]> git.uio.no Git - u/mrichter/AliRoot.git/blame - DPMJET/dpmjet3.0-4.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Add the number of local boards
[u/mrichter/AliRoot.git] / DPMJET / dpmjet3.0-4.f
CommitLineData
d30b8254 1*
2* +-------------------------------------------------------------+
3* | |
4* | |
5* | DPMJET 3.0 |
6* | |
7* | |
8* | S. Roesler+), R. Engel#), J. Ranft*) |
9* | |
10* | +) CERN, TIS-RP |
11* | CH-1211 Geneva 23, Switzerland |
12* | Email: Stefan.Roesler@cern.ch |
13* | |
14* | #) University of Delaware, BRI |
15* | Newark, DE 19716, USA |
16* | |
17* | *) University of Siegen, Dept. of Physics |
18* | D-57068 Siegen, Germany |
19* | |
20* | |
21* | http://home.cern.ch/sroesler/dpmjet3.html |
22* | |
23* | |
24* | Monte Carlo models used for event generation: |
25* | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 |
26* | |
27* +-------------------------------------------------------------+
28*
29*
30*===init===============================================================*
31*
32CDECK ID>, DT_INIT
33 SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
34 & IDP,IGLAU)
35
36************************************************************************
37* Initialization of event generation *
38* This version dated 7.4.98 is written by S. Roesler. *
39************************************************************************
40
41 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
42 SAVE
43
44 PARAMETER ( LINP = 5 ,
45 & LOUT = 6 ,
46 & LDAT = 9 )
47
48 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
49
50* particle properties (BAMJET index convention)
51 CHARACTER*8 ANAME
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
55 CHARACTER*8 BTYPE
56 COMMON /DTPAIN/ BTYPE(30)
57
ba758f5a 58 INCLUDE '(DIMPAR)'
59 INCLUDE '(PAREVT)'
60 INCLUDE '(EVAPAR)'
61 INCLUDE '(FRBKCM)'
d30b8254 62
63 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
64
65* emulsion treatment
66 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
67 & NCOMPO,IEMUL
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),
72 & NSITEB,NSTATB
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
89 LOGICAL LPAULI
90 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
91* various options for treatment of partons (DTUNUC 1.x)
92* (chain recombination, Cronin,..)
93 LOGICAL LCO2CR,LINTPT
94 COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
95 & LCO2CR,LINTPT
96* threshold values for x-sampling (DTUNUC 1.x)
97 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
98 & SSMIMQ,VVMTHR
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
103* nuclear potential
104 LOGICAL LFERMI
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
118 CHARACTER*8 CMODEL
119 LOGICAL LPHOIN
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
138 LOGICAL LPROD
139 CHARACTER*8 CGLB
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
145
146 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
147
148 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
149
150* LEPTO
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
155* LEPTO
156 REAL RPPN
157 COMMON /LEPTOI/ RPPN,LEPIN,INTER
158* steering flags for qel neutrino scattering modules
159 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
160* event flag
161 COMMON /DTEVNO/ NEVENT,ICASCA
162
163 INTEGER PYCOMP
164
165C DIMENSION XPARA(5)
166 DIMENSION XDUMB(40),IPRANG(5)
167
168 PARAMETER (MXCARD=58)
169 CHARACTER*78 CLINE,CTITLE
170 CHARACTER*60 CWHAT
171 CHARACTER*8 BLANK,SDUM
172 CHARACTER*10 CODE,CODEWD
173 CHARACTER*72 HEADER
174 LOGICAL LSTART,LEINP,LXSTAB
175 DIMENSION WHAT(6),CODE(MXCARD)
176 DATA CODE/
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',
191 & 'START ','STOP '/
192 DATA BLANK /' '/
193
194 DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
195 DATA CMEOLD /0.0D0/
196
197* --- Added by Chiara
198
199 CHARACTER*100 ALIROOT
200 CHARACTER*100 FILNAM
201 INTEGER*4 LNROOT
202 LOGICAL EXISTS
203 ALIROOT=' '
204
205*---------------------------------------------------------------------
206* at the first call of INIT: initialize event generation
207 EPNSAV = EPN
208 IF (LSTART) THEN
209 CALL DT_TITLE
210* initialization and test of the random number generator
211 IF (ITRSPT.NE.1) THEN
212
213 CALL FL48UT (ISRM48,ISEED1,ISEED2)
214 CALL FL48IN (54217137,ISEED1,ISEED2)
215
216 ENDIF
217* initialization of BAMJET, DECAY and HADRIN
218 CALL DT_DDATAR
219 CALL DT_DHADDE
220 CALL DT_DCHANT
221 CALL DT_DCHANH
222* set default values for input variables
223 CALL DT_DEFAUL(EPN,PPN)
224 IGLAU = 0
225 IXSQEL = 0
226* flag for collision energy input
227 LEINP = .FALSE.
228 LSTART = .FALSE.
229 ENDIF
230
231*---------------------------------------------------------------------
232 10 CONTINUE
233
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
237 IP = NPMASS
238 IPZ = NPCHAR
239 PPN = EPNSAV
240 EPN = ZERO
241 CMENER = ZERO
242 LEINP = .TRUE.
243 MKCRON = 0
244 WHAT(1) = 1
245 WHAT(2) = 0
246 CODEWD = 'START '
247 GOTO 900
248 ENDIF
249
250* read control card from input-unit LINP
251C READ(LINP,'(A78)',END=9999) CLINE
252* ### Read control card from specified file
253* ### Changed by Chiara (original version LINP=5)
254* OPEN(UNIT=7,
255* + FILE='/home/oppedisa/AliRoot/new/DPMJET/inp/PbPbLHC.inp',
256* + STATUS='OLD')
257
258 CALL GETENVF('ALICE_ROOT',ALIROOT)
259 LNROOT = LNBLNK(ALIROOT)
260
ba758f5a 261 FILNAM=ALIROOT(1:LNROOT)//'/DPMJET/inp/ppLHC.inp'
d30b8254 262 OPEN(UNIT=7,FILE=FILNAM,STATUS='OLD')
ba758f5a 263 OPEN(UNIT=14,FILE="nuclear.bin",STATUS='OLD')
264* OPEN(UNIT=6,FILE="dpm.out",STATUS='UNKNOWN')
d30b8254 265
266 READ(7,'(A78)',END=9999) CLINE
267
268 IF (CLINE(1:1).EQ.'*') THEN
269* comment-line
270C WRITE(LOUT,'(A78)') CLINE
271 GOTO 10
272 ENDIF
273C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
274C1000 FORMAT(A10,6E10.0,A8)
275 DO 1008 I=1,6
276 WHAT(I) = ZERO
277 1008 CONTINUE
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)
281 1007 CONTINUE
282 WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
283 1001 FORMAT(A10,6G10.3,A8)
284
285 900 CONTINUE
286
287* check for valid control card and get card index
288 ICW = 0
289 DO 11 I=1,MXCARD
290 IF (CODEWD.EQ.CODE(I)) ICW = I
291 11 CONTINUE
292 IF (ICW.EQ.0) THEN
293 WRITE(LOUT,1002) CODEWD
294 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
295 GOTO 10
296 ENDIF
d30b8254 297 GOTO(
298*------------------------------------------------------------
299* TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
300 & 100 , 110 , 120 , 130 , 140 ,
301*
302*------------------------------------------------------------
303* CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
304 & 150 , 160 , 170 , 180 , 190 ,
305*
306*------------------------------------------------------------
307* COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
308 & 200 , 210 , 220 , 230 , 240 ,
309*
310*------------------------------------------------------------
311* PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
312 & 250 , 260 , 270 , 280 , 290 ,
313*
314*------------------------------------------------------------
315* COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
316 & 300 , 310 , 320 , 330 , 340 ,
317*
318*------------------------------------------------------------
319* SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
320 & 350 , 360 , 370 , 380 , 390 ,
321*
322*------------------------------------------------------------
323* NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
324 & 400 , 410 , 420 , 430 , 440 ,
325*
326*------------------------------------------------------------
327* LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
328 & 450 , 451 , 452 , 460 , 470 ,
329*
330*------------------------------------------------------------
331* OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
332 & 480 , 490 , 500 , 510 , 520 ,
333*
334*------------------------------------------------------------
335* VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
336 & 530 , 540 , 550 , 560 , 565 ,
337*
338*------------------------------------------------------------
339* , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
340 & 570 , 580 , 590 ,
341*
342*------------------------------------------------------------
343* LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
344 & 600 , 610 , 620 , 630 , 640 ) , ICW
345*
346*------------------------------------------------------------
347
348 GOTO 10
349
350*********************************************************************
351* *
352* control card: codewd = TITLE *
353* *
354* what (1..6), sdum no meaning *
355* *
356* Note: The control-card following this must consist of *
357* a string of characters usually giving the title of *
358* the run. *
359* *
360*********************************************************************
361
362 100 CONTINUE
363C READ(LINP,'(A78)') CTITLE
364* ### Read control card from specified file
365* ### Changed by Chiara (original version LINP=5)
366 READ(7,'(A78)') CTITLE
367
368 WRITE(LOUT,'(//,5X,A78,//)') CTITLE
369 GOTO 10
370
371*********************************************************************
372* *
373* control card: codewd = PROJPAR *
374* *
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 *
379* *
380* Note: If sdum is defined what (1..2) have no meaning. *
381* *
382*********************************************************************
383
384 110 CONTINUE
385 IF (SDUM.EQ.BLANK) THEN
386 IP = INT(WHAT(1))
387 IPZ = INT(WHAT(2))
388 IJPROJ = 1
389 IBPROJ = 1
390 ELSE
391 IJPROJ = 0
392 DO 111 II=1,30
393 IF (SDUM.EQ.BTYPE(II)) THEN
394 IP = 1
395 IPZ = 1
396 IF (II.EQ.26) THEN
397 IJPROJ = 135
398 ELSEIF (II.EQ.27) THEN
399 IJPROJ = 136
400 ELSEIF (II.EQ.28) THEN
401 IJPROJ = 133
402 ELSEIF (II.EQ.29) THEN
403 IJPROJ = 134
404 ELSE
405 IJPROJ = II
406 ENDIF
407 IBPROJ = IIBAR(IJPROJ)
408* photon
409 IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
410* lepton
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)
414 ENDIF
415 111 CONTINUE
416 IF (IJPROJ.EQ.0) THEN
417 WRITE(LOUT,1110)
418 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
419 GOTO 9999
420 ENDIF
421 ENDIF
422 GOTO 10
423
424*********************************************************************
425* *
426* control card: codewd = TARPAR *
427* *
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 *
432* *
433* Note: If sdum is defined what (1..2) have no meaning. *
434* *
435*********************************************************************
436
437 120 CONTINUE
438 IF (SDUM.EQ.BLANK) THEN
439 IT = INT(WHAT(1))
440 ITZ = INT(WHAT(2))
441 IJTARG = 1
442 IBTARG = 1
443 ELSE
444 IJTARG = 0
445 DO 121 II=1,30
446 IF (SDUM.EQ.BTYPE(II)) THEN
447 IT = 1
448 ITZ = 1
449 IJTARG = II
450 IBTARG = IIBAR(IJTARG)
451 ENDIF
452 121 CONTINUE
453 IF (IJTARG.EQ.0) THEN
454 WRITE(LOUT,1120)
455 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
456 GOTO 9999
457 ENDIF
458 ENDIF
459 GOTO 10
460
461*********************************************************************
462* *
463* control card: codewd = ENERGY *
464* *
465* what (1) = energy (GeV) of projectile in Lab. *
466* if what(1) < 0: |what(1)| = kinetic energy *
467* default: 200 GeV *
468* if |what(2)| > 0: min. energy for variable *
469* energy runs *
470* what (2) = max. energy for variable energy runs *
471* if what(2) < 0: |what(2)| = kinetic energy *
472* *
473*********************************************************************
474
475 130 CONTINUE
476 EPN = WHAT(1)
477 PPN = ZERO
478 CMENER = ZERO
479 IF ((ABS(WHAT(2)).GT.ZERO).AND.
480 & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
481 VARELO = WHAT(1)
482 VAREHI = WHAT(2)
483 EPN = VAREHI
484 ENDIF
485 LEINP = .TRUE.
486 GOTO 10
487
488*********************************************************************
489* *
490* control card: codewd = MOMENTUM *
491* *
492* what (1) = momentum (GeV/c) of projectile in Lab. *
493* default: 200 GeV/c *
494* what (2..6), sdum no meaning *
495* *
496*********************************************************************
497
498 140 CONTINUE
499 EPN = ZERO
500 PPN = WHAT(1)
501 CMENER = ZERO
502 LEINP = .TRUE.
503 GOTO 10
504
505*********************************************************************
506* *
507* control card: codewd = CMENERGY *
508* *
509* what (1) = energy in nucleon-nucleon cms. *
510* default: none *
511* what (2..6), sdum no meaning *
512* *
513*********************************************************************
514
515 150 CONTINUE
516 EPN = ZERO
517 PPN = ZERO
518 CMENER = WHAT(1)
519 LEINP = .TRUE.
520 GOTO 10
521
522*********************************************************************
523* *
524* control card: codewd = EMULSION *
525* *
526* definition of nuclear emulsions *
527* *
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 *
534* sdum no meaning *
535* *
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. *
542* *
543*********************************************************************
544
545 160 CONTINUE
546 IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
547 & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
548 NCOMPO = NCOMPO+1
549 IF (NCOMPO.GT.NCOMPX) THEN
550 WRITE(LOUT,1600)
551 STOP
552 ENDIF
553 IEMUMA(NCOMPO) = INT(WHAT(1))
554 IEMUCH(NCOMPO) = INT(WHAT(2))
555 EMUFRA(NCOMPO) = WHAT(3)
556 IEMUL = 1
557C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
558 ENDIF
559 IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
560 & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
561 NCOMPO = NCOMPO+1
562 IF (NCOMPO.GT.NCOMPX) THEN
563 WRITE(LOUT,1001)
564 STOP
565 ENDIF
566 IEMUMA(NCOMPO) = INT(WHAT(4))
567 IEMUCH(NCOMPO) = INT(WHAT(5))
568 EMUFRA(NCOMPO) = WHAT(6)
569C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
570 ENDIF
571 1600 FORMAT(1X,'too many emulsion components - program stopped')
572 GOTO 10
573
574*********************************************************************
575* *
576* control card: codewd = FERMI *
577* *
578* what (1) = -1 Fermi-motion of nucleons not treated *
579* default: 1 *
580* what (2) = scale factor for Fermi-momentum *
581* default: 0.75 *
582* what (3..6), sdum no meaning *
583* *
584*********************************************************************
585
586 170 CONTINUE
587 IF (WHAT(1).EQ.-1.0D0) THEN
588 LFERMI = .FALSE.
589 ELSE
590 LFERMI = .TRUE.
591 ENDIF
592 XMOD = WHAT(2)
593 IF (XMOD.GE.ZERO) FERMOD = XMOD
594 GOTO 10
595
596*********************************************************************
597* *
598* control card: codewd = TAUFOR *
599* *
600* formation time supressed intranuclear cascade *
601* *
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 *
605* default: 5. fm/c *
606* what (2) number of generations followed *
607* default: 25 *
608* what (3) = 1. p_t-dependent formation zone *
609* = 2. constant formation zone *
610* default: 1 *
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 *
617* default: 1 *
618* what (5..6), sdum no meaning *
619* *
620*********************************************************************
621
622 180 CONTINUE
623 TAUFOR = WHAT(1)
624 KTAUGE = INT(WHAT(2))
625 INCMOD = 1
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))
630 GOTO 10
631
632*********************************************************************
633* *
634* control card: codewd = PAULI *
635* *
636* what (1) = -1 Pauli's principle for secondary *
637* interactions not treated *
638* default: 1 *
639* what (2..6), sdum no meaning *
640* *
641*********************************************************************
642
643 190 CONTINUE
644 IF (WHAT(1).EQ.-1.0D0) THEN
645 LPAULI = .FALSE.
646 ELSE
647 LPAULI = .TRUE.
648 ENDIF
649 GOTO 10
650
651*********************************************************************
652* *
653* control card: codewd = COULOMB *
654* *
655* what (1) = -1. Coulomb-energy treatment switched off *
656* default: 1 *
657* what (2..6), sdum no meaning *
658* *
659*********************************************************************
660
661 200 CONTINUE
662 ICOUL = 1
663 IF (WHAT(1).EQ.-1.0D0) THEN
664 ICOUL = 0
665 ELSE
666 ICOUL = 1
667 ENDIF
668 GOTO 10
669
670*********************************************************************
671* *
672* control card: codewd = HADRIN *
673* *
674* HADRIN module *
675* *
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 *
680* default: 1 *
681* what (2) upper threshold in total energy (GeV) below *
682* which interactions are sampled by HADRIN *
683* default: 5. GeV *
684* what (3..6), sdum no meaning *
685* *
686*********************************************************************
687
688 210 CONTINUE
689 IWHAT = INT(WHAT(1))
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)
692 GOTO 10
693
694*********************************************************************
695* *
696* control card: codewd = EVAP *
697* *
698* evaporation module *
699* *
700* what (1) =< -1 ==> evaporation is switched off *
701* >= 1 ==> evaporation is performed *
702* *
703* what (1) = i1 + i2*10 + i3*100 + i4*10000 *
704* (i1, i2, i3, i4 >= 0 ) *
705* *
706* i1 is the flag for selecting the T=0 level density option used *
707* = 1: standard EVAP level densities with Cook pairing *
708* energies *
709* = 2: Z,N-dependent Gilbert & Cameron level densities *
710* (default) *
711* = 3: Julich A-dependent level densities *
712* = 4: Z,N-dependent Brancazio & Cameron level densities *
713* *
714* i2 >= 1: high energy fission activated *
715* (default high energy fission activated) *
716* *
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 *
728* parameters *
729* = 6: Second Ignyatuk (1975, 2nd) energy dependence *
730* for level densities with fit 2 Iljinov & Mebel set of *
731* parameters *
732* = 7: Second Ignyatuk (1975, 2nd) energy dependence *
733* for level densities with fit 3 Iljinov & Mebel set of *
734* parameters *
735* = 8: Second Ignyatuk (1975, 2nd) energy dependence *
736* for level densities with fit 4 Iljinov & Mebel set of *
737* parameters *
738* *
739* i4 >= 1: Original Gilbert and Cameron pairing energies used *
740* (default Cook's modified pairing energies) *
741* *
742* what (2) = ig + 10 * if (ig and if must have the same sign) *
743* *
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 *
754* *
755*********************************************************************
756
757 220 CONTINUE
758
759 IF (WHAT(1).LE.-1.0D0) THEN
760 LEVPRT = .FALSE.
761 LDEEXG = .FALSE.
762 LHEAVY = .FALSE.
763 GOTO 10
764 ENDIF
765 WHTSAV = WHAT (1)
766 IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
767 LLVMOD = .FALSE.
768 JLVHLP = NINT (WHAT (1)) / 10000
769 WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
770 END IF
771 IF ( NINT (WHAT (1)) .GE. 100 ) THEN
772 JLVMOD = NINT (WHAT (1)) / 100
773 WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
774 END IF
775 IF ( NINT (WHAT (1)) .GE. 10 ) THEN
776 IFISS = 1
777 JLVHLP = NINT (WHAT (1)) / 10
778 WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
779 ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
780 IFISS = 0
781 END IF
782 IF ( NINT (WHAT (1)) .GE. 0 ) THEN
783 LEVPRT = .TRUE.
784 ILVMOD = NINT (WHAT(1))
785 IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN
786 LFRMBK = .TRUE.
787 JLVHLP = NINT (WHAT (2)) / 10
788 WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
789 ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
790 LFRMBK = .FALSE.
791 END IF
792 IF ( NINT (WHAT (2)) .GE. 0 ) THEN
793 LDEEXG = .TRUE.
794 ELSE
795 LDEEXG = .FALSE.
796 END IF
797**sr heavies are always put to /FKFHVY/
798C IF ( NINT (WHAT(3)) .GE. 1 ) THEN
799C LHEAVY = .TRUE.
800C ELSE
801C LHEAVY = .FALSE.
802C END IF
803 LHEAVY = .TRUE.
804 ELSE
805 LEVPRT = .FALSE.
806 LDEEXG = .FALSE.
807 LHEAVY = .FALSE.
808 END IF
809
810 LOLDEV = .FALSE.
811
812 GOTO 10
813
814*********************************************************************
815* *
816* control card: codewd = EMCCHECK *
817* *
818* extended energy-momentum / quantum-number conservation check *
819* *
820* what (1) = -1 extended check not performed *
821* default: 1. *
822* what (2..6), sdum no meaning *
823* *
824*********************************************************************
825
826 230 CONTINUE
827 IF (WHAT(1).EQ.-1) THEN
828 LEMCCK = .FALSE.
829 ELSE
830 LEMCCK = .TRUE.
831 ENDIF
832 GOTO 10
833
834*********************************************************************
835* *
836* control card: codewd = MODEL *
837* *
838* Model to be used to treat nucleon-nucleon interactions *
839* *
840* sdum = DTUNUC two-chain model *
841* = PHOJET multiple chains including minijets *
842* = LEPTO DIS *
843* = QNEUTRIN quasi-elastic neutrino scattering *
844* default: PHOJET *
845* *
846* if sdum = LEPTO: *
847* what (1) (variable INTER) *
848* = 1 gamma exchange *
849* = 2 W+- exchange *
850* = 3 Z0 exchange *
851* = 4 gamma/Z0 exchange *
852* *
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 *
860* *
861* what (2..6) no meaning *
862* *
863*********************************************************************
864
865 240 CONTINUE
866 IF (SDUM.EQ.CMODEL(1)) THEN
867 MCGENE = 1
868 ELSEIF (SDUM.EQ.CMODEL(2)) THEN
869 MCGENE = 2
870 ELSEIF (SDUM.EQ.CMODEL(3)) THEN
871 MCGENE = 3
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
875 MCGENE = 4
876 IWHAT = INT(WHAT(1))
877 IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
878 & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
879 & NEUDEC = IWHAT
880 ELSE
881 STOP ' Unknown model !'
882 ENDIF
883 GOTO 10
884
885*********************************************************************
886* *
887* control card: codewd = PHOINPUT *
888* *
889* Start of input-section for PHOJET-specific input-cards *
890* Note: This section will not be finished before giving *
891* ENDINPUT-card *
892* what (1..6), sdum no meaning *
893* *
894*********************************************************************
895
896 250 CONTINUE
897 IF (LPHOIN) THEN
898
899C 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)
903
904 IF (IREJ1.NE.0) THEN
905 WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
906 STOP
907 ENDIF
908 LPHOIN = .FALSE.
909 ENDIF
910 GOTO 10
911
912*********************************************************************
913* *
914* control card: codewd = GLAUBERI *
915* *
916* Pre-initialization of impact parameter selection *
917* *
918* what (1..6), sdum no meaning *
919* *
920*********************************************************************
921
922 260 CONTINUE
923 IF (IFIRST.NE.99) THEN
924 CALL DT_RNDMST(12,34,56,78)
925 CALL DT_RNDMTE(1)
926 OPEN(40,FILE='shm.out',STATUS='UNKNOWN')
927C OPEN(11,FILE='shm.dbg',STATUS='UNKNOWN')
928 IFIRST = 99
929 ENDIF
930
931 IPPN = 8
932 PLOW = 10.0D0
933C IPPN = 1
934C PLOW = 100.0D0
935 PHI = 1.0D5
936 APLOW = LOG10(PLOW)
937 APHI = LOG10(PHI)
938 ADP = (APHI-APLOW)/DBLE(IPPN)
939
940 IPLOW = 1
941 IDIP = 1
942 IIP = 5
943C IPLOW = 1
944C IDIP = 1
945C IIP = 1
946 IPRANG(1) = 1
947 IPRANG(2) = 2
948 IPRANG(3) = 5
949 IPRANG(4) = 10
950 IPRANG(5) = 20
951
952 ITLOW = 30
953 IDIT = 3
954 IIT = 60
955C IDIT = 10
956C IIT = 21
957
958 DO 473 NCIT=1,IIT
959 IT = ITLOW+(NCIT-1)*IDIT
960C IPHI = IT
961C IDIP = 10
962C IIP = (IPHI-IPLOW)/IDIP
963C IF (IIP.EQ.0) IIP = 1
964C IF (IT.EQ.IPLOW) IIP = 0
965
966 DO 472 NCIP=1,IIP
967 IP = IPRANG(NCIP)
968CC IF (NCIP.LE.IIP) THEN
969C IP = IPLOW+(NCIP-1)*IDIP
970CC ELSE
971CC IP = IT
972CC ENDIF
973 IF (IP.GT.IT) GOTO 472
974
975 DO 471 NCP=1,IPPN+1
976 APPN = APLOW+DBLE(NCP-1)*ADP
977 PPN = 10**APPN
978
979 OPEN(12,FILE='shm.sta',STATUS='UNKNOWN')
980 WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
981 CLOSE(12)
982
983 XLIM1 = 0.0D0
984 XLIM2 = 50.0D0
985 XLIM3 = ZERO
986 IBIN = 50
987 CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
988 CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
989
990 NEVFIT = 5
991C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
992C NEVFIT = 5
993C ELSE
994C NEVFIT = 10
995C ENDIF
996 SIGAV = 0.0D0
997
998 DO 478 I=1,NEVFIT
999 CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
1000 SIGAV = SIGAV+XSPRO(1,1,1)
1001 DO 479 J=1,50
1002 XC = DBLE(J)
1003 CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
1004 479 CONTINUE
1005 478 CONTINUE
1006
1007 CALL DT_EVTHIS(IDUM)
1008 HEADER = ' BSITE'
1009C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
1010
1011C CALL GENFIT(XPARA)
1012C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
1013C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
1014
1015 471 CONTINUE
1016
1017 472 CONTINUE
1018
1019 473 CONTINUE
1020
1021 STOP
1022
1023*********************************************************************
1024* *
1025* control card: codewd = FLUCTUAT *
1026* *
1027* Treatment of cross section fluctuations *
1028* *
1029* what (1) = 1 treat cross section fluctuations *
1030* default: 0. *
1031* what (1..6), sdum no meaning *
1032* *
1033*********************************************************************
1034
1035 270 CONTINUE
1036 IFLUCT = 0
1037 IF (WHAT(1).EQ.ONE) THEN
1038 IFLUCT = 1
1039 CALL DT_FLUINI
1040 ENDIF
1041 GOTO 10
1042
1043*********************************************************************
1044* *
1045* control card: codewd = CENTRAL *
1046* *
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 *
1055* *
1056* what (4..6), sdum no meaning *
1057* *
1058*********************************************************************
1059
1060 280 CONTINUE
1061 ICENTR = INT(WHAT(1))
1062 IF (ICENTR.LT.0) THEN
1063 IF (ICENTR.GT.-100) THEN
1064 BIMIN = WHAT(2)
1065 BIMAX = WHAT(3)
1066 ELSE
1067 XSFRAC = WHAT(2)
1068 ENDIF
1069 ENDIF
1070 GOTO 10
1071
1072*********************************************************************
1073* *
1074* control card: codewd = RECOMBIN *
1075* *
1076* Chain recombination *
1077* (recombine S-S and V-V chains to V-S chains) *
1078* *
1079* what (1) = -1. recombination switched off default: 1 *
1080* what (2..6), sdum no meaning *
1081* *
1082*********************************************************************
1083
1084 290 CONTINUE
1085 IRECOM = 1
1086 IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1087 GOTO 10
1088
1089*********************************************************************
1090* *
1091* control card: codewd = COMBIJET *
1092* *
1093* chain fusion (2 q-aq --> qq-aqaq) *
1094* *
1095* what (1) = 1 fusion treated *
1096* default: 0. *
1097* what (2) minimum number of uncombined chains from *
1098* single projectile or target nucleons *
1099* default: 0. *
1100* what (3..6), sdum no meaning *
1101* *
1102*********************************************************************
1103
1104 300 CONTINUE
1105 LCO2CR = .FALSE.
1106 IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1107 IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1108 GOTO 10
1109
1110*********************************************************************
1111* *
1112* control card: codewd = XCUTS *
1113* *
1114* thresholds for x-sampling *
1115* *
1116* what (1) defines lower threshold for val.-q x-value (CVQ) *
1117* default: 1. *
1118* what (2) defines lower threshold for val.-qq x-value (CDQ) *
1119* default: 2. *
1120* what (3) defines lower threshold for sea-q x-value (CSEA) *
1121* default: 0.2 *
1122* what (4) sea-q x-values in S-S chains (SSMIMA) *
1123* default: 0.14 *
1124* what (5) not used *
1125* default: 2. *
1126* what (6), sdum no meaning *
1127* *
1128* Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1129* *
1130*********************************************************************
1131
1132 310 CONTINUE
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
1137 SSMIMA = WHAT(4)
1138 SSMIMQ = SSMIMA**2
1139 ENDIF
1140 IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1141 GOTO 10
1142
1143*********************************************************************
1144* *
1145* control card: codewd = INTPT *
1146* *
1147* what (1) = -1 intrinsic transverse momenta of partons *
1148* not treated default: 1 *
1149* what (2..6), sdum no meaning *
1150* *
1151*********************************************************************
1152
1153 320 CONTINUE
1154 IF (WHAT(1).EQ.-1.0D0) THEN
1155 LINTPT = .FALSE.
1156 ELSE
1157 LINTPT = .TRUE.
1158 ENDIF
1159 GOTO 10
1160
1161*********************************************************************
1162* *
1163* control card: codewd = CRONINPT *
1164* *
1165* Cronin effect (multiple scattering of partons at chain ends) *
1166* *
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 *
1170* *
1171*********************************************************************
1172
1173 330 CONTINUE
1174 IF (WHAT(1).EQ.-1.0D0) THEN
1175 MKCRON = 0
1176 ELSE
1177 MKCRON = 1
1178 ENDIF
1179 CRONCO = WHAT(2)
1180 GOTO 10
1181
1182*********************************************************************
1183* *
1184* control card: codewd = SEADISTR *
1185* *
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 *
1192* *
1193*********************************************************************
1194
1195 340 CONTINUE
1196 XSEACO = WHAT(1)
1197 XSEACU = 1.05D0-XSEACO
1198 UNON = WHAT(2)
1199 IF (UNON.LT.0.1D0) UNON = 2.0D0
1200 UNOM = WHAT(3)
1201 IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1202 UNOSEA = WHAT(4)
1203 IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1204 GOTO 10
1205
1206*********************************************************************
1207* *
1208* control card: codewd = SEASU3 *
1209* *
1210* Treatment of strange-quarks at chain ends *
1211* *
1212* what (1) (SEASQ) strange-quark supression factor *
1213* iflav = 1.+rndm*(2.+SEASQ) *
1214* default: 1. *
1215* what (2..6), sdum no meaning *
1216* *
1217*********************************************************************
1218
1219 350 CONTINUE
1220 SEASQ = WHAT(1)
1221 GOTO 10
1222
1223*********************************************************************
1224* *
1225* control card: codewd = DIQUARKS *
1226* *
1227* what (1) = -1. sea-diquark/antidiquark-pairs not treated *
1228* default: 1. *
1229* what (2..6), sdum no meaning *
1230* *
1231*********************************************************************
1232
1233 360 CONTINUE
1234 IF (WHAT(1).EQ.-1.0D0) THEN
1235 LSEADI = .FALSE.
1236 ELSE
1237 LSEADI = .TRUE.
1238 ENDIF
1239 GOTO 10
1240
1241*********************************************************************
1242* *
1243* control card: codewd = RESONANC *
1244* *
1245* treatment of low mass chains *
1246* *
1247* what (1) = -1 low chain masses are not corrected for resonance *
1248* masses (obsolete for BAMJET-fragmentation) *
1249* default: 1. *
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 *
1256* *
1257*********************************************************************
1258
1259 370 CONTINUE
1260 IRESCO = 1
1261 IMSHL = 1
1262 IRESRJ = 0
1263 IF (WHAT(1).EQ.-ONE) IRESCO = 0
1264 IF (WHAT(2).EQ.-ONE) IMSHL = 0
1265 IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1266 GOTO 10
1267
1268*********************************************************************
1269* *
1270* control card: codewd = DIFFRACT *
1271* *
1272* Treatment of diffractive events *
1273* *
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) *
1281* default: 0. *
1282* *
1283* what (2) = (IDOUBD) 0 no double diffraction *
1284* 1 double diffraction included *
1285* 2 double diffractive events only *
1286* default: 0. *
1287* what (3) = 1 projectile diffraction treated (2-channel form.) *
1288* default: 0. *
1289* what (4) = alpha-parameter in projectile diffraction *
1290* default: 0. *
1291* what (5..6), sdum no meaning *
1292* *
1293*********************************************************************
1294
1295 380 CONTINUE
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
1299 WRITE(LOUT,1380)
1300 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
1301 & 11X,'IDOUBD is reset to zero')
1302 IDOUBD = 0
1303 ENDIF
1304 IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1305 IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1306 GOTO 10
1307
1308*********************************************************************
1309* *
1310* control card: codewd = SINGLECH *
1311* *
1312* what (1) = 1. Regge contribution (one chain) included *
1313* default: 0. *
1314* what (2..6), sdum no meaning *
1315* *
1316*********************************************************************
1317
1318 390 CONTINUE
1319 ISICHA = 0
1320 IF (WHAT(1).EQ.ONE) ISICHA = 1
1321 GOTO 10
1322
1323*********************************************************************
1324* *
1325* control card: codewd = NOFRAGME *
1326* *
1327* biased chain hadronization *
1328* *
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 *
1339* sdum no meaning *
1340* *
1341*********************************************************************
1342
1343 400 CONTINUE
1344 DO 401 I=1,6
1345 ICHAIN = INT(WHAT(I))
1346 IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1347 & LHADRO(ABS(ICHAIN)) = .FALSE.
1348 401 CONTINUE
1349 GOTO 10
1350
1351*********************************************************************
1352* *
1353* control card: codewd = HADRONIZE *
1354* *
1355* hadronization model and parameter switch *
1356* *
1357* what (1) = 1 hadronization via BAMJET *
1358* = 2 hadronization via JETSET *
1359* default: 2 *
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 *
1364* default: 1 *
1365* what (3..6), sdum no meaning *
1366* *
1367*********************************************************************
1368
1369 410 CONTINUE
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))
1374 & IFRAG(2) = IWHAT2
1375 GOTO 10
1376
1377*********************************************************************
1378* *
1379* control card: codewd = POPCORN *
1380* *
1381* "Popcorn-effect" in fragmentation and diquark breaking diagrams *
1382* *
1383* what (1) = (PDB) frac. of diquark fragmenting directly into *
1384* baryons (PYTHIA/JETSET fragmentation) *
1385* (JETSET: = 0. Popcorn mechanism switched off) *
1386* default: 0.5 *
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 *
1391* default: 0.0 *
1392* what (4..6), sdum no meaning *
1393* *
1394*********************************************************************
1395
1396 420 CONTINUE
1397 IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1398 IF (WHAT(2).GE.0.0D0) THEN
1399 PDBSEA(1) = WHAT(2)
1400 PDBSEA(2) = WHAT(2)
1401 ENDIF
1402 IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1403 DO 421 I=1,8
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))
1407 421 CONTINUE
1408 GOTO 10
1409
1410*********************************************************************
1411* *
1412* control card: codewd = PARDECAY *
1413* *
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 *
1418* *
1419*********************************************************************
1420
1421 430 CONTINUE
1422 IF (WHAT(1).EQ.ONE) ISIG0 = 1
1423 IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1424 GOTO 10
1425
1426*********************************************************************
1427* *
1428* control card: codewd = BEAM *
1429* *
1430* definition of beam parameters *
1431* *
1432* what (1/2) > 0 : energy of beam 1/2 (GeV) *
1433* < 0 : abs(what(1/2)) energy per charge of *
1434* beam 1/2 (GeV) *
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 *
1440* *
1441* Note: this card requires previously defined projectile and *
1442* target identities (PROJPAR, TARPAR) *
1443* *
1444*********************************************************************
1445
1446 440 CONTINUE
1447 CALL DT_BEAMPR(WHAT,PPN,1)
1448 EPN = ZERO
1449 CMENER = ZERO
1450 LEINP = .TRUE.
1451 GOTO 10
1452
1453*********************************************************************
1454* *
1455* control card: codewd = LUND-MSTU *
1456* *
1457* set parameter MSTU in JETSET-common /LUDAT1/ *
1458* *
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 *
1463* what (2) *
1464* default: default-Lund or corresponding to *
1465* the set given in HADRONIZE *
1466* *
1467*********************************************************************
1468
1469 450 CONTINUE
1470 IF (WHAT(1).GT.ZERO) THEN
1471 NMSTU = NMSTU+1
1472 IMSTU(NMSTU) = INT(WHAT(1))
1473 MSTUX(NMSTU) = INT(WHAT(2))
1474 ENDIF
1475 IF (WHAT(3).GT.ZERO) THEN
1476 NMSTU = NMSTU+1
1477 IMSTU(NMSTU) = INT(WHAT(3))
1478 MSTUX(NMSTU) = INT(WHAT(4))
1479 ENDIF
1480 IF (WHAT(5).GT.ZERO) THEN
1481 NMSTU = NMSTU+1
1482 IMSTU(NMSTU) = INT(WHAT(5))
1483 MSTUX(NMSTU) = INT(WHAT(6))
1484 ENDIF
1485 GOTO 10
1486
1487*********************************************************************
1488* *
1489* control card: codewd = LUND-MSTJ *
1490* *
1491* set parameter MSTJ in JETSET-common /LUDAT1/ *
1492* *
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 *
1497* what (2) *
1498* default: default-Lund or corresponding to *
1499* the set given in HADRONIZE *
1500* *
1501*********************************************************************
1502
1503 451 CONTINUE
1504 IF (WHAT(1).GT.ZERO) THEN
1505 NMSTJ = NMSTJ+1
1506 IMSTJ(NMSTJ) = INT(WHAT(1))
1507 MSTJX(NMSTJ) = INT(WHAT(2))
1508 ENDIF
1509 IF (WHAT(3).GT.ZERO) THEN
1510 NMSTJ = NMSTJ+1
1511 IMSTJ(NMSTJ) = INT(WHAT(3))
1512 MSTJX(NMSTJ) = INT(WHAT(4))
1513 ENDIF
1514 IF (WHAT(5).GT.ZERO) THEN
1515 NMSTJ = NMSTJ+1
1516 IMSTJ(NMSTJ) = INT(WHAT(5))
1517 MSTJX(NMSTJ) = INT(WHAT(6))
1518 ENDIF
1519 GOTO 10
1520
1521*********************************************************************
1522* *
1523* control card: codewd = LUND-MDCY *
1524* *
1525* set parameter MDCY(I,1) for particle decays in JETSET-common *
1526* /LUDAT3/ *
1527* *
1528* what (1-6) = PDG particle index of particle which should *
1529* not decay *
1530* default: default-Lund or forced in *
1531* DT_INITJS *
1532* *
1533*********************************************************************
1534
1535 452 CONTINUE
1536 DO 4521 I=1,6
1537 IF (WHAT(I).NE.ZERO) THEN
1538
1539 KC = PYCOMP(INT(WHAT(I)))
1540
1541 MDCY(KC,1) = 0
1542 ENDIF
1543 4521 CONTINUE
1544 GOTO 10
1545
1546*********************************************************************
1547* *
1548* control card: codewd = LUND-PARJ *
1549* *
1550* set parameter PARJ in JETSET-common /LUDAT1/ *
1551* *
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 *
1556* what (2) *
1557* default: default-Lund or corresponding to *
1558* the set given in HADRONIZE *
1559* *
1560*********************************************************************
1561
1562 460 CONTINUE
1563 IF (WHAT(1).NE.ZERO) THEN
1564 NPARJ = NPARJ+1
1565 IPARJ(NPARJ) = INT(WHAT(1))
1566 PARJX(NPARJ) = WHAT(2)
1567 ENDIF
1568 IF (WHAT(3).NE.ZERO) THEN
1569 NPARJ = NPARJ+1
1570 IPARJ(NPARJ) = INT(WHAT(3))
1571 PARJX(NPARJ) = WHAT(4)
1572 ENDIF
1573 IF (WHAT(5).NE.ZERO) THEN
1574 NPARJ = NPARJ+1
1575 IPARJ(NPARJ) = INT(WHAT(5))
1576 PARJX(NPARJ) = WHAT(6)
1577 ENDIF
1578 GOTO 10
1579
1580*********************************************************************
1581* *
1582* control card: codewd = LUND-PARU *
1583* *
1584* set parameter PARJ in JETSET-common /LUDAT1/ *
1585* *
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 *
1590* what (2) *
1591* default: default-Lund or corresponding to *
1592* the set given in HADRONIZE *
1593* *
1594*********************************************************************
1595
1596 470 CONTINUE
1597 IF (WHAT(1).GT.ZERO) THEN
1598 NPARU = NPARU+1
1599 IPARU(NPARU) = INT(WHAT(1))
1600 PARUX(NPARU) = WHAT(2)
1601 ENDIF
1602 IF (WHAT(3).GT.ZERO) THEN
1603 NPARU = NPARU+1
1604 IPARU(NPARU) = INT(WHAT(3))
1605 PARUX(NPARU) = WHAT(4)
1606 ENDIF
1607 IF (WHAT(5).GT.ZERO) THEN
1608 NPARU = NPARU+1
1609 IPARU(NPARU) = INT(WHAT(5))
1610 PARUX(NPARU) = WHAT(6)
1611 ENDIF
1612 GOTO 10
1613
1614*********************************************************************
1615* *
1616* control card: codewd = OUTLEVEL *
1617* *
1618* output control switches *
1619* *
1620* what (1) = internal rejection informations default: 0 *
1621* what (2) = energy-momentum conservation check output *
1622* default: 0 *
1623* what (3) = internal warning messages default: 0 *
1624* what (4..6), sdum not yet used *
1625* *
1626*********************************************************************
1627
1628 480 CONTINUE
1629 DO 481 K=1,6
1630 IOULEV(K) = INT(WHAT(K))
1631 481 CONTINUE
1632 GOTO 10
1633
1634*********************************************************************
1635* *
1636* control card: codewd = FRAME *
1637* *
1638* frame in which final state is given in DTEVT1 *
1639* *
1640* what (1) = 1 target rest frame (laboratory) *
1641* = 2 nucleon-nucleon cms *
1642* default: 1 *
1643* *
1644*********************************************************************
1645
1646 490 CONTINUE
1647 KFRAME = INT(WHAT(1))
1648 IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1649 GOTO 10
1650
1651*********************************************************************
1652* *
1653* control card: codewd = L-TAG *
1654* *
1655* lepton tagger: *
1656* definition of kinematical cuts for radiated photon and *
1657* outgoing lepton detection in lepton-nucleus interactions *
1658* *
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 *
1666* sdum no meaning *
1667* *
1668*********************************************************************
1669
1670 500 CONTINUE
1671 YMIN = WHAT(1)
1672 YMAX = WHAT(2)
1673 Q2MIN = WHAT(3)
1674 Q2MAX = WHAT(4)
1675 THMIN = WHAT(5)
1676 THMAX = WHAT(6)
1677 GOTO 10
1678
1679*********************************************************************
1680* *
1681* control card: codewd = L-ETAG *
1682* *
1683* lepton tagger: *
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 *
1689* *
1690*********************************************************************
1691
1692 510 CONTINUE
1693 ELMIN = MAX(WHAT(1),ZERO)
1694 EGMIN = MAX(WHAT(2),ZERO)
1695 EGMAX = MAX(WHAT(3),ZERO)
1696 GOTO 10
1697
1698*********************************************************************
1699* *
1700* control card: codewd = ECMS-CUT *
1701* *
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 *
1707* *
1708*********************************************************************
1709
1710 520 CONTINUE
1711 ECMIN = WHAT(1)
1712 ECMAX = WHAT(2)
1713 IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1714 XBJMIN = MAX(WHAT(3),ZERO)
1715 GOTO 10
1716
1717*********************************************************************
1718* *
1719* control card: codewd = VDM-PAR1 *
1720* *
1721* parameters in gamma-nucleus cross section calculation *
1722* *
1723* what (1) = Lambda^2 default: 2. *
1724* what (2) lower limit in M^2 integration *
1725* = 1 (3m_pi)^2 *
1726* = 2 (m_rho0)^2 *
1727* = 3 (m_phi)^2 default: 1 *
1728* what (3) upper limit in M^2 integration *
1729* = 1 s/2 *
1730* = 2 s/4 *
1731* = 3 s default: 3 *
1732* what (4) CKMT F_2 structure function *
1733* = 2212 proton *
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 *
1738* = 3 using SIGGA *
1739* = 4 PHOJET cross sections default: 4 *
1740* *
1741* what (6), sdum no meaning *
1742* *
1743*********************************************************************
1744
1745 530 CONTINUE
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))
1751 GOTO 10
1752
1753*********************************************************************
1754* *
1755* control card: codewd = HISTOGRAM *
1756* *
1757* activate different classes of histograms *
1758* *
1759* default: no histograms *
1760* *
1761*********************************************************************
1762
1763 540 CONTINUE
1764 DO 541 J=1,6
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
1770 ENDIF
1771 541 CONTINUE
1772 GOTO 10
1773
1774*********************************************************************
1775* *
1776* control card: codewd = XS-TABLE *
1777* *
1778* output of cross section table for requested interaction *
1779* - particle production deactivated ! - *
1780* *
1781* what (1) lower energy limit for tabulation *
1782* > 0 Lab. frame *
1783* < 0 nucleon-nucleon cms *
1784* what (2) upper energy limit for tabulation *
1785* > 0 Lab. frame *
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 *
1793* *
1794*********************************************************************
1795
1796 550 CONTINUE
1797 IF (WHAT(1).EQ.99999.0D0) THEN
1798 IRATIO = INT(WHAT(2))
1799 GOTO 10
1800 ENDIF
1801 CMENER = ABS(WHAT(2))
1802 IF (.NOT.LXSTAB) THEN
1803
1804 CALL BERTTP
1805 CALL INCINI
1806
1807 ENDIF
1808 IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1809 CMEOLD = CMENER
1810 IF (WHAT(2).GT.ZERO)
1811 & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1812 EPN = ZERO
1813 PPN = ZERO
1814C WRITE(LOUT,*) 'CMENER = ',CMENER
1815 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1816 CALL DT_PHOINI
1817 ENDIF
1818 CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1819 IXSQEL = 0
1820 LXSTAB = .TRUE.
1821 GOTO 10
1822
1823*********************************************************************
1824* *
1825* control card: codewd = GLAUB-PAR *
1826* *
1827* parameters in Glauber-formalism *
1828* *
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 *
1834* default: 0 *
1835* what (4) = 1 read pre-calculated impact-parameter distrib. *
1836* from "sdum".glb *
1837* =-1 dump pre-calculated impact-parameter distrib. *
1838* into "sdum".glb *
1839* = 100 read pre-calculated impact-parameter distrib. *
1840* for variable projectile/target/energy runs *
1841* from "sdum".glb *
1842* default: 0 *
1843* what (5..6) no meaning *
1844* sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
1845* *
1846*********************************************************************
1847
1848 560 CONTINUE
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))
1854 CGLB = SDUM
1855 ENDIF
1856 GOTO 10
1857
1858*********************************************************************
1859* *
1860* control card: codewd = GLAUB-INI *
1861* *
1862* pre-initialization of profile function *
1863* *
1864* what (1) lower energy limit for initialization *
1865* > 0 Lab. frame *
1866* < 0 nucleon-nucleon cms *
1867* what (2) upper energy limit for initialization *
1868* > 0 Lab. frame *
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) *
1876* default: 18 *
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 *
1880* default: 5 *
1881* what (6) no meaning *
1882* sdum no meaning *
1883* *
1884*********************************************************************
1885
1886 565 CONTINUE
1887 IOGLB = -100
1888 CALL DT_GLBINI(WHAT)
1889 GOTO 10
1890
1891*********************************************************************
1892* *
1893* control card: codewd = VDM-PAR2 *
1894* *
1895* parameters in gamma-nucleus cross section calculation *
1896* *
1897* what (1) = 0 no suppression of shadowing by direct photon *
1898* processes *
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 *
1907* account *
1908* eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
1909* what (5..6), sdum no meaning *
1910* *
1911*********************************************************************
1912
1913 570 CONTINUE
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))
1917 EPSPOL = WHAT(4)
1918 GOTO 10
1919
1920*********************************************************************
1921* *
1922* control card: XS-QELPRO *
1923* *
1924* what (1..6), sdum no meaning *
1925* *
1926*********************************************************************
1927
1928 580 CONTINUE
1929 IXSQEL = ABS(WHAT(1))
1930 GOTO 10
1931
1932*********************************************************************
1933* *
1934* control card: RNDMINIT *
1935* *
1936* initialization of random number generator *
1937* *
1938* what (1..4) values for initialization (= 1..168) *
1939* what (5..6), sdum no meaning *
1940* *
1941*********************************************************************
1942
1943 590 CONTINUE
1944 IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1945 NA1 = 22
1946 ELSE
1947 NA1 = WHAT(1)
1948 ENDIF
1949 IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1950 NA2 = 54
1951 ELSE
1952 NA2 = WHAT(2)
1953 ENDIF
1954 IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1955 NA3 = 76
1956 ELSE
1957 NA3 = WHAT(3)
1958 ENDIF
1959 IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1960 NA4 = 92
1961 ELSE
1962 NA4 = WHAT(4)
1963 ENDIF
1964 CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1965 GOTO 10
1966
1967*********************************************************************
1968* *
1969* control card: codewd = LEPTO-CUT *
1970* *
1971* set parameter CUT in LEPTO-common /LEPTOU/ *
1972* *
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 *
1977* what (2) *
1978* default: default-LEPTO parameters *
1979* *
1980*********************************************************************
1981
1982 600 CONTINUE
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)
1986 GOTO 10
1987
1988*********************************************************************
1989* *
1990* control card: codewd = LEPTO-LST *
1991* *
1992* set parameter LST in LEPTO-common /LEPTOU/ *
1993* *
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 *
1998* what (2) *
1999* default: default-LEPTO parameters *
2000* *
2001*********************************************************************
2002
2003 610 CONTINUE
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))
2007 GOTO 10
2008
2009*********************************************************************
2010* *
2011* control card: codewd = LEPTO-PARL *
2012* *
2013* set parameter PARL in LEPTO-common /LEPTOU/ *
2014* *
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 *
2019* what (2) *
2020* default: default-LEPTO parameters *
2021* *
2022*********************************************************************
2023
2024 620 CONTINUE
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)
2028 GOTO 10
2029
2030*********************************************************************
2031* *
2032* control card: codewd = START *
2033* *
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 *
2039* is requested) *
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 *
2046* *
2047*********************************************************************
2048
2049 630 CONTINUE
2050
2051* check for cross-section table output only
2052 IF (LXSTAB) STOP
2053
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))
2058 & IGLAU = 0
2059
2060 NPMASS = IP
2061 NPCHAR = IPZ
2062 NTMASS = IT
2063 NTCHAR = ITZ
2064 IDP = IJPROJ
2065 IDT = IJTARG
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..)
2070C IF (IDP.EQ.26) IDP = 5
2071C IF (IDP.EQ.27) IDP = 6
2072
2073* redefine collision energy
2074 IF (LEINP) THEN
2075 IF (ABS(VAREHI).GT.ZERO) THEN
2076 PDUM = ZERO
2077 IF (VARELO.LT.EHADLO) VARELO = EHADLO
2078 CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2079 PDUM = ZERO
2080 CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2081 ENDIF
2082 CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2083 ELSE
2084 WRITE(LOUT,1003)
2085 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
2086 & 1X,' -program stopped- ')
2087 STOP
2088 ENDIF
2089
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
2092 IF (LEVPRT) THEN
2093 WRITE(LOUT,1004)
2094 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
2095 & ' central collisions forced.')
2096 LEVPRT = .FALSE.
2097 LDEEXG = .FALSE.
2098 LHEAVY = .FALSE.
2099 ENDIF
2100 ENDIF
2101
2102* initialization of evaporation-module
2103
2104* initialize evaporation if the code is not used as Fluka event generator
2105 IF (ITRSPT.NE.1) THEN
ba758f5a 2106* CALL BERTTP
2107* CALL INCINI
d30b8254 2108 ENDIF
2109 IF (LEVPRT) LHEAVY = .TRUE.
2110
2111
2112* save the default JETSET-parameter
2113 CALL DT_JSPARA(0)
2114
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
2121
2122 STOP ' This version does not contain LEPTO !'
2123
2124 ENDIF
2125
2126* initialization of quasi-elastic neutrino scattering
2127 IF (MCGENE.EQ.4) THEN
2128 IF (IJPROJ.EQ.5) THEN
2129 NEUTYP = 1
2130 ELSEIF (IJPROJ.EQ.6) THEN
2131 NEUTYP = 2
2132 ELSEIF (IJPROJ.EQ.135) THEN
2133 NEUTYP = 3
2134 ELSEIF (IJPROJ.EQ.136) THEN
2135 NEUTYP = 4
2136 ELSEIF (IJPROJ.EQ.133) THEN
2137 NEUTYP = 5
2138 ELSEIF (IJPROJ.EQ.134) THEN
2139 NEUTYP = 6
2140 ENDIF
2141 ENDIF
2142
2143* normalize fractions of emulsion components
2144 IF (NCOMPO.GT.0) THEN
2145 SUMFRA = ZERO
2146 DO 491 I=1,NCOMPO
2147 SUMFRA = SUMFRA+EMUFRA(I)
2148 491 CONTINUE
2149 IF (SUMFRA.GT.ZERO) THEN
2150 DO 492 I=1,NCOMPO
2151 EMUFRA(I) = EMUFRA(I)/SUMFRA
2152 492 CONTINUE
2153 ENDIF
2154 ENDIF
2155
2156* disallow Cronin's multiple scattering for nucleus-nucleus interactions
2157 IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
2158 WRITE(LOUT,1005)
2159 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
2160 MKCRON = 0
2161 ENDIF
2162
2163* initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2164C IF (NCOMPO.LE.0) THEN
2165C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2166C ELSE
2167C DO 493 I=1,NCOMPO
2168C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2169C 493 CONTINUE
2170C ENDIF
2171
2172* pre-tabulation of elastic cross-sections
2173 CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2174
2175 CALL DT_XTIME
2176
2177 RETURN
2178
2179*********************************************************************
2180* *
2181* control card: codewd = STOP *
2182* *
2183* stop of the event generation *
2184* *
2185* what (1..6) no meaning *
2186* *
2187*********************************************************************
2188
2189 9999 CONTINUE
2190 WRITE(LOUT,9000)
2191 9000 FORMAT(1X,'---> unexpected end of input !')
2192
2193 640 CONTINUE
2194 STOP
2195
2196 END
2197*
2198*===kkinc==============================================================*
2199*
2200CDECK ID>, DT_KKINC
2201 SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2202 & IREJ)
2203
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************************************************************************
2210
2211 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2212 SAVE
2213
2214 PARAMETER ( LINP = 5 ,
2215 & LOUT = 6 ,
2216 & LDAT = 9 )
2217
2218 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2219 & TINY2=1.0D-2,TINY3=1.0D-3)
2220
2221 LOGICAL LFZC
2222
2223* event history
2224
2225 PARAMETER (NMXHKK=200000)
2226
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),
2233 & IHIST(2,NMXHKK)
2234* particle properties (BAMJET index convention)
2235 CHARACTER*8 ANAME
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
2254 LOGICAL LPROD
2255 CHARACTER*8 CGLB
2256 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2257
2258 DIMENSION WHAT(6)
2259
2260 IREJ = 0
2261 ILOOP = 0
2262 100 CONTINUE
2263 IF (ILOOP.EQ.4) THEN
2264 WRITE(LOUT,1000) NEVHKK
2265 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
2266 GOTO 9999
2267 ENDIF
2268 ILOOP = ILOOP+1
2269
2270* variable energy-runs, recalculate parameters for LT's
2271 IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2272 PDUM = ZERO
2273 CDUM = ZERO
2274 CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2275 ENDIF
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) !'
2280 STOP
2281 ENDIF
2282
2283* re-initialize /DTPRTA/
2284 IP = NPMASS
2285 IPZ = NPCHAR
2286 IT = NTMASS
2287 ITZ = NTCHAR
2288 IJPROJ = IDP
2289 IBPROJ = IIBAR(IJPROJ)
2290
2291* calculate nuclear potentials (common /DTNPOT/)
2292 CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2293
2294* initialize treatment for residual nuclei
2295 CALL DT_RESNCL(EPN,NLOOP,1)
2296
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'
2301 GOTO 9999
2302 ENDIF
2303
2304 IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2305
2306* intranuclear cascade of final state particles for KTAUGE generations
2307* of secondaries
2308 CALL DT_FOZOCA(LFZC,IREJ1)
2309 IF (IREJ1.GT.0) THEN
2310 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2311 GOTO 9999
2312 ENDIF
2313
2314* baryons unable to escape the nuclear potential are treated as
2315* excited nucleons (ISTHKK=15,16)
2316 CALL DT_SCN4BA
2317
2318* decay of resonances produced in intranuclear cascade processes
2319**sr 15-11-95 should be obsolete
2320C IF (LFZC) CALL DT_DECAY1
2321
2322 101 CONTINUE
2323* treatment of residual nuclei
2324 CALL DT_RESNCL(EPN,NLOOP,2)
2325
2326* evaporation / fission / fragmentation
2327* (if intranuclear cascade was sampled only)
2328 IF (LFZC) THEN
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
2332 ENDIF
2333
2334 ENDIF
2335
2336* transform finale state into Lab.
2337 IFLAG = 2
2338 CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2339 IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2340
2341 IF (IPI0.EQ.1) CALL DT_DECPI0
2342
2343C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2344
2345 RETURN
2346 9999 CONTINUE
2347 IREJ = 1
2348 RETURN
2349 END
2350*
2351*===defaul=============================================================*
2352*
2353CDECK ID>, DT_DEFAUL
2354 SUBROUTINE DT_DEFAUL(EPN,PPN)
2355
2356************************************************************************
2357* Variables are set to default values. *
2358* This version dated 8.5.95 is written by S. Roesler. *
2359************************************************************************
2360
2361 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2362 SAVE
2363 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2364 PARAMETER (TWOPI = 6.283185307179586454D+00)
2365
2366* particle properties (BAMJET index convention)
2367 CHARACTER*8 ANAME
2368 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2369 & IICH(210),IIBAR(210),K1(210),K2(210)
2370* nuclear potential
2371 LOGICAL LFERMI
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
2383
2384 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2385
2386* emulsion treatment
2387 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2388 & NCOMPO,IEMUL
2389* parameter for intranuclear cascade
2390 LOGICAL LPAULI
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,
2396 & LCO2CR,LINTPT
2397* threshold values for x-sampling (DTUNUC 1.x)
2398 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2399 & SSMIMQ,VVMTHR
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
2414 CHARACTER*8 CMODEL
2415 LOGICAL LPHOIN
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
2422 LOGICAL LPROD
2423 CHARACTER*8 CGLB
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
2434* LEPTO
2435 REAL RPPN
2436 COMMON /LEPTOI/ RPPN,LEPIN,INTER
2437* steering flags for qel neutrino scattering modules
2438 COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2439* event flag
2440 COMMON /DTEVNO/ NEVENT,ICASCA
2441
2442 DATA POTMES /0.002D0/
2443
2444* common /DTNPOT/
2445 DO 10 I=1,2
2446 PFERMP(I) = ZERO
2447 PFERMN(I) = ZERO
2448 EBINDP(I) = ZERO
2449 EBINDN(I) = ZERO
2450 DO 11 J=1,210
2451 EPOT(I,J) = ZERO
2452 11 CONTINUE
2453* nucleus independent meson potential
2454 EPOT(I,13) = POTMES
2455 EPOT(I,14) = POTMES
2456 EPOT(I,15) = POTMES
2457 EPOT(I,16) = POTMES
2458 EPOT(I,23) = POTMES
2459 EPOT(I,24) = POTMES
2460 EPOT(I,25) = POTMES
2461 10 CONTINUE
2462**sr 7.4.98: changed after corrected B-sampling
2463C FERMOD = 0.55D0
2464 FERMOD = 0.68D0
2465 ETACOU(1) = ZERO
2466 ETACOU(2) = ZERO
2467 ICOUL = 1
2468 LFERMI = .TRUE.
2469
2470* common /HNTHRE/
2471 EHADTH = -99.0D0
2472 EHADLO = 4.06D0
2473 EHADHI = 6.0D0
2474 INTHAD = 1
2475 IDXTA = 2
2476
2477* common /DTIMPA/
2478 ICENTR = 0
2479 BIMIN = ZERO
2480 BIMAX = 1.0D10
2481 XSFRAC = 1.0D0
2482
2483* common /DTPRTA/
2484 IP = 1
2485 IPZ = 1
2486 IT = 1
2487 ITZ = 1
2488 IJPROJ = 1
2489 IBPROJ = 1
2490 IJTARG = 1
2491 IBTARG = 1
2492* common /DTGPRO/
2493 VIRT = ZERO
2494 DO 14 I=1,4
2495 PGAMM(I) = ZERO
2496 PLEPT0(I) = ZERO
2497 PLEPT1(I) = ZERO
2498 PNUCL(I) = ZERO
2499 14 CONTINUE
2500 IDIREC = 0
2501
2502* common /DTFOTI/
2503**sr 7.4.98: changed after corrected B-sampling
2504C TAUFOR = 4.4D0
2505 TAUFOR = 3.1D0
2506 KTAUGE = 25
2507 ITAUVE = 1
2508 INCMOD = 1
2509 LPAULI = .TRUE.
2510
2511* common /DTCHAI/
2512 SEASQ = ONE
2513 MKCRON = 1
2514 CRONCO = 0.64D0
2515 ISICHA = 0
2516 CUTOF = 100.0D0
2517 LCO2CR = .FALSE.
2518 IRECOM = 1
2519 LINTPT = .TRUE.
2520
2521* common /DTXCUT/
2522* definition of soft quark distributions
2523 XSEACU = 0.05D0
2524 UNON = 2.0D0
2525 UNOM = 1.5D0
2526 UNOSEA = 5.0D0
2527* cutoff parameters for x-sampling
2528 CVQ = 1.0D0
2529 CDQ = 2.0D0
2530C CSEA = 0.3D0
2531 CSEA = 0.1D0
2532 SSMIMA = 1.2D0
2533 SSMIMQ = SSMIMA**2
2534 VVMTHR = 2.0D0
2535
2536* common /DTXSFL/
2537 IFLUCT = 0
2538
2539* common /DTFRPA/
2540 PDB = 0.15D0
2541 PDBSEA(1) = 0.0D0
2542 PDBSEA(2) = 0.0D0
2543 PDBSEA(3) = 0.0D0
2544 ISIG0 = 0
2545 IPI0 = 0
2546 NMSTU = 0
2547 NPARU = 0
2548 NMSTJ = 0
2549 NPARJ = 0
2550
2551* common /DTDIQB/
2552 DO 15 I=1,8
2553 DBRKR(1,I) = 5.0D0
2554 DBRKR(2,I) = 5.0D0
2555 DBRKR(3,I) = 10.0D0
2556 DBRKA(1,I) = ZERO
2557 DBRKA(2,I) = ZERO
2558 DBRKA(3,I) = ZERO
2559 15 CONTINUE
2560 CHAM1 = 0.2D0
2561 CHAM3 = 0.5D0
2562 CHAB1 = 0.7D0
2563 CHAB3 = 1.0D0
2564
2565* common /DTFLG3/
2566 ISINGD = 0
2567 IDOUBD = 0
2568 IFLAGD = 0
2569 IDIFF = 0
2570
2571* common /DTMODL/
2572 MCGENE = 2
2573 CMODEL(1) = 'DTUNUC '
2574 CMODEL(2) = 'PHOJET '
2575 CMODEL(3) = 'LEPTO '
2576 CMODEL(4) = 'QNEUTRIN'
2577 LPHOIN = .TRUE.
2578 ELOJET = 5.0D0
2579
2580* common /DTLCUT/
2581 ECMIN = 3.5D0
2582 ECMAX = 1.0D10
2583 XBJMIN = ZERO
2584 ELMIN = ZERO
2585 EGMIN = ZERO
2586 EGMAX = 1.0D10
2587 YMIN = TINY10
2588 YMAX = 0.999D0
2589 Q2MIN = TINY10
2590 Q2MAX = 10.0D0
2591 THMIN = ZERO
2592 THMAX = TWOPI
2593 Q2LI = ZERO
2594 Q2HI = 1.0D10
2595 ECMLI = ZERO
2596 ECMHI = 1.0D10
2597
2598* common /DTVDMP/
2599 RL2 = 2.0D0
2600 INTRGE(1) = 1
2601 INTRGE(2) = 3
2602 IDPDF = 2212
2603 MODEGA = 4
2604 ISHAD(1) = 1
2605 ISHAD(2) = 1
2606 ISHAD(3) = 1
2607 EPSPOL = ZERO
2608
2609* common /DTGLGP/
2610 JSTATB = 1000
2611 JBINSB = 49
2612 CGLB = ' '
2613 IF (ITRSPT.EQ.1) THEN
2614 IOGLB = 100
2615 ELSE
2616 IOGLB = 0
2617 ENDIF
2618 LPROD = .TRUE.
2619
2620* common /DTHIS3/
2621 DO 16 I=1,50
2622 IHISPP(I) = 0
2623 IHISXS(I) = 0
2624 16 CONTINUE
2625 IXSTBL = 0
2626
2627* common /DTVARE/
2628 VARELO = ZERO
2629 VAREHI = ZERO
2630 VARCLO = ZERO
2631 VARCHI = ZERO
2632
2633* common /DTDIHA/
2634 DIBETA = -1.0D0
2635 DIALPH = ZERO
2636
2637* common /LEPTOI/
2638 RPPN = 0.0
2639 LEPIN = 0
2640 INTER = 0
2641
2642* common /QNEUTO/
2643 NEUTYP = 1
2644 NEUDEC = 0
2645
2646* common /DTEVNO/
2647 NEVENT = 1
2648 IF (ITRSPT.EQ.1) THEN
2649 ICASCA = 1
2650 ELSE
2651 ICASCA = 0
2652 ENDIF
2653
2654* default Lab.-energy
2655 EPN = 200.0D0
2656 PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2657
2658 RETURN
2659 END
2660*
2661*===aaevt==============================================================*
2662*
2663CDECK ID>, DT_AAEVT
2664 SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2665 & IDP,IGLAU)
2666
2667************************************************************************
2668* This version dated 22.03.96 is written by S. Roesler. *
2669************************************************************************
2670
2671 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2672 SAVE
2673
2674 PARAMETER ( LINP = 5 ,
2675 & LOUT = 6 ,
2676 & LDAT = 9 )
2677
2678 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2679
2680* emulsion treatment
2681 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2682 & NCOMPO,IEMUL
2683* event flag
2684 COMMON /DTEVNO/ NEVENT,ICASCA
2685
2686 CHARACTER*8 DATE,HHMMSS
2687 DIMENSION IDMNYR(3)
2688
2689 KKMAT = 1
2690 NMSG = MAX(NEVTS/100,1)
2691
2692* initialization of run-statistics and histograms
2693 CALL DT_STATIS(1)
2694
2695 CALL PHO_PHIST(1000,DUM)
2696
2697* initialization of Glauber-formalism
2698 IF (NCOMPO.LE.0) THEN
2699 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2700 ELSE
2701 DO 1 I=1,NCOMPO
2702 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2703 1 CONTINUE
2704 ENDIF
2705 CALL DT_SIGEMU
2706
2707 CALL IDATE(IDMNYR)
2708 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2709 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2710 CALL ITIME(IDMNYR)
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,' )')
2716
2717* generate NEVTS events
2718 DO 2 IEVT=1,NEVTS
2719
2720* print run-status message
2721 IF (MOD(IEVT,NMSG).EQ.0) THEN
2722 CALL IDATE(IDMNYR)
2723 WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2724 & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2725 CALL ITIME(IDMNYR)
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,' )',/)
2731C WRITE(LOUT,1000) IEVT-1
2732C1000 FORMAT(1X,I8,' events sampled')
2733 ENDIF
2734 NEVENT = IEVT
2735* treat nuclear emulsions
2736 IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2737* composite targets only
2738 KKMAT = -KKMAT
2739* sample this event
2740 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2741
2742 CALL PHO_PHIST(2000,DUM)
2743
2744 2 CONTINUE
2745
2746* print run-statistics and histograms to output-unit 6
2747
2748 CALL PHO_PHIST(3000,DUM)
2749
2750 CALL DT_STATIS(2)
2751
2752 RETURN
2753 END
2754*
2755*===laevt==============================================================*
2756*
2757CDECK ID>, DT_LAEVT
2758 SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2759 & IDP,IGLAU)
2760
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************************************************************************
2767
2768 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2769 SAVE
2770
2771 PARAMETER ( LINP = 5 ,
2772 & LOUT = 6 ,
2773 & LDAT = 9 )
2774
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,
2778 & PI = TWOPI/TWO,
2779 & ALPHEM = ONE/137.0D0)
2780
2781C CHARACTER*72 HEADER
2782
2783* particle properties (BAMJET index convention)
2784 CHARACTER*8 ANAME
2785 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2786 & IICH(210),IIBAR(210),K1(210),K2(210)
2787* event history
2788
2789 PARAMETER (NMXHKK=200000)
2790
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),
2797 & IHIST(2,NMXHKK)
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
2809
2810 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2811
2812* emulsion treatment
2813 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2814 & NCOMPO,IEMUL
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
2827 CHARACTER*8 CMODEL
2828 LOGICAL LPHOIN
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
2834* event flag
2835 COMMON /DTEVNO/ NEVENT,ICASCA
2836
2837 DIMENSION XDUMB(40),BGTA(4)
2838
2839* LEPTO
2840 IF (MCGENE.EQ.3) THEN
2841
2842 STOP ' This version does not contain LEPTO !'
2843
2844 ENDIF
2845
2846 KKMAT = 1
2847 NMSG = MAX(NEVTS/10,1)
2848
2849* mass of incident lepton
2850 AMLPT = AAM(IDP)
2851 AMLPT2 = AMLPT**2
2852 IDPPDG = IDT_IPDGHA(IDP)
2853
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)
2859
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,
2867 & THMIN,THMAX,ELMIN
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',/)
2875
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)
2900
2901* limits for Glauber-initialization
2902 Q2LI = Q2MIN
2903 Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2904 ECMLI = MAX(EGNMIN,THREE)
2905 ECMHI = EGNMAX
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)
2915 ELSE
2916 DO 9 I=1,NCOMPO
2917 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2918 9 CONTINUE
2919 ENDIF
2920 CALL DT_SIGEMU
2921
2922* initialization of run-statistics and histograms
2923 CALL DT_STATIS(1)
2924
2925 CALL PHO_PHIST(1000,DUM)
2926
2927* maximum photon-nucleus cross section
2928 I1 = 1
2929 I2 = 1
2930 RAT = ONE
2931 IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2932 I1 = NEBINI
2933 I2 = NEBINI
2934 RAT = ONE
2935 ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2936 DO 5 I=2,NEBINI
2937 IF (EGNMAX.LT.ECMNN(I)) THEN
2938 I1 = I-1
2939 I2 = I
2940 RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2941 GOTO 6
2942 ENDIF
2943 5 CONTINUE
2944 6 CONTINUE
2945 ENDIF
2946 SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2947 EGNXX = EGNMAX
2948 I1 = 1
2949 I2 = 1
2950 RAT = ONE
2951 IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2952 I1 = NEBINI
2953 I2 = NEBINI
2954 RAT = ONE
2955 ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2956 DO 7 I=2,NEBINI
2957 IF (EGNMIN.LT.ECMNN(I)) THEN
2958 I1 = I-1
2959 I2 = I
2960 RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2961 GOTO 8
2962 ENDIF
2963 7 CONTINUE
2964 8 CONTINUE
2965 ENDIF
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'
2970
2971* plot photon flux table
2972 AYMIN = LOG(YMIN)
2973 AYMAX = LOG(YMAX)
2974 AYRGE = AYMAX-AYMIN
2975 MAXTAB = 50
2976 ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2977C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
2978 DO 1 I=1,MAXTAB
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))
2985C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2986 1 CONTINUE
2987
2988* maximum residual weight for flux sampling (dy/y)
2989 YY = YMIN
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
2993
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)
3006 XBLOW = 0.001D0
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)
3010
3011 ITRY = 0
3012 ITRW = 0
3013 NC0 = 0
3014 NC1 = 0
3015
3016* generate events
3017 DO 2 IEVT=1,NEVTS
3018 IF (MOD(IEVT,NMSG).EQ.0) THEN
3019C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
3020C & STATUS='UNKNOWN')
3021 WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
3022C CLOSE(LDAT)
3023 ENDIF
3024 NEVENT = IEVT
3025
3026 100 CONTINUE
3027 ITRY = ITRY+1
3028
3029* sample y
3030 101 CONTINUE
3031 ITRW = ITRW+1
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
3040
3041* sample Q2
3042 YEFF = ONE+(ONE-YY)**2
3043 102 CONTINUE
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
3047
3048c NC0 = NC0+1
3049c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3050c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3051
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)
3058 PLEPT1(1) = YQ2*COF
3059 PLEPT1(2) = YQ2*SIF
3060 PLEPT1(3) = E1Y-Q2E
3061 PLEPT1(4) = E1Y+Q2E
3062C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3063* radiated photon
3064 PGAMM(1) = -PLEPT1(1)
3065 PGAMM(2) = -PLEPT1(2)
3066 PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3067 PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3068* E_cm cut
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
3074 ECMGN = SQRT(ECMGN)
3075 IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3076
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) ',
3088 & 2F10.4)
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) ',
3092 & 2F10.2)
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) ',
3096 & 2F10.4)
3097
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
3102 ENDIF
3103* photon energy-cut (Lab)
3104 IF (PPG(4).LT.EGMIN) GOTO 101
3105 IF (PPG(4).GT.EGMAX) GOTO 101
3106* x_Bj cut
3107 XBJ = ABS(Q2/(1.876D0*PPG(4)))
3108 IF (XBJ.LT.XBJMIN) GOTO 101
3109
3110 NC0 = NC0+1
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)
3116
3117* rotation angles against z-axis
3118 COD = PPG(3)/PGTOT
3119C SID = SQRT((ONE-COD)*(ONE+COD))
3120 PPT = SQRT(PPG(1)**2+PPG(2)**2)
3121 SID = PPT/PGTOT
3122 COF = ONE
3123 SIF = ZERO
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)
3128 COF = COF/ANORF
3129 SIF = SIF/ANORF
3130 ENDIF
3131
3132 IF (IXSTBL.EQ.0) THEN
3133* change to photon projectile
3134 IJPROJ = 7
3135* set virtuality
3136 VIRT = Q2
3137* re-initialize LTs with new kinematics
3138* !!PGAMM ist set in cms (ECMGN) along z
3139 EPN = ZERO
3140 PPN = ZERO
3141 CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3142* Introduced by Chiara -> force CMS-system
3143* IFRAME = 2
3144* to force Lab-system
3145 IFRAME = 1
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,
3153 & Q2,ECMGN,STOT
3154 IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3155 NC1 = NC1+1
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
3162 KKMAT = -KKMAT
3163* sample this event
3164 CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3165 & IREJ)
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
3170 PX = PHKK(1,I)
3171 PY = PHKK(2,I)
3172 PZ = PHKK(3,I)
3173 CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3174 & PHKK(1,I),PHKK(2,I),PHKK(3,I))
3175 ENDIF
3176 4 CONTINUE
3177 ENDIF
3178
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)
3184
3185* dump this event to histograms
3186
3187 CALL PHO_PHIST(2000,DUM)
3188
3189 2 CONTINUE
3190
3191 WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3192 WGY = WGY*LOG(YMAX/YMIN)
3193 WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3194
3195C HEADER = ' LAEVT: Q^2 distribution 0'
3196C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3197C HEADER = ' LAEVT: Q^2 distribution 1'
3198C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3199C HEADER = ' LAEVT: Q^2 distribution 2'
3200C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3201C HEADER = ' LAEVT: y distribution 0'
3202C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3203C HEADER = ' LAEVT: y distribution 1'
3204C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3205C HEADER = ' LAEVT: y distribution 2'
3206C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3207C HEADER = ' LAEVT: x distribution 0'
3208C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3209C HEADER = ' LAEVT: x distribution 1'
3210C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3211C HEADER = ' LAEVT: x distribution 2'
3212C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3213C HEADER = ' LAEVT: E_g distribution 0'
3214C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3215C HEADER = ' LAEVT: E_g distribution 1'
3216C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3217C HEADER = ' LAEVT: E_g distribution 2'
3218C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3219C HEADER = ' LAEVT: E_c distribution 0'
3220C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3221C HEADER = ' LAEVT: E_c distribution 1'
3222C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3223C HEADER = ' LAEVT: E_c distribution 2'
3224C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3225
3226* print run-statistics and histograms to output-unit 6
3227
3228 CALL PHO_PHIST(3000,DUM)
3229
3230 IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3231
3232 RETURN
3233 END
3234*
3235*===dtuini=============================================================*
3236*
3237CDECK ID>, DT_DTUINI
3238 SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3239 & IDP,IEMU)
3240
3241 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3242 SAVE
3243
3244 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3245
3246* emulsion treatment
3247 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3248 & NCOMPO,IEMUL
3249* Glauber formalism: flags and parameters for statistics
3250 LOGICAL LPROD
3251 CHARACTER*8 CGLB
3252 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3253
3254 CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3255 CALL DT_STATIS(1)
3256
3257 CALL PHO_PHIST(1000,DUM)
3258
3259 IF (NCOMPO.LE.0) THEN
3260 CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3261 ELSE
3262 DO 1 I=1,NCOMPO
3263 CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3264 1 CONTINUE
3265 ENDIF
3266 IF (IOGLB.NE.100) CALL DT_SIGEMU
3267 IEMU = IEMUL
3268
3269 RETURN
3270 END
3271*
3272*===dtuout=============================================================*
3273*
3274CDECK ID>, DT_DTUOUT
3275 SUBROUTINE DT_DTUOUT
3276
3277 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3278 SAVE
3279
3280 CALL PHO_PHIST(3000,DUM)
3281
3282 CALL DT_STATIS(2)
3283
3284 RETURN
3285 END
3286*
3287*===beam===============================================================*
3288*
3289CDECK ID>, DT_BEAMPR
3290 SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3291
3292************************************************************************
3293* Initialization of event generation *
3294* This version dated 7.4.98 is written by S. Roesler. *
3295************************************************************************
3296
3297 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3298 SAVE
3299
3300 PARAMETER ( LINP = 5 ,
3301 & LOUT = 6 ,
3302 & LDAT = 9 )
3303
3304 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3305 PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3306
3307 LOGICAL LBEAM
3308
3309* event history
3310
3311 PARAMETER (NMXHKK=200000)
3312
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),
3319 & IHIST(2,NMXHKK)
3320* properties of interacting particles
3321 COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3322* particle properties (BAMJET index convention)
3323 CHARACTER*8 ANAME
3324 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3325 & IICH(210),IIBAR(210),K1(210),K2(210)
3326* beam momenta
3327 COMMON /DTBEAM/ P1(4),P2(4)
3328
3329C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3330 DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3331
3332 DATA LBEAM /.FALSE./
3333
3334 GOTO (1,2) MODE
3335
3336 1 CONTINUE
3337
3338 E1 = WHAT(1)
3339 IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3340 E2 = WHAT(2)
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
3345 PH = WHAT(4)*BOG
3346 P1(1) = PP1*SIN(TH)*COS(PH)
3347 P1(2) = PP1*SIN(TH)*SIN(PH)
3348 P1(3) = PP1*COS(TH)
3349 P1(4) = E1
3350 P2(1) = PP2*SIN(TH)*COS(PH)
3351 P2(2) = PP2*SIN(TH)*SIN(PH)
3352 P2(3) = -PP2*COS(TH)
3353 P2(4) = E2
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
3367C SID = SQRT((ONE-COD)*(ONE+COD))
3368 PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3369 SID = PPT/P1TOT
3370 COF = ONE
3371 SIF = ZERO
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)
3376 COF = COF/ANORF
3377 SIF = SIF/ANORF
3378 ENDIF
3379**check
3380C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3381C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3382C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3383C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3384C PAX = ZERO
3385C PAY = ZERO
3386C PAZ = P1TOT
3387C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3388C PBX = ZERO
3389C PBY = ZERO
3390C PBZ = -P2TOT
3391C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3392C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3393C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3394C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3395C & P1CMS(1),P1CMS(2),P1CMS(3))
3396C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3397C & P2CMS(1),P2CMS(2),P2CMS(3))
3398C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3399C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3400C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3401C & P1TOT,P1(1),P1(2),P1(3),P1(4))
3402C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3403C & P2TOT,P2(1),P2(2),P2(3),P2(4))
3404C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3405C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3406C STOP
3407**
3408
3409 LBEAM = .TRUE.
3410
3411 RETURN
3412
3413 2 CONTINUE
3414
3415 IF (LBEAM) THEN
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)
3422 PECMS = PHKK(4,I)
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))
3425 ENDIF
3426 20 CONTINUE
3427 ELSE
3428 MODE = -1
3429 ENDIF
3430
3431 RETURN
3432 END
3433*
3434*===eventb=============================================================*
3435*
3436CDECK ID>, DT_EVENTB
3437 SUBROUTINE DT_EVENTB(NCSY,IREJ)
3438
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************************************************************************
3446
3447 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3448 SAVE
3449
3450 PARAMETER ( LINP = 5 ,
3451 & LOUT = 6 ,
3452 & LDAT = 9 )
3453
3454 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3455
3456* event history
3457
3458 PARAMETER (NMXHKK=200000)
3459
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),
3466 & IHIST(2,NMXHKK)
3467*! uncomment this line for internal phojet-fragmentation
3468C #include "dtu_dtevtp.inc"
3469* particle properties (BAMJET index convention)
3470 CHARACTER*8 ANAME
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
3477* rejection counter
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,
3489 & LCO2CR,LINTPT
3490* statistics
3491 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3492 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3493 & ICEVTG(8,0:30)
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
3508 CHARACTER*8 CMODEL
3509 LOGICAL LPHOIN
3510 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3511C 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)
3516C model switches and parameters
3517 CHARACTER*8 MDLNA
3518 INTEGER ISWMDL,IPAMDL
3519 DOUBLE PRECISION PARMDL
3520 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3521C 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
3530C event debugging information
3531 INTEGER NMAXD
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
3537C general process information
3538 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3539 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3540
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)
3545
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/
3549
3550 IREJ = 0
3551* pointer to first parton of the first chain in dtevt common
3552 NPOINT(3) = NHKK+1
3553* special flag for double-Pomeron statistics
3554 IPOPO = 1
3555* counter for low-mass (DTUNUC) interactions
3556 NDTUSC = 0
3557* counter for interactions treated by PHOJET
3558 NPHOSC = 0
3559
3560* scan interactions for single nucleon-nucleon interactions
3561* (this has to be checked here because Cronin modifies parton momenta)
3562 NC = NPOINT(2)
3563 IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3564 DO 8 I=1,NCSY
3565 ISINGL(I) = 0
3566 MOP = JMOHKK(1,NC)
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
3571 NC = NC+4
3572 8 CONTINUE
3573
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)
3577
3578* switch to PHOJET-settings for JETSET parameter
3579 CALL DT_INITJS(1)
3580
3581* loop over nucleon-nucleon interaction
3582 NC = NPOINT(2)
3583 DO 2 I=1,NCSY
3584*
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
3591 MOP = JMOHKK(1,NC)
3592 MOT = JMOHKK(1,NC+1)
3593 DO 3 K=1,4
3594 PPNN(K) = PHKK(K,MOP)
3595 PTNN(K) = PHKK(K,MOT)
3596 PTOTNN(K) = PPNN(K)+PTNN(K)
3597 PP1(K) = PHKK(K,NC)
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)
3604 3 CONTINUE
3605*
3606*-----------------------------------------------------------------------
3607* this is a complete nucleon-nucleon interaction
3608*
3609 IF (ISINGL(I).EQ.1) THEN
3610*
3611* initialize PHOJET-variables for remnant/valence-partons
3612 IHFLD(1,1) = 0
3613 IHFLD(1,2) = 0
3614 IHFLD(2,1) = 0
3615 IHFLD(2,2) = 0
3616 IHFLS(1) = 1
3617 IHFLS(2) = 1
3618* save current settings of PHOJET process and min. bias flags
3619 DO 9 K=1,11
3620 KPRON(K) = IPRON(K,1)
3621 9 CONTINUE
3622 ISWSAV = ISWMDL(2)
3623*
3624* check if forced sampling of diffractive interaction requested
3625 IF (ISINGD.LT.-1) THEN
3626 DO 90 K=1,11
3627 IPRON(K,1) = 0
3628 90 CONTINUE
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
3632 ENDIF
3633*
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
3639 IPRON(8,1) = 0
3640* this is a direct interactions
3641 IF (IDIREC.EQ.1) THEN
3642 DO 12 K=1,11
3643 IPRON(K,1) = 0
3644 12 CONTINUE
3645 IPRON(8,1) = 1
3646* this is an anomalous interactions
3647* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3648 ELSEIF (IDIREC.EQ.2) THEN
3649 ISWMDL(2) = 0
3650 ENDIF
3651 ELSE
3652 IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3653 ENDIF
3654*
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)
3658 IF (IR1.NE.0) THEN
3659 IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3660 & 'EVENTB: mass shell correction rejected'
3661 GOTO 9999
3662 ENDIF
3663*
3664* initialize the incoming particles in PHOJET
3665 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3666
3667 CALL PHO_SETPAR(1,22,0,VIRT)
3668
3669 ELSE
3670
3671 CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3672
3673 ENDIF
3674
3675 CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3676
3677*
3678* initialize rejection loop counter for anomalous processes
3679 IRJANO = 0
3680 800 CONTINUE
3681 IRJANO = IRJANO+1
3682*
3683* temporary fix for ifano problem
3684 IFANO(1) = 0
3685 IFANO(2) = 0
3686*
3687* generate complete hadron/nucleon/photon-nucleon event with PHOJET
3688
3689 CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3690
3691*
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
3699 ELSE
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
3703 ENDIF
3704 ELSE
3705 WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3706 & IRJANO,IDIREC,NEVHKK
3707 ENDIF
3708 ENDIF
3709*
3710* copy back original settings of PHOJET process and min. bias flags
3711 DO 10 K=1,11
3712 IPRON(K,1) = KPRON(K)
3713 10 CONTINUE
3714 ISWMDL(2) = ISWSAV
3715*
3716* check if PHOJET has rejected this event
3717 IF (IREJ1.NE.0) THEN
3718C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3719 WRITE(LOUT,'(1X,A,I4)')
3720 & 'EVENTB: chain system rejected',IDIREC
3721
3722 CALL PHO_PREVNT(0)
3723
3724 GOTO 9999
3725 ENDIF
3726*
3727* copy partons and strings from PHOJET common back into DTEVT for
3728* external fragmentation
3729 MO1 = NC
3730 MO2 = NC+3
3731*! uncomment this line for internal phojet-fragmentation
3732C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3733 NPHOSC = NPHOSC+1
3734 CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3735 IF (IREJ1.NE.0) THEN
3736 IF (IOULEV(1).GT.0)
3737 & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3738 GOTO 9999
3739 ENDIF
3740*
3741* update statistics counter
3742 ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3743*
3744*-----------------------------------------------------------------------
3745* this interaction involves "remnants"
3746*
3747 ELSE
3748*
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
3753 AMTOT = ZERO
3754 ELSE
3755 AMTOT = SQRT(AMTOT2)
3756 ENDIF
3757*
3758* systems with masses larger than elojet are treated with PHOJET
3759 IF (AMTOT.GT.ELOJET) THEN
3760*
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)
3765 IHFLS(1) = 0
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)
3771 IHFLS(2) = 0
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
3778 IREMN1 = IHFLS(1)-1
3779 IREMN2 = IHFLS(2)-1
3780*
3781* initialize the incoming particles in PHOJET
3782 IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3783
3784 CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3785
3786 ELSE
3787
3788 CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3789
3790 ENDIF
3791
3792 CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3793
3794*
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)
3820***
3821* testprint
3822c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3823c & (PPTCMS(2)+PTTCMS(2))**2 +
3824c & (PPTCMS(3)+PTTCMS(3))**2 )
3825c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3826c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3827c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3828c & (PPSUB(2)+PTSUB(2))**2 +
3829c & (PPSUB(3)+PTSUB(3))**2 )
3830c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3831c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3832***
3833*
3834* save current settings of PHOJET process and min. bias flags
3835 DO 7 K=1,11
3836 KPRON(K) = IPRON(K,1)
3837 7 CONTINUE
3838* disallow direct photon int. (does not make sense here anyway)
3839 IPRON(8,1) = 0
3840* disallow double pomeron processes (due to technical problems
3841* in PHOJET, needs to be solved sometime)
3842 IPRON(4,1) = 0
3843* disallow diffraction for sea-diquarks
3844 IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3845 & (IABS(IHFLD(1,2)).GT.1100)) THEN
3846 IPRON(3,1) = 0
3847 IPRON(6,1) = 0
3848 ENDIF
3849 IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3850 & (IABS(IHFLD(2,2)).GT.1100)) THEN
3851 IPRON(3,1) = 0
3852 IPRON(5,1) = 0
3853 ENDIF
3854*
3855* we need massless partons: transform them on mass shell
3856 XMP = ZERO
3857 XMT = ZERO
3858 DO 6 K=1,4
3859 PPTMP(K) = PPSUB(K)
3860 PTTMP(K) = PTSUB(K)
3861 6 CONTINUE
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) )
3871*
3872* after mass shell transformation the x_sub - relation has to be
3873* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3874*
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.
3880C 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)
3886 ELSE
3887*???????
3888 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3889 & *(PPTCMS(4)+PHKK(5,MOP)))
3890C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3891C & *(PPTCMS(4)+PHKK(5,MOT)))
3892 ENDIF
3893C 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)))
3898 DO 4 K=1,3
3899 PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3900 PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3901 4 CONTINUE
3902***
3903* testprint
3904*
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
3909*
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)
3913*
3914c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3915c & (PPTCMS(2)+PTTCMS(2))**2 +
3916c & (PPTCMS(3)+PTTCMS(3))**2 )
3917c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3918c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3919c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3920c & (PPSUB(2)+PTSUB(2))**2 +
3921c & (PPSUB(3)+PTSUB(3))**2 )
3922c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3923c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
3924c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3925c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3926c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3927c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
3928c ENDIF
3929c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3930c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3931c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3932c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3933* transform interacting nucleons into nucleon-nucleon cm-system
3934c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3935c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3936c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3937c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3938c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3939c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3940c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3941c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3942c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3943c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3944c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3945c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3946c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3947c & (PPNEW2+PTNEW2)**2 +
3948c & (PPNEW3+PTNEW3)**2 )
3949c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3950c & (PPNEW4+PTNEW4+PTSTCM) )
3951c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3952c & (PPSUB2+PTSUB2)**2 +
3953c & (PPSUB3+PTSUB3)**2 )
3954c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3955c & (PPSUB4+PTSUB4+PTSTSU) )
3956C WRITE(*,*) ' mother cmE :'
3957C WRITE(*,*) ETSTCM,ENEWCM
3958C WRITE(*,*) ' subsystem cmE :'
3959C WRITE(*,*) ETSTSU,ENEWSU
3960C WRITE(*,*) ' projectile mother :'
3961C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3962C WRITE(*,*) ' target mother :'
3963C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3964C WRITE(*,*) ' projectile subsystem:'
3965C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3966C WRITE(*,*) ' target subsystem:'
3967C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3968C WRITE(*,*) ' projectile subsystem should be:'
3969C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3970C & XPSUB*ETSTCM/2.0D0
3971C WRITE(*,*) ' target subsystem should be:'
3972C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3973C & XTSUB*ETSTCM/2.0D0
3974C WRITE(*,*) ' subsystem cmE should be: '
3975C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3976***
3977*
3978* generate complete remnant - nucleon/remnant event with PHOJET
3979
3980 CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3981
3982*
3983* copy back original settings of PHOJET process flags
3984 DO 11 K=1,11
3985 IPRON(K,1) = KPRON(K)
3986 11 CONTINUE
3987*
3988* check if PHOJET has rejected this event
3989 IF (IREJ1.NE.0) THEN
3990 IF (IOULEV(1).GT.0)
3991 & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
3992 WRITE(LOUT,*)
3993 & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3994
3995 CALL PHO_PREVNT(0)
3996
3997 GOTO 9999
3998 ENDIF
3999*
4000* copy partons and strings from PHOJET common back into DTEVT for
4001* external fragmentation
4002 MO1 = NC
4003 MO2 = NC+3
4004*! uncomment this line for internal phojet-fragmentation
4005C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4006 NPHOSC = NPHOSC+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'
4011 GOTO 9999
4012 ENDIF
4013*
4014* update statistics counter
4015 ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4016*
4017*-----------------------------------------------------------------------
4018* two-chain approx. for smaller systems
4019*
4020 ELSE
4021*
4022 NDTUSC = NDTUSC+1
4023* special flag for double-Pomeron statistics
4024 IPOPO = 0
4025*
4026* pick up flavors at the ends of the two chains
4027 IFP1 = IDHKK(NC)
4028 IFT1 = IDHKK(NC+1)
4029 IFP2 = IDHKK(NC+2)
4030 IFT2 = IDHKK(NC+3)
4031* ..and the indices of the mothers
4032 MOP1 = NC
4033 MOT1 = NC+1
4034 MOP2 = NC+2
4035 MOT2 = NC+3
4036 CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4037 & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4038*
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
4045 ENDIF
4046 IRHHA = IRHHA+1
4047 GOTO 9999
4048 ENDIF
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
4052 ENDIF
4053*
4054 ENDIF
4055*
4056* update statistics counter
4057 ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4058*
4059 NC = NC+4
4060*
4061 2 CONTINUE
4062*
4063*-----------------------------------------------------------------------
4064* treatment of low-mass chains (if there are any)
4065*
4066 IF (NDTUSC.GT.0) THEN
4067*
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
4074 GOTO 9999
4075 ENDIF
4076 ENDIF
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)
4081C CALL DT_EVTFRA(IREJ1)
4082C IF (IREJ1.GT.0) THEN
4083C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4084C IRFRAG = IRFRAG+1
4085C GOTO 9999
4086C ENDIF
4087 ELSE
4088*! uncomment this line for internal phojet-fragmentation
4089C NPOINT(4) = NHKK+1
4090 IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4091 ENDIF
4092*
4093*-----------------------------------------------------------------------
4094* new di-quark breaking mechanisms
4095*
4096 MXLEFT = 2
4097 CALL DT_CHASTA(0)
4098 IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4099 & .OR.(PDBSEA(3).GT.0.0D0)) THEN
4100 CALL DT_DIQBRK
4101 MXLEFT = 4
4102 ENDIF
4103*
4104*-----------------------------------------------------------------------
4105* hadronize this event
4106*
4107* hadronize PHOJET chain systems
4108 NPYMAX = 0
4109 NPJE = NPHOSC/MXPHFR
4110 IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4111 IF (NPJE.GT.1) THEN
4112 NLEFT = NPHOSC-NPJE*MXPHFR
4113 DO 20 JFRG=1,NPJE
4114 NFRG = JFRG*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
4118 NLEFT = 0
4119 ELSE
4120 CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4121 IF (IREJ1.GT.0) GOTO 22
4122 ENDIF
4123 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4124 20 CONTINUE
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
4129 ENDIF
4130 ELSE
4131 CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4132 IF (IREJ1.GT.0) GOTO 22
4133 IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4134 ENDIF
4135*
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)
4141 ELSE
4142 MXPHFR = MAX(1,MXPHFR-1)
4143 ENDIF
4144C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4145 ENDIF
4146*
4147* hadronize DTUNUC chain systems
4148 23 CONTINUE
4149 IBACK = MXDTFR
4150 CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4151 IF (IREJ2.GT.0) GOTO 22
4152*
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)
4158 ELSE
4159 MXDTFR = MAX(1,MXDTFR-10)
4160 ENDIF
4161C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4162 ENDIF
4163*
4164 IF (IBACK.EQ.-1) GOTO 23
4165*
4166 22 CONTINUE
4167C CALL DT_EVTFRG(1,IREJ1)
4168C 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'
4171 IRFRAG = IRFRAG+1
4172 GOTO 9999
4173 ENDIF
4174*
4175* get final state particles from /DTEVTP/
4176*! uncomment this line for internal phojet-fragmentation
4177C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4178
4179 IF (IJPROJ.NE.7)
4180 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4181C IF (IREJ3.NE.0) GOTO 9999
4182
4183 RETURN
4184
4185 9999 CONTINUE
4186 IREVT = IREVT+1
4187 IREJ = 1
4188 RETURN
4189 END
4190*
4191*===getpje=============================================================*
4192*
4193CDECK ID>, DT_GETPJE
4194 SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4195
4196************************************************************************
4197* This subroutine copies PHOJET partons and strings from POEVT1 into *
4198* DTEVT1. *
4199* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
4200* PP,PT 4-momenta of projectile/target being handled by *
4201* PHOJET *
4202* This version dated 11.12.99 is written by S. Roesler *
4203************************************************************************
4204
4205 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4206 SAVE
4207
4208 PARAMETER ( LINP = 5 ,
4209 & LOUT = 6 ,
4210 & LDAT = 9 )
4211
4212 PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4213 & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4214
4215 LOGICAL LFLIP
4216
4217* event history
4218
4219 PARAMETER (NMXHKK=200000)
4220
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),
4227 & IHIST(2,NMXHKK)
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
4239* statistics
4240 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4241 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4242 & ICEVTG(8,0:30)
4243* rejection counter
4244 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4245 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4246 & IREXCI(3),IRDIFF(2),IRINC
4247
4248C standard particle data interface
4249 INTEGER NMXHEP
4250
4251 PARAMETER (NMXHEP=4000)
4252
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),
4257 & VHEP(4,NMXHEP)
4258C extension to standard particle data interface (PHOJET specific)
4259 INTEGER IMPART,IPHIST,ICOLOR
4260 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4261
4262C color string configurations including collapsed strings and hadrons
4263 INTEGER MSTR
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
4269C general process information
4270 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4271 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4272C model switches and parameters
4273 CHARACTER*8 MDLNA
4274 INTEGER ISWMDL,IPAMDL
4275 DOUBLE PRECISION PARMDL
4276 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4277C event debugging information
4278 INTEGER NMAXD
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
4284
4285 DIMENSION PP(4),PT(4)
4286 DATA MAXLOP /10000/
4287
4288 INHKK = NHKK
4289 LFLIP = .TRUE.
4290 1 CONTINUE
4291 NPVAL = 0
4292 NTVAL = 0
4293 IREJ = 0
4294
4295* store initial momenta for energy-momentum conservation check
4296 IF (LEMCCK) THEN
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)
4299 ENDIF
4300* copy partons and strings from POEVT1 into DTEVT1
4301 DO 11 I=1,ISTR
4302C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4303 IF (NCODE(I).EQ.-99) THEN
4304 IDXSTG = NPOS(1,I)
4305 IDSTG = IDHEP(IDXSTG)
4306 PX = PHEP(1,IDXSTG)
4307 PY = PHEP(2,IDXSTG)
4308 PZ = PHEP(3,IDXSTG)
4309 PE = PHEP(4,IDXSTG)
4310 IF (MODE.LT.0) THEN
4311 ISTAT = 70000+IPJE
4312 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4313 & 11,IDSTG,0)
4314 IF (LEMCCK) THEN
4315 PX = -PX
4316 PY = -PY
4317 PZ = -PZ
4318 PE = -PE
4319 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4320 ENDIF
4321 ELSE
4322 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4323 & PPX,PPY,PPZ,PPE)
4324 ISTAT = 70000+IPJE
4325 CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4326 & 11,IDSTG,0)
4327 IF (LEMCCK) THEN
4328 PX = -PPX
4329 PY = -PPY
4330 PZ = -PPZ
4331 PE = -PPE
4332 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4333 ENDIF
4334 ENDIF
4335 NOBAM(NHKK) = 0
4336 IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4337 IHIST(2,NHKK) = 0
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)),' ! '
4345 STOP ' GETPJE 1'
4346 ENDIF
4347 IDXSTG = 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
4352 IDXMS1 = IDXSTG
4353 IDXMS2 = IDXSTG
4354C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4355 ENDIF
4356* search POEVT1 for the original hadron of the parton
4357 ILOOP = 0
4358 IPOM1 = 0
4359 14 CONTINUE
4360 ILOOP = ILOOP+1
4361
4362 IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4363
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 ! '
4368 IPOM2 = 0
4369 ILOOP = 0
4370 15 CONTINUE
4371 ILOOP = ILOOP+1
4372
4373 IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4374
4375 IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4376 IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4377 ELSE
4378 IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4379 ENDIF
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 ! '
4383* parton 1
4384 IF (IDXMS1.EQ.1) THEN
4385 ISPTN1 = ISTHKK(MO1)
4386 M1PTN1 = MO1
4387 M2PTN1 = MO1+2
4388 ELSE
4389 ISPTN1 = ISTHKK(MO2)
4390 M1PTN1 = MO2-2
4391 M2PTN1 = MO2
4392 ENDIF
4393* parton 2
4394 IF (IDXMS2.EQ.1) THEN
4395 ISPTN2 = ISTHKK(MO1)
4396 M1PTN2 = MO1
4397 M2PTN2 = MO1+2
4398 ELSE
4399 ISPTN2 = ISTHKK(MO2)
4400 M1PTN2 = MO2-2
4401 M2PTN2 = MO2
4402 ENDIF
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.
4406 & (LFLIP)) THEN
4407 IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4408 ISPTN1 = ISTHKK(MO1)
4409 M1PTN1 = MO1
4410 M2PTN1 = MO1+2
4411 ISPTN2 = ISTHKK(MO2)
4412 M1PTN2 = MO2-2
4413 M2PTN2 = MO2
4414 ELSE
4415 ISPTN1 = ISTHKK(MO2)
4416 M1PTN1 = MO2-2
4417 M2PTN1 = MO2
4418 ISPTN2 = ISTHKK(MO1)
4419 M1PTN2 = MO1
4420 M2PTN2 = MO1+2
4421 ENDIF
4422 ENDIF
4423* register partons in temporary common
4424* parton at chain end
4425 PX = PHEP(1,IDX1)
4426 PY = PHEP(2,IDX1)
4427 PZ = PHEP(3,IDX1)
4428 PE = PHEP(4,IDX1)
4429* flag only partons coming from Pomeron with 41/42
4430C 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
4434 ISPTN1 = -(40+IMO)
4435 ELSE
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
4441 ISPTN1 = -(60+IMO)
4442 ELSE
4443 ISPTN1 = -(50+IMO)
4444 ENDIF
4445 ENDIF
4446 ENDIF
4447 IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4448 IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4449 IF (MODE.LT.0) THEN
4450 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4451 & PZ,PE,0,0,0)
4452 ELSE
4453 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4454 & PPX,PPY,PPZ,PPE)
4455 CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4456 & PPZ,PPE,0,0,0)
4457 ENDIF
4458 IHIST(1,NHKK) = IPHIST(1,IDX1)
4459 IHIST(2,NHKK) = 0
4460 DO 19 KK=1,4
4461 VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4462 WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4463 19 CONTINUE
4464 VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4465 WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4466 M1STRG = NHKK
4467* gluon kinks
4468 NGLUON = IDX2-IDX1-1
4469 IF (NGLUON.GT.0) THEN
4470 DO 17 IGLUON=1,NGLUON
4471 IDX = IDX1+IGLUON
4472 IDXMS = ABS(JMOHEP(1,IDX))
4473 IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4474 ILOOP = 0
4475 16 CONTINUE
4476 ILOOP = ILOOP+1
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 ! '
4482 ENDIF
4483 IF (IDXMS.EQ.1) THEN
4484 ISPTN = ISTHKK(MO1)
4485 M1PTN = MO1
4486 M2PTN = MO1+2
4487 ELSE
4488 ISPTN = ISTHKK(MO2)
4489 M1PTN = MO2-2
4490 M2PTN = MO2
4491 ENDIF
4492 PX = PHEP(1,IDX)
4493 PY = PHEP(2,IDX)
4494 PZ = PHEP(3,IDX)
4495 PE = PHEP(4,IDX)
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
4501 ISPTN = -(60+IMO)
4502 ELSE
4503 ISPTN = -(50+IMO)
4504 ENDIF
4505 ENDIF
4506 IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4507 IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4508 IF (MODE.LT.0) THEN
4509 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4510 & PX,PY,PZ,PE,0,0,0)
4511 ELSE
4512 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4513 & PPX,PPY,PPZ,PPE)
4514 CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4515 & PPX,PPY,PPZ,PPE,0,0,0)
4516 ENDIF
4517 IHIST(1,NHKK) = IPHIST(1,IDX)
4518 IHIST(2,NHKK) = 0
4519 DO 20 KK=1,4
4520 VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4521 WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4522 20 CONTINUE
4523 VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4524 WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4525 17 CONTINUE
4526 ENDIF
4527* parton at chain end
4528 PX = PHEP(1,IDX2)
4529 PY = PHEP(2,IDX2)
4530 PZ = PHEP(3,IDX2)
4531 PE = PHEP(4,IDX2)
4532* flag only partons coming from Pomeron with 41/42
4533C 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
4537 ISPTN2 = -(40+IMO)
4538 ELSE
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
4544 ISPTN2 = -(60+IMO)
4545 ELSE
4546 ISPTN2 = -(50+IMO)
4547 ENDIF
4548 ENDIF
4549 ENDIF
4550 IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4551 IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4552 IF (MODE.LT.0) THEN
4553 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4554 & PX,PY,PZ,PE,0,0,0)
4555 ELSE
4556 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4557 & PPX,PPY,PPZ,PPE)
4558 CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4559 & PPX,PPY,PPZ,PPE,0,0,0)
4560 ENDIF
4561 IHIST(1,NHKK) = IPHIST(1,IDX2)
4562 IHIST(2,NHKK) = 0
4563 DO 21 KK=1,4
4564 VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4565 WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4566 21 CONTINUE
4567 VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4568 WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4569 M2STRG = NHKK
4570* register string
4571 JSTRG = 100*IPROCE+NCODE(I)
4572 PX = PHEP(1,IDXSTG)
4573 PY = PHEP(2,IDXSTG)
4574 PZ = PHEP(3,IDXSTG)
4575 PE = PHEP(4,IDXSTG)
4576 IF (MODE.LT.0) THEN
4577 ISTAT = 70000+IPJE
4578 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4579 & PX,PY,PZ,PE,0,0,0)
4580 IF (LEMCCK) THEN
4581 PX = -PX
4582 PY = -PY
4583 PZ = -PZ
4584 PE = -PE
4585 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4586 ENDIF
4587 ELSE
4588 CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4589 & PPX,PPY,PPZ,PPE)
4590 ISTAT = 70000+IPJE
4591 CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4592 & PPX,PPY,PPZ,PPE,0,0,0)
4593 IF (LEMCCK) THEN
4594 PX = -PPX
4595 PY = -PPY
4596 PZ = -PPZ
4597 PE = -PPE
4598 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4599 ENDIF
4600 ENDIF
4601 NOBAM(NHKK) = 0
4602 IHIST(1,NHKK) = 0
4603 IHIST(2,NHKK) = 0
4604 DO 18 KK=1,4
4605 VHKK(KK,NHKK) = VHKK(KK,MO2)
4606 WHKK(KK,NHKK) = WHKK(KK,MO1)
4607 18 CONTINUE
4608 VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4609 WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4610 ENDIF
4611 11 CONTINUE
4612
4613 IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4614 NHKK = INHKK
4615 LFLIP = .FALSE.
4616 GOTO 1
4617 ENDIF
4618
4619 IF (LEMCCK) THEN
4620 IF (UMO.GT.1.0D5) THEN
4621 CHKLEV = 1.0D0
4622 ELSE
4623 CHKLEV = TINY1
4624 ENDIF
4625 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4626
4627 IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4628
4629 ENDIF
4630
4631* internal statistics
4632* dble-Po statistics.
4633 IF (IPROCE.NE.4) IPOPO = 0
4634
4635 INTFLG = IPROCE
4636 IDCHSY = IDCH(MO1)
4637 IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4638 ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4639 ELSE
4640 WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4641 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
4642 & ') at evt(chain) ',I6,'(',I2,')')
4643 ENDIF
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
4647 ELSE
4648C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4649 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
4650 & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4651 ENDIF
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
4655 ELSE
4656C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4657 ENDIF
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
4669 ELSE
4670 WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4671 ENDIF
4672 ENDIF
4673 IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4674 & THEN
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
4678 ENDIF
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)
4684
4685 RETURN
4686
4687 9999 CONTINUE
4688 IREJ = 1
4689 RETURN
4690 END
4691*
4692*===phoini=============================================================*
4693*
4694CDECK ID>, DT_PHOINI
4695 SUBROUTINE DT_PHOINI
4696
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************************************************************************
4702
4703 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4704 SAVE
4705
4706 PARAMETER ( LINP = 5 ,
4707 & LOUT = 6 ,
4708 & LDAT = 9 )
4709
4710 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4711
4712* nucleon-nucleon event-generator
4713 CHARACTER*8 CMODEL
4714 LOGICAL LPHOIN
4715 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4716* particle properties (BAMJET index convention)
4717 CHARACTER*8 ANAME
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
4727
4728 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4729
4730* emulsion treatment
4731 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4732 & NCOMPO,IEMUL
4733* VDM parameter for photon-nucleus interactions
4734 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4735* nuclear potential
4736 LOGICAL LFERMI
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
4741 LOGICAL LPROD
4742 CHARACTER*8 CGLB
4743 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4744*
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
4755 DATA IPARPD /
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/
4758* number of set
4759 DATA ISETPD /
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/
4762
4763**PHOJET105a
4764C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4765C PARAMETER ( MAXPRO = 16 )
4766C PARAMETER ( MAXTAB = 20 )
4767C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4768C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4769C CHARACTER*8 MDLNA
4770C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4771C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4772**PHOJET110
4773C global event kinematics and particle IDs
4774 INTEGER IFPAP,IFPAB
4775 DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4776 COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4777C hard cross sections and MC selection weights
4778 INTEGER Max_pro_2
4779 PARAMETER ( Max_pro_2 = 16 )
4780 INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4781 & MH_acc_1,MH_acc_2
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)
4788C model switches and parameters
4789 CHARACTER*8 MDLNA
4790 INTEGER ISWMDL,IPAMDL
4791 DOUBLE PRECISION PARMDL
4792 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4793C general process information
4794 INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4795 COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4796**
4797 DIMENSION PP(4),PT(4)
4798
4799 LOGICAL LSTART
4800 DATA LSTART /.TRUE./
4801
4802 IJP = IJPROJ
4803 IJT = IJTARG
4804 Q2 = VIRT
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
4807 IJP = 7
4808 Q2 = ZERO
4809 ENDIF
4810
4811 IF (LPHOIN) CALL PHO_INIT(-1,IDUM)
4812
4813* switch Reggeon off
4814C IPAMDL(3)= 0
4815 IF (IP.EQ.1) THEN
4816 IFPAP(1) = IDT_IPDGHA(IJP)
4817 IFPAB(1) = IJP
4818 ELSE
4819 IFPAP(1) = 2212
4820 IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4821 ENDIF
4822 PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4823 PVIRT(1) = PMASS(1)**2
4824 IF (IT.EQ.1) THEN
4825 IFPAP(2) = IDT_IPDGHA(IJT)
4826 IFPAB(2) = IJT
4827 ELSE
4828 IFPAP(2) = 2212
4829 IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4830 ENDIF
4831 PMASS(2) = AAM(IFPAB(2))
4832 PVIRT(2) = ZERO
4833 DO 1 K=1,4
4834 PP(K) = ZERO
4835 PT(K) = ZERO
4836 1 CONTINUE
4837* get max. possible momenta of incoming particles to be used for PHOJET ini.
4838 PPF = ZERO
4839 PTF = ZERO
4840 SCPF= 1.5D0
4841 IF (UMO.GE.1.E5) THEN
4842 SCPF= 5.0D0
4843 ENDIF
4844 IF (NCOMPO.GT.0) THEN
4845 DO 2 I=1,NCOMPO
4846 IF (IT.GT.1) THEN
4847 CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4848 ELSE
4849 CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4850 ENDIF
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
4855 2 CONTINUE
4856 ELSE
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))
4860 ENDIF
4861 PTF = -PTF
4862 PPF = SCPF*PPF
4863 PTF = SCPF*PTF
4864 IF (IJP.EQ.7) THEN
4865 AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4866 PP(3) = PPCM
4867 PP(4) = SQRT(AMP2+PP(3)**2)
4868 ELSE
4869 EPF = SQRT(PPF**2+PMASS(1)**2)
4870 CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4871 ENDIF
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)
4876 IF (LSTART) THEN
4877C *** Commented by Chiara
4878C WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4879 1001 FORMAT(
4880 & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
4881 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4882C *** Commented by Chiara
4883C IF (NCOMPO.GT.0) THEN
4884C WRITE(LOUT,1002) SCPF,PTF,PT
4885C ELSE
4886C WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4887C ENDIF
4888 1002 FORMAT(
4889 & ' DT_PHOINI: PHOJET initialized for target emulsion ',
4890 & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4891 1003 FORMAT(
4892 & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
4893 & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
4894C *** Commented by Chiara
4895C WRITE(LOUT,1004) ECMINI
4896 1004 FORMAT(' E_cm = ',E10.3)
4897 IF (IJP.EQ.8) WRITE(LOUT,1005)
4898 1005 FORMAT(
4899 & ' DT_PHOINI: warning! proton parameters used for neutron',
4900 & ' projectile')
4901 LSTART = .FALSE.
4902 ENDIF
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)
4909 ENDIF
4910*
4911C IF (IJP.EQ.7) THEN
4912C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
4913C PP(3) = PPCM
4914C PP(4) = SQRT(AMP2+PP(3)**2)
4915C ELSE
4916C PFERMX = ZERO
4917C IF (IP.GT.1) PFERMX = 0.5D0
4918C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4919C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4920C ENDIF
4921C PFERMX = ZERO
4922C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4923C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4924C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4925**sr 26.10.96
4926 ISAV = IPAMDL(13)
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
4930**
4931
4932 CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4933
4934**sr 26.10.96
4935 IPAMDL(13) = ISAV
4936**
4937*
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
4942 WRITE(LOUT,1006)
4943 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4944 & ' assiged (ID,IPAR,ISET)',/)
4945 NPDF = 0
4946 DO 3 I=1,30
4947 IF (IPARPD(I).NE.0) THEN
4948 NPDF = NPDF+1
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)
4952 IPAR = IPARPD(I)
4953 ISET = ISETPD(I)
4954 WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4955 CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4956 ENDIF
4957 ENDIF
4958 3 CONTINUE
4959 ENDIF
4960
4961C CALL PHO_PHIST(-1,SIGMAX)
4962
4963 IF (IREJ1.NE.0) THEN
4964 WRITE(LOUT,1000)
4965 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
4966 STOP
4967 ENDIF
4968
4969 RETURN
4970 END
4971
4972*
4973*===eventd=============================================================*
4974*
4975CDECK ID>, DT_EVENTD
4976 SUBROUTINE DT_EVENTD(IREJ)
4977
4978************************************************************************
4979* Quasi-elastic neutrino nucleus scattering. *
4980* This version dated 29.04.00 is written by S. Roesler. *
4981************************************************************************
4982
4983 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4984 SAVE
4985
4986 PARAMETER ( LINP = 5 ,
4987 & LOUT = 6 ,
4988 & LDAT = 9 )
4989
4990 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4991 PARAMETER (SQTINF=1.0D+15)
4992
4993 LOGICAL LFIRST
4994
4995* event history
4996
4997 PARAMETER (NMXHKK=200000)
4998
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),
5005 & IHIST(2,NMXHKK)
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
5010
5011 PARAMETER (MAXLND=4000)
5012 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5013
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
5019* nuclear potential
5020 LOGICAL LFERMI
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
5027
5028 INTEGER PYK
5029
5030 DATA LFIRST /.TRUE./
5031
5032 IREJ = 0
5033
5034 IF (LFIRST) THEN
5035 LFIRST = .FALSE.
5036 CALL DT_MASS_INI
5037 ENDIF
5038
5039* JETSET parameter
5040 CALL DT_INITJS(0)
5041
5042* interacting target nucleon
5043 LTYP = NEUTYP
5044 IF (NEUDEC.LE.9) THEN
5045 IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5046 NUCTYP = 2112
5047 NUCTOP = 2
5048 ELSE
5049 NUCTYP = 2212
5050 NUCTOP = 1
5051 ENDIF
5052 ELSE
5053 RTYP = DT_RNDM(RTYP)
5054 ZFRAC = DBLE(ITZ)/DBLE(IT)
5055 IF (RTYP.LE.ZFRAC) THEN
5056 NUCTYP = 2212
5057 NUCTOP = 1
5058 ELSE
5059 NUCTYP = 2112
5060 NUCTOP = 2
5061 ENDIF
5062 ENDIF
5063
5064* select first nucleon in list with matching id and reset all other
5065* nucleons which have been marked as "wounded" by ININUC
5066 IFOUND = 0
5067 DO 1 I=1,NHKK
5068 IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5069 ISTHKK(I) = 12
5070 IFOUND = 1
5071 IDX = I
5072 ELSE
5073 IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5074 ENDIF
5075 1 CONTINUE
5076 IF (IFOUND.EQ.0)
5077 & STOP ' EVENTD: interacting target nucleon not found! '
5078
5079* correct position of proj. lepton: assume position of target nucleon
5080 DO 3 I=1,4
5081 VHKK(I,1) = VHKK(I,IDX)
5082 WHKK(I,1) = WHKK(I,IDX)
5083 3 CONTINUE
5084
5085* load initial momenta for conservation check
5086 IF (LEMCCK) THEN
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),
5089 & 2,IDUM,IDUM)
5090 ENDIF
5091
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))
5104 ENDIF
5105
5106* get final state particles from Lund-common and write them into HKKEVT
5107 NPOINT(1) = NHKK+1
5108 NPOINT(4) = NHKK+1
5109
5110 NLINES = PYK(0,1)
5111
5112 NHKK0 = NHKK+1
5113 DO 4 I=4,NLINES
5114 IF (K(I,1).EQ.1) THEN
5115 ID = K(I,2)
5116 PX = P(I,1)
5117 PY = P(I,2)
5118 PZ = P(I,3)
5119 PE = P(I,4)
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
5125 ENDIF
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)
5130C IF (I.EQ.4) THEN
5131C WHKK(1,NHKK) = POLARX(1)
5132C WHKK(2,NHKK) = POLARX(2)
5133C WHKK(3,NHKK) = POLARX(3)
5134C WHKK(4,NHKK) = POLARX(4)
5135C ELSE
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)
5140C ENDIF
5141 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5142 ENDIF
5143 4 CONTINUE
5144
5145 IF (LEMCCK) THEN
5146 CHKLEV = TINY5
5147 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5148 IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5149 ENDIF
5150
5151* transform momenta into cms (as required for inc etc.)
5152 DO 5 I=NHKK0,NHKK
5153 IF (ISTHKK(I).EQ.1) THEN
5154 CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5155 PHKK(3,I) = PZ
5156 PHKK(4,I) = PE
5157 ENDIF
5158 5 CONTINUE
5159
5160 RETURN
5161 END
5162*
5163*===kkevnt=============================================================*
5164*
5165CDECK ID>, DT_KKEVNT
5166 SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5167
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************************************************************************
5175
5176 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5177 SAVE
5178
5179 PARAMETER ( LINP = 5 ,
5180 & LOUT = 6 ,
5181 & LDAT = 9 )
5182
5183 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5184
5185 PARAMETER ( MAXNCL = 260,
5186
5187 & MAXVQU = MAXNCL,
5188 & MAXSQU = 20*MAXVQU,
5189 & MAXINT = MAXVQU+MAXSQU)
5190* event history
5191
5192 PARAMETER (NMXHKK=200000)
5193
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),
5200 & IHIST(2,NMXHKK)
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
5205* rejection counter
5206 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5207 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5208 & IREXCI(3),IRDIFF(2),IRINC
5209* statistics
5210 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5211 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5212 & ICEVTG(8,0:30)
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
5223 CHARACTER*8 CMODEL
5224 LOGICAL LPHOIN
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
5236**temporary
5237* statistics: Glauber-formalism
5238 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5239**
5240
5241 DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5242
5243 IREJ = 0
5244 ICREQU = ICREQU+1
5245 NC = 0
5246
5247 1 CONTINUE
5248 ICSAMP = ICSAMP+1
5249 NC = NC+1
5250 IF (MOD(NC,10).EQ.0) THEN
5251 WRITE(LOUT,1000) NEVHKK
5252 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5253 GOTO 9999
5254 ENDIF
5255
5256* initialize DTEVT1/DTEVT2
5257 CALL DT_EVTINI
5258
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
5262* in this case.
5263 IF (MCGENE.EQ.4) THEN
5264 JJPROJ = 1
5265 ELSE
5266 JJPROJ = IJPROJ
5267 ENDIF
5268
5269 10 CONTINUE
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'
5279 NWTSAM = NN
5280 NWASAM = NP
5281 NWBSAM = NT
5282 NEVOLD = NEVHKK
5283 IPOLD = IP
5284 ITOLD = IT
5285 JJPOLD = JJPROJ
5286 EPROLD = EPROJ
5287 ENDIF
5288
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
5292 NEVOLD = 0
5293 GOTO 10
5294 ENDIF
5295
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
5300 ENDIF
5301
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)
5305 MODE = 2
5306 IF (EPROJ.LE.EHADTH) MODE = 3
ba758f5a 5307 CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
d30b8254 5308
5309 IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5310
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)
5316 RR = DT_RNDM(FRAC)
5317 IF (RR.GT.FRAC) THEN
5318 IF (IP.EQ.1) THEN
5319 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5320 IF (IREJ1.GT.0) GOTO 1
5321 RETURN
5322 ELSE
5323 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5324 ENDIF
5325 ENDIF
5326 ELSE
5327* fixed threshold for onset of production via HADRIN
5328 IF (EPROJ.LE.EHADTH) THEN
5329 IF (IP.EQ.1) THEN
5330 CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5331 IF (IREJ1.GT.0) GOTO 1
5332 RETURN
5333 ELSE
5334 WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5335 ENDIF
5336 ENDIF
5337 ENDIF
5338 ENDIF
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')
5343
5344* sampling of momentum-x fractions & flavors of chain ends
5345 CALL DT_SPLPTN(NN)
5346
5347* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5348 CALL DT_NUC2CM
5349
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
5353
5354 ENDIF
5355
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'
5362 GOTO 1
5363 ENDIF
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'
5369 GOTO 1
5370 ENDIF
5371 ELSEIF (MCGENE.EQ.3) THEN
5372
5373 STOP ' This version does not contain LEPTO !'
5374
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'
5380 GOTO 1
5381 ENDIF
5382 ELSE
5383 WRITE(LOUT,1002) MCGENE
5384 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
5385 & ' not available - program stopped')
5386 STOP
5387 ENDIF
5388
5389 RETURN
5390
5391 9999 CONTINUE
5392 IREJ = 1
5393 RETURN
5394 END
5395*
5396*===chkcen=============================================================*
5397*
5398CDECK ID>, DT_CHKCEN
5399 SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5400
5401************************************************************************
5402* Check of number of involved projectile nucleons if central production*
5403* is requested. *
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************************************************************************
5408
5409 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5410 SAVE
5411
5412 PARAMETER ( LINP = 5 ,
5413 & LOUT = 6 ,
5414 & LDAT = 9 )
5415
5416* statistics
5417 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5418 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5419 & ICEVTG(8,0:30)
5420* central particle production, impact parameter biasing
5421 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5422
5423 IBACK = 0
5424
5425* old version
5426 IF (ICENTR.EQ.2) THEN
5427 IF (IP.LT.IT) THEN
5428 IF (IP.LE.8) 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
5436 ENDIF
5437 ELSEIF (IP.EQ.IT) THEN
5438 IF (IP.EQ.32) THEN
5439 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5440 ELSE
5441 IF (NP.LT.IP-IP/8) IBACK = 1
5442 ENDIF
5443 ELSEIF (ABS(IP-IT).LT.3) THEN
5444 IF (NP.LT.IP-IP/8) IBACK = 1
5445 ENDIF
5446 ELSE
5447* new version (DPMJET, 5.6.99)
5448 IF (IP.LT.IT) THEN
5449 IF (IP.LE.8) THEN
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
5456 IF (IT.LE.150) THEN
5457* Example: S-Ag
5458 IF (NP.LT.IP-1) IBACK = 1
5459 ELSE
5460* Example: S-Au
5461 IF (NP.LT.IP) IBACK = 1
5462 ENDIF
5463 ENDIF
5464 ELSEIF (IP.EQ.IT) THEN
5465* Example: S-S
5466 IF (IP.EQ.32) THEN
5467 IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5468* Example: Pb-Pb
5469 ELSE
5470 IF (NP.LT.IP-IP/4) IBACK = 1
5471 ENDIF
5472 ELSEIF (ABS(IP-IT).LT.3) THEN
5473 IF (NP.LT.IP-IP/8) IBACK = 1
5474 ENDIF
5475 ENDIF
5476
5477 ICCPRO = ICCPRO+1
5478
5479 RETURN
5480 END
5481*
5482*===ininuc=============================================================*
5483*
5484CDECK ID>, DT_ININUC
5485 SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5486
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************************************************************************
5502
5503 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5504 SAVE
5505
5506 PARAMETER ( LINP = 5 ,
5507 & LOUT = 6 ,
5508 & LDAT = 9 )
5509
5510 PARAMETER (FM2MM=1.0D-12)
5511
5512 PARAMETER ( MAXNCL = 260,
5513
5514 & MAXVQU = MAXNCL,
5515 & MAXSQU = 20*MAXVQU,
5516 & MAXINT = MAXVQU+MAXSQU)
5517* event history
5518
5519 PARAMETER (NMXHKK=200000)
5520
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),
5527 & IHIST(2,NMXHKK)
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)
5534* nuclear potential
5535 LOGICAL LFERMI
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)
5542 CHARACTER*8 ANAME
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
5558
5559 DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5560
5561* number of neutrons
5562 NNEU = NMASS-NCH
5563* initializations
5564 NP = 0
5565 NN = 0
5566 DO 1 K=1,4
5567 PFTOT(K) = 0.0D0
5568 1 CONTINUE
5569 MODE = IMODE
5570 IF (IMODE.GT.2) MODE = 2
5571**sr 29.5. new NPOINT(1)-definition
5572C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5573**
5574 NHADRI = 0
5575 NC = NHKK
5576
5577* get initial configuration
5578 DO 2 I=1,NMASS
5579 NHKK = NHKK+1
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
5584 NHADRI = NHADRI+1
5585 IF (NHADRI.EQ.1) IDXTA = NHKK
5586 IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5587 ENDIF
5588 ELSE
5589 ISTHKK(NHKK) = 12+MODE
5590 ENDIF
5591 IF (NMASS.GE.2) THEN
5592* treatment for nuclei
5593 FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5594 RR = DT_RNDM(FRAC)
5595 IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5596 IDX = 8
5597 NN = NN+1
5598 ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5599 IDX = 1
5600 NP = NP+1
5601 ELSEIF (NN.LT.NNEU) THEN
5602 IDX = 8
5603 NN = NN+1
5604 ELSEIF (NP.LT.NCH) THEN
5605 IDX = 1
5606 NP = NP+1
5607 ENDIF
5608 IDHKK(NHKK) = IDT_IPDGHA(IDX)
5609 IDBAM(NHKK) = IDX
5610 IF (MODE.EQ.1) THEN
5611 IPOSP(I) = NHKK
5612 KKPROJ(I) = IDX
5613 ELSE
5614 IPOST(I) = NHKK
5615 KKTARG(I) = IDX
5616 ENDIF
5617 IF (IDX.EQ.1) THEN
5618 PFER = PFERMP(MODE)
5619 PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5620 ELSE
5621 PFER = PFERMN(MODE)
5622 PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5623 ENDIF
5624 CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5625 DO 3 K=1,4
5626 PFTOT(K) = PFTOT(K)+PF(K)
5627 PHKK(K,NHKK) = PF(K)
5628 3 CONTINUE
5629 PHKK(5,NHKK) = AAM(IDX)
5630 ELSE
5631* treatment for hadrons
ba758f5a 5632
d30b8254 5633 IDHKK(NHKK) = IDT_IPDGHA(ID)
5634 IDBAM(NHKK) = ID
5635 PHKK(4,NHKK) = AAM(ID)
5636 PHKK(5,NHKK) = AAM(ID)
ba758f5a 5637
5638C * VDM assumption
d30b8254 5639C IF (IDHKK(NHKK).EQ.22) THEN
5640C PHKK(4,NHKK) = AAM(33)
5641C PHKK(5,NHKK) = AAM(33)
5642C ENDIF
5643 IF (MODE.EQ.1) THEN
5644 IPOSP(I) = NHKK
5645 KKPROJ(I) = ID
5646 PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5647 ELSE
5648 IPOST(I) = NHKK
5649 KKTARG(I) = ID
5650 ENDIF
5651 ENDIF
5652 DO 4 K=1,3
5653 VHKK(K,NHKK) = COORD(K,I)*FM2MM
5654 WHKK(K,NHKK) = COORD(K,I)*FM2MM
5655 4 CONTINUE
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
5660 2 CONTINUE
5661
5662* balance Fermi-momenta
5663 IF (NMASS.GE.2) THEN
5664 DO 5 I=1,NMASS
5665 NC = NC+1
5666 DO 6 K=1,3
5667 PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5668 6 CONTINUE
5669 PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5670 & PHKK(2,NC)**2+PHKK(3,NC)**2)
5671 5 CONTINUE
5672 ENDIF
5673
5674 RETURN
5675 END
5676*
5677*===fer4m==============================================================*
5678*
5679CDECK ID>, DT_FER4M
5680 SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5681
5682************************************************************************
5683* Sampling of nucleon Fermi-momenta from distributions at T=0. *
5684* processed by S. Roesler, 17.10.95 *
5685************************************************************************
5686
5687 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5688 SAVE
5689
5690 PARAMETER ( LINP = 5 ,
5691 & LOUT = 6 ,
5692 & LDAT = 9 )
5693
5694 LOGICAL LSTART
5695
5696* particle properties (BAMJET index convention)
5697 CHARACTER*8 ANAME
5698 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5699 & IICH(210),IIBAR(210),K1(210),K2(210)
5700* nuclear potential
5701 LOGICAL LFERMI
5702 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5703 & EBINDP(2),EBINDN(2),EPOT(2,210),
5704 & ETACOU(2),ICOUL,LFERMI
5705
5706 DATA LSTART /.TRUE./
5707
5708 ILOOP = 0
5709 IF (LFERMI) THEN
5710 IF (LSTART) THEN
5711 WRITE(LOUT,1000)
5712 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
5713 LSTART = .FALSE.
5714 ENDIF
5715 1 CONTINUE
5716 CALL DT_DFERMI(PABS)
5717 PABS = PFERM*PABS
5718C IF (PABS.GE.PBIND) THEN
5719C ILOOP = ILOOP+1
5720C IF (MOD(ILOOP,500).EQ.0) THEN
5721C WRITE(LOUT,1001) PABS,PBIND,ILOOP
5722C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
5723C & ' energy ',2E12.3,I6)
5724C ENDIF
5725C GOTO 1
5726C ENDIF
5727 CALL DT_DPOLI(POLC,POLS)
5728 CALL DT_DSFECF(SFE,CFE)
5729 CXTA = POLS*CFE
5730 CYTA = POLS*SFE
5731 CZTA = POLC
5732 ET = SQRT(PABS*PABS+AAM(KT)**2)
5733 PXT = CXTA*PABS
5734 PYT = CYTA*PABS
5735 PZT = CZTA*PABS
5736 ELSE
5737 ET = AAM(KT)
5738 PXT = 0.0D0
5739 PYT = 0.0D0
5740 PZT = 0.0D0
5741 ENDIF
5742
5743 RETURN
5744 END
5745*
5746*===nuc2cm=============================================================*
5747*
5748CDECK ID>, DT_NUC2CM
5749 SUBROUTINE DT_NUC2CM
5750
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************************************************************************
5756
5757 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5758 SAVE
5759
5760 PARAMETER ( LINP = 5 ,
5761 & LOUT = 6 ,
5762 & LDAT = 9 )
5763
5764 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5765
5766* event history
5767
5768 PARAMETER (NMXHKK=200000)
5769
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),
5776 & IHIST(2,NMXHKK)
5777* statistics
5778 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5779 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5780 & ICEVTG(8,0:30)
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)
5784 CHARACTER*8 ANAME
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
5790**temporary
5791* statistics: Glauber-formalism
5792 COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5793**
5794
5795 ICWP = 0
5796 ICWT = 0
5797 NWTACC = 0
5798 NWAACC = 0
5799 NWBACC = 0
5800
5801 NPOINT(1) = NHKK+1
5802 NEND = NHKK
5803 DO 1 I=1,NEND
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
5807 MODE = ISTHKK(I)-9
5808C IF (IDHKK(I).EQ.22) THEN
5809C* VDM assumption
5810C PEIN = AAM(33)
5811C IDB = 33
5812C ELSE
5813C PEIN = PHKK(4,I)
5814C IDB = IDBAM(I)
5815C ENDIF
5816C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5817C & 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)
5821 ELSE
5822 PX = PGAMM(1)
5823 PY = PGAMM(2)
5824 PZ = PGAMM(3)
5825 PE = PGAMM(4)
5826 ENDIF
5827 IST = ISTHKK(I)-2
5828 ID = IDHKK(I)
5829C* VDM assumption
5830C 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
5834 ENDIF
5835 1 CONTINUE
5836
5837 NWTACC = MAX(NWAACC,NWBACC)
5838 ICDPR = ICDPR+ICWP
5839 ICDTA = ICDTA+ICWT
5840**temporary
5841 IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5842 CALL DT_EVTOUT(4)
5843 STOP
5844 ENDIF
5845
5846 RETURN
5847 END
5848*
5849*===splptn=============================================================*
5850*
5851CDECK ID>, DT_SPLPTN
5852 SUBROUTINE DT_SPLPTN(NN)
5853
5854************************************************************************
5855* SamPLing of ParToN momenta and flavors. *
5856* This version dated 15.01.95 is written by S. Roesler *
5857************************************************************************
5858
5859 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5860 SAVE
5861
5862 PARAMETER ( LINP = 5 ,
5863 & LOUT = 6 ,
5864 & LDAT = 9 )
5865
5866* Lorentz-parameters of the current interaction
5867 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5868 & UMO,PPCM,EPROJ,PPROJ
5869
5870* sample flavors of sea-quarks
5871 CALL DT_SPLFLA(NN,1)
5872
5873* sample x-values of partons at chain ends
5874 ECM = UMO
5875 CALL DT_XKSAMP(NN,ECM)
5876
5877* samle flavors
5878 CALL DT_SPLFLA(NN,2)
5879
5880 RETURN
5881 END
5882*
5883*===splfla=============================================================*
5884*
5885CDECK ID>, DT_SPLFLA
5886 SUBROUTINE DT_SPLFLA(NN,MODE)
5887
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************************************************************************
5897
5898 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5899 SAVE
5900
5901 PARAMETER ( LINP = 5 ,
5902 & LOUT = 6 ,
5903 & LDAT = 9 )
5904
5905 PARAMETER ( MAXNCL = 260,
5906
5907 & MAXVQU = MAXNCL,
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)
5933 CHARACTER*8 ANAME
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,
5940 & LCO2CR,LINTPT
5941
5942 IF (MODE.EQ.1) THEN
5943* sea-flavors
5944 DO 1 I=1,NN
5945 IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5946 IPSAQ(I) = -IPSQ(I)
5947 1 CONTINUE
5948 DO 2 I=1,NN
5949 ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5950 ITSAQ(I)= -ITSQ(I)
5951 2 CONTINUE
5952 ELSEIF (MODE.EQ.2) THEN
5953* valence flavors
5954 DO 3 I=1,IXPV
5955 CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5956 3 CONTINUE
5957 DO 4 I=1,IXTV
5958 CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5959 4 CONTINUE
5960 ENDIF
5961
5962 RETURN
5963 END
5964*
5965*===getptn=============================================================*
5966*
5967CDECK ID>, DT_GETPTN
5968 SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5969
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************************************************************************
5975
5976 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5977 SAVE
5978
5979 PARAMETER ( LINP = 5 ,
5980 & LOUT = 6 ,
5981 & LDAT = 9 )
5982
5983 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5984
5985 LOGICAL LCHK
5986
5987 PARAMETER ( MAXNCL = 260,
5988
5989 & MAXVQU = MAXNCL,
5990 & MAXSQU = 20*MAXVQU,
5991 & MAXINT = MAXVQU+MAXSQU)
5992* event history
5993
5994 PARAMETER (NMXHKK=200000)
5995
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),
6002 & IHIST(2,NMXHKK)
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)
6009* statistics
6010 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6011 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6012 & ICEVTG(8,0:30)
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)
6042
6043 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6044
6045 DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6046
6047 IREJ = 0
6048 NCSY = 0
6049 NPOINT(2) = NHKK+1
6050
6051* sea-sea chains
6052 DO 10 I=1,NSS
6053 IF (ISKPCH(1,I).EQ.99) GOTO 10
6054 ICCHAI(1,1) = ICCHAI(1,1)+2
6055 IDXP = INTSS1(I)
6056 IDXT = INTSS2(I)
6057 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6058 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6059 DO 11 K=1,4
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)
6064 11 CONTINUE
6065 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6066 & +(PP1(3)+PT1(3))**2)
6067 ECH = PP1(4)+PT1(4)
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)
6071 ECH = PP2(4)+PT2(4)
6072 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6073 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6074 AM1 = SQRT(AM1)
6075 AM2 = SQRT(AM2)
6076 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6077C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6078 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6079 ENDIF
6080 ELSE
6081 WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6082 ENDIF
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),
6088 & 0,0,1)
6089 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6090 & 0,0,1)
6091 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6092 & 0,0,1)
6093 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6094 & 0,0,1)
6095 NCSY = NCSY+1
6096 10 CONTINUE
6097
6098* disea-sea chains
6099 DO 20 I=1,NDS
6100 IF (ISKPCH(2,I).EQ.99) GOTO 20
6101 ICCHAI(1,2) = ICCHAI(1,2)+2
6102 IDXP = INTDS1(I)
6103 IDXT = INTDS2(I)
6104 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6105 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6106 DO 21 K=1,4
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)
6111 21 CONTINUE
6112 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6113 & +(PP1(3)+PT1(3))**2)
6114 ECH = PP1(4)+PT1(4)
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)
6118 ECH = PP2(4)+PT2(4)
6119 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6120 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6121 AM1 = SQRT(AM1)
6122 AM2 = SQRT(AM2)
6123 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6124C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6125 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6126 ENDIF
6127 ELSE
6128 WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6129 ENDIF
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),
6135 & 0,0,2)
6136 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6137 & 0,0,2)
6138 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6139 & 0,0,2)
6140 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6141 & 0,0,2)
6142 NCSY = NCSY+1
6143 20 CONTINUE
6144
6145* sea-disea chains
6146 DO 30 I=1,NSD
6147 IF (ISKPCH(3,I).EQ.99) GOTO 30
6148 ICCHAI(1,3) = ICCHAI(1,3)+2
6149 IDXP = INTSD1(I)
6150 IDXT = INTSD2(I)
6151 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6152 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6153 DO 31 K=1,4
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)
6158 31 CONTINUE
6159 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6160 & +(PP1(3)+PT1(3))**2)
6161 ECH = PP1(4)+PT1(4)
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)
6165 ECH = PP2(4)+PT2(4)
6166 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6167 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6168 AM1 = SQRT(AM1)
6169 AM2 = SQRT(AM2)
6170 IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6171C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6172 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6173 ENDIF
6174 ELSE
6175 WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6176 ENDIF
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),
6182 & 0,0,3)
6183 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6184 & 0,0,3)
6185 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6186 & 0,0,3)
6187 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6188 & 0,0,3)
6189 NCSY = NCSY+1
6190 30 CONTINUE
6191
6192* disea-valence chains
6193 DO 50 I=1,NDV
6194 IF (ISKPCH(5,I).EQ.99) GOTO 50
6195 ICCHAI(1,5) = ICCHAI(1,5)+2
6196 IDXP = INTDV1(I)
6197 IDXT = INTDV2(I)
6198 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6199 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6200 DO 51 K=1,4
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)
6205 51 CONTINUE
6206 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6207 & +(PP1(3)+PT1(3))**2)
6208 ECH = PP1(4)+PT1(4)
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)
6212 ECH = PP2(4)+PT2(4)
6213 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6214 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6215 AM1 = SQRT(AM1)
6216 AM2 = SQRT(AM2)
6217 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6218C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6219 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6220 ENDIF
6221 ELSE
6222 WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6223 ENDIF
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),
6229 & 0,0,5)
6230 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6231 & 0,0,5)
6232 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6233 & 0,0,5)
6234 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6235 & 0,0,5)
6236 NCSY = NCSY+1
6237 50 CONTINUE
6238
6239* valence-sea chains
6240 DO 60 I=1,NVS
6241 IF (ISKPCH(6,I).EQ.99) GOTO 60
6242 ICCHAI(1,6) = ICCHAI(1,6)+2
6243 IDXP = INTVS1(I)
6244 IDXT = INTVS2(I)
6245 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6246 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6247 DO 61 K=1,4
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)
6252 61 CONTINUE
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)
6258 IF (LCHK) THEN
6259 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6260 & 0,0,6)
6261 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6262 & 0,0,6)
6263 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6264 & 0,0,6)
6265 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6266 & 0,0,6)
6267 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6268 & +(PP1(3)+PT1(3))**2)
6269 ECH = PP1(4)+PT1(4)
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)
6273 ECH = PP2(4)+PT2(4)
6274 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6275 ELSE
6276 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6277 & 0,0,6)
6278 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6279 & 0,0,6)
6280 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6281 & 0,0,6)
6282 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6283 & 0,0,6)
6284 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6285 & +(PP1(3)+PT2(3))**2)
6286 ECH = PP1(4)+PT2(4)
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)
6290 ECH = PP2(4)+PT1(4)
6291 AM1 = (ECH+PTOCH)*(ECH-PTOCH)
6292 ENDIF
6293 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6294 AM1 = SQRT(AM1)
6295 AM2 = SQRT(AM2)
6296 IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6297C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6298 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6299 ENDIF
6300 ELSE
6301 WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6302 ENDIF
6303 NCSY = NCSY+1
6304 60 CONTINUE
6305
6306* sea-valence chains
6307 DO 40 I=1,NSV
6308 IF (ISKPCH(4,I).EQ.99) GOTO 40
6309 ICCHAI(1,4) = ICCHAI(1,4)+2
6310 IDXP = INTSV1(I)
6311 IDXT = INTSV2(I)
6312 MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6313 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6314 DO 41 K=1,4
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)
6319 41 CONTINUE
6320 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6321 & +(PP1(3)+PT1(3))**2)
6322 ECH = PP1(4)+PT1(4)
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)
6326 ECH = PP2(4)+PT2(4)
6327 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6328 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6329 AM1 = SQRT(AM1)
6330 AM2 = SQRT(AM2)
6331 IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6332C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6333 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6334 ENDIF
6335 ELSE
6336 WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6337 ENDIF
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),
6343 & 0,0,4)
6344 CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6345 & 0,0,4)
6346 CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6347 & 0,0,4)
6348 CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6349 & 0,0,4)
6350 NCSY = NCSY+1
6351 40 CONTINUE
6352
6353* valence-disea chains
6354 DO 70 I=1,NVD
6355 IF (ISKPCH(7,I).EQ.99) GOTO 70
6356 ICCHAI(1,7) = ICCHAI(1,7)+2
6357 IDXP = INTVD1(I)
6358 IDXT = INTVD2(I)
6359 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6360 MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
6361 DO 71 K=1,4
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)
6366 71 CONTINUE
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)
6372 IF (LCHK) THEN
6373 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6374 & 0,0,7)
6375 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6376 & 0,0,7)
6377 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6378 & 0,0,7)
6379 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6380 & 0,0,7)
6381 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6382 & +(PP1(3)+PT1(3))**2)
6383 ECH = PP1(4)+PT1(4)
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)
6387 ECH = PP2(4)+PT2(4)
6388 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6389 ELSE
6390 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6391 & 0,0,7)
6392 CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6393 & 0,0,7)
6394 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6395 & 0,0,7)
6396 CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6397 & 0,0,7)
6398 PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6399 & +(PP1(3)+PT2(3))**2)
6400 ECH = PP1(4)+PT2(4)
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)
6404 ECH = PP2(4)+PT1(4)
6405 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6406 ENDIF
6407 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6408 AM1 = SQRT(AM1)
6409 AM2 = SQRT(AM2)
6410 IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6411C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6412 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6413 ENDIF
6414 ELSE
6415 WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6416 ENDIF
6417 NCSY = NCSY+1
6418 70 CONTINUE
6419
6420* valence-valence chains
6421 DO 80 I=1,NVV
6422 IF (ISKPCH(8,I).EQ.99) GOTO 80
6423 ICCHAI(1,8) = ICCHAI(1,8)+2
6424 IDXP = INTVV1(I)
6425 IDXT = INTVV2(I)
6426 MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6427 MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
6428 DO 81 K=1,4
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)
6433 81 CONTINUE
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)
6438
6439* check for diffractive event
6440 IDIFF = 0
6441 IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6442 & (IP.EQ.1).AND.(NN.EQ.1)) THEN
6443 DO 800 K=1,4
6444 PP(K) = PP1(K)+PP2(K)
6445 PT(K) = PT1(K)+PT2(K)
6446 800 CONTINUE
6447 ISTCK = NHKK
6448 CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6449 & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6450C IF (IREJ1.NE.0) GOTO 9999
6451 IF (IREJ1.NE.0) THEN
6452 IDIFF = 0
6453 NHKK = ISTCK
6454 ENDIF
6455 ELSE
6456 IDIFF = 0
6457 ENDIF
6458
6459 IF (IDIFF.EQ.0) THEN
6460* valence-valence chain system
6461 CALL DT_CHKCSY(IFP1,IFT1,LCHK)
6462 IF (LCHK) THEN
6463* baryon-baryon
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)
6474 ECH = PP1(4)+PT1(4)
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)
6478 ECH = PP2(4)+PT2(4)
6479 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6480 ELSE
6481* antibaryon-baryon
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)
6492 ECH = PP1(4)+PT2(4)
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)
6496 ECH = PP2(4)+PT1(4)
6497 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
6498 ENDIF
6499 IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6500 AM1 = SQRT(AM1)
6501 AM2 = SQRT(AM2)
6502 IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6503C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6504 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6505 ENDIF
6506 ELSE
6507 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6508 ENDIF
6509 NCSY = NCSY+1
6510 ENDIF
6511 80 CONTINUE
6512 IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6513
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,
6518 & 1,3,10,IREJ)
6519 ELSE
6520 IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6521 & 1,3,10,IREJ)
6522 ENDIF
6523 IF (IREJ.NE.0) THEN
6524 CALL DT_EVTOUT(4)
6525 STOP
6526 ENDIF
6527 ENDIF
6528
6529 RETURN
6530
6531 9999 CONTINUE
6532 IREJ = 1
6533 RETURN
6534 END
6535*
6536*===chkcsy=============================================================*
6537*
6538CDECK ID>, DT_CHKCSY
6539 SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6540
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************************************************************************
6548
6549 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6550 SAVE
6551
6552 PARAMETER ( LINP = 5 ,
6553 & LOUT = 6 ,
6554 & LDAT = 9 )
6555
6556 LOGICAL LCHK
6557
6558 LCHK = .TRUE.
6559
6560* q-aq chain
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.
6567* qq-aqaq chain
6568 ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6569 IF (ID1*ID2.GT.0) LCHK = .FALSE.
6570 ENDIF
6571
6572 RETURN
6573 END
6574*
6575*===eventa=============================================================*
6576*
6577CDECK ID>, DT_EVENTA
6578 SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6579
6580************************************************************************
6581* Treatment of nucleon-nucleon interactions in a two-chain *
6582* approximation. *
6583* (input) ID BAMJET-index of projectile hadron (in case of *
6584* h-K scattering) *
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************************************************************************
6590
6591 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6592 SAVE
6593
6594 PARAMETER ( LINP = 5 ,
6595 & LOUT = 6 ,
6596 & LDAT = 9 )
6597
6598 PARAMETER (TINY10=1.0D-10)
6599
6600* event history
6601
6602 PARAMETER (NMXHKK=200000)
6603
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),
6610 & IHIST(2,NMXHKK)
6611* rejection counter
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)
6618 CHARACTER*8 ANAME
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,
6629 & LCO2CR,LINTPT
6630
6631 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6632
6633 IREJ = 0
6634 NPOINT(3) = NHKK+1
6635
6636* skip following treatment for low-mass diffraction
6637 IF (ABS(IFLAGD).EQ.1) THEN
6638 NPOINT(3) = NPOINT(2)
6639 GOTO 5
6640 ENDIF
6641
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)
6645
6646 NC = NPOINT(2)
6647* get a two-chain system from DTEVT1
6648 DO 3 I=1,NCSY
6649 IFP1 = IDHKK(NC)
6650 IFT1 = IDHKK(NC+1)
6651 IFP2 = IDHKK(NC+2)
6652 IFT2 = IDHKK(NC+3)
6653 DO 4 K=1,4
6654 PP1(K) = PHKK(K,NC)
6655 PT1(K) = PHKK(K,NC+1)
6656 PP2(K) = PHKK(K,NC+2)
6657 PT2(K) = PHKK(K,NC+3)
6658 4 CONTINUE
6659 MOP1 = NC
6660 MOT1 = NC+1
6661 MOP2 = NC+2
6662 MOT2 = 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
6666 IRHHA = IRHHA+1
6667 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6668 GOTO 9999
6669 ENDIF
6670 NC = NC+4
6671 3 CONTINUE
6672
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
6677 ENDIF
6678
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'
6685 GOTO 9999
6686 ENDIF
6687 ENDIF
6688
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
6692 CALL DT_RESPT
6693
6694* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6695 IF (LCO2CR) CALL DT_COM2CR
6696
6697 5 CONTINUE
6698
6699* fragmentation of the complete event
6700**uncomment for internal phojet-fragmentation
6701C CALL DT_EVTFRA(IREJ1)
6702 CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6703 IF (IREJ1.GT.0) THEN
6704 IRFRAG = IRFRAG+1
6705 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6706 GOTO 9999
6707 ENDIF
6708
6709* decay of possible resonances (should be obsolete)
6710 CALL DT_DECAY1
6711
6712 RETURN
6713
6714 9999 CONTINUE
6715 IREVT = IREVT+1
6716 IREJ = 1
6717 RETURN
6718 END
6719*
6720*===getcsy=============================================================*
6721*
6722CDECK ID>, DT_GETCSY
6723 SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6724 & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6725
6726************************************************************************
6727* This version dated 15.01.95 is written by S. Roesler *
6728************************************************************************
6729
6730 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6731 SAVE
6732
6733 PARAMETER ( LINP = 5 ,
6734 & LOUT = 6 ,
6735 & LDAT = 9 )
6736
6737 PARAMETER (TINY10=1.0D-10)
6738
6739* event history
6740
6741 PARAMETER (NMXHKK=200000)
6742
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),
6749 & IHIST(2,NMXHKK)
6750* rejection counter
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
6760
6761 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6762 & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6763
6764 IREJ = 0
6765
6766* get quark content of partons
6767 DO 1 I=1,2
6768 IFP1(I) = 0
6769 IFP2(I) = 0
6770 IFT1(I) = 0
6771 IFT2(I) = 0
6772 1 CONTINUE
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)
6781
6782* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6783 IDCH1 = 2
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
6786 IDCH2 = 2
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
6789
6790* store initial configuration for energy-momentum cons. check
6791 IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6792
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'
6799 IRPT = IRPT+1
6800 GOTO 9999
6801 ENDIF
6802
6803C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6804C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6805C* check second chain for resonance
6806C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6807C & AMCH2,AMCH2N,IDCH2,IREJ1)
6808C IF (IREJ1.NE.0) GOTO 9999
6809C IF (IDR2.NE.0) THEN
6810C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6811C & AMCH2,AMCH2N,AMCH1,IREJ1)
6812C IF (IREJ1.NE.0) GOTO 9999
6813C ENDIF
6814C* check first chain for resonance
6815C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6816C & AMCH1,AMCH1N,IDCH1,IREJ1)
6817C IF (IREJ1.NE.0) GOTO 9999
6818C IF (IDR1.NE.0) IDR1 = 100*IDR1
6819C ELSE
6820C* check first chain for resonance
6821C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6822C & AMCH1,AMCH1N,IDCH1,IREJ1)
6823C IF (IREJ1.NE.0) GOTO 9999
6824C IF (IDR1.NE.0) THEN
6825C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6826C & AMCH1,AMCH1N,AMCH2,IREJ1)
6827C IF (IREJ1.NE.0) GOTO 9999
6828C ENDIF
6829C* check second chain for resonance
6830C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6831C & AMCH2,AMCH2N,IDCH2,IREJ1)
6832C IF (IREJ1.NE.0) GOTO 9999
6833C IF (IDR2.NE.0) IDR2 = 100*IDR2
6834C ENDIF
6835C ENDIF
6836
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
6876 ELSE
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
6885 ENDIF
6886 ENDIF
6887 ENDIF
6888
6889* store final configuration for energy-momentum cons. check
6890 IF (LEMCCK) THEN
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
6894 ENDIF
6895
6896* put partons and chains into DTEVT1
6897 DO 10 I=1,4
6898 PCH1(I) = PP1(I)+PT1(I)
6899 PCH2(I) = PP2(I)+PT2(I)
6900 10 CONTINUE
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)
6912 KCH = KCH+1
6913 CALL DT_EVTPUT(KCH,88888,-2,-1,
6914 & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6915
6916 RETURN
6917
6918 9999 CONTINUE
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
6924 IREJ = -1
6925 RETURN
6926 ENDIF
6927 9998 CONTINUE
6928 IREJ = 1
6929 RETURN
6930 END
6931*
6932*===chkine=============================================================*
6933*
6934CDECK ID>, DT_CHKINE
6935 SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6936 & AMCH1,AMCH1N,AMCH2,IREJ)
6937
6938************************************************************************
6939* This subroutine replaces CORMOM. *
6940* This version dated 05.01.95 is written by S. Roesler *
6941************************************************************************
6942
6943 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6944 SAVE
6945
6946 PARAMETER ( LINP = 5 ,
6947 & LOUT = 6 ,
6948 & LDAT = 9 )
6949
6950 PARAMETER (TINY10=1.0D-10)
6951
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
6956* rejection counter
6957 COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6958 & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6959 & IREXCI(3),IRDIFF(2),IRINC
6960
6961 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6962 & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6963
6964 IREJ = 0
6965 JMSHL = IMSHL
6966
6967 SCALE = AMCH1N/MAX(AMCH1,TINY10)
6968 DO 10 I=1,4
6969 PP1(I) = PP1I(I)
6970 PP2(I) = PP2I(I)
6971 PT1(I) = PT1I(I)
6972 PT2(I) = PT2I(I)
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)
6977 10 CONTINUE
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
6980
6981 ECH = PP2(4)+PT2(4)
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
6986 IF (IOULEV(1).GT.0)
6987 & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6988 GOTO 9997
6989 ENDIF
6990
6991 AMCH1 = AMCH1N
6992 AMCH2 = SQRT(AMCH22)
6993
6994* put partons again on mass shell
6995 13 CONTINUE
6996 XM1 = 0.0D0
6997 XM2 = 0.0D0
6998 IF (JMSHL.EQ.1) THEN
6999
7000 XM1 = PYMASS(IFP1)
7001 XM2 = PYMASS(IFT1)
7002
7003 ENDIF
7004 CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7005 IF (IREJ1.NE.0) THEN
7006 IF (JMSHL.EQ.0) GOTO 9998
7007 JMSHL = 0
7008 GOTO 13
7009 ENDIF
7010 JMSHL = IMSHL
7011 DO 11 I=1,4
7012 PP1(I) = P1(I)
7013 PT1(I) = P2(I)
7014 11 CONTINUE
7015 14 CONTINUE
7016 XM1 = 0.0D0
7017 XM2 = 0.0D0
7018 IF (JMSHL.EQ.1) THEN
7019
7020 XM1 = PYMASS(IFP2)
7021 XM2 = PYMASS(IFT2)
7022
7023 ENDIF
7024 CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7025 IF (IREJ1.NE.0) THEN
7026 IF (JMSHL.EQ.0) GOTO 9998
7027 JMSHL = 0
7028 GOTO 14
7029 ENDIF
7030 DO 12 I=1,4
7031 PP2(I) = P1(I)
7032 PT2(I) = P2(I)
7033 12 CONTINUE
7034 DO 15 I=1,4
7035 PP1I(I) = PP1(I)
7036 PP2I(I) = PP2(I)
7037 PT1I(I) = PT1(I)
7038 PT2I(I) = PT2(I)
7039 15 CONTINUE
7040 RETURN
7041
7042 9997 IRCHKI(1) = IRCHKI(1)+1
7043**sr
7044C GOTO 9999
7045 IREJ = -1
7046 RETURN
7047**
7048 9998 IRCHKI(2) = IRCHKI(2)+1
7049
7050 9999 CONTINUE
7051 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7052 IREJ = 1
7053 RETURN
7054 END
7055*
7056*===ch2res=============================================================*
7057*
7058CDECK ID>, DT_CH2RES
7059 SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7060 & AM,AMN,IMODE,IREJ)
7061
7062************************************************************************
7063* Check chains for resonance production. *
7064* This subroutine replaces COMCMA/COBCMA/COMCM2 *
7065* input: *
7066* IF1,2,3,4 input flavors (q,aq in any order) *
7067* AM chain mass *
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 *
7071* output: *
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 *
7077* *
7078* IREJ rejection flag *
7079* This version dated 06.01.95 is written by S. Roesler *
7080************************************************************************
7081
7082 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7083 SAVE
7084
7085 PARAMETER ( LINP = 5 ,
7086 & LOUT = 6 ,
7087 & LDAT = 9 )
7088
7089* particle properties (BAMJET index convention)
7090 CHARACTER*8 ANAME
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)
7096* rejection counter
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
7104
7105 DIMENSION IF(4),JF(4)
7106
7107**sr 4.7. test
7108C DATA AMLOM,AMLOB /0.08D0,0.2D0/
7109 DATA AMLOM,AMLOB /0.1D0,0.7D0/
7110**
7111C DATA AMLOM,AMLOB /0.001D0,0.001D0/
7112
7113 MODE = ABS(IMODE)
7114
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')
7119 STOP
7120 ENDIF
7121
7122 AMX = AM
7123 IREJ = 0
7124 IDR = 0
7125 IDXR = 0
7126 AMN = AMX
7127 IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7128 IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7129
7130 IF(1) = IF1
7131 IF(2) = IF2
7132 IF(3) = IF3
7133 IF(4) = IF4
7134 NF = 0
7135 DO 100 I=1,4
7136 IF (IF(I).NE.0) THEN
7137 NF = NF+1
7138 JF(NF) = IF(I)
7139 ENDIF
7140 100 CONTINUE
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)
7145 GOTO 9999
7146 ENDIF
7147
7148 GOTO (1,2,3) MODE
7149
7150* check for meson resonance
7151 1 CONTINUE
7152 IFQ = JF(1)
7153 IFAQ = ABS(JF(2))
7154 IF (JF(2).GT.0) THEN
7155 IFQ = JF(2)
7156 IFAQ = ABS(JF(1))
7157 ENDIF
7158 IFPS = IMPS(IFAQ,IFQ)
7159 IFV = IMVE(IFAQ,IFQ)
7160 AMPS = AAM(IFPS)
7161 AMV = AAM(IFV)
7162 AMHI = AMV+0.3D0
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
7167 ELSE
7168 IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7169 ENDIF
7170 LOMRES = LOMRES+1
7171 ENDIF
7172* replace chain by pseudoscalar meson
7173 IDR = -1
7174 IDXR = IFPS
7175 AMN = AMPS
7176 ELSEIF (AMX.LT.AMHI) THEN
7177* replace chain by vector-meson
7178 IDR = 1
7179 IDXR = IFV
7180 AMN = AMV
7181 ENDIF
7182 RETURN
7183
7184* check for baryon resonance
7185 2 CONTINUE
7186 CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7187 AM8 = AAM(JB8)
7188 AM10 = AAM(JB10)
7189 AMHI = AM10+0.3D0
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
7194 ELSE
7195 IF (AMX.LT.0.8D0*AM8) GOTO 9999
7196 ENDIF
7197 LOBRES = LOBRES+1
7198 ENDIF
7199* replace chain by oktet baryon
7200 IDR = -1
7201 IDXR = JB8
7202 AMN = AM8
7203 ELSEIF (AMX.LT.AMHI) THEN
7204 IDR = 1
7205 IDXR = JB10
7206 AMN = AM10
7207 ENDIF
7208 RETURN
7209
7210* check qq-aqaq for lower mass cut
7211 3 CONTINUE
7212* empirical definition of AMHI to allow for (b-antib)-pair prod.
7213 AMHI = 2.5D0
7214 IF (AMX.LT.AMHI) GOTO 9999
7215 RETURN
7216
7217 9999 CONTINUE
7218 IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7219 & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7220 IREJ = 1
7221 IRRES(2) = IRRES(2)+1
7222 RETURN
7223 END
7224*
7225*===rjseac=============================================================*
7226*
7227CDECK ID>, DT_RJSEAC
7228 SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7229
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************************************************************************
7236
7237 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7238 SAVE
7239
7240 PARAMETER ( LINP = 5 ,
7241 & LOUT = 6 ,
7242 & LDAT = 9 )
7243
7244 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7245
7246* event history
7247
7248 PARAMETER (NMXHKK=200000)
7249
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),
7256 & IHIST(2,NMXHKK)
7257* statistics
7258 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7259 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7260 & ICEVTG(8,0:30)
7261
7262 DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7263
7264 IREJ = 0
7265
7266* projectile sea q-aq-pair
7267* indices of sea-pair
7268 IDXSEA(1,1) = MOP1
7269 IDXSEA(1,2) = MOP2
7270* index of mother-nucleon
7271 IDXNUC(1) = JMOHKK(1,MOP1)
7272* status of valence quarks to be corrected
7273 ISTVAL(1) = -21
7274
7275* target sea q-aq-pair
7276* indices of sea-pair
7277 IDXSEA(2,1) = MOT1
7278 IDXSEA(2,2) = MOT2
7279* index of mother-nucleon
7280 IDXNUC(2) = JMOHKK(1,MOT1)
7281* status of valence quarks to be corrected
7282 ISTVAL(2) = -22
7283
7284 DO 1 N=1,2
7285 IDONE = 0
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
7291 DO 3 K=1,4
7292 PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7293 & PHKK(K,IDXSEA(N,2))
7294 3 CONTINUE
7295 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7296 & PHKK(2,I)**2-PHKK(3,I)**2))
7297* "cancel" sea-pair
7298 DO 4 J=1,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
7305 DO 5 K=1,4
7306 PHKK(K,IDXSEA(N,J)) = ZERO
7307 VHKK(K,IDXSEA(N,J)) = ZERO
7308 WHKK(K,IDXSEA(N,J)) = ZERO
7309 5 CONTINUE
7310 PHKK(5,IDXSEA(N,J)) = ZERO
7311 4 CONTINUE
7312 IDONE = 1
7313 ENDIF
7314 2 CONTINUE
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!')
7320 GOTO 9999
7321 ENDIF
7322 1 CONTINUE
7323 ICRJSS = ICRJSS+1
7324 RETURN
7325
7326 9999 CONTINUE
7327 IREJ = 1
7328 RETURN
7329 END
7330*
7331*===vv2sch=============================================================*
7332*
7333CDECK ID>, DT_VV2SCH
7334 SUBROUTINE DT_VV2SCH
7335
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 *
7341* meson at rest. *
7342* This version dated 18.01.95 is written by S. Roesler *
7343************************************************************************
7344
7345 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7346 SAVE
7347
7348 PARAMETER ( LINP = 5 ,
7349 & LOUT = 6 ,
7350 & LDAT = 9 )
7351
7352 PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7353
7354 LOGICAL LSTART
7355
7356* event history
7357
7358 PARAMETER (NMXHKK=200000)
7359
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),
7366 & IHIST(2,NMXHKK)
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
7371* statistics
7372 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7373 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7374 & ICEVTG(8,0:30)
7375
7376 DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7377 & PCH2(4)
7378
7379 DATA LSTART /.TRUE./
7380
7381 IFSC = 0
7382 IF (LSTART) THEN
7383 WRITE(LOUT,1000)
7384 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
7385 & 'valence chains treated')
7386 LSTART = .FALSE.
7387 ENDIF
7388
7389 NSTOP = NHKK
7390
7391* get index of first chain
7392 DO 1 I=NPOINT(3),NHKK
7393 IF (IDHKK(I).EQ.88888) THEN
7394 NC = I
7395 GOTO 2
7396 ENDIF
7397 1 CONTINUE
7398
7399 2 CONTINUE
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+
7412 & PHKK(3,MO1)**2)
7413
7414 SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7415 IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7416 ICVV2S = ICVV2S+1
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)
7423 DO 3 I=1,4
7424 IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7425 IF(I,2) = 0
7426 IF (ABS(IDHKK(MO(I))).GE.1000)
7427 & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7428 3 CONTINUE
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
7433 K1 = 1
7434 K2 = 3
7435 N1 = NC-2
7436 N2 = NC+1
7437 ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7438 K1 = 3
7439 K2 = 1
7440 N1 = NC+1
7441 N2 = NC-2
7442 ELSE
7443 GOTO 10
7444 ENDIF
7445 DO 4 K=1,4
7446 PP1(K) = PHKK(K,N1)
7447 PT1(K) = PHKK(K,N1+1)
7448 PP2(K) = PHKK(K,N2)
7449 PT2(K) = PHKK(K,N2+1)
7450 4 CONTINUE
7451 AMCH1 = PHKK(5,N1+2)
7452 AMCH2 = PHKK(5,N2+2)
7453* get meson-identity corresponding to flavors of q-aq chain
7454 ITMP = IRESRJ
7455 IRESRJ = 0
7456 CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7457 & ZERO,AMCH1N,1,IDUM)
7458 IRESRJ = ITMP
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
7465 IDCHAI = 2
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
7472 DO 5 K=1,4
7473 PCH1(K) = PP1(K)+PT1(K)
7474 PCH2(K) = PP2(K)+PT2(K)
7475 5 CONTINUE
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))
7483 IDHKK(N1+2) = 22222
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))
7491 IDHKK(N2+2) = 22222
7492 ENDIF
7493 ENDIF
7494 ELSE
7495 GOTO 11
7496 ENDIF
7497 10 CONTINUE
7498 NC = NC+6
7499 GOTO 2
7500
7501 11 CONTINUE
7502
7503 RETURN
7504 END
7505*
7506*=== phnsch ===========================================================*
7507*
7508CDECK ID>, DT_PHNSCH
7509 DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7510
7511*----------------------------------------------------------------------*
7512* *
7513* Probability for Hadron Nucleon Single CHain interactions: *
7514* *
7515* Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
7516* Infn - Milan *
7517* *
7518* Last change on 04-jan-94 by Alfredo Ferrari *
7519* *
7520* modified by J.R.for use in DTUNUC 6.1.94 *
7521* *
7522* Input variables: *
7523* Kp = hadron projectile index (Part numbering *
7524* scheme) *
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 *
7530* *
7531*----------------------------------------------------------------------*
7532
7533 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7534 SAVE
7535
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 )
7544
7545 PARAMETER ( NALLWP = 39 )
7546 PARAMETER ( IDMAXP = 210 )
7547
7548 DIMENSION ICHRGE(39),AM(39)
7549
7550* particle properties (BAMJET index convention)
7551 CHARACTER*8 ANAME
7552 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7553 & IICH(210),IIBAR(210),K1(210),K2(210)
7554
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)
7560
7561 DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7562 DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7563 SAVE SGTCOE, IHLP
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))
7568
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/
7573
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 /
7577C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7578 DATA SGTCO1 /
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/
7599C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7600 DATA SGTCO2 /
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/
7617C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7618 DATA SGTCO3 /
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 /
7649*
7650* +-------------------------------------------------------------------*
7651 ICHRGE(KTARG)=IICH(KTARG)
7652 AM (KTARG)=AAM (KTARG)
7653* | Check for pi0 (d-dbar)
7654 IF ( KP .NE. 26 ) THEN
7655 IP = KPTOIP (KP)
7656 IF(IP.EQ.0)IP=1
7657 ICHRGE(IP)=IICH(KP)
7658 AM (IP)=AAM (KP)
7659* |
7660* +-------------------------------------------------------------------*
7661* |
7662 ELSE
7663 IP = 23
7664 ICHRGE(IP)=0
7665 END IF
7666* |
7667* +-------------------------------------------------------------------*
7668* +-------------------------------------------------------------------*
7669* | No such interactions for baryon-baryon
7670 IF ( IIBAR (KP) .GT. 0 ) THEN
7671 DT_PHNSCH = ZERZER
7672 RETURN
7673* |
7674* +-------------------------------------------------------------------*
7675* | No "annihilation" diagram possible for K+ p/n
7676 ELSE IF ( IP .EQ. 15 ) THEN
7677 DT_PHNSCH = ZERZER
7678 RETURN
7679* |
7680* +-------------------------------------------------------------------*
7681* | No "annihilation" diagram possible for K0 p/n
7682 ELSE IF ( IP .EQ. 24 ) THEN
7683 DT_PHNSCH = ZERZER
7684 RETURN
7685* |
7686* +-------------------------------------------------------------------*
7687* | No "annihilation" diagram possible for Omebar p/n
7688 ELSE IF ( IP .GE. 38 ) THEN
7689 DT_PHNSCH = ZERZER
7690 RETURN
7691 END IF
7692* |
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 )
7702* | x sqrt(s/s(50))
7703* | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7704 IF ( PLAB .GT. 50.D+00 ) THEN
7705 PLA = 50.D+00
7706 AMPSQ = AM (IP)**2
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 )
7713* |
7714* +-------------------------------------------------------------------*
7715* | P < 3 GeV/c
7716 ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7717 PLA = 3.D+00
7718 AMPSQ = AM (IP)**2
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 )
7725* |
7726* +-------------------------------------------------------------------*
7727* | P < 50 GeV/c
7728 ELSE
7729 PLA = PLAB
7730 UMORAT = ONEONE
7731 END IF
7732* |
7733* +-------------------------------------------------------------------*
7734 ALGPLA = LOG (PLA)
7735* +-------------------------------------------------------------------*
7736* | Pions:
7737 IF ( IHLP (IP) .EQ. 2 ) THEN
7738 ACOF = SGTCOE (1,3)
7739 BCOF = SGTCOE (2,3)
7740 ENNE = SGTCOE (3,3)
7741 CCOF = SGTCOE (4,3)
7742 DCOF = SGTCOE (5,3)
7743* | Compute the pi+ p total cross section:
7744 SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7745 & + DCOF * ALGPLA
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
7753 & + DCOF * ALGPLA
7754* | Compute the pi+ p inelastic cross section:
7755 SPPPIN = SPPPTT - SPPPEL
7756 ACOF = SGTCOE (1,4)
7757 BCOF = SGTCOE (2,4)
7758 ENNE = SGTCOE (3,4)
7759 CCOF = SGTCOE (4,4)
7760 DCOF = SGTCOE (5,4)
7761* | Compute the pi- p total cross section:
7762 SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7763 & + DCOF * ALGPLA
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
7771 & + DCOF * ALGPLA
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
7782 KHELP = KTARG / 8
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
7791 & + DCOF * ALGPLA
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
7800 & + DCOF * ALGPLA
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
7807 IQFSC2 = 0
7808 IQBSC1 = 1 + KHELP
7809 IQBSC2 = 1 + IP - 13
7810* | |
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)
7815 ELSE
7816 KHELP = KTARG / 8
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
7826 IQFSC1 = 1 + K2HLP
7827 IQFSC2 = 0
7828 IQBSC1 = 1 + KHELP
7829 IQBSC2 = 2 - K2HLP
7830 END IF
7831* | |
7832* | +----------------------------------------------------------------*
7833* | end pi's
7834* +-------------------------------------------------------------------*
7835* | Kaons:
7836 ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7837 ACOF = SGTCOE (1,6)
7838 BCOF = SGTCOE (2,6)
7839 ENNE = SGTCOE (3,6)
7840 CCOF = SGTCOE (4,6)
7841 DCOF = SGTCOE (5,6)
7842* | Compute the K+ p total cross section:
7843 SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7844 & + DCOF * ALGPLA
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
7852 & + DCOF * ALGPLA
7853* | Compute the K+ p inelastic cross section:
7854 SKPPIN = SKPPTT - SKPPEL
7855 ACOF = SGTCOE (1,9)
7856 BCOF = SGTCOE (2,9)
7857 ENNE = SGTCOE (3,9)
7858 CCOF = SGTCOE (4,9)
7859 DCOF = SGTCOE (5,9)
7860* | Compute the K- p total cross section:
7861 SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7862 & + DCOF * ALGPLA
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
7870 & + DCOF * ALGPLA
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
7877 KHELP = KTARG / 8
7878* | | +-------------------------------------------------------------*
7879* | | | Proton target:
7880 IF ( KHELP .EQ. 0 ) THEN
7881 SHNCIN = SKMPIN
7882* | | | Number of diagrams:
7883 NDIAGR = 2
7884* | | |
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)
7889 ELSE
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
7897 & + DCOF * ALGPLA
7898* | | | Compute the elastic cross section:
7899 SHNCEL = SKMPEL
7900* | | | Compute the inelastic cross section:
7901 SHNCIN = SHNCTT - SHNCEL
7902* | | | Number of diagrams:
7903 NDIAGR = 1
7904 END IF
7905* | | |
7906* | | +-------------------------------------------------------------*
7907* | | Now compute the chain end (anti)quark-(anti)diquark
7908 IQFSC1 = 3
7909 IQFSC2 = 0
7910 IQBSC1 = 1 + KHELP
7911 IQBSC2 = 2
7912* | |
7913* | +----------------------------------------------------------------*
7914* | | K0's: (actually only K0bar)
7915 ELSE
7916 KHELP = KTARG / 8
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:
7923 NDIAGR = 1
7924* | | |
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)
7931 ELSE
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
7939 & + DCOF * ALGPLA
7940* | | | Compute the elastic cross section:
7941 SHNCEL = SKMPEL
7942* | | | Compute the inelastic cross section:
7943 SHNCIN = SHNCTT - SHNCEL + SIGDIA
7944* | | | Number of diagrams:
7945 NDIAGR = 2
7946 END IF
7947* | | |
7948* | | +-------------------------------------------------------------*
7949* | | Now compute the chain end (anti)quark-(anti)diquark
7950 IQFSC1 = 3
7951 IQFSC2 = 0
7952 IQBSC1 = 1
7953 IQBSC2 = 1 + KHELP
7954 END IF
7955* | |
7956* | +----------------------------------------------------------------*
7957* | end Kaon's
7958* +-------------------------------------------------------------------*
7959* | Antinucleons:
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
7970 & + DCOF * ALGPLA
7971 IF ( PLA .LT. FIVFIV ) THEN
7972 JREAC = 26
7973 ELSE
7974 JREAC = 25
7975 END IF
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
7983 & + DCOF * ALGPLA
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
7993 & + DCOF * ALGPLA
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
8001 & + DCOF * ALGPLA
8002* | Compute the K- p inelastic cross section:
8003 SPPINE = SPPTOT - SPPELA
8004 SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8005 KHELP = KTARG / 8
8006* | +----------------------------------------------------------------*
8007* | | Pbar:
8008 IF ( ICHRGE (IP) .NE. 0 ) THEN
8009 NDIAGR = 5 - KHELP
8010* | | +-------------------------------------------------------------*
8011* | | | Proton target:
8012 IF ( KHELP .EQ. 0 ) THEN
8013* | | | Number of diagrams:
8014 SHNCIN = SAPPIN
8015 PUUBAR = 0.8D+00
8016* | | |
8017* | | +-------------------------------------------------------------*
8018* | | | Neutron target: it is supposed that (ap n)el is almost equal
8019* | | | to (ap p)el (reasonable above 5 GeV/c)
8020 ELSE
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
8028 & + DCOF * ALGPLA
8029* | | | Compute the elastic cross section:
8030 SHNCEL = SAPPEL
8031* | | | Compute the inelastic cross section:
8032 SHNCIN = SHNCTT - SHNCEL
8033 PUUBAR = HLFHLF
8034 END IF
8035* | | |
8036* | | +-------------------------------------------------------------*
8037* | | Now compute the chain end (anti)quark-(anti)diquark
8038* | | there are different possibilities, make a random choiche:
8039 IQFSC1 = -1
8040 RNCHEN = DT_RNDM(PUUBAR)
8041 IF ( RNCHEN .LT. PUUBAR ) THEN
8042 IQFSC2 = -2
8043 ELSE
8044 IQFSC2 = -1
8045 END IF
8046 IQBSC1 = -IQFSC1 + KHELP
8047 IQBSC2 = -IQFSC2
8048* | |
8049* | +----------------------------------------------------------------*
8050* | | nbar:
8051 ELSE
8052 NDIAGR = 4 + KHELP
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
8058 PDDBAR = HLFHLF
8059* | | |
8060* | | +-------------------------------------------------------------*
8061* | | | Neutron target: (nbar n)el is supposed to be equal to
8062* | | | (pbar p)el (reasonable above 5 GeV/c)
8063 ELSE
8064* | | | Compute the total cross section:
8065 SHNCTT = SAPPTT
8066* | | | Compute the elastic cross section:
8067 SHNCEL = SAPPEL
8068* | | | Compute the inelastic cross section:
8069 SHNCIN = SHNCTT - SHNCEL
8070 PDDBAR = 0.8D+00
8071 END IF
8072* | | |
8073* | | +-------------------------------------------------------------*
8074* | | Now compute the chain end (anti)quark-(anti)diquark
8075* | | there are different possibilities, make a random choiche:
8076 IQFSC1 = -2
8077 RNCHEN = DT_RNDM(RNCHEN)
8078 IF ( RNCHEN .LT. PDDBAR ) THEN
8079 IQFSC2 = -1
8080 ELSE
8081 IQFSC2 = -2
8082 END IF
8083 IQBSC1 = -IQFSC1 + KHELP - 1
8084 IQBSC2 = -IQFSC2
8085 END IF
8086* | |
8087* | +----------------------------------------------------------------*
8088* |
8089* +-------------------------------------------------------------------*
8090* | Others: not yet implemented
8091 ELSE
8092 SIGDIA = ZERZER
8093 SHNCIN = ONEONE
8094 NDIAGR = 0
8095 DT_PHNSCH = ZERZER
8096 RETURN
8097 END IF
8098* | end others
8099* +-------------------------------------------------------------------*
8100 DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8101 IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8102 & + IQECHR (IQBSC2)
8103 IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8104 & + IQBCHR (IQBSC2)
8105 IQECHC = IQECHC / 3
8106 IQBCHC = IQBCHC / 3
8107 IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8108 & + IQSCHR (IQBSC2)
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 )
8120 END IF
8121* |
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
8127 WRITE (LUNOUT,*)
8128 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8129 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8130 WRITE (LUNERR,*)
8131 &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8132 & IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8133 END IF
8134* |
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 )
8140 RETURN
8141*
8142 ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8143 DT_SCHQUA = ONEONE
8144 JQFSC1 = IQFSC1
8145 JQFSC2 = IQFSC2
8146 JQBSC1 = IQBSC1
8147 JQBSC2 = IQBSC2
8148*=== End of function Phnsch ===========================================*
8149 RETURN
8150 END
8151*
8152*===respt==============================================================*
8153*
8154CDECK ID>, DT_RESPT
8155 SUBROUTINE DT_RESPT
8156
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************************************************************************
8161
8162 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8163 SAVE
8164
8165 PARAMETER ( LINP = 5 ,
8166 & LOUT = 6 ,
8167 & LDAT = 9 )
8168
8169 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8170
8171* event history
8172
8173 PARAMETER (NMXHKK=200000)
8174
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),
8181 & IHIST(2,NMXHKK)
8182
8183* get index of first chain
8184 DO 1 I=NPOINT(3),NHKK
8185 IF (IDHKK(I).EQ.88888) THEN
8186 NC = I
8187 GOTO 2
8188 ENDIF
8189 1 CONTINUE
8190
8191 2 CONTINUE
8192 IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8193C 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)
8200 ENDIF
8201 ENDIF
8202 ELSE
8203 GOTO 3
8204 ENDIF
8205 NC = NC+6
8206 GOTO 2
8207
8208 3 CONTINUE
8209
8210 RETURN
8211 END
8212*
8213*===evtres=============================================================*
8214*
8215CDECK ID>, DT_EVTRES
8216 SUBROUTINE DT_EVTRES(IREJ)
8217
8218************************************************************************
8219* This version dated 14.12.94 is written by S. Roesler *
8220************************************************************************
8221
8222 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8223 SAVE
8224
8225 PARAMETER ( LINP = 5 ,
8226 & LOUT = 6 ,
8227 & LDAT = 9 )
8228
8229 PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8230
8231* event history
8232
8233 PARAMETER (NMXHKK=200000)
8234
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),
8241 & IHIST(2,NMXHKK)
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)
8247 CHARACTER*8 ANAME
8248 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8249 & IICH(210),IIBAR(210),K1(210),K2(210)
8250
8251 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8252
8253 IREJ = 0
8254
8255 DO 1 I=NPOINT(3),NHKK
8256 IF (ABS(IDRES(I)).GE.100) THEN
8257 AMMX = 0.0D0
8258 DO 2 J=NPOINT(3),NHKK
8259 IF (IDHKK(J).EQ.88888) THEN
8260 IF (PHKK(5,J).GT.AMMX) THEN
8261 AMMX = PHKK(5,J)
8262 IMMX = J
8263 ENDIF
8264 ENDIF
8265 2 CONTINUE
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'
8270C GOTO 6
8271 GOTO 9999
8272 ELSE
8273 GOTO 9999
8274 ENDIF
8275 ENDIF
8276 IMO11 = JMOHKK(1,I)
8277 IMO12 = JMOHKK(2,I)
8278 IF (PHKK(3,IMO11).LT.0.0D0) THEN
8279 IMO11 = JMOHKK(2,I)
8280 IMO12 = JMOHKK(1,I)
8281 ENDIF
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)
8287 ENDIF
8288 AMCH1 = PHKK(5,I)
8289 AMCH1N = AAM(IDXRES(I))
8290
8291 IFPR1 = IDHKK(IMO11)
8292 IFPR2 = IDHKK(IMO21)
8293 IFTA1 = IDHKK(IMO12)
8294 IFTA2 = IDHKK(IMO22)
8295 DO 4 J=1,4
8296 PP1(J) = PHKK(J,IMO11)
8297 PP2(J) = PHKK(J,IMO21)
8298 PT1(J) = PHKK(J,IMO12)
8299 PT2(J) = PHKK(J,IMO22)
8300 4 CONTINUE
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)
8309 IFP(2) = 0
8310 IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8311 IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8312 IFT(2) = 0
8313 IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8314 IDCH2 = 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
8320 IF (IOULEV(1).GT.0)
8321 & WRITE(LOUT,*) ' correction for resonance not poss.'
8322**sr test
8323C GOTO 1
8324C GOTO 9999
8325**
8326 ENDIF
8327* store final configuration for energy-momentum cons. check
8328 IF (LEMCCK) THEN
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
8332 ENDIF
8333 DO 5 J=1,4
8334 PHKK(J,IMO11) = PP1(J)
8335 PHKK(J,IMO21) = PP2(J)
8336 PHKK(J,IMO12) = PT1(J)
8337 PHKK(J,IMO22) = PT2(J)
8338 5 CONTINUE
8339* correct entries of chains
8340 DO 3 K=1,4
8341 PHKK(K,I) = PHKK(K,IMO11)+PHKK(K,IMO12)
8342 PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8343 3 CONTINUE
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-
8346 & PHKK(3,IMMX)**2
8347* ?? the following should now be obsolete
8348**sr test
8349C IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8350 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8351**
8352 WRITE(LOUT,'(1X,A,4G10.3)')
8353 & 'EVTRES: inonsistent mass-corr.',AM1,AM2
8354C GOTO 9999
8355 GOTO 1
8356 ENDIF
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
8365 GOTO 9999
8366 ENDIF
8367 ENDIF
8368 1 CONTINUE
8369 6 CONTINUE
8370 RETURN
8371
8372 9999 CONTINUE
8373 IREJ = 1
8374 RETURN
8375 END
8376*
8377*===getspt=============================================================*
8378*
8379CDECK 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)
8383
8384************************************************************************
8385* This version dated 12.12.94 is written by S. Roesler *
8386************************************************************************
8387
8388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8389 SAVE
8390
8391 PARAMETER ( LINP = 5 ,
8392 & LOUT = 6 ,
8393 & LDAT = 9 )
8394
8395 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8396
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,
8401 & LCO2CR,LINTPT
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
8408
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)
8413
8414 IC = 0
8415 IREJ = 0
8416C B33P = 4.0D0
8417C B33T = 4.0D0
8418C IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8419C IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8420 REDU = 1.0D0
8421C B33P = 3.5D0
8422C B33T = 3.5D0
8423 B33P = 4.0D0
8424 B33T = 4.0D0
8425 IF (IDIFF.NE.0) THEN
8426 B33P = 16.0D0
8427 B33T = 16.0D0
8428 ENDIF
8429
8430 DO 1 I=1,4
8431 PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8432 PP1(I) = PP1I(I)
8433 PP2(I) = PP2I(I)
8434 PT1(I) = PT1I(I)
8435 PT2(I) = PT2I(I)
8436 1 CONTINUE
8437* get initial chain masses
8438 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8439 & +(PP1(3)+PT1(3))**2)
8440 ECH = PP1(4)+PT1(4)
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)
8444 ECH = PP2(4)+PT2(4)
8445 AM2 = (ECH+PTOCH)*(ECH-PTOCH)
8446 IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8447 IF (IOULEV(1).GT.0)
8448 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8449 & AM1,AM2
8450 GOTO 9999
8451 ENDIF
8452 AM1 = SQRT(AM1)
8453 AM2 = SQRT(AM2)
8454 AM1N = ZERO
8455 AM2N = ZERO
8456
8457 MODE = 0
8458C IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8459C MODE = 0
8460C ELSE
8461C MODE = 1
8462C IF (AM1.LT.0.6) THEN
8463C B33P = 10.0D0
8464C ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8465CC B33P = 4.0D0
8466C ENDIF
8467C IF (AM2.LT.0.6) THEN
8468C B33T = 10.0D0
8469C ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8470CC B33T = 4.0D0
8471C ENDIF
8472C ENDIF
8473
8474* check chain masses for very low mass chains
8475C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8476C & AM1,DUM,-IDCH1,IREJ1)
8477C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8478C & AM2,DUM,-IDCH2,IREJ2)
8479C IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8480C B33P = 20.0D0
8481C B33T = 20.0D0
8482C ENDIF
8483
8484 JMSHL = IMSHL
8485
8486 2 CONTINUE
8487 IC = IC+1
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
8491C IF (MOD(IC,19).EQ.0) JMSHL = 0
8492 IF (MOD(IC,20).EQ.0) GOTO 7
8493C WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8494C RETURN
8495C GOTO 9999
8496C ENDIF
8497
8498* get transverse momentum
8499 IF (LINTPT) THEN
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)
8503 HPSP = HPSP*REDU
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)
8507 HPST = HPST*REDU
8508 ELSE
8509 HPSP = ZERO
8510 HPST = ZERO
8511 ENDIF
8512 CALL DT_DSFECF(SFE1,CFE1)
8513 CALL DT_DSFECF(SFE2,CFE2)
8514 IF (MODE.EQ.0) THEN
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
8523 ELSE
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
8532 ENDIF
8533
8534* put partons on mass shell
8535 XMP1 = 0.0D0
8536 XMT1 = 0.0D0
8537 IF (JMSHL.EQ.1) THEN
8538
8539 XMP1 = PYMASS(IFPR1)
8540 XMT1 = PYMASS(IFTA1)
8541
8542 ENDIF
8543 CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8544 IF (IREJ1.NE.0) GOTO 2
8545 DO 3 I=1,4
8546 PTOTF(I) = P1(I)+P2(I)
8547 PP1(I) = P1(I)
8548 PT1(I) = P2(I)
8549 3 CONTINUE
8550 XMP2 = 0.0D0
8551 XMT2 = 0.0D0
8552 IF (JMSHL.EQ.1) THEN
8553
8554 XMP2 = PYMASS(IFPR2)
8555 XMT2 = PYMASS(IFTA2)
8556
8557 ENDIF
8558 CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8559 IF (IREJ1.NE.0) GOTO 2
8560 DO 4 I=1,4
8561 PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8562 PP2(I) = P1(I)
8563 PT2(I) = P2(I)
8564 4 CONTINUE
8565
8566* check consistency
8567 DO 5 I=1,4
8568 DIFF(I) = PTOTI(I)-PTOTF(I)
8569 5 CONTINUE
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
8573 GOTO 9999
8574 ENDIF
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))
8585 & THEN
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
8591C GOTO 9999
8592 ENDIF
8593
8594* get chain masses
8595 PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8596 & +(PP1(3)+PT1(3))**2)
8597 ECH = PP1(4)+PT1(4)
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)
8601 ECH = PP2(4)+PT2(4)
8602 AM2N = (ECH+PTOCH)*(ECH-PTOCH)
8603 IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8604 IF (IOULEV(1).GT.0)
8605 & WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8606 & AM1N,AM2N
8607 GOTO 2
8608 ENDIF
8609 AM1N = SQRT(AM1N)
8610 AM2N = SQRT(AM2N)
8611
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
8619
8620 7 CONTINUE
8621 IF (AM1N.GT.ZERO) THEN
8622 AM1 = AM1N
8623 AM2 = AM2N
8624 ENDIF
8625 DO 6 I=1,4
8626 PP1I(I) = PP1(I)
8627 PP2I(I) = PP2(I)
8628 PT1I(I) = PT1(I)
8629 PT2I(I) = PT2(I)
8630 6 CONTINUE
8631
8632 RETURN
8633
8634 9999 CONTINUE
8635 IREJ = 1
8636 RETURN
8637 END
8638*
8639*===saptre=============================================================*
8640*
8641CDECK ID>, DT_SAPTRE
8642 SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8643
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************************************************************************
8650
8651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8652 SAVE
8653
8654 PARAMETER ( LINP = 5 ,
8655 & LOUT = 6 ,
8656 & LDAT = 9 )
8657
8658 PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8659
8660* event history
8661
8662 PARAMETER (NMXHKK=200000)
8663
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),
8670 & IHIST(2,NMXHKK)
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
8675
8676 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8677
8678 DATA B3 /4.0D0/
8679
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
8684
8685 HMA = PHKK(5,IDX1)
8686 DO 1 K=1,4
8687 PA1(K) = PHKK(K,IDX1)
8688 PA2(K) = PHKK(K,IDX2)
8689 1 CONTINUE
8690
8691 IF (LEMCCK) THEN
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)
8694 ENDIF
8695
8696 EXEB = 0.0D0
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)
8701 XAB = DT_RNDM(WA)
8702 10 CONTINUE
8703* ES is the transverse kinetic energy
8704 IF (XAB.LT.WA)THEN
8705 X = DT_RNDM(WA)
8706 Y = DT_RNDM(WA)
8707 ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8708 ELSE
8709 X = DT_RNDM(Y)
8710 ES = ABS(-LOG(X+TINY7)/B3)
8711 ENDIF
8712 IF (ES.GT.ESMAX) GOTO 10
8713 ES = ES+HMA
8714* transverse momentum
8715 HPS = SQRT((ES-HMA)*(ES+HMA))
8716
8717 CALL DT_DSFECF(SFE,CFE)
8718 HPX = HPS*CFE
8719 HPY = HPS*SFE
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
8723
8724C PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8725C PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8726 PA1(1) = PA1(1)+HPX
8727 PA1(2) = PA1(2)+HPY
8728 PA2(1) = PA2(1)-HPX
8729 PA2(2) = PA2(2)-HPY
8730
8731* put resonances on mass-shell again
8732 XM1 = PHKK(5,IDX1)
8733 XM2 = PHKK(5,IDX2)
8734 CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8735 IF (IREJ1.NE.0) RETURN
8736
8737 IF (LEMCCK) THEN
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
8742 ENDIF
8743
8744 DO 2 K=1,4
8745 PHKK(K,IDX1) = P1(K)
8746 PHKK(K,IDX2) = P2(K)
8747 2 CONTINUE
8748
8749 RETURN
8750 END
8751*
8752*===cronin=============================================================*
8753*
8754CDECK ID>, DT_CRONIN
8755 SUBROUTINE DT_CRONIN(INCL)
8756
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************************************************************************
8763
8764 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8765 SAVE
8766
8767 PARAMETER ( LINP = 5 ,
8768 & LOUT = 6 ,
8769 & LDAT = 9 )
8770
8771 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8772
8773* event history
8774
8775 PARAMETER (NMXHKK=200000)
8776
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),
8783 & IHIST(2,NMXHKK)
8784* rejection counter
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
8791
8792 DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8793
8794 DO 1 K=1,4
8795 DEV(K) = ZERO
8796 1 CONTINUE
8797
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
8804 IDXNU = JMOHKK(1,I)
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
8811 DO 3 K=1,4
8812 PIN(K) = PHKK(K,I)
8813 3 CONTINUE
8814* multiple scattering of parton with DTEVT1-index I
8815 CALL DT_CROMSC(PIN,R,POUT,INCL)
8816**testprint
8817C IF (NEVHKK.EQ.5) THEN
8818C AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8819C AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8820C AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8821C AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8822C WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8823C WRITE(6,'(A,4E15.5)')'PIN: ',PIN
8824C WRITE(6,'(A,4E15.5)')'POUT: ',POUT
8825C ENDIF
8826**
8827* increase accumulator by energy-momentum difference
8828 DO 4 K=1,4
8829 DEV(K) = DEV(K)+POUT(K)-PIN(K)
8830 PHKK(K,I) = POUT(K)
8831 4 CONTINUE
8832 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8833 & PHKK(2,I)**2-PHKK(3,I)**2))
8834 ENDIF
8835 2 CONTINUE
8836
8837* dump accumulator to momenta of valence partons
8838 NVAL = 0
8839 ETOT = 0.0D0
8840 DO 5 I=NPOINT(2),NHKK
8841 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8842 NVAL = NVAL+1
8843 ETOT = ETOT+PHKK(4,I)
8844 ENDIF
8845 5 CONTINUE
8846C WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8847 1000 FORMAT(1X,'CRONIN : number of val. partons ',I4,/,
8848 & 9X,4E12.4)
8849 DO 6 I=NPOINT(2),NHKK
8850 IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8851 E = PHKK(4,I)
8852 DO 7 K=1,4
8853C PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8854 PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8855 7 CONTINUE
8856 PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8857 & PHKK(2,I)**2-PHKK(3,I)**2))
8858 ENDIF
8859 6 CONTINUE
8860
8861 RETURN
8862 END
8863*
8864*===cromsc=============================================================*
8865*
8866CDECK ID>, DT_CROMSC
8867 SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8868
8869************************************************************************
8870* Cronin-Effect. Multiple scattering of one parton passing through *
8871* nuclear matter. *
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************************************************************************
8880
8881 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8882 SAVE
8883
8884 PARAMETER ( LINP = 5 ,
8885 & LOUT = 6 ,
8886 & LDAT = 9 )
8887
8888 PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8889
8890 LOGICAL LSTART
8891
8892* rejection counter
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,
8903 & LCO2CR,LINTPT
8904
8905 DIMENSION PIN(4),POUT(4),R(3)
8906
8907 DATA LSTART /.TRUE./
8908
8909 IRCRON(1) = IRCRON(1)+1
8910
8911 IF (LSTART) THEN
8912 WRITE(LOUT,1000) CRONCO
8913 1000 FORMAT(/,1X,'CROMSC: multiple scattering of chain ends',
8914 & ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8915 LSTART = .FALSE.
8916 ENDIF
8917
8918 NCBACK = 0
8919 RNCL = RPROJ
8920 IF (INCL.EQ.2) RNCL = RTARG
8921
8922* Lorentz-transformation into Lab.
8923 MODE = -(INCL+1)
8924 CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8925
8926 PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8927 IF (PTOT.LE.8.0D0) GOTO 9997
8928
8929* direction cosines of parton before mult. scattering
8930 COSX = PIN(1)/PTOT
8931 COSY = PIN(2)/PTOT
8932 COSZ = PZ/PTOT
8933
8934 RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8935 IF (RTESQ.GE.-TINY3) GOTO 9999
8936
8937* calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8938* in the direction of particle motion
8939
8940 A = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8941 TMP = A**2-RTESQ
8942 IF (TMP.LT.ZERO) GOTO 9998
8943 DIST = -A+SQRT(TMP)
8944
8945* multiple scattering angle
8946 THETO = CRONCO*SQRT(DIST)/PTOT
8947 IF (THETO.GT.0.1D0) THETO=0.1D0
8948
8949 1 CONTINUE
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)
8955 COSTH = COS(THETA)
8956 SINTH = SIN(THETA)
8957
8958* new direction cosines
8959 CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8960 & COSXN,COSYN,COSZN)
8961
8962 POUT(1) = COSXN*PTOT
8963 POUT(2) = COSYN*PTOT
8964 PZ = COSZN*PTOT
8965* Lorentz-transformation into nucl.-nucl. cms
8966 MODE = INCL+1
8967 CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8968
8969C IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8970C 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
8972 THETO = THETO/2.0D0
8973 NCBACK = NCBACK+1
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)
8979 GOTO 9997
8980 ENDIF
8981 GOTO 1
8982 ENDIF
8983
8984 RETURN
8985
8986 9997 IRCRON(2) = IRCRON(2)+1
8987 GOTO 9999
8988 9998 IRCRON(3) = IRCRON(3)+1
8989
8990 9999 CONTINUE
8991 DO 100 K=1,4
8992 POUT(K) = PIN(K)
8993 100 CONTINUE
8994 RETURN
8995 END
8996*
8997*===com2sr=============================================================*
8998*
8999CDECK ID>, DT_COM2CR
9000 SUBROUTINE DT_COM2CR
9001
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************************************************************************
9009
9010 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9011 SAVE
9012
9013 PARAMETER ( LINP = 5 ,
9014 & LOUT = 6 ,
9015 & LDAT = 9 )
9016
9017* event history
9018
9019 PARAMETER (NMXHKK=200000)
9020
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),
9027 & IHIST(2,NMXHKK)
9028* statistics
9029 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9030 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9031 & ICEVTG(8,0:30)
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,
9036 & LCO2CR,LINTPT
9037
9038 DIMENSION IDXQA(248),IDXAQ(248)
9039
9040 ICCHAI(1,9) = ICCHAI(1,9)+1
9041 NQA = 0
9042 NAQ = 0
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
9047 MO1 = JMOHKK(1,I)
9048 MO2 = JMOHKK(2,I)
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
9052 NQA = NQA+1
9053 IDXQA(NQA) = I
9054 ELSE
9055 NAQ = NAQ+1
9056 IDXAQ(NAQ) = I
9057 ENDIF
9058 ENDIF
9059 ENDIF
9060 10 CONTINUE
9061
9062* minimum number of q-aq chains requested for the same projectile/
9063* target
9064 NCHMIN = IDT_NPOISS(CUTOF)
9065
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)
9074
9075 RETURN
9076 END
9077*
9078*===scn4cr=============================================================*
9079*
9080CDECK ID>, DT_SCN4CR
9081 SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9082
9083************************************************************************
9084* SCan q-aq chains for Color Ropes. *
9085* This version dated 11.01.95 is written by S. Roesler. *
9086************************************************************************
9087
9088 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9089 SAVE
9090
9091 PARAMETER ( LINP = 5 ,
9092 & LOUT = 6 ,
9093 & LDAT = 9 )
9094
9095* event history
9096
9097 PARAMETER (NMXHKK=200000)
9098
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),
9105 & IHIST(2,NMXHKK)
9106
9107 DIMENSION IDXCH(248),IDXJN(248)
9108
9109 DO 1 I=1,NCH
9110 IF (IDXCH(I).GT.0) THEN
9111 NJOIN = 1
9112 IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9113 IDXJN(NJOIN) = I
9114 IF (I.LT.NCH) THEN
9115 DO 2 J=I+1,NCH
9116 IF (IDXCH(J).GT.0) THEN
9117 IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9118 IF (IDXMO.EQ.IDXMO1) THEN
9119 NJOIN = NJOIN+1
9120 IDXJN(NJOIN) = J
9121 ENDIF
9122 ENDIF
9123 2 CONTINUE
9124 ENDIF
9125 IF (NJOIN.GE.NCHMIN+2) THEN
9126 NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9127 DO 3 J=1,2*NJ,2
9128 CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9129 IF (IREJ1.NE.0) GOTO 3
9130 IDXCH(IDXJN(J)) = 0
9131 IDXCH(IDXJN(J+1)) = 0
9132 3 CONTINUE
9133 ENDIF
9134 ENDIF
9135 1 CONTINUE
9136
9137 RETURN
9138 END
9139*
9140*===join===============================================================*
9141*
9142CDECK ID>, DT_JOIN
9143 SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9144
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************************************************************************
9150
9151 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9152 SAVE
9153
9154 PARAMETER ( LINP = 5 ,
9155 & LOUT = 6 ,
9156 & LDAT = 9 )
9157
9158* event history
9159
9160 PARAMETER (NMXHKK=200000)
9161
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),
9168 & IHIST(2,NMXHKK)
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
9173* statistics
9174 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9175 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9176 & ICEVTG(8,0:30)
9177
9178 DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9179
9180 IREJ = 0
9181
9182 IDX(1) = IDX1
9183 IDX(2) = IDX2
9184 DO 1 I=1,2
9185 DO 2 J=1,2
9186 MO(I,J) = JMOHKK(J,IDX(I))
9187 ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9188 2 CONTINUE
9189 1 CONTINUE
9190
9191* check consistency
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),
9197 & MO(2,2)
9198 1000 FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9199 & 2I5,' chain ',I4,':',2I5)
9200 ENDIF
9201
9202* join chains
9203 DO 3 K=1,4
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))
9206 3 CONTINUE
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))
9211
9212* put partons again on mass shell
9213 XM1 = 0.0D0
9214 XM2 = 0.0D0
9215 IF (IMSHL.EQ.1) THEN
9216
9217 XM1 = PYMASS(IF1)
9218 XM2 = PYMASS(IF2)
9219
9220 ENDIF
9221 CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9222 IF (IREJ1.NE.0) GOTO 9999
9223 DO 4 I=1,4
9224 PP(I) = P1(I)
9225 PT(I) = P2(I)
9226 4 CONTINUE
9227
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),
9230 & 0,0,0)
9231 CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9232 & 0,0,0)
9233 DO 5 K=1,4
9234 PCH(K) = PP(K)+PT(K)
9235 5 CONTINUE
9236
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
9243 NHKK = NHKK-2
9244 GOTO 9999
9245 ENDIF
9246 ENDIF
9247
9248 ICCHAI(2,9) = ICCHAI(2,9)+1
9249* store new chain in DTEVT1
9250 KCH = 191
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
9255 DO 6 K=1,4
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
9258 6 CONTINUE
9259 RETURN
9260
9261 9999 CONTINUE
9262 IREJ = 1
9263 RETURN
9264 END
9265*
9266*===xsglau=============================================================*
9267*
9268CDECK ID>, DT_XSGLAU
9269 SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9270
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************************************************************************
9282
9283 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9284 SAVE
9285
9286 PARAMETER ( LINP = 5 ,
9287 & LOUT = 6 ,
9288 & LDAT = 9 )
9289
9290 COMPLEX*16 CZERO,CONE,CTWO
9291 CHARACTER*12 CFILE
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,
9295 & PI = TWOPI/TWO,
9296 & GEV2MB = 0.38938D0,
9297 & GEV2FM = 0.1972D0,
9298 & ALPHEM = ONE/137.0D0,
9299* proton mass
9300 & AMP = 0.938D0,
9301 & AMP2 = AMP**2,
9302* approx. nucleon radius
9303 & RNUCLE = 1.12D0)
9304
9305* particle properties (BAMJET index convention)
9306 CHARACTER*8 ANAME
9307 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9308 & IICH(210),IIBAR(210),K1(210),K2(210)
9309
9310 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9311
9312 PARAMETER ( MAXNCL = 260,
9313
9314 & MAXVQU = MAXNCL,
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),
9321 & NSITEB,NSTATB
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
9334 LOGICAL LPROD
9335 CHARACTER*8 CGLB
9336 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9337* nucleon-nucleon event-generator
9338 CHARACTER*8 CMODEL
9339 LOGICAL LPHOIN
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
9345
9346 COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9347 & OMPP11,OMPP12,OMPP21,OMPP22,
9348 & DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9349 & PPTMP1,PPTMP2
9350 COMPLEX*16 C,CA,CI
9351 DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9352 & COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9353 & BPROD(KSITEB)
9354
9355 PARAMETER (NPOINT=16)
9356 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9357
9358 LOGICAL LFIRST,LOPEN
9359 DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9360
9361 NTARG = ABS(NIDX)
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
9366 IJPROJ = 1
9367 ELSE
9368 IJPROJ = JJPROJ
9369 ENDIF
9370
9371 IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9372 I = INDEX(CGLB,' ')
9373 IF (I.EQ.0) 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')
9379 ELSE
9380 STOP 'XSGLAU 1'
9381 ENDIF
9382 LOPEN = .TRUE.
9383 ENDIF
9384
9385 CZERO = DCMPLX(ZERO,ZERO)
9386 CONE = DCMPLX(ONE,ZERO)
9387 CTWO = DCMPLX(TWO,ZERO)
9388 NEBINI = IE
9389 NQBINI = IQ
9390
9391* re-define kinematics
9392 S = ECMI**2
9393 Q2 = Q2I
9394 X = XI
9395* g(Q2=0)-A, h-A, A-A scattering
9396 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9397 Q2 = 0.0001D0
9398 X = Q2/(S+Q2-AMP2)
9399* g(Q2>0)-A scattering
9400 ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9401 X = Q2/(S+Q2-AMP2)
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
9406 ELSE
9407 WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9408 STOP
9409 ENDIF
9410 ECMNN(IE) = SQRT(S)
9411 Q2G(IQ) = Q2
9412 XNU = (S+Q2-AMP2)/(TWO*AMP)
9413
9414* parameters determining statistics in evaluating Glauber-xsection
9415 NSTATB = JSTATB
9416 NSITEB = JBINSB
9417 IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9418
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
9424 RASH(1) = ZERO
9425 RBSH(NTARG) = RTANCL
9426 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9427 ELSE
9428 IF (NIDX.LE.-1) THEN
9429 RASH(1) = RPRNCL
9430 RBSH(NTARG) = RTANCL
9431 BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9432 ELSE
9433 RASH(NTARG) = RPRNCL
9434 RBSH(1) = RTANCL
9435 BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9436 ENDIF
9437 ENDIF
9438* maximum impact-parameter
9439 BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9440
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
9444 ZERO1 = ZERO
9445 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9446 & BSLOPE,0)
9447 ELSE
9448 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9449 ENDIF
9450 IF (ECMNN(IE).LE.3.0D0) THEN
9451 ROSH = -0.43D0
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
9455 ROSH = 0.1D0
9456 ENDIF
9457 ELSEIF (IJPROJ.EQ.7) THEN
9458 ROSH = 0.1D0
9459 ELSE
9460 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9461 ROSH = 0.01D0
9462 ENDIF
9463
9464* projectile-nucleon xsection (in fm)
9465 IF (IJPROJ.EQ.7) THEN
9466 SIGSH = DT_SIGVP(X,Q2)/10.0D0
9467 ELSE
9468 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9469 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9470C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9471 DUMZER = ZERO
9472 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9473 SIGSH = SIGSH/10.0D0
9474 ENDIF
9475
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
9479 ZERO1 = ZERO
9480 CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9481C DIBETA = SDIF1/STOT
9482 DIBETA = 0.2D0
9483 DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9484 IF (DIBETA.LE.ZERO) THEN
9485 ALPGAM = ONE
9486 ELSE
9487 ALPGAM = DIALPH/DIGAMM
9488 ENDIF
9489 FACDI1 = ONE-ALPGAM
9490 FACDI2 = ONE+ALPGAM
9491 FACDI = SQRT(FACDI1*FACDI2)
9492 WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9493 ELSE
9494 DIBETA = -1.0D0
9495 DIALPH = ZERO
9496 DIGAMM = ZERO
9497 FACDI1 = ZERO
9498 FACDI2 = 2.0D0
9499 FACDI = ZERO
9500 ENDIF
9501
9502* initializations
9503 DO 10 I=1,NSITEB
9504 BSITE( 0,IQ,NTARG,I) = ZERO
9505 BSITE(IE,IQ,NTARG,I) = ZERO
9506 BPROD(I) = ZERO
9507 10 CONTINUE
9508 STOT = ZERO
9509 STOT2 = ZERO
9510 SELA = ZERO
9511 SELA2 = ZERO
9512 SQEP = ZERO
9513 SQEP2 = ZERO
9514 SQET = ZERO
9515 SQET2 = ZERO
9516 SQE2 = ZERO
9517 SQE22 = ZERO
9518 SPRO = ZERO
9519 SPRO2 = ZERO
9520 SDEL = ZERO
9521 SDEL2 = ZERO
9522 SDQE = ZERO
9523 SDQE2 = ZERO
9524 FACN = ONE/DBLE(NSTATB)
9525
9526 IPNT = 0
9527 RPNT = ZERO
9528
9529* initialize Gauss-integration for photon-proj.
9530 JPOINT = 1
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
9535 AMLO2 = AAM(33)**2
9536 ELSE
9537 AMLO2 = AAM(96)**2
9538 ENDIF
9539 IF (INTRGE(2).EQ.1) THEN
9540 AMHI2 = S/TWO
9541 ELSEIF (INTRGE(2).EQ.2) THEN
9542 AMHI2 = S/4.0D0
9543 ELSE
9544 AMHI2 = S
9545 ENDIF
9546 AMHI20 = (ECMNN(IE)-AMP)**2
9547 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9548 XAMLO = LOG( AMLO2+Q2 )
9549 XAMHI = LOG( AMHI2+Q2 )
9550**PHOJET105a
9551C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9552**PHOJET112
9553
9554 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9555
9556**
9557 JPOINT = NPOINT
9558* ratio direct/total photon-nucleon xsection
9559 CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9560 ENDIF
9561
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)
9571 STOP
9572 ENDIF
9573 IF (LFIRST) WRITE(LOUT,1001) CFILE
9574 1001 FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9575 & 'file ',A12,/)
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
9584 DO 21 I=1,NLINES
9585 ISTART = 7*I-6
9586 READ(LDAT,'(7E11.4)')
9587 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9588 21 CONTINUE
9589 ENDIF
9590 ISTART = 7*NLINES+1
9591 IF (ISTART.LE.NSITEB) THEN
9592 READ(LDAT,'(7E11.4)')
9593 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9594 ENDIF
9595 LFIRST = .FALSE.
9596 GOTO 100
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)
9601 GOTO 100
9602 ENDIF
9603
9604* cross sections averaged over NSTATB nucleon configurations
9605 DO 11 IS=1,NSTATB
9606C IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9607 STOTN = ZERO
9608 SELAN = ZERO
9609 SQEPN = ZERO
9610 SQETN = ZERO
9611 SQE2N = ZERO
9612 SPRON = ZERO
9613 SDELN = ZERO
9614 SDQEN = ZERO
9615
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)
9622 ENDIF
9623 ELSE
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)
9629 ENDIF
9630 ENDIF
9631
9632* integration over impact parameter B
9633 DO 12 IB=1,NSITEB-1
9634 STOTB = ZERO
9635 SELAB = ZERO
9636 SQEPB = ZERO
9637 SQETB = ZERO
9638 SQE2B = ZERO
9639 SPROB = ZERO
9640 SDIR = ZERO
9641 SDELB = ZERO
9642 SDQEB = ZERO
9643 B = DBLE(IB)*BSTEP(NTARG)
9644 FACB = 10.0D0*TWOPI*B*BSTEP(NTARG)
9645
9646* integration over M_V^2 for photon-proj.
9647 DO 14 IM=1,JPOINT
9648 PP11(1) = CONE
9649 PP12(1) = CONE
9650 PP21(1) = CONE
9651 PP22(1) = CONE
9652 IF (IJPROJ.EQ.7) THEN
9653 DO 13 K=2,NB
9654 PP11(K) = CONE
9655 PP12(K) = CONE
9656 PP21(K) = CONE
9657 PP22(K) = CONE
9658 13 CONTINUE
9659 ENDIF
9660 SHI = ZERO
9661 FACM = ONE
9662 DCOH = 1.0D10
9663
9664 IF (IJPROJ.EQ.7) THEN
9665 AMV2 = EXP(ABSZX(IM))-Q2
9666 AMV = SQRT(AMV2)
9667 IF (AMV2.LT.16.0D0) THEN
9668 R = TWO
9669 ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9670 R = 10.0D0/3.0D0
9671 ELSE
9672 R = 11.0D0/3.0D0
9673 ENDIF
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)))
9681* coherence length
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)
9686 ENDIF
9687 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9688 GAM = GSH
9689 IF (IJPROJ.EQ.7) THEN
9690 RCA = GAM*SIGMV/TWOPI
9691 ELSE
9692 RCA = GAM*SIGSH/TWOPI
9693 ENDIF
9694 FCA = -ROSH*RCA
9695 CA = DCMPLX(RCA,FCA)
9696 CI = CONE
9697
9698 DO 15 INA=1,NA
9699 KK1 = 1
9700 INT1 = 1
9701 KK2 = 1
9702 INT2 = 1
9703 DO 16 INB=1,NB
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
9707 KK1 = INB
9708 INT1 = INT1+1
9709 ENDIF
9710 IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9711 KK2 = INB
9712 INT2 = INT2+1
9713 ENDIF
9714 ENDIF
9715
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
9727 AR = DBLE(C)
9728 AI = DIMAG(C)
9729 SHI = SHI+LOG(AR*AR+AI*AI)
9730 ENDIF
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
9743 ENDIF
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
9755 ENDIF
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
9767 ENDIF
9768 ENDIF
9769 16 CONTINUE
9770 15 CONTINUE
9771
9772 OMPP11 = CZERO
9773 OMPP21 = CZERO
9774 DIPP11 = CZERO
9775 DIPP21 = CZERO
9776 DO 17 K=1,INT1
9777 IF (PP11(K).EQ.CZERO) THEN
9778 PPTMP1 = CZERO
9779 PPTMP2 = CZERO
9780 ELSE
9781 PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9782 PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9783 ENDIF
9784 AVDIPP = 0.5D0*
9785 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9786 OMPP11 = OMPP11+AVDIPP
9787C OMPP11 = OMPP11+(CONE-PP11(K))
9788 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9789 DIPP11 = DIPP11+AVDIPP
9790 IF (PP21(K).EQ.CZERO) THEN
9791 PPTMP1 = CZERO
9792 PPTMP2 = CZERO
9793 ELSE
9794 PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9795 PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9796 ENDIF
9797 AVDIPP = 0.5D0*
9798 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9799 OMPP21 = OMPP21+AVDIPP
9800C OMPP21 = OMPP21+(CONE-PP21(K))
9801 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9802 DIPP21 = DIPP21+AVDIPP
9803 17 CONTINUE
9804 OMPP12 = CZERO
9805 OMPP22 = CZERO
9806 DIPP12 = CZERO
9807 DIPP22 = CZERO
9808 DO 18 K=1,INT2
9809 IF (PP12(K).EQ.CZERO) THEN
9810 PPTMP1 = CZERO
9811 PPTMP2 = CZERO
9812 ELSE
9813 PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9814 PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9815 ENDIF
9816 AVDIPP = 0.5D0*
9817 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9818 OMPP12 = OMPP12+AVDIPP
9819C OMPP12 = OMPP12+(CONE-PP12(K))
9820 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9821 DIPP12 = DIPP12+AVDIPP
9822 IF (PP22(K).EQ.CZERO) THEN
9823 PPTMP1 = CZERO
9824 PPTMP2 = CZERO
9825 ELSE
9826 PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9827 PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9828 ENDIF
9829 AVDIPP = 0.5D0*
9830 & ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9831 OMPP22 = OMPP22+AVDIPP
9832C OMPP22 = OMPP22+(CONE-PP22(K))
9833 AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9834 DIPP22 = DIPP22+AVDIPP
9835 18 CONTINUE
9836
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
9850 IF (NB.GT.1) THEN
9851 SQEPB = SQEPB+FACM*SQEPM
9852 SDQEB = SDQEB+FACM*SDQEM
9853 ENDIF
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
9857 ENDIF
9858
9859 14 CONTINUE
9860
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
9869
9870 IF (IJPROJ.EQ.7) THEN
9871 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9872 ELSE
9873 IF (DIBETA.GT.ZERO) THEN
9874 BPROD(IB+1)= BPROD(IB+1)
9875 & +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9876 ELSE
9877 BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9878 ENDIF
9879 ENDIF
9880
9881 12 CONTINUE
9882
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
9899
9900 11 CONTINUE
9901
9902* final cross sections
9903* 1) total
9904 XSTOT(IE,IQ,NTARG) = STOT
9905 IF (IJPROJ.EQ.7)
9906 & XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9907* 2) elastic
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
9918 ELSE
9919 XSPRO(IE,IQ,NTARG) = SPRO
9920 ENDIF
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
9925* stat. errors
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))
9934
9935 IF (IJPROJ.EQ.7) THEN
9936 BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9937 & -XSQEP(IE,IQ,NTARG)
9938 ELSE
9939 BNORM = XSPRO(IE,IQ,NTARG)
9940 ENDIF
9941 DO 19 I=2,NSITEB
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)
9945 19 CONTINUE
9946
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
9959 DO 20 I=1,NLINES
9960 ISTART = 7*I-6
9961 WRITE(LDAT,'(1P,7E11.4)')
9962 & (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9963 20 CONTINUE
9964 ENDIF
9965 ISTART = 7*NLINES+1
9966 IF (ISTART.LE.NSITEB) THEN
9967 WRITE(LDAT,'(1P,7E11.4)')
9968 & (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9969 ENDIF
9970 ENDIF
9971
9972 100 CONTINUE
9973
9974C IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9975
9976 RETURN
9977 END
9978*
9979*===getbxs=============================================================*
9980*
9981CDECK ID>, DT_GETBXS
9982 SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9983
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) *
9990* (output) *
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************************************************************************
9997
9998 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9999 SAVE
10000
10001 PARAMETER ( LINP = 5 ,
10002 & LOUT = 6 ,
10003 & LDAT = 9 )
10004
10005 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10006
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),
10011 & NSITEB,NSTATB
10012
10013 NTARG = ABS(NIDX)
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
10018 XSFRAC = 0.0D0
10019 RETURN
10020 ENDIF
10021 IF (ILO.EQ.NSITEB-1) THEN
10022 FRCLO = BSITE(0,1,NTARG,NSITEB)
10023 ELSE
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))
10027 ENDIF
10028 IF (IHI.EQ.NSITEB-1) THEN
10029 FRCHI = BSITE(0,1,NTARG,NSITEB)
10030 ELSE
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))
10034 ENDIF
10035 XSFRAC = FRCHI-FRCLO
10036 ELSE
10037 BLO = 0.0D0
10038 BHI = BMAX(NTARG)
10039 DO 1 I=1,NSITEB-1
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
10044 GOTO 2
10045 ENDIF
10046 1 CONTINUE
10047 2 CONTINUE
10048 ENDIF
10049
10050 RETURN
10051 END
10052*
10053*===conucl=============================================================*
10054*
10055CDECK ID>, DT_CONUCL
10056 SUBROUTINE DT_CONUCL(X,N,R,MODE)
10057
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************************************************************************
10067
10068 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10069 SAVE
10070
10071 PARAMETER ( LINP = 5 ,
10072 & LOUT = 6 ,
10073 & LDAT = 9 )
10074
10075 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10076 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10077
10078 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10079
10080 PARAMETER (NSRT=10)
10081 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10082 DIMENSION X(3,N),XTMP(3,260)
10083
10084 CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10085
10086 IF ((MODE.NE.0).AND.((N.EQ.3).OR.(N.GT.4))) THEN
10087 K = 0
10088 DO 1 I=1,NSRT
10089 IF (MODE.EQ.2) THEN
10090 ISRT = NSRT+1-I
10091 ELSE
10092 ISRT = I
10093 ENDIF
10094 K1 = K
10095 DO 2 J=1,ICSRT(ISRT)
10096 K = K+1
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))
10100 2 CONTINUE
10101 IF (ICSRT(ISRT).GT.1) THEN
10102 I0 = K1+1
10103 I1 = K
10104 CALL DT_SORT(X,N,I0,I1,MODE)
10105 ENDIF
10106 1 CONTINUE
10107 ELSEIF ((MODE.NE.0).AND.((N.EQ.2).OR.(N.EQ.4))) THEN
10108 DO 3 I=1,N
10109 X(1,I) = XTMP(1,I)
10110 X(2,I) = XTMP(2,I)
10111 X(3,I) = XTMP(3,I)
10112 3 CONTINUE
10113 CALL DT_SORT(X,N,1,N,MODE)
10114 ELSE
10115 DO 4 I=1,N
10116 X(1,I) = XTMP(1,I)
10117 X(2,I) = XTMP(2,I)
10118 X(3,I) = XTMP(3,I)
10119 4 CONTINUE
10120 ENDIF
10121
10122 RETURN
10123 END
10124*
10125*===coordi=============================================================*
10126*
10127CDECK ID>, DT_COORDI
10128 SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10129
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************************************************************************
10137
10138 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10139 SAVE
10140
10141 PARAMETER ( LINP = 5 ,
10142 & LOUT = 6 ,
10143 & LDAT = 9 )
10144
10145 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10146 & ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10147
10148 PARAMETER (TWOPI = 6.283185307179586454D+00 )
10149
10150 LOGICAL LSTART
10151
10152 PARAMETER (NSRT=10)
10153 DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10154 DIMENSION X(3,260),WD(4),RD(3)
10155
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/
10159
10160 X1SUM = ZERO
10161 X2SUM = ZERO
10162 X3SUM = ZERO
10163
10164 IF (N.EQ.1) THEN
10165 X(1,1) = ZERO
10166 X(2,1) = ZERO
10167 X(3,1) = ZERO
10168 ELSEIF (N.EQ.2) THEN
10169 EPS = DT_RNDM(RD(1))
10170 DO 30 I=1,3
10171 IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10172 30 CONTINUE
10173 40 CONTINUE
10174 DO 50 J=1,3
10175 CALL DT_RANNOR(X1,X2)
10176 X(J,1) = RD(I)*X1
10177 X(J,2) = -X(J,1)
10178 50 CONTINUE
10179 ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10180 SIGMA = R/SQRTWO
10181 LSTART = .TRUE.
10182 CALL DT_RANNOR(X3,X4)
10183 DO 100 I=1,N
10184 CALL DT_RANNOR(X1,X2)
10185 X(1,I) = SIGMA*X1
10186 X(2,I) = SIGMA*X2
10187 IF (LSTART) GOTO 80
10188 X(3,I) = SIGMA*X4
10189 CALL DT_RANNOR(X3,X4)
10190 GOTO 90
10191 80 CONTINUE
10192 X(3,I) = SIGMA*X3
10193 90 CONTINUE
10194 LSTART = .NOT.LSTART
10195 X1SUM = X1SUM+X(1,I)
10196 X2SUM = X2SUM+X(2,I)
10197 X3SUM = X3SUM+X(3,I)
10198 100 CONTINUE
10199 X1SUM = X1SUM/DBLE(N)
10200 X2SUM = X2SUM/DBLE(N)
10201 X3SUM = X3SUM/DBLE(N)
10202 DO 101 I=1,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
10206 101 CONTINUE
10207 ELSE
10208
10209* maximum nuclear radius for coordinate sampling
10210 RMAX = R+4.605D0*PDIF
10211
10212* initialize pre-sorting
10213 DO 121 I=1,NSRT
10214 ICSRT(I) = 0
10215 121 CONTINUE
10216 DR = TWO*RMAX/DBLE(NSRT)
10217
10218* sample coordinates for N nucleons
10219 DO 140 I=1,N
10220 120 CONTINUE
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
10230 X(3,I) = RAD*CT
10231* ensure that distance between two nucleons is greater than R2MIN
10232 IF (I.LT.2) GOTO 122
10233 I1 = I-1
10234 DO 130 I2=1,I1
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
10238 130 CONTINUE
10239 122 CONTINUE
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)
10247 140 CONTINUE
10248 X1SUM = X1SUM/DBLE(N)
10249 X2SUM = X2SUM/DBLE(N)
10250 X3SUM = X3SUM/DBLE(N)
10251 DO 141 I=1,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
10255 141 CONTINUE
10256
10257 ENDIF
10258
10259 RETURN
10260 END
10261*
10262*===densit=============================================================*
10263*
10264CDECK ID>, DT_DENSIT
10265 DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10266
10267 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10268 SAVE
10269
10270 PARAMETER ( LINP = 5 ,
10271 & LOUT = 6 ,
10272 & LDAT = 9 )
10273
10274 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10275 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10276 & PI = TWOPI/TWO)
10277
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/
10288
10289 DT_DENSIT = ZERO
10290* shell model
10291 IF (NA.LE.4) THEN
10292 STOP 'DT_DENSIT-0'
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)
10297* Woods-Saxon
10298 ELSEIF (NA.GT.18) THEN
10299 DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10300 ENDIF
10301
10302 RETURN
10303 END
10304*
10305*===rnclus=============================================================*
10306*
10307CDECK ID>, DT_RNCLUS
10308 DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10309
10310************************************************************************
10311* Nuclear radius for nucleus with mass number N. *
10312* This version dated 26.9.00 is written by S. Roesler *
10313************************************************************************
10314
10315 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10316 SAVE
10317
10318 PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10319
10320* nucleon radius
10321 PARAMETER (RNUCLE = 1.12D0)
10322
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/
10327
10328 IF (N.LE.18) THEN
10329 IF (RADNUC(N).GT.0.0D0) THEN
10330 DT_RNCLUS = RADNUC(N)
10331 ELSE
10332 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10333 ENDIF
10334 ELSE
10335 DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10336 ENDIF
10337
10338 RETURN
10339 END
10340*
10341*===dentst=============================================================*
10342*
10343C PROGRAM DT_DENTST
10344CDECK ID>, DT_DENTST
10345 SUBROUTINE DT_DENTST
10346
10347 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10348 SAVE
10349
10350 OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10351 OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10352
10353 RMIN = 0.0D0
10354 RMAX = 8.0D0
10355 NBINS = 500.0D0
10356 DR = (RMAX-RMIN)/DBLE(NBINS)
10357 DO 1 IA=5,18
10358 FMAX = 0.0D0
10359 DO 2 IR=1,NBINS+1
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
10364 2 CONTINUE
10365 WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10366 1 CONTINUE
10367
10368 CLOSE(40)
10369 CLOSE(41)
10370
10371 END
10372*
10373*===shmaki=============================================================*
10374*
10375CDECK ID>, DT_SHMAKI
10376 SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10377
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************************************************************************
10394
10395 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10396 SAVE
10397
10398 PARAMETER ( LINP = 5 ,
10399 & LOUT = 6 ,
10400 & LDAT = 9 )
10401
10402 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10403 & THREE=3.0D0)
10404
10405 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10406
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),
10411 & NSITEB,NSTATB
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
10434 CHARACTER*8 CMODEL
10435 LOGICAL LPHOIN
10436 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10437* Glauber formalism: flags and parameters for statistics
10438 LOGICAL LPROD
10439 CHARACTER*8 CGLB
10440 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10441
10442 DATA NTARG,ICOUT,IVEOUT /0,0,0/
10443
10444C CALL DT_HISHAD
10445C STOP
10446
10447 NTARG = NTARG+1
10448 IF (MODE.EQ.99) NTARG = 1
10449 NIDX = -NTARG
10450 IF (MODE.EQ.-1) NIDX = NTARG
10451
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 & '-------------------------',/)
10457
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'
10462 ENDIF
10463 IF (MODE.EQ.1) THEN
10464 CALL DT_PROFBI(NA,NB,PPN,NTARG)
10465 ELSE
10466 IBACK = 1
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))
10482 IESTEP = NEB-1
10483 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10484 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10485 DO 1 I=1,IESTEP+1
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))
10491 & WRITE(LOUT,1003)
10492 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10493 Q2LI = 0.01D0
10494 IBIN = 2
10495 ELSE
10496 IBIN = 1
10497 ENDIF
10498 IQSTEP = NQB-IBIN
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)
10508 2 CONTINUE
10509 ELSE
10510 CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10511 IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10512 & WRITE(LOUT,1003)
10513 & ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10514 ENDIF
10515 1003 FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10516 1 CONTINUE
10517 IVEOUT = 1
10518 ELSE
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,/)
10526 WRITE(LOUT,1005)
10527 1005 FORMAT(' E_cm (GeV) E_Lab (GeV) sig_tot^pp (mb)'
10528 & ,' Sigma_tot (mb) Sigma_prod (mb)',/,
10529 & ' -------------------------------------',
10530 & '--------------------------------------')
10531 ENDIF
10532 AECMLO = LOG10(VARCLO)
10533 AECMHI = LOG10(VARCHI)
10534 IESTEP = NEB-1
10535 DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10536 IF (AECMLO.EQ.AECMHI) IESTEP = 0
10537 DO 3 I=1,IESTEP+1
10538 ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10539 AMP = 0.938D0
10540 AMT = 0.938D0
10541 AMP2 = AMP**2
10542 AMT2 = AMT**2
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))
10547 & WRITE(LOUT,1006)
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)
10550 3 CONTINUE
10551 IVEOUT = 1
10552 ELSE
10553 CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10554 ENDIF
10555 ENDIF
10556 ENDIF
10557 ENDIF
10558
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',/)
10572 ENDIF
10573
10574 RETURN
10575 END
10576*
10577*===profbi=============================================================*
10578*
10579CDECK ID>, DT_PROFBI
10580 SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10581
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************************************************************************
10592
10593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10594 SAVE
10595
10596 PARAMETER ( LINP = 5 ,
10597 & LOUT = 6 ,
10598 & LDAT = 9 )
10599
10600 SAVE
10601
10602 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10603
10604 LOGICAL LSTART
10605 CHARACTER CNAME*80
10606
10607 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10608
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),
10613 & NSITEB,NSTATB
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
10625
10626 PARAMETER (NGLMAX=8000)
10627 DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10628 & GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10629
10630 DATA LSTART /.TRUE./
10631
10632 IF (LSTART) THEN
10633* read fit-parameters from file
10634 OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10635 I = 0
10636 1 CONTINUE
10637 READ(47,'(A80)') CNAME
10638 IF (CNAME.EQ.'STOP') GOTO 2
10639 I = I+1
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
10644 WRITE(LOUT,1000)
10645 1000 FORMAT(1X,'PROFBI: warning! array size exceeded - ',
10646 & 'program stopped')
10647 STOP
10648 ENDIF
10649 GOTO 1
10650 2 CONTINUE
10651 NGLPAR = I
10652 LSTART = .FALSE.
10653 ENDIF
10654
10655 NNA = NA
10656 NNB = NB
10657 IF (NA.GT.NB) THEN
10658 NNA = NB
10659 NNB = NA
10660 ENDIF
10661 IDXGLA = 0
10662 DO 3 J=1,NGLPAR
10663 IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10664 IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10665 DO 4 K=1,J-1
10666 IPOINT = J-K
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
10673 IDXGLA = IPOINT+1
10674 GOTO 6
10675 ELSE
10676 J1BEG = IPOINT+1
10677 J1END = J
10678C IF (J.EQ.NGLPAR) THEN
10679C J1BEG = IPOINT
10680C J1END = J
10681C ENDIF
10682 DO 5 J1=J1BEG,J1END
10683 IF (NGLIP(J1).EQ.NATMP) THEN
10684 IF (PPN.LT.GLAPPN(J1)) THEN
10685 IDXGLA = J1
10686 GOTO 6
10687 ENDIF
10688 ELSE
10689 IDXGLA = J1-1
10690 GOTO 6
10691 ENDIF
10692 5 CONTINUE
10693 IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10694 & IDXGLA = NGLPAR
10695 ENDIF
10696 ENDIF
10697 4 CONTINUE
10698 ENDIF
10699 3 CONTINUE
10700
10701 6 CONTINUE
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 ')
10706 STOP
10707 ENDIF
10708
10709* no interpolation yet available
10710 XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10711
10712 BSITE(1,1,NTARG,1) = ZERO
10713 DO 10 I=2,NSITEB
10714 XX = DBLE(I)
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
10721 10 CONTINUE
10722
10723 RETURN
10724 END
10725*
10726*===glaube=============================================================*
10727*
10728CDECK ID>, DT_GLAUBE
10729 SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10730
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************************************************************************
10743
10744 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10745 SAVE
10746
10747 PARAMETER ( LINP = 5 ,
10748 & LOUT = 6 ,
10749 & LDAT = 9 )
10750
10751 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10752 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10753
10754 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10755
10756 PARAMETER ( MAXNCL = 260,
10757
10758 & MAXVQU = MAXNCL,
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),
10765 & NSITEB,NSTATB
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
10786 LOGICAL LPROD
10787 CHARACTER*8 CGLB
10788 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10789
10790 DIMENSION JS(MAXNCL),JT(MAXNCL)
10791
10792 NTARG = ABS(NIDX)
10793
10794* get actual energy from /DTLTRA/
10795 ECMNOW = UMO
10796 Q2 = VIRT
10797*
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)
10801*
10802* variable energy run, interpolate profile function
10803 ELSE
10804 I1 = 1
10805 I2 = 1
10806 RATE = ONE
10807 IF (NEBINI.GT.1) THEN
10808 IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10809 I1 = NEBINI
10810 I2 = NEBINI
10811 RATE = ONE
10812 ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10813 DO 1 I=2,NEBINI
10814 IF (ECMNOW.LT.ECMNN(I)) THEN
10815 I1 = I-1
10816 I2 = I
10817 RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10818 GOTO 2
10819 ENDIF
10820 1 CONTINUE
10821 2 CONTINUE
10822 ENDIF
10823 ENDIF
10824 J1 = 1
10825 J2 = 1
10826 RATQ = ONE
10827 IF (NQBINI.GT.1) THEN
10828 IF (Q2.GE.Q2G(NQBINI)) THEN
10829 J1 = NQBINI
10830 J2 = NQBINI
10831 RATQ = ONE
10832 ELSEIF (Q2.GT.Q2G(1)) THEN
10833 DO 3 I=2,NQBINI
10834 IF (Q2.LT.Q2G(I)) THEN
10835 J1 = I-1
10836 J2 = I
10837 RATQ = LOG10( Q2/MAX(Q2G(J1),TINY14))/
10838 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10839C RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10840 GOTO 4
10841 ENDIF
10842 3 CONTINUE
10843 4 CONTINUE
10844 ENDIF
10845 ENDIF
10846
10847 DO 5 I=1,KSITEB
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))
10853 5 CONTINUE
10854 ENDIF
10855
10856 CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10857 IF (NIDX.LE.-1) THEN
10858 RPROJ = RASH(1)
10859 RTARG = RBSH(NTARG)
10860 ELSE
10861 RPROJ = RASH(NTARG)
10862 RTARG = RBSH(1)
10863 ENDIF
10864
10865 RETURN
10866 END
10867*
10868*===diagr==============================================================*
10869*
10870CDECK ID>, DT_DIAGR
10871 SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10872 & NIDX)
10873
10874************************************************************************
10875* Based on the original version by Shmakov et al. *
10876* This version dated 21.04.95 is revised by S. Roesler *
10877************************************************************************
10878
10879 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10880 SAVE
10881
10882 PARAMETER ( LINP = 5 ,
10883 & LOUT = 6 ,
10884 & LDAT = 9 )
10885
10886 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10887 PARAMETER (TWOPI = 6.283185307179586454D+00,
10888 & PI = TWOPI/TWO,
10889 & GEV2MB = 0.38938D0,
10890 & GEV2FM = 0.1972D0,
10891 & ALPHEM = ONE/137.0D0,
10892* proton mass
10893 & AMP = 0.938D0,
10894 & AMP2 = AMP**2,
10895* rho0 mass
10896 & AMRHO0 = 0.77D0)
10897
10898 COMPLEX*16 C,CA,CI
10899
10900 PARAMETER ( MAXNCL = 260,
10901
10902 & MAXVQU = MAXNCL,
10903 & MAXSQU = 20*MAXVQU,
10904 & MAXINT = MAXVQU+MAXSQU)
10905* particle properties (BAMJET index convention)
10906 CHARACTER*8 ANAME
10907 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10908 & IICH(210),IIBAR(210),K1(210),K2(210)
10909
10910 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10911
10912* emulsion treatment
10913 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10914 & NCOMPO,IEMUL
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),
10919 & NSITEB,NSTATB
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
10934 CHARACTER*8 CMODEL
10935 LOGICAL LPHOIN
10936 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10937**PHOJET105a
10938C COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10939**PHOJET112
10940C 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
10943**
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
10954
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)
10959
10960 LOGICAL LFIRST
10961 DATA LFIRST /.TRUE./
10962
10963 DATA NTARGO,ICNT /0,0/
10964
10965 NTARG = ABS(NIDX)
10966
10967 IF (LFIRST) THEN
10968 LFIRST = .FALSE.
10969 IF (NCOMPO.EQ.0) THEN
10970 NCALL = 0
10971 NWAMAX = NA
10972 NWBMAX = NB
10973 DO 17 I=0,210
10974 NWA(I) = 0
10975 NWB(I) = 0
10976 17 CONTINUE
10977 ENDIF
10978 ENDIF
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)
10988 18 CONTINUE
10989 ENDIF
10990 RETURN
10991 ENDIF
10992
10993 DCOH = 1.0D10
10994 IPNT = 0
10995
10996 SQ2 = Q2
10997 IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10998 S = ECMNOW**2
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
11003 15 CONTINUE
11004* VDM assumption: mass of V-meson
11005 AMV2 = DT_SAM2(SQ2,ECMNOW)
11006 AMV = SQRT(AMV2)
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)
11010**sr 27.10.
11011C SIGSH = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11012 SIGSH = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11013**
11014 ROSH = 0.1D0
11015 BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11016 & +0.25D0*LOG(S/(AMV2+SQ2)))
11017* coherence length
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
11021 ZERO1 = ZERO
11022 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11023 & BSLOPE,0)
11024 ELSE
11025 BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11026 ENDIF
11027 IF (ECMNOW.LE.3.0D0) THEN
11028 ROSH = -0.43D0
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
11032 ROSH = 0.1D0
11033 ENDIF
11034 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11035 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11036 IF (MCGENE.EQ.2) THEN
11037 ZERO1 = ZERO
11038 CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11039 & BDUM,0)
11040 SIGSH = SIGSH/10.0D0
11041 ELSE
11042C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11043 DUMZER = ZERO
11044 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11045 SIGSH = SIGSH/10.0D0
11046 ENDIF
11047 ELSE
11048 BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11049 ROSH = 0.01D0
11050 ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11051 PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11052C SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11053 DUMZER = ZERO
11054 CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11055 SIGSH = SIGSH/10.0D0
11056 ENDIF
11057 GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11058 GAM = GSH
11059 RCA = GAM*SIGSH/TWOPI
11060 FCA = -ROSH*RCA
11061 CA = DCMPLX(RCA,FCA)
11062 CI = DCMPLX(ONE,ZERO)
11063
11064 16 CONTINUE
11065* impact parameter
11066 IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11067
11068 NTRY = 0
11069 3 CONTINUE
11070 NTRY = NTRY+1
11071* initializations
11072 JNT = 0
11073 DO 1 I=1,NA
11074 JS(I) = 0
11075 1 CONTINUE
11076 DO 2 I=1,NB
11077 JT(I) = 0
11078 2 CONTINUE
11079 IF (IJPROJ.EQ.7) THEN
11080 DO 8 I=1,MAXNCL
11081 JS0(I) = 0
11082 JNT0(I)= 0
11083 DO 9 J=1,NB
11084 JT0(I,J) = 0
11085 9 CONTINUE
11086 8 CONTINUE
11087 ENDIF
11088
11089* nucleon configuration
11090C IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11091 IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11092C CALL DT_CONUCL(PKOO,NA,RASH,2)
11093C 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)
11097 ELSE
11098 CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11099 CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11100 ENDIF
11101 NTARGO = NTARG
11102 ENDIF
11103 ICNT = ICNT+1
11104
11105* LEPTO: pick out one struck nucleon
11106 IF (MCGENE.EQ.3) THEN
11107 JNT = 1
11108 JS(1) = 1
11109 IDX = INT(DT_RNDM(X)*NB)+1
11110 JT(IDX) = 1
11111 B = ZERO
11112 GOTO 19
11113 ENDIF
11114
11115 DO 4 INA=1,NA
11116* cross section fluctuations
11117 AFLUC = ONE
11118 IF (IFLUCT.EQ.1) THEN
11119 IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11120 AFLUC = FLUIXX(IFLUK)
11121 ENDIF
11122 KK1 = 1
11123 KINT = 1
11124 DO 5 INB=1,NB
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
11128 KK1 = INB
11129 KINT = KINT+1
11130 ENDIF
11131 ENDIF
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)
11137 AR = DBLE(C)
11138 AI = DIMAG(C)
11139 P = AR*AR+AI*AI
11140 IF (DT_RNDM(XY).GE.P) THEN
11141 JNT = JNT+1
11142 IF (IJPROJ.EQ.7) THEN
11143 JNT0(KINT) = JNT0(KINT)+1
11144 IF (JNT0(KINT).GT.MAXNCL) THEN
11145 WRITE(LOUT,1001) MAXNCL
11146 1001 FORMAT(1X,
11147 & 'DIAGR: no. of requested interactions',
11148 & ' exceeds array dimensions ',I4)
11149 STOP
11150 ENDIF
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
11155 ELSE
11156 IF (JNT.GT.MAXINT) THEN
11157 WRITE(LOUT,1000) JNT, MAXINT
11158 1000 FORMAT(1X,
11159 & 'DIAGR: no. of requested interactions ('
11160 & ,I4,') exceeds array dimensions (',I4,')')
11161 STOP
11162 ENDIF
11163 JS(INA) = JS(INA)+1
11164 JT(INB) = JT(INB)+1
11165 INTER1(JNT) = INA
11166 INTER2(JNT) = INB
11167 ENDIF
11168 ENDIF
11169 ENDIF
11170 5 CONTINUE
11171 4 CONTINUE
11172
11173 IF (JNT.EQ.0) THEN
11174 IF (NTRY.LT.500) THEN
11175 GOTO 3
11176 ELSE
11177C WRITE(6,*) ' new impact parameter required (old= ',B,')'
11178 GOTO 16
11179 ENDIF
11180 ENDIF
11181
11182 IDIREC = 0
11183 IF (IJPROJ.EQ.7) THEN
11184 K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11185 10 CONTINUE
11186 IF (JNT0(K).EQ.0) THEN
11187 K = K+1
11188 IF (K.GT.KINT) K = 1
11189 GOTO 10
11190 ENDIF
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
11194 JNT = 1
11195 JS(1) = 1
11196 DO 11 INB=1,NB
11197 JT(INB) = JT0(K,INB)
11198 IF (JT(INB).GT.0) GOTO 12
11199 11 CONTINUE
11200 12 CONTINUE
11201 INTER1(1) = 1
11202 INTER2(1) = INB
11203 IDIREC = IPNT
11204 ELSE
11205 JNT = JNT0(K)
11206 JS(1) = JS0(K)
11207 DO 13 INB=1,NB
11208 JT(INB) = JT0(K,INB)
11209 13 CONTINUE
11210 DO 14 I=1,JNT
11211 INTER1(I) = JI1(K,I)
11212 INTER2(I) = JI2(K,I)
11213 14 CONTINUE
11214 ENDIF
11215 ENDIF
11216
11217 19 CONTINUE
11218 INTA = 0
11219 INTB = 0
11220 DO 6 I=1,NA
11221 IF (JS(I).NE.0) INTA=INTA+1
11222 6 CONTINUE
11223 DO 7 I=1,NB
11224 IF (JT(I).NE.0) INTB=INTB+1
11225 7 CONTINUE
11226 ICWPG = INTA
11227 ICWTG = INTB
11228 ICIG = JNT
11229 IPGLB = IPGLB+INTA
11230 ITGLB = ITGLB+INTB
11231 NGLB = NGLB+1
11232
11233 IF (NCOMPO.EQ.0) THEN
11234 NCALL = NCALL+1
11235 NWA(INTA) = NWA(INTA)+1
11236 NWB(INTB) = NWB(INTB)+1
11237 ENDIF
11238
11239 RETURN
11240 END
11241*
11242*===modb===============================================================*
11243*
11244CDECK ID>, DT_MODB
11245 SUBROUTINE DT_MODB(B,NIDX)
11246
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************************************************************************
11254
11255 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11256 SAVE
11257
11258 PARAMETER ( LINP = 5 ,
11259 & LOUT = 6 ,
11260 & LDAT = 9 )
11261
11262 PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11263
11264 LOGICAL LEFT,LFIRST
11265
11266* central particle production, impact parameter biasing
11267 COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11268
11269 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11270
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),
11275 & NSITEB,NSTATB
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
11287
11288 DATA LFIRST /.TRUE./
11289
11290 NTARG = ABS(NIDX)
11291 IF (NIDX.LE.-1) THEN
11292 RA = RASH(1)
11293 RB = RBSH(NTARG)
11294 ELSE
11295 RA = RASH(NTARG)
11296 RB = RBSH(1)
11297 ENDIF
11298
11299 IF (ICENTR.EQ.2) THEN
11300 IF (RA.EQ.RB) THEN
11301 BB = DT_RNDM(B)*(0.3D0*RA)**2
11302 B = SQRT(BB)
11303 ELSEIF(RA.LT.RB)THEN
11304 BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11305 B = SQRT(BB)
11306 ELSEIF(RA.GT.RB)THEN
11307 BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11308 B = SQRT(BB)
11309 ENDIF
11310 ELSE
11311 9 CONTINUE
11312 Y = DT_RNDM(BB)
11313 I0 = 1
11314 I2 = NSITEB
11315 10 CONTINUE
11316 I1 = (I0+I2)/2
11317 LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11318 & *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11319 IF (LEFT) GOTO 20
11320 I0 = I1
11321 GOTO 30
11322 20 CONTINUE
11323 I2 = I1
11324 30 CONTINUE
11325 IF (I2-I0-2) 40,50,60
11326 40 CONTINUE
11327 I1 = I2+1
11328 IF (I1.GT.NSITEB) I1 = I0-1
11329 GOTO 70
11330 50 CONTINUE
11331 I1 = I0+1
11332 GOTO 70
11333 60 CONTINUE
11334 GOTO 10
11335 70 CONTINUE
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)
11342 80 CONTINUE
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
11351 IF (LFIRST) THEN
11352 LFIRST = .FALSE.
11353 IF (ICENTR.LE.-100) THEN
11354 BIMIN = 0.0D0
11355 ELSE
11356 XSFRAC = 0.0D0
11357 ENDIF
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',/)
11370 ENDIF
11371 IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11372 B = BIMIN
11373 ELSE
11374 IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11375 ENDIF
11376 ENDIF
11377 ENDIF
11378
11379 RETURN
11380 END
11381*
11382*===shfast=============================================================*
11383*
11384CDECK ID>, DT_SHFAST
11385 SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11386
11387 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11388 SAVE
11389
11390 PARAMETER ( LINP = 5 ,
11391 & LOUT = 6 ,
11392 & LDAT = 9 )
11393
11394 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11395 & ONE=1.0D0,TWO=2.0D0)
11396
11397 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11398
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),
11403 & NSITEB,NSTATB
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
11417
11418 IBACK = 0
11419
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)
11428 DO 10 I=1,100
11429 WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11430 10 CONTINUE
11431 WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11432 1003 FORMAT(1X,2I10,3E15.5)
11433 CLOSE(47)
11434 ELSE
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
11443 DO 11 I=1,100
11444 READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11445 11 CONTINUE
11446 READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11447 ELSE
11448 IBACK = 1
11449 ENDIF
11450 CLOSE(47)
11451 ENDIF
11452
11453 RETURN
11454 END
11455*
11456*===poilik=============================================================*
11457*
11458CDECK ID>, DT_POILIK
11459 SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11460
11461 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11462 SAVE
11463
11464 PARAMETER ( LINP = 5 ,
11465 & LOUT = 6 ,
11466 & LDAT = 9 )
11467
11468 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11469 PARAMETER (NE = 8)
11470
11471**PHOJET105a
11472C CHARACTER*8 MDLNA
11473C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11474C PARAMETER (IEETAB=10)
11475C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11476**PHOJET110
11477C model switches and parameters
11478 CHARACTER*8 MDLNA
11479 INTEGER ISWMDL,IPAMDL
11480 DOUBLE PRECISION PARMDL
11481 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11482C energy-interpolation table
11483 INTEGER IEETA2
11484 PARAMETER ( IEETA2 = 20 )
11485 INTEGER ISIMAX
11486 DOUBLE PRECISION SIGTAB,SIGECM
11487 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11488**
11489* VDM parameter for photon-nucleus interactions
11490 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11491**sr 22.7.97
11492
11493 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11494
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
11506**
11507
11508 DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11509
11510 IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11511
11512* load cross sections from interpolation table
11513 IP = 1
11514 IF(ECM.LE.SIGECM(IP,1)) THEN
11515 I1 = 1
11516 I2 = 1
11517 ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11518 DO 50 I=2,ISIMAX
11519 IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11520 50 CONTINUE
11521 200 CONTINUE
11522 I1 = I-1
11523 I2 = I
11524 ELSE
11525 WRITE(LOUT,'(/1X,A,2E12.3)')
11526 & 'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11527 I1 = ISIMAX
11528 I2 = ISIMAX
11529 ENDIF
11530 FAC2 = ZERO
11531 IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11532 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11533 FAC1 = ONE-FAC2
11534
11535 SIGANO = DT_SANO(ECM)
11536
11537* cross section dependence on photon virtuality
11538 FSUP1 = ZERO
11539 DO 150 I=1,3
11540 FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11541 & /(ONE+VIRT/PARMDL(30+I))**2
11542 150 CONTINUE
11543 FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11544 FAC1 = FAC1*FSUP1
11545 FAC2 = FAC2*FSUP1
11546 FSUP2 = ONE
11547
11548 ECMOLD = ECM
11549 Q2OLD = VIRT
11550
11551 3 CONTINUE
11552
11553C 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)
11557 ELSE
11558 SIGDIR = ZERO
11559 ENDIF
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
11565
11566 RR = DT_RNDM(SIGTOT)
11567 IF (RR.LT.SIGDIR/SIGTOT) THEN
11568 IPNT = 1
11569 ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11570 & (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11571 IPNT = 2
11572 ELSE
11573 IPNT = 0
11574 ENDIF
11575 RPNT = (SIGDIR+SIGANO)/SIGTOT
11576C WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11577C WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11578C WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11579C WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11580 IF (MODE.EQ.1) RETURN
11581
11582**sr 22.7.97
11583 K1 = 1
11584 K2 = 1
11585 RATE = ZERO
11586 IF (ECM.GE.ECMNN(NEBINI)) THEN
11587 K1 = NEBINI
11588 K2 = NEBINI
11589 RATE = ONE
11590 ELSEIF (ECM.GT.ECMNN(1)) THEN
11591 DO 10 I=2,NEBINI
11592 IF (ECM.LT.ECMNN(I)) THEN
11593 K1 = I-1
11594 K2 = I
11595 RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11596 GOTO 11
11597 ENDIF
11598 10 CONTINUE
11599 11 CONTINUE
11600 ENDIF
11601 J1 = 1
11602 J2 = 1
11603 RATQ = ZERO
11604 IF (NQBINI.GT.1) THEN
11605 IF (VIRT.GE.Q2G(NQBINI)) THEN
11606 J1 = NQBINI
11607 J2 = NQBINI
11608 RATQ = ONE
11609 ELSEIF (VIRT.GT.Q2G(1)) THEN
11610 DO 12 I=2,NQBINI
11611 IF (VIRT.LT.Q2G(I)) THEN
11612 J1 = I-1
11613 J2 = I
11614 RATQ = LOG10( VIRT/MAX(Q2G(J1),TINY14))/
11615 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11616 GOTO 13
11617 ENDIF
11618 12 CONTINUE
11619 13 CONTINUE
11620 ENDIF
11621 ENDIF
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
11629 SPL = SDI+SAN
11630 RR = DT_RNDM(SPL)
11631 IF (RR.LT.SDI/SGA) THEN
11632 IPNT = 1
11633 ELSEIF ((RR.GE.SDI/SGA).AND.
11634 & (RR.LT.SPL/SGA)) THEN
11635 IPNT = 2
11636 ELSE
11637 IPNT = 0
11638 ENDIF
11639 RPNT = SPL/SGA
11640C WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11641**
11642
11643 RETURN
11644 END
11645*
11646*===glbini=============================================================*
11647*
11648CDECK ID>, DT_GLBINI
11649 SUBROUTINE DT_GLBINI(WHAT)
11650
11651************************************************************************
11652* Pre-initialization of profile function *
11653* This version dated 28.11.00 is written by S. Roesler. *
11654************************************************************************
11655
11656 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11657 SAVE
11658
11659 PARAMETER ( LINP = 5 ,
11660 & LOUT = 6 ,
11661 & LDAT = 9 )
11662
11663 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11664
11665 LOGICAL LCMS
11666
11667* particle properties (BAMJET index convention)
11668 CHARACTER*8 ANAME
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
11673
11674 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11675
11676* emulsion treatment
11677 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11678 & NCOMPO,IEMUL
11679* Glauber formalism: flags and parameters for statistics
11680 LOGICAL LPROD
11681 CHARACTER*8 CGLB
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,
11692 & 0, 0, 1, 2, 2/
11693* Acceptance interval for target nucleus mass
11694 PARAMETER (KBACC = 6)
11695
11696 PARAMETER (MAXMSS = 100)
11697 DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11698 DIMENSION WHAT(6)
11699
11700 DATA JPEACH,JPSTEP / 18, 5 /
11701
11702* temporary patch until fix has been implemented in phojet:
11703* maximum energy for pion projectile
11704 DATA ECMXPI / 100000.0D0 /
11705*
11706*--------------------------------------------------------------------------
11707* general initializations
11708*
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))
11712*
11713* energy range and binning
11714 ELO = ABS(WHAT(1))
11715 EHI = ABS(WHAT(2))
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)
11720 IF (LCMS) THEN
11721 ECMINI = EHI
11722 ELSE
11723 ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11724 & +2.0D0*AAM(IJTARG)*EHI)
11725 ENDIF
11726*
11727* default arguments for Glauber-routine
11728 XI = ZERO
11729 Q2I = ZERO
11730*
11731* initialize nuclear parameters, etc.
11732
11733 CALL BERTTP
11734 CALL INCINI
11735
11736*
11737* open Glauber-data output file
11738 IDX = INDEX(CGLB,' ')
11739 K = 12
11740 IF (IDX.GT.1) K = IDX-1
11741 OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11742*
11743*--------------------------------------------------------------------------
11744* Glauber-initialization for proton and nuclei projectiles
11745*
11746* initialize phojet for proton-proton interactions
11747 ELAB = ZERO
11748 PLAB = ZERO
11749 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11750 CALL DT_PHOINI
11751*
11752* record projectile masses
11753 NASAV = 0
11754 NPROJ = MIN(IP,JPEACH)
11755 DO 10 KPROJ=1,NPROJ
11756 NASAV = NASAV+1
11757 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11758 IASAV(NASAV) = KPROJ
11759 10 CONTINUE
11760 IF (IP.GT.JPEACH) THEN
11761 NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11762 IF (NPROJ.EQ.0) THEN
11763 NASAV = NASAV+1
11764 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11765 IASAV(NASAV) = IP
11766 ELSE
11767 DO 11 IPROJ=1,NPROJ
11768 KPROJ = JPEACH+IPROJ*JPSTEP
11769 NASAV = NASAV+1
11770 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11771 IASAV(NASAV) = KPROJ
11772 11 CONTINUE
11773 IF (KPROJ.LT.IP) THEN
11774 NASAV = NASAV+1
11775 IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11776 IASAV(NASAV) = IP
11777 ENDIF
11778 ENDIF
11779 ENDIF
11780*
11781* record target masses
11782 NBSAV = 0
11783 NTARG = 1
11784 IF (NCOMPO.GT.0) NTARG = NCOMPO
11785 DO 12 ITARG=1,NTARG
11786 NBSAV = NBSAV+1
11787 IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11788 IF (NCOMPO.GT.0) THEN
11789 IBSAV(NBSAV) = IEMUMA(ITARG)
11790 ELSE
11791 IBSAV(NBSAV) = IT
11792 ENDIF
11793 12 CONTINUE
11794*
11795* print masses
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
11800 DO 13 I=1,NLINES
11801 IF (I.EQ.1) THEN
11802 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11803 ELSE
11804 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11805 ENDIF
11806 13 CONTINUE
11807 ENDIF
11808 I0 = 18*NLINES+1
11809 IF (I0.LE.NASAV) THEN
11810 IF (I0.EQ.1) THEN
11811 WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11812 ELSE
11813 WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11814 ENDIF
11815 ENDIF
11816 NLINES = DBLE(NBSAV)/18.0D0
11817 IF (NLINES.GT.0) THEN
11818 DO 14 I=1,NLINES
11819 IF (I.EQ.1) THEN
11820 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11821 ELSE
11822 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11823 ENDIF
11824 14 CONTINUE
11825 ENDIF
11826 I0 = 18*NLINES+1
11827 IF (I0.LE.NBSAV) THEN
11828 IF (I0.EQ.1) THEN
11829 WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11830 ELSE
11831 WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11832 ENDIF
11833 ENDIF
11834*
11835* calculate Glauber-data for each energy and mass combination
11836*
11837* loop over energy bins
11838 ELO = LOG10(ELO)
11839 EHI = LOG10(EHI)
11840 DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11841 DO 1 IE=1,NEBIN+1
11842 E = ELO+DBLE(IE-1)*DEBIN
11843 E = 10**E
11844 IF (LCMS) THEN
11845 E = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11846 ECM = E
11847 ELSE
11848 PLAB = ZERO
11849 ECM = ZERO
11850 E = MAX(AAM(IJPROJ)+0.1D0,E)
11851 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11852 ENDIF
11853*
11854* loop over projectile and target masses
11855 DO 2 ITARG=1,NBSAV
11856 DO 3 IPROJ=1,NASAV
11857 CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11858 & XI,Q2I,ECM,1,1,-1)
11859 3 CONTINUE
11860 2 CONTINUE
11861*
11862 1 CONTINUE
11863*
11864*--------------------------------------------------------------------------
11865* Glauber-initialization for pion, kaon, ... projectiles
11866*
11867 DO 6 IJ=1,MAXOFF
11868*
11869* initialize phojet for this interaction
11870 ELAB = ZERO
11871 PLAB = ZERO
11872 IJPROJ = IJPINI(IJ)
11873 IP = 1
11874 IPZ = 1
11875*
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)
11879 ELSE
11880 CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11881 ENDIF
11882 CALL DT_PHOINI
11883*
11884* calculate Glauber-data for each energy and mass combination
11885*
11886* loop over energy bins
11887 DO 4 IE=1,NEBIN+1
11888 E = ELO+DBLE(IE-1)*DEBIN
11889 E = 10**E
11890 IF (LCMS) THEN
11891 E = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11892 ECM = E
11893 ELSE
11894 PLAB = ZERO
11895 ECM = ZERO
11896 E = MAX(AAM(IJPROJ)+TINY14,E)
11897 CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11898 ENDIF
11899*
11900* loop over projectile and target masses
11901 DO 5 ITARG=1,NBSAV
11902 CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11903 5 CONTINUE
11904*
11905 4 CONTINUE
11906*
11907 6 CONTINUE
11908
11909*--------------------------------------------------------------------------
11910* close output unit(s), etc.
11911*
11912 CLOSE(LDAT)
11913
11914 RETURN
11915 END
11916*
11917*===glbset=============================================================*
11918*
11919CDECK 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************************************************************************
11925
11926 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11927 SAVE
11928
11929 PARAMETER ( LINP = 5 ,
11930 & LOUT = 6 ,
11931 & LDAT = 9 )
11932
11933 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11934
11935 LOGICAL LCMS,LREAD,LFRST1,LFRST2
11936
11937* particle properties (BAMJET index convention)
11938 CHARACTER*8 ANAME
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
11942 LOGICAL LPROD
11943 CHARACTER*8 CGLB
11944 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11945
11946 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11947
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),
11952 & NSITEB,NSTATB
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,
11973 & 0, 0, 1, 2, 2/
11974* Acceptance interval for target nucleus mass
11975 PARAMETER (KBACC = 6)
11976* emulsion treatment
11977 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11978 & NCOMPO,IEMUL
11979
11980 PARAMETER (MAXSET=5000,
11981 & MAXBIN=100)
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),
11985 & IAIDX(10)
11986
11987 DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11988*
11989* read data from file
11990*
11991 IF (MODE.EQ.0) THEN
11992
11993 IF (LREAD) RETURN
11994
11995 DO 1 I=1,MAXSET
11996 DO 2 J=1,6
11997 XSIG(I,J) = ZERO
11998 XERR(I,J) = ZERO
11999 2 CONTINUE
12000 DO 3 J=1,KSITEB
12001 BPROFL(I,J) = ZERO
12002 3 CONTINUE
12003 1 CONTINUE
12004 DO 4 I=1,MAXBIN
12005 IABIN(I) = 0
12006 IBBIN(I) = 0
12007 4 CONTINUE
12008 DO 5 I=1,KSITEB
12009 BPRO0(I) = ZERO
12010 BPRO1(I) = ZERO
12011 BPRO(I) = ZERO
12012 5 CONTINUE
12013
12014 IDX = INDEX(CGLB,' ')
12015 K = 12
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 ',
12020 & 'file ',A12,/)
12021*
12022* read binning information
12023 READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12024* return lower energy threshold to Fluka-interface
12025 ELAB = ELO
12026 LCMS = ELO.LT.ZERO
12027 WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12028 IF (LCMS) THEN
12029 WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12030 ELSE
12031 WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12032 ENDIF
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)
12042 ELSE
12043 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12044 ENDIF
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
12049 DO 7 I=1,NLINES
12050 I0 = 18*(I+1)-17
12051 READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12052 WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12053 7 CONTINUE
12054 ENDIF
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)
12059 ENDIF
12060 ENDIF
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)
12065 ELSE
12066 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12067 ENDIF
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
12072 DO 8 I=1,NLINES
12073 I0 = 18*(I+1)-17
12074 READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12075 WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12076 8 CONTINUE
12077 ENDIF
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)
12082 ENDIF
12083 ENDIF
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
12089*
12090* read profile function data
12091 NSET = 0
12092 NAIDX = 0
12093 IPOLD = 0
12094 10 CONTINUE
12095 NSET = NSET+1
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
12100 NAIDX = NAIDX+1
12101 IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12102 IAIDX(NAIDX) = IP
12103 IPOLD = IP
12104 ENDIF
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
12109 DO 11 I=1,NLINES
12110 READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12111 11 CONTINUE
12112 ENDIF
12113 I0 = 7*NLINES+1
12114 IF (I0.LE.ISITEB)
12115 & READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12116 GOTO 10
12117 100 CONTINUE
12118 NSET = NSET-1
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)
12124 ELSE
12125 WRITE(LOUT,'(6X,A)') 'none'
12126 ENDIF
12127*
12128 CLOSE(LDAT)
12129 WRITE(LOUT,*)
12130 LREAD = .TRUE.
12131
12132 IF (NCOMPO.EQ.0) THEN
12133 DO 12 J=1,NBBIN
12134 NCOMPO = NCOMPO+1
12135 IEMUMA(NCOMPO) = IBBIN(J)
12136 IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12137 EMUFRA(NCOMPO) = 1.0D0
12138 12 CONTINUE
12139 IEMUL = 1
12140 ENDIF
12141*
12142* calculate profile function for certain set of parameters
12143*
12144 ELSE
12145
12146c write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12147*
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
12155 ELSE
12156 IDXOFF = 0
12157 ENDIF
12158*
12159* get energy bin and interpolation factor
12160 IF (LCMS) THEN
12161 E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12162 ELSE
12163 E = ELAB
12164 ENDIF
12165 E = LOG10(E)
12166 IF (E.LT.ELO) THEN
12167 IF (LFRST1) THEN
12168 WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12169 LFRST1 = .FALSE.
12170 ENDIF
12171 E = ELO
12172 ENDIF
12173 IF (E.GT.EHI) THEN
12174 IF (LFRST2) THEN
12175 WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12176 LFRST2 = .FALSE.
12177 ENDIF
12178 E = EHI
12179 ENDIF
12180 IE0 = (E-ELO)/DEBIN+1
12181 IE1 = IE0+1
12182 FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12183*
12184* get target nucleus index
12185 KB = 0
12186 NBACC = KBACC
12187 DO 20 I=1,NBBIN
12188 NBDIFF = ABS(NB-IBBIN(I))
12189 IF (NB.EQ.IBBIN(I)) THEN
12190 KB = I
12191 GOTO 21
12192 ELSEIF (NBDIFF.LE.NBACC) THEN
12193 KB = I
12194 NBACC = NBDIFF
12195 ENDIF
12196 20 CONTINUE
12197 IF (KB.NE.0) GOTO 21
12198 WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12199 STOP
12200 21 CONTINUE
12201*
12202* get projectile nucleus bin and interpolation factor
12203 KA0 = 0
12204 KA1 = 0
12205 FACNA = 0
12206 IF (IDXOFF.GT.0) THEN
12207 KA0 = 1
12208 KA1 = 1
12209 KABIN = 1
12210 ELSE
12211 IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12212 DO 22 I=1,NABIN
12213 IF (NA.EQ.IABIN(I)) THEN
12214 KA0 = I
12215 KA1 = I
12216 GOTO 23
12217 ELSEIF (NA.LT.IABIN(I)) THEN
12218 KA0 = I-1
12219 KA1 = I
12220 GOTO 23
12221 ENDIF
12222 22 CONTINUE
12223 WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12224 STOP
12225 23 CONTINUE
12226 IF (KA0.NE.KA1)
12227 & FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12228 KABIN = NABIN
12229 ENDIF
12230*
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)
12237 DO 30 I=1,ISITEB
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))
12242 30 CONTINUE
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)
12246*
12247* interpolate cross sections for energy E and projectile mass
12248 DO 31 I=1,6
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)
12255 31 CONTINUE
12256*
12257* interpolate between ka0 and ka1
12258 RADA = DT_RNCLUS(NA)
12259 BMX = 2.0D0*(RADA+RADB)
12260 BSTP = BMX/DBLE(ISITEB-1)
12261 BPRO(1) = ZERO
12262 DO 32 I=1,ISITEB-1
12263 B = DBLE(I)*BSTP
12264*
12265* calculate values of profile functions at B
12266 IDX0 = B/BSTP0+1
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))
12271 IDX0 = B/BSTP1+1
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))
12276*
12277 BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12278 32 CONTINUE
12279*
12280* fill common dtglam
12281 NSITEB = ISITEB
12282 RASH(1) = RADA
12283 RBSH(1) = RADB
12284 BMAX(1) = BMX
12285 BSTEP(1) = BSTP
12286 DO 33 I=1,KSITEB
12287 BSITE(0,1,1,I) = BPRO(I)
12288 33 CONTINUE
12289*
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)
12303
12304 ENDIF
12305
12306 RETURN
12307 END
12308*
12309*===xksamp=============================================================*
12310*
12311CDECK ID>, DT_XKSAMP
12312 SUBROUTINE DT_XKSAMP(NN,ECM)
12313
12314************************************************************************
12315* Sampling of parton x-values and chain system for one interaction. *
12316* processed by S. Roesler, 9.8.95 *
12317************************************************************************
12318
12319 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12320 SAVE
12321
12322 PARAMETER ( LINP = 5 ,
12323 & LOUT = 6 ,
12324 & LDAT = 9 )
12325
12326 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12327 SAVE
12328
12329 PARAMETER (
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
12336 & XVMAX = 0.98D0,
12337* fraction of sea-diquarks sampled out of sea-partons
12338**test
12339C & FRCDIQ = 0.9D0,
12340**
12341*
12342 & SQMA = 0.7D0,
12343*
12344* maximum number of trials to generate x's for the required number
12345* of sea quark pairs for a given hadron
12346C & NSEATY = 12
12347 & NSEATY = 3
12348 & )
12349
12350 LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12351
12352 PARAMETER ( MAXNCL = 260,
12353
12354 & MAXVQU = MAXNCL,
12355 & MAXSQU = 20*MAXVQU,
12356 & MAXINT = MAXVQU+MAXSQU)
12357* event history
12358
12359 PARAMETER (NMXHKK=200000)
12360
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)
12365 CHARACTER*8 ANAME
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,
12375 & SSMIMQ,VVMTHR
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,
12413 & LCO2CR,LINTPT
12414
12415 DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12416 & INTLO(MAXINT)
12417
12418* (1) initializations
12419*-----------------------------------------------------------------------
12420
12421**test
12422 IF (ECM.LT.4.5D0) THEN
12423C FRCDIQ = 0.6D0
12424 FRCDIQ = 0.4D0
12425 ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12426C FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12427 FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12428 ELSE
12429C FRCDIQ = 0.9D0
12430 FRCDIQ = 0.7D0
12431 ENDIF
12432**
12433 DO 30 I=1,MAXSQU
12434 ZUOSP(I) = .FALSE.
12435 ZUOST(I) = .FALSE.
12436 IF (I.LE.MAXVQU) THEN
12437 ZUOVP(I) = .FALSE.
12438 ZUOVT(I) = .FALSE.
12439 ENDIF
12440 30 CONTINUE
12441
12442* lower thresholds for x-selection
12443* sea-quarks (default: CSEA=0.2)
12444 IF (ECM.LT.10.0D0) THEN
12445**!!test
12446 XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12447C XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12448 NSEA = NSEATY
12449C XSTHR = ONE/ECM**2
12450 ELSE
12451**sr 30.3.98
12452C XSTHR = CSEA/ECM
12453 XSTHR = CSEA/ECM**2
12454C XSTHR = ONE/ECM**2
12455**
12456 IF ((IP.GE.150).AND.(IT.GE.150))
12457 & XSTHR = 2.5D0/(ECM*SQRT(ECM))
12458 NSEA = NSEATY
12459 ENDIF
12460* (default: SSMIMA=0.14) used for sea-diquarks (?)
12461 XSSTHR = SSMIMA/ECM
12462 BSQMA = SQMA/ECM
12463* valence-quarks (default: CVQ=1.0)
12464 XVTHR = CVQ/ECM
12465* valence-diquarks (default: CDQ=2.0)
12466 XDTHR = CDQ/ECM
12467
12468* maximum-x for sea-quarks
12469 XVCUT = XVTHR+XDTHR
12470 IF (XVCUT.GT.XVMAX) THEN
12471 XVCUT = XVMAX
12472 XVTHR = XVCUT/3.0D0
12473 XDTHR = XVCUT-XVTHR
12474 ENDIF
12475 XXSEAM = ONE-XVCUT
12476**sr 18.4. test: DPMJET
12477C XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12478C & - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12479C & -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12480**
12481* maximum number of sea-pairs allowed kinematically
12482C NSMAX = INT(OHALF*XXSEAM/XSTHR)
12483 RNSMAX = OHALF*XXSEAM/XSTHR
12484 IF (RNSMAX.GT.10000.0D0) THEN
12485 NSMAX = 10000
12486 ELSE
12487 NSMAX = INT(OHALF*XXSEAM/XSTHR)
12488 ENDIF
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,')')
12495C XVTHR = XVMAX-XDTHR
12496C IF (XVTHR.LT.ZERO) STOP
12497 STOP
12498 ENDIF
12499
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
12503 UNOPRV = UNOM
12504 ELSE
12505 UNOPRV = UNON
12506 ENDIF
12507
12508* (2) select parton x-values of interacting projectile nucleons
12509*-----------------------------------------------------------------------
12510
12511 IXPV = 0
12512 IXPS = 0
12513
12514 DO 100 IPP=1,IP
12515* get interacting projectile nucleon as sampled by Glauber
12516 IF (JSSH(IPP).NE.0) THEN
12517 IXSTMP = IXPS
12518 IXVTMP = IXPV
12519 99 CONTINUE
12520 IXPS = IXSTMP
12521 IXPV = IXVTMP
12522* JIPP is the actual number of sea-pairs sampled for this nucleon
12523 JIPP = MIN(JSSH(IPP)-1,NSMAX)
12524 41 CONTINUE
12525 XXSEA = ZERO
12526 IF (JIPP.GT.0) THEN
12527 XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12528*???
12529 IF (XSTHR.GE.XSMAX) THEN
12530 JIPP = JIPP-1
12531 GOTO 41
12532 ENDIF
12533
12534*>>>get x-values of sea-quark pairs
12535 NSCOUN = 0
12536 PLW = 0.5D0
12537 40 CONTINUE
12538* accumulator for sea x-values
12539 XXSEA = ZERO
12540 NSCOUN = NSCOUN+1
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
12544 JIPP = JIPP-1
12545 NSCOUN = 0
12546 ENDIF
12547 DO 70 ISQ=1,JIPP
12548* sea-quarks
12549 IF (IPSQ(IXPS+1).LE.2) THEN
12550**sr 8.4.98 (1/sqrt(x))
12551C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12552C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12553 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12554**
12555 ELSE
12556 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12557 XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12558 ELSE
12559**sr 8.4.98 (1/sqrt(x))
12560C XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12561C XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12562 XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12563**
12564 ENDIF
12565 ENDIF
12566* sea-antiquarks
12567 IF (IPSAQ(IXPS+1).GE.-2) THEN
12568**sr 8.4.98 (1/sqrt(x))
12569C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12570C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12571 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12572**
12573 ELSE
12574 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12575 XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12576 ELSE
12577**sr 8.4.98 (1/sqrt(x))
12578C XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12579C XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12580 XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12581**
12582 ENDIF
12583 ENDIF
12584 XXSEA = XXSEA+XPSQI+XPSAQI
12585* check for maximum allowed sea x-value
12586 IF (XXSEA.GE.XXSEAM) THEN
12587 IXPS = IXPS-ISQ+1
12588 GOTO 40
12589 ENDIF
12590* accept this sea-quark pair
12591 IXPS = IXPS+1
12592 XPSQ(IXPS) = XPSQI
12593 XPSAQ(IXPS) = XPSAQI
12594 IFROSP(IXPS) = IPP
12595 ZUOSP(IXPS) = .TRUE.
12596 70 CONTINUE
12597 ENDIF
12598
12599*>>>get x-values of valence partons
12600* valence quark
12601 IF (XVTHR.GT.0.05D0) THEN
12602 XVHI = ONE-XXSEA-XDTHR
12603 XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12604 ELSE
12605 90 CONTINUE
12606 XPVQI = DT_DBETAR(OHALF,UNOPRV)
12607 IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12608 & GOTO 90
12609 ENDIF
12610* valence diquark
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
12616 IXPV = IXPV+1
12617 XPVQ(IXPV) = XPVQI
12618 XPVD(IXPV) = XPVDI
12619 IFROVP(IXPV) = IPP
12620 ITOVP(IPP) = IXPV
12621 ZUOVP(IXPV) = .TRUE.
12622
12623 ENDIF
12624 100 CONTINUE
12625
12626* (3) select parton x-values of interacting target nucleons
12627*-----------------------------------------------------------------------
12628
12629 IXTV = 0
12630 IXTS = 0
12631
12632 DO 170 ITT=1,IT
12633* get interacting target nucleon as sampled by Glauber
12634 IF (JTSH(ITT).NE.0) THEN
12635 IXSTMP = IXTS
12636 IXVTMP = IXTV
12637 169 CONTINUE
12638 IXTS = IXSTMP
12639 IXTV = IXVTMP
12640* JITT is the actual number of sea-pairs sampled for this nucleon
12641 JITT = MIN(JTSH(ITT)-1,NSMAX)
12642 111 CONTINUE
12643 XXSEA = ZERO
12644 IF (JITT.GT.0) THEN
12645 XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12646*???
12647 IF (XSTHR.GE.XSMAX) THEN
12648 JITT = JITT-1
12649 GOTO 111
12650 ENDIF
12651
12652*>>>get x-values of sea-quark pairs
12653 NSCOUN = 0
12654 PLW = 0.5D0
12655 110 CONTINUE
12656* accumulator for sea x-values
12657 XXSEA = ZERO
12658 NSCOUN = NSCOUN+1
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
12662 JITT = JITT-1
12663 NSCOUN = 0
12664 ENDIF
12665 DO 140 ISQ=1,JITT
12666* sea-quarks
12667 IF (ITSQ(IXTS+1).LE.2) THEN
12668**sr 8.4.98 (1/sqrt(x))
12669C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12670C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12671 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12672**
12673 ELSE
12674 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12675 XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12676 ELSE
12677**sr 8.4.98 (1/sqrt(x))
12678C XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12679C XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12680 XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12681**
12682 ENDIF
12683 ENDIF
12684* sea-antiquarks
12685 IF (ITSAQ(IXTS+1).GE.-2) THEN
12686**sr 8.4.98 (1/sqrt(x))
12687C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12688C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12689 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12690**
12691 ELSE
12692 IF (XSMAX.GT.XSTHR+BSQMA) THEN
12693 XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12694 ELSE
12695**sr 8.4.98 (1/sqrt(x))
12696C XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12697C XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12698 XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12699**
12700 ENDIF
12701 ENDIF
12702 XXSEA = XXSEA+XTSQI+XTSAQI
12703* check for maximum allowed sea x-value
12704 IF (XXSEA.GE.XXSEAM) THEN
12705 IXTS = IXTS-ISQ+1
12706 GOTO 110
12707 ENDIF
12708* accept this sea-quark pair
12709 IXTS = IXTS+1
12710 XTSQ(IXTS) = XTSQI
12711 XTSAQ(IXTS) = XTSAQI
12712 IFROST(IXTS) = ITT
12713 ZUOST(IXTS) = .TRUE.
12714 140 CONTINUE
12715 ENDIF
12716
12717*>>>get x-values of valence partons
12718* valence quark
12719 IF (XVTHR.GT.0.05D0) THEN
12720 XVHI = ONE-XXSEA-XDTHR
12721 XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12722 ELSE
12723 160 CONTINUE
12724 XTVQI = DT_DBETAR(OHALF,UNON)
12725 IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12726 & GOTO 160
12727 ENDIF
12728* valence diquark
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
12734 IXTV = IXTV+1
12735 XTVQ(IXTV) = XTVQI
12736 XTVD(IXTV) = XTVDI
12737 IFROVT(IXTV) = ITT
12738 ITOVT(ITT) = IXTV
12739 ZUOVT(IXTV) = .TRUE.
12740
12741 ENDIF
12742 170 CONTINUE
12743
12744* (4) get valence-valence chains
12745*-----------------------------------------------------------------------
12746
12747 NVV = 0
12748 DO 240 I=1,NN
12749 INTLO(I) = .TRUE.
12750 IPVAL = ITOVP(INTER1(I))
12751 ITVAL = ITOVT(INTER2(I))
12752 IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12753 INTLO(I) = .FALSE.
12754 ZUOVP(IPVAL) = .FALSE.
12755 ZUOVT(ITVAL) = .FALSE.
12756 NVV = NVV+1
12757 ISKPCH(8,NVV) = 0
12758 INTVV1(NVV) = IPVAL
12759 INTVV2(NVV) = ITVAL
12760 ENDIF
12761 240 CONTINUE
12762
12763* (5) get sea-valence chains
12764*-----------------------------------------------------------------------
12765
12766 NSV = 0
12767 NDV = 0
12768 PLW = 0.5D0
12769 DO 270 I=1,NN
12770 IF (INTLO(I)) THEN
12771 IPVAL = ITOVP(INTER1(I))
12772 ITVAL = ITOVT(INTER2(I))
12773 DO 250 J=1,IXPS
12774 IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12775 & ZUOVT(ITVAL)) THEN
12776 ZUOSP(J) = .FALSE.
12777 ZUOVT(ITVAL) = .FALSE.
12778 INTLO(I) = .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
12783 ENDIF
12784 NSV = NSV+1
12785 ISKPCH(4,NSV) = 0
12786 INTSV1(NSV) = J
12787 INTSV2(NSV) = ITVAL
12788
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
12795* q being s-quark
12796 AMCHK1 = AMAS
12797 AMCHK2 = AMIS
12798 ELSE
12799* q being u/d-quark
12800 AMCHK1 = AMAU
12801 AMCHK2 = AMIU
12802 ENDIF
12803* q-qq chain
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))
12808C XPSQXX = DT_SAMPEX(XPSQTH,XPSQ(J))
12809C XPSQXX = DT_SAMSQX(XPSQTH,XPSQ(J))
12810 XPSQXX = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12811**
12812 XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12813 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
12821 XPSQ(J) = XPSQW
12822 ENDIF
12823 ENDIF
12824* aq-q chain
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
12832 XPSAQ(J) = XPSQW
12833 ENDIF
12834 ENDIF
12835*>>>end of chain mass correction
12836
12837 GOTO 260
12838 ENDIF
12839 250 CONTINUE
12840 ENDIF
12841 260 CONTINUE
12842 270 CONTINUE
12843
12844* (6) get valence-sea chains
12845*-----------------------------------------------------------------------
12846
12847 NVS = 0
12848 NVD = 0
12849 DO 300 I=1,NN
12850 IF (INTLO(I)) THEN
12851 IPVAL = ITOVP(INTER1(I))
12852 ITVAL = ITOVT(INTER2(I))
12853 DO 280 J=1,IXTS
12854 IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12855 & (IFROST(J).EQ.INTER2(I))) THEN
12856 ZUOST(J) = .FALSE.
12857 ZUOVP(IPVAL) = .FALSE.
12858 INTLO(I) = .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
12863 ENDIF
12864 NVS = NVS + 1
12865 ISKPCH(6,NVS) = 0
12866 INTVS1(NVS) = IPVAL
12867 INTVS2(NVS) = J
12868
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
12875* q being s-quark
12876 AMCHK1 = AMIS
12877 AMCHK2 = AMAS
12878 ELSE
12879* q being u/d-quark
12880 AMCHK1 = AMIU
12881 AMCHK2 = AMAU
12882 ENDIF
12883* q-aq chain
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
12891 XTSAQ(J) = XTSQW
12892 ENDIF
12893 ENDIF
12894* qq-q chain
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))
12899C XTSQXX = DT_SAMPEX(XTSQTH,XTSQ(J))
12900C XTSQXX = DT_SAMSQX(XTSQTH,XTSQ(J))
12901 XTSQXX = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12902**
12903 XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12904 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
12912 XTSQ(J) = XTSQW
12913 ENDIF
12914 ENDIF
12915*>>>end of chain mass correction
12916
12917 GOTO 290
12918 ENDIF
12919 280 CONTINUE
12920 ENDIF
12921 290 CONTINUE
12922 300 CONTINUE
12923
12924* (7) get sea-sea chains
12925*-----------------------------------------------------------------------
12926
12927 NSS = 0
12928 NDS = 0
12929 NSD = 0
12930 DO 420 I=1,NN
12931 IF (INTLO(I)) THEN
12932 IPVAL = ITOVP(INTER1(I))
12933 ITVAL = ITOVT(INTER2(I))
12934* loop over target partons not yet matched
12935 DO 400 J=1,IXTS
12936 IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12937* loop over projectile partons not yet matched
12938 DO 390 JJ=1,IXPS
12939 IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12940 ZUOSP(JJ) = .FALSE.
12941 ZUOST(J) = .FALSE.
12942 INTLO(I) = .FALSE.
12943 NSS = NSS+1
12944 ISKPCH(1,NSS) = 0
12945 INTSS1(NSS) = JJ
12946 INTSS2(NSS) = J
12947
12948*---->chain recombination option
12949 VALFRA = DBLE(NVV/(NVV+IXPS+IXTS))
12950 IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12951 & THEN
12952* sea-sea chains may recombine with valence-valence chains
12953* only if they have the same projectile or target nucleon
12954 DO 4201 IVV=1,NVV
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
12961 ISKPCH(1,NSS) = 99
12962 ISKPCH(8,IVV) = 99
12963
12964* (a) assign new s-v chains
12965* ~~~~~~~~~~~~~~~~~~~~~~~~~
12966 IF (LSEADI.AND.
12967 & (DT_RNDM(VALFRA).GT.FRCDIQ))
12968 & THEN
12969* sample sea-diquark pair
12970 CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12971 & IREJ1)
12972 IF (IREJ1.EQ.0) GOTO 4202
12973 ENDIF
12974 NSV = NSV+1
12975 ISKPCH(4,NSV) = 0
12976 INTSV1(NSV) = JJ
12977 INTSV2(NSV) = IXVTA
12978*>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12979* the actual chain masses
12980 AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12981 & *ECM**2
12982 AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12983 & *ECM**2
12984* get lower mass cuts
12985 IF (IPSQ(JJ).EQ.3) THEN
12986* q being s-quark
12987 AMCHK1 = AMAS
12988 AMCHK2 = AMIS
12989 ELSE
12990* q being u/d-quark
12991 AMCHK1 = AMAU
12992 AMCHK2 = AMIU
12993 ENDIF
12994* q-qq chain
12995* chain mass above minimum - resampling of sea-q x-value
12996 IF (AMSVQ1.GT.AMCHK1) THEN
12997 XPSQTH =
12998 & AMCHK1/(XTVD(IXVTA)*ECM**2)
12999**sr 8.4.98 (1/sqrt(x))
13000 XPSQXX =
13001 & DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13002C & DT_SAMSQX(XPSQTH,XPSQ(JJ))
13003C & DT_SAMPEX(XPSQTH,XPSQ(JJ))
13004**
13005 XPVD(IPVAL) =
13006 & XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13007 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
13011 XPSQW =
13012 & AMCHK1/(XTVD(IXVTA)*ECM**2)
13013 DXPSQ = XPSQW-XPSQ(JJ)
13014 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13015 & THEN
13016 XPVD(IPVAL) =
13017 & XPVD(IPVAL)-DXPSQ
13018 XPSQ(JJ) = XPSQW
13019 ENDIF
13020 ENDIF
13021* aq-q chain
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
13025 XPSQW =
13026 & AMCHK2/(XTVQ(IXVTA)*ECM**2)
13027 DXPSQ = XPSQW-XPSAQ(JJ)
13028 IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13029 & THEN
13030 XPVD(IPVAL) =
13031 & XPVD(IPVAL)-DXPSQ
13032 XPSAQ(JJ) = XPSQW
13033 ENDIF
13034 ENDIF
13035*>>>>>>>>>>>end of chain mass correction
13036 4202 CONTINUE
13037
13038* (b) assign new v-s chains
13039* ~~~~~~~~~~~~~~~~~~~~~~~~~
13040 IF (LSEADI.AND.(
13041 & DT_RNDM(AMSVQ2).GT.FRCDIQ))
13042 & THEN
13043* sample sea-diquark pair
13044 CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13045 & IREJ1)
13046 IF (IREJ1.EQ.0) GOTO 4203
13047 ENDIF
13048 NVS = NVS+1
13049 ISKPCH(6,NVS) = 0
13050 INTVS1(NVS) = IXVPR
13051 INTVS2(NVS) = J
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
13058* q being s-quark
13059 AMCHK1 = AMIS
13060 AMCHK2 = AMAS
13061 ELSE
13062* q being u/d-quark
13063 AMCHK1 = AMIU
13064 AMCHK2 = AMAU
13065 ENDIF
13066* q-aq chain
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
13070 XTSQW =
13071 & AMCHK1/(XPVQ(IXVPR)*ECM**2)
13072 DXTSQ = XTSQW-XTSAQ(J)
13073 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13074 & THEN
13075 XTVD(ITVAL) =
13076 & XTVD(ITVAL)-DXTSQ
13077 XTSAQ(J) = XTSQW
13078 ENDIF
13079 ENDIF
13080 IF (AMVSQ2.GT.AMCHK2) THEN
13081 XTSQTH =
13082 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13083**sr 8.4.98 (1/sqrt(x))
13084 XTSQXX =
13085 & DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13086C & DT_SAMSQX(XTSQTH,XTSQ(J))
13087C & DT_SAMPEX(XTSQTH,XTSQ(J))
13088**
13089 XTVD(ITVAL) =
13090 & XTVD(ITVAL)+XTSQ(J)-XTSQXX
13091 XTSQ(J) = XTSQXX
13092 ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13093 XTSQW =
13094 & AMCHK2/(XPVD(IXVPR)*ECM**2)
13095 DXTSQ = XTSQW-XTSQ(J)
13096 IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13097 & THEN
13098 XTVD(ITVAL) =
13099 & XTVD(ITVAL)-DXTSQ
13100 XTSQ(J) = XTSQW
13101 ENDIF
13102 ENDIF
13103*>>>>>>>>>end of chain mass correction
13104 4203 CONTINUE
13105* jump out of s-s chain loop
13106 GOTO 420
13107 ENDIF
13108 ENDIF
13109 4201 CONTINUE
13110 ENDIF
13111*---->end of chain recombination option
13112
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
13117 ISKPCH(1,NSS) = 99
13118 GOTO 410
13119 ENDIF
13120 ENDIF
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
13125 ISKPCH(1,NSS) = 99
13126 GOTO 410
13127 ENDIF
13128 ENDIF
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-
13142 & 1.2D0*XSSTHR
13143 XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13144 & 1.2D0*XSSTHR
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
13149 ICOUS = 0
13150 310 CONTINUE
13151 ICOUS = ICOUS+1
13152 IF (XSSTHR.GT.0.05D0) THEN
13153 XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13154 & XSPMAX)
13155 XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13156 & XSPMAX)
13157 ELSE
13158 320 CONTINUE
13159 XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13160 IF ((XPSQI.LT.XSSTHR).OR.
13161 & (XPSQI.GT.XSPMAX)) GOTO 320
13162 330 CONTINUE
13163 XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13164 IF ((XPSAQI.LT.XSSTHR).OR.
13165 & (XPSAQI.GT.XSPMAX)) GOTO 330
13166 ENDIF
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
13171*!!!
13172C IF (ICOUS.LT.5) GOTO 310
13173 IF (ICOUS.LT.0.5D0) GOTO 310
13174 GOTO 380
13175 ENDIF
13176* resampling of x for target sea quark pair
13177 ICOUS = 0
13178 350 CONTINUE
13179 ICOUS = ICOUS+1
13180 IF (XSSTHR.GT.0.05D0) THEN
13181 XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13182 & XSTMAX)
13183 XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13184 & XSTMAX)
13185 ELSE
13186 360 CONTINUE
13187 XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13188 IF ((XTSQI.LT.XSSTHR).OR.
13189 & (XTSQI.GT.XSTMAX)) GOTO 360
13190 370 CONTINUE
13191 XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13192 IF ((XTSAQI.LT.XSSTHR).OR.
13193 & (XTSAQI.GT.XSTMAX)) GOTO 370
13194 ENDIF
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
13200 GOTO 380
13201 ENDIF
13202 XPVD(IPVAL) = XPVDCO
13203 XTVD(ITVAL) = XTVDCO
13204 XPSQ(JJ) = XPSQI
13205 XPSAQ(JJ) = XPSAQI
13206 XTSQ(J) = XTSQI
13207 XTSAQ(J) = XTSAQI
13208*>>>>>end of chain mass correction
13209 GOTO 410
13210 ENDIF
13211* come here to discard s-s interaction
13212* resampling of x values not allowed or unsuccessful
13213 380 CONTINUE
13214 INTLO(I) = .FALSE.
13215 ZUOST(J) = .TRUE.
13216 ZUOSP(JJ) = .TRUE.
13217 NSS = NSS-1
13218 ENDIF
13219* consider next s-s interaction
13220 GOTO 410
13221 ENDIF
13222 390 CONTINUE
13223 ENDIF
13224 400 CONTINUE
13225 ENDIF
13226 410 CONTINUE
13227 420 CONTINUE
13228
13229* correct x-values of valence quarks for non-matching sea quarks
13230 DO 430 I=1,IXPS
13231 IF (ZUOSP(I)) THEN
13232 IPVAL = ITOVP(IFROSP(I))
13233 XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13234 XPSQ(I) = ZERO
13235 XPSAQ(I) = ZERO
13236 ZUOSP(I) = .FALSE.
13237 ENDIF
13238 430 CONTINUE
13239 DO 440 I=1,IXTS
13240 IF (ZUOST(I)) THEN
13241 ITVAL = ITOVT(IFROST(I))
13242 XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13243 XTSQ(I) = ZERO
13244 XTSAQ(I) = ZERO
13245 ZUOST(I) = .FALSE.
13246 ENDIF
13247 440 CONTINUE
13248 DO 450 I=1,IXPV
13249 IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13250 450 CONTINUE
13251 DO 460 I=1,IXTV
13252 IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13253 460 CONTINUE
13254
13255 RETURN
13256 END
13257*
13258*===samsdq=============================================================*
13259*
13260CDECK ID>, DT_SAMSDQ
13261 SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13262
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************************************************************************
13276
13277 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13278 SAVE
13279
13280 PARAMETER (ZERO=0.0D0)
13281
13282* threshold values for x-sampling (DTUNUC 1.x)
13283 COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13284 & SSMIMQ,VVMTHR
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,
13289 & LCO2CR,LINTPT
13290
13291 PARAMETER ( MAXNCL = 260,
13292
13293 & MAXVQU = MAXNCL,
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)
13325
13326 IREJ = 0
13327* threshold-x for valence diquarks
13328 XDTHR = CDQ/ECM
13329
13330 GOTO (1,2,3,4) MODE
13331
13332*---------------------------------------------------------------------
13333* proj. valence partons - targ. sea partons
13334* get x-values and flavors for target sea-diquark pair
13335
13336 1 CONTINUE
13337 IDXVP = IDX1
13338 IDXST = IDX2
13339
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
13344
13345 IF (XXD.GE.ZERO) THEN
13346* x-values for the three diquarks of the target nucleon
13347 RR1 = DT_RNDM(XXD)
13348 RR2 = DT_RNDM(RR1)
13349 RR3 = DT_RNDM(RR2)
13350 SR123 = RR1+RR2+RR3
13351 XXTV = XDTHR+RR1*XXD/SR123
13352 XXTSQ = XDTHR+RR2*XXD/SR123
13353 XXTSAQ = XDTHR+RR3*XXD/SR123
13354 ELSE
13355 XXTV = XTVD(IDXVT)
13356 XXTSQ = XTSQ(IDXST)
13357 XXTSAQ = XTSAQ(IDXST)
13358 ENDIF
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.
13366* ss-asas pair
13367 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13368 IREJ = 1
13369 RETURN
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
13373 IREJ = 1
13374 RETURN
13375 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13376 IREJ = 1
13377 RETURN
13378 ENDIF
13379* accept the new sea-diquark
13380 XTVD(IDXVT) = XXTV
13381 XTSQ(IDXST) = XXTSQ
13382 XTSAQ(IDXST) = XXTSAQ
13383 NVD = NVD+1
13384 INTVD1(NVD) = IDXVP
13385 INTVD2(NVD) = IDXST
13386 ISKPCH(7,NVD) = 0
13387 RETURN
13388
13389*---------------------------------------------------------------------
13390* proj. sea partons - targ. valence partons
13391* get x-values and flavors for projectile sea-diquark pair
13392
13393 2 CONTINUE
13394 IDXSP = IDX2
13395 IDXVT = IDX1
13396
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
13401
13402 IF (XXD.GE.ZERO) THEN
13403* x-values for the three diquarks of the projectile nucleon
13404 RR1 = DT_RNDM(XXD)
13405 RR2 = DT_RNDM(RR1)
13406 RR3 = DT_RNDM(RR2)
13407 SR123 = RR1+RR2+RR3
13408 XXPV = XDTHR+RR1*XXD/SR123
13409 XXPSQ = XDTHR+RR2*XXD/SR123
13410 XXPSAQ = XDTHR+RR3*XXD/SR123
13411 ELSE
13412 XXPV = XPVD(IDXVP)
13413 XXPSQ = XPSQ(IDXSP)
13414 XXPSAQ = XPSAQ(IDXSP)
13415 ENDIF
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.
13423* ss-asas pair
13424 & ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0)) ) THEN
13425 IREJ = 1
13426 RETURN
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
13430 IREJ = 1
13431 RETURN
13432 ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13433 IREJ = 1
13434 RETURN
13435 ENDIF
13436* accept the new sea-diquark
13437 XPVD(IDXVP) = XXPV
13438 XPSQ(IDXSP) = XXPSQ
13439 XPSAQ(IDXSP) = XXPSAQ
13440 NDV = NDV+1
13441 INTDV1(NDV) = IDXSP
13442 INTDV2(NDV) = IDXVT
13443 ISKPCH(5,NDV) = 0
13444 RETURN
13445
13446*---------------------------------------------------------------------
13447* proj. sea partons - targ. sea partons
13448* get x-values and flavors for target sea-diquark pair
13449
13450 3 CONTINUE
13451 IDXSP = IDX1
13452 IDXST = IDX2
13453
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
13458
13459 IF (XXD.GE.ZERO) THEN
13460* x-values for the three diquarks of the target nucleon
13461 RR1 = DT_RNDM(XXD)
13462 RR2 = DT_RNDM(RR1)
13463 RR3 = DT_RNDM(RR2)
13464 SR123 = RR1+RR2+RR3
13465 XXTV = XDTHR+RR1*XXD/SR123
13466 XXTSQ = XDTHR+RR2*XXD/SR123
13467 XXTSAQ = XDTHR+RR3*XXD/SR123
13468 ELSE
13469 XXTV = XTVD(IDXVT)
13470 XXTSQ = XTSQ(IDXST)
13471 XXTSAQ = XTSAQ(IDXST)
13472 ENDIF
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.
13480* ss-asas pair
13481 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13482 IREJ = 1
13483 RETURN
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
13487 IREJ = 1
13488 RETURN
13489 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13490 IREJ = 1
13491 RETURN
13492 ENDIF
13493* accept the new sea-diquark
13494 XTVD(IDXVT) = XXTV
13495 XTSQ(IDXST) = XXTSQ
13496 XTSAQ(IDXST) = XXTSAQ
13497 NSD = NSD+1
13498 INTSD1(NSD) = IDXSP
13499 INTSD2(NSD) = IDXST
13500 ISKPCH(3,NSD) = 0
13501 RETURN
13502
13503*---------------------------------------------------------------------
13504* proj. sea partons - targ. sea partons
13505* get x-values and flavors for projectile sea-diquark pair
13506
13507 4 CONTINUE
13508 IDXSP = IDX2
13509 IDXST = IDX1
13510
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
13515
13516 IF (XXD.GE.ZERO) THEN
13517* x-values for the three diquarks of the projectile nucleon
13518 RR1 = DT_RNDM(XXD)
13519 RR2 = DT_RNDM(RR1)
13520 RR3 = DT_RNDM(RR2)
13521 SR123 = RR1+RR2+RR3
13522 XXPV = XDTHR+RR1*XXD/SR123
13523 XXPSQ = XDTHR+RR2*XXD/SR123
13524 XXPSAQ = XDTHR+RR3*XXD/SR123
13525 ELSE
13526 XXPV = XPVD(IDXVP)
13527 XXPSQ = XPSQ(IDXSP)
13528 XXPSAQ = XPSAQ(IDXSP)
13529 ENDIF
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.
13537* ss-asas pair
13538 & ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0)) ) THEN
13539 IREJ = 1
13540 RETURN
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
13544 IREJ = 1
13545 RETURN
13546 ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13547 IREJ = 1
13548 RETURN
13549 ENDIF
13550* accept the new sea-diquark
13551 XPVD(IDXVP) = XXPV
13552 XPSQ(IDXSP) = XXPSQ
13553 XPSAQ(IDXSP) = XXPSAQ
13554 NDS = NDS+1
13555 INTDS1(NDS) = IDXSP
13556 INTDS2(NDS) = IDXST
13557 ISKPCH(2,NDS) = 0
13558 RETURN
13559 END
13560*
13561*===difevt=============================================================*
13562*
13563CDECK ID>, DT_DIFEVT
13564 SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13565 & IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13566
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************************************************************************
13582
13583 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13584 SAVE
13585
13586 PARAMETER ( LINP = 5 ,
13587 & LOUT = 6 ,
13588 & LDAT = 9 )
13589
13590 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13591 & OHALF=0.5D0)
13592
13593* event history
13594
13595 PARAMETER (NMXHKK=200000)
13596
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),
13603 & IHIST(2,NMXHKK)
13604* flags for diffractive interactions (DTUNUC 1.x)
13605 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13606
13607 DIMENSION PP(4),PT(4)
13608
13609 LOGICAL LFIRST
13610 DATA LFIRST /.TRUE./
13611
13612 IREJ = 0
13613 JDIFF = 0
13614 IFLAGD = JDIFF
13615
13616* cm. energy
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))
13622
13623* single diffractive xsections
13624 CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13625* double diffractive xsections
13626**!! no double diff yet
13627C CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13628 DDTOT = 0.0D0
13629 DDHM = 0.0D0
13630**!!
13631* total inelastic xsection
13632C SIGIN = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13633 DUMZER = ZERO
13634 CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13635 SIGIN = MAX(SIGTO-SIGEL,ZERO)
13636
13637* fraction of diffractive processes
13638 FRADIF = (SDTOT+DDTOT)/SIGIN
13639
13640 IF (LFIRST) THEN
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 = ',
13644 & F5.1,' mb',/)
13645 LFIRST = .FALSE.
13646 ENDIF
13647
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!!
13654C FRADDH = DDHM/DDTOT
13655 FRADDH = 1.0D0
13656**
13657 IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13658* single diffraction
13659 KDIFF = 1
13660 IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13661 KP = 2
13662 KT = 0
13663 IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13664 & ISINGD.NE.3) THEN
13665 KP = 0
13666 KT = 2
13667 ENDIF
13668 ELSE
13669 KP = 1
13670 KT = 0
13671 IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13672 & ISINGD.NE.3) THEN
13673 KP = 0
13674 KT = 1
13675 ENDIF
13676 ENDIF
13677 ELSE
13678* double diffraction
13679 KDIFF = -1
13680 IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13681 KP = 2
13682 KT = 2
13683 ELSE
13684 KP = 1
13685 KT = 1
13686 ENDIF
13687 ENDIF
13688 CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13689 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13690 IF (IREJ1.EQ.0) THEN
13691 IFLAGD = 2*KDIFF
13692 IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13693 ELSE
13694 GOTO 9999
13695 ENDIF
13696 ENDIF
13697 JDIFF = IFLAGD
13698
13699 RETURN
13700
13701 9999 CONTINUE
13702 IREJ = 1
13703 RETURN
13704 END
13705*
13706*===difkin=============================================================*
13707*
13708CDECK ID>, DT_DIFFKI
13709 SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13710 & IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13711
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************************************************************************
13728
13729 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13730 SAVE
13731
13732 PARAMETER ( LINP = 5 ,
13733 & LOUT = 6 ,
13734 & LDAT = 9 )
13735
13736 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13737
13738 LOGICAL LSTART
13739
13740* particle properties (BAMJET index convention)
13741 CHARACTER*8 ANAME
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),
13754 & PPF(4),PTF(4),
13755 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13756 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13757
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)
13760
13761 DATA LSTART /.TRUE./
13762
13763 IF (LSTART) THEN
13764 WRITE(LOUT,2000)
13765 2000 FORMAT(/,1X,'DIFEVT: diffractive interactions treated ')
13766 LSTART = .FALSE.
13767 ENDIF
13768
13769 IREJ = 0
13770
13771* initialize common /DTDIKI/
13772 CALL DT_DIFINI
13773* store momenta of initial incoming particles for emc-check
13774 IF (LEMCCK) THEN
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)
13777 ENDIF
13778
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
13783 XMP = SQRT(XMP2)
13784 XMT = SQRT(XMT2)
13785* check quark-input (used to adjust coherence cond. for M-selection)
13786 IBP = 0
13787 IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13788 IBT = 0
13789 IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13790
13791* parameter for Lorentz-transformation into nucleon-nucleon cms
13792 DO 3 K=1,4
13793 PITOT(K) = PP(K)+PT(K)
13794 3 CONTINUE
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)
13800 GOTO 9999
13801 ENDIF
13802 XMTOT = SQRT(XMTOT2)
13803 DO 4 K=1,4
13804 BGTOT(K) = PITOT(K)/XMTOT
13805 4 CONTINUE
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))
13811* rotation angles
13812 COD = PP1(3)/PPTOT
13813C SID = SQRT((ONE-COD)*(ONE+COD))
13814 PPT = SQRT(PP1(1)**2+PP1(2)**2)
13815 SID = PPT/PPTOT
13816 COF = ONE
13817 SIF = ZERO
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)
13822 COF = COF/ANORF
13823 SIF = SIF/ANORF
13824 ENDIF
13825* check consistency
13826 DO 5 K=1,4
13827 DEV1(K) = ABS(PP1(K)+PT1(K))
13828 5 CONTINUE
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! ',
13834 & /,8X,4E12.3)
13835 GOTO 9999
13836 ENDIF
13837
13838* select x-fractions in high-mass diff. interactions
13839 IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13840
13841* select diffractive masses
13842* - projectile
13843 IF (KP.EQ.1) THEN
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)
13849 ELSE
13850 XMPF = XMP
13851 ENDIF
13852* - target
13853 IF (KT.EQ.1) THEN
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)
13859 ELSE
13860 XMTF = XMT
13861 ENDIF
13862
13863* kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13864 XMPF2 = XMPF**2
13865 XMTF2 = XMTF**2
13866 PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13867 PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13868
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
13874
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)
13883 GOTO 9999
13884 ENDIF
13885 CALL DT_DSFECF(SINPHI,COSPHI)
13886 PPBLT = SQRT(PPBLT2)
13887 PPBLOB(1) = COSPHI*PPBLT
13888 PPBLOB(2) = SINPHI*PPBLT
13889
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,
13892 & XX,YY,ZZ)
13893 PPBLOB(1) = XX
13894 PPBLOB(2) = YY
13895 PPBLOB(3) = ZZ
13896
13897* 4-momentum of excited/elastically scattered target and of exchanged
13898* Pomeron
13899 DO 6 K=1,4
13900 IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13901 PPOM1(K) = PP1(K)-PPBLOB(K)
13902 6 CONTINUE
13903 PTBLOB(4) = XMTOT-PPBLOB(4)
13904
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))
13915
13916* store 4-momentum of elastically scattered particle (in single diff.
13917* events)
13918 IF (KP.EQ.0) THEN
13919 DO 7 K=1,4
13920 PSC(K) = PPF(K)
13921 7 CONTINUE
13922 ELSEIF (KT.EQ.0) THEN
13923 DO 8 K=1,4
13924 PSC(K) = PTF(K)
13925 8 CONTINUE
13926 ENDIF
13927
13928* check consistency of kinematical treatment so far
13929 IF (LEMCCK) THEN
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
13934 ENDIF
13935 DO 9 K=1,4
13936 DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13937 DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13938 9 CONTINUE
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! ',
13945 & 2(/,8X,4E12.3))
13946 GOTO 9999
13947 ENDIF
13948
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
13952
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
13956
13957 RETURN
13958
13959 9999 CONTINUE
13960 IRDIFF(1) = IRDIFF(1)+1
13961 IREJ = 1
13962 RETURN
13963 END
13964*
13965*===xmhmd==============================================================*
13966*
13967CDECK ID>, DT_XMHMD
13968 DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13969
13970************************************************************************
13971* Diffractive mass in high mass single/double diffractive events. *
13972* This version dated 11.02.95 is written by S. Roesler *
13973************************************************************************
13974
13975 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13976 SAVE
13977
13978 PARAMETER ( LINP = 5 ,
13979 & LOUT = 6 ,
13980 & LDAT = 9 )
13981
13982 PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13983
13984* kinematics of diffractive interactions (DTUNUC 1.x)
13985 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13986 & PPF(4),PTF(4),
13987 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13988 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13989
13990C DATA XCOLOW /0.05D0/
13991 DATA XCOLOW /0.15D0/
13992
13993 DT_XMHMD = ZERO
13994 XH = XPH(2)
13995 IF (MODE.EQ.2) XH = XTH(2)
13996
13997* minimum Pomeron-x for high-mass diffraction
13998* (adjusted to get a smooth transition between HM and LM component)
13999 R = DT_RNDM(XH)
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)
14004 ENDIF
14005* maximum Pomeron-x for high-mass diffraction
14006* (coherence condition, adjusted to fit to experimental data)
14007 IF (IB.NE.0) THEN
14008* baryon-diffraction
14009 XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14010 ELSE
14011* meson-diffraction
14012 XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14013 ENDIF
14014* check boundaries
14015 IF (XDIMIN.GE.XDIMAX) THEN
14016 XDIMIN = OHALF*XDIMAX
14017 ENDIF
14018
14019 KLOOP = 0
14020 1 CONTINUE
14021 KLOOP = KLOOP+1
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
14028
14029 RETURN
14030 END
14031*
14032*===xmlmd==============================================================*
14033*
14034CDECK ID>, DT_XMLMD
14035 DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14036
14037************************************************************************
14038* Diffractive mass in high mass single/double diffractive events. *
14039* This version dated 11.02.95 is written by S. Roesler *
14040************************************************************************
14041
14042 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14043 SAVE
14044
14045 PARAMETER ( LINP = 5 ,
14046 & LOUT = 6 ,
14047 & LDAT = 9 )
14048
14049* minimum Pomeron-x for low-mass diffraction
14050C AMO = 1.5D0
14051 AMO = 2.0D0
14052* maximum Pomeron-x for low-mass diffraction
14053* (adjusted to get a smooth transition between HM and LM component)
14054 R = DT_RNDM(AMO)
14055 SAM = 1.0D0
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
14060
14061* selection of diffractive mass
14062* (adjusted to get a smooth transition between HM and LM component)
14063 R = DT_RNDM(AMU)
14064 IF (ECM.LE.50.0D0) THEN
14065 DT_XMLMD = AMO*(AMU/AMO)**R
14066 ELSE
14067 A = 0.7D0
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))
14070 ENDIF
14071
14072 RETURN
14073 END
14074*
14075*===tdiff==============================================================*
14076*
14077CDECK ID>, DT_TDIFF
14078 DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14079
14080************************************************************************
14081* t-selection for single/double diffractive interactions. *
14082* ECM cm. energy *
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************************************************************************
14091
14092 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14093 SAVE
14094
14095 PARAMETER ( LINP = 5 ,
14096 & LOUT = 6 ,
14097 & LDAT = 9 )
14098
14099 PARAMETER (ZERO=0.0D0)
14100
14101 PARAMETER ( BTP0 = 3.7D0,
14102 & ALPHAP = 0.24D0 )
14103
14104 IREJ = 0
14105 NCLOOP = 0
14106 DT_TDIFF = ZERO
14107
14108 IF (K1.GT.0) THEN
14109 XM1 = XM1I
14110 XM2 = XM2I
14111 ELSE
14112 XM1 = XM2I
14113 ENDIF
14114 XDI = (XM1/ECM)**2
14115 IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14116* slope for single diffraction
14117 SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14118 ELSE
14119* slope for double diffraction
14120 SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14121 ENDIF
14122
14123 1 CONTINUE
14124 NCLOOP = NCLOOP+1
14125 IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14126 Y = DT_RNDM(XDI)
14127 T = -LOG(1.0D0-Y)/SLOPE
14128 IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14129 DT_TDIFF = -ABS(T)
14130
14131 RETURN
14132
14133 9999 CONTINUE
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)
14138 IREJ = 1
14139 RETURN
14140 END
14141*
14142*===xvalhm=============================================================*
14143*
14144CDECK ID>, DT_XVALHM
14145 SUBROUTINE DT_XVALHM(KP,KT)
14146
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************************************************************************
14151
14152 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14153 SAVE
14154
14155 PARAMETER ( LINP = 5 ,
14156 & LOUT = 6 ,
14157 & LDAT = 9 )
14158
14159 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14160
14161* kinematics of diffractive interactions (DTUNUC 1.x)
14162 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14163 & PPF(4),PTF(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,
14170 & LCO2CR,LINTPT
14171
14172 DATA UNON,XVQTHR /2.0D0,0.8D0/
14173
14174 IF (KP.EQ.2) THEN
14175* x-fractions of projectile valence partons
14176 1 CONTINUE
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
14181 XPOLO = TINY2
14182 XPOHI = ONE-TINY2
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))
14187 IFPPO(1) = IFLAV
14188 IFPPO(2) = -IFLAV
14189 IF (DT_RNDM(UNON).GT.OHALF) THEN
14190 IFPPO(1) = -IFLAV
14191 IFPPO(2) = IFLAV
14192 ENDIF
14193 ENDIF
14194
14195 IF (KT.EQ.2) THEN
14196* x-fractions of projectile target partons
14197 2 CONTINUE
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
14202 XPOLO = TINY2
14203 XPOHI = ONE-TINY2
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))
14208 IFTPO(1) = IFLAV
14209 IFTPO(2) = -IFLAV
14210 IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14211 IFTPO(1) = -IFLAV
14212 IFTPO(2) = IFLAV
14213 ENDIF
14214 ENDIF
14215
14216 RETURN
14217 END
14218*
14219*===lm2res=============================================================*
14220*
14221CDECK ID>, DT_LM2RES
14222 SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14223
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************************************************************************
14231
14232 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14233 SAVE
14234
14235 PARAMETER ( LINP = 5 ,
14236 & LOUT = 6 ,
14237 & LDAT = 9 )
14238
14239 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14240
14241* kinematics of diffractive interactions (DTUNUC 1.x)
14242 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14243 & PPF(4),PTF(4),
14244 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14245 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14246
14247 IREJ = 0
14248 IF1B = 0
14249 IF2B = 0
14250 XMI = XM
14251
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)
14257
14258* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14259 IDCH = 2
14260 IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14261
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
14265
14266 XM = XMN
14267 RETURN
14268
14269 9999 CONTINUE
14270 IREJ = 1
14271 RETURN
14272 END
14273*
14274*===lmkine=============================================================*
14275*
14276CDECK ID>, DT_LMKINE
14277 SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14278
14279************************************************************************
14280* Kinematical treatment of low-mass excitations. *
14281* This version dated 12.02.95 is written by S. Roesler *
14282************************************************************************
14283
14284 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14285 SAVE
14286
14287 PARAMETER ( LINP = 5 ,
14288 & LOUT = 6 ,
14289 & LDAT = 9 )
14290
14291 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14292
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),
14299 & PPF(4),PTF(4),
14300 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14301 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14302
14303 DIMENSION P1(4),P2(4)
14304
14305 IREJ = 0
14306
14307 IF (KP.EQ.1) THEN
14308 PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14309 POE = PPF(4)/PABS
14310 FAC1 = OHALF*(POE+ONE)
14311 FAC2 = -OHALF*(POE-ONE)
14312 DO 1 K=1,3
14313 PPLM1(K) = FAC1*PPF(K)
14314 PPLM2(K) = FAC2*PPF(K)
14315 1 CONTINUE
14316 PPLM1(4) = FAC1*PABS
14317 PPLM2(4) = -FAC2*PABS
14318 IF (IMSHL.EQ.1) THEN
14319
14320 XM1 = PYMASS(IFP1)
14321 XM2 = PYMASS(IFP2)
14322
14323 CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14324 IF (IREJ1.NE.0) GOTO 9999
14325 DO 2 K=1,4
14326 PPLM1(K) = P1(K)
14327 PPLM2(K) = P2(K)
14328 2 CONTINUE
14329 ENDIF
14330 ENDIF
14331
14332 IF (KT.EQ.1) THEN
14333 PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14334 POE = PTF(4)/PABS
14335 FAC1 = OHALF*(POE+ONE)
14336 FAC2 = -OHALF*(POE-ONE)
14337 DO 3 K=1,3
14338 PTLM2(K) = FAC1*PTF(K)
14339 PTLM1(K) = FAC2*PTF(K)
14340 3 CONTINUE
14341 PTLM2(4) = FAC1*PABS
14342 PTLM1(4) = -FAC2*PABS
14343 IF (IMSHL.EQ.1) THEN
14344
14345 XM1 = PYMASS(IFT1)
14346 XM2 = PYMASS(IFT2)
14347
14348 CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14349 IF (IREJ1.NE.0) GOTO 9999
14350 DO 4 K=1,4
14351 PTLM1(K) = P1(K)
14352 PTLM2(K) = P2(K)
14353 4 CONTINUE
14354 ENDIF
14355 ENDIF
14356
14357 RETURN
14358
14359 9999 CONTINUE
14360 WRITE(LOUT,'(A)') 'LMKINE: kinematical treatment rejected'
14361 IREJ = 1
14362 RETURN
14363 END
14364*
14365*===difini=============================================================*
14366*
14367CDECK ID>, DT_DIFINI
14368 SUBROUTINE DT_DIFINI
14369
14370************************************************************************
14371* Initialization of common /DTDIKI/ *
14372* This version dated 12.02.95 is written by S. Roesler *
14373************************************************************************
14374
14375 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14376 SAVE
14377
14378 PARAMETER ( LINP = 5 ,
14379 & LOUT = 6 ,
14380 & LDAT = 9 )
14381
14382 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14383
14384* kinematics of diffractive interactions (DTUNUC 1.x)
14385 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14386 & PPF(4),PTF(4),
14387 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14388 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14389
14390 DO 1 K=1,4
14391 PPOM(K) = ZERO
14392 PSC(K) = ZERO
14393 PPF(K) = ZERO
14394 PTF(K) = ZERO
14395 PPLM1(K) = ZERO
14396 PPLM2(K) = ZERO
14397 PTLM1(K) = ZERO
14398 PTLM2(K) = ZERO
14399 1 CONTINUE
14400 DO 2 K=1,2
14401 XPH(K) = ZERO
14402 XPPO(K) = ZERO
14403 XTH(K) = ZERO
14404 XTPO(K) = ZERO
14405 IFPPO(K) = 0
14406 IFTPO(K) = 0
14407 2 CONTINUE
14408 IDPR = 0
14409 IDXPR = 0
14410 IDTR = 0
14411 IDXTR = 0
14412
14413 RETURN
14414 END
14415*
14416*===difput=============================================================*
14417*
14418CDECK ID>, DT_DIFPUT
14419 SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14420 & IREJ)
14421
14422************************************************************************
14423* Dump diffractive chains into DTEVT1 *
14424* This version dated 12.02.95 is written by S. Roesler *
14425************************************************************************
14426
14427 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14428 SAVE
14429
14430 PARAMETER ( LINP = 5 ,
14431 & LOUT = 6 ,
14432 & LDAT = 9 )
14433
14434 PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14435
14436 LOGICAL LCHK
14437
14438* kinematics of diffractive interactions (DTUNUC 1.x)
14439 COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14440 & PPF(4),PTF(4),
14441 & PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14442 & IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14443* event history
14444
14445 PARAMETER (NMXHKK=200000)
14446
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),
14453 & IHIST(2,NMXHKK)
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
14458
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)
14461
14462 IREJ = 0
14463
14464 IF (KP.EQ.1) THEN
14465 DO 1 K=1,4
14466 PCH(K) = PPLM1(K)+PPLM2(K)
14467 1 CONTINUE
14468 ID1 = IFP1
14469 ID2 = IFP2
14470 IF (DT_RNDM(PT).GT.OHALF) THEN
14471 ID1 = IFP2
14472 ID2 = IFP1
14473 ENDIF
14474 CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14475 & PPLM1(4),0,0,0)
14476 CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14477 & PPLM2(4),0,0,0)
14478 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14479 & IDPR,IDXPR,8)
14480 ELSEIF (KP.EQ.2) THEN
14481 DO 2 K=1,4
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)
14486 2 CONTINUE
14487 CALL DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14488 XM1 = ZERO
14489 XM2 = ZERO
14490 IF (LCHK) THEN
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
14495 DO 3 K=1,4
14496 PP1(K) = P1(K)
14497 PT1(K) = P2(K)
14498 PP2(K) = P3(K)
14499 PT2(K) = P4(K)
14500 3 CONTINUE
14501 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14502 & 0,0,8)
14503 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14504 & PT1(4),0,0,8)
14505 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14506 & 0,0,8)
14507 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14508 & PT2(4),0,0,8)
14509 ELSE
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
14514 DO 4 K=1,4
14515 PP1(K) = P1(K)
14516 PT2(K) = P2(K)
14517 PP2(K) = P3(K)
14518 PT1(K) = P4(K)
14519 4 CONTINUE
14520 CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14521 & 0,0,8)
14522 CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14523 & PT2(4),0,0,8)
14524 CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14525 & 0,0,8)
14526 CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14527 & PT1(4),0,0,8)
14528 ENDIF
14529 NCSY = NCSY+1
14530 ELSE
14531 CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14532 & 0,0,0)
14533 ENDIF
14534
14535 IF (KT.EQ.1) THEN
14536 DO 5 K=1,4
14537 PCH(K) = PTLM1(K)+PTLM2(K)
14538 5 CONTINUE
14539 ID1 = IFT1
14540 ID2 = IFT2
14541 IF (DT_RNDM(PT).GT.OHALF) THEN
14542 ID1 = IFT2
14543 ID2 = IFT1
14544 ENDIF
14545 CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14546 & PTLM1(4),0,0,0)
14547 CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14548 & PTLM2(4),0,0,0)
14549 CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14550 & IDTR,IDXTR,8)
14551 ELSEIF (KT.EQ.2) THEN
14552 DO 6 K=1,4
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)
14557 6 CONTINUE
14558 CALL DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14559 XM1 = ZERO
14560 XM2 = ZERO
14561 IF (LCHK) THEN
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
14566 DO 7 K=1,4
14567 PP1(K) = P1(K)
14568 PT1(K) = P2(K)
14569 PP2(K) = P3(K)
14570 PT2(K) = P4(K)
14571 7 CONTINUE
14572 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14573 & PP1(4),0,0,8)
14574 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14575 & 0,0,8)
14576 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14577 & PP2(4),0,0,8)
14578 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14579 & 0,0,8)
14580 ELSE
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
14585 DO 8 K=1,4
14586 PP1(K) = P1(K)
14587 PT2(K) = P2(K)
14588 PP2(K) = P3(K)
14589 PT1(K) = P4(K)
14590 8 CONTINUE
14591 CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14592 & PP1(4),0,0,8)
14593 CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14594 & 0,0,8)
14595 CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14596 & PP2(4),0,0,8)
14597 CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14598 & 0,0,8)
14599 ENDIF
14600 NCSY = NCSY+1
14601 ELSE
14602 CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14603 & 0,0,0)
14604 ENDIF
14605
14606 RETURN
14607
14608 9999 CONTINUE
14609 IRDIFF(2) = IRDIFF(2)+1
14610 IREJ = 1
14611 RETURN
14612 END
14613*
14614*===evtfrg=============================================================*
14615*
14616CDECK ID>, DT_EVTFRG
14617 SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14618
14619************************************************************************
14620* Hadronization of chains in DTEVT1. *
14621* *
14622* Input: *
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 *
14629* Output: *
14630* NPYMEM number of entries in JETSET-common after hadronization *
14631* IREJ rejection flag *
14632* *
14633* This version dated 17.09.00 is written by S. Roesler *
14634************************************************************************
14635
14636 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14637 SAVE
14638
14639 PARAMETER ( LINP = 5 ,
14640 & LOUT = 6 ,
14641 & LDAT = 9 )
14642
14643 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14644 PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14645
14646 LOGICAL LACCEP
14647
14648 PARAMETER (MXJOIN=200)
14649
14650* event history
14651
14652 PARAMETER (NMXHKK=200000)
14653
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),
14660 & IHIST(2,NMXHKK)
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
14665* statistics
14666 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14667 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14668 & ICEVTG(8,0:30)
14669* flags for diffractive interactions (DTUNUC 1.x)
14670 COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14671* nucleon-nucleon event-generator
14672 CHARACTER*8 CMODEL
14673 LOGICAL LPHOIN
14674 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14675* phojet
14676C model switches and parameters
14677 CHARACTER*8 MDLNA
14678 INTEGER ISWMDL,IPAMDL
14679 DOUBLE PRECISION PARMDL
14680 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14681* jetset
14682
14683 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14684
14685 PARAMETER (MAXLND=4000)
14686 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14687
14688 INTEGER PYK
14689
14690 DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14691
14692 MODE = KMODE
14693 ISTSTG = 7
14694 IF (MODE.NE.1) ISTSTG = 8
14695 IREJ = 0
14696
14697 IP = 0
14698 ISH = 0
14699 INIEMC = 1
14700 NEND = NHKK
14701 NACCEP = 0
14702 IFRG = 0
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
14706C LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14707C & ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14708 LACCEP = .TRUE.
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
14715 IFRG = IPJE
14716 IF (IFRG.GT.NFRG) GOTO 16
14717 ENDIF
14718 ELSE
14719 IPJE = 1
14720 IFRG = IFRG+1
14721 IF (IFRG.GT.NFRG) THEN
14722 NFRG = -1
14723 GOTO 16
14724 ENDIF
14725 ENDIF
14726* statistics counter
14727c IF (IDCH(I).LE.8)
14728c & ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14729c 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
14733 ID = IDXRES(I)
14734 ELSE
14735 ID = IDT_IPDGHA(IDXRES(I))
14736 ENDIF
14737 IF (LEMCCK) THEN
14738 CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14739 & PHKK(4,I),INIEMC,IDUM,IDUM)
14740 INIEMC = 2
14741 ENDIF
14742 IP = IP+1
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)
14749 K(IP,1) = 1
14750 K(IP,2) = ID
14751 K(IP,3) = 0
14752 K(IP,4) = 0
14753 K(IP,5) = 0
14754 IHIST(2,I) = 10000*IPJE+IP
14755 IF (IHIST(1,I).LE.-100) THEN
14756 ISH = ISH+1
14757 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14758 ISJOIN(ISH) = I
14759 ENDIF
14760 N = IP
14761 IHISMO(IP) = I
14762 ELSE
14763 IJ = 0
14764 DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14765 IF (LEMCCK) THEN
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)
14769 INIEMC = 2
14770 ENDIF
14771 ID = IDHKK(KK)
14772 IF (ID.EQ.0) ID = 21
14773c PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14774c AM0 = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14775
14776c AMRQ = PYMASS(ID)
14777
14778c AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14779c IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14780c & (ABS(IDIFF).EQ.0)) THEN
14781cC WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14782c DELTA = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14783c PHKK(4,KK) = PHKK(4,KK)+DELTA
14784c PTOT1 = PTOT-DELTA
14785c PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14786c PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14787c PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14788c PHKK(5,KK) = AMRQ
14789c ENDIF
14790 IP = IP+1
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)
14797 K(IP,1) = 1
14798 K(IP,2) = ID
14799 K(IP,3) = 0
14800 K(IP,4) = 0
14801 K(IP,5) = 0
14802 IHIST(2,KK) = 10000*IPJE+IP
14803 IF (IHIST(1,KK).LE.-100) THEN
14804 ISH = ISH+1
14805 IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14806 ISJOIN(ISH) = KK
14807 ENDIF
14808 IJ = IJ+1
14809 IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14810 IJOIN(IJ) = IP
14811 IHISMO(IP) = I
14812 11 CONTINUE
14813 N = IP
14814* join the two-parton system
14815
14816 CALL PYJOIN(IJ,IJOIN)
14817
14818 ENDIF
14819 IDHKK(I) = 99999
14820 ENDIF
14821 10 CONTINUE
14822 16 CONTINUE
14823 N = IP
14824
14825 IF (IP.GT.0) THEN
14826
14827* final state parton shower
14828 DO 136 NPJE=1,IPJE
14829 IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14830 IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14831 DO 130 K1=1,ISH
14832 IF (ISJOIN(K1).EQ.0) GOTO 130
14833 I = ISJOIN(K1)
14834 IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14835 & GOTO 130
14836 IH1 = IHIST(2,I)/10000
14837 IF (IH1.NE.NPJE) GOTO 130
14838 IH1 = IHIST(2,I)-IH1*10000
14839 DO 135 K2=K1+1,ISH
14840 IF (ISJOIN(K2).EQ.0) GOTO 135
14841 II = ISJOIN(K2)
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)
14848
14849 RQLUN = MIN(PT1,PT2)
14850 CALL PYSHOW(IH1,IH2,RQLUN)
14851
14852 ISJOIN(K1) = 0
14853 ISJOIN(K2) = 0
14854 GOTO 130
14855 ENDIF
14856 135 CONTINUE
14857 130 CONTINUE
14858 ENDIF
14859 ENDIF
14860 136 CONTINUE
14861
14862 CALL DT_INITJS(MODE)
14863* hadronization
14864
14865 CALL PYEXEC
14866
14867 IF (MSTU(24).NE.0) THEN
14868 WRITE(LOUT,*) ' JETSET-reject at event',
14869 & NEVHKK,MSTU(24),KMODE
14870C CALL DT_EVTOUT(4)
14871
14872C CALL PYLIST(2)
14873
14874 GOTO 9999
14875 ENDIF
14876
14877* number of entries in LUJETS
14878
14879 NLINES = PYK(0,1)
14880
14881 NPYMEM = NLINES
14882
14883 DO 12 I=1,NLINES
14884 IFLG(I) = 0
14885 12 CONTINUE
14886
14887 DO 13 II=1,NLINES
14888
14889 IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14890
14891* pick up mother resonance if possible and put it together with
14892* their decay-products into the common
14893 IDXMOR = K(II,3)
14894 IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14895 KFMOR = K(IDXMOR,2)
14896 ISMOR = K(IDXMOR,1)
14897 ELSE
14898 KFMOR = 91
14899 ISMOR = 1
14900 ENDIF
14901 IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14902 & (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14903 ID = K(IDXMOR,2)
14904
14905 MO = IHISMO(PYK(IDXMOR,15))
14906 PX = PYP(IDXMOR,1)
14907 PY = PYP(IDXMOR,2)
14908 PZ = PYP(IDXMOR,3)
14909 PE = PYP(IDXMOR,4)
14910
14911 CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14912 IFLG(IDXMOR) = 1
14913 MO = NHKK
14914 DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14915
14916 IF (PYK(JDAUG,7).EQ.1) THEN
14917 ID = PYK(JDAUG,8)
14918 PX = PYP(JDAUG,1)
14919 PY = PYP(JDAUG,2)
14920 PZ = PYP(JDAUG,3)
14921 PE = PYP(JDAUG,4)
14922
14923 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14924 IF (LEMCCK) THEN
14925
14926 PX = -PYP(JDAUG,1)
14927 PY = -PYP(JDAUG,2)
14928 PZ = -PYP(JDAUG,3)
14929 PE = -PYP(JDAUG,4)
14930
14931 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14932 ENDIF
14933 IFLG(JDAUG) = 1
14934 ENDIF
14935 15 CONTINUE
14936 ELSE
14937* there was no mother resonance
14938
14939 MO = IHISMO(PYK(II,15))
14940 ID = PYK(II,8)
14941 PX = PYP(II,1)
14942 PY = PYP(II,2)
14943 PZ = PYP(II,3)
14944 PE = PYP(II,4)
14945
14946 CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14947 IF (LEMCCK) THEN
14948
14949 PX = -PYP(II,1)
14950 PY = -PYP(II,2)
14951 PZ = -PYP(II,3)
14952 PE = -PYP(II,4)
14953
14954 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14955 ENDIF
14956 ENDIF
14957 ENDIF
14958 13 CONTINUE
14959 IF (LEMCCK) THEN
14960 CHKLEV = TINY1
14961 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14962C IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14963 ENDIF
14964
14965* global energy-momentum & flavor conservation check
14966**sr 16.5. this check is skipped in case of phojet-treatment
14967 IF (MCGENE.EQ.1)
14968 & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14969
14970* update statistics-counter for diffraction
14971c IF (IFLAGD.NE.0) THEN
14972c ICDIFF(1) = ICDIFF(1)+1
14973c IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14974c IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14975c IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14976c IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14977c ENDIF
14978
14979 ENDIF
14980
14981 RETURN
14982
14983 9999 CONTINUE
14984 IREJ = 1
14985 RETURN
14986 END
14987*
14988*===decay==============================================================*
14989*
14990CDECK ID>, DT_DECAYS
14991 SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14992
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************************************************************************
15004
15005 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15006 SAVE
15007
15008 PARAMETER ( LINP = 5 ,
15009 & LOUT = 6 ,
15010 & LDAT = 9 )
15011
15012 PARAMETER (TINY17=1.0D-17)
15013
15014* HADRIN: decay channel information
15015 PARAMETER (IDMAX9=602)
15016 CHARACTER*8 ZKNAME
15017 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15018* particle properties (BAMJET index convention)
15019 CHARACTER*8 ANAME
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
15026
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)
15030
15031* ISTAB = 1 strong and weak decays
15032* = 2 strong decays only
15033* = 3 strong decays, weak decays for charmed particles and tau
15034* leptons only
15035 DATA ISTAB /2/
15036
15037 IREJ = 0
15038 NSEC = 0
15039* put initial resonance to stack
15040 NSTK = 1
15041 IDXSTK(NSTK) = IDXIN
15042 DO 5 I=1,4
15043 PI(NSTK,I) = PIN(I)
15044 5 CONTINUE
15045
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)
15049
15050 100 CONTINUE
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
15069 ENDIF
15070
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)
15074 DO 1 I=1,3
15075 DCOS(I) = PI(NSTK,I)/PTOT
15076 1 CONTINUE
15077 GAM = PI(NSTK,4)/AAM(IDXI)
15078 BGAM = PTOT/AAM(IDXI)
15079
15080* get decay-channel
15081 KCHAN = K1(IDXI)-1
15082 2 CONTINUE
15083 KCHAN = KCHAN+1
15084 IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15085
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)
15091
15092* handle decay in rest system of decaying particle
15093 IF (IDX(3).EQ.0) THEN
15094* two-particle decay
15095 NDEC = 2
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)))
15099 ELSE
15100* three-particle decay
15101 NDEC = 3
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)))
15106 ENDIF
15107 NSTK = NSTK-1
15108
15109* transform decay products back
15110 DO 3 I=1,NDEC
15111 NSTK = NSTK+1
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)
15117 DO 4 J=1,3
15118 PI(NSTK,J) = DCOSF(J)*PFF(I)
15119 4 CONTINUE
15120 3 CONTINUE
15121 GOTO 100
15122
15123 10 CONTINUE
15124* stable particle, put to output-arrays
15125 NSEC = NSEC+1
15126 DO 6 I=1,4
15127 POUT(NSEC,I) = PI(NSTK,I)
15128 6 CONTINUE
15129 IDXOUT(NSEC) = IDXSTK(NSTK)
15130* store secondaries for energy-momentum conservation check
15131 IF (LEMCCK)
15132 &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15133 & -POUT(NSEC,4),2,IDUM,IDUM)
15134 NSTK = NSTK-1
15135 IF (NSTK.GT.0) GOTO 100
15136
15137* check energy-momentum conservation
15138 IF (LEMCCK) THEN
15139 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15140 IF (IREJ1.NE.0) GOTO 9999
15141 ENDIF
15142
15143 RETURN
15144
15145 9999 CONTINUE
15146 IREJ = 1
15147 RETURN
15148 END
15149*
15150*===decay1=============================================================*
15151*
15152CDECK ID>, DT_DECAY1
15153 SUBROUTINE DT_DECAY1
15154
15155************************************************************************
15156* Decay of resonances stored in DTEVT1. *
15157* This version dated 20.01.95 is written by S. Roesler *
15158************************************************************************
15159
15160 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15161 SAVE
15162
15163 PARAMETER ( LINP = 5 ,
15164 & LOUT = 6 ,
15165 & LDAT = 9 )
15166
15167* event history
15168
15169 PARAMETER (NMXHKK=200000)
15170
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),
15177 & IHIST(2,NMXHKK)
15178
15179 DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15180
15181 NEND = NHKK
15182C DO 1 I=NPOINT(5),NEND
15183 DO 1 I=NPOINT(4),NEND
15184 IF (ABS(ISTHKK(I)).EQ.1) THEN
15185 DO 2 K=1,4
15186 PIN(K) = PHKK(K,I)
15187 2 CONTINUE
15188 IDXIN = IDBAM(I)
15189 CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15190 IF (NSEC.GT.1) THEN
15191 DO 3 N=1,NSEC
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)
15195 3 CONTINUE
15196 ENDIF
15197 ENDIF
15198 1 CONTINUE
15199
15200 RETURN
15201 END
15202*
15203*===decpi0=============================================================*
15204*
15205CDECK ID>, DT_DECPI0
15206 SUBROUTINE DT_DECPI0
15207
15208************************************************************************
15209* Decay of pi0 handled with JETSET. *
15210* This version dated 18.02.96 is written by S. Roesler *
15211************************************************************************
15212
15213 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15214 SAVE
15215
15216 PARAMETER ( LINP = 5 ,
15217 & LOUT = 6 ,
15218 & LDAT = 9 )
15219
15220 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15221
15222* event history
15223
15224 PARAMETER (NMXHKK=200000)
15225
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),
15232 & IHIST(2,NMXHKK)
15233
15234 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15235
15236 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15237
15238 PARAMETER (MAXLND=4000)
15239 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15240
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
15245
15246 INTEGER PYCOMP,PYK
15247
15248 DIMENSION IHISMO(NMXHKK),P1(4)
15249
15250 TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15251
15252 CALL DT_INITJS(2)
15253* allow pi0 decay
15254
15255 KC = PYCOMP(111)
15256
15257 MDCY(KC,1) = 1
15258
15259 NN = 0
15260 INI = 0
15261 DO 1 I=1,NHKK
15262 IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15263 IF (INI.EQ.0) THEN
15264 INI = 1
15265 ELSE
15266 INI = 2
15267 ENDIF
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
15274 THETA = ZERO
15275 ELSEIF (COSTH.LT.-ONE) THEN
15276 THETA = TWOPI/2.0D0
15277 ELSE
15278 THETA = ACOS(COSTH)
15279 ENDIF
15280 PHI = ASIN(PHKK(2,I)/(PT +TINY10))
15281 IF (PHKK(1,I).LT.0.0D0)
15282
15283 & PHI = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15284
15285 ENER = PHKK(4,I)
15286 NN = NN+1
15287 KTEMP = MSTU(10)
15288 MSTU(10)= 1
15289 P(NN,5) = PHKK(5,I)
15290
15291 CALL PY1ENT(NN,111,ENER,THETA,PHI)
15292
15293 MSTU(10) = KTEMP
15294 IHISMO(NN)= I
15295 ENDIF
15296 1 CONTINUE
15297 IF (NN.GT.0) THEN
15298
15299 CALL PYEXEC
15300
15301 NLINES = PYK(0,1)
15302
15303 DO 2 II=1,NLINES
15304
15305 IF (PYK(II,7).EQ.1) THEN
15306
15307 DO 3 KK=1,4
15308
15309 P1(KK) = PYP(II,KK)
15310
15311 3 CONTINUE
15312
15313 ID = PYK(II,8)
15314 MO = IHISMO(PYK(II,15))
15315
15316 CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15317 IF (LEMCCK)
15318 & CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15319 & IDUM,IDUM)
15320*sr: flag with neg. sign (for HELIOS p/A-W jobs)
15321 ISTHKK(MO) = -2
15322 ENDIF
15323 2 CONTINUE
15324 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15325 ENDIF
15326 MDCY(KC,1) = 0
15327
15328 RETURN
15329 END
15330*
15331*===dtwopd=============================================================*
15332*
15333CDECK ID>, DT_DTWOPD
15334 SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15335 & COF2,SIF2,AM1,AM2)
15336
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************************************************************************
15345
15346 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15347 SAVE
15348
15349 PARAMETER ( LINP = 5 ,
15350 & LOUT = 6 ,
15351 & LDAT = 9 )
15352
15353 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15354
15355 IF (UMO.LT.(AM1+AM2)) THEN
15356 WRITE(LOUT,1000) UMO,AM1,AM2
15357 1000 FORMAT(1X,'DTWOPD: inconsistent kinematics - UMO,AM1,AM2 ',
15358 & 3E12.3)
15359 STOP
15360 ENDIF
15361
15362 ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15363 ECM2 = UMO-ECM1
15364 PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15365 PCM2 = PCM1
15366 CALL DT_DSFECF(SIF1,COF1)
15367 COD1 = TWO*DT_RNDM(PCM2)-ONE
15368 COD2 = -COD1
15369 COF2 = -COF1
15370 SIF2 = -SIF1
15371
15372 RETURN
15373 END
15374*
15375*===dthrep=============================================================*
15376*
15377CDECK 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)
15380
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) *
15387* *
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************************************************************************
15392
15393 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15394 SAVE
15395
15396 PARAMETER ( LINP = 5 ,
15397 & LOUT = 6 ,
15398 & LDAT = 9 )
15399
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 )
15407
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
15413
15414 DIMENSION F(5),XX(5)
15415 DATA EPS /AZRZRZ/
15416
15417 UMOO=UMO+UMO
15418C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15419C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15420C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15421 UUMO=UMO
15422 AAM1=AM1
15423 AAM2=AM2
15424 AAM3=AM3
15425 GU=(AM2+AM3)**2
15426 GO=(UMO-AM1)**2
15427* UFAK=1.0000000000001D0
15428* IF (GU.GT.GO) UFAK=0.9999999999999D0
15429 IF (GU.GT.GO) THEN
15430 UFAK=ONEMNS
15431 ELSE
15432 UFAK=ONEPLS
15433 END IF
15434 OFAK=2.D0-UFAK
15435 GU=GU*UFAK
15436 GO=GO*OFAK
15437 DS2=(GO-GU)/99.D0
15438 AM11=AM1*AM1
15439 AM22=AM2*AM2
15440 AM33=AM3*AM3
15441 UMO2=UMO*UMO
15442 RHO2=0.D0
15443 S22=GU
15444 DO 124 I=1,100
15445 S21=S22
15446 S22=GU+(I-1.D0)*DS2
15447 RHO1=RHO2
15448 RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15449 * (S22+EPS)
15450 IF(RHO2.LT.RHO1) GO TO 125
15451 124 CONTINUE
15452 125 S2SUP=(S22-S21)*.5D0+S21
15453 SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15454 * (S2SUP+EPS)
15455 SUPRHO=SUPRHO*1.05D0
15456 XO=S21-DS2
15457 IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15458 IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15459 XX(1)=XO
15460 XX(3)=S22
15461 X1=(XO+S22)*0.5D0
15462 XX(2)=X1
15463 F(3)=RHO2
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)
15466 DO 126 I=1,16
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)/
15470 * (X4+EPS)
15471 F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15472 * (X5+EPS)
15473 XX(4)=X4
15474 XX(5)=X5
15475 DO 128 II=1,5
15476 IA=II
15477 DO 128 III=IA,5
15478 IF (F (II).GE.F (III)) GO TO 128
15479 FH=F(II)
15480 F(II)=F(III)
15481 F(III)=FH
15482 FH=XX(II)
15483 XX(II)=XX(III)
15484 XX(III)=FH
15485128 CONTINUE
15486 SUPRHO=F(1)
15487 S2SUP=XX(1)
15488 DO 129 II=1,3
15489 IA=II
15490 DO 129 III=IA,3
15491 IF (XX(II).GE.XX(III)) GO TO 129
15492 FH=F(II)
15493 F(II)=F(III)
15494 F(III)=FH
15495 FH=XX(II)
15496 XX(II)=XX(III)
15497 XX(III)=FH
15498129 CONTINUE
15499126 CONTINUE
15500 AM23=(AM2+AM3)**2
15501 ITH=0
15502 REDU=2.D0
15503 1 CONTINUE
15504 ITH=ITH+1
15505 IF (ITH.GT.200) REDU=-9.D0
15506 IF (ITH.GT.200) GO TO 400
15507 C=DT_RNDM(REDU)
15508* S2=AM23+C*((UMO-AM1)**2-AM23)
15509 S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15510 Y=DT_RNDM(S2)
15511 Y=Y*SUPRHO
15512 RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15513 IF(Y.GT.RHO) GO TO 1
15514C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15515 S1=DT_RNDM(S2)
15516 S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15517 &RHO*.5D0
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)
15526C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15527C***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
15531 GO TO 300
15532 200 CONTINUE
15533 UW=DT_RNDM(S1)
15534 COSTH=(UW-0.5D+00)*2.D+00
15535 300 CONTINUE
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
15550C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15551C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15552C***THE DIRECTION OF PARTICLE 3
15553C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15554 CX11=-COSTH1
15555 CY11=SINTH1*CFE
15556 CZ11=SINTH1*SFE
15557 CX22=-COSTH2
15558 CY22=-SINTH2*CFE
15559 CZ22=-SINTH2*SFE
15560 CALL DT_DSFECF(SIF3,COF3)
15561 COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15562 SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15563 2 FORMAT(5F20.15)
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,
15567 &CX11,CZ11
15568 SID1=SQRT(CHLP)
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
15575 400 CONTINUE
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
15591 WRITE(LOUT,*)
15592 & ' *** Threpd: energy/momentum conservation failure! ***',
15593 & EOCHCK,PXCHCK,PYCHCK,PZCHCK
15594 WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15595 ENDIF
15596**
15597 END IF
15598 RETURN
15599 END
15600*
15601*===dbklas=============================================================*
15602*
15603CDECK ID>, DT_DBKLAS
15604 SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15605
15606 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15607 SAVE
15608
15609 PARAMETER ( LINP = 5 ,
15610 & LOUT = 6 ,
15611 & LDAT = 9 )
15612
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)
15616
15617 IF (I) 20,20,10
15618* baryons
15619 10 CONTINUE
15620 CALL DT_INDEXD(J,K,IND)
15621 I8 = IB08(I,IND)
15622 I10 = IB10(I,IND)
15623 IF (I8.LE.0) I8 = I10
15624 RETURN
15625* antibaryons
15626 20 CONTINUE
15627 II = IABS(I)
15628 JJ = IABS(J)
15629 KK = IABS(K)
15630 CALL DT_INDEXD(JJ,KK,IND)
15631 I8 = IA08(II,IND)
15632 I10 = IA10(II,IND)
15633 IF (I8.LE.0) I8 = I10
15634
15635 RETURN
15636 END
15637*
15638*===indexd=============================================================*
15639*
15640CDECK ID>, DT_INDEXD
15641 SUBROUTINE DT_INDEXD(KA,KB,IND)
15642
15643 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15644 SAVE
15645
15646 PARAMETER ( LINP = 5 ,
15647 & LOUT = 6 ,
15648 & LDAT = 9 )
15649
15650 KP = KA*KB
15651 KS = KA+KB
15652 IF (KP.EQ.1) IND=1
15653 IF (KP.EQ.2) IND=2
15654 IF (KP.EQ.3) IND=3
15655 IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15656 IF (KP.EQ.5) IND=5
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
15660 IF (KP.EQ.8) IND=9
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
15673
15674 RETURN
15675 END
15676*
15677*===dchant=============================================================*
15678*
15679CDECK ID>, DT_DCHANT
15680 SUBROUTINE DT_DCHANT
15681
15682 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15683 SAVE
15684
15685 PARAMETER ( LINP = 5 ,
15686 & LOUT = 6 ,
15687 & LDAT = 9 )
15688
15689 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15690
15691* HADRIN: decay channel information
15692 PARAMETER (IDMAX9=602)
15693 CHARACTER*8 ZKNAME
15694 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15695* particle properties (BAMJET index convention)
15696 CHARACTER*8 ANAME
15697 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15698 & IICH(210),IIBAR(210),K1(210),K2(210)
15699
15700 DIMENSION HWT(IDMAX9)
15701
15702* change of weights wt from absolut values into the sum of wt of a dec.
15703 DO 10 J=1,IDMAX9
15704 HWT(J) = ZERO
15705 10 CONTINUE
15706C DO 999 KKK=1,210
15707C WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15708C & ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15709C & K1(KKK),K2(KKK)
15710C 999 CONTINUE
15711C STOP
15712 DO 30 I=1,210
15713 IK1 = K1(I)
15714 IK2 = K2(I)
15715 HV = ZERO
15716 DO 20 J=IK1,IK2
15717 HV = HV+WT(J)
15718 HWT(J) = HV
15719**sr 13.1.95
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)
15722 20 CONTINUE
15723 30 CONTINUE
15724 DO 40 J=1,IDMAX9
15725 WT(J) = HWT(J)
15726 40 CONTINUE
15727
15728 RETURN
15729 END
15730*
15731*===ddatar=============================================================*
15732*
15733CDECK ID>, DT_DDATAR
15734 SUBROUTINE DT_DDATAR
15735
15736 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15737 SAVE
15738
15739 PARAMETER ( LINP = 5 ,
15740 & LOUT = 6 ,
15741 & LDAT = 9 )
15742
15743 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15744
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)
15748
15749 DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15750
15751 DATA IV/ 33, 34, 38,123, 0, 0, 32, 33, 39,124,
15752 & 0, 0, 36, 37, 96,127, 0, 0,126,125,
15753 & 128,129,14*0/
15754 DATA IP/ 23, 14, 16,116, 0, 0, 13, 23, 25,117,
15755 & 0, 0, 15, 24, 31,120, 0, 0,119,118,
15756 & 121,122,14*0/
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/
15789
15790 L=0
15791 DO 2 I=1,6
15792 DO 1 J=1,6
15793 L = L+1
15794 IMPS(I,J) = IP(L)
15795 IMVE(I,J) = IV(L)
15796 1 CONTINUE
15797 2 CONTINUE
15798 L=0
15799 DO 4 I=1,6
15800 DO 3 J=1,21
15801 L = L+1
15802 IB08(I,J) = IB(L)
15803 IB10(I,J) = IBB(L)
15804 IA08(I,J) = IA(L)
15805 IA10(I,J) = IAA(L)
15806 3 CONTINUE
15807 4 CONTINUE
15808C A1 = 0.88D0
15809C B1 = 3.0D0
15810C B2 = 3.0D0
15811C B3 = 8.0D0
15812C LT = 0
15813C LB = 0
15814C BET = 12.0D0
15815C AS = 0.25D0
15816C B8 = 0.33D0
15817C AME = 0.95D0
15818C DIQ = 0.375D0
15819C ISU = 4
15820
15821 RETURN
15822 END
15823*
15824*===initjs=============================================================*
15825*
15826CDECK ID>, DT_INITJS
15827 SUBROUTINE DT_INITJS(MODE)
15828
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************************************************************************
15836
15837 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15838 SAVE
15839
15840 PARAMETER ( LINP = 5 ,
15841 & LOUT = 6 ,
15842 & LDAT = 9 )
15843
15844 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15845
15846 LOGICAL LFIRST,LFIRDT,LFIRPH
15847
ba758f5a 15848 INCLUDE '(DIMPAR)'
15849 INCLUDE '(PART)'
d30b8254 15850
15851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15852
15853 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15854
15855 COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15856
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
15865
15866 INTEGER PYCOMP
15867
15868 DIMENSION IDXSTA(40)
15869 DATA IDXSTA
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/
15878
15879 DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15880
15881 IF (LFIRST) THEN
15882* save default settings
15883 PDEF1 = PARJ(1)
15884 PDEF2 = PARJ(2)
15885 PDEF3 = PARJ(3)
15886 PDEF5 = PARJ(5)
15887 PDEF6 = PARJ(6)
15888 PDEF7 = PARJ(7)
15889 PDEF18 = PARJ(18)
15890 PDEF19 = PARJ(19)
15891 PDEF21 = PARJ(21)
15892 PDEF42 = PARJ(42)
15893 MDEF12 = MSTJ(12)
15894* LUJETS / PYJETS array-dimensions
15895
15896 MSTU(4) = 4000
15897
15898* increase maximum number of JETSET-error prints
15899 MSTU(22) = 50000
15900* prevent particles decaying
15901 DO 1 I=1,35
15902 IF (I.LT.34) THEN
15903
15904 KC = PYCOMP(IDXSTA(I))
15905
15906 IF (I.EQ.2) THEN
15907* pi0 decay
15908C MDCY(KC,1) = 1
15909 MDCY(KC,1) = 0
15910**cr mode
15911C ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15912C & (I.EQ.8).OR.(I.EQ.10)) THEN
15913C ELSEIF (I.EQ.4) THEN
15914C MDCY(KC,1) = 1
15915**
15916 ELSE
15917 MDCY(KC,1) = 0
15918 ENDIF
15919 ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15920
15921 KC = PYCOMP(IDXSTA(I))
15922
15923 MDCY(KC,1) = 0
15924 ENDIF
15925 1 CONTINUE
15926*
15927
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
15931 DO 5 I=1,IDMAXP
15932 IF (KPTOIP(I).NE.0) THEN
15933 IDPDG = MPDGHA(I)
15934
15935 KC = PYCOMP(IDPDG)
15936
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)
15941 MDCY(KC,1) = 0
15942 ENDIF
15943 ENDIF
15944 5 CONTINUE
15945 DO 6 KC=1,500
15946 IDPDG = KCHG(KC,4)
15947 KP = MCIHAD(IDPDG)
15948 IF (KP.GT.0) THEN
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)
15955 MDCY(KC,1) = 1
15956 ENDIF
15957 ENDIF
15958 6 CONTINUE
15959 ENDIF
15960
15961*
15962* popcorn:
15963 IF (PDB.LE.ZERO) THEN
15964* no popcorn-mechanism
15965 MSTJ(12) = 1
15966 ELSE
15967 MSTJ(12) = 3
15968 PARJ(5) = PDB
15969 ENDIF
15970* set JETSET-parameter requested by input cards
15971 IF (NMSTU.GT.0) THEN
15972 DO 2 I=1,NMSTU
15973 MSTU(IMSTU(I)) = MSTUX(I)
15974 2 CONTINUE
15975 ENDIF
15976 IF (NMSTJ.GT.0) THEN
15977 DO 3 I=1,NMSTJ
15978 MSTJ(IMSTJ(I)) = MSTJX(I)
15979 3 CONTINUE
15980 ENDIF
15981 IF (NPARU.GT.0) THEN
15982 DO 4 I=1,NPARU
15983 PARU(IPARU(I)) = PARUX(I)
15984 4 CONTINUE
15985 ENDIF
15986 LFIRST = .FALSE.
15987 ENDIF
15988*
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)
16002*
16003* PHOJET settings
16004 IF (MODE.EQ.1) THEN
16005* JETSET default
16006C PARJ(1) = PDEF1
16007C PARJ(2) = PDEF2
16008C PARJ(3) = PDEF3
16009C PARJ(6) = PDEF6
16010C PARJ(7) = PDEF7
16011C PARJ(18) = PDEF18
16012C PARJ(21) = PDEF21
16013C PARJ(42) = PDEF42
16014**sr 18.11.98 parameter tuning
16015C PARJ(1) = 0.092D0
16016C PARJ(2) = 0.25D0
16017C PARJ(3) = 0.45D0
16018C PARJ(19) = 0.3D0
16019C PARJ(21) = 0.45D0
16020C PARJ(42) = 1.0D0
16021**sr 28.04.99 parameter tuning (May 99 minor modifications)
16022 PARJ(1) = 0.085D0
16023 PARJ(2) = 0.26D0
16024 PARJ(3) = 0.8D0
16025 PARJ(11) = 0.38D0
16026 PARJ(18) = 0.3D0
16027 PARJ(19) = 0.4D0
16028 PARJ(21) = 0.36D0
16029 PARJ(41) = 0.3D0
16030 PARJ(42) = 0.86D0
16031 IF (NPARJ.GT.0) THEN
16032 DO 10 I=1,NPARJ
16033 IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16034 10 CONTINUE
16035 ENDIF
16036 IF (LFIRPH) THEN
16037C *** Commented by Chiara
16038C WRITE(LOUT,'(1X,A)')
16039C & 'DT_INITJS: JETSET-parameter for PHOJET'
16040 CALL DT_JSPARA(0)
16041 LFIRPH = .FALSE.
16042 ENDIF
16043* DTUNUC settings
16044 ELSEIF (MODE.EQ.2) THEN
16045 IF (IFRAG(2).EQ.1) THEN
16046**sr parameters before 9.3.96
16047C PARJ(2) = 0.27D0
16048C PARJ(3) = 0.6D0
16049C PARJ(6) = 0.75D0
16050C PARJ(7) = 0.75D0
16051C PARJ(21) = 0.55D0
16052C PARJ(42) = 1.3D0
16053**sr 18.11.98 parameter tuning
16054C PARJ(1) = 0.05D0
16055C PARJ(2) = 0.27D0
16056C PARJ(3) = 0.4D0
16057C PARJ(19) = 0.2D0
16058C PARJ(21) = 0.45D0
16059C PARJ(42) = 1.0D0
16060**sr 28.04.99 parameter tuning
16061 PARJ(1) = 0.11D0
16062 PARJ(2) = 0.36D0
16063 PARJ(3) = 0.8D0
16064 PARJ(19) = 0.2D0
16065 PARJ(21) = 0.3D0
16066 PARJ(41) = 0.3D0
16067 PARJ(42) = 0.58D0
16068 IF (NPARJ.GT.0) THEN
16069 DO 20 I=1,NPARJ
16070 IF (IPARJ(I).LT.0) THEN
16071 IDX = ABS(IPARJ(I))
16072 PARJ(IDX) = PARJX(I)
16073 ENDIF
16074 20 CONTINUE
16075 ENDIF
16076 IF (LFIRDT) THEN
16077 WRITE(LOUT,'(1X,A)')
16078 & 'DT_INITJS: JETSET-parameter for DTUNUC'
16079 CALL DT_JSPARA(0)
16080 LFIRDT = .FALSE.
16081 ENDIF
16082 ELSEIF (IFRAG(2).EQ.2) THEN
16083 PARJ(1) = 0.11D0
16084 PARJ(2) = 0.27D0
16085 PARJ(3) = 0.3D0
16086 PARJ(6) = 0.35D0
16087 PARJ(7) = 0.45D0
16088 PARJ(18) = 0.66D0
16089C PARJ(21) = 0.55D0
16090C PARJ(42) = 1.0D0
16091 PARJ(21) = 0.60D0
16092 PARJ(42) = 1.3D0
16093 ELSE
16094 PARJ(1) = PDEF1
16095 PARJ(2) = PDEF2
16096 PARJ(3) = PDEF3
16097 PARJ(6) = PDEF6
16098 PARJ(7) = PDEF7
16099 PARJ(18) = PDEF18
16100 PARJ(21) = PDEF21
16101 PARJ(42) = PDEF42
16102 ENDIF
16103 ELSE
16104 PARJ(1) = PDEF1
16105 PARJ(2) = PDEF2
16106 PARJ(3) = PDEF3
16107 PARJ(5) = PDEF5
16108 PARJ(6) = PDEF6
16109 PARJ(7) = PDEF7
16110 PARJ(18) = PDEF18
16111 PARJ(19) = PDEF19
16112 PARJ(21) = PDEF21
16113 PARJ(42) = PDEF42
16114 MSTJ(12) = MDEF12
16115 ENDIF
16116
16117 RETURN
16118 END
16119*
16120*===jspara=============================================================*
16121*
16122CDECK ID>, DT_JSPARA
16123 SUBROUTINE DT_JSPARA(MODE)
16124
16125 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16126 SAVE
16127
16128 PARAMETER ( LINP = 5 ,
16129 & LOUT = 6 ,
16130 & LDAT = 9 )
16131
16132 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16133 & ONE=1.0D0,ZERO=0.0D0)
16134
16135 LOGICAL LFIRST
16136
16137 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16138
16139 DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16140
16141 DATA LFIRST /.TRUE./
16142
16143* save the default JETSET-parameter on the first call
16144 IF (LFIRST) THEN
16145 DO 1 I=1,200
16146 ISTU(I) = MSTU(I)
16147 QARU(I) = PARU(I)
16148 ISTJ(I) = MSTJ(I)
16149 QARJ(I) = PARJ(I)
16150 1 CONTINUE
16151 LFIRST = .FALSE.
16152 ENDIF
16153
16154C *** Commented by Chiara
16155C WRITE(LOUT,1000)
16156C 1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16157
16158* compare the default JETSET-parameter with the present values
16159 DO 2 I=1,200
16160C *** Commented by Chiara
16161C IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16162C WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16163CC ISTU(I) = MSTU(I)
16164C ENDIF
16165 DIFF = ABS(PARU(I)-QARU(I))
16166C *** Commented by Chiara
16167C IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16168C WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16169CC QARU(I) = PARU(I)
16170C ENDIF
16171C *** Commented by Chiara
16172C IF (MSTJ(I).NE.ISTJ(I)) THEN
16173C WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16174CC ISTJ(I) = MSTJ(I)
16175C ENDIF
16176 DIFF = ABS(PARJ(I)-QARJ(I))
16177C *** Commented by Chiara
16178C IF (DIFF.GE.1.0D-5) THEN
16179C WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16180CC QARJ(I) = PARJ(I)
16181C ENDIF
16182 2 CONTINUE
16183 1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16184 1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16185
16186 RETURN
16187 END
16188*
16189*===fozoca=============================================================*
16190*
16191CDECK ID>, DT_FOZOCA
16192 SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16193
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************************************************************************
16202
16203 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16204 SAVE
16205
16206 PARAMETER ( LINP = 5 ,
16207 & LOUT = 6 ,
16208 & LDAT = 9 )
16209
16210 PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16211 PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16212
16213 LOGICAL LSTART,LCAS,LFZC
16214
16215* event history
16216
16217 PARAMETER (NMXHKK=200000)
16218
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),
16225 & IHIST(2,NMXHKK)
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
16242 LOGICAL LPAULI
16243 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16244
16245 DIMENSION NCWOUN(2)
16246
16247 DATA LSTART /.TRUE./
16248
16249 LFZC = .TRUE.
16250 IREJ = 0
16251
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
16255 DO 1 I=1,8
16256 IF (.NOT.LHADRO(I)) GOTO 9999
16257 1 CONTINUE
16258
16259 IF (LSTART) THEN
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',/)
16268 LSTART = .FALSE.
16269 ENDIF
16270
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)
16274 NOINC = 0
16275 DO 9 I=1,NPOINT(1)-1
16276 NOINC = NOINC+1
16277 IDXINC(NOINC) = I
16278 9 CONTINUE
16279
16280* initialize Pauli-principle treatment (find wounded nucleons)
16281 NWOUND(1) = 0
16282 NWOUND(2) = 0
16283 NCWOUN(1) = 0
16284 NCWOUN(2) = 0
16285 DO 2 J=1,NPOINT(1)
16286 DO 3 I=1,2
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
16291 ENDIF
16292 3 CONTINUE
16293 2 CONTINUE
16294
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)
16301
16302 NSTART = NPOINT(4)
16303 NEND = NHKK
16304
16305 7 CONTINUE
16306 DO 8 I=NSTART,NEND
16307
16308 IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16309* select nucleus the cascade starts first (proj. - 1, target - -1)
16310 NCAS = 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
16316 IF (IP.GT.IT) THEN
16317 NCAS = -NCAS
16318 ELSEIF (IP.EQ.IT) THEN
16319 IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16320 ENDIF
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)))
16325 ENDIF
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
16329
16330* treat intranuclear cascade in the nucleus selected first
16331 LCAS = .FALSE.
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.
16335 NCAS = -NCAS
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
16340 ENDIF
16341
16342 ENDIF
16343
16344 8 CONTINUE
16345 NSTART = NEND+1
16346 NEND = NHKK
16347 IF (NSTART.LE.NEND) GOTO 7
16348
16349 RETURN
16350
16351 9998 CONTINUE
16352* reject this event
16353 IRINC = IRINC+1
16354 IREJ = 1
16355
16356 9999 CONTINUE
16357* intranucl. cascade not treated because of interaction properties or
16358* it is supressed by user or it was rejected or...
16359 LFZC = .FALSE.
16360* reset flag characterizing direction of motion in n-n-cms
16361**sr14-11-95
16362C DO 9990 I=NPOINT(5),NHKK
16363C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16364C9990 CONTINUE
16365
16366 RETURN
16367 END
16368*
16369*===inucas=============================================================*
16370*
16371CDECK ID>, DT_INUCAS
16372 SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16373
16374************************************************************************
16375* Formation zone supressed IntraNUclear CAScade for one final state *
16376* particle. *
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************************************************************************
16383
16384 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16385 SAVE
16386
16387 PARAMETER ( LINP = 5 ,
16388 & LOUT = 6 ,
16389 & LDAT = 9 )
16390
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)
16396
16397 LOGICAL LABSOR,LCAS
16398
16399* event history
16400
16401 PARAMETER (NMXHKK=200000)
16402
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),
16409 & IHIST(2,NMXHKK)
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)
16418 CHARACTER*8 ANAME
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
16425 LOGICAL LFERMI
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
16430 LOGICAL LPAULI
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
16435 CHARACTER*8 CMODEL
16436 LOGICAL LPHOIN
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),
16445 & NEVAFI(2,2)
16446
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)
16451
16452 DATA PDIF /0.545D0/
16453
16454 IREJ = 0
16455
16456* update counter
16457 IF (NINCEV(1).NE.NEVHKK) THEN
16458 NINCEV(1) = NEVHKK
16459 NINCEV(2) = NINCEV(2)+1
16460 ENDIF
16461
16462* "BAMJET-index" of this hadron
16463 IDCAS = IDBAM(IDXCAS)
16464 IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16465
16466* skip gammas, electrons, etc..
16467 IF (AAM(IDCAS).LT.TINY2) RETURN
16468
16469* Lorentz-trsf. into projectile rest system
16470 IF (IP.GT.1) THEN
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))
16478 ELSE
16479 PCAS(1,5) = AAM(IDCAS)
16480 ENDIF
16481 DO 20 K=1,3
16482 COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16483 20 CONTINUE
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)
16489 ELSE
16490 DO 21 K=1,5
16491 PCAS(1,K) = ZERO
16492 IF (K.LE.3) COSCAS(1,K) = ZERO
16493 21 CONTINUE
16494 PTOCAS(1) = ZERO
16495 BGCAS(1) = ZERO
16496 GACAS(1) = ZERO
16497 BECAS(1) = ZERO
16498 ENDIF
16499* Lorentz-trsf. into target rest system
16500 IF (IT.GT.1) THEN
16501* LEPTO: final state particles are already in target rest frame
16502C IF (MCGENE.EQ.3) THEN
16503C PCAS(2,1) = PHKK(1,IDXCAS)
16504C PCAS(2,2) = PHKK(2,IDXCAS)
16505C PCAS(2,3) = PHKK(3,IDXCAS)
16506C PCAS(2,4) = PHKK(4,IDXCAS)
16507C ELSE
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)
16511C ENDIF
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))
16516 ELSE
16517 PCAS(2,5) = AAM(IDCAS)
16518 ENDIF
16519 DO 22 K=1,3
16520 COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16521 22 CONTINUE
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)
16527 ELSE
16528 DO 23 K=1,5
16529 PCAS(2,K) = ZERO
16530 IF (K.LE.3) COSCAS(2,K) = ZERO
16531 23 CONTINUE
16532 PTOCAS(2) = ZERO
16533 BGCAS(2) = ZERO
16534 GACAS(2) = ZERO
16535 BECAS(2) = ZERO
16536 ENDIF
16537
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)
16543 BIMPC(1) = ZERO
16544 BIMPC(2) = BIMPAC*FM2MM
16545
16546* get position of initial hadron in projectile/target rest-syst.
16547 DO 3 K=1,4
16548 VTXCAS(1,K) = WHKK(K,IDXCAS)
16549 VTXCAS(2,K) = VHKK(K,IDXCAS)
16550 3 CONTINUE
16551
16552 ICAS = 1
16553 I2 = 2
16554 IF (NCAS.EQ.-1) THEN
16555 ICAS = 2
16556 I2 = 1
16557 ENDIF
16558
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)
16563 GOTO 9999
16564 ENDIF
16565
16566* reset spectator flags
16567 NSPE = 0
16568 IDXSPE(1) = 0
16569 IDXSPE(2) = 0
16570 IDSPE(1) = 0
16571 IDSPE(2) = 0
16572
16573* formation length (in fm)
16574C IF (LCAS) THEN
16575C DEL0 = ZERO
16576C ELSE
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
16581 ENDIF
16582C ENDIF
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)
16588
16589 DEL = DEL1
16590 TAUSAM = DEL/BGCAS(ICAS)
16591 REL = TAUSAM*BGCAS(I2)
16592
16593* special treatment for negative particles unable to escape
16594* nuclear potential (implemented for ap, pi-, K- only)
16595 LABSOR = .FALSE.
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
16601 DO 4 K=1,5
16602 PCAS1(K) = PCAS(ICAS,K)
16603 4 CONTINUE
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.
16608 ENDIF
16609 ENDIF
16610
16611* if the initial particle has not been absorbed proceed with
16612* "normal" cascade
16613 IF (.NOT.LABSOR) THEN
16614
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
16617* treated
16618 DSTEP = DEL*FM2MM
16619 DTIME = DSTEP/BECAS(ICAS)
16620 RSTEP = REL*FM2MM
16621 IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16622 RTIME = RSTEP/BECAS(I2)
16623 ELSE
16624 RTIME = ZERO
16625 ENDIF
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)
16632 ELSE
16633 RTIME1 = ZERO
16634 ENDIF
16635* transport to the end of the formation zone in this system
16636 DO 5 K=1,3
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)
16641 5 CONTINUE
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
16646
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
16653C RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16654C RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16655C RNCLPR = (RPROJ)*FM2MM
16656C 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
16661 ENDIF
16662 ENDIF
16663
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
16674 GOTO 9997
16675 ENDIF
16676 DIST = DLARGE
16677 DISTP = DLARGE
16678 DISTN = DLARGE
16679 IDXP = 0
16680 IDXN = 0
16681
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
16687C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16688C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
16689C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16690C & E12.4,', above or below HADRIN-thresholds',I6)
16691 NSPE = 0
16692 GOTO 9997
16693 ENDIF
16694
16695 DO 7 IDXHKK=1,NOINC
16696 I = IDXINC(IDXHKK)
16697* scan DTEVT1 for unwounded or excited nucleons
16698 IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16699 DO 8 K=1,3
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)
16704 ENDIF
16705 8 CONTINUE
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+
16713 & VTXDST(3)**2)
16714* impact parameter
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)
16720 GOTO 7
16721 ENDIF
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)
16727 DO 19 K=1,5
16728 PCAS1(K) = PCAS(ICAS,K)
16729 PNUC(K) = PHKK(K,I)
16730 19 CONTINUE
16731* Lorentz-parameter for trafo into rest-system of target
16732 DO 18 K=1,4
16733 BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16734 18 CONTINUE
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)
16739**
16740C CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16741C CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16742 DUMZER = ZERO
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
16748C SIGTOT = SIGIN+SIGEL+SIGAB
16749**
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
16756 DIST = DISTNU
16757 BINT = BIMNU
16758 IF (IDNUC.NE.IDSPE(1)) THEN
16759 IDSPE(2) = IDSPE(1)
16760 IDXSPE(2) = IDXSPE(1)
16761 IDSPE(1) = IDNUC
16762 ENDIF
16763 IDXSPE(1) = I
16764 NSPE = 1
16765**sr
16766 SELA = SIGEL
16767 SABS = SIGAB
16768 STOT = SIGTOT
16769C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16770C SELA = SIGEL
16771C STOT = SIGIN+SIGEL
16772C ELSE
16773C SELA = SIGEL+0.75D0*SIGIN
16774C STOT = 0.25D0*SIGIN+SELA
16775C ENDIF
16776**
16777 ENDIF
16778 ENDIf
16779 ENDIF
16780 DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16781 & VTXDST(3)**2)
16782 IDNUC = IDT_ICIHAD(IDHKK(I))
16783 IF (IDNUC.EQ.1) THEN
16784 IF (DISTNU.LT.DISTP) THEN
16785 DISTP = DISTNU
16786 IDXP = I
16787 POSP = POSNUC
16788 ENDIF
16789 ELSEIF (IDNUC.EQ.8) THEN
16790 IF (DISTNU.LT.DISTN) THEN
16791 DISTN = DISTNU
16792 IDXN = I
16793 POSN = POSNUC
16794 ENDIF
16795 ENDIF
16796 ENDIF
16797 7 CONTINUE
16798
16799* there is no nucleon for a secondary interaction
16800 IF (NSPE.EQ.0) GOTO 9997
16801
16802C IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16803C & WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16804 IF (IDXSPE(2).EQ.0) THEN
16805 IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16806C DO 80 K=1,3
16807C IF (ICAS.EQ.1) THEN
16808C VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16809C ELSEIF (ICAS.EQ.2) THEN
16810C VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16811C ENDIF
16812C 80 CONTINUE
16813C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16814C & VTXDST(3)**2)
16815C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16816 IDXSPE(2) = IDXN
16817 IDSPE(2) = 8
16818C ELSE
16819C STOT = STOT-SABS
16820C SABS = ZERO
16821C ENDIF
16822 ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16823C DO 81 K=1,3
16824C IF (ICAS.EQ.1) THEN
16825C VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16826C ELSEIF (ICAS.EQ.2) THEN
16827C VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16828C ENDIF
16829C 81 CONTINUE
16830C DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16831C & VTXDST(3)**2)
16832C IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16833 IDXSPE(2) = IDXP
16834 IDSPE(2) = 1
16835C ELSE
16836C STOT = STOT-SABS
16837C SABS = ZERO
16838C ENDIF
16839 ELSE
16840 STOT = STOT-SABS
16841 SABS = ZERO
16842 ENDIF
16843 ENDIF
16844 RR = DT_RNDM(DIST)
16845 IF (RR.LT.SELA/STOT) THEN
16846 IPROC = 2
16847 ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16848 IPROC = 3
16849 ELSE
16850 IPROC = 1
16851 ENDIF
16852
16853 DO 9 K=1,5
16854 PCAS1(K) = PCAS(ICAS,K)
16855 PNUC(K) = PHKK(K,IDXSPE(1))
16856 9 CONTINUE
16857 IF (IPROC.EQ.3) THEN
16858* 2-nucleon absorption of pion
16859 NSPE = 2
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.
16863 ELSE
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
16869 ENDIF
16870 ENDIF
16871
16872* update arrays to include Pauli-principle
16873 DO 10 I=1,NSPE
16874 IF (NWOUND(ICAS).LE.299) THEN
16875 NWOUND(ICAS) = NWOUND(ICAS)+1
16876 EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16877 ENDIF
16878 10 CONTINUE
16879
16880* dump initial hadron for energy-momentum conservation check
16881 IF (LEMCCK)
16882 & CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16883 & PCAS(ICAS,4),1,IDUM,IDUM)
16884
16885* dump final state particles into DTEVT1
16886
16887* check if Pauli-principle is fulfilled
16888 NPAULI = 0
16889 NWTMP(1) = NWOUND(1)
16890 NWTMP(2) = NWOUND(2)
16891 DO 111 I=1,NFSP
16892 NPAULI = 0
16893 J1 = 2
16894 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16895 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16896 DO 117 J=1,J1
16897 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16898 IF (J.EQ.1) THEN
16899 IDX = ICAS
16900 PE = PFSP(4,I)
16901 ELSE
16902 IDX = I2
16903 MODE = 1
16904 IF (IDX.EQ.1) MODE = -1
16905 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16906 ENDIF
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)
16915 ELSE
16916 POTLOW = POT-EBINDN(IDX)
16917 ENDIF
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
16923 NPAULI = NPAULI+1
16924 NWOUND(IDX) = NWOUND(IDX)-1
16925 ELSE
16926* interaction prohibited by Pauli-principle
16927 NWOUND(1) = NWTMP(1)
16928 NWOUND(2) = NWTMP(2)
16929 GOTO 9997
16930 ENDIF
16931 ENDIF
16932 ENDIF
16933 117 CONTINUE
16934 111 CONTINUE
16935
16936 NPAULI = 0
16937 NWOUND(1) = NWTMP(1)
16938 NWOUND(2) = NWTMP(2)
16939
16940 DO 11 I=1,NFSP
16941
16942 IST = ISTHKK(IDXCAS)
16943
16944 NPAULI = 0
16945 J1 = 2
16946 IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16947 & ((NCAS.EQ.-1).AND.(IP.LE.1))) J1 = 1
16948 DO 17 J=1,J1
16949 IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16950 IDX = ICAS
16951 PE = PFSP(4,I)
16952 IF (J.EQ.2) THEN
16953 IDX = I2
16954 CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16955 ENDIF
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)
16964 ELSE
16965 POTLOW = POT-EBINDN(IDX)
16966 ENDIF
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
16973 NPAULI = NPAULI+1
16974 IST = 14+IDX
16975 ELSE
16976* interaction prohibited by Pauli-principle
16977 NWOUND(1) = NWTMP(1)
16978 NWOUND(2) = NWTMP(2)
16979 GOTO 9997
16980 ENDIF
16981**sr
16982c ELSEIF (PE.LE.POT) THEN
16983cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16984cC NWOUND(IDX) = NWOUND(IDX)-1
16985c**
16986c NPAULI = NPAULI+1
16987c IST = 14+IDX
16988 ENDIF
16989 ENDIF
16990 17 CONTINUE
16991
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)
16995
16996 PX = PFSP(1,I)
16997 PY = PFSP(2,I)
16998 PZ = PFSP(3,I)
16999 PE = PFSP(4,I)
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
17003C IF (MCGENE.EQ.3) THEN
17004C PFSP(1,I) = PX
17005C PFSP(2,I) = PY
17006C PFSP(3,I) = PZ
17007C PFSP(4,I) = PE
17008C ELSE
17009 IMODE = ICAS+1
17010 CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17011 & PFSP(4,I),IDFSP(I),IMODE)
17012C ENDIF
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)
17023 ENDIF
17024
17025* dump final state particles into DTEVT1
17026 IGEN = IDCH(IDXCAS)+1
17027 ID = IDT_IPDGHA(IDFSP(I))
17028 IXR = 0
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)
17032
17033* update the counter for particles which got stuck inside the nucleus
17034 IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17035 NOINC = NOINC+1
17036 IDXINC(NOINC) = NHKK
17037 ENDIF
17038 IF (LABSOR) THEN
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
17043 DO 12 K=1,4
17044 WHKK(K,NHKK) = WHKK(K,IDXCAS)
17045 VHKK(K,NHKK) = VHKK(K,IDXCAS)
17046 12 CONTINUE
17047 ELSE
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)
17059 ELSE
17060 RTIME = ZERO
17061 ENDIF
17062* RDISTL, RTIME are this step and time in the rest system of the other
17063* nucleus
17064 DO 13 K=1,3
17065 VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17066 VTXCA1(I2,K) = VTXCAS(I2,K) +COSCAS(I2,K) *RDISTL
17067 13 CONTINUE
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
17072 DO 14 K=1,3
17073 WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17074 VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17075 14 CONTINUE
17076* time of production of secondary = time of interaction
17077 WHKK(4,NHKK) = VTXCA1(1,4)
17078 VHKK(4,NHKK) = VTXCA1(2,4)
17079 ENDIF
17080
17081 11 CONTINUE
17082
17083* modify status and position of cascade particle (the latter for
17084* statistics reasons only)
17085 ISTHKK(IDXCAS) = 2
17086 IF (LABSOR) ISTHKK(IDXCAS) = 19
17087 IF (.NOT.LABSOR) THEN
17088 DO 15 K=1,4
17089 WHKK(K,IDXCAS) = VTXCA1(1,K)
17090 VHKK(K,IDXCAS) = VTXCA1(2,K)
17091 15 CONTINUE
17092 ENDIF
17093
17094 DO 16 I=1,NSPE
17095 IS = IDXSPE(I)
17096* dump interacting nucleons for energy-momentum conservation check
17097 IF (LEMCCK)
17098 & CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17099 & 2,IDUM,IDUM)
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
17103 IF (I.GE.2) THEN
17104 JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17105 JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17106 ENDIF
17107 16 CONTINUE
17108
17109* check energy-momentum conservation
17110 IF (LEMCCK) THEN
17111 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17112 IF (IREJ1.NE.0) GOTO 9999
17113 ENDIF
17114
17115* update counter
17116 IF (LABSOR) THEN
17117 NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17118 ELSE
17119 IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17120 IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17121 ENDIF
17122
17123 RETURN
17124
17125 9997 CONTINUE
17126 9998 CONTINUE
17127* transport-step but no cascade step due to configuration (i.e. there
17128* is no nucleon for interaction etc.)
17129 IF (LCAS) THEN
17130 DO 100 K=1,4
17131C WHKK(K,IDXCAS) = VTXCAS(1,K)
17132C VHKK(K,IDXCAS) = VTXCAS(2,K)
17133 WHKK(K,IDXCAS) = VTXCA1(1,K)
17134 VHKK(K,IDXCAS) = VTXCA1(2,K)
17135 100 CONTINUE
17136 ENDIF
17137
17138C9998 CONTINUE
17139* no cascade-step because of configuration
17140* (i.e. hadron outside nucleus etc.)
17141 LCAS = .TRUE.
17142 RETURN
17143
17144 9999 CONTINUE
17145* rejection
17146 IREJ = 1
17147 RETURN
17148 END
17149*
17150*===absorp=============================================================*
17151*
17152CDECK ID>, DT_ABSORP
17153 SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17154
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************************************************************************
17172
17173 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17174 SAVE
17175
17176 PARAMETER ( LINP = 5 ,
17177 & LOUT = 6 ,
17178 & LDAT = 9 )
17179
17180 PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17181 & ONETHI=0.3333D0,TWOTHI=0.6666D0)
17182
17183* event history
17184
17185 PARAMETER (NMXHKK=200000)
17186
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),
17193 & IHIST(2,NMXHKK)
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)
17202 CHARACTER*8 ANAME
17203 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17204 & IICH(210),IIBAR(210),K1(210),K2(210)
17205
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)
17209
17210 IREJ = 0
17211 NFSP = 0
17212
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
17220
17221 NUCAS = NCAS
17222 IF (NUCAS.EQ.-1) NUCAS = 2
17223
17224 IF (MODE.EQ.0) THEN
17225* scan spectator nucleons for nucleons being able to "absorb"
17226 NSPE = 0
17227 IDXSPE(1) = 0
17228 IDXSPE(2) = 0
17229 DO 1 I=1,NHKK
17230 IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17231 NSPE = NSPE+1
17232 IDXSPE(NSPE) = I
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
17239 NSPE = 1
17240 GOTO 1
17241 ELSE
17242 GOTO 2
17243 ENDIF
17244 ENDIF
17245 ENDIF
17246 1 CONTINUE
17247
17248 2 CONTINUE
17249 ENDIF
17250* transform excited projectile nucleons (status=15) into proj. rest s.
17251 DO 3 I=1,NSPE
17252 DO 4 K=1,5
17253 PSPE(I,K) = PHKK(K,IDXSPE(I))
17254 4 CONTINUE
17255 3 CONTINUE
17256
17257* antiproton absorption
17258 IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17259 DO 5 K=1,5
17260 PSPE1(K) = PSPE(1,K)
17261 5 CONTINUE
17262 CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17263 IF (IREJ1.NE.0) GOTO 9999
17264
17265* meson absorption
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
17269* pi- absorption
17270 IDFSP(1) = 8
17271 IDFSP(2) = 8
17272 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17273 ELSEIF (IDCAS.EQ.13) THEN
17274* pi+ absorption
17275 IDFSP(1) = 1
17276 IDFSP(2) = 1
17277 IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17278 ELSEIF (IDCAS.EQ.23) THEN
17279* pi0 absorption
17280 IDFSP(1) = IDSPE(1)
17281 IDFSP(2) = IDSPE(2)
17282 ELSEIF (IDCAS.EQ.16) THEN
17283* K- absorption
17284 R = DT_RNDM(PCAS)
17285 IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17286 IF (R.LT.ONETHI) THEN
17287 IDFSP(1) = 21
17288 IDFSP(2) = 8
17289 ELSEIF (R.LT.TWOTHI) THEN
17290 IDFSP(1) = 17
17291 IDFSP(2) = 1
17292 ELSE
17293 IDFSP(1) = 22
17294 IDFSP(2) = 1
17295 ENDIF
17296 ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17297 IDFSP(1) = 20
17298 IDFSP(2) = 8
17299 ELSE
17300 IF (R.LT.ONETHI) THEN
17301 IDFSP(1) = 20
17302 IDFSP(2) = 1
17303 ELSEIF (R.LT.TWOTHI) THEN
17304 IDFSP(1) = 17
17305 IDFSP(2) = 8
17306 ELSE
17307 IDFSP(1) = 22
17308 IDFSP(2) = 8
17309 ENDIF
17310 ENDIF
17311 ENDIF
17312* dump initial particles for energy-momentum cons. check
17313 IF (LEMCCK) THEN
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,
17316 & IDUM,IDUM)
17317 CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17318 & IDUM,IDUM)
17319 ENDIF
17320* get Lorentz-parameter of 3 particle initial state
17321 DO 6 K=1,4
17322 PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17323 6 CONTINUE
17324 P3P = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17325 AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17326 DO 7 K=1,4
17327 BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17328 7 CONTINUE
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)))
17333 DO 8 I=1,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),
17340 & PFSP(4,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)
17348 ENDIF
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)
17352 8 CONTINUE
17353 NFSP = 2
17354 IF (LEMCCK) THEN
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)),
17358 & AM3P
17359 GOTO 9999
17360 ENDIF
17361 ENDIF
17362 ELSE
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,')')
17366 NSPE = 0
17367 ENDIF
17368
17369 RETURN
17370
17371 9999 CONTINUE
17372 IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17373 IREJ = 1
17374 RETURN
17375 END
17376*
17377*===hadrin=============================================================*
17378*
17379CDECK ID>, DT_HADRIN
17380 SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17381
17382************************************************************************
17383* Interface to the HADRIN-routines for inelastic and elastic *
17384* scattering. *
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************************************************************************
17392
17393 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17394 SAVE
17395
17396 PARAMETER ( LINP = 5 ,
17397 & LOUT = 6 ,
17398 & LDAT = 9 )
17399
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)
17402
17403 LOGICAL LCORR,LMSSG
17404
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)
17413 CHARACTER*8 ANAME
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
17421
17422 DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17423 & P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17424
17425 DATA LMSSG /.TRUE./
17426
17427 IREJ = 0
17428 NFSP = 0
17429 KCORR = 0
17430 IMCORR(1) = 0
17431 IMCORR(2) = 0
17432 LCORR = .FALSE.
17433
17434* dump initial particles for energy-momentum cons. check
17435 IF (LEMCCK) THEN
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)
17438 ENDIF
17439
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)
17450 LMSSG = .FALSE.
17451 LCORR = .TRUE.
17452 ENDIF
17453
17454* convert initial state particles into particles which can be
17455* handled by HADRIN
17456 IDHPR = IDPR
17457 IDHTA = IDTA
17458 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17459 IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17460 DO 1 K=1,4
17461 P1IN(K) = PPR(K)
17462 P2IN(K) = PTA(K)
17463 1 CONTINUE
17464 XM1 = AAM(IDHPR)
17465 XM2 = AAM(IDHTA)
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.'
17469 GOTO 9999
17470 ENDIF
17471 DO 2 K=1,4
17472 PPR(K) = P1OUT(K)
17473 PTA(K) = P2OUT(K)
17474 2 CONTINUE
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)
17477 ENDIF
17478
17479* Lorentz-parameter for trafo into rest-system of target
17480 DO 3 K=1,4
17481 BGTA(K) = PTA(K)/PTA(5)
17482 3 CONTINUE
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),
17486 & PPR1(4))
17487
17488* direction cosines of projectile in target rest system
17489 CX = PPR1(1)/PPRTO1
17490 CY = PPR1(2)/PPRTO1
17491 CZ = PPR1(3)/PPRTO1
17492
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'
17502 GOTO 9999
17503 ENDIF
17504 IF (IRH.EQ.1) GOTO 9998
17505 ELSE
17506 WRITE(LOUT,1001) MODE,INTHAD
17507 1001 FORMAT(1X,'HADRIN: warning! inconsistent interaction mode',
17508 & I4,' (INTHAD =',I4,')')
17509 GOTO 9999
17510 ENDIF
17511
17512* transform final state particles back into Lab.
17513 DO 4 I=1,IRH
17514 NFSP = NFSP+1
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-
17523 & PFSP(3,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)
17529 GOTO 9999
17530 ELSE
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)),
17534 & PFSP(5,NFSP)
17535 1003 FORMAT(1X,'HADRIN: warning! final state particle',
17536 & ' (id = ',I2,') with inconsistent mass',/,1X,
17537 & 2E12.4)
17538 KCORR = KCORR+1
17539 IF (KCORR.GT.2) GOTO 9999
17540 IMCORR(KCORR) = NFSP
17541 ENDIF
17542 ENDIF
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)
17546 4 CONTINUE
17547
17548* transform momenta on mass shell in case of inconsistencies in
17549* HADRIN
17550 IF (KCORR.GT.0) THEN
17551 IF (KCORR.EQ.2) THEN
17552 I1 = IMCORR(1)
17553 I2 = IMCORR(2)
17554 ELSE
17555 IF (IMCORR(1).EQ.1) THEN
17556 I1 = 1
17557 I2 = 2
17558 ELSE
17559 I1 = 1
17560 I2 = IMCORR(1)
17561 ENDIF
17562 ENDIF
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)
17567 DO 5 K=1,4
17568 P1IN(K) = PFSP(K,I1)
17569 P2IN(K) = PFSP(K,I2)
17570 5 CONTINUE
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.'
17576C GOTO 9999
17577 ENDIF
17578 DO 6 K=1,4
17579 PFSP(K,I1) = P1OUT(K)
17580 PFSP(K,I2) = P2OUT(K)
17581 6 CONTINUE
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)
17591 ENDIF
17592
17593* check energy-momentum conservation
17594 IF (LEMCCK) THEN
17595 CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17596 IF (IREJ1.NE.0) GOTO 9999
17597 ENDIF
17598
17599 RETURN
17600
17601 9998 CONTINUE
17602 IREJ = 2
17603 RETURN
17604
17605 9999 CONTINUE
17606 IREJ = 1
17607 RETURN
17608 END
17609*
17610*===hadcol=============================================================*
17611*
17612CDECK ID>, DT_HADCOL
17613 SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17614
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************************************************************************
17626
17627 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17628 SAVE
17629
17630 PARAMETER ( LINP = 5 ,
17631 & LOUT = 6 ,
17632 & LDAT = 9 )
17633
17634 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17635
17636 LOGICAL LSTART
17637
17638* event history
17639
17640 PARAMETER (NMXHKK=200000)
17641
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),
17648 & IHIST(2,NMXHKK)
17649* nuclear potential
17650 LOGICAL LFERMI
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
17657 LOGICAL LPAULI
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)
17663 CHARACTER*8 ANAME
17664 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17665 & IICH(210),IIBAR(210),K1(210),K2(210)
17666
17667 DIMENSION PPROJ(5),PNUC(5)
17668
17669 DATA LSTART /.TRUE./
17670
17671 IREJ = 0
17672
17673 NPOINT(1) = NHKK+1
17674
17675 TAUSAV = TAUFOR
17676**sr 6/9/01 commented
17677C TAUFOR = TAUFOR/2.0D0
17678**
17679 IF (LSTART) THEN
17680 WRITE(LOUT,1000)
17681 1000 FORMAT(/,1X,'HADCOL: Scattering handled by HADRIN')
17682 WRITE(LOUT,1001) TAUFOR
17683 1001 FORMAT(/,1X,'HADCOL: Formation zone parameter set to ',
17684 & F5.1,' fm/c')
17685 LSTART = .FALSE.
17686 ENDIF
17687
17688 IDNUC = IDBAM(IDXTAR)
17689 IDNUC1 = IDT_MCHAD(IDNUC)
17690 IDPRO1 = IDT_MCHAD(IDPROJ)
17691
17692 IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17693 IPROC = INTHAD
17694 ELSE
17695**
17696C CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17697C CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17698 DUMZER = ZERO
17699 CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17700 SIGIN = SIGTOT-SIGEL
17701C SIGTOT = SIGIN+SIGEL
17702**
17703 IPROC = 1
17704 IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17705 ENDIF
17706
17707 PPROJ(1) = ZERO
17708 PPROJ(2) = ZERO
17709 PPROJ(3) = PPN
17710 PPROJ(5) = AAM(IDPROJ)
17711 PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17712 DO 1 K=1,5
17713 PNUC(K) = PHKK(K,IDXTAR)
17714 1 CONTINUE
17715
17716 ILOOP = 0
17717 2 CONTINUE
17718 ILOOP = ILOOP+1
17719 IF (ILOOP.GT.100) GOTO 9999
17720
17721 CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17722 IF (IREJ1.EQ.1) GOTO 9999
17723
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)
17734 NPOINT(4) = NHKK
17735 ELSE
17736* require Pauli blocking for final state nucleons
17737 DO 4 I=1,NFSP
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
17744 4 CONTINUE
17745* store final state particles
17746 DO 5 I=1,NFSP
17747 IST = 1
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),
17753 & PCMS,ECMS,0,0,0)
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)
17763 5 CONTINUE
17764 ENDIF
17765 TAUFOR = TAUSAV
17766 RETURN
17767
17768 9999 CONTINUE
17769 IREJ = 1
17770 TAUFOR = TAUSAV
17771 RETURN
17772 END
17773*
17774*===getemu=============================================================*
17775*
17776CDECK ID>, DT_GETEMU
17777 SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17778
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************************************************************************
17783
17784 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17785 SAVE
17786
17787 PARAMETER ( LINP = 5 ,
17788 & LOUT = 6 ,
17789 & LDAT = 9 )
17790
17791 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17792
17793 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17794
17795* emulsion treatment
17796 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17797 & NCOMPO,IEMUL
17798* Glauber formalism: flags and parameters for statistics
17799 LOGICAL LPROD
17800 CHARACTER*8 CGLB
17801 COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17802
17803 IF (MODE.EQ.0) THEN
17804 SUMFRA = ZERO
17805 RR = DT_RNDM(SUMFRA)
17806 IT = 0
17807 ITZ = 0
17808 DO 1 ICOMP=1,NCOMPO
17809 SUMFRA = SUMFRA+EMUFRA(ICOMP)
17810 IF (SUMFRA.GT.RR) THEN
17811 IT = IEMUMA(ICOMP)
17812 ITZ = IEMUCH(ICOMP)
17813 KKMAT = ICOMP
17814 GOTO 2
17815 ENDIF
17816 1 CONTINUE
17817 2 CONTINUE
17818 IF (IT.LE.0) THEN
17819 WRITE(LOUT,'(1X,A,E12.3)')
17820 & 'Warning! norm. failure within emulsion fractions',
17821 & SUMFRA
17822 STOP
17823 ENDIF
17824 ELSEIF (MODE.EQ.1) THEN
17825 NDIFF = 10000
17826 DO 3 I=1,NCOMPO
17827 IDIFF = ABS(IT-IEMUMA(I))
17828 IF (IDIFF.LT.NDIFF) THEN
17829 KKMAT = I
17830 NDIFF = IDIFF
17831 ENDIF
17832 3 CONTINUE
17833 ELSE
17834 STOP 'DT_GETEMU'
17835 ENDIF
17836
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
17840 KKMAT = 1
17841 ENDIF
17842
17843 RETURN
17844 END
17845*
17846*===nclpot=============================================================*
17847*
17848CDECK ID>, DT_NCLPOT
17849 SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17850
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************************************************************************
17861
17862 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17863 SAVE
17864
17865 PARAMETER ( LINP = 5 ,
17866 & LOUT = 6 ,
17867 & LDAT = 9 )
17868
17869 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17870 & TINY10=1.0D-10)
17871
17872 LOGICAL LSTART
17873
17874* particle properties (BAMJET index convention)
17875 CHARACTER*8 ANAME
17876 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17877 & IICH(210),IIBAR(210),K1(210),K2(210)
17878* nuclear potential
17879 LOGICAL LFERMI
17880 COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17881 & EBINDP(2),EBINDN(2),EPOT(2,210),
17882 & ETACOU(2),ICOUL,LFERMI
17883
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/
17889
17890 DATA AN /0.4D0/
17891 DATA LSTART /.TRUE./
17892
17893 IF (MODE.EQ.0) THEN
17894 EBINDP(1) = ZERO
17895 EBINDN(1) = ZERO
17896 EBINDP(2) = ZERO
17897 EBINDN(2) = ZERO
17898 ENDIF
17899 AIP = DBLE(IP)
17900 AIPZ = DBLE(IPZ)
17901 AIT = DBLE(IT)
17902 AITZ = DBLE(ITZ)
17903
17904 FERMIP = AFERP
17905 IF (AFERP.LE.ZERO) FERMIP = FERMOD
17906 FERMIT = AFERT
17907 IF (AFERT.LE.ZERO) FERMIT = FERMOD
17908
17909* Fermi momenta and binding energy for projectile
17910 IF ((IP.GT.1).AND.LFERMI) THEN
17911 IF (MODE.EQ.0) THEN
17912C EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17913C EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17914 BIP = AIP -ONE
17915 BIPZ = AIPZ-ONE
17916
17917 EBINDP(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17918 & -ENERGY(BIP,BIPZ))
17919
17920 IF (AIP.LE.AIPZ) THEN
17921 EBINDN(1) = EBINDP(1)
17922 WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17923 ELSE
17924
17925 EBINDN(1) = 1.0D-3*ABS(ENERGY(AIP,AIPZ)
17926 & -ENERGY(BIP,AIPZ))
17927
17928 ENDIF
17929 ENDIF
17930 PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17931 PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17932 ELSE
17933 PFERMP(1) = ZERO
17934 PFERMN(1) = ZERO
17935 ENDIF
17936* effective nuclear potential for projectile
17937C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17938C 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)
17941
17942* Fermi momenta and binding energy for target
17943 IF ((IT.GT.1).AND.LFERMI) THEN
17944 IF (MODE.EQ.0) THEN
17945C EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17946C EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17947 BIT = AIT -ONE
17948 BITZ = AITZ-ONE
17949
17950 EBINDP(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17951 & -ENERGY(BIT,BITZ))
17952
17953 IF (AIT.LE.AITZ) THEN
17954 EBINDN(2) = EBINDP(2)
17955 WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17956 ELSE
17957
17958 EBINDN(2) = 1.0D-3*ABS(ENERGY(AIT,AITZ)
17959 & -ENERGY(BIT,AITZ))
17960
17961 ENDIF
17962 ENDIF
17963 PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17964 PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17965 ELSE
17966 PFERMP(2) = ZERO
17967 PFERMN(2) = ZERO
17968 ENDIF
17969* effective nuclear potential for target
17970C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17971C 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)
17974
17975 DO 2 I=1,14
17976 EPOT(1,IDXPOT(I)) = EPOT(1,8)
17977 EPOT(2,IDXPOT(I)) = EPOT(2,8)
17978 2 CONTINUE
17979
17980* Coulomb energy
17981 ETACOU(1) = ZERO
17982 ETACOU(2) = ZERO
17983 IF (ICOUL.EQ.1) THEN
17984 IF (IP.GT.1)
17985 & ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17986 IF (IT.GT.1)
17987 & ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17988 ENDIF
17989
17990 IF (LSTART) THEN
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),
17994 & FERMOD,ETACOU
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 '),/,/)
18005 LSTART = .FALSE.
18006 ENDIF
18007
18008 RETURN
18009 END
18010*
18011*===resncl=============================================================*
18012*
18013CDECK ID>, DT_RESNCL
18014 SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18015
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************************************************************************
18022
18023 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18024 SAVE
18025
18026 PARAMETER ( LINP = 5 ,
18027 & LOUT = 6 ,
18028 & LDAT = 9 )
18029
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,
18034 & FM2MM = 1.0D-12,
18035 & RNUCLE = 1.12D0)
18036
18037* event history
18038
18039 PARAMETER (NMXHKK=200000)
18040
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),
18047 & IHIST(2,NMXHKK)
18048* particle properties (BAMJET index convention)
18049 CHARACTER*8 ANAME
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
18057 LOGICAL LFERMI
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
18074
18075 DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18076 DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18077 & IDXCOR(15000),IDXOTH(NMXHKK)
18078
18079 GOTO (1,2) MODE
18080
18081*------- initializations
18082 1 CONTINUE
18083
18084* initialize arrays for residual nuclei
18085 DO 10 K=1,5
18086 IF (K.LE.4) THEN
18087 PFSP(K) = ZERO
18088 ENDIF
18089 PINIPR(K) = ZERO
18090 PINITA(K) = ZERO
18091 PRCLPR(K) = ZERO
18092 PRCLTA(K) = ZERO
18093 TRCLPR(K) = ZERO
18094 TRCLTA(K) = ZERO
18095 10 CONTINUE
18096 SCPOT = ONE
18097 NLOOP = 0
18098
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
18102 EPNI = EPN
18103* Coulomb-energy:
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
18108 WRITE(LOUT,1000)
18109 1000 FORMAT(/,1X,'KKINC: WARNING! projectile energy',
18110 & ' below Coulomb threshold - event rejected',/)
18111 ISTHKK(1) = 1
18112 RETURN
18113 ENDIF
18114* negatively charged hadron - increase energy by Coulomb energy
18115 ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18116 EPNI = EPNI+ETACOU(2)
18117 ENDIF
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)
18121C EPNI = EPNI+EPOT(2,IJPROJ)
18122 EBIPOT = EBINDP(2)
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
18127 DUM1 = ZERO
18128 DUM2 = ZERO
18129 CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18130 ENDIF
18131 ENDIF
18132
18133* projectile in n-n cms
18134 IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18135 PMASS1 = AAM(IJPROJ)
18136C* VDM assumption
18137C IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18138 IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18139 PMASS2 = AAM(1)
18140 PM1 = SIGN(PMASS1**2,PMASS1)
18141 PM2 = SIGN(PMASS2**2,PMASS2)
18142 PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18143 PINIPR(5) = PMASS1
18144 IF (PMASS1.GT.ZERO) THEN
18145 PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18146 & *(PINIPR(4)+PINIPR(5)))
18147 ELSE
18148 PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18149 ENDIF
18150 AIT = DBLE(IT)
18151 AITZ = DBLE(ITZ)
18152
18153 PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18154
18155 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18156 ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18157 PMASS1 = AAM(1)
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)
18162 PINITA(5) = PMASS2
18163 PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18164 & *(PINITA(4)+PINITA(5)))
18165 AIP = DBLE(IP)
18166 AIPZ = DBLE(IPZ)
18167
18168 PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18169
18170 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18171 ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18172 AIP = DBLE(IP)
18173 AIPZ = DBLE(IPZ)
18174
18175 PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18176
18177 CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18178 AIT = DBLE(IT)
18179 AITZ = DBLE(ITZ)
18180
18181 PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18182
18183 CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18184 ENDIF
18185
18186 RETURN
18187
18188*------- treatment of final state
18189 2 CONTINUE
18190
18191 NLOOP = NLOOP+1
18192 IF (NLOOP.GT.1) SCPOT = 0.10D0
18193C WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18194
18195 JPW = NPW
18196 JPCW = NPCW
18197 JTW = NTW
18198 JTCW = NTCW
18199 DO 40 K=1,4
18200 PFSP(K) = ZERO
18201 40 CONTINUE
18202
18203 NOB = 0
18204 NOM = 0
18205 DO 900 I=NPOINT(4),NHKK
18206 IDXOTH(I) = -1
18207 IF (ISTHKK(I).EQ.1) THEN
18208 IF (IDBAM(I).EQ.7) GOTO 900
18209 IPOT = 0
18210 IOTHER = 0
18211* particle moving into forward direction
18212 IF (PHKK(3,I).GE.ZERO) THEN
18213* most likely to be effected by projectile potential
18214 IPOT = 1
18215* there is no projectile nucleus, try target
18216 IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18217 IPOT = 2
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
18221 ENDIF
18222* particle moving into backward direction
18223 ELSE
18224* most likely to be effected by target potential
18225 IPOT = 2
18226* there is no target nucleus, try projectile
18227 IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18228 IPOT = 1
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
18232 ENDIF
18233 ENDIF
18234 IFLG = -IPOT
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
18239* overlap region
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))
18244 & THEN
18245 NOB = NOB+1
18246 PMOMB(NOB) = PHKK(3,I)
18247 IDXB(NOB) = SIGN(1000000*IABS(IFLG)
18248 & +100000*IOTHER+I,IFLG)
18249 ENDIF
18250* mesons: keep only those mesons where flag is set
18251 ELSE
18252 IF (IFLG.GT.0) THEN
18253 NOM = NOM+1
18254 PMOMM(NOM) = PHKK(3,I)
18255 IDXM(NOM) = 1000000*IFLG+100000*IOTHER+I
18256 ENDIF
18257 ENDIF
18258 ENDIF
18259 900 CONTINUE
18260*
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)
18264*
18265* shuffle indices into one and the same array according to the later
18266* sequence of correction
18267 NCOR = 0
18268 IF (IT.GT.1) THEN
18269 DO 910 I=1,NOB
18270 IF (PMOMB(I).GT.ZERO) GOTO 911
18271 NCOR = NCOR+1
18272 IDXCOR(NCOR) = IDXB(I)
18273 910 CONTINUE
18274 911 CONTINUE
18275 IF (IP.GT.1) THEN
18276 DO 912 J=1,NOB
18277 I = NOB+1-J
18278 IF (PMOMB(I).LT.ZERO) GOTO 913
18279 NCOR = NCOR+1
18280 IDXCOR(NCOR) = IDXB(I)
18281 912 CONTINUE
18282 913 CONTINUE
18283 ELSE
18284 DO 914 I=1,NOB
18285 IF (PMOMB(I).GT.ZERO) THEN
18286 NCOR = NCOR+1
18287 IDXCOR(NCOR) = IDXB(I)
18288 ENDIF
18289 914 CONTINUE
18290 ENDIF
18291 ELSE
18292 DO 915 J=1,NOB
18293 I = NOB+1-J
18294 NCOR = NCOR+1
18295 IDXCOR(NCOR) = IDXB(I)
18296 915 CONTINUE
18297 ENDIF
18298 DO 925 I=1,NOM
18299 IF (PMOMM(I).GT.ZERO) GOTO 926
18300 NCOR = NCOR+1
18301 IDXCOR(NCOR) = IDXM(I)
18302 925 CONTINUE
18303 926 CONTINUE
18304 DO 927 J=1,NOM
18305 I = NOM+1-J
18306 IF (PMOMM(I).LT.ZERO) GOTO 928
18307 NCOR = NCOR+1
18308 IDXCOR(NCOR) = IDXM(I)
18309 927 CONTINUE
18310 928 CONTINUE
18311*
18312C IF (NEVHKK.EQ.484) THEN
18313C WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18314C 9000 FORMAT(1X,'wounded nucleons (proj.-p,n targ.-p,n)',/,4I10)
18315C WRITE(LOUT,9001) NOB,NOM,NCOR
18316C 9001 FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18317C WRITE(LOUT,'(/,A)') ' baryons '
18318C DO 950 I=1,NOB
18319CC J = IABS(IDXB(I))
18320CC INDEX = J-IABS(J/1000000)*1000000
18321C IPOT = IABS(IDXB(I))/1000000
18322C IOTHER = IABS(IDXB(I))/100000-IPOT*10
18323C INDEX = IABS(IDXB(I))-IPOT*1000000-IOTHER*100000
18324C WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18325C 950 CONTINUE
18326C WRITE(LOUT,'(/,A)') ' mesons '
18327C DO 951 I=1,NOM
18328CC INDEX = IDXM(I)-IABS(IDXM(I)/1000000)*1000000
18329C IPOT = IABS(IDXM(I))/1000000
18330C IOTHER = IABS(IDXM(I))/100000-IPOT*10
18331C INDEX = IABS(IDXM(I))-IPOT*1000000-IOTHER*100000
18332C WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18333C 951 CONTINUE
18334C 9002 FORMAT(1X,4I14,E14.5)
18335C WRITE(LOUT,'(/,A)') ' all '
18336C DO 952 I=1,NCOR
18337CC J = IABS(IDXCOR(I))
18338CC INDEX = J-IABS(J/1000000)*1000000
18339CC IPOT = IABS(IDXCOR(I))/1000000
18340C IOTHER = IABS(IDXCOR(I))/100000-IPOT*10
18341C INDEX = IABS(IDXCOR(I))-IPOT*1000000-IOTHER*100000
18342C WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18343C 952 CONTINUE
18344C 9003 FORMAT(1X,4I14)
18345C ENDIF
18346*
18347 DO 20 ICOR=1,NCOR
18348 IPOT = IABS(IDXCOR(ICOR))/1000000
18349 IOTHER = IABS(IDXCOR(ICOR))/100000-IPOT*10
18350 I = IABS(IDXCOR(ICOR))-IPOT*1000000-IOTHER*100000
18351 IDXOTH(I) = 1
18352
18353 IDSEC = IDBAM(I)
18354
18355* reduction of particle momentum by corresponding nuclear potential
18356* (this applies only if Fermi-momenta are requested)
18357
18358 IF (LFERMI) THEN
18359
18360* Lorentz-transformation into the rest system of the selected nucleus
18361 IMODE = -IPOT-1
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)))
18366 JPMOD = 0
18367
18368 CHKLEV = TINY3
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,/)
18377 GOTO 23
18378 ENDIF
18379
18380 DO 21 K=1,4
18381 PSEC0(K) = PSEC(K)
18382 21 CONTINUE
18383
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
18393**test
18394C RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18395C & +(VHKK(2,IPW(JPW))/FM2MM)**2
18396C & +(VHKK(3,IPW(JPW))/FM2MM)**2)
18397C RAD = RNUCLE*DBLE(IP)**ONETHI
18398C FDEN = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18399C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18400**
18401 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18402 JPW = JPW-1
18403 JPMOD = 1
18404 ELSE
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)
18409 JPMOD = 1
18410 ENDIF
18411 ENDIF
18412 ELSEIF (IPOT.EQ.2) THEN
18413 IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18414* this is most likely a wounded nucleon
18415**test
18416C RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18417C & +(VHKK(2,ITW(JTW))/FM2MM)**2
18418C & +(VHKK(3,ITW(JTW))/FM2MM)**2)
18419C RAD = RNUCLE*DBLE(IT)**ONETHI
18420C FDEN = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18421C PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18422**
18423 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18424 JTW = JTW-1
18425 JPMOD = 1
18426 ELSE
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)
18430 JPMOD = 1
18431 ENDIF
18432 ENDIF
18433 ENDIF
18434 ELSE
18435 IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18436 PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18437 JPMOD = 1
18438 ENDIF
18439 ENDIF
18440
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
18447 JPCW = JPCW-1
18448 ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18449 JTCW = JTCW-1
18450 ELSE
18451 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18452 ENDIF
18453 ELSE
18454 IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18455 ENDIF
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
18461 DO 26 K=1,4
18462 PHKK(K,I) = PSEC0(K)
18463 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18464 26 CONTINUE
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
18468 DO 27 K=1,4
18469 PHKK(K,I) = PSEC0(K)
18470 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18471 27 CONTINUE
18472 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18473 IF (IDSEC.EQ.1) NTCW = NTCW-1
18474 ENDIF
18475 GOTO 20
18476 ENDIF
18477 ELSEIF (IICH(IDSEC).EQ.-1) THEN
18478* neg. particles: decrease energy by Coulomb-potential
18479 PSEC(4) = PSEC(4)-ETACOU(IPOT)
18480 JPMOD = 1
18481 ENDIF
18482 ENDIF
18483
18484 25 CONTINUE
18485
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,
18492 & ' mass: ',E12.3)
18493 ISTHKK(I) = 14+IPOT
18494 IF (ISTHKK(I).EQ.15) THEN
18495 DO 28 K=1,4
18496 PHKK(K,I) = PSEC0(K)
18497 TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18498 28 CONTINUE
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
18502 DO 29 K=1,4
18503 PHKK(K,I) = PSEC0(K)
18504 TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18505 29 CONTINUE
18506 IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18507 IF (IDSEC.EQ.1) NTCW = NTCW-1
18508 ENDIF
18509 GOTO 20
18510 ENDIF
18511
18512 IF (JPMOD.EQ.1) THEN
18513 PSECN = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18514* 4-momentum after correction for nuclear potential
18515 DO 22 K=1,3
18516 PSEC(K) = PSEC(K)*PSECN/PSECO
18517 22 CONTINUE
18518
18519* store recoil momentum from particles escaping the nuclear potentials
18520 DO 30 K=1,4
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)
18525 ENDIF
18526 30 CONTINUE
18527
18528* transform momentum back into n-n cms
18529 IMODE = IPOT+1
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),
18532 & IDSEC,IMODE)
18533 ENDIF
18534
18535 ENDIF
18536
18537 23 CONTINUE
18538 DO 31 K=1,4
18539 PFSP(K) = PFSP(K)+PHKK(K,I)
18540 31 CONTINUE
18541
18542 20 CONTINUE
18543
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)
18550 ENDIF
18551 33 CONTINUE
18552
18553 DO 34 K=1,5
18554 PRCLPR(K) = TRCLPR(K)
18555 PRCLTA(K) = TRCLTA(K)
18556 34 CONTINUE
18557
18558 IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18559* hadron-nucleus interactions: get residual momentum from energy-
18560* momentum conservation
18561 DO 32 K=1,4
18562 PRCLPR(K) = ZERO
18563 PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18564 32 CONTINUE
18565 ELSE
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
18569* n-n cms
18570 PZI = PRCLPR(3)
18571 PEI = PRCLPR(4)
18572 CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18573 PZI = PRCLTA(3)
18574 PEI = PRCLTA(4)
18575 CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18576C IF (IP.GT.1) THEN
18577 PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18578 PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18579C ENDIF
18580 IF (IT.GT.1) THEN
18581 PRCLTA(3) = PRCLTA(3)+PINITA(3)
18582 PRCLTA(4) = PRCLTA(4)+PINITA(4)
18583 ENDIF
18584 ENDIF
18585
18586* check momenta of residual nuclei
18587 IF (LEMCCK) THEN
18588 CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18589 & 1,IDUM,IDUM)
18590 CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18591 & 2,IDUM,IDUM)
18592 CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18593 & 2,IDUM,IDUM)
18594 CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18595 & 2,IDUM,IDUM)
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
18598C CHKLEV = TINY3
18599 CHKLEV = TINY1
18600 CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18601C IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18602C & CALL DT_EVTOUT(4)
18603 IF (IREJ1.GT.0) RETURN
18604 ENDIF
18605
18606 RETURN
18607 END
18608*
18609*===scn4ba=============================================================*
18610*
18611CDECK ID>, DT_SCN4BA
18612 SUBROUTINE DT_SCN4BA
18613
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************************************************************************
18618
18619 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18620 SAVE
18621
18622 PARAMETER ( LINP = 5 ,
18623 & LOUT = 6 ,
18624 & LDAT = 9 )
18625
18626 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18627 & TINY10=1.0D-10)
18628
18629* event history
18630
18631 PARAMETER (NMXHKK=200000)
18632
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),
18639 & IHIST(2,NMXHKK)
18640* particle properties (BAMJET index convention)
18641 CHARACTER*8 ANAME
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
18647 LOGICAL LFERMI
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
18657
18658 DIMENSION PLAB(2,5),PCMS(4)
18659
18660 IREJ = 0
18661
18662* get number of wounded nucleons
18663 NPW = 0
18664 NPW0 = 0
18665 NPCW = 0
18666 NPSTCK = 0
18667 NTW = 0
18668 NTW0 = 0
18669 NTCW = 0
18670 NTSTCK = 0
18671
18672 ISGLPR = 0
18673 ISGLTA = 0
18674 LRCLPR = .FALSE.
18675 LRCLTA = .FALSE.
18676
18677C DO 2 I=1,NHKK
18678 DO 2 I=1,NPOINT(1)
18679* projectile nucleons wounded in primary interaction and in fzc
18680 IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18681 NPW = NPW+1
18682 IPW(NPW) = I
18683 NPSTCK = NPSTCK+1
18684 IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18685 IF (ISTHKK(I).EQ.11) NPW0 = NPW0+1
18686C IF (IP.GT.1) THEN
18687 DO 5 K=1,4
18688 TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18689 5 CONTINUE
18690C ENDIF
18691* target nucleons wounded in primary interaction and in fzc
18692 ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18693 NTW = NTW+1
18694 ITW(NTW) = I
18695 NTSTCK = NTSTCK+1
18696 IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18697 IF (ISTHKK(I).EQ.12) NTW0 = NTW0+1
18698 IF (IT.GT.1) THEN
18699 DO 6 K=1,4
18700 TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18701 6 CONTINUE
18702 ENDIF
18703 ELSEIF (ISTHKK(I).EQ.13) THEN
18704 ISGLPR = I
18705 ELSEIF (ISTHKK(I).EQ.14) THEN
18706 ISGLTA = I
18707 ENDIF
18708 2 CONTINUE
18709
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
18713 ISGLPR = I
18714 NPSTCK = NPSTCK-1
18715 IF (IIBAR(IDBAM(I)).NE.0) THEN
18716 NPW = NPW-1
18717 IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18718 ENDIF
18719 DO 7 K=1,4
18720 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18721 7 CONTINUE
18722* baryons which are unable to escape the nuclear potential of targ.
18723 ELSEIF (ISTHKK(I).EQ.16) THEN
18724 ISGLTA = I
18725 NTSTCK = NTSTCK-1
18726 IF (IIBAR(IDBAM(I)).NE.0) THEN
18727 NTW = NTW-1
18728 IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18729 ENDIF
18730 DO 8 K=1,4
18731 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18732 8 CONTINUE
18733 ENDIF
18734 11 CONTINUE
18735
18736* residual nuclei so far
18737 IRESP = IP-NPSTCK
18738 IREST = IT-NTSTCK
18739
18740* ckeck for "residual nuclei" consisting of one nucleon only
18741* treat it as final state particle
18742 IF (IRESP.EQ.1) THEN
18743 ID = IDBAM(ISGLPR)
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
18750 ELSE
18751 ISTHKK(ISGLPR) = 2
18752 ENDIF
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
18758 DO 21 K=1,4
18759 TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18760 21 CONTINUE
18761 ENDIF
18762 IF (IREST.EQ.1) THEN
18763 ID = IDBAM(ISGLTA)
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
18770 ELSE
18771 ISTHKK(ISGLTA) = 2
18772 ENDIF
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
18778 DO 22 K=1,4
18779 TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18780 22 CONTINUE
18781 ENDIF
18782
18783* get nuclear potential corresp. to the residual nucleus
18784 IPRCL = IP -NPW
18785 IPZRCL = IPZ-NPCW
18786 ITRCL = IT -NTW
18787 ITZRCL = ITZ-NTCW
18788 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18789
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
18794 ID = IDBAM(I)
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
18797 NPOTP = 1
18798 NPOTT = 1
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),
18804 & PLAB(1,4),ID,-2)
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
18811 ENDIF
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),
18817 & PLAB(2,4),ID,-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
18824 ENDIF
18825 IF (PHKK(3,I).GE.ZERO) THEN
18826 ISTHKK(I) = NPOTT
18827 IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18828 ELSE
18829 ISTHKK(I) = NPOTP
18830 IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18831 ENDIF
18832 IF (ISTHKK(I).NE.1) THEN
18833 J = ISTHKK(I)-14
18834 DO 4 K=1,5
18835 PHKK(K,I) = PLAB(J,K)
18836 4 CONTINUE
18837 IF (ISTHKK(I).EQ.15) THEN
18838 NPW = NPW-1
18839 IF (ID.EQ.1) NPCW = NPCW-1
18840 DO 9 K=1,4
18841 TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18842 9 CONTINUE
18843 ELSEIF (ISTHKK(I).EQ.16) THEN
18844 NTW = NTW-1
18845 IF (ID.EQ.1) NTCW = NTCW-1
18846 DO 10 K=1,4
18847 TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18848 10 CONTINUE
18849 ENDIF
18850 ENDIF
18851 ENDIF
18852 ENDIF
18853 3 CONTINUE
18854
18855* again: get nuclear potential corresp. to the residual nucleus
18856 IPRCL = IP -NPW
18857 IPZRCL = IPZ-NPCW
18858 ITRCL = IT -NTW
18859 ITZRCL = ITZ-NTCW
18860c AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18861cC AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18862c & *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18863C AFERP = 0.0D0
18864c AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18865cC AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18866c & *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18867C AFERT = 0.0D0
18868C IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18869C IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18870C IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18871C IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18872 AFERP = FERMOD+0.1D0
18873 AFERT = FERMOD+0.1D0
18874
18875 CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18876
18877 RETURN
18878 END
18879*
18880*===ficonf=============================================================*
18881*
18882CDECK ID>, DT_FICONF
18883 SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18884
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************************************************************************
18892
18893 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18894 SAVE
18895
18896 PARAMETER ( LINP = 5 ,
18897 & LOUT = 6 ,
18898 & LDAT = 9 )
18899
18900 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18901 PARAMETER (ANGLGB=5.0D-16)
18902
18903* event history
18904
18905 PARAMETER (NMXHKK=200000)
18906
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),
18913 & IHIST(2,NMXHKK)
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)
18921 CHARACTER*8 ANAME
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),
18939 & NEVAFI(2,2)
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
18944
ba758f5a 18945 INCLUDE '(DIMPAR)'
18946 INCLUDE '(FINUC)'
18947 INCLUDE '(RESNUC)'
d30b8254 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
18956 & * 1.D-09 )
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 )
ba758f5a 18962 INCLUDE '(NUCDAT)'
18963 INCLUDE '(PAREVT)'
18964 INCLUDE '(FHEAVY)'
d30b8254 18965
18966* event flag
18967 COMMON /DTEVNO/ NEVENT,ICASCA
18968
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)
18972
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/
18976
18977 IREJ = 0
18978 LRCLPR = .FALSE.
18979 LRCLTA = .FALSE.
18980
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
18984
18985 DO 1 K=1,2
18986 IDPAR(K) = 0
18987 IDXPAR(K)= 0
18988 NTOT(K) = 0
18989 NTOTFI(K)= 0
18990 NPRO(K) = 0
18991 NPROFI(K)= 0
18992 NN(K) = 0
18993 NH(K) = 0
18994 NHPOS(K) = 0
18995 NQ(K) = 0
18996 EEXC(K) = ZERO
18997 MO1(K) = 0
18998 MO2(K) = 0
18999 DO 2 I=1,4
19000 VRCL(K,I) = ZERO
19001 WRCL(K,I) = ZERO
19002 2 CONTINUE
19003 1 CONTINUE
19004 NFSP = 0
19005 INUC(1) = IP
19006 INUC(2) = IT
19007
19008 DO 3 I=1,NHKK
19009
19010* number of final state particles
19011 IF (ABS(ISTHKK(I)).EQ.1) THEN
19012 NFSP = NFSP+1
19013 IDFSP = IDBAM(I)
19014 ENDIF
19015
19016* properties of remaining nucleon configurations
19017 KF = 0
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
19020 IF (KF.GT.0) THEN
19021 IF (MO1(KF).EQ.0) MO1(KF) = I
19022 MO2(KF) = I
19023* position of residual nucleus = average position of nucleons
19024 DO 4 K=1,4
19025 VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19026 WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19027 4 CONTINUE
19028* total number of particles contributing to each residual nucleus
19029 NTOT(KF) = NTOT(KF)+1
19030 IDTMP = IDBAM(I)
19031 IDXTMP = I
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
19039 NN(KF) = NN(KF)+1
19040 ELSE
19041* number of baryons other than n, p
19042 IF (IIBAR(IDTMP).EQ.1) THEN
19043 NH(KF) = NH(KF)+1
19044 IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19045 ELSE
19046* any other mesons (status set to 1)
19047C WRITE(LOUT,1002) KF,IDTMP
19048C1002 FORMAT(1X,'FICONF: residual nucleus ',I2,
19049C & ' containing meson ',I4,', status set to 1')
19050 ISTHKK(I) = 1
19051 IDTMP = IDPAR(KF)
19052 IDXTMP = IDXPAR(KF)
19053 NTOT(KF) = NTOT(KF)-1
19054 ENDIF
19055 ENDIF
19056 IDPAR(KF) = IDTMP
19057 IDXPAR(KF) = IDXTMP
19058 ENDIF
19059 3 CONTINUE
19060
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
19064 GOTO 9999
19065C RETURN
19066 ENDIF
19067
19068* check if one nucleus disappeared..
19069C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19070C DO 5 K=1,4
19071C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19072C PRCLPR(K) = ZERO
19073C 5 CONTINUE
19074C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19075C DO 6 K=1,4
19076C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19077C PRCLTA(K) = ZERO
19078C 6 CONTINUE
19079C ENDIF
19080
19081 ICOR = 0
19082 INORCL = 0
19083 DO 7 I=1,2
19084 DO 8 K=1,4
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)
19090 8 CONTINUE
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
19096
19097C 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)
19100
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),
19108 & PRCL(I,4),NTOT
19109 1000 FORMAT(1X,'warning! negative excitation energy',/,
19110 & I4,4E15.4,2I4)
19111 AMRCL(I) = ZERO
19112 EEXC(I) = ZERO
19113 IF (NLOOP.LE.500) THEN
19114 GOTO 9998
19115 ELSE
19116 IREXCI(2) = IREXCI(2)+1
19117 GOTO 9999
19118 ENDIF
19119 ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
19120 & THEN
19121**sr
19122C WRITE(6,*) NEVHKK,I,NTOT(1),NTOT(2),AMRCL(I),AMRCL0(I)
19123**
19124**sr 3.3
19125C 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))
19129 ELSE
19130 70 CONTINUE
19131 M = M+1
19132 IF (M.GE.INUC(I)) THEN
19133 AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
19134 ELSE
19135 IF (NEXC(I,M).GT.0) THEN
19136 AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19137 ELSE
19138 GOTO 70
19139 ENDIF
19140 ENDIF
19141 ENDIF
19142**
19143 EEXC(I) = AMRCL(I)-AMRCL0(I)
19144 ICOR = ICOR+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)
19150 AMRCL(I) = ZERO
19151 EEXC(I) = ZERO
19152 IF (NLOOP.LE.500) THEN
19153 GOTO 9998
19154 ELSE
19155 IREXCI(2) = IREXCI(2)+1
19156 GOTO 9999
19157 ENDIF
19158 ELSE
19159* excitation energies of residual nuclei
19160 EEXC(I) = AMRCL(I)-AMRCL0(I)
19161 IF (ICASCA.EQ.0) THEN
19162**sr 15.1.
19163C 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
19168 ENDIF
19169 ENDIF
19170 ELSEIF (NTOT(I).EQ.1) THEN
19171 WRITE(LOUT,1003) I
19172 1003 FORMAT(1X,'FICONF: warning! NTOT(I)=1? (I=',I3,')')
19173 GOTO 9999
19174 ELSE
19175 AMRCL0(I) = ZERO
19176 AMRCL(I) = ZERO
19177 EEXC(I) = ZERO
19178 INORCL = INORCL+I
19179 ENDIF
19180 7 CONTINUE
19181
19182 PRCLPR(5) = AMRCL(1)
19183 PRCLTA(5) = AMRCL(2)
19184
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
19189 DO 9 K=1,4
19190 P1IN(K) = PRCL(1,K)
19191 P2IN(K) = PRCL(2,K)
19192 9 CONTINUE
19193 XM1 = AMRCL(1)
19194 XM2 = AMRCL(2)
19195 CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19196 IF (IREJ1.GT.0) THEN
19197 WRITE(LOUT,*) 'ficonf-mashel rejection'
19198 GOTO 9999
19199 ENDIF
19200 DO 10 K=1,4
19201 PRCL(1,K) = P1OUT(K)
19202 PRCL(2,K) = P2OUT(K)
19203 PRCLPR(K) = P1OUT(K)
19204 PRCLTA(K) = P2OUT(K)
19205 10 CONTINUE
19206 PRCLPR(5) = AMRCL(1)
19207 PRCLTA(5) = AMRCL(2)
19208 ELSE
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,
19217 & 2(/,11X,3E12.3))
19218 IF (NLOOP.LE.500) THEN
19219 GOTO 9998
19220 ELSE
19221 IREXCI(1) = IREXCI(1)+1
19222 ENDIF
19223 ENDIF
19224 ENDIF
19225
19226* update counter
19227C IF (NRESEV(1).NE.NEVHKK) THEN
19228C NRESEV(1) = NEVHKK
19229C NRESEV(2) = NRESEV(2)+1
19230C ENDIF
19231 NRESEV(2) = NRESEV(2)+1
19232 DO 15 I=1,2
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)
19241 15 CONTINUE
19242
19243* evaporation
19244 IF (LEVPRT) THEN
19245 DO 13 I=1,2
19246* initialize evaporation counter
19247 NP = 0
19248 EEXCFI(I) = ZERO
19249 IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19250 & (EEXC(I).GT.ZERO)) THEN
19251* put residual nuclei into DTEVT1
19252 IDRCL = 80000
19253 JMASS = INT( AIF(I))
19254 JCHAR = INT(AIZF(I))
19255* the following patch is required to transmit the correct excitation
19256* energy to Eventd
19257 IF (ITRSPT.EQ.1) THEN
19258 PRCL0 = PRCL(I,4)
19259 PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19260 & +PRCL(I,3)**2)
19261 IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19262 WRITE(LOUT,*)
19263 & ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19264 ENDIF
19265 ENDIF
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)
19268**sr 22.6.97
19269 NOBAM(NHKK) = I
19270**
19271 DO 14 J=1,4
19272 VHKK(J,NHKK) = VRCL(I,J)
19273 WHKK(J,NHKK) = WRCL(I,J)
19274 14 CONTINUE
19275* interface to evaporation module - fill final residual nucleus into
19276* common FKRESN
19277* fill resnuc only if code is not used as event generator in Fluka
19278 IF (ITRSPT.NE.1) THEN
19279 PXRES = PRCL(I,1)
19280 PYRES = PRCL(I,2)
19281 PZRES = PRCL(I,3)
19282 IBRES = NPRO(I)+NN(I)+NH(I)
19283 ICRES = NPRO(I)+NHPOS(I)
19284 ANOW = DBLE(IBRES)
19285 ZNOW = DBLE(ICRES)
19286 PTRES = SQRT(PXRES**2+PYRES**2+PZRES**2)
19287* ground state mass of the residual nucleus (should be equal to AM0T)
19288
19289 AMNRES = AMRCL0(I)
19290 AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
19291
19292* common FKFINU
19293 TV = ZERO
19294* kinetic energy of residual nucleus
19295 TVRECL = PRCL(I,4)-AMRCL(I)
19296* excitation energy of residual nucleus
19297 TVCMS = EEXC(I)
19298 PTOLD = PTRES
19299 PTRES = SQRT(ABS(TVRECL*(TVRECL+
19300 & 2.0D0*(AMMRES+TVCMS))))
19301 IF (PTOLD.LT.ANGLGB) THEN
19302 CALL DT_RACO(PXRES,PYRES,PZRES)
19303 PTOLD = ONE
19304 ENDIF
19305 PXRES = PXRES*PTRES/PTOLD
19306 PYRES = PYRES*PTRES/PTOLD
19307 PZRES = PZRES*PTRES/PTOLD
19308* evaporation
19309 WE = ONE
19310
19311 NPHEAV = 0
19312 LRNFSS = .FALSE.
19313 LFRAGM = .FALSE.
19314 CALL EVEVAP(WE)
19315
19316* put evaporated particles and residual nuclei to DTEVT1
19317 MO = NHKK
19318 CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19319 ENDIF
19320 EEXCFI(I) = EXCITF
19321 EXCEVA(I) = EXCEVA(I)+EXCITF
19322 ENDIF
19323 13 CONTINUE
19324 ENDIF
19325
19326 RETURN
19327
19328C9998 IREXCI(1) = IREXCI(1)+1
19329 9998 IREJ = IREJ+1
19330 9999 CONTINUE
19331 LRCLPR = .TRUE.
19332 LRCLTA = .TRUE.
19333 IREJ = IREJ+1
19334 RETURN
19335 END
19336* *
19337*====eva2he============================================================*
19338* *
19339CDECK ID>, DT_EVA2HE
19340 SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19341
19342************************************************************************
19343* Interface between common's of evaporation module (FKFINU,FKFHVY) *
19344* and DTEVT1. *
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************************************************************************
19351
19352 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19353 SAVE
19354
19355 PARAMETER ( LINP = 5 ,
19356 & LOUT = 6 ,
19357 & LDAT = 9 )
19358
19359 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19360
19361* event history
19362
19363 PARAMETER (NMXHKK=200000)
19364
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),
19373 & IHIST(2,NMXHKK)
19374* particle properties (BAMJET index convention)
19375 CHARACTER*8 ANAME
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),
19389 & NEVAFI(2,2)
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)
19394
ba758f5a 19395 INCLUDE '(DIMPAR)'
19396 INCLUDE '(FINUC)'
19397 INCLUDE '(RESNUC)'
19398 INCLUDE '(FHEAVY)'
d30b8254 19399
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 /
19404
19405 IREJ = 0
19406
19407* skip if evaporation package is not included
19408 IF (.NOT.LEVAPO) RETURN
19409
19410* update counter
19411 IF (NRESEV(3).NE.NEVHKK) THEN
19412 NRESEV(3) = NEVHKK
19413 NRESEV(4) = NRESEV(4)+1
19414 ENDIF
19415
19416 IF (LEMCCK)
19417 & CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19418 & IDUM,IDUM)
19419* mass number/charge of residual nucleus before evaporation
19420 IBTOT = IDRES(MO)
19421 IZTOT = IDXRES(MO)
19422
19423* protons/neutrons/gammas
19424 DO 1 I=1,NP
19425 PX = CXR(I)*PLR(I)
19426 PY = CYR(I)*PLR(I)
19427 PZ = CZR(I)*PLR(I)
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)
19436 ENDIF
19437 PE = TKI(I)+AM
19438 CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19439 NOBAM(NHKK) = IRCL
19440 IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19441 IBTOT = IBTOT-IIBAR(ID)
19442 IZTOT = IZTOT-IICH(ID)
19443 1 CONTINUE
19444
19445* heavy fragments
19446 DO 2 I=1,NPHEAV
19447 PX = CXHEAV(I)*PHEAVY(I)
19448 PY = CYHEAV(I)*PHEAVY(I)
19449 PZ = CZHEAV(I)*PHEAVY(I)
19450 IDHEAV = 80000
19451 AM = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19452 & (2.0D0*MAX(TKHEAV(I),TINY10))
19453 PE = TKHEAV(I)+AM
19454 CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19455 & IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19456 NOBAM(NHKK) = IRCL
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))
19460 2 CONTINUE
19461
19462 IF (IBRES.GT.0) THEN
19463* residual nucleus after evaporation
19464 IDNUC = 80000
19465 CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19466 & IBRES,ICRES,0)
19467 NOBAM(NHKK) = IRCL
19468 ENDIF
19469 EEXCF = TVCMS
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
19475
19476* count events with fission
19477 NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19478 IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19479
19480* energy-momentum conservation check
19481 IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19482C IF (IREJ.GT.0) THEN
19483C CALL DT_EVTOUT(4)
19484C WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19485C ENDIF
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)
19491 ENDIF
19492
19493 RETURN
19494 END
19495*
19496*===ebind==============================================================*
19497*
19498CDECK ID>, DT_EBIND
19499 DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19500
19501************************************************************************
19502* Binding energy for nuclei. *
19503* (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972) *
19504* IA mass number *
19505* IZ atomic number *
19506* This version dated 5.5.95 is updated by S. Roesler. *
19507************************************************************************
19508
19509 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19510 SAVE
19511
19512 PARAMETER ( LINP = 5 ,
19513 & LOUT = 6 ,
19514 & LDAT = 9 )
19515
19516 PARAMETER (ZERO=0.0D0)
19517
19518 DATA A1, A2, A3, A4, A5
19519 & / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19520
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
19523 DT_EBIND = ZERO
19524 RETURN
19525 ENDIF
19526 AA = IA
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
19530 IA5 = 0
19531 ELSEIF (MOD(IZ,2).EQ.1) THEN
19532 IA5 = 1
19533 ELSE
19534 IA5 = -1
19535 ENDIF
19536 DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19537
19538 RETURN
19539 END
19540
19541************************************************************************
19542* *
19543* DPMJET 3.0: cross section routines *
19544* *
19545************************************************************************
19546*
19547*
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
19569* sigma_VN(tilde)
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
19580*
19581* SUBROUTINE DT_FLUINI
19582* total nucleon cross section fluctuation treatment
19583*
19584* SUBROUTINE DT_SIGTBL
19585* pre-tabulation of low-energy elastic x-sec. using SIHNEL
19586* SUBROUTINE DT_XSTABL
19587* service routines
19588*
19589*
19590*
19591*===shndif===============================================================*
19592*
19593CDECK ID>, DT_SHNDIF
19594 SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
19595
19596**********************************************************************
19597* Single diffractive hadron-nucleon cross sections *
19598* S.Roesler 14/1/93 *
19599* *
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 *
19603* sections. *
19604**********************************************************************
19605
19606 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19607 SAVE
19608 PARAMETER (ZERO=0.0D0)
19609
19610* particle properties (BAMJET index convention)
19611 CHARACTER*8 ANAME
19612 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19613 & IICH(210),IIBAR(210),K1(210),K2(210)
19614*
19615 CSD1 = 4.201483727D0
19616 CSD4 = -0.4763103556D-02
19617 CSD5 = 0.4324148297D0
19618*
19619 CHMSD1 = 0.8519297242D0
19620 CHMSD4 = -0.1443076599D-01
19621 CHMSD5 = 0.4014954567D0
19622*
19623 EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
19624 PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
19625*
19626 SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
19627 SHMSD = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
19628 FRAC = SHMSD/SDIAPP
19629*
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
19633*
19634 10 CONTINUE
19635*---------------------------- p - p , n - p , sigma0+- - p ,
19636* Lambda - 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
19642 RETURN
19643*
19644 20 CONTINUE
19645*
19646 KPSCAL = 2
19647 KTSCAL = 1
19648C F = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
19649 DUMZER = ZERO
19650 CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
19651 F = SDIAPP/SIGTO
19652 KT = 1
19653C SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
19654 CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
19655 SIGDIF = SIGTO*F
19656 SIGDIH = FRAC*SIGDIF
19657 RETURN
19658*
19659 999 CONTINUE
19660*-------------------------- leptons..
19661 SIGDIF = 1.D-10
19662 SIGDIH = 1.D-10
19663 RETURN
19664 END
19665*
19666*===phoxs================================================================*
19667*
19668CDECK ID>, DT_PHOXS
19669 SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
19670
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************************************************************************
19676
19677 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19678 SAVE
19679
19680 PARAMETER ( LINP = 5 ,
19681 & LOUT = 6 ,
19682 & LDAT = 9 )
19683
19684 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
19685 PARAMETER (TWOPI = 6.283185307179586454D+00,
19686 & PI = TWOPI/TWO,
19687 & GEV2MB = 0.38938D0)
19688
19689 LOGICAL LFIRST
19690 DATA LFIRST /.TRUE./
19691
19692* nucleon-nucleon event-generator
19693 CHARACTER*8 CMODEL
19694 LOGICAL LPHOIN
19695 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19696* particle properties (BAMJET index convention)
19697 CHARACTER*8 ANAME
19698 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19699 & IICH(210),IIBAR(210),K1(210),K2(210)
19700
19701**PHOJET105a
19702C PARAMETER (IEETAB=10)
19703C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19704**PHOJET110
19705C energy-interpolation table
19706 INTEGER IEETA2
19707 PARAMETER ( IEETA2 = 20 )
19708 INTEGER ISIMAX
19709 DOUBLE PRECISION SIGTAB,SIGECM
19710 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19711**
19712
19713 IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
19714 WRITE(LOUT,*) MCGENE
19715 1000 FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
19716 STOP
19717 ENDIF
19718
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))
19722 ENDIF
19723
19724 IF (MODE.EQ.1) THEN
19725* DL
19726 DELDL = 0.0808D0
19727 EPSDL = -0.4525D0
19728 S = ECM*ECM
19729 STOT = 21.7D0*S**DELDL+56.08D0*S**EPSDL
19730 ALPHAP= 0.25D0
19731 BEL = 8.5D0+2.D0*ALPHAP*LOG(S)
19732 SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
19733 SINE = STOT-SIGEL
19734 SDIF1 = ZERO
19735 ELSE
19736* Phojet
19737 IP = 1
19738 IF(ECM.LE.SIGECM(IP,1)) THEN
19739 I1 = 1
19740 I2 = 1
19741 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
19742 DO 1 I=2,ISIMAX
19743 IF (ECM.LE.SIGECM(IP,I)) GOTO 2
19744 1 CONTINUE
19745 2 CONTINUE
19746 I1 = I-1
19747 I2 = I
19748 ELSE
19749 IF (LFIRST) THEN
19750 WRITE(LOUT,'(/1X,A,2E12.3)')
19751 & 'PHOXS: warning! energy above initialization limit (',
19752 & ECM,SIGECM(IP,ISIMAX)
19753 LFIRST = .FALSE.
19754 ENDIF
19755 I1 = ISIMAX
19756 I2 = ISIMAX
19757 ENDIF
19758 FAC2 = ZERO
19759 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
19760 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
19761 FAC1 = ONE-FAC2
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)
19767 ENDIF
19768
19769 RETURN
19770 END
19771*
19772*===xshn===============================================================*
19773*
19774CDECK ID>, DT_XSHN
19775 SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
19776
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************************************************************************
19792
19793 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19794 SAVE
19795
19796 PARAMETER ( LINP = 5 ,
19797 & LOUT = 6 ,
19798 & LDAT = 9 )
19799
19800 PARAMETER (ZERO=0.0D0,ONE=1.0D0)
19801
19802 PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
19803 & PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
19804 PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
19805
19806 LOGICAL LFIRST
19807* particle properties (BAMJET index convention)
19808 CHARACTER*8 ANAME
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
19812 CHARACTER*8 CMODEL
19813 LOGICAL LPHOIN
19814 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
19815**PHOJET105a
19816C PARAMETER (IEETAB=10)
19817C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
19818**PHOJET110
19819C energy-interpolation table
19820 INTEGER IEETA2
19821 PARAMETER ( IEETA2 = 20 )
19822 INTEGER ISIMAX
19823 DOUBLE PRECISION SIGTAB,SIGECM
19824 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
19825
19826 DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
19827 DIMENSION IDXDAT(25,2)
19828*
19829 DATA APL /
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/
19837*
19838* total cross sections:
19839* p p
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/
19848* pbar p
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/
19857* n p
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/
19866* pi+ p
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/
19875* pi- p
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/
19884* K+ p
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/
19893* K- p
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/
19902* K+ n
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/
19911* K- n
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/
19920* Lambda p
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/
19929*
19930* elastic cross sections:
19931* p p
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/
19940* pbar p
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/
19949* n p
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/
19958* pi+ p
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/
19967* pi- p
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/
19976* K+ p
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/
19985* K- p
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/
19994* K+ n
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/
20003* K- n
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/
20012* Lambda p
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/
20021
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,
20024 & 1, 3,45, 8, 9/
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,
20027 & 3, 1,45, 6, 7/
20028
20029 DATA LFIRST /.TRUE./
20030
20031 IF (LFIRST) THEN
20032 APLABL = LOG10(PLABLO)
20033 APLABH = LOG10(PLABHI)
20034 APTHRE = LOG10(PTHRE)
20035 ADP1 = (APTHRE-APLABL)/DBLE(NPOIN1)
20036 ADP2 = (APLABH-APTHRE)/DBLE(NPOIN2)
20037 DUM0 = ZERO
20038 PHOPLA = PLABHI
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)
20044 ELSE
20045 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20046 ENDIF
20047 ELSE
20048 CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
20049 ENDIF
20050 PHOSEL = PHOSTO-PHOSIN
20051 APHOST = LOG10(PHOSTO)
20052 APHOSE = LOG10(PHOSEL)
20053 LFIRST = .FALSE.
20054 ENDIF
20055 STOT = ZERO
20056 SELA = ZERO
20057 PLAB = PL
20058 ECMS = ECM
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)
20063 STOP
20064 ENDIF
20065
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)
20072 STOP
20073 ENDIF
20074
20075* index of spectrum
20076 IDXP = IP
20077 IF (IP.GT.25) THEN
20078 IF (AAM(IP).GT.ZERO) THEN
20079 IF (ABS(IIBAR(IP)).GT.0) THEN
20080 IDXP = 1
20081 ELSE
20082 IDXP = 13
20083 ENDIF
20084 ELSE
20085 IDXP = 7
20086 ENDIF
20087 ENDIF
20088 IDXT = 1
20089 IF (IT.EQ.8) IDXT = 2
20090 IDXS = IDXDAT(IDXP,IDXT)
20091 IF (IDXS.EQ.0) RETURN
20092
20093* compute momentum bin indices
20094 IF (PLAB.LT.PLABLO) THEN
20095 IDX0 = 1
20096 IDX1 = 1
20097 ELSEIF (PLAB.GE.PLABHI) THEN
20098 IDX0 = NPOINT
20099 IDX1 = NPOINT
20100 ELSE
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
20106 ENDIF
20107 IDX1 = IDX0+1
20108 ENDIF
20109
20110* interpolate cross section
20111 IF (IDXS.GT.10) THEN
20112 IDXS1 = IDXS/10
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))
20118 ELSE
20119 DUM0 = ZERO
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)
20128 ENDIF
20129 ELSE
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)
20141 ENDIF
20142 ELSE
20143 IF (IDX0.EQ.IDX1) THEN
20144 IF (IDX0.EQ.1) THEN
20145 ASTOT = ASIGTO(IDXS,IDX0)
20146 ASELA = ASIGEL(IDXS,IDX0)
20147 ELSE
20148 DUM0 = ZERO
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)
20153 ENDIF
20154 ELSE
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))
20160 ENDIF
20161 ENDIF
20162 STOT = 10.0D0**ASTOT
20163 SELA = 10.0D0**ASELA
20164
20165 RETURN
20166 END
20167*
20168*===sihnab===============================================================*
20169*
20170CDECK ID>, DT_SIHNAB
20171 SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
20172
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**********************************************************************
20179
20180 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20181 SAVE
20182 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
20183 PARAMETER (AMPR = 938.0D0,
20184 & AMPI = 140.0D0,
20185 & AMDE = TWO*AMPR,
20186 & A = -1.2D0,
20187 & B = 3.5D0,
20188 & C = 7.4D0,
20189 & D = 5600.0D0,
20190 & ER = 2136.0D0)
20191
20192 SIGABS = ZERO
20193 IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
20194 & .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
20195 PTOT = PLAB*1.0D3
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
20204
20205 RETURN
20206 END
20207*
20208*===sigemu=============================================================*
20209*
20210CDECK ID>, DT_SIGEMU
20211 SUBROUTINE DT_SIGEMU
20212
20213************************************************************************
20214* Combined cross section for target compounds. *
20215* This version dated 6.4.98 is written by S. Roesler *
20216************************************************************************
20217
20218 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20219 SAVE
20220
20221 PARAMETER ( LINP = 5 ,
20222 & LOUT = 6 ,
20223 & LDAT = 9 )
20224
20225 PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
20226 & OHALF=0.5D0,ONE=1.0D0)
20227
20228 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20229
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),
20243 & NCOMPO,IEMUL
20244* nucleon-nucleon event-generator
20245 CHARACTER*8 CMODEL
20246 LOGICAL LPHOIN
20247 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20248
20249 IF (MCGENE.NE.4) THEN
20250 WRITE(LOUT,'(A)') ' DT_SIGEMU: Combined cross sections'
20251 WRITE(LOUT,'(15X,A)') '-----------------------'
20252 ENDIF
20253 DO 1 IE=1,NEBINI
20254 DO 2 IQ=1,NQBINI
20255 SIGTOT = ZERO
20256 SIGELA = ZERO
20257 SIGQEP = ZERO
20258 SIGQET = ZERO
20259 SIGQE2 = ZERO
20260 SIGPRO = ZERO
20261 SIGDEL = ZERO
20262 SIGDQE = ZERO
20263 ERRTOT = ZERO
20264 ERRELA = ZERO
20265 ERRQEP = ZERO
20266 ERRQET = ZERO
20267 ERRQE2 = ZERO
20268 ERRPRO = ZERO
20269 ERRDEL = ZERO
20270 ERRDQE = ZERO
20271 IF (NCOMPO.GT.0) THEN
20272 DO 3 IC=1,NCOMPO
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
20289 3 CONTINUE
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)
20298 ELSE
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)
20315 ENDIF
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,' +-',
20325 & F11.5,' mb')
20326 WRITE(LOUT,1004) SIGQET,ERRQET
20327 1004 FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
20328 & F11.5,' mb')
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')
20338 ENDIF
20339
20340 2 CONTINUE
20341 1 CONTINUE
20342
20343 RETURN
20344 END
20345*
20346*===sigga==============================================================*
20347*
20348CDECK ID>, DT_SIGGA
20349 SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
20350
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************************************************************************
20357
20358 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20359 SAVE
20360
20361 PARAMETER ( LINP = 5 ,
20362 & LOUT = 6 ,
20363 & LDAT = 9 )
20364
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)
20368
20369 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20370
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
20382
20383 NT = NTI
20384 X = XI
20385 Q2 = Q2I
20386 ECM = ECMI
20387 XNU = XNUI
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)
20393 SIN = XSPRO(1,1,1)
20394 EIN = XEPRO(1,1,1)
20395
20396 RETURN
20397 END
20398*
20399*===siggat=============================================================*
20400*
20401CDECK ID>, DT_SIGGAT
20402 SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
20403
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************************************************************************
20409
20410 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20411 SAVE
20412
20413 PARAMETER ( LINP = 5 ,
20414 & LOUT = 6 ,
20415 & LDAT = 9 )
20416
20417 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20418 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20419
20420 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
20421
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
20433
20434 NTARG = ABS(NT)
20435 I1 = 1
20436 I2 = 1
20437 RATE = ONE
20438 IF (NEBINI.GT.1) THEN
20439 IF (ECMI.GE.ECMNN(NEBINI)) THEN
20440 I1 = NEBINI
20441 I2 = NEBINI
20442 RATE = ONE
20443 ELSEIF (ECMI.GT.ECMNN(1)) THEN
20444 DO 1 I=2,NEBINI
20445 IF (ECMI.LT.ECMNN(I)) THEN
20446 I1 = I-1
20447 I2 = I
20448 RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
20449 GOTO 2
20450 ENDIF
20451 1 CONTINUE
20452 2 CONTINUE
20453 ENDIF
20454 ENDIF
20455 J1 = 1
20456 J2 = 1
20457 RATQ = ONE
20458 IF (NQBINI.GT.1) THEN
20459 IF (Q2I.GE.Q2G(NQBINI)) THEN
20460 J1 = NQBINI
20461 J2 = NQBINI
20462 RATQ = ONE
20463 ELSEIF (Q2I.GT.Q2G(1)) THEN
20464 DO 3 I=2,NQBINI
20465 IF (Q2I.LT.Q2G(I)) THEN
20466 J1 = I-1
20467 J2 = I
20468 RATQ = LOG10( Q2I/MAX(Q2G(J1),TINY14))/
20469 & LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
20470C RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
20471 GOTO 4
20472 ENDIF
20473 3 CONTINUE
20474 4 CONTINUE
20475 ENDIF
20476 ENDIF
20477
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))
20483
20484 RETURN
20485 END
20486*
20487*===sigano=============================================================*
20488*
20489CDECK ID>, DT_SANO
20490 DOUBLE PRECISION FUNCTION DT_SANO(ECM)
20491
20492************************************************************************
20493* This version dated 31.07.96 is written by S. Roesler *
20494************************************************************************
20495
20496 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20497 SAVE
20498
20499 PARAMETER ( LINP = 5 ,
20500 & LOUT = 6 ,
20501 & LDAT = 9 )
20502
20503 PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
20504 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20505 PARAMETER (NE = 8)
20506
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
20511
20512 DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
20513 DATA ECMANO /
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
20516 & /
20517* fixed cut (3 GeV/c)
20518 DATA FRAANO /
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
20521 & /
20522 DATA SIGHRD /
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
20525 & /
20526* running cut (based on obsolete Phojet-caluclations, bugs..)
20527C DATA FRAANO /
20528C & 0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
20529C & 0.167E+00,0.150E+00,0.131E+00
20530C & /
20531C DATA SIGHRD /
20532C & 6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
20533C & 2.5736E-01,4.5593E-01,8.2550E-01
20534C & /
20535
20536 DT_SANO = ZERO
20537 IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
20538 J1 = 0
20539 J2 = 0
20540 RATE = ONE
20541 IF (ECM.GE.ECMANO(NE)) THEN
20542 J1 = NE
20543 J2 = NE
20544 ELSEIF (ECM.GT.ECMANO(1)) THEN
20545 DO 1 IE=2,NE
20546 IF (ECM.LT.ECMANO(IE)) THEN
20547 J1 = IE-1
20548 J2 = IE
20549 RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
20550 GOTO 2
20551 ENDIF
20552 1 CONTINUE
20553 2 CONTINUE
20554 ENDIF
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))
20559 ENDIF
20560
20561 RETURN
20562 END
20563*
20564*===siggp==============================================================*
20565*
20566CDECK ID>, DT_SIGGP
20567 SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
20568
20569************************************************************************
20570* Total/inelastic photon-nucleon cross sections. *
20571* This version dated 30.04.96 is written by S. Roesler *
20572************************************************************************
20573
20574 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20575 SAVE
20576
20577 PARAMETER ( LINP = 5 ,
20578 & LOUT = 6 ,
20579 & LDAT = 9 )
20580
20581 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20582 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20583 & PI = TWOPI/TWO,
20584 & GEV2MB = 0.38938D0,
20585 & ALPHEM = ONE/137.0D0)
20586
20587* particle properties (BAMJET index convention)
20588 CHARACTER*8 ANAME
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)
20593
20594**PHOJET105a
20595C CHARACTER*8 MDLNA
20596C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
20597C PARAMETER (IEETAB=10)
20598C COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20599**PHOJET110
20600C model switches and parameters
20601 CHARACTER*8 MDLNA
20602 INTEGER ISWMDL,IPAMDL
20603 DOUBLE PRECISION PARMDL
20604 COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
20605C energy-interpolation table
20606 INTEGER IEETA2
20607 PARAMETER ( IEETA2 = 20 )
20608 INTEGER ISIMAX
20609 DOUBLE PRECISION SIGTAB,SIGECM
20610 COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20611**
20612
20613C PARAMETER (NPOINT=80)
20614 PARAMETER (NPOINT=16)
20615 DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
20616
20617 STOT = ZERO
20618 SINE = ZERO
20619 SDIR = ZERO
20620
20621 W2 = ECMI**2
20622 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20623 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20624 Q2 = Q2I
20625 X = XI
20626* photoprod.
20627 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20628 Q2 = 0.0001D0
20629 X = Q2/(W2+Q2-AAM(1)**2)
20630* DIS
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
20637 ELSE
20638 WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
20639 STOP
20640 ENDIF
20641 ECM = SQRT(W2)
20642
20643 IF (MODEGA.EQ.1) THEN
20644 SCALE = SQRT(Q2)
20645 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20646 & IDPDF)
20647C W = SQRT(W2)
20648
20649C ALLMF2 = PHO_ALLM97(Q2,W)
20650
20651C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20652 STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20653 SINE = ZERO
20654 SDIR = ZERO
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
20659 AMLO2 = AAM(33)**2
20660 ELSE
20661 AMLO2 = AAM(96)**2
20662 ENDIF
20663 IF (INTRGE(2).EQ.1) THEN
20664 AMHI2 = W2/TWO
20665 ELSEIF (INTRGE(2).EQ.2) THEN
20666 AMHI2 = W2/4.0D0
20667 ELSE
20668 AMHI2 = W2
20669 ENDIF
20670 AMHI20 = (ECM-AAM(1))**2
20671 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20672 XAMLO = LOG( AMLO2+Q2 )
20673 XAMHI = LOG( AMHI2+Q2 )
20674**PHOJET105a
20675C CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20676**PHOJET112
20677
20678 CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
20679
20680**
20681 SUM = ZERO
20682 DO 1 J=1,NPOINT
20683 AM2 = EXP(ABSZX(J))-Q2
20684 IF (AM2.LT.16.0D0) THEN
20685 R = TWO
20686 ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
20687 R = 10.0D0/3.0D0
20688 ELSE
20689 R = 11.0D0/3.0D0
20690 ENDIF
20691C 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
20695 1 CONTINUE
20696 SINE = SUM
20697 SDIR = DT_SIGVP(X,Q2)
20698 STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
20699 SDIR = SDIR/(0.588D0+RL2+Q2)
20700C 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
20705 IP = 1
20706 IF(ECM.LE.SIGECM(IP,1)) THEN
20707 I1 = 1
20708 I2 = 1
20709 ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20710 DO 2 I=2,ISIMAX
20711 IF (ECM.LE.SIGECM(IP,I)) GOTO 3
20712 2 CONTINUE
20713 3 CONTINUE
20714 I1 = I-1
20715 I2 = I
20716 ELSE
20717 WRITE(LOUT,'(/1X,A,2E12.3)')
20718 & 'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
20719 I1 = ISIMAX
20720 I2 = ISIMAX
20721 ENDIF
20722 FAC2 = ZERO
20723 IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20724 & /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20725 FAC1 = ONE-FAC2
20726* cross section dependence on photon virtuality
20727 FSUP1 = ZERO
20728 DO 4 I=1,3
20729 FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
20730 & /(1.D0+Q2/PARMDL(30+I))**2
20731 4 CONTINUE
20732 FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
20733 FAC1 = FAC1*FSUP1
20734 FAC2 = FAC2*FSUP1
20735 FSUP2 = 1.0D0
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)
20739**re:
20740 STOT = STOT-SDIR
20741**
20742 SDIR = SDIR/(FSUP1*FSUP2)
20743**re:
20744 STOT = STOT+SDIR
20745**
20746 ENDIF
20747
20748 RETURN
20749 END
20750*
20751*===sigvel=============================================================*
20752*
20753CDECK ID>, DT_SIGVEL
20754 SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
20755
20756************************************************************************
20757* Cross section for elastic vector meson production *
20758* This version dated 10.05.96 is written by S. Roesler *
20759************************************************************************
20760
20761 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20762 SAVE
20763
20764 PARAMETER ( LINP = 5 ,
20765 & LOUT = 6 ,
20766 & LDAT = 9 )
20767
20768 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20769 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20770 & PI = TWOPI/TWO,
20771 & GEV2MB = 0.38938D0,
20772 & ALPHEM = ONE/137.0D0)
20773
20774* particle properties (BAMJET index convention)
20775 CHARACTER*8 ANAME
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)
20780
20781 W2 = ECMI**2
20782 IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
20783 & W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
20784 Q2 = Q2I
20785 X = XI
20786* photoprod.
20787 IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
20788 Q2 = 0.0001D0
20789 X = Q2/(W2+Q2-AAM(1)**2)
20790* DIS
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
20797 ELSE
20798 WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
20799 STOP
20800 ENDIF
20801 ECM = SQRT(W2)
20802
20803 AMV = AAM(IDXV)
20804 AMV2 = AMV**2
20805
20806 BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
20807 & +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
20808 ROSH = 0.1D0
20809 STOVP = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
20810 SELVP = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
20811
20812 IF (IDXV.EQ.33) THEN
20813 COUPL = 0.00365D0
20814 ELSE
20815 STOP
20816 ENDIF
20817 SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
20818 SIG2 = SELVP
20819 SVEL = COUPL * (AMV2/(AMV2+Q2))**2
20820 & * (ONE+EPSPOL*Q2/AMV2) * SELVP
20821
20822 RETURN
20823 END
20824*
20825*===sigvp==============================================================*
20826*
20827CDECK ID>, DT_SIGVP
20828 DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
20829
20830************************************************************************
20831* sigma_Vp *
20832************************************************************************
20833
20834 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20835 SAVE
20836
20837 PARAMETER ( LINP = 5 ,
20838 & LOUT = 6 ,
20839 & LDAT = 9 )
20840
20841 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20842 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20843 & PI = TWOPI/TWO,
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)
20849
20850 X = XI
20851 Q2 = Q2I
20852 IF (XI.LE.ZERO) X = 0.0001D0
20853 IF (Q2I.LE.ZERO) Q2 = 0.0001D0
20854
20855 ECM = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
20856
20857 SCALE = SQRT(Q2)
20858 IF (MODEGA.EQ.1) THEN
20859 CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
20860 & IDPDF)
20861C W = ECM
20862
20863C ALLMF2 = PHO_ALLM97(Q2,W)
20864
20865C write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
20866C STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
20867C 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)
20871C F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
20872 DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
20873 ELSE
20874 STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
20875 ENDIF
20876
20877 RETURN
20878
20879 END
20880*
20881*===RRM2===============================================================*
20882*
20883CDECK ID>, DT_RRM2
20884 DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
20885
20886 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20887 SAVE
20888
20889 PARAMETER ( LINP = 5 ,
20890 & LOUT = 6 ,
20891 & LDAT = 9 )
20892
20893 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20894 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20895 & PI = TWOPI/TWO,
20896 & GEV2MB = 0.38938D0)
20897
20898* particle properties (BAMJET index convention)
20899 CHARACTER*8 ANAME
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)
20904
20905 S = Q2*(ONE-X)/X+AAM(1)**2
20906 ECM = SQRT(S)
20907
20908 IF (INTRGE(1).EQ.1) THEN
20909 AMLO2 = (3.0D0*AAM(13))**2
20910 ELSEIF (INTRGE(1).EQ.2) THEN
20911 AMLO2 = AAM(33)**2
20912 ELSE
20913 AMLO2 = AAM(96)**2
20914 ENDIF
20915 IF (INTRGE(2).EQ.1) THEN
20916 AMHI2 = S/TWO
20917 ELSEIF (INTRGE(2).EQ.2) THEN
20918 AMHI2 = S/4.0D0
20919 ELSE
20920 AMHI2 = S
20921 ENDIF
20922 AMHI20 = (ECM-AAM(1))**2
20923 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
20924
20925 AM1C2 = 16.0D0
20926 AM2C2 = 121.0D0
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)
20932 ELSE
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)
20936 ENDIF
20937
20938 RETURN
20939 END
20940*
20941*===RM2================================================================*
20942*
20943CDECK ID>, DT_RM2
20944 DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
20945
20946 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20947 SAVE
20948
20949 PARAMETER ( LINP = 5 ,
20950 & LOUT = 6 ,
20951 & LDAT = 9 )
20952
20953 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
20954 PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
20955 & PI = TWOPI/TWO,
20956 & GEV2MB = 0.38938D0)
20957* VDM parameter for photon-nucleus interactions
20958 COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
20959
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))
20964 ELSE
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)
20969 & +EPSPOL*(
20970 & -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
20971 & -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
20972 ENDIF
20973
20974 RETURN
20975 END
20976*
20977*===SAM2===============================================================*
20978*
20979CDECK ID>, DT_SAM2
20980 DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
20981
20982 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20983 SAVE
20984
20985 PARAMETER ( LINP = 5 ,
20986 & LOUT = 6 ,
20987 & LDAT = 9 )
20988
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,
20992 & PI = TWOPI/TWO,
20993 & GEV2MB = 0.38938D0)
20994
20995* particle properties (BAMJET index convention)
20996 CHARACTER*8 ANAME
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)
21001
21002 S = ECM**2
21003 IF (INTRGE(1).EQ.1) THEN
21004 AMLO2 = (3.0D0*AAM(13))**2
21005 ELSEIF (INTRGE(1).EQ.2) THEN
21006 AMLO2 = AAM(33)**2
21007 ELSE
21008 AMLO2 = AAM(96)**2
21009 ENDIF
21010 IF (INTRGE(2).EQ.1) THEN
21011 AMHI2 = S/TWO
21012 ELSEIF (INTRGE(2).EQ.2) THEN
21013 AMHI2 = S/4.0D0
21014 ELSE
21015 AMHI2 = S
21016 ENDIF
21017 AMHI20 = (ECM-AAM(1))**2
21018 IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21019
21020 AM1C2 = 16.0D0
21021 AM2C2 = 121.0D0
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
21027 FACHI = TWO
21028 ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
21029 FACHI = TENTRD
21030 ELSE
21031 FACHI = ELVTRD
21032 ENDIF
21033
21034 1 CONTINUE
21035 YSAM2 = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
21036 IF (YSAM2.LE.YC1) THEN
21037 FAC = TWO
21038 ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
21039 FAC = TENTRD
21040 ELSE
21041 FAC = ELVTRD
21042 ENDIF
21043 WEIGMX = FACHI*(ONE-Q2*EXP( -YHI))
21044 XSAM2 = FAC *(ONE-Q2*EXP(-YSAM2))
21045 IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
21046
21047 DT_SAM2 = EXP(YSAM2)-Q2
21048
21049 RETURN
21050 END
21051*
21052*===ckmt===============================================================*
21053*
21054CDECK ID>, DT_CKMT
21055 SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
21056 & F2,IPAR)
21057
21058************************************************************************
21059* This version dated 31.01.96 is written by S. Roesler *
21060************************************************************************
21061
21062 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21063 SAVE
21064
21065 PARAMETER ( LINP = 5 ,
21066 & LOUT = 6 ,
21067 & LDAT = 9 )
21068
21069 PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
21070
21071 PARAMETER (Q02 = 2.0D0,
21072 & DQ2 = 10.05D0,
21073 & Q12 = Q02+DQ2)
21074
21075 DIMENSION PD(-6:6),SEA(3),VAL(2)
21076
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
21085
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)
21090 UPV = VAL(1)
21091 DNV = VAL(2)
21092 USEA = SEA(1)
21093 DSEA = SEA(2)
21094 STR = SEA(3)
21095 CHM = 0.0D0
21096 BOT = 0.0D0
21097 TOP = 0.0D0
21098 GL = GLU
21099 ELSE
21100 CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
21101 F2 = F2*SMOOTH
21102 UPV = PD(2)-PD(3)
21103 DNV = PD(1)-PD(3)
21104 USEA = PD(3)
21105 DSEA = PD(3)
21106 STR = PD(3)
21107 CHM = PD(4)
21108 BOT = PD(5)
21109 TOP = PD(6)
21110 GL = PD(0)
21111C UPV = UPV*SMOOTH
21112C DNV = DNV*SMOOTH
21113C USEA = USEA*SMOOTH
21114C DSEA = DSEA*SMOOTH
21115C STR = STR*SMOOTH
21116C CHM = CHM*SMOOTH
21117C GL = GL*SMOOTH
21118 ENDIF
21119
21120 RETURN
21121 END
21122C
21123CDECK ID>, DT_CKMTX
21124 SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
21125C**********************************************************************
21126C
21127C PDF based on Regge theory, evolved with .... by ....
21128C
21129C input: IPAR 2212 proton (not installed)
21130C 45 Pomeron
21131C 100 Deuteron
21132C
21133C output: PD(-6:6) x*f(x) parton distribution functions
21134C (PDFLIB convention: d = PD(1), u = PD(2) )
21135C
21136C**********************************************************************
21137
21138 SAVE
21139 DOUBLE PRECISION X,SCALE2,PD(-6:6),CDN,CUP,F2
21140
21141 PARAMETER ( LINP = 5 ,
21142 & LOUT = 6 ,
21143 & LDAT = 9 )
21144
21145 DIMENSION QQ(7)
21146C
21147 Q2=SNGL(SCALE2)
21148 Q1S=Q2
21149 XX=SNGL(X)
21150C QCD lambda for evolution
21151 OWLAM = 0.23D0
21152 OWLAM2=OWLAM**2
21153C Q0**2 for evolution
21154 Q02 = 2.D0
21155C
21156C
21157C the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
21158C q(6)=x*charm, q(7)=x*gluon
21159C
21160 SB=0.
21161 IF(Q2-Q02) 1,1,2
21162 2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
21163 1 CONTINUE
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))
21172C ELSEIF (IPAR.EQ.45) THEN
21173C CALL CKMTPO(1,0,XX,SB,QQ(1))
21174C CALL CKMTPO(2,0,XX,SB,QQ(2))
21175C CALL CKMTPO(3,0,XX,SB,QQ(3))
21176C CALL CKMTPO(4,0,XX,SB,QQ(4))
21177C CALL CKMTPO(5,0,XX,SB,QQ(5))
21178C CALL CKMTPO(8,0,XX,SB,QQ(6))
21179C 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))
21188 ELSE
21189 WRITE(LOUT,'(1X,A,I4,A)')
21190 & 'CKMTX: IPAR =',IPAR,' not implemented!'
21191 STOP
21192 ENDIF
21193C
21194 PD(-6) = 0.D0
21195 PD(-5) = 0.D0
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))
21205 PD(5) = 0.D0
21206 PD(6) = 0.D0
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
21212 PD(1) = PD(-1)
21213 PD(2) = PD(-2)
21214 ENDIF
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))
21218 END
21219C
21220*
21221*===pdf0===============================================================*
21222*
21223CDECK ID>, DT_PDF0
21224 SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
21225
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 *
21230* = 100 deuteron *
21231* This version dated 31.01.96 is written by S. Roesler *
21232************************************************************************
21233
21234 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21235 SAVE
21236
21237 PARAMETER ( LINP = 5 ,
21238 & LOUT = 6 ,
21239 & LDAT = 9 )
21240
21241 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21242
21243 PARAMETER (
21244 & AA = 0.1502D0,
21245 & BBDEU = 1.2D0,
21246 & BUD = 0.754D0,
21247 & BDD = 0.4495D0,
21248 & BUP = 1.2064D0,
21249 & BDP = 0.1798D0,
21250 & DELTA0 = 0.07684D0,
21251 & D = 1.117D0,
21252 & C = 3.5489D0,
21253 & A = 0.2631D0,
21254 & B = 0.6452D0,
21255 & ALPHAR = 0.415D0,
21256 & E = 0.1D0
21257 & )
21258
21259 PARAMETER (NPOINT=16)
21260C DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21261 DIMENSION SEA(3),VAL(2)
21262
21263 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21264 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
21265* proton, deuteron
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
21269 SEA(2) = SEA(1)
21270 SEA(3) = SEA(1)
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
21280 STOP
21281 ENDIF
21282**PHOJET105a
21283C CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21284**PHOJET112
21285
21286C CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
21287
21288**
21289C SUMQ = ZERO
21290C SUMG = ZERO
21291C DO 1 J=1,NPOINT
21292C CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
21293C VALU0 = 9.0D0/4.0D0*VALU0
21294C VALD0 = 9.0D0*VALD0
21295C SEA0 = 0.75D0*SEA0
21296C SUMQ = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
21297C SUMG = SUMG+ (SEA0/(1.0D0-ABSZX(J))) *WEIGHT(J)
21298C 1 CONTINUE
21299C GLU = GLU0*(1.0D0-SUMQ)/SUMG
21300 ELSE
21301 WRITE(LOUT,'(1X,A,I4,A)')
21302 & 'PDF0: IPAR =',IPAR,' not implemented!'
21303 STOP
21304 ENDIF
21305
21306 RETURN
21307 END
21308*
21309*===ckmtq0=============================================================*
21310*
21311CDECK ID>, DT_CKMTQ0
21312 SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
21313
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 *
21318* = 100 deuteron *
21319* This version dated 31.01.96 is written by S. Roesler *
21320************************************************************************
21321
21322 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21323 SAVE
21324
21325 PARAMETER ( LINP = 5 ,
21326 & LOUT = 6 ,
21327 & LDAT = 9 )
21328
21329 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
21330
21331 PARAMETER (
21332 & AA = 0.1502D0,
21333 & BBDEU = 1.2D0,
21334 & BUD = 0.754D0,
21335 & BDD = 0.4495D0,
21336 & BUP = 1.2064D0,
21337 & BDP = 0.1798D0,
21338 & DELTA0 = 0.07684D0,
21339 & D = 1.117D0,
21340 & C = 3.5489D0,
21341 & A = 0.2631D0,
21342 & B = 0.6452D0,
21343 & ALPHAR = 0.415D0,
21344 & E = 0.1D0
21345 & )
21346
21347 DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
21348 AN = 1.5D0*(1.0D0+Q2/(Q2+C))
21349* proton, deuteron
21350 IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
21351 IF (IPAR.EQ.2212) THEN
21352 BU = BUP
21353 BD = BDP
21354 ELSE
21355 BU = BUD
21356 BD = BDD
21357 ENDIF
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)
21364 ELSE
21365 WRITE(LOUT,'(1X,A,I4,A)')
21366 & 'CKMTQ0: IPAR =',IPAR,' not implemented!'
21367 STOP
21368 ENDIF
21369 RETURN
21370 END
21371C
21372C
21373CDECK ID>, DT_CKMTDE
21374 SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
21375C
21376C**********************************************************************
21377C Deuteron - PDFs
21378C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
21379C ANS = PDF(I)
21380C This version by S. Roesler, 30.01.96
21381C**********************************************************************
21382
21383 SAVE
21384 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
21385 EQUIVALENCE (GF(1,1,1),DL(1))
21386 DATA DELTA/.13/
21387C
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/
22236C
22237 ANS = 0.
22238 IF (X.GT.0.9985) RETURN
22239 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
22240C
22241 IS = S/DELTA+1
22242 IS1 = IS+1
22243 DO 1 L=1,25
22244 KL = L+NDRV*25
22245 F1(L) = GF(I,IS,KL)
22246 F2(L) = GF(I,IS1,KL)
22247 1 CONTINUE
22248 A1 = DT_CKMTFF(X,F1)
22249 A2 = DT_CKMTFF(X,F2)
22250C A1=ALOG(A1)
22251C A2=ALOG(A2)
22252 S1 = (IS-1)*DELTA
22253 S2 = S1+DELTA
22254 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
22255C ANS=EXP(ANS)
22256 RETURN
22257 END
22258C
22259C
22260CDECK ID>, DT_CKMTPR
22261 SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
22262C
22263C**********************************************************************
22264C Proton - PDFs
22265C I = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22266C ANS = PDF(I)
22267C This version by S. Roesler, 31.01.96
22268C**********************************************************************
22269
22270 SAVE
22271 DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22272 EQUIVALENCE (GF(1,1,1),DL(1))
22273 DATA DELTA/.10/
22274C
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/
23123C
23124 ANS = 0.
23125 IF (X.GT.0.9985) RETURN
23126 IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23127C
23128 IS = S/DELTA+1
23129 IS1 = IS+1
23130 DO 1 L=1,25
23131 KL = L+NDRV*25
23132 F1(L) = GF(I,IS,KL)
23133 F2(L) = GF(I,IS1,KL)
23134 1 CONTINUE
23135 A1 = DT_CKMTFF(X,F1)
23136 A2 = DT_CKMTFF(X,F2)
23137C A1=ALOG(A1)
23138C A2=ALOG(A2)
23139 S1 = (IS-1)*DELTA
23140 S2 = S1+DELTA
23141 ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23142C ANS=EXP(ANS)
23143 RETURN
23144 END
23145C
23146CDECK ID>, DT_CKMTFF
23147 FUNCTION DT_CKMTFF(X,FVL)
23148C**********************************************************************
23149C
23150C LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
23151C FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
23152C NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
23153C IN MAIN ROUTINE.
23154C
23155C**********************************************************************
23156
23157 SAVE
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/
23161C
23162 DT_CKMTFF=0.
23163 DO 1 I=1,NX
23164 IF(X.LT.XGRID(I)) GO TO 2
23165 1 CONTINUE
23166 2 I=I-1
23167 IF(I.EQ.0) THEN
23168 I=I+1
23169 ELSE IF(I.GT.23) THEN
23170 I=23
23171 ENDIF
23172 J=I+1
23173 K=J+1
23174 AXI=LOG(XGRID(I))
23175 BXI=LOG(1.-XGRID(I))
23176 AXJ=LOG(XGRID(J))
23177 BXJ=LOG(1.-XGRID(J))
23178 AXK=LOG(XGRID(K))
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*
23185 $ BXI))/DET
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.)
23189 1RETURN
23190C IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
23191C WRITE(6,2001) X,FVL
23192C 2001 FORMAT(8E12.4)
23193C WRITE(6,2001) ALPHA,BETA,ALOGA,DET
23194C ENDIF
23195 DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
23196 RETURN
23197 END
23198*
23199*===fluini=============================================================*
23200*
23201CDECK ID>, DT_FLUINI
23202 SUBROUTINE DT_FLUINI
23203
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************************************************************************
23209
23210 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23211 SAVE
23212
23213 PARAMETER ( LINP = 5 ,
23214 & LOUT = 6 ,
23215 & LDAT = 9 )
23216
23217 PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
23218
23219 PARAMETER ( A = 0.1D0,
23220 & B = 0.893D0,
23221 & OM = 1.1D0,
23222 & N = 6,
23223 & DX = 0.003D0)
23224
23225* n-n cross section fluctuations
23226 PARAMETER (NBINS = 1000)
23227 COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
23228 DIMENSION FLUSI(NBINS),FLUIX(NBINS)
23229
23230 WRITE(LOUT,1000)
23231 1000 FORMAT(/,1X,'FLUINI: hadronic cross section fluctuations ',
23232 & 'treated')
23233
23234 FLUSU = ZERO
23235 FLUSUU = ZERO
23236
23237 DO 1 I=1,NBINS
23238 X = DBLE(I)*DX
23239 FLUIX(I) = X
23240 FLUS = ((X-B)/(OM*B))**N
23241 IF (FLUS.LE.20.0D0) THEN
23242 FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
23243 ELSE
23244 FLUSI(I) = ZERO
23245 ENDIF
23246 FLUSU = FLUSU+FLUSI(I)
23247 1 CONTINUE
23248 DO 2 I=1,NBINS
23249 FLUSUU = FLUSUU+FLUSI(I)/FLUSU
23250 FLUSI(I) = FLUSUU
23251 2 CONTINUE
23252
23253C WRITE(LOUT,1001)
23254C1001 FORMAT(1X,'FLUCTUATIONS')
23255C CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
23256
23257 DO 3 I=1,NBINS
23258 AF = DBLE(I)*0.001D0
23259 DO 4 J=1,NBINS
23260 IF (AF.LE.FLUSI(J)) THEN
23261 FLUIXX(I) = FLUIX(J)
23262 GOTO 5
23263 ENDIF
23264 4 CONTINUE
23265 5 CONTINUE
23266 3 CONTINUE
23267 FLUIXX(1) = FLUIX(1)
23268 FLUIXX(NBINS) = FLUIX(NBINS)
23269
23270 RETURN
23271 END
23272*
23273*===sigtab=============================================================*
23274*
23275CDECK ID>, DT_SIGTBL
23276 SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
23277
23278************************************************************************
23279* This version dated 18.11.95 is written by S. Roesler *
23280************************************************************************
23281
23282 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23283 SAVE
23284
23285 PARAMETER ( LINP = 5 ,
23286 & LOUT = 6 ,
23287 & LDAT = 9 )
23288
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)
23292
23293 LOGICAL LINIT
23294
23295* particle properties (BAMJET index convention)
23296 CHARACTER*8 ANAME
23297 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
23298 & IICH(210),IIBAR(210),K1(210),K2(210)
23299
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,
23303 & 0, 0, 5/
23304 DATA LINIT /.FALSE./
23305
23306* precalculation and tabulation of elastic cross sections
23307 IF (ABS(MODE).EQ.1) THEN
23308 IF (MODE.EQ.1)
23309 & OPEN(LDAT,FILE='sigtab.out',STATUS='UNKNOWN')
23310 PLABLX = LOG10(PLO)
23311 PLABHX = LOG10(PHI)
23312 DPLAB = (PLABHX-PLABLX)/DBLE(NBINS)
23313 DO 1 I=1,NBINS+1
23314 PLAB = PLABLX+DBLE(I-1)*DPLAB
23315 PLAB = 10**PLAB
23316 DO 2 IPROJ=1,23
23317 IDX = IDSIG(IPROJ)
23318 IF (IDX.GT.0) THEN
23319C CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
23320C CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
23321 DUMZER = ZERO
23322 CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
23323 CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
23324 ENDIF
23325 2 CONTINUE
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)
23330 ENDIF
23331 1 CONTINUE
23332 IF (MODE.EQ.1) CLOSE(LDAT)
23333 LINIT = .TRUE.
23334 ELSE
23335 SIGE = -ONE
23336 IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
23337 & .AND.(PTOT.LE.PHI) ) THEN
23338 IDX = IDSIG(JP)
23339 IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
23340 PLABX = LOG10(PTOT)
23341 IF (PLABX.LE.PLABLX) THEN
23342 I1 = 1
23343 I2 = 1
23344 ELSEIF (PLABX.GE.PLABHX) THEN
23345 I1 = NBINS+1
23346 I2 = NBINS+1
23347 ELSE
23348 I1 = INT((PLABX-PLABLX)/DPLAB)+1
23349 I2 = I1+1
23350 ENDIF
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)
23356 ELSE
23357 RATX = ZERO
23358 ENDIF
23359 IF (JT.EQ.1) THEN
23360 SIG1 = SIGEP(IDX,I1)
23361 SIG2 = SIGEP(IDX,I2)
23362 ELSE
23363 SIG1 = SIGEN(IDX,I1)
23364 SIG2 = SIGEN(IDX,I2)
23365 ENDIF
23366 SIGE = SIG1+RATX*(SIG2-SIG1)
23367 ENDIF
23368 ENDIF
23369 ENDIF
23370
23371 RETURN
23372 END
23373*
23374*===xstabl=============================================================*
23375*
23376CDECK ID>, DT_XSTABL
23377 SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
23378
23379 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23380 SAVE
23381
23382 PARAMETER ( LINP = 5 ,
23383 & LOUT = 6 ,
23384 & LDAT = 9 )
23385
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
23389
23390* particle properties (BAMJET index convention)
23391 CHARACTER*8 ANAME
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
23396
23397 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
23398
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),
23412 & NCOMPO,IEMUL
23413
23414 DIMENSION WHAT(6)
23415
23416 LLAB = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
23417 ELO = ABS(WHAT(1))
23418 EHI = ABS(WHAT(2))
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)
23423 IF (LELOG) THEN
23424 AELO = LOG10(ELO)
23425 AEHI = LOG10(EHI)
23426 ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
23427 ENDIF
23428 Q2LO = WHAT(4)
23429 Q2HI = WHAT(5)
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)
23434 IF (LQLOG) THEN
23435 AQ2LO = LOG10(Q2LO)
23436 AQ2HI = LOG10(Q2HI)
23437 ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
23438 ENDIF
23439
23440 IF ( ELO.EQ. EHI) NEBINS = 0
23441 IF (Q2LO.EQ.Q2HI) NQBINS = 0
23442
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,/)
23448
23449C 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
23453 SUMFRA = ZERO
23454 DO 10 I=1,NCOMPO
23455 SUMFRA = SUMFRA+EMUFRA(I)
23456 10 CONTINUE
23457 IF (SUMFRA.GT.ZERO) THEN
23458 DO 11 I=1,NCOMPO
23459 EMUFRA(I) = EMUFRA(I)/SUMFRA
23460 11 CONTINUE
23461 ENDIF
23462 ENDIF
23463C ELSE
23464C WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
23465C ENDIF
23466 DO 1 I=1,NEBINS+1
23467 IF (LELOG) THEN
23468 E = 10**(AELO+DBLE(I-1)*ADEBIN)
23469 ELSE
23470 E = ELO+DBLE(I-1)*DEBINS
23471 ENDIF
23472 DO 2 J=1,NQBINS+1
23473 IF (LQLOG) THEN
23474 Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
23475 ELSE
23476 Q2 = Q2LO+DBLE(J-1)*DQBINS
23477 ENDIF
23478c IF (IJPROJ.NE.7) THEN
23479 IF (LLAB) THEN
23480 PLAB = ZERO
23481 ECM = ZERO
23482 CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
23483 ELSE
23484 ECM = E
23485 ENDIF
23486 XI = ZERO
23487 Q2I = ZERO
23488 IF (IJPROJ.EQ.7) Q2I = Q2
23489 IF (NCOMPO.GT.0) THEN
23490 DO 20 IC=1,NCOMPO
23491 IIT = IEMUMA(IC)
23492 CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
23493 20 CONTINUE
23494 ELSE
23495 CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
23496C CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
23497 ENDIF
23498 IF (NCOMPO.GT.0) THEN
23499 XTOT = ZERO
23500 ETOT = ZERO
23501 XELA = ZERO
23502 EELA = ZERO
23503 XQEP = ZERO
23504 EQEP = ZERO
23505 XQET = ZERO
23506 EQET = ZERO
23507 XQE2 = ZERO
23508 EQE2 = ZERO
23509 XPRO = ZERO
23510 EPRO = ZERO
23511 XPRO1= ZERO
23512 XDEL = ZERO
23513 EDEL = ZERO
23514 XDQE = ZERO
23515 EDQE = ZERO
23516 DO 21 IC=1,NCOMPO
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)
23535 & -XSQE2(1,1,IC)
23536 XPRO1= XPRO1+EMUFRA(IC)*YPRO
23537 21 CONTINUE
23538 ETOT = SQRT(ETOT)
23539 EELA = SQRT(EELA)
23540 EQEP = SQRT(EQEP)
23541 EQET = SQRT(EQET)
23542 EQE2 = SQRT(EQE2)
23543 EPRO = SQRT(EPRO)
23544 EDEL = SQRT(EDEL)
23545 EDQE = SQRT(EDQE)
23546 WRITE(LOUT,'(8E9.3)')
23547 & E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
23548C WRITE(LOUT,'(4E9.3)')
23549C & E,XDEL,XDQE,XDEL+XDQE
23550 ELSE
23551 WRITE(LOUT,'(11E10.3)')
23552 & E,
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)
23558C WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
23559C & XSDEL(1,1,1)+XSDQE(1,1,1)
23560 ENDIF
23561c ELSE
23562c IF (LLAB) THEN
23563c IF (IT.GT.1) THEN
23564c IF (IXSQEL.EQ.0) THEN
23565cC CALL DT_SIGGA(IT, Q2, E,ZERO,ZERO,
23566cC CALL DT_SIGGA(IT, E,Q2,ZERO,ZERO,
23567c CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
23568c & STOT,ETOT,SIN,EIN,STOT0)
23569c IF (IRATIO.EQ.1) THEN
23570c CALL DT_SIGGP( Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
23571cC CALL DT_SIGGP( E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
23572cC CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
23573c*!! save cross sections
23574c STOTA = STOT
23575c ETOTA = ETOT
23576c STOTP = STGP
23577c*!!
23578c STOT = STOT/(DBLE(IT)*STGP)
23579c SIN = SIN/(DBLE(IT)*SIGP)
23580c STOT0 = STGP
23581c ETOT = ZERO
23582c EIN = ZERO
23583c ENDIF
23584c ELSE
23585c WRITE(LOUT,*)
23586c & ' XSTABL: qel. xs. not implemented for nuclei'
23587c STOP
23588c ENDIF
23589c ELSE
23590c ETOT = ZERO
23591c EIN = ZERO
23592c STOT0= ZERO
23593c IF (IXSQEL.EQ.0) THEN
23594c CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
23595c ELSE
23596c SIN = ZERO
23597c CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
23598c ENDIF
23599c ENDIF
23600c ELSE
23601c IF (IT.GT.1) THEN
23602c IF (IXSQEL.EQ.0) THEN
23603c CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
23604c & STOT,ETOT,SIN,EIN,STOT0)
23605c IF (IRATIO.EQ.1) THEN
23606c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
23607c*!! save cross sections
23608c STOTA = STOT
23609c ETOTA = ETOT
23610c STOTP = STGP
23611c*!!
23612c STOT = STOT/(DBLE(IT)*STGP)
23613c SIN = SIN/(DBLE(IT)*SIGP)
23614c STOT0 = STGP
23615c ETOT = ZERO
23616c EIN = ZERO
23617c ENDIF
23618c ELSE
23619c WRITE(LOUT,*)
23620c & ' XSTABL: qel. xs. not implemented for nuclei'
23621c STOP
23622c ENDIF
23623c ELSE
23624c ETOT = ZERO
23625c EIN = ZERO
23626c STOT0= ZERO
23627c IF (IXSQEL.EQ.0) THEN
23628c CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
23629c ELSE
23630c SIN = ZERO
23631c CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
23632c ENDIF
23633c ENDIF
23634c ENDIF
23635cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
23636cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
23637cC WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
23638c WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
23639c ENDIF
23640 2 CONTINUE
23641 1 CONTINUE
23642
23643 RETURN
23644 END
23645*
23646*===testxs=============================================================*
23647*
23648CDECK ID>, DT_TESTXS
23649 SUBROUTINE DT_TESTXS
23650
23651 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23652 SAVE
23653
23654 DIMENSION XSTOT(26,2),XSELA(26,2)
23655
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')
23660 DUMECM = 0.0D0
23661 PLABL = 0.01D0
23662 PLABH = 10000.0D0
23663 NBINS = 120
23664 APLABL = LOG10(PLABL)
23665 APLABH = LOG10(PLABH)
23666 ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
23667 DO 1 I=1,NBINS+1
23668 ADP = APLABL+DBLE(I-1)*ADPLAB
23669 P = 10.0D0**ADP
23670 DO 2 J=1,26
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))
23673 2 CONTINUE
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)
23678 1 CONTINUE
23679 1000 FORMAT(F8.3,26F9.3)
23680
23681 RETURN
23682 END
23683************************************************************************
23684* *
23685* DTUNUC 2.0: library routines *
23686* processed by S. Roesler, 6.5.95 *
23687* *
23688************************************************************************
23689*
23690* 1) Handling of parton momenta
23691* SUBROUTINE MASHEL
23692* SUBROUTINE DFERMI
23693*
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
23703*
23704* 3) Energy-momentum and quantum number conservation check routines
23705* SUBROUTINE EMC1
23706* SUBROUTINE EMC2
23707* SUBROUTINE EVTEMC
23708* SUBROUTINE EVTFLC
23709* SUBROUTINE EVTCHG
23710*
23711* 4) Transformations
23712* SUBROUTINE LTINI
23713* SUBROUTINE LTRANS
23714* SUBROUTINE LTNUC
23715* SUBROUTINE DALTRA
23716* SUBROUTINE DTRAFO
23717* SUBROUTINE STTRAN
23718* SUBROUTINE MYTRAN
23719* SUBROUTINE LT2LAO
23720* SUBROUTINE LT2LAB
23721*
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
23731* SUBROUTINE DPOLI
23732* SUBROUTINE DSFECF
23733* SUBROUTINE RACO
23734*
23735* 6) Special functions, algorithms and service routines
23736* DOUBLE PRECISION FUNCTION YLAMB
23737* SUBROUTINE SORT
23738* SUBROUTINE SORT1
23739* SUBROUTINE DT_XTIME
23740*
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
23747*
23748************************************************************************
23749* *
23750* 1) Handling of parton momenta *
23751* *
23752************************************************************************
23753*
23754*===mashel=============================================================*
23755*
23756CDECK ID>, DT_MASHEL
23757 SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
23758
23759************************************************************************
23760* *
23761* rescaling of momenta of two partons to put both *
23762* on mass shell *
23763* *
23764* input: PA1,PA2 input momentum vectors *
23765* XM1,2 desired masses of particles afterwards *
23766* P1,P2 changed momentum vectors *
23767* *
23768* The original version is written by R. Engel. *
23769* This version dated 12.12.94 is modified by S. Roesler. *
23770************************************************************************
23771
23772 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23773 SAVE
23774
23775 PARAMETER ( LINP = 5 ,
23776 & LOUT = 6 ,
23777 & LDAT = 9 )
23778
23779 PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
23780
23781 DIMENSION PA1(4),PA2(4),P1(4),P2(4)
23782
23783 IREJ = 0
23784
23785* Lorentz transformation into system CMS
23786 PX = PA1(1)+PA2(1)
23787 PY = PA1(2)+PA2(2)
23788 PZ = PA1(3)+PA2(3)
23789 EE = PA1(4)+PA2(4)
23790 XPTOT = SQRT(PX**2+PY**2+PZ**2)
23791 XMS = (EE-XPTOT)*(EE+XPTOT)
23792 IF(XMS.LT.(XM1+XM2)**2) THEN
23793C WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
23794 GOTO 9999
23795 ENDIF
23796 XMS = SQRT(XMS)
23797 BGX = PX/XMS
23798 BGY = PY/XMS
23799 BGZ = PZ/XMS
23800 GAM = EE/XMS
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))
23803* rotation angles
23804 COD = P1(3)/PTOT1
23805C SID = SQRT((ONE-COD)*(ONE+COD))
23806 PPT = SQRT(P1(1)**2+P1(2)**2)
23807 SID = PPT/PTOT1
23808 COF = ONE
23809 SIF = ZERO
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)
23814 COF = COF/ANORF
23815 SIF = SIF/ANORF
23816 ENDIF
23817* new CM momentum and energies (for masses XM1,XM2)
23818 XM12 = SIGN(XM1**2,XM1)
23819 XM22 = SIGN(XM2**2,XM2)
23820 SS = XMS**2
23821 PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
23822 EE1 = SQRT(XM12+PCMP**2)
23823 EE2 = XMS-EE1
23824* back rotation
23825 MODE = 1
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
23832 DEL = XMS*0.0001D0
23833 IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
23834 IDEV = 1
23835 ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
23836 IDEV = 2
23837 ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
23838 IDEV = 3
23839 ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
23840 IDEV = 4
23841 ELSE
23842 IDEV = 0
23843 ENDIF
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)
23853 ENDIF
23854 RETURN
23855
23856 9999 CONTINUE
23857 IREJ = 1
23858 RETURN
23859 END
23860*
23861*===dfermi=============================================================*
23862*
23863CDECK ID>, DT_DFERMI
23864 SUBROUTINE DT_DFERMI(GPART)
23865
23866************************************************************************
23867* Find largest of three random numbers. *
23868************************************************************************
23869
23870 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23871 SAVE
23872
23873 DIMENSION G(3)
23874
23875 DO 10 I=1,3
23876 G(I)=DT_RNDM(GPART)
23877 10 CONTINUE
23878 IF (G(3).LT.G(2)) GOTO 40
23879 IF (G(3).LT.G(1)) GOTO 30
23880 GPART = G(3)
23881 20 RETURN
23882 30 GPART = G(1)
23883 GOTO 20
23884 40 IF (G(2).LT.G(1)) GOTO 30
23885 GPART = G(2)
23886 GOTO 20
23887
23888 END
23889
23890************************************************************************
23891* *
23892* 2) Handling of parton flavors and particle indices *
23893* *
23894************************************************************************
23895*
23896*===ipdg2b=============================================================*
23897*
23898CDECK ID>, IDT_IPDG2B
23899 INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
23900
23901************************************************************************
23902* *
23903* conversion of quark numbering scheme *
23904* *
23905* input: PDG parton numbering *
23906* for diquarks: NN number of the constituent quark *
23907* (e.g. ID=2301,NN=1 -> ICONV2=1) *
23908* *
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 *
23914* *
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************************************************************************
23918
23919 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23920 SAVE
23921
23922 PARAMETER ( LINP = 5 ,
23923 & LOUT = 6 ,
23924 & LDAT = 9 )
23925
23926 IDA = ABS(ID)
23927* diquarks
23928 IF (IDA.GT.6) THEN
23929 KF = 3
23930 IF (IDA.GE.1000) KF = 4
23931 IDA = IDA/(10**(KF-NN))
23932 IDA = MOD(IDA,10)
23933 ENDIF
23934* exchange up and dn quarks
23935 IF (IDA.EQ.1) THEN
23936 IDA = 2
23937 ELSEIF (IDA.EQ.2) THEN
23938 IDA = 1
23939 ENDIF
23940* antiquarks
23941 IF (ID.LT.0) THEN
23942 IF (MODE.EQ.1) THEN
23943 IDA = IDA+6
23944 ELSE
23945 IDA = -IDA
23946 ENDIF
23947 ENDIF
23948 IDT_IPDG2B = IDA
23949
23950 RETURN
23951 END
23952*
23953*===ib2pdg=============================================================*
23954*
23955CDECK ID>, IDT_IB2PDG
23956 INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
23957
23958************************************************************************
23959* *
23960* conversion of quark numbering scheme *
23961* *
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 *
23967* *
23968* output: PDG parton numbering *
23969* *
23970* This version dated 13.12.94 is written by S. Roesler. *
23971************************************************************************
23972
23973 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
23974 SAVE
23975
23976 PARAMETER ( LINP = 5 ,
23977 & LOUT = 6 ,
23978 & LDAT = 9 )
23979
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/
23985
23986 IDA = ID1
23987 IDB = ID2
23988 IF (MODE.EQ.1) THEN
23989 IF (ID1.GT.6) IDA = -(ID1-6)
23990 IF (ID2.GT.6) IDB = -(ID2-6)
23991 ENDIF
23992 IF (ID2.EQ.0) THEN
23993 IDT_IB2PDG = IHKKQ(IDA)
23994 ELSE
23995 IDT_IB2PDG = IHKKQQ(IDA,IDB)
23996 ENDIF
23997
23998 RETURN
23999 END
24000*
24001*===ipdgqu=============================================================*
24002*
24003CDECK ID>, IDT_IQUARK
24004 INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
24005
24006************************************************************************
24007* *
24008* quark contents according to PDG conventions *
24009* (random selection in case of quark mixing) *
24010* *
24011* input: IDBAMJ BAMJET particle code *
24012* K 1..3 quark number *
24013* *
24014* output: 1 d (anti --> neg.) *
24015* 2 u *
24016* 3 s *
24017* 4 c *
24018* *
24019* This version written by R. Engel. *
24020************************************************************************
24021
24022 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24023 SAVE
24024
24025 IQ = IDT_IBJQUA(K,IDBAMJ)
24026* quark-antiquark
24027 IF (IQ.GT.6) THEN
24028 IQ = 6-IQ
24029 ENDIF
24030* exchange of up and down
24031 IF (ABS(IQ).EQ.1) THEN
24032 IQ = SIGN(2,IQ)
24033 ELSEIF (ABS(IQ).EQ.2) THEN
24034 IQ = SIGN(1,IQ)
24035 ENDIF
24036 IDT_IQUARK = IQ
24037
24038 RETURN
24039 END
24040*
24041*===ibamq==============================================================*
24042*
24043CDECK ID>, IDT_IBJQUA
24044 INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
24045
24046************************************************************************
24047* *
24048* quark contents according to BAMJET conventions *
24049* (random selection in case of quark mixing) *
24050* *
24051* input: IDBAMJ BAMJET particle code *
24052* K 1..3 quark number *
24053* *
24054* output: 1 u 7 u bar *
24055* 2 d 8 d bar *
24056* 3 s 9 s bar *
24057* 4 c 10 c bar *
24058* *
24059* This version written by R. Engel. *
24060************************************************************************
24061
24062 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24063 SAVE
24064
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,
24070*sr 10.1.94
24071C & 0, 0, 0, 0, 0, 0, 0, 0, 0,
24072 & 0, 0, 0, 0, 0, 0, 3, 8, 0,
24073*
24074 & 1, 8, 0, 2, 7, 0, 1, 9, 0,
24075*sr 10.1.94
24076C & 3, 7, 0, 0, 0, 0, 0, 0, 0,
24077 & 3, 7, 0, 3, 1, 2, 9, 7, 8,
24078*sr 10.1.94
24079C & 0, 0, 0, 2, 2, 3, 1, 1, 3,
24080 & 2, 9, 0, 2, 2, 3, 1, 1, 3,
24081*
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 /
24151 DATA IDOLD /0/
24152
24153 ONE = 1.0D0
24154 IF (ITAB(1,IDBAMJ).LE.200) THEN
24155 ID = ITAB(K,IDBAMJ)
24156 ELSE
24157 IF(IDOLD.NE.IDBAMJ) THEN
24158 IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
24159 & DT_RNDM(ONE)+ITAB(1,IDBAMJ))
24160 ELSE
24161 IDOLD = 0
24162 ENDIF
24163 ID = ITAB(K,IT)
24164 ENDIF
24165 IDOLD = IDBAMJ
24166 IDT_IBJQUA = ID
24167
24168 RETURN
24169 END
24170*
24171*===icihad=============================================================*
24172*
24173CDECK ID>, IDT_ICIHAD
24174 INTEGER FUNCTION IDT_ICIHAD(MCIND)
24175
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************************************************************************
24181
24182 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24183 SAVE
24184
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),
24188 & IAMCIN(210)
24189
24190 IDT_ICIHAD = 0
24191 KPDG = ABS(MCIND)
24192 IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
24193 IF (MCIND.LT.0) THEN
24194 JSIGN = 1
24195 ELSE
24196 JSIGN = 2
24197 ENDIF
24198 IF (KPDG.GE.10000) THEN
24199 DO 1 I=1,19
24200 IDT_ICIHAD = IBAM5(JSIGN,I)
24201 IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
24202 IDT_ICIHAD = 0
24203 1 CONTINUE
24204 ELSEIF (KPDG.GE.1000) THEN
24205 DO 2 I=1,29
24206 IDT_ICIHAD = IBAM4(JSIGN,I)
24207 IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
24208 IDT_ICIHAD = 0
24209 2 CONTINUE
24210 ELSEIF (KPDG.GE.100) THEN
24211 DO 3 I=1,22
24212 IDT_ICIHAD = IBAM3(JSIGN,I)
24213 IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
24214 IDT_ICIHAD = 0
24215 3 CONTINUE
24216 ELSEIF (KPDG.GE.10) THEN
24217 DO 4 I=1,7
24218 IDT_ICIHAD = IBAM2(JSIGN,I)
24219 IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
24220 IDT_ICIHAD = 0
24221 4 CONTINUE
24222 ENDIF
24223 5 CONTINUE
24224
24225 RETURN
24226 END
24227*
24228*===ipdgha=============================================================*
24229*
24230CDECK ID>, IDT_IPDGHA
24231 INTEGER FUNCTION IDT_IPDGHA(MCIND)
24232
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************************************************************************
24238
24239 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24240 SAVE
24241
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),
24245 & IAMCIN(210)
24246
24247 IDT_IPDGHA = IAMCIN(MCIND)
24248
24249 RETURN
24250 END
24251*
24252*===flahad=============================================================*
24253*
24254CDECK ID>, DT_FLAHAD
24255 SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
24256
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************************************************************************
24266
24267 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24268 SAVE
24269
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)
24274
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/
24277
24278 ONE = 1.0D0
24279 IF (ID.EQ.7) THEN
24280* photon (charge dependent flavour sampling)
24281 K = INT(DT_RNDM(ONE)*6.D0+1.D0)
24282 IF (K.LE.4) THEN
24283 IF1 = 2
24284 IF2 = -2
24285 ELSE IF(K.EQ.5) THEN
24286 IF1 = 1
24287 IF2 = -1
24288 ELSE
24289 IF1 = 3
24290 IF2 = -3
24291 ENDIF
24292 IF(DT_RNDM(ONE).LT.0.5D0) THEN
24293 K = IF1
24294 IF1 = IF2
24295 IF2 = K
24296 ENDIF
24297 IF3 = 0
24298 ELSE
24299* hadron
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
24305 IF1 = IF3
24306 IF3 = 0
24307 ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
24308 IF2 = IF3
24309 IF3 = 0
24310 ENDIF
24311 ENDIF
24312
24313 RETURN
24314 END
24315*
24316*===mchad==============================================================*
24317*
24318CDECK ID>, IDT_MCHAD
24319 INTEGER FUNCTION IDT_MCHAD(ITDTU)
24320
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************************************************************************
24325
24326 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24327 SAVE
24328
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/
24337
24338 IDT_MCHAD = ITRANS(ITDTU)
24339
24340 RETURN
24341 END
24342
24343************************************************************************
24344* *
24345* 3) Energy-momentum and quantum number conservation check routines *
24346* *
24347************************************************************************
24348*
24349*===emc1===============================================================*
24350*
24351CDECK ID>, DT_EMC1
24352 SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
24353
24354************************************************************************
24355* This version dated 15.12.94 is written by S. Roesler *
24356************************************************************************
24357
24358 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24359 SAVE
24360
24361 PARAMETER ( LINP = 5 ,
24362 & LOUT = 6 ,
24363 & LDAT = 9 )
24364
24365 PARAMETER (TINY10=1.0D-10)
24366
24367 DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
24368
24369 IREJ = 0
24370
24371 IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
24372 & WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
24373
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)
24379 ENDIF
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)
24388 ENDIF
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)
24392 ENDIF
24393
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
24397 ENDIF
24398 RETURN
24399
24400 9999 CONTINUE
24401 IREJ = 1
24402 RETURN
24403 END
24404*
24405*===emc2===============================================================*
24406*
24407CDECK ID>, DT_EMC2
24408 SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
24409 & MODE,IPOS,IREJ)
24410
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************************************************************************
24419
24420 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24421 SAVE
24422
24423 PARAMETER ( LINP = 5 ,
24424 & LOUT = 6 ,
24425 & LDAT = 9 )
24426
24427 PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
24428
24429* event history
24430
24431 PARAMETER (NMXHKK=200000)
24432
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),
24439 & IHIST(2,NMXHKK)
24440
24441 IREJ = 0
24442 IREJ1 = 0
24443 IREJ2 = 0
24444 IREJ3 = 0
24445
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)
24451 DO 1 I=1,NHKK
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)
24456 & .OR.(MODE.EQ.5))
24457 & CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
24458 & 2,IDUM,IDUM)
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)
24463 ENDIF
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)
24468 & .OR.(MODE.EQ.5))
24469 & CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
24470 & 2,IDUM,IDUM)
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)
24475 ENDIF
24476 1 CONTINUE
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
24483
24484 RETURN
24485
24486 9999 CONTINUE
24487 IREJ = 1
24488 RETURN
24489 END
24490*
24491*===evtemc=============================================================*
24492*
24493CDECK ID>, DT_EVTEMC
24494 SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
24495
24496************************************************************************
24497* This version dated 13.12.94 is written by S. Roesler *
24498************************************************************************
24499
24500 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24501 SAVE
24502
24503 PARAMETER ( LINP = 5 ,
24504 & LOUT = 6 ,
24505 & LDAT = 9 )
24506
24507 PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
24508 & ZERO=0.0D0)
24509
24510* event history
24511
24512 PARAMETER (NMXHKK=200000)
24513
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
24521
24522 IREJ = 0
24523
24524 MODE = IMODE
24525 CHKLEV = TINY10
24526 IF (MODE.EQ.4) THEN
24527 CHKLEV = TINY2
24528 MODE = 3
24529 ELSEIF (MODE.EQ.5) THEN
24530 CHKLEV = TINY1
24531 MODE = 3
24532 ELSEIF (MODE.EQ.-1) THEN
24533 CHKLEV = EIO
24534 MODE = 3
24535 ENDIF
24536
24537 IF (ABS(MODE).EQ.3) THEN
24538 PXDEV = PX
24539 PYDEV = PY
24540 PZDEV = PZ
24541 EDEV = E
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
24549 PX = 0.0D0
24550 PY = 0.0D0
24551 PZ = 0.0D0
24552 E = 0.0D0
24553 GOTO 9999
24554 ENDIF
24555 PX = 0.0D0
24556 PY = 0.0D0
24557 PZ = 0.0D0
24558 E = 0.0D0
24559 RETURN
24560 ENDIF
24561
24562 IF (MODE.EQ.1) THEN
24563 PX = 0.0D0
24564 PY = 0.0D0
24565 PZ = 0.0D0
24566 E = 0.0D0
24567 ENDIF
24568
24569 PX = PX+PXIO
24570 PY = PY+PYIO
24571 PZ = PZ+PZIO
24572 E = E+EIO
24573
24574 RETURN
24575
24576 9999 CONTINUE
24577 IREJ = 1
24578 RETURN
24579 END
24580*
24581*===evtflc=============================================================*
24582*
24583CDECK ID>, DT_EVTFLC
24584 SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
24585
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 *
24594* = 2 add 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************************************************************************
24601
24602 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24603 SAVE
24604
24605 PARAMETER ( LINP = 5 ,
24606 & LOUT = 6 ,
24607 & LDAT = 9 )
24608
24609 PARAMETER (TINY10=1.0D-10)
24610
24611 IREJ = 0
24612
24613 IF (MODE.EQ.3) THEN
24614 IF (IFL.NE.0) THEN
24615 WRITE(LOUT,'(1X,A,I3,A,I3)')
24616 & 'EVTFLC: flavor-conservation failure at pos. ',IPOS,
24617 & ' ! IFL = ',IFL
24618 IFL = 0
24619 GOTO 9999
24620 ENDIF
24621 IFL = 0
24622 RETURN
24623 ENDIF
24624
24625 IF (MODE.EQ.1) IFL = 0
24626 IF (ID.EQ.0) RETURN
24627
24628 IF (ID1.EQ.1) THEN
24629 IDD = ABS(ID)
24630 NQ = 1
24631 IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
24632 IF (IDD.GE.1000) NQ = 3
24633 DO 1 I=1,NQ
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)
24639 ENDIF
24640 IF (MODE.GT.0) THEN
24641 IFL = IFL+IFBAM
24642 ELSE
24643 IFL = IFL-IFBAM
24644 ENDIF
24645 1 CONTINUE
24646 RETURN
24647 ENDIF
24648
24649 IDD = ID
24650 IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
24651 IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
24652 DO 2 I=1,3
24653 IF (MODE.GT.0) THEN
24654 IFL = IFL+IDT_IQUARK(I,IDD)
24655 ELSE
24656 IFL = IFL-IDT_IQUARK(I,IDD)
24657 ENDIF
24658 2 CONTINUE
24659 ENDIF
24660 RETURN
24661
24662 9999 CONTINUE
24663 IREJ = 1
24664 RETURN
24665 END
24666*
24667*===evtchg=============================================================*
24668*
24669CDECK ID>, DT_EVTCHG
24670 SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
24671
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************************************************************************
24684
24685 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24686 SAVE
24687
24688 PARAMETER ( LINP = 5 ,
24689 & LOUT = 6 ,
24690 & LDAT = 9 )
24691
24692* event history
24693
24694 PARAMETER (NMXHKK=200000)
24695
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)
24700 CHARACTER*8 ANAME
24701 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24702 & IICH(210),IIBAR(210),K1(210),K2(210)
24703
24704 IREJ = 0
24705
24706 IF (MODE.EQ.1) THEN
24707 ICH = 0
24708 IBAR = 0
24709 RETURN
24710 ENDIF
24711
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
24717 ICH = 0
24718 IBAR = 0
24719 GOTO 9999
24720 ENDIF
24721 ICH = 0
24722 IBAR = 0
24723 RETURN
24724 ENDIF
24725
24726 IF (ID.EQ.0) RETURN
24727
24728 IDD = IDT_ICIHAD(ID)
24729* modification 21.1.01: use intrinsic phojet-functions to determine charge
24730* and baryon number
24731C IF (IDD.GT.0) THEN
24732C IF (MODE.EQ.2) THEN
24733C ICH = ICH+IICH(IDD)
24734C IBAR = IBAR+IIBAR(IDD)
24735C ELSEIF (MODE.EQ.-2) THEN
24736C ICH = ICH-IICH(IDD)
24737C IBAR = IBAR-IIBAR(IDD)
24738C ENDIF
24739C ELSE
24740C WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
24741C CALL DT_EVTOUT(4)
24742C STOP
24743C ENDIF
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
24750 ENDIF
24751
24752 RETURN
24753
24754 9999 CONTINUE
24755 IREJ = 1
24756 RETURN
24757 END
24758
24759************************************************************************
24760* *
24761* 4) Transformations *
24762* *
24763************************************************************************
24764*
24765*===ltini==============================================================*
24766*
24767CDECK ID>, DT_LTINI
24768 SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
24769
24770************************************************************************
24771* Initializations of Lorentz-transformations, calculation of Lorentz- *
24772* parameters. *
24773* This version dated 13.11.95 is written by S. Roesler. *
24774************************************************************************
24775
24776 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24777 SAVE
24778
24779 PARAMETER ( LINP = 5 ,
24780 & LOUT = 6 ,
24781 & LDAT = 9 )
24782
24783 PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
24784 & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
24785
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)
24792 CHARACTER*8 ANAME
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
24796 CHARACTER*8 CMODEL
24797 LOGICAL LPHOIN
24798 COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
24799
24800 Q2 = VIRT
24801 IDP = IDPR
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
24807 IDP = 7
24808 Q2 = ZERO
24809 ENDIF
24810 ENDIF
24811 IDT = IDTA
24812 EPN = EPN0
24813 PPN = PPN0
24814 ECM = ECM0
24815 AMP = AAM(IDP)-SQRT(ABS(Q2))
24816 AMT = AAM(IDT)
24817 AMP2 = SIGN(AMP**2,AMP)
24818 AMT2 = AMT**2
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))
24823 ELSE
24824 PPN = SQRT(EPN**2-AMP2)
24825 ENDIF
24826 ELSE
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))
24832 ELSE
24833 PPN = SQRT(EPN**2-AMP2)
24834 ENDIF
24835 ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
24836 IF (AMP2.GT.ZERO) THEN
24837 EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
24838 ELSE
24839 EPN = SQRT(PPN**2+AMP2)
24840 ENDIF
24841 ENDIF
24842 ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
24843 ENDIF
24844 UMO = ECM
24845 EPROJ = EPN
24846 PPROJ = PPN
24847 IF (AMP2.GT.ZERO) THEN
24848 ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
24849 PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
24850 ELSE
24851 ETARG = TINY10
24852 PTARG = TINY10
24853 ENDIF
24854* photon-projectiles (get momentum in cm-frame for virtuality Q^2)
24855 IF (IDP.EQ.7) THEN
24856 PGAMM(1) = ZERO
24857 PGAMM(2) = ZERO
24858 AMGAM = AMP
24859 AMGAM2 = AMP2
24860 IF (ECM0.GT.ZERO) THEN
24861 S = ECM0**2
24862 ELSE
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)
24867 ENDIF
24868 ENDIF
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
24873 PNUCL(1) = ZERO
24874 PNUCL(2) = ZERO
24875 PNUCL(3) = -PGAMM(3)
24876 PNUCL(4) = SQRT(S)-PGAMM(4)
24877 ENDIF
24878 ENDIF
24879 IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
24880 & (IDPR.EQ.10).OR.(IDPR.EQ.11)) THEN
24881 PLEPT0(1) = ZERO
24882 PLEPT0(2) = ZERO
24883* neglect lepton masses
24884C AMLPT2 = AAM(IDPR)**2
24885 AMLPT2 = ZERO
24886*
24887 IF (ECM0.GT.ZERO) THEN
24888 S = ECM0**2
24889 ELSE
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)
24894 ENDIF
24895 ENDIF
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)
24899 PNUCL(1) = ZERO
24900 PNUCL(2) = ZERO
24901 PNUCL(3) = -PLEPT0(3)
24902 PNUCL(4) = SQRT(S)-PLEPT0(4)
24903 ENDIF
24904* Lorentz-parameter for transformation Lab. - projectile rest system
24905 IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
24906 GALAB = TINY10
24907 BGLAB = TINY10
24908 BLAB = TINY10
24909 ELSE
24910 GALAB = EPROJ/AMP
24911 BGLAB = PPROJ/AMP
24912 BLAB = BGLAB/GALAB
24913 ENDIF
24914* Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
24915 IF (IDP.EQ.7) THEN
24916 GACMS(1) = TINY10
24917 BGCMS(1) = TINY10
24918 ELSE
24919 GACMS(1) = (ETARG+AMP)/UMO
24920 BGCMS(1) = PTARG/UMO
24921 ENDIF
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
24926
24927 EPN0 = EPN
24928 PPN0 = PPN
24929 ECM0 = ECM
24930
24931 RETURN
24932 END
24933*
24934*===ltrans=============================================================*
24935*
24936CDECK ID>, DT_LTRANS
24937 SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
24938
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************************************************************************
24946
24947 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24948 SAVE
24949
24950 PARAMETER ( LINP = 5 ,
24951 & LOUT = 6 ,
24952 & LDAT = 9 )
24953
24954 PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
24955
24956 PARAMETER (SQTINF=1.0D+15)
24957
24958* particle properties (BAMJET index convention)
24959 CHARACTER*8 ANAME
24960 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24961 & IICH(210),IIBAR(210),K1(210),K2(210)
24962
24963 PXO = PXI
24964 PYO = PYI
24965 CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
24966
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))
24974 PEO = PEO+DELTA
24975 PO1 = PO -DELTA
24976 PXO = PXO*PO1/PO
24977 PYO = PYO*PO1/PO
24978 PZO = PZO*PO1/PO
24979C WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
24980 ENDIF
24981
24982 RETURN
24983 END
24984*
24985*===ltnuc==============================================================*
24986*
24987CDECK ID>, DT_LTNUC
24988 SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
24989
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************************************************************************
25001
25002 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25003 SAVE
25004
25005 PARAMETER ( LINP = 5 ,
25006 & LOUT = 6 ,
25007 & LDAT = 9 )
25008
25009 PARAMETER (ZERO=0.0D0)
25010
25011* Lorentz-parameters of the current interaction
25012 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25013 & UMO,PPCM,EPROJ,PPROJ
25014
25015 BDUM1 = ZERO
25016 BDUM2 = ZERO
25017 PDUM1 = ZERO
25018 PDUM2 = ZERO
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)
25031 ELSE
25032 WRITE(LOUT,1000) MODE
25033 1000 FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
25034 EOUT = EIN
25035 POUT = PIN
25036 ENDIF
25037
25038 RETURN
25039 END
25040*
25041*===daltra=============================================================*
25042*
25043CDECK ID>, DT_DALTRA
25044 SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
25045
25046************************************************************************
25047* Arbitrary Lorentz-transformation. *
25048* Adopted from the original by S. Roesler. This version dated 15.01.95 *
25049************************************************************************
25050
25051 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25052 SAVE
25053 PARAMETER (ONE=1.0D0)
25054
25055 EP = PCX*BGX+PCY*BGY+PCZ*BGZ
25056 PE = EP/(GA+ONE)+EC
25057 PX = PCX+BGX*PE
25058 PY = PCY+BGY*PE
25059 PZ = PCZ+BGZ*PE
25060 P = SQRT(PX*PX+PY*PY+PZ*PZ)
25061 E = GA*EC+EP
25062
25063 RETURN
25064 END
25065*
25066*====dtrafo============================================================*
25067*
25068CDECK ID>, DT_DTRAFO
25069 SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
25070 & PL,CXL,CYL,CZL,EL)
25071
25072C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
25073
25074 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25075 SAVE
25076
25077 IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
25078 SID = SQRT(1.D0-COD*COD)
25079 PLX = P*SID*COF
25080 PLY = P*SID*SIF
25081 PCMZ = P*COD
25082 PLZ = GAM*PCMZ+BGAM*ECM
25083 PL = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
25084 EL = GAM*ECM+BGAM*PCMZ
25085C ROTATION INTO THE ORIGINAL DIRECTION
25086 COZ = PLZ/PL
25087 SIZ = SQRT(1.D0-COZ**2)
25088 CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
25089
25090 RETURN
25091 END
25092*
25093*====sttran============================================================*
25094*
25095CDECK ID>, DT_STTRAN
25096 SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
25097
25098 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25099 SAVE
25100 DATA ANGLSQ/1.D-30/
25101************************************************************************
25102* VERSION BY J. RANFT *
25103* LEIPZIG *
25104* *
25105* THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES *
25106* *
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" *
25114* *
25115* OUTPUT VARIABLES: *
25116* X,Y,Z = NEW DIRECTION COSINES *
25117* *
25118* ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 ) *
25119************************************************************************
25120*
25121*
25122* Changed by A. Ferrari
25123*
25124* IF (ABS(XO)-0.0001D0) 1,1,2
25125* 1 IF (ABS(YO)-0.0001D0) 3,3,2
25126* 3 CONTINUE
25127 A = XO**2 + YO**2
25128 IF ( A .LT. ANGLSQ ) THEN
25129 X=SDE*CFE
25130 Y=SDE*SFE
25131 Z=CDE*ZO
25132 ELSE
25133 XI=SDE*CFE
25134 YI=SDE*SFE
25135 ZI=CDE
25136 A=SQRT(A)
25137 X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
25138 Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
25139 Z=A*YI+ZO*ZI
25140 ENDIF
25141
25142 RETURN
25143 END
25144*
25145*===mytran=============================================================*
25146*
25147CDECK ID>, DT_MYTRAN
25148 SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
25149
25150************************************************************************
25151* This subroutine rotates the coordinate frame *
25152* a) theta around y *
25153* b) phi around z if IMODE = 1 *
25154* *
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 *
25158* *
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************************************************************************
25163
25164 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25165 SAVE
25166
25167 PARAMETER ( LINP = 5 ,
25168 & LOUT = 6 ,
25169 & LDAT = 9 )
25170
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
25175 ELSE
25176 X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
25177 Y= -SFE*XO+CFE*YO
25178 Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
25179 ENDIF
25180 RETURN
25181 END
25182*
25183*===lt2lab=============================================================*
25184*
25185CDECK ID>, DT_LT2LAO
25186 SUBROUTINE DT_LT2LAO
25187
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************************************************************************
25194
25195 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25196 SAVE
25197
25198 PARAMETER ( LINP = 5 ,
25199 & LOUT = 6 ,
25200 & LDAT = 9 )
25201
25202* event history
25203
25204 PARAMETER (NMXHKK=200000)
25205
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),
25212 & IHIST(2,NMXHKK)
25213
25214 NEND = NHKK
25215 NPOINT(5) = NHKK+1
25216 IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
25217 DO 1 I=NPOINT(4),NEND
25218C DO 1 I=1,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)
25222 NOB = NOBAM(I)
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)
25227 NOBAM(NHKK) = NOB
25228 ELSE
25229 IF (ISTHKK(I).EQ.-1) NOBAM(NHKK) = NOB
25230 ISTHKK(I) = SIGN(3,ISTHKK(I))
25231 ENDIF
25232 JDAHKK(1,I) = NHKK
25233 ENDIF
25234 1 CONTINUE
25235
25236 RETURN
25237 END
25238*
25239*===lt2lab=============================================================*
25240*
25241CDECK ID>, DT_LT2LAB
25242 SUBROUTINE DT_LT2LAB
25243
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************************************************************************
25250
25251 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25252 SAVE
25253
25254 PARAMETER ( LINP = 5 ,
25255 & LOUT = 6 ,
25256 & LDAT = 9 )
25257
25258* event history
25259
25260 PARAMETER (NMXHKK=200000)
25261
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),
25268 & IHIST(2,NMXHKK)
25269
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)
25275 PHKK(3,I) = PZ
25276 PHKK(4,I) = PE
25277 ENDIF
25278 1 CONTINUE
25279
25280 RETURN
25281 END
25282
25283************************************************************************
25284* *
25285* 5) Sampling from distributions *
25286* *
25287************************************************************************
25288*
25289*===npoiss=============================================================*
25290*
25291CDECK ID>, IDT_NPOISS
25292 INTEGER FUNCTION IDT_NPOISS(AVN)
25293
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************************************************************************
25299
25300 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25301 SAVE
25302
25303 PARAMETER ( LINP = 5 ,
25304 & LOUT = 6 ,
25305 & LDAT = 9 )
25306
25307 EXPAVN = EXP(-AVN)
25308 K = 1
25309 A = 1.0D0
25310
25311 10 CONTINUE
25312 A = DT_RNDM(A)*A
25313 IF (A.GE.EXPAVN) THEN
25314 K = K+1
25315 GOTO 10
25316 ENDIF
25317 IDT_NPOISS = K-1
25318
25319 RETURN
25320 END
25321*
25322*===sampxb=============================================================*
25323*
25324CDECK ID>, DT_SAMPXB
25325 DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
25326
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************************************************************************
25331
25332 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25333 SAVE
25334 PARAMETER (TWO=2.0D0)
25335
25336 A1 = LOG(X1+SQRT(X1**2+B**2))
25337 A2 = LOG(X2+SQRT(X2**2+B**2))
25338 AN = A2-A1
25339 A = AN*DT_RNDM(A1)+A1
25340 BB = EXP(A)
25341 DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
25342
25343 RETURN
25344 END
25345*
25346*===sampex=============================================================*
25347*
25348CDECK ID>, DT_SAMPEX
25349 DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
25350
25351************************************************************************
25352* Sampling from f(x)=1./x between x1 and x2. *
25353* Processed by S. Roesler, 6.5.95 *
25354************************************************************************
25355
25356 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25357 SAVE
25358 PARAMETER (ONE=1.0D0)
25359
25360 R = DT_RNDM(X1)
25361 AL1 = LOG(X1)
25362 AL2 = LOG(X2)
25363 DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
25364
25365 RETURN
25366 END
25367*
25368*===samsqx=============================================================*
25369*
25370CDECK ID>, DT_SAMSQX
25371 DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
25372
25373************************************************************************
25374* Sampling from f(x)=1./x^0.5 between x1 and x2. *
25375* Processed by S. Roesler, 6.5.95 *
25376************************************************************************
25377
25378 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25379 SAVE
25380 PARAMETER (ONE=1.0D0)
25381
25382 R = DT_RNDM(X1)
25383 DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
25384
25385 RETURN
25386 END
25387*
25388*===samplw=============================================================*
25389*
25390CDECK ID>, DT_SAMPLW
25391 DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
25392
25393************************************************************************
25394* Sampling from f(x)=1/x^b between x_min and x_max. *
25395* S. Roesler, 18.4.98 *
25396************************************************************************
25397
25398 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25399 SAVE
25400 PARAMETER (ONE=1.0D0)
25401
25402 R = DT_RNDM(B)
25403 IF (B.EQ.ONE) THEN
25404 DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
25405 ELSE
25406 ONEMB = ONE-B
25407 DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
25408 ENDIF
25409
25410 RETURN
25411 END
25412*
25413*===betrej=============================================================*
25414*
25415CDECK ID>, DT_BETREJ
25416 DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
25417
25418 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25419 SAVE
25420
25421 PARAMETER ( LINP = 5 ,
25422 & LOUT = 6 ,
25423 & LDAT = 9 )
25424
25425 PARAMETER (ONE=1.0D0)
25426
25427 IF (XMIN.GE.XMAX)THEN
25428 WRITE (LOUT,500) XMIN,XMAX
25429 500 FORMAT(1X,'DT_BETREJ: XMIN<XMAX execution stopped ',2F10.5)
25430 STOP
25431 ENDIF
25432
25433 10 CONTINUE
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
25439 DT_BETREJ = XX
25440
25441 RETURN
25442 END
25443*
25444*===dgamrn=============================================================*
25445*
25446CDECK ID>, DT_DGAMRN
25447 DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
25448
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************************************************************************
25454
25455 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25456 SAVE
25457 PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
25458
25459 NCOU = 0
25460 N = INT(ETA)
25461 F = ETA-DBLE(N)
25462 IF (F.EQ.ZERO) GOTO 20
25463 10 R = DT_RNDM(F)
25464 NCOU = NCOU+1
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
25469 Y = EXP(YYY)
25470 IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
25471 GOTO 40
25472 20 Y = 0.0D0
25473 GOTO 50
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
25477 50 Z = 1.0D0
25478 DO 60 I = 1,N
25479 60 Z = Z*DT_RNDM(Z)
25480 Y = Y-LOG(Z+TINY9)
25481 70 DT_DGAMRN = Y/ALAM
25482
25483 RETURN
25484 END
25485*
25486*===dbetar=============================================================*
25487*
25488CDECK ID>, DT_DBETAR
25489 DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
25490
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************************************************************************
25496
25497 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25498 SAVE
25499
25500 Y = DT_DGAMRN(1.0D0,GAM)
25501 Z = DT_DGAMRN(1.0D0,ETA)
25502 DT_DBETAR = Y/(Y+Z)
25503
25504 RETURN
25505 END
25506*
25507*===rannor=============================================================*
25508*
25509CDECK ID>, DT_RANNOR
25510 SUBROUTINE DT_RANNOR(X,Y)
25511
25512************************************************************************
25513* Sampling from Gaussian distribution. *
25514* Processed by S. Roesler, 6.5.95 *
25515************************************************************************
25516
25517 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25518 SAVE
25519 PARAMETER (TINY10=1.0D-10)
25520
25521 CALL DT_DSFECF(SFE,CFE)
25522 V = MAX(TINY10,DT_RNDM(X))
25523 A = SQRT(-2.D0*LOG(V))
25524 X = A*SFE
25525 Y = A*CFE
25526
25527 RETURN
25528 END
25529*
25530*===dpoli==============================================================*
25531*
25532CDECK ID>, DT_DPOLI
25533 SUBROUTINE DT_DPOLI(CS,SI)
25534
25535 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25536 SAVE
25537
25538 U = DT_RNDM(CS)
25539 CS = DT_RNDM(U)
25540 IF (U.LT.0.5D0) CS=-CS
25541 SI = SQRT(1.0D0-CS*CS+1.0D-10)
25542
25543 RETURN
25544 END
25545*
25546*===dsfecf=============================================================*
25547*
25548CDECK ID>, DT_DSFECF
25549 SUBROUTINE DT_DSFECF(SFE,CFE)
25550
25551 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25552 SAVE
25553 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25554
25555 1 CONTINUE
25556 X = DT_RNDM(SFE)
25557 Y = DT_RNDM(X)
25558 XX = X*X
25559 YY = Y*Y
25560 XY = XX+YY
25561 IF (XY.GT.ONE) GOTO 1
25562 CFE = (XX-YY)/XY
25563 SFE = TWO*X*Y/XY
25564 IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
25565 RETURN
25566 END
25567*
25568*===raco===============================================================*
25569*
25570CDECK ID>, DT_RACO
25571 SUBROUTINE DT_RACO(WX,WY,WZ)
25572
25573************************************************************************
25574* Direction cosines of random uniform (isotropic) direction in three *
25575* dimensional space *
25576* Processed by S. Roesler, 20.11.95 *
25577************************************************************************
25578
25579 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25580 SAVE
25581 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
25582
25583 10 CONTINUE
25584 X = TWO*DT_RNDM(WX)-ONE
25585 Y = DT_RNDM(X)
25586 X2 = X*X
25587 Y2 = Y*Y
25588 IF (X2+Y2.GT.ONE) GOTO 10
25589
25590 CFE = (X2-Y2)/(X2+Y2)
25591 SFE = TWO*X*Y/(X2+Y2)
25592* z = 1/2 [ 1 + cos (theta) ]
25593 Z = DT_RNDM(X)
25594* 1/2 sin (theta)
25595 WZ = SQRT(Z*(ONE-Z))
25596 WX = TWO*WZ*CFE
25597 WY = TWO*WZ*SFE
25598 WZ = TWO*Z-ONE
25599
25600 RETURN
25601 END
25602
25603************************************************************************
25604* *
25605* 6) Special functions, algorithms and service routines *
25606* *
25607************************************************************************
25608*
25609*===ylamb==============================================================*
25610*
25611CDECK ID>, DT_YLAMB
25612 DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
25613
25614************************************************************************
25615* *
25616* auxiliary function for three particle decay mode *
25617* (standard LAMBDA**(1/2) function) *
25618* *
25619* Adopted from an original version written by R. Engel. *
25620* This version dated 12.12.94 is written by S. Roesler. *
25621************************************************************************
25622
25623 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25624 SAVE
25625
25626 YZ = Y-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)
25630
25631 RETURN
25632 END
25633*
25634*===sort1==============================================================*
25635*
25636CDECK ID>, DT_SORT
25637 SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
25638
25639************************************************************************
25640* This subroutine sorts entries in A in increasing/decreasing order *
25641* of A(3,i). *
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************************************************************************
25646
25647 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25648 SAVE
25649
25650 DIMENSION A(3,N)
25651
25652 M = I1
25653 10 CONTINUE
25654 M = I1-1
25655 IF (M.LE.0) RETURN
25656 L = 0
25657 DO 20 I=I0,M
25658 J = I+1
25659 IF (MODE.EQ.1) THEN
25660 IF (A(3,I).LE.A(3,J)) GOTO 20
25661 ELSE
25662 IF (A(3,I).GE.A(3,J)) GOTO 20
25663 ENDIF
25664 B = A(3,I)
25665 C = A(1,I)
25666 D = A(2,I)
25667 A(3,I) = A(3,J)
25668 A(2,I) = A(2,J)
25669 A(1,I) = A(1,J)
25670 A(3,J) = B
25671 A(1,J) = C
25672 A(2,J) = D
25673 L = 1
25674 20 CONTINUE
25675 IF (L.EQ.1) GOTO 10
25676
25677 RETURN
25678 END
25679*
25680*===sort1==============================================================*
25681*
25682CDECK ID>, DT_SORT1
25683 SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
25684
25685************************************************************************
25686* This subroutine sorts entries in A in increasing/decreasing order *
25687* of A(i). *
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************************************************************************
25692
25693 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25694 SAVE
25695
25696 DIMENSION A(N),IDX(N)
25697
25698 M = I1
25699 10 CONTINUE
25700 M = I1-1
25701 IF (M.LE.0) RETURN
25702 L = 0
25703 DO 20 I=I0,M
25704 J = I+1
25705 IF (MODE.EQ.1) THEN
25706 IF (A(I).LE.A(J)) GOTO 20
25707 ELSE
25708 IF (A(I).GE.A(J)) GOTO 20
25709 ENDIF
25710 B = A(I)
25711 A(I) = A(J)
25712 A(J) = B
25713 IX = IDX(I)
25714 IDX(I) = IDX(J)
25715 IDX(J) = IX
25716 L = 1
25717 20 CONTINUE
25718 IF (L.EQ.1) GOTO 10
25719
25720 RETURN
25721 END
25722*
25723*===xtime==============================================================*
25724*
25725CDECK ID>, DT_XTIME
25726 SUBROUTINE DT_XTIME
25727
25728 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25729 SAVE
25730
25731 PARAMETER ( LINP = 5 ,
25732 & LOUT = 6 ,
25733 & LDAT = 9 )
25734
25735 CHARACTER DAT*9,TIM*11
25736
25737 DAT = ' '
25738 TIM = ' '
25739C CALL GETDAT(IYEAR,IMONTH,IDAY)
25740C CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
25741
25742C CALL DATE(DAT)
25743C CALL TIME(TIM)
25744C WRITE(LOUT,1000) DAT,TIM
25745 1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
25746
25747 RETURN
25748 END
25749
25750************************************************************************
25751* *
25752* 7) Random number generator package *
25753* *
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 *
25770*--- *
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 *
25794* SAME STATUS *
25795* AS BEFORE CALL OF DT_RNDMTE *
25796************************************************************************
25797*
25798*===rndm===============================================================*
25799*
25800CDECK ID>, DT_RNDM
25801 DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
25802
25803 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25804 SAVE
25805
25806* counter of calls to random number generator
25807* uncomment if needed
25808C COMMON /DTRNCT/ IRNCT0,IRNCT1
25809C LOGICAL LFIRST
25810C DATA LFIRST /.TRUE./
25811
25812* counter of calls to random number generator
25813* uncomment if needed
25814C IF (LFIRST) THEN
25815C IRNCT0 = 0
25816C IRNCT1 = 0
25817C LFIRST = .FALSE.
25818C ENDIF
25819
25820 DT_RNDM = FLRNDM(VDUMMY)
25821* counter of calls to random number generator
25822* uncomment if needed
25823C IRNCT1 = IRNCT1+1
25824
25825 RETURN
25826 END
25827*
25828*===rndmst=============================================================*
25829*
25830CDECK ID>, DT_RNDMST
25831 SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
25832
25833 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25834 SAVE
25835
25836* random number generator
25837 COMMON /DTRAND/ U(97),C,CD,CM,I,J
25838
25839 MA1 = NA1
25840 MA2 = NA2
25841 MA3 = NA3
25842 MB1 = NB1
25843 I = 97
25844 J = 33
25845 DO 20 II2 = 1,97
25846 S = 0
25847 T = 0.5D0
25848 DO 10 II1 = 1,24
25849 MAT = MOD(MOD(MA1*MA2,179)*MA3,179)
25850 MA1 = MA2
25851 MA2 = MA3
25852 MA3 = MAT
25853 MB1 = MOD(53*MB1+1,169)
25854 IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
25855 10 T = 0.5D0*T
25856 20 U(II2) = S
25857 C = 362436.0D0/16777216.0D0
25858 CD = 7654321.0D0/16777216.0D0
25859 CM = 16777213.0D0/16777216.0D0
25860 RETURN
25861 END
25862*
25863*===rndmin=============================================================*
25864*
25865CDECK ID>, DT_RNDMIN
25866 SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
25867
25868 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25869 SAVE
25870
25871* random number generator
25872 COMMON /DTRAND/ U(97),C,CD,CM,I,J
25873
25874 DIMENSION UIN(97)
25875
25876 DO 10 KKK = 1,97
25877 10 U(KKK) = UIN(KKK)
25878 C = CIN
25879 CD = CDIN
25880 CM = CMIN
25881 I = IIN
25882 J = JIN
25883
25884 RETURN
25885 END
25886*
25887*===rndmou=============================================================*
25888*
25889CDECK ID>, DT_RNDMOU
25890 SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
25891
25892 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25893 SAVE
25894
25895* random number generator
25896 COMMON /DTRAND/ U(97),C,CD,CM,I,J
25897
25898 DIMENSION UOUT(97)
25899
25900 DO 10 KKK = 1,97
25901 10 UOUT(KKK) = U(KKK)
25902 COUT = C
25903 CDOUT = CD
25904 CMOUT = CM
25905 IOUT = I
25906 JOUT = J
25907
25908 RETURN
25909 END
25910*
25911*===rndmte=============================================================*
25912*
25913CDECK ID>, DT_RNDMTE
25914 SUBROUTINE DT_RNDMTE(IO)
25915
25916 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25917 SAVE
25918
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/
25922
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)
25927 SD = 0.0D0
25928 DO 20 II2 = 1,6
25929 X(II2) = 4096.D0*(4096.D0*DT_RNDM(SD))
25930 D(II2) = X(II2)-U(II2)
25931 20 SD = SD+D(II2)
25932 CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
25933**sr 24.01.95
25934C 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
25936C WRITE(6,1000)
25937 1000 FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
25938 & ' passed')
25939 ENDIF
25940**
25941 RETURN
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')
25946 END
25947*
25948*
25949*===title==============================================================*
25950*
25951CDECK ID>, DT_TITLE
25952 SUBROUTINE DT_TITLE
25953
25954 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25955 SAVE
25956
25957 PARAMETER ( LINP = 5 ,
25958 & LOUT = 6 ,
25959 & LDAT = 9 )
25960
25961 CHARACTER*6 CVERSI
25962 CHARACTER*11 CCHANG
25963 DATA CVERSI,CCHANG /'3.0-4 ','18 Sep 2001'/
25964
25965 CALL DT_XTIME
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',
25979 & 17X,'|',/,
25980 & 1X,'|',71X,'|',/,
25981 & 1X,'+-------------------------------------------------',
25982 & '----------------------+',/,
25983 & 1X,'| Please send suggestions, bug reports, etc. to: ',
25984 & 'Stefan.Roesler@cern.ch |',/,
25985 & 1X,'+-------------------------------------------------',
25986 & '----------------------+',/)
25987
25988 RETURN
25989 END
25990*
25991*===evtini=============================================================*
25992*
25993CDECK ID>, DT_EVTINI
25994 SUBROUTINE DT_EVTINI
25995
25996************************************************************************
25997* Initialization of DTEVT1. *
25998* This version dated 15.01.94 is written by S. Roesler *
25999************************************************************************
26000
26001 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26002 SAVE
26003
26004 PARAMETER ( LINP = 5 ,
26005 & LOUT = 6 ,
26006 & LDAT = 9 )
26007
26008* event history
26009
26010 PARAMETER (NMXHKK=200000)
26011
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),
26018 & IHIST(2,NMXHKK)
26019* event flag
26020 COMMON /DTEVNO/ NEVENT,ICASCA
26021
26022 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
26023
26024* emulsion treatment
26025 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
26026 & NCOMPO,IEMUL
26027
26028* initialization of DTEVT1/DTEVT2
26029 NEND = NHKK
26030 IF (NEVENT.EQ.1) NEND = NMXHKK
26031 NHKK = 0
26032 NEVHKK = NEVENT
26033 DO 1 I=1,NEND
26034 ISTHKK(I) = 0
26035 IDHKK(I) = 0
26036 JMOHKK(1,I) = 0
26037 JMOHKK(2,I) = 0
26038 JDAHKK(1,I) = 0
26039 JDAHKK(2,I) = 0
26040 IDRES(I) = 0
26041 IDXRES(I) = 0
26042 NOBAM(I) = 0
26043 IDCH(I) = 0
26044 IHIST(1,I) = 0
26045 IHIST(2,I) = 0
26046 DO 2 J=1,4
26047 PHKK(J,I) = 0.0D0
26048 VHKK(J,I) = 0.0D0
26049 WHKK(J,I) = 0.0D0
26050 2 CONTINUE
26051 PHKK(5,I) = 0.0D0
26052 1 CONTINUE
26053 DO 3 I=1,10
26054 NPOINT(I) = 0
26055 3 CONTINUE
26056 CALL DT_CHASTA(-1)
26057
26058C* initialization of DTLTRA
26059C IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
26060
26061 RETURN
26062 END
26063*
26064*===statis=============================================================*
26065*
26066CDECK ID>, DT_STATIS
26067 SUBROUTINE DT_STATIS(MODE)
26068
26069************************************************************************
26070* Initialization and output of run-statistics. *
26071* MODE = 1 initialization *
26072* = 2 output *
26073* This version dated 23.01.94 is written by S. Roesler *
26074************************************************************************
26075
26076 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26077 SAVE
26078
26079 PARAMETER ( LINP = 5 ,
26080 & LOUT = 6 ,
26081 & LDAT = 9 )
26082
26083 PARAMETER (TINY3=1.0D-3)
26084
26085* statistics
26086 COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
26087 & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
26088 & ICEVTG(8,0:30)
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,
26099 & LCO2CR,LINTPT
26100* nucleon-nucleon event-generator
26101 CHARACTER*8 CMODEL
26102 LOGICAL LPHOIN
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
26110
26111 DIMENSION PP(4),PT(4)
26112
26113 GOTO (1,2) MODE
26114
26115* initialization
26116 1 CONTINUE
26117
26118* initialize statistics counter
26119 ICREQU = 0
26120 ICSAMP = 0
26121 ICCPRO = 0
26122 ICDPR = 0
26123 ICDTA = 0
26124 ICRJSS = 0
26125 ICVV2S = 0
26126 DO 10 I=1,9
26127 ICRES(I) = 0
26128 ICCHAI(1,I) = 0
26129 ICCHAI(2,I) = 0
26130 10 CONTINUE
26131* initialize rejection counter
26132 IRPT = 0
26133 IRHHA = 0
26134 LOMRES = 0
26135 LOBRES = 0
26136 IRFRAG = 0
26137 IREVT = 0
26138 IRRES(1) = 0
26139 IRRES(2) = 0
26140 IRCHKI(1) = 0
26141 IRCHKI(2) = 0
26142 IRCRON(1) = 0
26143 IRCRON(2) = 0
26144 IRCRON(3) = 0
26145 IRDIFF(1) = 0
26146 IRDIFF(2) = 0
26147 IRINC = 0
26148 DO 11 I=1,5
26149 ICDIFF(I) = 0
26150 11 CONTINUE
26151 DO 12 I=1,8
26152 DO 13 J=0,30
26153 ICEVTG(I,J) = 0
26154 13 CONTINUE
26155 12 CONTINUE
26156
26157 RETURN
26158
26159* output
26160 2 CONTINUE
26161
26162* statistics counter
26163 WRITE(LOUT,1000)
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)
26175 ENDIF
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)
26182 ENDIF
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))
26187
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)
26196 ENDIF
26197 WRITE(LOUT,1006)
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,/)
26214 WRITE(LOUT,1008)
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
26244C *** Commented by Chiara
26245C WRITE(LOUT,1010) ELOJET
26246C 1010 FORMAT(/,/,1X,'PHOJET-treatment of chain systems above ',
26247C & F4.1,' GeV')
26248C WRITE(LOUT,1011)
26249C 1011 FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
26250C & 30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
26251C & 5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
26252C WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
26253C & (INT(ICCHAI(2,I)/2.0D0),I=1,8),
26254C & (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
26255C & ((ICEVTG(I,J),I=1,8),J=3,7),
26256C & ((ICEVTG(I,J),I=1,8),J=19,21),
26257C & (ICEVTG(I,8),I=1,8),
26258C & ((ICEVTG(I,J),I=1,8),J=22,24),
26259C & (ICEVTG(I,9),I=1,8),
26260C & ((ICEVTG(I,J),I=1,8),J=25,28),
26261C & ((ICEVTG(I,J),I=1,8),J=10,18)
26262C 1012 FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
26263C & 8I8,/,/,1X,'PHOJET ',8I8,/,' sngl ',8I8,/,/,
26264C & ' no-dif.',8I8,/,
26265C & ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
26266C & ' diff-1 ',8I8,/,' low ',8I8,/,' high ',8I8,/,
26267C & ' h-diff',8I8,/,' diff-2 ',8I8,/,' low ',8I8,/,
26268C & ' high ',8I8,/,' h-diff',8I8,/,' dbl-di.',8I8,/,
26269C & ' lo-lo ',8I8,/,' hi-hi ',8I8,/,' lo-hi ',8I8,/,
26270C & ' hi-lo ',8I8,/,
26271C & ' dir-ga.',8I8,/,/,' dir-1 ',8I8,/,' dir-2 ',8I8,/,
26272C & ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
26273C & ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
26274C WRITE(LOUT,1013)
26275C 1013 FORMAT(/,1X,'2. chain system statistics -',
26276C & ' mean numbers per evt:',/,30X,'---------------------',
26277C & /,/,16X,'s-s',7X,'d-s',7X,'s-d')
26278C WRITE(LOUT,1014)
26279C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
26280C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
26281C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
26282C 1014 FORMAT(/,1X,'req.to. ',3E10.2,/,/,1X,'low rq. ',3E10.2,/,
26283C & 1X,'low ac. ',3E10.2,/,/,1X,'PHOJET ',3E10.2,/,/,
26284C & ' no-dif. ',3E10.2,/,' el-sca. ',3E10.2,/,
26285C & ' qel-sc. ',3E10.2,/,' dbl-Po. ',3E10.2,/,
26286C & ' diff-1 ',3E10.2,/,' diff-2 ',3E10.2,/,
26287C & ' dbl-di. ',3E10.2,/,' dir-ga. ',3E10.2,/,/,
26288C & ' dir-1 ',3E10.2,/,' dir-2 ',3E10.2,/,
26289C & ' dbl-dir ',3E10.2,/,' s-Pom. ',3E10.2,/,
26290C & ' h-Pom. ',3E10.2,/,' s-Reg. ',3E10.2,/,
26291C & ' enh-trg ',3E10.2,/,' enh-log ',3E10.2)
26292C WRITE(LOUT,1015)
26293C 1015 FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
26294C WRITE(LOUT,1016)
26295C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
26296C & (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
26297C & ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
26298C 1016 FORMAT(/,1X,'req.to. ',5E10.2,/,/,1X,'low rq. ',5E10.2,/,
26299C & 1X,'low ac. ',5E10.2,/,/,1X,'PHOJET ',5E10.2,/,/,
26300C & ' no-dif. ',5E10.2,/,' el-sca. ',5E10.2,/,
26301C & ' qel-sc. ',5E10.2,/,' dbl-Po. ',5E10.2,/,
26302C & ' diff-1 ',5E10.2,/,' diff-2 ',5E10.2,/,
26303C & ' dbl-di. ',5E10.2,/,' dir-ga. ',5E10.2,/,/,
26304C & ' dir-1 ',5E10.2,/,' dir-2 ',5E10.2,/,
26305C & ' dbl-dir ',5E10.2,/,' s-Pom. ',5E10.2,/,
26306C & ' h-Pom. ',5E10.2,/,' s-Reg. ',5E10.2,/,
26307C & ' enh-trg ',5E10.2,/,' enh-log ',5E10.2)
26308
26309 ENDIF
26310 CALL DT_CHASTA(1)
26311
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)
26338 ENDIF
26339
26340 FAC = 1.0D0
26341 IF (MCGENE.EQ.2) THEN
26342
26343C CALL PHO_PHIST(-2,SIGMAX)
26344 CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
26345
26346 ENDIF
26347
26348 CALL DT_XTIME
26349
26350 RETURN
26351 END
26352*
26353*===evtout=============================================================*
26354*
26355CDECK ID>, DT_EVTOUT
26356 SUBROUTINE DT_EVTOUT(MODE)
26357
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************************************************************************
26364
26365 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26366 SAVE
26367
26368 PARAMETER ( LINP = 5 ,
26369 & LOUT = 6 ,
26370 & LDAT = 9 )
26371
26372* event history
26373
26374 PARAMETER (NMXHKK=200000)
26375
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)
26379
26380 DIMENSION IRANGE(NMXHKK)
26381
26382 IF (MODE.EQ.2) RETURN
26383
26384 CALL DT_EVTPLO(IRANGE,MODE)
26385
26386 RETURN
26387 END
26388*
26389*===evtplo=============================================================*
26390*
26391CDECK ID>, DT_EVTPLO
26392 SUBROUTINE DT_EVTPLO(IRANGE,MODE)
26393
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************************************************************************
26402
26403 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26404 SAVE
26405
26406 PARAMETER ( LINP = 5 ,
26407 & LOUT = 6 ,
26408 & LDAT = 9 )
26409
26410 CHARACTER*16 CHAU
26411
26412* event history
26413
26414 PARAMETER (NMXHKK=200000)
26415
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),
26422 & IHIST(2,NMXHKK)
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
26427
26428 DIMENSION IRANGE(NMXHKK)
26429
26430 IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
26431 WRITE(LOUT,1000)
26432 1000 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTEVT1/',/,
26433 & 15X,' --------------------------',/,/,
26434 & ' ST ID M1 M2 D1 D2 PX PY',
26435 & ' PZ E M',/)
26436 DO 1 I=1,NHKK
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),
26440 & PHKK(5,I)
26441C WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
26442C & JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
26443C & PHKK(3,I),PHKK(4,I)
26444C WRITE(LOUT,'(4E15.4)')
26445C & 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)
26448 1 CONTINUE
26449 WRITE(LOUT,*)
26450C DO 4 I=1,NHKK
26451C WRITE(LOUT,1006) I,ISTHKK(I),
26452C & VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
26453C & WHKK(2,I),WHKK(3,I)
26454C1006 FORMAT(1X,I4,I6,6E10.3)
26455C 4 CONTINUE
26456 ENDIF
26457
26458 IF (MODE.EQ.2) THEN
26459 WRITE(LOUT,1000)
26460 NC = 0
26461 2 CONTINUE
26462 NC = NC+1
26463 IF (IRANGE(NC).EQ.-100) GOTO 9999
26464 I = IRANGE(NC)
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),
26468 & PHKK(5,I)
26469 GOTO 2
26470 ENDIF
26471
26472 IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
26473 WRITE(LOUT,1002)
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',/)
26479 DO 3 I=1,NHKK
26480C IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
26481 KF = IDHKK(I)
26482 IDCHK = KF/10000
26483 IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
26484 & (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
26485
26486 CALL PYNAME(KF,CHAU)
26487
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),
26491 & PHKK(5,I),CHAU
26492 1003 FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
26493C ENDIF
26494 3 CONTINUE
26495 ENDIF
26496
26497 IF (MODE.EQ.5) THEN
26498 WRITE(LOUT,1004)
26499 1004 FORMAT(/,1X,'EVTPLO:',14X,' content of COMMON /DTREJC/',/,
26500 & 15X,' --------------------------',/)
26501 WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
26502 & IRSEA,IRCRON
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,/)
26507 ENDIF
26508
26509 9999 RETURN
26510 END
26511*
26512*===evtput=============================================================*
26513*
26514CDECK ID>, DT_EVTPUT
26515 SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
26516
26517 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26518 SAVE
26519
26520 PARAMETER ( LINP = 5 ,
26521 & LOUT = 6 ,
26522 & LDAT = 9 )
26523
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)
26526
26527* event history
26528
26529 PARAMETER (NMXHKK=200000)
26530
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),
26537 & IHIST(2,NMXHKK)
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)
26542 CHARACTER*8 ANAME
26543 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26544 & IICH(210),IIBAR(210),K1(210),K2(210)
26545
26546C IF (MODE.GT.100) THEN
26547C WRITE(LOUT,'(1X,A,I5,A,I5)')
26548C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
26549C NHKK = NHKK-MODE+100
26550C RETURN
26551C ENDIF
26552 MO1 = M1
26553 MO2 = M2
26554 NHKK = NHKK+1
26555
26556 IF (NHKK.GT.NMXHKK) THEN
26557 WRITE(LOUT,1000) NHKK
26558 1000 FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
26559 & '! program execution stopped..')
26560 STOP
26561 ENDIF
26562 IF (M1.LT.0) MO1 = NHKK+M1
26563 IF (M2.LT.0) MO2 = NHKK+M2
26564 ISTHKK(NHKK) = IST
26565 IDHKK(NHKK) = ID
26566 JMOHKK(1,NHKK) = MO1
26567 JMOHKK(2,NHKK) = MO2
26568 JDAHKK(1,NHKK) = 0
26569 JDAHKK(2,NHKK) = 0
26570 IDRES(NHKK) = IDR
26571 IDXRES(NHKK) = IDXR
26572 IDCH(NHKK) = IDC
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
26581 ELSE
26582 NOBAM(NHKK) = 0
26583 ENDIF
26584 IDBAM(NHKK) = IDT_ICIHAD(ID)
26585 IF (MO1.GT.0) THEN
26586 IF (JDAHKK(1,MO1).NE.0) THEN
26587 JDAHKK(2,MO1) = NHKK
26588 ELSE
26589 JDAHKK(1,MO1) = NHKK
26590 ENDIF
26591 ENDIF
26592 IF (MO2.GT.0) THEN
26593 IF (JDAHKK(1,MO2).NE.0) THEN
26594 JDAHKK(2,MO2) = NHKK
26595 ELSE
26596 JDAHKK(1,MO2) = NHKK
26597 ENDIF
26598 ENDIF
26599C IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
26600C PTOT = SQRT(PX**2+PY**2+PZ**2)
26601C AM0 = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
26602C AMRQ = AAM(IDBAM(NHKK))
26603C AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
26604C IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
26605C & (PTOT.GT.ZERO)) THEN
26606C DELTA = -AMDIF2/(2.0D0*(E+PTOT))
26607CC DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
26608C E = E+DELTA
26609C PTOT1 = PTOT-DELTA
26610C PX = PX*PTOT1/PTOT
26611C PY = PY*PTOT1/PTOT
26612C PZ = PZ*PTOT1/PTOT
26613C ENDIF
26614C ENDIF
26615 PHKK(1,NHKK) = PX
26616 PHKK(2,NHKK) = PY
26617 PHKK(3,NHKK) = PZ
26618 PHKK(4,NHKK) = E
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))
26623 ELSE
26624 PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
26625C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
26626C & WRITE(LOUT,'(1X,A,G10.3)')
26627C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
26628 PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
26629 ENDIF
26630 IDCHK = ID/10000
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
26636C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
26637C 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
26642C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
26643C 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
26648 ELSE
26649 IF (MO1.GT.0) THEN
26650 DO 1 I=1,4
26651 VHKK(I,NHKK) = VHKK(I,MO1)
26652 WHKK(I,NHKK) = WHKK(I,MO1)
26653 1 CONTINUE
26654 ELSE
26655 DO 2 I=1,4
26656 VHKK(I,NHKK) = ZERO
26657 WHKK(I,NHKK) = ZERO
26658 2 CONTINUE
26659 ENDIF
26660 ENDIF
26661
26662 RETURN
26663 END
26664*
26665*===chasta=============================================================*
26666*
26667CDECK ID>, DT_CHASTA
26668 SUBROUTINE DT_CHASTA(MODE)
26669
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. *
26674* *
26675* This version dated 8.5.00 is written by S. Roesler. *
26676************************************************************************
26677
26678 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26679 SAVE
26680
26681 PARAMETER ( LINP = 5 ,
26682 & LOUT = 6 ,
26683 & LDAT = 9 )
26684
26685 CHARACTER*5 CCHTYP
26686
26687* event history
26688
26689 PARAMETER (NMXHKK=200000)
26690
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),
26697 & IHIST(2,NMXHKK)
26698* pointer to chains in hkkevt common (used by qq-breaking mechanisms)
26699 PARAMETER (MAXCHN=10000)
26700 COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
26701
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 '/
26713*
26714* initialization
26715*
26716 IF (MODE.EQ.-1) THEN
26717 NCHAIN = 0
26718*
26719* loop over DTEVT1 and analyse chain configurations
26720*
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) ',
26729 & ' at entry ',IDX
26730 GOTO 21
26731 ENDIF
26732*
26733 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26734 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26735 IMO1 = IST1/10
26736 IMO1 = IST1-10*IMO1
26737 IMO2 = IST2/10
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
26743 DO 22 K=1,NPTN/2
26744 I0 = JMOHKK(1,IDX)-1+K
26745 I1 = JMOHKK(2,IDX)+1-K
26746 ITMP = ISTHKK(I0)
26747 ISTHKK(I0) = ISTHKK(I1)
26748 ISTHKK(I1) = ITMP
26749 ITMP = IDHKK(I0)
26750 IDHKK(I0) = IDHKK(I1)
26751 IDHKK(I1) = ITMP
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
26780 DO 23 J=1,4
26781 RTMP1 = PHKK(J,I0)
26782 RTMP2 = VHKK(J,I0)
26783 RTMP3 = WHKK(J,I0)
26784 PHKK(J,I0) = PHKK(J,I1)
26785 VHKK(J,I0) = VHKK(J,I1)
26786 WHKK(J,I0) = WHKK(J,I1)
26787 PHKK(J,I1) = RTMP1
26788 VHKK(J,I1) = RTMP2
26789 WHKK(J,I1) = RTMP3
26790 23 CONTINUE
26791 RTMP1 = PHKK(5,I0)
26792 PHKK(5,I0) = PHKK(5,I1)
26793 PHKK(5,I1) = RTMP1
26794 ITMP = IDRES(I0)
26795 IDRES(I0) = IDRES(I1)
26796 IDRES(I1) = ITMP
26797 ITMP = IDXRES(I0)
26798 IDXRES(I0) = IDXRES(I1)
26799 IDXRES(I1) = ITMP
26800 ITMP = NOBAM(I0)
26801 NOBAM(I0) = NOBAM(I1)
26802 NOBAM(I1) = ITMP
26803 ITMP = IDBAM(I0)
26804 IDBAM(I0) = IDBAM(I1)
26805 IDBAM(I1) = ITMP
26806 ITMP = IDCH(I0)
26807 IDCH(I0) = IDCH(I1)
26808 IDCH(I1) = ITMP
26809 ITMP = IHIST(1,I0)
26810 IHIST(1,I0) = IHIST(1,I1)
26811 IHIST(1,I1) = ITMP
26812 ITMP = IHIST(2,I0)
26813 IHIST(2,I0) = IHIST(2,I1)
26814 IHIST(2,I1) = ITMP
26815 22 CONTINUE
26816 ENDIF
26817 IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
26818 IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
26819*
26820* parton 1 (projectile side)
26821 IF (IST1.EQ.21) THEN
26822 IDX1 = 1
26823 ELSEIF (IST1.EQ.22) THEN
26824 IDX1 = 2
26825 ELSEIF (IST1.EQ.31) THEN
26826 IDX1 = 3
26827 ELSEIF (IST1.EQ.32) THEN
26828 IDX1 = 4
26829 ELSEIF (IST1.EQ.41) THEN
26830 IDX1 = 5
26831 ELSEIF (IST1.EQ.42) THEN
26832 IDX1 = 6
26833 ELSEIF (IST1.EQ.51) THEN
26834 IDX1 = 7
26835 ELSEIF (IST1.EQ.52) THEN
26836 IDX1 = 8
26837 ELSEIF (IST1.EQ.61) THEN
26838 IDX1 = 9
26839 ELSEIF (IST1.EQ.62) THEN
26840 IDX1 = 10
26841 ELSE
26842c WRITE(LOUT,*)
26843c & ' CHASTA: unknown parton status flag (',
26844c & IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26845 GOTO 21
26846 ENDIF
26847 ID = IDHKK(JMOHKK(1,IDX))
26848 IF (ABS(ID).LE.4) THEN
26849 IF (ID.GT.0) THEN
26850 ITYP1 = 1
26851 ELSE
26852 ITYP1 = 2
26853 ENDIF
26854 ELSEIF (ABS(ID).GE.1000) THEN
26855 IF (ID.GT.0) THEN
26856 ITYP1 = 3
26857 ELSE
26858 ITYP1 = 4
26859 ENDIF
26860 ELSEIF (ID.EQ.21) THEN
26861 ITYP1 = 5
26862 ELSE
26863 WRITE(LOUT,*)
26864 & ' CHASTA: inconsistent parton identity (',
26865 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26866 GOTO 21
26867 ENDIF
26868*
26869* parton 2 (target side)
26870 IF (IST2.EQ.21) THEN
26871 IDX2 = 1
26872 ELSEIF (IST2.EQ.22) THEN
26873 IDX2 = 2
26874 ELSEIF (IST2.EQ.31) THEN
26875 IDX2 = 3
26876 ELSEIF (IST2.EQ.32) THEN
26877 IDX2 = 4
26878 ELSEIF (IST2.EQ.41) THEN
26879 IDX2 = 5
26880 ELSEIF (IST2.EQ.42) THEN
26881 IDX2 = 6
26882 ELSEIF (IST2.EQ.51) THEN
26883 IDX2 = 7
26884 ELSEIF (IST2.EQ.52) THEN
26885 IDX2 = 8
26886 ELSEIF (IST2.EQ.61) THEN
26887 IDX2 = 9
26888 ELSEIF (IST2.EQ.62) THEN
26889 IDX2 = 10
26890 ELSE
26891c WRITE(LOUT,*)
26892c & ' CHASTA: unknown parton status flag (',
26893c & IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
26894 GOTO 21
26895 ENDIF
26896 ID = IDHKK(JMOHKK(2,IDX))
26897 IF (ABS(ID).LE.4) THEN
26898 IF (ID.GT.0) THEN
26899 ITYP2 = 1
26900 ELSE
26901 ITYP2 = 2
26902 ENDIF
26903 ELSEIF (ABS(ID).GE.1000) THEN
26904 IF (ID.GT.0) THEN
26905 ITYP2 = 3
26906 ELSE
26907 ITYP2 = 4
26908 ENDIF
26909 ELSEIF (ID.EQ.21) THEN
26910 ITYP2 = 5
26911 ELSE
26912 WRITE(LOUT,*)
26913 & ' CHASTA: inconsistent parton identity (',
26914 & ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
26915 GOTO 21
26916 ENDIF
26917*
26918* fill counter
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
26925
26926 NCHAIN = NCHAIN+1
26927 IF (NCHAIN.GT.MAXCHN) THEN
26928 WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
26929 & NCHAIN,MAXCHN
26930 STOP
26931 ENDIF
26932 IDXCHN(1,NCHAIN) = IDX
26933 IDXCHN(2,NCHAIN) = ITYPE
26934 ELSE
26935 WRITE(LOUT,*)
26936 & ' CHASTA: inconsistent chain at entry ',IDX
26937 GOTO 21
26938 ENDIF
26939 ENDIF
26940 21 CONTINUE
26941*
26942* write statistics to output unit
26943*
26944 ELSEIF (MODE.EQ.1) THEN
26945C *** Commented by Chiara
26946C WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
26947 DO 31 I=1,10
26948C WRITE(LOUT,'(/,2A)')
26949C & ' -----------------------------------------',
26950C & '------------------------------------'
26951C WRITE(LOUT,'(2A)')
26952C & ' p\\t 21 22 31 32 41',
26953C & ' 42 51 52 61 62'
26954C WRITE(LOUT,'(2A)')
26955C & ' -----------------------------------------',
26956C & '------------------------------------'
26957 DO 32 J=1,10
26958 ITOT(J) = 0
26959 DO 33 K=1,9
26960 ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
26961 33 CONTINUE
26962 32 CONTINUE
26963C *** Commented by Chiara
26964c WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
26965 DO 34 K=1,9
26966 ISUM = 0
26967 DO 35 J=1,10
26968 ISUM = ISUM+ICHCFG(I,J,K,1)
26969 35 CONTINUE
26970C *** Commented by Chiara
26971C IF (ISUM.GT.0)
26972C & WRITE(LOUT,'(1X,A5,2X,10I7)')
26973C & CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
26974 34 CONTINUE
26975C WRITE(LOUT,'(2A)')
26976C & ' -----------------------------------------',
26977C & '-------------------------------'
26978 31 CONTINUE
26979*
26980 ELSE
26981 WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
26982 STOP
26983 ENDIF
26984
26985 RETURN
26986 END
26987*
26988*===pohist=============================================================*
26989*
26990
26991CDECK ID>, PHO_PHIST
26992 SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
26993
26994 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
26995 SAVE
26996
26997 PARAMETER ( LINP = 5 ,
26998 & LOUT = 6 ,
26999 & LDAT = 9 )
27000
27001 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27002
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
27014
27015 ILAB = 0
27016 IF (IMODE.EQ.10) THEN
27017 IMODE = 1
27018 ILAB = 1
27019 ENDIF
27020 IF (ABS(IMODE).LT.1000) THEN
27021* PHOJET-statistics
27022C CALL POHISX(IMODE,WEIGHT)
27023 IF (IMODE.EQ.-1) THEN
27024 MODE = 1
27025 XSTOT(1,1,1) = WEIGHT
27026 ENDIF
27027 IF (IMODE.EQ. 1) MODE = 2
27028 IF (IMODE.EQ.-2) MODE = 3
27029 IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
27030C IF (MODE.EQ.3) WRITE(LOUT,*)
27031C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
27032 CALL DT_HISTOG(MODE)
27033 CALL DT_USRHIS(MODE)
27034 ELSE
27035* DTUNUC-statistics
27036 MODE = IMODE/1000
27037C IF (MODE.EQ.3) WRITE(LOUT,*)
27038C & ' Sigma = ',XSPRO(1,1,1),' mb used for normalization'
27039 CALL DT_HISTOG(MODE)
27040 CALL DT_USRHIS(MODE)
27041 ENDIF
27042
27043 RETURN
27044 END
27045*
27046*===swppho=============================================================*
27047*
27048CDECK ID>, DT_SWPPHO
27049 SUBROUTINE DT_SWPPHO(ILAB)
27050
27051 IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
27052 SAVE
27053
27054 PARAMETER ( LINP = 5 ,
27055 & LOUT = 6 ,
27056 & LDAT = 9 )
27057
27058 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27059
27060 LOGICAL LSTART
27061
27062* event history
27063
27064 PARAMETER (NMXHKK=200000)
27065
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),
27072 & IHIST(2,NMXHKK)
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
27079
27080**PHOJET105a
27081C PARAMETER (NMXHEP=2000)
27082C COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
27083C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
27084C COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
27085C COMMON /PLASAV/ PLAB
27086**PHOJET110
27087
27088C standard particle data interface
27089 INTEGER NMXHEP
27090
27091 PARAMETER (NMXHEP=4000)
27092
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),
27097 & VHEP(4,NMXHEP)
27098C extension to standard particle data interface (PHOJET specific)
27099 INTEGER IMPART,IPHIST,ICOLOR
27100 COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
27101
27102C 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)
27106**
27107 DATA ICOUNT/0/
27108
27109 DATA LSTART /.TRUE./
27110
27111C IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
27112 IF ((IFRAME.EQ.1).AND.LSTART) THEN
27113 UMO = ECM
27114 ELA = ZERO
27115 PLA = ZERO
27116 IDP = IDT_ICIHAD(IFPAP(1))
27117 IDT = IDT_ICIHAD(IFPAP(2))
27118 VIRT = PVIRT(1)
27119 CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
27120 PLAB = PLA
27121 LSTART = .FALSE.
27122 ENDIF
27123
27124 NHKK = 0
27125 ICOUNT = ICOUNT+1
27126C NEVHKK = NEVHEP
27127 NEVHKK = ICOUNT
27128 IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
27129 DO 1 I=3,NHEP
27130 IF (ISTHEP(I).EQ.1) THEN
27131 NHKK = NHKK+1
27132 ISTHKK(NHKK) = 1
27133 IDHKK(NHKK) = IDHEP(I)
27134 JMOHKK(1,NHKK) = 0
27135 JMOHKK(2,NHKK) = 0
27136 JDAHKK(1,NHKK) = 0
27137 JDAHKK(2,NHKK) = 0
27138 DO 2 K=1,4
27139 PHKK(K,NHKK) = PHEP(K,I)
27140 VHKK(K,NHKK) = ZERO
27141 WHKK(K,NHKK) = ZERO
27142 2 CONTINUE
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)
27147 IDRES(NHKK) = 0
27148 IDXRES(NHKK) = 0
27149 NOBAM(NHKK) = 0
27150 IDBAM(NHKK) = IDT_ICIHAD(IDHEP(I))
27151 IDCH(NHKK) = 0
27152 ENDIF
27153 1 CONTINUE
27154
27155 RETURN
27156 END
27157*
27158*===histog=============================================================*
27159*
27160CDECK ID>, DT_HISTOG
27161 SUBROUTINE DT_HISTOG(MODE)
27162
27163************************************************************************
27164* This version dated 25.03.96 is written by S. Roesler *
27165************************************************************************
27166
27167 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27168 SAVE
27169
27170 PARAMETER ( LINP = 5 ,
27171 & LOUT = 6 ,
27172 & LDAT = 9 )
27173
27174 LOGICAL LFSP,LRNL
27175
27176* event history
27177
27178 PARAMETER (NMXHKK=200000)
27179
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),
27186 & IHIST(2,NMXHKK)
27187* event flag used for histograms
27188 COMMON /DTNORM/ ICEVT,IEVHKK
27189* flags for activated histograms
27190 COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
27191
27192 IEVHKK = NEVHKK
27193 GOTO (1,2,3) MODE
27194
27195*------------------------------------------------------------------
27196* initialization
27197 1 CONTINUE
27198 ICEVT = 0
27199 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
27200 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
27201
27202 RETURN
27203*------------------------------------------------------------------
27204* filling of histogram with event-record
27205 2 CONTINUE
27206 ICEVT = ICEVT+1
27207
27208 DO 20 I=1,NHKK
27209 CALL DT_SWPFSP(I,LFSP,LRNL)
27210 IF (LFSP) THEN
27211 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
27212 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
27213 ENDIF
27214 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
27215 20 CONTINUE
27216 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
27217
27218 RETURN
27219*------------------------------------------------------------------
27220* output
27221 3 CONTINUE
27222 IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
27223 IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
27224
27225 RETURN
27226 END
27227*
27228*===swpfsp=============================================================*
27229*
27230CDECK ID>, DT_SWPFSP
27231 SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
27232
27233 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27234 SAVE
27235 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27236 PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
27237 & PI =TWOPI/TWO,
27238 & BOG =TWOPI/360.0D0)
27239
27240* event history
27241
27242 PARAMETER (NMXHKK=200000)
27243
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),
27250 & IHIST(2,NMXHKK)
27251* particle properties (BAMJET index convention)
27252 CHARACTER*8 ANAME
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
27262
ba758f5a 27263 INCLUDE '(DIMPAR)'
27264 INCLUDE '(PAREVT)'
d30b8254 27265
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
27273
27274 LOGICAL LFSP,LRNL
27275
27276 LFSP = .FALSE.
27277 LRNL = .FALSE.
27278 ISTRNL = 1000
27279 MULDEF = 1
27280 IF (LEVPRT) ISTRNL = 1001
27281
27282 IF (ABS(ISTHKK(IDX)).EQ.1) THEN
27283 IST = ISTHKK(IDX)
27284 IDPDG = IDHKK(IDX)
27285 LFRAG = .FALSE.
27286 IF (IDHKK(IDX).LT.80000) THEN
27287 IDBJT = IDBAM(IDX)
27288 IBARY = IIBAR(IDBJT)
27289 ICHAR = IICH(IDBJT)
27290 AMASS = AAM(IDBJT)
27291 ELSEIF (IDHKK(IDX).EQ.80000) THEN
27292 IDBJT = 0
27293 IBARY = IDRES(IDX)
27294 ICHAR = IDXRES(IDX)
27295 AMASS = PHKK(5,IDX)
27296 INUT = IBARY-ICHAR
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.
27302 ELSE
27303 GOTO 9999
27304 ENDIF
27305 PE = PHKK(4,IDX)
27306 PX = PHKK(1,IDX)
27307 PY = PHKK(2,IDX)
27308 PZ = PHKK(3,IDX)
27309 PT2 = PX**2+PY**2
27310 PT = SQRT(PT2)
27311 PTOT = SQRT(PT2+PZ**2)
27312 SINTHE = PT/MAX(PTOT,TINY14)
27313 COSTHE = PZ/MAX(PTOT,TINY14)
27314 IF (COSTHE.GT.ONE) THEN
27315 THETA = ZERO
27316 ELSEIF (COSTHE.LT.-ONE) THEN
27317 THETA = TWOPI/2.0D0
27318 ELSE
27319 THETA = ACOS(COSTHE)
27320 ENDIF
27321 EKIN = PE-AMASS
27322**sr 15.4.96 new E_t-definition
27323 IF (IBARY.GT.0) THEN
27324 ET = EKIN*SINTHE
27325 ELSEIF (IBARY.LT.0) THEN
27326 ET = (EKIN+TWO*AMASS)*SINTHE
27327 ELSE
27328 ET = PE*SINTHE
27329 ENDIF
27330**
27331 XLAB = PZ/MAX(PPROJ,TINY14)
27332C XLAB = PE/MAX(EPROJ,TINY14)
27333 BETA = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
27334 & *(ONE+AMASS/MAX(PE,TINY14)) ))
27335 PPLUS = PE+PZ
27336 PMINUS = PE-PZ
27337 IF (PMINUS.GT.TINY14) THEN
27338 YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
27339 ELSE
27340 YY = 100.0D0
27341 ENDIF
27342 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27343 ETA = -LOG(TAN(THETA/TWO))
27344 ELSE
27345 ETA = 100.0D0
27346 ENDIF
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))
27353 ELSE
27354 YYCMS = 100.0D0
27355 ENDIF
27356 PTOTCM = SQRT(PT2+PZCMS**2)
27357 COSTH = PZCMS/MAX(PTOTCM,TINY14)
27358 IF (COSTH.GT.ONE) THEN
27359 THECMS = ZERO
27360 ELSEIF (COSTH.LT.-ONE) THEN
27361 THECMS = TWOPI/2.0D0
27362 ELSE
27363 THECMS = ACOS(COSTH)
27364 ENDIF
27365 IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
27366 ETACMS = -LOG(TAN(THECMS/TWO))
27367 ELSE
27368 ETACMS = 100.0D0
27369 ENDIF
27370 XF = PZCMS/MAX(PPCM,TINY14)
27371 THECMS = THECMS/BOG
27372 ELSE
27373 PZCMS = PZ
27374 EECMS = PE
27375 YYCMS = YY
27376 ETACMS = ETA
27377 XF = XLAB
27378 THECMS = THETA/BOG
27379 ENDIF
27380 THETA = THETA/BOG
27381
27382* set flag for "grey/black"
27383 LGREY = .FALSE.
27384 LBLACK = .FALSE.
27385 EK = EKIN
27386 IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
27387 IF (MULDEF.EQ.1) THEN
27388* EMU01-Def.
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) ) )
27403 & LGREY = .TRUE.
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) ) )
27412 & LBLACK = .TRUE.
27413 ELSE
27414* common Def.
27415 IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
27416 IF (BETA.LE.0.23D0) LBLACK=.TRUE.
27417 ENDIF
27418 LFSP = .TRUE.
27419 ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
27420 IST = ISTHKK(IDX)
27421 IDPDG = IDHKK(IDX)
27422 LFRAG = .TRUE.
27423 IDBJT = 0
27424 IBARY = IDRES(IDX)
27425 ICHAR = IDXRES(IDX)
27426 AMASS = PHKK(5,IDX)
27427 PE = PHKK(4,IDX)
27428 PX = PHKK(1,IDX)
27429 PY = PHKK(2,IDX)
27430 PZ = PHKK(3,IDX)
27431 PT2 = PX**2+PY**2
27432 PT = SQRT(PT2)
27433 PTOT = SQRT(PT2+PZ**2)
27434 SINTHE = PT/MAX(PTOT,TINY14)
27435 COSTHE = PZ/MAX(PTOT,TINY14)
27436 IF (COSTHE.GT.ONE) THEN
27437 THETA = ZERO
27438 ELSEIF (COSTHE.LT.-ONE) THEN
27439 THETA = TWOPI/2.0D0
27440 ELSE
27441 THETA = ACOS(COSTHE)
27442 ENDIF
27443 EKIN = PE-AMASS
27444**sr 15.4.96 new E_t-definition
27445C ET = PE*SINTHE
27446 ET = EKIN*SINTHE
27447**
27448 IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
27449 ETA = -LOG(TAN(THETA/TWO))
27450 ELSE
27451 ETA = 100.0D0
27452 ENDIF
27453 THETA = THETA/BOG
27454 LRNL = .TRUE.
27455 ENDIF
27456
27457 9999 CONTINUE
27458 RETURN
27459 END
27460*
27461*===himult=============================================================*
27462*
27463CDECK ID>, DT_HIMULT
27464 SUBROUTINE DT_HIMULT(MODE)
27465
27466************************************************************************
27467* Tables of average energies/multiplicities. *
27468* This version dated 30.08.2000 is written by S. Roesler *
27469************************************************************************
27470
27471 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27472 SAVE
27473
27474 PARAMETER ( LINP = 5 ,
27475 & LOUT = 6 ,
27476 & LDAT = 9 )
27477
27478 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27479
27480 PARAMETER (SWMEXP=1.7D0)
27481
27482 CHARACTER*8 ANAMEH(4)
27483
27484* particle properties (BAMJET index convention)
27485 CHARACTER*8 ANAME
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
27500
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 '/
27505
27506 GOTO (1,2,3) MODE
27507
27508*------------------------------------------------------------------
27509* initialization
27510 1 CONTINUE
27511 DO 10 I=1,NOPART
27512 DO 11 J=1,4
27513 AVMULT(J,I) = ZERO
27514 AVE(J,I) = ZERO
27515 AVSWM(J,I) = ZERO
27516 AVPT(J,I) = ZERO
27517 IAVPT(J,I) = 0
27518 11 CONTINUE
27519 10 CONTINUE
27520
27521 RETURN
27522
27523*------------------------------------------------------------------
27524* filling of histogram with event-record
27525 2 CONTINUE
27526 IF (PE.LT.0.0D0) THEN
27527 WRITE(LOUT,*) ' HIMULT: PE < 0 ! ',PE
27528 RETURN
27529 ENDIF
27530 IF (.NOT.LFRAG) THEN
27531 IVEL = 2
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
27568 ENDIF
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
27580 ENDIF
27581 ENDIF
27582 ENDIF
27583
27584 RETURN
27585
27586*------------------------------------------------------------------
27587* output
27588 3 CONTINUE
27589 WRITE(LOUT,3000)
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.'
27595 ELSE
27596 BETGRE = 0.7D0
27597 BETBLC = 0.23D0
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,/)
27601 ENDIF
27602 WRITE(LOUT,3003) SWMEXP
27603 3003 FORMAT(1X,'particle |',12X,'average multiplicity',/,
27604 & 13X,'| total fast',
27605C & ' grey black K f(',F3.1,')',/,1X,
27606 & ' grey black <pt> f(',F3.1,')',/,1X,
27607 & '------------+--------------',
27608 & '-------------------------------------------------')
27609 DO 30 I=1,NOPART
27610 DO 31 J=1,4
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
27615 31 CONTINUE
27616 IF (I.LE.115) THEN
27617 WRITE(LOUT,3004) ANAME(I),I,
27618 & AVMULT(1,I),AVMULT(2,I),
27619 & AVMULT(3,I),AVMULT(4,I),
27620C & 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),
27626C & AVE(1,I),AVSWM(1,I)
27627 & AVPT(1,I),AVSWM(1,I)
27628 ENDIF
27629 3004 FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
27630 30 CONTINUE
27631**temporary
27632C WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
27633C & AVMULT(3,27)+AVMULT(4,27)
27634**
27635
27636 RETURN
27637 END
27638*
27639*===histat=============================================================*
27640*
27641CDECK ID>, DT_HISTAT
27642 SUBROUTINE DT_HISTAT(IDX,MODE)
27643
27644************************************************************************
27645* This version dated 26.02.96 is written by S. Roesler *
27646************************************************************************
27647
27648 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27649 SAVE
27650
27651 PARAMETER ( LINP = 5 ,
27652 & LOUT = 6 ,
27653 & LDAT = 9 )
27654
27655 PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
27656 PARAMETER (NDIM=199)
27657
27658* event history
27659
27660 PARAMETER (NMXHKK=200000)
27661
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),
27668 & IHIST(2,NMXHKK)
27669* particle properties (BAMJET index convention)
27670 CHARACTER*8 ANAME
27671 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27672 & IICH(210),IIBAR(210),K1(210),K2(210)
27673
27674 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27675
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),
27689 & NCOMPO,IEMUL
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),
27703 & NEVAFI(2,2)
27704* parameter for intranuclear cascade
27705 LOGICAL LPAULI
27706 COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
27707
ba758f5a 27708 INCLUDE '(DIMPAR)'
27709 INCLUDE '(PAREVT)'
27710 INCLUDE '(FRBKCM)'
27711 INCLUDE '(EVAPAR)'
d30b8254 27712
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
27724
27725 DIMENSION EMUSAM(NCOMPX)
27726
27727 CHARACTER*13 CMSG(3)
27728 DATA CMSG /'not requested','not requested','not requested'/
27729
27730 GOTO (1,2,3,4,5) MODE
27731
27732*------------------------------------------------------------------
27733* initialization
27734 1 CONTINUE
27735* emulsion treatment
27736 IF (NCOMPO.GT.0) THEN
27737 DO 10 I=1,NCOMPX
27738 EMUSAM(I) = ZERO
27739 10 CONTINUE
27740 ENDIF
27741* common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
27742 NINCGE = 0
27743 DO 11 I=1,2
27744 EXCDPM(I) = ZERO
27745 EXCDPM(I+2) = ZERO
27746 EXCEVA(I) = ZERO
27747 NINCWO(I) = 0
27748 NINCEV(I) = 0
27749 NRESTO(I) = 0
27750 NRESPR(I) = 0
27751 NRESNU(I) = 0
27752 NRESBA(I) = 0
27753 NRESPB(I) = 0
27754 NRESCH(I) = 0
27755 NRESEV(I) = 0
27756 NRESEV(I+2) = 0
27757 NEVAGA(I) = 0
27758 NEVAHT(I) = 0
27759 NEVAFI(1,I) = 0
27760 NEVAFI(2,I) = 0
27761 DO 12 J=1,6
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
27765 NEVA(I,J) = 0
27766 12 CONTINUE
27767 DO 13 J=1,210
27768 NEVAHY(1,I,J) = 0
27769 NEVAHY(2,I,J) = 0
27770 13 CONTINUE
27771 11 CONTINUE
27772 MAXGEN = 0
27773**dble Po statistics.
27774 KPOPO = 0
27775
27776 RETURN
27777*------------------------------------------------------------------
27778* filling of histogram with event-record
27779 2 CONTINUE
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
27797 ENDIF
27798 ENDIF
27799 ELSE
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
27804 ENDIF
27805 ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
27806 IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
27807 ENDIF
27808
27809 RETURN
27810*------------------------------------------------------------------
27811* output
27812 3 CONTINUE
27813
27814**dble Po statistics.
27815C WRITE(LOUT,'(1X,A,2I7,2E12.4)')
27816C & '# evts. / # dble-Po. evts / s_in / s_popo :',
27817C & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
27818
27819* emulsion treatment
27820 IF (NCOMPO.GT.0) THEN
27821 WRITE(LOUT,3000)
27822 3000 FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
27823 & 22X,'----------------------------',/,/,19X,
27824 & 'mass charge fraction',/,39X,
27825 & 'input treated',/)
27826 DO 30 I=1,NCOMPO
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)
27830 30 CONTINUE
27831 ENDIF
27832
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)
27842 ICEV1 = ICEV
27843 IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
27844 WRITE(LOUT,3002)
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,/)
27872
27873 WRITE(LOUT,3004)
27874 3004 FORMAT(/,22X,'1) before evaporation-step:',/)
27875 ICEV = MAX(NRESEV(2),1)
27876 WRITE(LOUT,3005)
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,/,/)
27892
27893* evaporation / fission / fragmentation statistics: output
27894 ICEV = MAX(NRESEV(2),1)
27895 ICEV1 = MAX(NRESEV(4),1)
27896 NTEVA1 =
27897 & NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
27898 NTEVA2 =
27899 & NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
27900 IF (LEVPRT) THEN
27901 IF (IFISS.EQ.1) CMSG(1) = 'requested '
27902 IF (LFRMBK) CMSG(2) = 'requested '
27903 IF (LDEEXG) CMSG(3) = 'requested '
27904 WRITE(LOUT,3006)
27905 & CMSG,
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,'%)',/)
27933 ENDIF
27934C IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
27935C WRITE(LOUT,3008)
27936C3008 FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
27937C & ' proj. / target',/)
27938C DO 31 I=1,210
27939C IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
27940C WRITE(LOUT,3009) I,
27941C & (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27942C3009 FORMAT(38X,I3,3X,2E12.3)
27943C ENDIF
27944C 31 CONTINUE
27945C WRITE(LOUT,3010)
27946C3010 FORMAT(1X,'heavy fragments - statistics:',7X,'mass ',
27947C & ' proj. / target',/)
27948C DO 32 I=1,210
27949C IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
27950C WRITE(LOUT,3011) I,
27951C & (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
27952C3011 FORMAT(38X,I3,3X,2E12.3)
27953C ENDIF
27954C 32 CONTINUE
27955C WRITE(LOUT,*)
27956C ENDIF
27957 ELSE
27958 WRITE(LOUT,3012)
27959 3012 FORMAT(22X,'2) after evaporation-step:',/,/,1X,
27960 & 'Evaporation: not requested',/)
27961 ENDIF
27962
27963 RETURN
27964*------------------------------------------------------------------
27965* filling of histogram with event-record
27966 4 CONTINUE
27967* emulsion treatment
27968 IF (NCOMPO.GT.0) THEN
27969 DO 40 I=1,NCOMPO
27970 IF (IT.EQ.IEMUMA(I)) THEN
27971 EMUSAM(I) = EMUSAM(I)+ONE
27972 ENDIF
27973 40 CONTINUE
27974 ENDIF
27975 NINCGE = NINCGE+MAXGEN
27976 MAXGEN = 0
27977**dble Po statistics.
27978 IF (IPOPO.EQ.1) KPOPO = KPOPO+1
27979
27980 RETURN
27981*------------------------------------------------------------------
27982* filling of histogram with event-record
27983 5 CONTINUE
27984 IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
27985 IB = IIBAR(IDBAM(IDX))
27986 IC = IICH(IDBAM(IDX))
27987 J = ISTHKK(IDX)-14
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
27996 ENDIF
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
28002 IB = IDRES(IDX)
28003 IC = IDXRES(IDX)
28004 IF (IC.GT.0) 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
28007 ENDIF
28008 NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
28009 ENDIF
28010
28011 RETURN
28012 END
28013*
28014*===newhgr=============================================================*
28015*
28016CDECK ID>, DT_NEWHGR
28017 SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
28018
28019************************************************************************
28020* *
28021* Histogram initialization. *
28022* *
28023* input: XLIM1/XLIM2 lower/upper edge of histogram-window *
28024* XLIM3 bin size *
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 *
28030* *
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 *
28035* *
28036* *
28037* output: IREFN histogram index *
28038* (= -1 for inconsistent histogr. request) *
28039* *
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************************************************************************
28043
28044 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28045 SAVE
28046
28047 PARAMETER ( LINP = 5 ,
28048 & LOUT = 6 ,
28049 & LDAT = 9 )
28050
28051 LOGICAL LSTART
28052
28053 PARAMETER (ZERO = 0.0D0,
28054 & TINY = 1.0D-10)
28055
28056 DIMENSION XLIMB(*)
28057
28058* histograms
28059
28060 PARAMETER (NHIS=150, NDIM=250)
28061
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)
28066
28067 DATA LSTART /.TRUE./
28068
28069* reset histogram counter
28070 IF (LSTART.OR.(IBIN.EQ.-1)) THEN
28071 IHISL = 0
28072 IF (IBIN.EQ.-1) RETURN
28073 LSTART = .FALSE.
28074 ENDIF
28075
28076 IHIS = IHISL+1
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!')
28083 GOTO 9999
28084 ENDIF
28085
28086 IREFN = IHIS
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)
28094 IBINS(IHIS) = NDIM
28095 ENDIF
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!')
28100 GOTO 9999
28101 ENDIF
28102
28103* initialize arrays
28104 DO 1 I=1,NDIM
28105 DO 2 K=1,3
28106 HIST(K,IHIS,I) = ZERO
28107 HIST(K+3,IHIS,I) = ZERO
28108 TMPHIS(K,IHIS,I) = ZERO
28109 2 CONTINUE
28110 HIST(7,IHIS,I) = ZERO
28111 1 CONTINUE
28112 DENTRY(1,IHIS)= ZERO
28113 DENTRY(2,IHIS)= ZERO
28114 OVERF(IHIS) = ZERO
28115 UNDERF(IHIS) = ZERO
28116 TMPUFL(IHIS) = ZERO
28117 TMPOFL(IHIS) = ZERO
28118
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
28123 3 CONTINUE
28124 ISWI(IHIS) = 1
28125* bin str. sensitive to lower/upper edge and numb. of bins
28126 ELSEIF (XLIM3.EQ.ZERO) THEN
28127* linear binning
28128 IF (IBIN.GT.0) THEN
28129 XLOW = XLIM1
28130 XHI = XLIM2
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,')')
28135 GOTO 9999
28136 ENDIF
28137 ISWI(IHIS) = 1
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,')')
28144 GOTO 9999
28145 ENDIF
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,')')
28150 GOTO 9999
28151 ENDIF
28152 XLOW = LOG10(XLIM1)
28153 XHI = LOG10(XLIM2)
28154 ISWI(IHIS) = 3
28155 ENDIF
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
28159 4 CONTINUE
28160 ELSE
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)
28165 ISWI(IHIS) = 2
28166 ELSEIF (IBIN.LT.-1) THEN
28167 HIST(1,IHIS,K) = LOG10(XLIMB(K))
28168 ISWI(IHIS) = 4
28169 ENDIF
28170 5 CONTINUE
28171 ENDIF
28172
28173* histogram accepted
28174 IHISL = IHIS
28175
28176 RETURN
28177
28178 9999 CONTINUE
28179 IREFN = -1
28180 RETURN
28181 END
28182*
28183*===filhgr=============================================================*
28184*
28185CDECK ID>, DT_FILHGR
28186 SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
28187
28188************************************************************************
28189* *
28190* Scoring for histogram IHIS. *
28191* *
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************************************************************************
28195
28196 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28197 SAVE
28198
28199 PARAMETER ( LINP = 5 ,
28200 & LOUT = 6 ,
28201 & LDAT = 9 )
28202
28203 PARAMETER (ZERO = 0.0D0,
28204 & ONE = 1.0D0,
28205 & TINY = 1.0D-10)
28206
28207* histograms
28208
28209 PARAMETER (NHIS=150, NDIM=250)
28210
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)
28215
28216 DATA NCEVT /1/
28217
28218 X = XI
28219 Y = YI
28220
28221* dump content of temorary arrays into histograms
28222 IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
28223 CALL DT_EVTHIS(IDUM)
28224 NCEVT = NEVT
28225 ENDIF
28226
28227* check histogram index
28228 IF (IHIS.EQ.-1) RETURN
28229 IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
28230C WRITE(LOUT,1000) IHIS,IHISL
28231 1000 FORMAT(1X,'FILHGR: warning! histogram index',I4,
28232 & ' out of range (1..',I3,')')
28233 RETURN
28234 ENDIF
28235
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
28241 I1 = 0
28242 ELSE
28243 I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
28244 ENDIF
28245
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
28250 I1 = 0
28251 ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
28252 I1 = IBINS(IHIS)+1
28253 ELSE
28254* binary sort algorithm
28255 KMIN = 0
28256 KMAX = IBINS(IHIS)+1
28257 1 CONTINUE
28258 IF ((KMAX-KMIN).EQ.1) GOTO 2
28259 KK = (KMAX+KMIN)/2
28260 IF (X.LE.HIST(1,IHIS,KK)) THEN
28261 KMAX=KK
28262 ELSE
28263 KMIN=KK
28264 ENDIF
28265 GOTO 1
28266 2 CONTINUE
28267 I1 = KMIN
28268 ENDIF
28269
28270 ELSE
28271 WRITE(LOUT,1001)
28272 1001 FORMAT(1X,'FILHGR: warning! histogram not initialized')
28273 RETURN
28274 ENDIF
28275
28276* scoring
28277 IF (I1.LE.0) THEN
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
28283 ELSE
28284 TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
28285 ENDIF
28286 TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
28287 ELSE
28288 TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
28289 ENDIF
28290
28291 RETURN
28292 END
28293*
28294*===evthis=============================================================*
28295*
28296CDECK ID>, DT_EVTHIS
28297 SUBROUTINE DT_EVTHIS(NEVT)
28298
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 *
28302* to OUTHGR. *
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************************************************************************
28307
28308 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28309 SAVE
28310
28311 PARAMETER ( LINP = 5 ,
28312 & LOUT = 6 ,
28313 & LDAT = 9 )
28314
28315 LOGICAL LNOETY
28316
28317 PARAMETER (ZERO = 0.0D0,
28318 & ONE = 1.0D0,
28319 & TINY = 1.0D-10)
28320
28321* histograms
28322
28323 PARAMETER (NHIS=150, NDIM=250)
28324
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)
28329
28330 DATA NCEVT /0/
28331
28332 NCEVT = NCEVT+1
28333 NEVT = NCEVT
28334
28335 DO 1 I=1,IHISL
28336 LNOETY = .TRUE.
28337 DO 2 J=1,IBINS(I)
28338 IF (TMPHIS(1,I,J).GT.ZERO) THEN
28339 LNOETY = .FALSE.
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
28351 ENDIF
28352 2 CONTINUE
28353 IF (LNOETY) THEN
28354 IF (TMPUFL(I).GT.ZERO) THEN
28355 UNDERF(I) = UNDERF(I)+ONE
28356 TMPUFL(I) = ZERO
28357 ELSEIF (TMPOFL(I).GT.ZERO) THEN
28358 OVERF(I) = OVERF(I)+ONE
28359 TMPOFL(I) = ZERO
28360 ENDIF
28361 ELSE
28362 DENTRY(1,I) = DENTRY(1,I)+ONE
28363 ENDIF
28364 1 CONTINUE
28365
28366 RETURN
28367 END
28368*
28369*===outhgr=============================================================*
28370*
28371CDECK ID>, DT_OUTHGR
28372 SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
28373 & ILOGY,INORM,NMODE)
28374
28375************************************************************************
28376* *
28377* Plot histogram(s) to standard output unit *
28378* *
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 *
28391* = 6 per event *
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 *
28399* *
28400* *
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. *
28404* *
28405* This version dated 23.4.95 is written by S. Roesler. *
28406************************************************************************
28407
28408 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28409 SAVE
28410
28411 PARAMETER ( LINP = 5 ,
28412 & LOUT = 6 ,
28413 & LDAT = 9 )
28414
28415 CHARACTER*72 CHEAD
28416
28417 PARAMETER (ZERO = 0.0D0,
28418 & IZERO = 0,
28419 & ONE = 1.0D0,
28420 & TWO = 2.0D0,
28421 & OHALF = 0.5D0,
28422 & EPS = 1.0D-5,
28423 & TINY = 1.0D-8,
28424 & SMALL = -1.0D8,
28425 & RLARGE = 1.0D8 )
28426
28427* histograms
28428
28429 PARAMETER (NHIS=150, NDIM=250)
28430
28431 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28432 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28433
28434 PARAMETER (NDIM2 = 2*NDIM)
28435 DIMENSION XX(NDIM2),YY(NDIM2)
28436
28437 PARAMETER (NHISTO = 6)
28438 DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
28439 & IDX(NHISTO)
28440
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',
28448 & 'per event ',
28449 & 'per bin entry1 ',
28450 & 'per entry2 and bin width '/
28451
28452 IDX1(1) = I1
28453 IDX1(2) = I2
28454 IDX1(3) = I3
28455 IDX1(4) = I4
28456 IDX1(5) = I5
28457 IDX1(6) = I6
28458
28459 MODE = NMODE
28460
28461* initialization if "wide frame" is requested
28462 IF (ABS(MODE).EQ.2) THEN
28463 DO 1 I=1,NHISTO
28464 DO 2 J=1,NDIM
28465 XX1(J,I) = ZERO
28466 YY1(J,I) = ZERO
28467 2 CONTINUE
28468 1 CONTINUE
28469 ENDIF
28470
28471* plot header
28472 WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
28473
28474* check histogram indices
28475 NHI = 0
28476 DO 3 I=1,NHISTO
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
28480 WRITE(LOUT,1000)
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)
28485 ELSE
28486 NHI = NHI+1
28487 IDX(NHI) = IDX1(I)
28488 ENDIF
28489 ENDIF
28490 ENDIF
28491 3 CONTINUE
28492 IF (NHI.EQ.0) THEN
28493 WRITE(LOUT,1001)
28494 1001 FORMAT(/,1X,'OUTHGR: warning! histogram indices not valid')
28495 RETURN
28496 ENDIF
28497
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,
28506 & 'FAC = ',E11.4)
28507 RETURN
28508 ENDIF
28509
28510 WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
28511
28512* apply normalization
28513 DO 4 N=1,NHI
28514
28515 I = IDX(N)
28516
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)
28523 WRITE(LOUT,1007)
28524 1007 FORMAT(1X,'user defined bin structure')
28525 ELSEIF (ISWI(I).EQ.3) THEN
28526 WRITE(LOUT,1004)
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
28531 WRITE(LOUT,1004)
28532 & I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
28533 WRITE(LOUT,1007)
28534 ELSE
28535 WRITE(LOUT,1008) ISWI(I)
28536 1008 FORMAT(/,1X,'warning! inconsistent bin structure flag ',I4)
28537 ENDIF
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,/)
28543
28544 DO 5 K=1,IBINS(I)
28545 CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
28546 YMEAN = FAC*YMEAN
28547 YERR = FAC*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)
28551* small frame
28552 II = 2*K
28553 XX(II-1) = HIST(1,I,K)
28554 XX(II) = HIST(1,I,K+1)
28555 YY(II-1) = YMEAN
28556 YY(II) = YMEAN
28557* wide frame
28558 XX1(K,N) = XMEAN
28559 IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
28560 & XX1(K,N) = LOG10(XMEAN)
28561 YY1(K,N) = YMEAN
28562 5 CONTINUE
28563
28564* plot small frame
28565 IF (ABS(MODE).EQ.1) THEN
28566 IBIN2 = 2*IBINS(I)
28567 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28568 IF(ILOGY.EQ.1) THEN
28569 CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
28570 ELSE
28571 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28572 ENDIF
28573 ENDIF
28574
28575 4 CONTINUE
28576
28577* plot wide frame
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))
28583 YLOW = RLARGE
28584 YHI = SMALL
28585 DO 6 I=1,NHISTO
28586 DO 7 J=1,NDIM
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)
28590 ELSE
28591 YLOW = YY1(J,I)
28592 ENDIF
28593 ENDIF
28594 IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
28595 7 CONTINUE
28596 6 CONTINUE
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
28602 RETURN
28603 ENDIF
28604 IF (ILOGY.EQ.1) THEN
28605 YLOW = LOG10(YLOW)
28606 DY = (LOG10(YHI)-YLOW)/100.0D0
28607 DO 8 I=1,NHISTO
28608 DO 9 J=1,NDIM
28609 IF (YY1(J,I).LE.ZERO) THEN
28610 YY1(J,I) = YLOW
28611 ELSE
28612 YY1(J,I) = LOG10(YY1(J,I))
28613 ENDIF
28614 9 CONTINUE
28615 8 CONTINUE
28616 ENDIF
28617 CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
28618 ENDIF
28619
28620 RETURN
28621 END
28622*
28623*===getbin=============================================================*
28624*
28625CDECK ID>, DT_GETBIN
28626 SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
28627 & XMEAN,YMEAN,YERR)
28628
28629************************************************************************
28630* This version dated 23.4.95 is written by S. Roesler. *
28631************************************************************************
28632
28633 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28634 SAVE
28635
28636 PARAMETER ( LINP = 5 ,
28637 & LOUT = 6 ,
28638 & LDAT = 9 )
28639
28640 PARAMETER (ZERO = 0.0D0,
28641 & ONE = 1.0D0,
28642 & TINY35 = 1.0D-35)
28643
28644* histograms
28645
28646 PARAMETER (NHIS=150, NDIM=250)
28647
28648 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28649 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28650
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
28654 XLOW = 10**XLOW
28655 XHI = 10**XHI
28656 ENDIF
28657 IF (NORM.EQ.2) THEN
28658 DX = XHI-XLOW
28659 NEVT = INT(DENTRY(1,IHIS))
28660 ELSEIF (NORM.EQ.3) THEN
28661 DX = ONE
28662 NEVT = INT(HIST(2,IHIS,IBIN))
28663 ELSEIF (NORM.EQ.4) THEN
28664 DX = XHI**2-XLOW**2
28665 NEVT = KEVT
28666 ELSEIF (NORM.EQ.5) THEN
28667 DX = LOG(ABS(XHI))-LOG(ABS(XLOW))
28668 NEVT = KEVT
28669 ELSEIF (NORM.EQ.6) THEN
28670 DX = ONE
28671 NEVT = KEVT
28672 ELSEIF (NORM.EQ.7) THEN
28673 DX = ONE
28674 NEVT = INT(HIST(7,IHIS,IBIN))
28675 ELSEIF (NORM.EQ.8) THEN
28676 DX = XHI-XLOW
28677 NEVT = INT(DENTRY(2,IHIS))
28678 ELSE
28679 DX = ABS(XHI-XLOW)
28680 NEVT = KEVT
28681 ENDIF
28682 IF (ABS(DX).LT.TINY35) DX = ONE
28683 NEVT = MAX(NEVT,1)
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
28689C 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
28692
28693 RETURN
28694 END
28695*
28696*===joihis=============================================================*
28697*
28698CDECK ID>, DT_JOIHIS
28699 SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
28700
28701************************************************************************
28702* *
28703* Operation on histograms. *
28704* *
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 *
28710* *
28711* This version dated 23.4.95 is written by S. Roesler. *
28712************************************************************************
28713
28714 IMPLICIT DOUBLE PRECISION(A-H,O-Z)
28715 SAVE
28716
28717 PARAMETER ( LINP = 5 ,
28718 & LOUT = 6 ,
28719 & LDAT = 9 )
28720
28721 CHARACTER COPER*1
28722
28723 PARAMETER (ZERO = 0.0D0,
28724 & ONE = 1.0D0,
28725 & OHALF = 0.5D0,
28726 & TINY8 = 1.0D-8,
28727 & SMALL = -1.0D8,
28728 & RLARGE = 1.0D8 )
28729
28730* histograms
28731
28732 PARAMETER (NHIS=150, NDIM=250)
28733
28734 COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
28735 & UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
28736
28737 PARAMETER (NDIM2 = 2*NDIM)
28738 DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
28739
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',
28747 & 'per event '/
28748
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)
28755 GOTO 9999
28756 ENDIF
28757
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,')')
28764 GOTO 9999
28765 ENDIF
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)
28772 GOTO 9999
28773 ENDIF
28774 1 CONTINUE
28775
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,/)
28781
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)
28785 XLOW = XLOW1
28786 XHI = XHI1
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
28794 YMEAN = ZERO
28795 ELSE
28796 IF (FAC2.EQ.ZERO) FAC2 = ONE
28797 YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
28798 ENDIF
28799 ELSE
28800 GOTO 9998
28801 ENDIF
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)
28805* small frame
28806 II = 2*K
28807 XX(II-1) = HIST(1,IH1,K)
28808 XX(II) = HIST(1,IH1,K+1)
28809 YY(II-1) = YMEAN
28810 YY(II) = YMEAN
28811* wide frame
28812 XX1(K) = XMEAN
28813 IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
28814 YY1(K) = YMEAN
28815 2 CONTINUE
28816
28817* plot small frame
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)
28823 ELSE
28824 CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
28825 ENDIF
28826 ENDIF
28827
28828* plot wide frame
28829 IF (ABS(MODE).EQ.2) THEN
28830 WRITE(LOUT,'(/,1X,A)') 'Preview:'
28831 NSIZE = NDIM
28832 DXLOW = HIST(1,IH1,1)
28833 DDX = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
28834 YLOW = RLARGE
28835 YHI = SMALL
28836 DO 3 I=1,NDIM
28837 IF (YY1(I).LT.YLOW) THEN
28838 IF (ILOGY.EQ.1) THEN
28839 IF (YY1(I).GT.ZERO) YLOW = YY1(I)
28840 ELSE
28841 YLOW = YY1(I)
28842 ENDIF
28843 ENDIF
28844 IF (YY1(I).GT.YHI) YHI = YY1(I)
28845 3 CONTINUE
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
28851 RETURN
28852 ENDIF
28853 IF (ILOGY.EQ.1) THEN
28854 YLOW = LOG10(YLOW)
28855 DY = (LOG10(YHI)-YLOW)/100.0D0
28856 DO 4 I=1,NDIM
28857 IF (YY1(I).LE.ZERO) THEN
28858 YY1(I) = YLOW
28859 ELSE
28860 YY1(I) = LOG10(YY1(I))
28861 ENDIF
28862 4 CONTINUE
28863 ENDIF
28864 CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
28865 ENDIF
28866
28867 RETURN
28868
28869 9998 CONTINUE
28870 WRITE(LOUT,1005) COPER
28871 1005 FORMAT(1X,'JOIHIS: unknown operation ',A)
28872
28873 9999 CONTINUE
28874 RETURN
28875 END
28876*
28877*===qgraph=============================================================*
28878*
28879CDECK ID>, DT_XGRAPH
28880 SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
28881C***********************************************************************
28882C
28883C calculate quasi graphic picture with 25 lines and 79 columns
28884C ranges will be chosen automatically
28885C
28886C input N dimension of input fields
28887C IARG number of curves (fields) to plot
28888C X field of X
28889C Y1 field of Y1
28890C Y2 field of Y2
28891C
28892C This subroutine is written by R. Engel.
28893C***********************************************************************
28894 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28895 SAVE
28896
28897 PARAMETER ( LINP = 5 ,
28898 & LOUT = 6 ,
28899 & LDAT = 9 )
28900
28901C
28902 DIMENSION X(N),Y1(N),Y2(N)
28903 PARAMETER (EPS=1.D-30)
28904 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
28905 CHARACTER SYMB(5)
28906 CHARACTER COL(0:149,0:49)
28907C
28908 DATA SYMB /'0','e','z','#','x'/
28909C
28910 ISPALT=IBREIT-10
28911C
28912C*** automatic range fitting
28913C
28914 XMAX=X(1)
28915 XMIN=X(1)
28916 DO 600 I=1,N
28917 XMAX=MAX(X(I),XMAX)
28918 XMIN=MIN(X(I),XMIN)
28919 600 CONTINUE
28920 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
28921C
28922 ITEST=0
28923 DO 1100 K=0,IZEIL-1
28924 ITEST=ITEST+1
28925 IF (ITEST.EQ.IYRAST) THEN
28926 DO 1010 L=1,ISPALT-1
28927 COL(L,K)='-'
289281010 CONTINUE
28929 COL(ISPALT,K)='+'
28930 ITEST=0
28931 DO 1020 L=0,ISPALT-1,IXRAST
28932 COL(L,K)='+'
289331020 CONTINUE
28934 ELSE
28935 DO 1030 L=1,ISPALT-1
28936 COL(L,K)=' '
289371030 CONTINUE
28938 DO 1040 L=0,ISPALT-1,IXRAST
28939 COL(L,K)='|'
289401040 CONTINUE
28941 COL(ISPALT,K)='|'
28942 ENDIF
289431100 CONTINUE
28944C
28945C*** plot curve Y1
28946C
28947 YMAX=Y1(1)
28948 YMIN=Y1(1)
28949 DO 500 I=1,N
28950 YMAX=MAX(Y1(I),YMAX)
28951 YMIN=MIN(Y1(I),YMIN)
28952500 CONTINUE
28953 IF(IARG.GT.1) THEN
28954 DO 550 I=1,N
28955 YMAX=MAX(Y2(I),YMAX)
28956 YMIN=MIN(Y2(I),YMIN)
28957550 CONTINUE
28958 ENDIF
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'
28965 RETURN
28966 ENDIF
28967C
28968C*** plot curve Y1
28969C
28970 ILAST=-1
28971 LLAST=-1
28972 DO 1200 K=1,N
28973 L=NINT((X(K)-XMIN)/XZOOM)
28974 I=NINT((YMAX-Y1(K))/YZOOM)
28975 IF(ILAST.GE.0) THEN
28976 LD = L-LLAST
28977 ID = I-ILAST
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)
28981 66 CONTINUE
28982 55 CONTINUE
28983 ELSE
28984 COL(L,I)=SYMB(1)
28985 ENDIF
28986 ILAST = I
28987 LLAST = L
289881200 CONTINUE
28989C
28990 IF(IARG.GT.1) THEN
28991C
28992C*** plot curve Y2
28993C
28994 DO 1250 K=1,N
28995 L=NINT((X(K)-XMIN)/XZOOM)
28996 I=NINT((YMAX-Y2(K))/YZOOM)
28997 COL(L,I)=SYMB(2)
289981250 CONTINUE
28999 ENDIF
29000C
29001C*** write it
29002C
29003 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29004C
29005C*** write range of X
29006C
29007 XZOOM = (XMAX-XMIN)/DBLE(7)
29008 WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
29009C
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)
290141300 CONTINUE
29015C
29016C*** write range of X
29017C
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))
29022 END
29023*
29024*===qglogy=============================================================*
29025*
29026CDECK ID>, DT_XGLOGY
29027 SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
29028C***********************************************************************
29029C
29030C calculate quasi graphic picture with 25 lines and 79 columns
29031C logarithmic y axis
29032C ranges will be chosen automatically
29033C
29034C input N dimension of input fields
29035C IARG number of curves (fields) to plot
29036C X field of X
29037C Y1 field of Y1
29038C Y2 field of Y2
29039C
29040C This subroutine is written by R. Engel.
29041C***********************************************************************
29042C
29043 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29044 SAVE
29045
29046 PARAMETER ( LINP = 5 ,
29047 & LOUT = 6 ,
29048 & LDAT = 9 )
29049
29050 DIMENSION X(N),Y1(N),Y2(N)
29051 PARAMETER (EPS=1.D-30)
29052 PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
29053 CHARACTER SYMB(5)
29054 CHARACTER COL(0:149,0:49)
29055 PARAMETER (DEPS = 1.D-10)
29056C
29057 DATA SYMB /'0','e','z','#','x'/
29058C
29059 ISPALT=IBREIT-10
29060C
29061C*** automatic range fitting
29062C
29063 XMAX=X(1)
29064 XMIN=X(1)
29065 DO 600 I=1,N
29066 XMAX=MAX(X(I),XMAX)
29067 XMIN=MIN(X(I),XMIN)
29068 600 CONTINUE
29069 XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
29070C
29071 ITEST=0
29072 DO 1100 K=0,IZEIL-1
29073 ITEST=ITEST+1
29074 IF (ITEST.EQ.IYRAST) THEN
29075 DO 1010 L=1,ISPALT-1
29076 COL(L,K)='-'
290771010 CONTINUE
29078 COL(ISPALT,K)='+'
29079 ITEST=0
29080 DO 1020 L=0,ISPALT-1,IXRAST
29081 COL(L,K)='+'
290821020 CONTINUE
29083 ELSE
29084 DO 1030 L=1,ISPALT-1
29085 COL(L,K)=' '
290861030 CONTINUE
29087 DO 1040 L=0,ISPALT-1,IXRAST
29088 COL(L,K)='|'
290891040 CONTINUE
29090 COL(ISPALT,K)='|'
29091 ENDIF
290921100 CONTINUE
29093C
29094C*** plot curve Y1
29095C
29096 YMAX=Y1(1)
29097 YMIN=MAX(Y1(1),EPS)
29098 DO 500 I=1,N
29099 YMAX =MAX(Y1(I),YMAX)
29100 IF(Y1(I).GT.EPS) THEN
29101 IF(YMIN.EQ.EPS) THEN
29102 YMIN = Y1(I)/10.D0
29103 ELSE
29104 YMIN = MIN(Y1(I),YMIN)
29105 ENDIF
29106 ENDIF
29107500 CONTINUE
29108 IF(IARG.GT.1) THEN
29109 DO 550 I=1,N
29110 YMAX=MAX(Y2(I),YMAX)
29111 IF(Y2(I).GT.EPS) THEN
29112 IF(YMIN.EQ.EPS) THEN
29113 YMIN = Y2(I)
29114 ELSE
29115 YMIN = MIN(Y2(I),YMIN)
29116 ENDIF
29117 ENDIF
29118550 CONTINUE
29119 ENDIF
29120C
29121 DO 560 I=1,N
29122 Y1(I) = MAX(Y1(I),YMIN)
29123 560 CONTINUE
29124 IF(IARG.GT.1) THEN
29125 DO 570 I=1,N
29126 Y2(I) = MAX(Y2(I),YMIN)
29127 570 CONTINUE
29128 ENDIF
29129C
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'
29134 RETURN
29135 ENDIF
29136C
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'
29143 RETURN
29144 ENDIF
29145C
29146C*** plot curve Y1
29147C
29148 ILAST=-1
29149 LLAST=-1
29150 DO 1200 K=1,N
29151 L=NINT((X(K)-XMIN)/XZOOM)
29152 I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
29153 IF(ILAST.GE.0) THEN
29154 LD = L-LLAST
29155 ID = I-ILAST
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)
29159 66 CONTINUE
29160 55 CONTINUE
29161 ELSE
29162 COL(L,I)=SYMB(1)
29163 ENDIF
29164 ILAST = I
29165 LLAST = L
291661200 CONTINUE
29167C
29168 IF(IARG.GT.1) THEN
29169C
29170C*** plot curve Y2
29171C
29172 DO 1250 K=1,N
29173 L=NINT((X(K)-XMIN)/XZOOM)
29174 I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
29175 COL(L,I)=SYMB(2)
291761250 CONTINUE
29177 ENDIF
29178C
29179C*** write it
29180C
29181 WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
29182 WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
29183C
29184C*** write range of X
29185C
29186 XZOOM1 = (XMAX-XMIN)/DBLE(7)
29187 WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
29188C
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)
291931300 CONTINUE
29194C
29195C*** write range of X
29196C
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))
29200C
29201 END
29202*
29203*===plot===============================================================*
29204*
29205CDECK ID>, DT_SRPLOT
29206 SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
29207
29208 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29209 SAVE
29210
29211 PARAMETER ( LINP = 5 ,
29212 & LOUT = 6 ,
29213 & LDAT = 9 )
29214
29215*
29216* initial version
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* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
29223*
29224* Input Variables:
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
29235*
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)
29245*
29246*********************************************************************
29247*
29248 DIMENSION XX(61),YY(61),LL(101,10)
29249 DIMENSION X(N),Y(N),L(40),LOV(40,10)
29250 DATA L/
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 /
29255*
29256*
29257 MN=51
29258 DO 10 I=1,MN
29259 AI=I-1
29260 10 XX(I)=XO+AI*DX
29261 DO 20 I=1,11
29262 AI=I-1
29263 20 YY(I)=YO+10.0D0*AI*DY
29264 WRITE(LOUT, 500) (YY(I),I=1,11)
29265 MMN=MN-1
29266*
29267*
29268 DO 90 JJ=1,MMN,10
29269 JJJ=JJ-1
29270 DO 30 I=1,101
29271 DO 30 J=1,10
29272 30 LL(I,J)=L(40)
29273 DO 40 I=1,101
29274 40 LL(I,1)=L(39)
29275 DO 50 I=1,101,10
29276 DO 50 J=1,10
29277 50 LL(I,J)=L(38)
29278 DO 60 I=1,40
29279 DO 60 J=1,10
29280 60 LOV(I,J)=L(40)
29281*
29282*
29283 DO 70 I=1,M
29284 DO 70 J=1,MM
29285 II=J+(I-1)*MM
29286 AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
29287 AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
29288 AIX=AIX-DBLE(JJJ)
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
29292 IX=INT(AIX)
29293 IY=INT(AIY)
29294 IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
29295 + THEN
29296 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
29297 + =LL(IY,IX)
29298 LL(IY,IX)=L(I)
29299 ENDIF
29300 ENDIF
29301 70 CONTINUE
29302*
29303*
29304 DO 80 I=1,10
29305 II=I+JJJ
29306 III=II+1
29307 WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
29308 & (LOV(J,I),J=1,10)
29309 80 CONTINUE
29310 90 CONTINUE
29311*
29312*
29313 WRITE(LOUT, 520)
29314 WRITE(LOUT, 500) (YY(I),I=1,11)
29315 RETURN
29316*
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')
29320 END
29321*
29322*===defset=============================================================*
29323*
29324CDECK ID>, DT_DEFSET
29325 BLOCK DATA DT_DEFSET
29326
29327 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29328 SAVE
29329
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
29334
29335 PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29336
29337* emulsion treatment
29338 COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29339 & NCOMPO,IEMUL
29340
29341* / DTFLG1 /
29342 DATA IFRAG / 2, 1 /
29343 DATA IRESCO / 1 /
29344 DATA IMSHL / 1 /
29345 DATA IRESRJ / 0 /
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. /
29352 DATA IFRAME / 1 /
29353* Introduced by Chiara -> Forcing CMS-system
29354* DATA IFRAME / 2 /
29355 DATA ITRSPT / 0 /
29356
29357* / DTCOMP /
29358 DATA EMUFRA / NCOMPX*0.0D0 /
29359 DATA IEMUMA / NCOMPX*1 /
29360 DATA IEMUCH / NCOMPX*1 /
29361 DATA NCOMPO / 0 /
29362 DATA IEMUL / 0 /
29363
29364 END
29365*
29366*
29367*===hadprp=============================================================*
29368*
29369CDECK ID>, DT_HADPRP
29370 BLOCK DATA DT_HADPRP
29371
29372 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29373 SAVE
29374
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),
29382 & IAMCIN(210)
29383* names of hadrons used in input-cards
29384 CHARACTER*8 BTYPE
29385 COMMON /DTPAIN/ BTYPE(30)
29386
29387* / DTQUAR /
29388*----------------------------------------------------------------------*
29389* *
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 *
29404* *
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 *
29410* Iqcchr = charm *
29411* Iquchr = beauty *
29412* Iqtchr = ...... *
29413* *
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 /
29422 DATA MQUARK /
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 /
29431
29432* / DTHAIC /
29433* (renamed) (HAdron InDex COnversion)
29434* translation table version filled up by r.e. 25.01.94 *
29435 DATA IAMCIN /
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,
29444 &5*99999, 5*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,
29452 &5*99999, 5*99999,
29453 &10*99999,
29454 &5*99999 , 20211,20111,-20211,99999,20321,
29455 &-20321,20311,-20311,7*99999 ,
29456 &7*99999,12212,12112,99999/
29457
29458* / DTHAIC /
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,
29507 & 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,
29511 & 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,
29519 & 192, 208, 209/
29520
29521* / DTPAIN /
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' ,
29529 &'BLANK ' /
29530
29531 END
29532*
29533*===blkd46=============================================================*
29534*
29535CDECK ID>, DT_BLKD46
29536 BLOCK DATA DT_BLKD46
29537
29538 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29539 SAVE
29540
29541 PARAMETER ( AMELCT = 0.51099906 D-03 )
29542 PARAMETER ( AMMUON = 0.105658389 D+00 )
29543
29544* particle properties (BAMJET index convention)
29545 CHARACTER*8 ANAME
29546 COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29547 & IICH(210),IIBAR(210),K1(210),K2(210)
29548
29549* / DTPART /
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,
29607 & 70*.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,
29617 & 40*.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) /
29631 & 30*.0000D+00,
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,
29653 & 50*.0000D+00,
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/
29665* Particle names
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,
29751* 50
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,
29755* 85
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,
29766 & 590, 596, 602 /
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,
29772* 50
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,
29776* 85
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 /
29788
29789 END
29790*
29791*===blkd47=============================================================*
29792*
29793CDECK ID>, DT_BLKD47
29794 BLOCK DATA DT_BLKD47
29795
29796 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29797 SAVE
29798
29799* HADRIN: decay channel information
29800 PARAMETER (IDMAX9=602)
29801 CHARACTER*8 ZKNAME
29802 COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
29803
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 /
30049C
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,
30191 & 110*0 /
30192 DATA (NZK(K,3),K=171,340) /
30193 & 80*0,
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,
30199 & 30*0,
30200 & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
30201 DATA (NZK(K,3),K=341,510) /
30202 & 30*0,
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,
30209 & 80*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/
30216
30217 END
30218
30219*
30220*====phoini============================================================*
30221*
30222CDECK ID>, DT_XHOINI
30223 SUBROUTINE DT_XHOINI
30224C SUBROUTINE DT_PHOINI
30225
30226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30227 SAVE
30228
30229 PARAMETER ( LINP = 5 ,
30230 & LOUT = 6 ,
30231 & LDAT = 9 )
30232
30233 RETURN
30234 END
30235*
30236*====eventb============================================================*
30237*
30238CDECK ID>, DT_XVENTB
30239 SUBROUTINE DT_XVENTB(NCSY,IREJ)
30240C SUBROUTINE DT_EVENTB(NCSY,IREJ)
30241
30242 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30243 SAVE
30244
30245 PARAMETER ( LINP = 5 ,
30246 & LOUT = 6 ,
30247 & LDAT = 9 )
30248
30249 WRITE(LOUT,1000)
30250 1000 FORMAT(1X,'EVENTB: PHOJET-package requested but not linked!')
30251 STOP
30252
30253 END
30254*
30255*===event==============================================================*
30256*
30257CDECK ID>, DT_XVENT
30258 SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
30259C SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
30260
30261 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30262 SAVE
30263
30264 DIMENSION PP(4),PT(4)
30265
30266 RETURN
30267 END
30268*
30269*===pohisx=============================================================*
30270*
30271CDECK ID>, DT_XOHISX
30272 SUBROUTINE DT_XOHISX(I,X)
30273C SUBROUTINE POHISX(I,X)
30274
30275 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30276 SAVE
30277
30278 RETURN
30279 END
30280*
30281*===poluhi=============================================================*
30282*
30283**PHOJET105a
30284C SUBROUTINE XOLUHI(I,X)
30285**PHOJET112
30286
30287CDECK ID>, PHO_LHIST
30288 SUBROUTINE PHO_LHIST(I,X)
30289
30290**
30291
30292 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30293 SAVE
30294
30295 RETURN
30296 END
30297*
30298CDECK ID>, PDFSET
30299C**********************************************************************
30300C
30301C dummy subroutines, remove to link PDFLIB
30302C
30303C**********************************************************************
30304 SUBROUTINE PDFSET(PARAM,VALUE)
30305 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30306 DIMENSION PARAM(20),VALUE(20)
30307 CHARACTER*20 PARAM
30308 END
30309CDECK ID>, STRUCTM
30310 SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30311 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30312 END
30313CDECK ID>, STRUCTP
30314 SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
30315 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30316 END
30317*
30318*===diqbrk=============================================================*
30319*
30320CDECK ID>, DT_DIQBRK
30321 SUBROUTINE DT_XIQBRK
30322C SUBROUTINE DT_DIQBRK
30323
30324 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30325 SAVE
30326
30327 STOP 'diquark-breaking not implemeted !'
30328
30329 RETURN
30330 END
30331*
30332*===pho_rndm===========================================================*
30333*
30334CDECK ID>, PHO_RNDM
30335 DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
30336
30337 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30338 SAVE
30339
30340 PHO_RNDM = DT_RNDM(DUMMY)
30341
30342 RETURN
30343 END
30344*
30345*===pyr================================================================*
30346*
30347CDECK ID>, PYR
30348 DOUBLE PRECISION FUNCTION PYR(IDUMMY)
30349
30350 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30351 SAVE
30352
30353 DUMMY = DBLE(IDUMMY)
30354 PYR = DT_RNDM(DUMMY)
30355
30356 RETURN
30357 END
30358*
30359*===elhain=============================================================*
30360*
30361CDECK ID>, DT_ELHAIN
30362 SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
30363
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************************************************************************
30369
30370 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30371 SAVE
30372
30373 PARAMETER ( LINP = 5 ,
30374 & LOUT = 6 ,
30375 & LDAT = 9 )
30376
30377 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30378 & TINY10=1.0D-10)
30379
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)
30384
30385* particle properties (BAMJET index convention)
30386 CHARACTER*8 ANAME
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
30393
30394C DATA TSLOPE /10.0D0/
30395
30396 IREJ = 0
30397
30398 1 CONTINUE
30399
30400 PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
30401 EKIN = ELAB-AAM(IP)
30402* kinematical quantities in cms of the hadrons
30403 AMP2 = AAM(IP)**2
30404 AMT2 = AAM(IT)**2
30405 S = AMP2+AMT2+TWO*ELAB*AAM(IT)
30406 ECM = SQRT(S)
30407 ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
30408 PCM = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
30409
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
30414* nn into pp
30415 IF (IT.EQ.1) THEN
30416 KPROJ = IP
30417 ELSE
30418 KPROJ = 8
30419 IF (IP.EQ.8) KPROJ = 1
30420 ENDIF
30421 CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
30422 T = TWO*PCM**2*(CTCMS-ONE)
30423
30424* very crude treatment otherwise: sample t from exponential dist.
30425 ELSE
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)
30431 ELSE
30432 TSLOPE = BLOWM+RR*(BHIM-BLOWM)
30433 ENDIF
30434 FMAX = EXP(-TSLOPE*TMAX)-ONE
30435 R = DT_RNDM(RR)
30436 T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
30437 IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
30438 ENDIF
30439
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
30444C WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
30445 GOTO 1
30446 ENDIF
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))
30464* fill /HNFSPA/
30465 IRH = 2
30466 ITRH(1) = IP
30467 ITRH(2) = IT
30468
30469 RETURN
30470 END
30471*
30472*===tsamcs=============================================================*
30473*
30474CDECK ID>, DT_TSAMCS
30475 SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
30476
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************************************************************************
30483
30484 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30485 SAVE
30486
30487 PARAMETER ( LINP = 5 ,
30488 & LOUT = 6 ,
30489 & LDAT = 9 )
30490
30491 PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
30492 & TINY10=1.0D-10)
30493
30494 DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
30495 DIMENSION PDCI(60),PDCH(55)
30496
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/
30539
30540 DATA PDCI /
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/
30553
30554 DATA PDCH /
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/
30566
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/
30598
30599 DATA DCHNA /
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,
30607 & 1.000D+00/
30608
30609 DATA DCHNB /
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/
30622
30623 CST = ONE
30624 IF (EKIN.GT.3.5D0) RETURN
30625C
30626 IF(KPROJ.EQ.8) GOTO 101
30627 IF(KPROJ.EQ.1) GOTO 102
30628C* INVALID REACTION
30629 WRITE(LOUT,'(A,I5/A)')
30630 & ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
30631 & ' COS(THETA) = 1D0 RETURNED'
30632 RETURN
30633C-------------------------------- NP ELASTIC SCATTERING----------
30634101 CONTINUE
30635 IF (EKIN.GT.0.740D0)GOTO 1000
30636 IF (EKIN.LT.0.300D0)THEN
30637C EKIN .LT. 300 MEV
30638 IDAT=1
30639 ELSE
30640C 300 MEV < EKIN < 740 MEV
30641 IDAT=6
30642 END IF
30643C
30644 ENER=EKIN
30645 IE=INT(ABS(ENER/0.020D0))
30646 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30647C FORWARD/BACKWARD DECISION
30648 K=IDAT+5*IE
30649 BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30650 IF (DT_RNDM(CST).LT.BWFW)THEN
30651 VALUE2=-1D0
30652 K=K+1
30653 ELSE
30654 VALUE2=1D0
30655 K=K+3
30656 END IF
30657C
30658 COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
30659 RND=DT_RNDM(COEF)
30660C
30661 IF(RND.LT.COEF)THEN
30662 CST=DT_RNDM(RND)
30663 CST=CST*VALUE2
30664 ELSE
30665 R1=DT_RNDM(CST)
30666 R2=DT_RNDM(R1)
30667 R3=DT_RNDM(R2)
30668 R4=DT_RNDM(R3)
30669C
30670 IF(VALUE2.GT.0.0)THEN
30671 CST=MAX(R1,R2,R3,R4)
30672 GOTO 1500
30673 ELSE
30674 R5=DT_RNDM(R4)
30675C
30676 IF (IDAT.EQ.1)THEN
30677 CST=-MAX(R1,R2,R3,R4,R5)
30678 ELSE
30679 R6=DT_RNDM(R5)
30680 R7=DT_RNDM(R6)
30681 CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
30682 END IF
30683C
30684 END IF
30685C
30686 END IF
30687C
30688 GOTO 1500
30689C
30690C******** EKIN .GT. 0.74 GEV
30691C
306921000 ENER=EKIN - 0.66D0
30693C IE=ABS(ENER/0.02)
30694 IE=INT(ENER/0.02D0)
30695 EMEV=EKIN*1D3
30696C
30697 UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
30698 K=IE
30699 BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
30700 RND=DT_RNDM(BWFW)
30701C FORWARD NEUTRON
30702 IF (RND.GE.BWFW)THEN
30703 DO 1200 K=10,36,9
30704 IF (DCHNA(K).GT.EMEV) THEN
30705 UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
30706 UNIV=DT_RNDM(UNIVE)
30707 DO 1100 I=1,8
30708 II=K+I
30709 P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
30710C
30711 IF (P.GT.UNIV)THEN
30712 UNIV=DT_RNDM(UNIVE)
30713 FLTI=DBLE(I)-UNIV
30714 GOTO(290,290,290,290,330,340,350,360) I
30715 END IF
30716 1100 CONTINUE
30717 END IF
30718 1200 CONTINUE
30719C
30720 ELSE
30721C BACKWARD NEUTRON
30722 DO 1400 K=13,60,12
30723 IF (DCHNB(K).GT.EMEV) THEN
30724 UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
30725 UNIV=DT_RNDM(UNIVE)
30726 DO 1300 I=1,11
30727 II=K+I
30728 P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
30729C
30730 IF (P.GT.UNIV)THEN
30731 UNIV=DT_RNDM(P)
30732 FLTI=DBLE(I)-UNIV
30733 GOTO(120,120,140,150,160,160,180,190,200,210,220) I
30734 END IF
30735 1300 CONTINUE
30736 END IF
30737 1400 CONTINUE
30738 END IF
30739C
30740120 CST=1.0D-2*FLTI-1.0D0
30741 GOTO 1500
30742140 CST=2.0D-2*UNIV-0.98D0
30743 GOTO 1500
30744150 CST=4.0D-2*UNIV-0.96D0
30745 GOTO 1500
30746160 CST=6.0D-2*FLTI-1.16D0
30747 GOTO 1500
30748180 CST=8.0D-2*UNIV-0.80D0
30749 GOTO 1500
30750190 CST=1.0D-1*UNIV-0.72D0
30751 GOTO 1500
30752200 CST=1.2D-1*UNIV-0.62D0
30753 GOTO 1500
30754210 CST=2.0D-1*UNIV-0.50D0
30755 GOTO 1500
30756220 CST=3.0D-1*(UNIV-1.0D0)
30757 GOTO 1500
30758C
30759290 CST=1.0D0-2.5d-2*FLTI
30760 GOTO 1500
30761330 CST=0.85D0+0.5D-1*UNIV
30762 GOTO 1500
30763340 CST=0.70D0+1.5D-1*UNIV
30764 GOTO 1500
30765350 CST=0.50D0+2.0D-1*UNIV
30766 GOTO 1500
30767360 CST=0.50D0*UNIV
30768C
307691500 RETURN
30770C
30771C----------------------------------- PP ELASTIC SCATTERING -------
30772C
30773 102 CONTINUE
30774 EMEV=EKIN*1D3
30775C
30776 IF (EKIN.LE.0.500D0) THEN
30777 RND=DT_RNDM(EMEV)
30778 CST=2.0D0*RND-1.0D0
30779 RETURN
30780C
30781 ELSEIF (EKIN.LT.1.0D0) THEN
30782 DO 2200 K=13,60,12
30783 IF (PDCI(K).GT.EMEV) THEN
30784 UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
30785 UNIV=DT_RNDM(UNIVE)
30786 SUM=0
30787 DO 2100 I=1,11
30788 II=K+I
30789 SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
30790C
30791 IF (UNIV.LT.SUM)THEN
30792 UNIV=DT_RNDM(SUM)
30793 FLTI=DBLE(I)-UNIV
30794 GOTO(55,55,55,60,60,65,65,65,65,70,70) I
30795 END IF
30796 2100 CONTINUE
30797 END IF
30798 2200 CONTINUE
30799 ELSE
30800 DO 2400 K=12,55,11
30801 IF (PDCH(K).GT.EMEV) THEN
30802 UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
30803 UNIV=DT_RNDM(UNIVE)
30804 SUM=0.0D0
30805 DO 2300 I=1,10
30806 II=K+I
30807 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
30808C
30809 IF (UNIV.LT.SUM)THEN
30810 UNIV=DT_RNDM(SUM)
30811 FLTI=UNIV+DBLE(I)
30812 GOTO(50,55,60,60,65,65,65,65,70,70) I
30813 END IF
30814 2300 CONTINUE
30815 END IF
30816 2400 CONTINUE
30817 END IF
30818C
3081950 CST=0.4D0*UNIV
30820 GOTO 2500
3082155 CST=0.2D0*FLTI
30822 GOTO 2500
3082360 CST=0.3D0+0.1D0*FLTI
30824 GOTO 2500
3082565 CST=0.6D0+0.04D0*FLTI
30826 GOTO 2500
3082770 CST=0.78D0+0.02D0*FLTI
30828C
308292500 CONTINUE
30830 IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
30831C
30832 RETURN
30833 END
30834*
30835*===dhadri=============================================================*
30836*
30837CDECK ID>, DT_DHADRI
30838 SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
30839
30840 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30841 SAVE
30842
30843 PARAMETER ( LINP = 5 ,
30844 & LOUT = 6 ,
30845 & LDAT = 9 )
30846
30847C
30848C-----------------------------
30849C*** INPUT VARIABLES LIST:
30850C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
30851C*** GEV/C LABORATORY MOMENTUM REGION
30852C*** N - PROJECTILE HADRON INDEX
30853C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
30854C*** ELAB - LABORATORY ENERGY OF N (GEV)
30855C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
30856C*** ITTA - TARGET NUCLEON INDEX
30857C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
30858C IR COUNTS THE NUMBER OF PRODUCED PARTICLES
30859C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
30860C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
30861C*** RESPECT., UNITS (GEV/C AND GEV)
30862C----------------------------
30863
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),
30874 & ITS(149),IS
30875 COMMON /HNDRUN/ RUNTES,EFTES
30876* particle properties (BAMJET index convention)
30877 CHARACTER*8 ANAME
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
30884
30885 DIMENSION ITPRF(110)
30886 DATA NNN/0/
30887 DATA UMODA/0./
30888 DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
30889 LOWP=0
30890 IF (N.LE.0.OR.N.GE.111)N=1
30891 IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
30892 GOTO 280
30893* WRITE (6,1000)
30894* + ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
30895* STOP
30896*1000 FORMAT (3(5H ****/),A,2I4,3(5H ****/))
30897* + 45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
30898 ENDIF
30899 IATMPT=0
30900 IF (ABS(PLAB-5.0D0).LT.4.99999D0) GO TO 20
30901C IF(IPRI.GE.1) WRITE (6,1010) PLAB
30902C STOP
30903 1010 FORMAT ( ' PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
30904 + ALLOWED REGION, PLAB=',1E15.5)
30905
30906 20 CONTINUE
30907 UMODAT=N*1.11111D0+ITTA*2.19291D0
30908 IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
30909 UMODA=UMODAT
30910 30 IATMPT=0
30911 LOWP=LOWP+1
30912 40 CONTINUE
30913 IMACH=0
30914 REDU=2.0D0
30915 IF (LOWP.GT.20) THEN
30916C WRITE(LOUT,*) ' jump 1'
30917 GO TO 280
30918 ENDIF
30919 NNN=N
30920 IF (NNN.EQ.N) GO TO 50
30921 RUNTES=0.0D0
30922 EFTES=0.0D0
30923 50 CONTINUE
30924 IS=1
30925 IRH=0
30926 IST=1
30927 NSTAB=23
30928 IRE=NURE(N,1)
30929 IF(ITTA.GT.1) IRE=NURE(N,2)
30930C
30931C-----------------------------
30932C*** IE,AMT,ECM,SI DETERMINATION
30933C----------------------------
30934 CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
30935 IANTH=-1
30936**sr
30937C IF (AMH(1).NE.0.93828D0) IANTH=1
30938 IF (AMH(1).NE.0.9383D0) IANTH=1
30939**
30940 IF (IANTH.GE.0) SI=1.0D0
30941 ECMMH=ECM
30942C
30943C-----------------------------
30944C ENERGY INDEX
30945C IRE CHARACTERIZES THE REACTION
30946C IE IS THE ENERGY INDEX
30947C----------------------------
30948 IF (SI.LT.1.D-6) THEN
30949C WRITE(LOUT,*) ' jump 2'
30950 GO TO 280
30951 ENDIF
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
30958 60 CONTINUE
30959 IMACH=IMACH+1
30960**sr 19.2.97: loop for direct channel suppression
30961C IF (IMACH.GT.10) THEN
30962 IF (IMACH.GT.1000) THEN
30963**
30964C WRITE(LOUT,*) ' jump 3'
30965 GO TO 280
30966 ENDIF
30967 ECM =ECMMH
30968 AMN2=AMN**2
30969 AMT2=AMT**2
30970 ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM )
30971 IF(ECMN.LE.AMN) ECMN=AMN
30972 PCMN=SQRT(ECMN**2-AMN2)
30973 GAM=(ELAB+AMT)/ECM
30974 BGAM=PLAB/ECM
30975 IF (IANTH.GE.0) ECM=2.1D0
30976C
30977C-----------------------------
30978C*** RANDOM CHOICE OF REACTION CHANNEL
30979C----------------------------
30980 IST=0
30981 VV=DT_RNDM(AMN2)
30982 VV=VV-1.D-17
30983C
30984C-----------------------------
30985C*** PLACE REDUCED VERSION
30986C----------------------------
30987 IIEI=IEII(IRE)
30988 IDWK=IEII(IRE+1)-IIEI
30989 IIWK=IRII(IRE)
30990 IIKI=IKII(IRE)
30991C
30992C-----------------------------
30993C*** SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
30994C----------------------------
30995 HECM=ECM
30996 HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
30997 IF (HUMO.LT.ECM) ECM=HUMO
30998C
30999C-----------------------------
31000C*** INTERPOLATION PREPARATION
31001C----------------------------
31002 ECMO=UMO(IE)
31003 ECM1=UMO(IE-1)
31004 DECM=ECMO-ECM1
31005 DEC=ECMO-ECM
31006C
31007C-----------------------------
31008C*** RANDOM LOOP
31009C----------------------------
31010 IK=0
31011 WKK=0.0D0
31012 WICOR=0.0D0
31013 70 IK=IK+1
31014 IWK=IIWK+(IK-1)*IDWK+IE-IIEI
31015 WOK=WK(IWK)
31016 WDK=WOK-WK(IWK-1)
31017C
31018C-----------------------------
31019C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
31020C GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
31021C CONTRIBUTE
31022C----------------------------
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
31027 WICOR=WICO
31028C
31029C-----------------------------
31030C*** INTERPOLATION IN CHANNEL WEIGHTS
31031C----------------------------
31032 EKLIM=-THRESH(IIKI+IK)
31033 IELIM=IDT_IEFUND(EKLIM,IRE)
31034 DELIM=UMO(IELIM)+EKLIM
31035 *+1.D-16
31036 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31037 IF (DELIM*DELIM-DETE*DETE) 90,90,80
31038 80 DECC=DELIM
31039 GO TO 100
31040 90 DECC=DECM
31041 100 CONTINUE
31042 WKK=WOK-WDK*DEC/(DECC+1.D-9)
31043C
31044C-----------------------------
31045C*** RANDOM CHOICE
31046C----------------------------
31047C
31048 IF (VV.GT.WKK) GO TO 70
31049C
31050C***IK IS THE REACTION CHANNEL
31051C----------------------------
31052 INRK=IKII(IRE)+IK
31053 ECM=HECM
31054 I1001 =0
31055C
31056 110 CONTINUE
31057 IT1=NRK(1,INRK)
31058 AM1=DT_DAMG(IT1)
31059 IT2=NRK(2,INRK)
31060 AM2=DT_DAMG(IT2)
31061 AMS=AM1+AM2
31062 I1001=I1001+1
31063 IF (I1001.GT.50) GO TO 60
31064C
31065 IF (IT2*AMS.GT.IT2*ECM) GO TO 110
31066 IT11=IT1
31067 IT22=IT2
31068 IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
31069 AM11=AM1
31070 AM22=AM2
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
31074 RR = DT_RNDM(AM11)
31075 IF (RR.LE.0.75D0) GOTO 60
31076 ENDIF
31077**
31078C
31079C-----------------------------
31080C INCLUSION OF DIRECT RESONANCES
31081C RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE IT1
31082C------------------------
31083 KZ1=K1H(IT1)
31084 IST=IST+1
31085 IECO=0
31086 ECO=ECM
31087 GAM=(ELAB+AMT)/ECO
31088 BGAM=PLAB/ECO
31089 CXS(1)=CX
31090 CYS(1)=CY
31091 CZS(1)=CZ
31092 GO TO 170
31093 120 CONTINUE
31094 WW=DT_RNDM(ECO)
31095 IF(WW.LT. 0.5D0) GO TO 130
31096 IT1=IT22
31097 IT2=IT11
31098 AM1=AM22
31099 AM2=AM11
31100 130 CONTINUE
31101C
31102C-----------------------------
31103C THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
31104 IBN=IBARH(N)
31105 IB1=IBARH(IT1)
31106 IT11=IT1
31107 IT22=IT2
31108 AM11=AM1
31109 AM22=AM2
31110 IF(IB1.EQ.IBN) GO TO 140
31111 IT1=IT22
31112 IT2=IT11
31113 AM1=AM22
31114 AM2=AM11
31115 140 CONTINUE
31116C-----------------------------
31117C***IT1,IT2 ARE THE CREATED PARTICLES
31118C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
31119C------------------------
31120 CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
31121 *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
31122 IST=IST+1
31123 ITS(IST)=IT1
31124 AMM(IST)=AM1
31125C
31126C-----------------------------
31127C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
31128C----------------------------
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))
31131 IST=IST+1
31132 ITS(IST)=IT2
31133 AMM(IST)=AM2
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))
31136 150 CONTINUE
31137C
31138C-----------------------------
31139C***TEST STABLE OR UNSTABLE
31140C----------------------------
31141 IF(ITS(IST).GT.NSTAB) GO TO 160
31142 IRH=IRH+1
31143C
31144C-----------------------------
31145C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
31146C----------------------------
31147C* IF (REDU.LT.0.D0) GO TO 1009
31148 ITRH(IRH)=ITS(IST)
31149 PLRH(IRH)=PLS(IST)
31150 CXRH(IRH)=CXS(IST)
31151 CYRH(IRH)=CYS(IST)
31152 CZRH(IRH)=CZS(IST)
31153 ELRH(IRH)=ELS(IST)
31154 IST=IST-1
31155 IF(IST.GE.1) GO TO 150
31156 GO TO 260
31157 160 CONTINUE
31158C
31159C RANDOM CHOICE OF DECAY CHANNELS
31160C----------------------------
31161C
31162 IT=ITS(IST)
31163 ECO=AMM(IST)
31164 GAM=ELS(IST)/ECO
31165 BGAM=PLS(IST)/ECO
31166 IECO=0
31167 KZ1=K1H(IT)
31168 170 CONTINUE
31169 IECO=IECO+1
31170 VV=DT_RNDM(GAM)
31171 VV=VV-1.D-17
31172 IIK=KZ1-1
31173 180 IIK=IIK+1
31174 IF (VV.GT.WTI(IIK)) GO TO 180
31175C
31176C IIK IS THE DECAY CHANNEL
31177C----------------------------
31178 IT1=NZKI(IIK,1)
31179 I310=0
31180 190 CONTINUE
31181 I310=I310+1
31182 AM1=DT_DAMG(IT1)
31183 IT2=NZKI(IIK,2)
31184 AM2=DT_DAMG(IT2)
31185 IF (IT2-1.LT.0) GO TO 240
31186 IT3=NZKI(IIK,3)
31187 AM3=DT_DAMG(IT3)
31188 AMS=AM1+AM2+AM3
31189C
31190C IF IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
31191C----------------------------
31192 IF (IECO.LE.10) GO TO 200
31193 IATMPT=IATMPT+1
31194 IF(IATMPT.GT.3) THEN
31195C WRITE(LOUT,*) ' jump 4'
31196 GO TO 280
31197 ENDIF
31198 GO TO 40
31199 200 CONTINUE
31200 IF (I310.GT.50) GO TO 170
31201 IF (AMS.GT.ECO) GO TO 190
31202C
31203C FOR THE DECAY CHANNEL
31204C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
31205C----------------------------
31206 IF (REDU.LT.0.D0) GO TO 30
31207 ITWTHC=0
31208 REDU=2.0D0
31209 IF(IT3.EQ.0) GO TO 220
31210 210 CONTINUE
31211 ITWTH=1
31212 CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
31213 *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
31214 GO TO 230
31215 220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
31216 &COD2,COF2,SIF2,AM1,AM2)
31217 ITWTH=-1
31218 IT3=0
31219 230 CONTINUE
31220 ITWTHC=ITWTHC+1
31221 IF (REDU.GT.0.D0) GO TO 240
31222 REDU=2.0D0
31223 IF (ITWTHC.GT.100) GO TO 30
31224 IF (ITWTH) 220,220,210
31225 240 CONTINUE
31226 ITS(IST )=IT1
31227 IF (IT2-1.LT.0) GO TO 250
31228 ITS(IST+1) =IT2
31229 ITS(IST+2)=IT3
31230 RX=CXS(IST)
31231 RY=CYS(IST)
31232 RZ=CZS(IST)
31233 AMM(IST)=AM1
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))
31236 IST=IST+1
31237 AMM(IST)=AM2
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
31241 IST=IST+1
31242 AMM(IST)=AM3
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))
31245 250 CONTINUE
31246 GO TO 150
31247 260 CONTINUE
31248 270 CONTINUE
31249 RETURN
31250 280 CONTINUE
31251C
31252C----------------------------
31253C
31254C ZERO CROSS SECTION CASE
31255C----------------------------
31256C
31257 IRH=1
31258 ITRH(1)=N
31259 CXRH(1)=CX
31260 CYRH(1)=CY
31261 CZRH(1)=CZ
31262 ELRH(1)=ELAB
31263 PLRH(1)=PLAB
31264 RETURN
31265 END
31266*
31267*===runtt==============================================================*
31268*
31269CDECK ID>, DT_RUNTT
31270 BLOCK DATA DT_RUNTT
31271
31272 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31273 SAVE
31274
31275 COMMON /HNDRUN/ RUNTES,EFTES
31276
31277 DATA RUNTES,EFTES /100.D0,100.D0/
31278
31279 END
31280*
31281*===noname=============================================================*
31282*
31283CDECK ID>, DT_NONAME
31284 BLOCK DATA DT_NONAME
31285
31286 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31287 SAVE
31288
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)
31292
31293C DATAS DATAS DATAS DATAS DATAS
31294C****** *********
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/
31301
31302C
31303C MASSES FOR THE SLOPE B(M) IN GEV
31304C SLOPE B(M) FOR AN MESONIC SYSTEM
31305C SLOPE B(M) FOR A BARYONIC SYSTEM
31306
31307*
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 /
31322*
31323 END
31324*
31325*===damg===============================================================*
31326*
31327CDECK ID>, DT_DAMG
31328 DOUBLE PRECISION FUNCTION DT_DAMG(IT)
31329
31330 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31331 SAVE
31332
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)
31337
31338 DIMENSION GASUNI(14)
31339 DATA GASUNI/
31340 *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
31341 *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
31342 DATA GAUNO/2.352D0/
31343 DATA GAUNON/2.4D0/
31344 DATA IO/14/
31345 DATA NSTAB/23/
31346
31347 I=1
31348 IF (IT.LE.0) GO TO 30
31349 IF (IT.LE.NSTAB) GO TO 20
31350 DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
31351 VV=DT_RNDM(DGAUNI)
31352 VV=VV*2.0D0-1.0D0+1.D-16
31353 10 CONTINUE
31354 VO=GASUNI(I)
31355 I=I+1
31356 V1=GASUNI(I)
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
31361 AAM=AMH(IT)+DAM
31362 DT_DAMG=AAM
31363 RETURN
31364 20 CONTINUE
31365 DT_DAMG=AMH(IT)
31366 RETURN
31367 30 CONTINUE
31368 DT_DAMG=0.0D0
31369 RETURN
31370 END
31371*
31372*===dcalum=============================================================*
31373*
31374CDECK ID>, DT_DCALUM
31375 SUBROUTINE DT_DCALUM(N,ITTA)
31376
31377 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31378 SAVE
31379
31380C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
31381
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)
31390
31391 IRE=NURE(N,ITTA/8+1)
31392 IEO=IEII(IRE)+1
31393 IEE=IEII(IRE +1)
31394 AM1=AMH(N )
31395 AM12=AM1**2
31396 AM2=AMH(ITTA)
31397 AM22=AM2**2
31398 DO 10 IE=IEO,IEE
31399 PLAB2=PLABF(IE)**2
31400 ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
31401 UMO(IE)=ELAB
31402 10 CONTINUE
31403 IKO=IKII(IRE)+1
31404 IKE=IKII(IRE +1)
31405 UMOO=UMO(IEO)
31406 DO 30 IK=IKO,IKE
31407 IF(NRK(2,IK).GT.0) GO TO 30
31408 IKI=NRK(1,IK)
31409 AMSS=5.0D0
31410 K11=K1H(IKI)
31411 K22=K2H(IKI)
31412 DO 20 IK1=K11,K22
31413 IN=NZKI(IK1,1)
31414 AMS=AMH(IN)
31415 IN=NZKI(IK1,2)
31416 IF(IN.GT.0)AMS=AMS+AMH(IN)
31417 IN=NZKI(IK1,3)
31418 IF(IN.GT.0) AMS=AMS+AMH(IN)
31419 IF (AMS.LT.AMSS) AMSS=AMS
31420 20 CONTINUE
31421 IF(UMOO.LT.AMSS) UMOO=AMSS
31422 THRESH(IK)=UMOO
31423 30 CONTINUE
31424 RETURN
31425 END
31426*
31427*===dchanh=============================================================*
31428*
31429CDECK ID>, DT_DCHANH
31430 SUBROUTINE DT_DCHANH
31431
31432 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31433 SAVE
31434
31435 PARAMETER ( LINP = 5 ,
31436 & LOUT = 6 ,
31437 & LDAT = 9 )
31438
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)
31447
31448 DIMENSION HWT(460),HWK(40),SI(5184)
31449 EQUIVALENCE (WK(1),SI(1))
31450C--------------------
31451C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
31452C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
31453C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
31454C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
31455C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
31456C--------------------------
31457 IREG=16
31458 DO 90 IRE=1,IREG
31459 IWKO=IRII(IRE)
31460 IEE=IEII(IRE+1)-IEII(IRE)
31461 IKE=IKII(IRE+1)-IKII(IRE)
31462 IEO=IEII(IRE)+1
31463 IIKA=IKII(IRE)
31464* modifications to suppress elestic scattering 24/07/91
31465 DO 80 IE=1,IEE
31466 SIS=1.D-14
31467 SINORC=0.0D0
31468 DO 10 IK=1,IKE
31469 IWK=IWKO+IEE*(IK-1)+IE
31470 IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
31471 SIS=SIS+SI(IWK)*SINORC
31472 10 CONTINUE
31473 SIIN(IEO+IE-1)=SIS
31474 SIO=0.D0
31475 IF (SIS.GE.1.D-12) GO TO 20
31476 SIS=1.D0
31477 SIO=1.D0
31478 20 CONTINUE
31479 SINORC=0.0D0
31480 DO 30 IK=1,IKE
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
31484 HWK(IK)=SIO
31485 30 CONTINUE
31486 DO 40 IK=1,IKE
31487 IWK=IWKO+IEE*(IK-1)+IE
31488 40 WK(IWK)=HWK(IK)
31489 IIKI=IKII(IRE)
31490 DO 70 IK=1,IKE
31491 AM111=0.D0
31492 INRK1=NRK(1,IIKI+IK)
31493 IF (INRK1.GT.0) AM111=AMH(INRK1)
31494 AM222=0.D0
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
31499 INRKK=K1H(INRK1)
31500 AMSS=5.D0
31501 INRKO=K2H(INRK1)
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
31509C WRITE (6,310)INRK1,INZK1,INZK2,INZK3
31510 1000 FORMAT (4I10)
31511 AMS=AMH(INZK1)+AMH(INZK2)
31512 IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
31513 IF (AMSS.GT.AMS) AMSS=AMS
31514 50 CONTINUE
31515 AMS=AMSS
31516 IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
31517 THRESH(IIKI+IK)=AMS
31518 60 CONTINUE
31519 70 CONTINUE
31520 80 CONTINUE
31521 90 CONTINUE
31522 DO 100 J=1,460
31523 100 HWT(J)=0.D0
31524 DO 120 I=1,110
31525 IK1=K1H(I)
31526 IK2=K2H(I)
31527 HV=0.D0
31528 IF (IK2.GT.460)IK2=460
31529 IF (IK1.LE.0)IK1=1
31530 DO 110 J=IK1,IK2
31531 HV=HV+WTI(J)
31532 HWT(J)=HV
31533 JI=J
31534 110 CONTINUE
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)
31537 120 CONTINUE
31538 DO 130 J=1,460
31539 130 WTI(J)=HWT(J)
31540 RETURN
31541 END
31542*
31543*===dhadde=============================================================*
31544*
31545CDECK ID>, DT_DHADDE
31546 SUBROUTINE DT_DHADDE
31547
31548 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31549 SAVE
31550
31551* particle properties (BAMJET index convention)
31552 CHARACTER*8 ANAME
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)
31557 CHARACTER*8 ZKNAME
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)
31568
31569 DATA IRETUR/0/
31570
31571 IRETUR=IRETUR+1
31572 AMH(31)=0.48D0
31573 IF (IRETUR.GT.1) RETURN
31574 DO 10 I=1,94
31575 AMH(I) = AAM(I)
31576 GAH(I) = GA(I)
31577 TAUH(I) = TAU(I)
31578 ICHH(I) = IICH(I)
31579 IBARH(I) = IIBAR(I)
31580 K1H(I) = K1(I)
31581 K2H(I) = K2(I)
31582 10 CONTINUE
31583**sr
31584C AMH(1)=0.93828D0
31585 AMH(1)=0.9383D0
31586**
31587 AMH(2)=AMH(1)
31588 DO 20 I=26,30
31589 K1H(I)=452
31590 K2H(I)=452
31591 20 CONTINUE
31592 DO 30 I=1,307
31593 WTI(I) = WT(I)
31594 NZKI(I,1) = NZK(I,1)
31595 NZKI(I,2) = NZK(I,2)
31596 NZKI(I,3) = NZK(I,3)
31597 30 CONTINUE
31598 DO 40 I=1,16
31599 L=I+94
31600 AMH(L)=AMZ(I)
31601 GAH( L)=GAZ(I)
31602 TAUH( L)=TAUZ(I)
31603 ICHH( L)=ICHZ(I)
31604 IBARH( L)=IBARZ(I)
31605 K1H( L)=K1Z(I)
31606 K2H( L)=K2Z(I)
31607 40 CONTINUE
31608 DO 50 I=1,153
31609 L=I+307
31610 WTI(L) = WTZ(I)
31611 NZKI(L,3) = NZK3(I)
31612 NZKI(L,2) = NZK2(I)
31613 NZKI(L,1) = NZK1(I)
31614 50 CONTINUE
31615 RETURN
31616 END
31617*
31618*===iefund=============================================================*
31619*
31620CDECK ID>, IDT_IEFUND
31621 INTEGER FUNCTION IDT_IEFUND(PL,IRE)
31622
31623 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31624 SAVE
31625
31626C*****IEFUN CALCULATES A MOMENTUM INDEX
31627
31628 PARAMETER ( LINP = 5 ,
31629 & LOUT = 6 ,
31630 & LDAT = 9 )
31631
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)
31636
31637 IPLA=IEII(IRE)+1
31638 *+1
31639 IPLE=IEII(IRE+1)
31640 IF (PL.LT.0.) GO TO 30
31641 DO 10 I=IPLA,IPLE
31642 J=I-IPLA+1
31643 IF (PL.LE.PLABF(I)) GO TO 60
31644 10 CONTINUE
31645 I=IPLE
31646 IF ( EFTES.GT.40.D0) GO TO 20
31647 EFTES=EFTES+1.0D0
31648 WRITE(LOUT,1000)PL,J
31649 20 CONTINUE
31650 GO TO 70
31651 30 CONTINUE
31652 DO 40 I=IPLA,IPLE
31653 J=I-IPLA+1
31654 IF (-PL.LE.UMO(I)) GO TO 60
31655 40 CONTINUE
31656 I=IPLE
31657 IF ( EFTES.GT.40.D0) GO TO 50
31658 EFTES=EFTES+1.0D0
31659 WRITE(LOUT,1000)PL,I
31660 50 CONTINUE
31661 60 CONTINUE
31662 70 CONTINUE
31663 IDT_IEFUND=I
31664 RETURN
31665 1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
31666 +7H IEFUN=,I5)
31667 END
31668*
31669*===dsigin=============================================================*
31670*
31671CDECK ID>, DT_DSIGIN
31672 SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
31673
31674 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31675 SAVE
31676
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)
31684
31685 IE=IDT_IEFUND(PLAB,IRE)
31686 IF (IE.LE.IEII(IRE)) IE=IE+1
31687 AMT=AMH(ITAR)
31688 AMN=AMH(N)
31689 AMN2=AMN*AMN
31690 AMT2=AMT*AMT
31691 ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
31692C*** INTERPOLATION PREPARATION
31693 ECMO=UMO(IE)
31694 ECM1=UMO(IE-1)
31695 DECM=ECMO-ECM1
31696 DEC=ECMO-ECM
31697 IIKI=IKII(IRE)+1
31698 EKLIM=-THRESH(IIKI)
31699 WOK=SIIN(IE)
31700 WDK=WOK-SIIN(IE-1)
31701 IF (ECM.GT.ECMO) WDK=0.0D0
31702C*** INTERPOLATION IN CHANNEL WEIGHTS
31703 IELIM=IDT_IEFUND(EKLIM,IRE)
31704 DELIM=UMO(IELIM)+EKLIM
31705 *+1.D-16
31706 DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
31707 IF (DELIM*DELIM-DETE*DETE) 20,20,10
31708 10 DECC=DELIM
31709 GO TO 30
31710 20 DECC=DECM
31711 30 CONTINUE
31712 WKK=WOK-WDK*DEC/(DECC+1.D-9)
31713 IF (WKK.LT.0.0D0) WKK=0.0D0
31714 SI=WKK+1.D-12
31715 IF (-EKLIM.GT.ECM) SI=1.D-14
31716 RETURN
31717 END
31718*
31719*===dtchoi=============================================================*
31720*
31721CDECK ID>, DT_DTCHOI
31722 SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
31723
31724 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31725 SAVE
31726
31727C ****************************
31728C TCHOIC CALCULATES A RANDOM VALUE
31729C FOR THE FOUR-MOMENTUM-TRANSFER T
31730C ****************************
31731
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)
31738
31739 AMA=AM1
31740 AMB=AM2
31741 IF (I.GT.30.AND.II.GT.30) GO TO 20
31742 III=II
31743 AM3=AM2
31744 IF (I.LE.30) GO TO 10
31745 III=I
31746 AM3=AM1
31747 10 CONTINUE
31748 GO TO 30
31749 20 CONTINUE
31750 III=II
31751 AM3=AM2
31752 IF (AMA.LE.AMB) GO TO 30
31753 III=I
31754 AM3=AM1
31755 30 CONTINUE
31756 IB=IBARH(III)
31757 AMA=AM3
31758 K=INT((AMA-0.75D0)/0.05D0)
31759 IF (K-2.LT.0) K=1
31760 IF (K-26.GE.0) K=25
31761 IF (IB)50,40,50
31762 40 BM=BBM(K)
31763 GO TO 60
31764 50 BM=BBB(K)
31765 60 CONTINUE
31766C NORMALIZATION
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
31769 VB=DT_RNDM(TMIN)
31770**sr test
31771C IF (VB.LT.0.2D0) BM=BM*0.1
31772C **0.5
31773 BM = BM*5.05D0
31774**
31775 TMI=BM*TMIN
31776 TMA=BM*TMAX
31777 ETMA=0.D0
31778 IF (ABS(TMA).GT.120.D0) GO TO 70
31779 ETMA=EXP(TMA)
31780 70 CONTINUE
31781 AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
31782C*** RANDOM CHOICE OF THE T - VALUE
31783 R=DT_RNDM(TMI)
31784 T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
31785 RETURN
31786 END
31787*
31788*===dtwopa=============================================================*
31789*
31790CDECK 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)
31793
31794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31795 SAVE
31796
31797C ******************************************************
31798C QUASI TWO PARTICLE PRODUCTION
31799C TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
31800C FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
31801C IN THE CM - SYSTEM
31802C COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
31803C SPHERICAL COORDINATES
31804C ******************************************************
31805
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)
31810
31811 AMA=AM1
31812 AMB=AM2
31813 AMA2=AMA*AMA
31814 E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
31815 E2=UMOO - E1
31816 IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
31817 AMTE=(E1-AMA)*(E1+AMA)
31818 AMTE=AMTE+1.D-18
31819 P1=SQRT(AMTE)
31820 P2=P1
31821C / P2 / = / P1 / BUT OPPOSITE DIRECTIONS
31822C DETERMINATION OF THE ANGLES
31823C COS(THETA1)=COD1 COS(THETA2)=COD2
31824C SIN(PHI1)=SIF1 SIN(PHI2)=SIF2
31825C COS(PHI1)=COF1 COS(PHI2)=COF2
31826C PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
31827 CALL DT_DSFECF(COF1,SIF1)
31828 COF2=-COF1
31829 SIF2=-SIF1
31830C 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
31834 COD2=-COD1
31835 RETURN
31836 END
31837*
31838*===zk=================================================================*
31839*
31840CDECK ID>, DT_ZK
31841 BLOCK DATA DT_ZK
31842
31843 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31844 SAVE
31845
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)
31853
31854* Particle masses in GeV *
31855 DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
31856 & 2*1.7D0, 3*0.D0/
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,
31868 & 3*460/
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,
31872 & 3*460/
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 /
31915* Particle names *
31916 DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS ',' PAP ',' PAN ',
31917 & 'APN', 'DEO ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
31918 & 3*'BLANK' /
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',
31929 & 'OMOMOM',
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+',
31943 & 9*'BLANK'/
31944*= end*block.zk *
31945 END
31946*
31947*===blkd43=============================================================*
31948*
31949CDECK ID>, DT_BLKD43
31950 BLOCK DATA DT_BLKD43
31951
31952 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31953 SAVE
31954
31955*$ CREATE REAC.ADD
31956*COPY REAC
31957*
31958*=== reac =============================================================*
31959*
31960*----------------------------------------------------------------------*
31961* *
31962* Created on 10 december 1991 by Alfredo Ferrari & Paola Sala *
31963* Infn - Milan *
31964* *
31965* Last change on 10-dec-91 by Alfredo Ferrari *
31966* *
31967* This is the original common reac of Hadrin *
31968* *
31969*----------------------------------------------------------------------*
31970*
31971 COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
31972 & NRK(2,268),NURE(30,2)
31973
31974 DIMENSION
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),
31986 & NURELN(60)
31987*
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))
32013*
32014**** pi- p data *
32015**** pi+ n data *
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 /
32026 DATA PLAKC /
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/
32039 DATA PLAK0 /
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/
32046* pp pn np nn *
32047 DATA PLAP /
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 *
32055 DATA PLAN /
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,
32070 & 2.735D0,2.90D0,
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,
32085 & 2.735D0, 2.90D0/
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,
32089 & 3.1D0,1.44D0,
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,
32092 & 3.1D0,1.44D0,
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,
32095 & 3.1D0,1.44D0,
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,
32098 & 3.1D0/
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,
32102 & 3.1D0,1.44D0,
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,
32105 & 3.1D0/
32106* pp pn np nn *
32107 DATA UMOP/
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 *
32115 DATA UMON /
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 /
32144* *
32145* k0 p k0 n ak0 p ak/ n *
32146* *
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/
32151* pp pn np nn *
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 /
32185**** pi+ n data *
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/
32206*
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 /
32227**** pi- p data *
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/
32247*
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 /
32268**** pi- n data *
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 /
32289**** k+ p data *
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 /
32303**** k+ n data *
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 /
32323**** k- p data *
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,
32356 & 10*0.D0/
32357***** k- n data *
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/
32383***** p p data *
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/
32399***** p n data *
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/
32418* nn - data *
32419* *
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 *
32469 DATA SAPNEL/
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 /
32493* *
32494* *
32495**************** an - p - data *
32496* *
32497 DATA SANPEL/
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,
32533 & 4.85D0, 4.9D0,
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 *
32564 END
32565*
32566*===qel_pol============================================================*
32567*
32568CDECK ID>, DT_QEL_POL
32569 SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
32570
32571 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32572 SAVE
32573
32574 CALL DT_MASS_INI
32575 CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32576
32577 RETURN
32578 END
32579
32580C==================================================================
32581C Generation of a Quasi-Elastic neutrino scattering
32582C==================================================================
32583*
32584*===gen_qel============================================================*
32585*
32586CDECK ID>, DT_GEN_QEL
32587 SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
32588
32589C...Generate a quasi-elastic neutrino/antineutrino
32590C. Interaction on a nuclear target
32591C. INPUT : LTYP = neutrino type (1,...,6)
32592C. ENU (GeV) = neutrino energy
32593C----------------------------------------------------
32594
32595 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32596 SAVE
32597
32598 PARAMETER ( LINP = 5 ,
32599 & LOUT = 6 ,
32600 & LDAT = 9 )
32601
32602 PARAMETER (MAXLND=4000)
32603 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
32604
32605* nuclear potential
32606 LOGICAL LFERMI
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)
32613C COMMON /CBAD/ LBAD, NBAD
32614C COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
32615**
32616
32617 DIMENSION PI(3),PO(3)
32618CJR+
32619 DATA ININU/0/
32620CJR-
32621C REAL*8 DBETA(3)
32622C 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/
32626 DATA INIPRI/0/
32627
32628C DATA PFERMI/0.22D0/
32629CGB+...Binding Energy
32630 DATA EBIND/0.008D0/
32631CGB-...
32632
32633 ININU=ININU+1
32634 IF(ININU.EQ.1)NDSIG=0
32635 LBAD = 0
32636 enu0=enu
32637c write(*,*) enu0
32638C...Lepton mass
32639 AML = AML0(LTYP) ! massa leptoni
32640 AML2 = AML**2 ! massa leptoni **2
32641C...Particle labels (LUND)
32642 N = 5
32643 K(1,1) = 21
32644 K(2,1) = 21
32645 K(3,1) = 21
32646 K(3,3) = 1
32647 K(4,1) = 1
32648 K(4,3) = 1
32649 K(5,1) = 1
32650 K(5,3) = 2
32651 K0 = (LTYP-1)/2 ! 2
32652 K1 = LTYP/2 ! 2
32653 KA = 12 + 2*K0 ! 16
32654 IS = -1 + 2*LTYP - 4*K1 ! -1 +10 -8 = 1
32655 K(1,2) = IS*KA
32656 K(4,2) = IS*(KA-1)
32657 K(3,2) = IS*24
32658 LNU = 2 - LTYP + 2*K1 ! 2 - 5 + 2 = - 1
32659 IF (LNU .EQ. 2) THEN
32660 K(2,2) = 2212
32661 K(5,2) = 2112
32662 AMI = AMN(1)
32663 AMF = AMN(2)
32664CJR+
32665 PFERMI=PFERMN(2)
32666CJR-
32667 ELSE
32668 K(2,2) = 2112
32669 K(5,2) = 2212
32670 AMI = AMN(2)
32671 AMF = AMN(1)
32672CJR+
32673 PFERMI=PFERMP(2)
32674CJR-
32675 ENDIF
32676 AMI2 = AMI**2
32677 AMF2 = AMF**2
32678
32679 DO IGB=1,5
32680 P(3,IGB) = 0.
32681 P(4,IGB) = 0.
32682 P(5,IGB) = 0.
32683 END DO
32684
32685 NTRY = 0
32686CGB+...
32687 EFMAX = SQRT(PFERMI**2 + AMI2) -AMI ! max. Fermi Energy
32688 ENWELL = EFMAX + EBIND ! depth of nuclear potential well
32689CGB-...
32690
32691 100 CONTINUE
32692
32693C...4-momentum initial lepton
32694 P(1,5) = 0. ! massa
32695 P(1,4) = ENU0 ! energia
32696 P(1,1) = 0. ! px
32697 P(1,2) = 0. ! py
32698 P(1,3) = ENU0 ! pz
32699
32700C PF = PFERMI*PYR(0)**(1./3.)
32701c write(23,*) PYR(0)
32702c write(*,*) 'Pfermi=',PF
32703c PF = 0.
32704 NTRY=NTRY+1
32705C IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
32706 IF (NTRY .GT. 500) THEN
32707 LBAD = 1
32708 WRITE (LOUT,1001) NBAD, ENU
32709 RETURN
32710 ENDIF
32711C CT = -1. + 2.*PYR(0)
32712c CT = -1.
32713C ST = SQRT(1.-CT*CT)
32714C F = 2.*3.1415926*PYR(0)
32715c F = 0.
32716
32717C P(2,4) = SQRT(PF*PF + MI2) - EBIND ! energia
32718C P(2,1) = PF*ST*COS(F) ! px
32719C P(2,2) = PF*ST*SIN(F) ! py
32720C P(2,3) = PF*CT ! pz
32721C P(2,5) = SQRT(P(2,4)**2-PF*PF) ! massa
32722 P(2,1) = P21
32723 P(2,2) = P22
32724 P(2,3) = P23
32725 P(2,4) = P24
32726 P(2,5) = P25
32727 beta1=-p(2,1)/p(2,4)
32728 beta2=-p(2,2)/p(2,4)
32729 beta3=-p(2,3)/p(2,4)
32730 N=2
32731C WRITE(6,*)' before transforming into target rest frame'
32732
32733 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
32734
32735C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
32736 N=5
32737
32738 phi11=atan(p(1,2)/p(1,3))
32739 pi(1)=p(1,1)
32740 pi(2)=p(1,2)
32741 pi(3)=p(1,3)
32742
32743 CALL DT_TESTROT(PI,Po,PHI11,1)
32744 DO ll=1,3
32745 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32746 END DO
32747c WRITE(*,*) po
32748 p(1,1)=po(1)
32749 p(1,2)=po(2)
32750 p(1,3)=po(3)
32751 phi12=atan(p(1,1)/p(1,3))
32752
32753 pi(1)=p(1,1)
32754 pi(2)=p(1,2)
32755 pi(3)=p(1,3)
32756 CALL DT_TESTROT(Pi,Po,PHI12,2)
32757 DO ll=1,3
32758 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32759 END DO
32760c WRITE(*,*) po
32761 p(1,1)=po(1)
32762 p(1,2)=po(2)
32763 p(1,3)=po(3)
32764
32765 enu=p(1,4)
32766
32767C...Kinematical limits in Q**2
32768c 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
32778
32779C...Generate Q**2
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)
32785 NDSIG=NDSIG+1
32786C WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
32787C &Q2,Q2min,Q2MAX,DSIGEV
32788
32789C...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 !
32794c WRITE(*,*)
32795c WRITE(*,*)
32796C WRITE(*,*) 'Input values laboratory frame'
32797 N=2
32798
32799 CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
32800
32801 N=5
32802c STHETA = ULANGL(P(1,3),P(1,1))
32803c write(*,*) 'stheta' ,stheta
32804c stheta=0.
32805c CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
32806c WRITE(*,*)
32807c WRITE(*,*)
32808C WRITE(*,*) 'Output values cm frame'
32809C...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
32818
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
32824
32825 P(3,5) = -Q2
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)
32830
32831C...Transform back to laboratory frame
32832C WRITE(*,*) 'before going back to nucl rest frame'
32833c CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
32834 N=5
32835
32836 CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
32837
32838C WRITE(*,*) 'Now back in nucl rest frame'
32839 IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
32840
32841c********************************************
32842
32843 DO kw=1,5
32844 pi(1)=p(kw,1)
32845 pi(2)=p(kw,2)
32846 pi(3)=p(kw,3)
32847 CALL DT_TESTROT(Pi,Po,PHI12,3)
32848 DO ll=1,3
32849 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32850 END DO
32851 p(kw,1)=po(1)
32852 p(kw,2)=po(2)
32853 p(kw,3)=po(3)
32854 END DO
32855c********************************************
32856
32857 DO kw=1,5
32858 pi(1)=p(kw,1)
32859 pi(2)=p(kw,2)
32860 pi(3)=p(kw,3)
32861 CALL DT_TESTROT(Pi,Po,PHI11,4)
32862 DO ll=1,3
32863 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
32864 END DO
32865 p(kw,1)=po(1)
32866 p(kw,2)=po(2)
32867 p(kw,3)=po(3)
32868 END DO
32869
32870c********************************************
32871
32872C WRITE(*,*) 'Now back in lab frame'
32873
32874 CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
32875
32876CGB+...
32877C...test (on final momentum of nucleon) if Fermi-blocking
32878C...is operating
32879 ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
32880 & - P(5,5)
32881 IF (ENUCL.LT. EFMAX) THEN
32882 IF(INIPRI.LT.10)THEN
32883 INIPRI=INIPRI+1
32884C WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
32885C...the interaction is not possible due to Pauli-Blocking and
32886C...it must be resampled
32887 ENDIF
32888 GOTO 100
32889 ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
32890 IF(INIPRI.LT.10)THEN
32891 INIPRI=INIPRI+1
32892C WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
32893 ENDIF
32894C Reject (J:R) here all these events
32895C are otherwise rejected in dpmjet
32896 GOTO 100
32897C...the interaction is possible, but the nucleon remains inside
32898C...the nucleus. The nucleus is therefore left excited.
32899C...We treat this case as a nucleon with 0 kinetic energy.
32900C P(5,5) = AMF
32901C P(5,4) = AMF
32902C P(5,1) = 0.
32903C P(5,2) = 0.
32904C P(5,3) = 0.
32905 ELSE IF (ENUCL.GE.ENWELL) THEN
32906C WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
32907C...the interaction is possible, the nucleon can exit the nucleus
32908C...but the nuclear well depth must be subtracted. The nucleus could be
32909C...left in an excited state.
32910 Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
32911C P(5,4) = ENUCL-ENWELL + AMF
32912 Pnucl = SQRT(P(5,4)**2-AMF**2)
32913C...The 3-momentum is scaled assuming that the direction remains
32914C...unaffected
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
32918C WRITE(6,*)' qel new P(5,4) ',P(5,4)
32919 ENDIF
32920CGB-...
32921 DSIGSU=DSIGSU+DSIGEV
32922
32923 GA=P(4,4)/P(4,5)
32924 BGX=P(4,1)/P(4,5)
32925 BGY=P(4,2)/P(4,5)
32926 BGZ=P(4,3)/P(4,5)
32927*
32928 DBETB(1)=BGX/GA
32929 DBETB(2)=BGY/GA
32930 DBETB(3)=BGZ/GA
32931 IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
32932
32933 CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
32934
32935 ENDIF
32936c
32937C PRINT*,' FINE EVENTO '
32938 enu=enu0
32939 RETURN
32940
32941 1001 FORMAT(2X, 'DT_GEN_QEL : event rejected ', I5, G10.3)
32942 END
32943
32944C====================================================================
32945C. Masses
32946C====================================================================
32947
32948*
32949*===mass_ini===========================================================*
32950*
32951CDECK ID>, DT_MASS_INI
32952 SUBROUTINE DT_MASS_INI
32953C...Initialize the kinematics for the quasi-elastic cross section
32954
32955 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32956 SAVE
32957
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
32962
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.
32974 EMNSQ = EMN**2
32975 DO J=1,3
32976 J0 = 2*(J-1)
32977 EMN1(J0+1) = EMNEUT
32978 EMN1(J0+2) = EMPROT
32979 EMN2(J0+1) = EMPROT
32980 EMN2(J0+2) = EMNEUT
32981 ENDDO
32982 DO J=1,6
32983 EMLSQ(J) = EML(J)**2
32984 ETQE(J) = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
32985 ENDDO
32986 RETURN
32987 END
32988*
32989*===dsqel_q2===========================================================*
32990*
32991CDECK ID>, DT_DSQEL_Q2
32992 DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
32993
32994C...differential cross section for Quasi-Elastic scattering
32995C. nu + N -> l + N'
32996C. From Llewellin Smith Phys.Rep. 3C, 261, (1971).
32997C.
32998C. INPUT : JTYP = 1,...,6 nu_e, ...., nubar_tau
32999C. ENU (GeV) = Neutrino energy
33000C. Q2 (GeV**2) = (Transfer momentum)**2
33001C.
33002C. OUTPUT : DSQEL_Q2 = differential cross section :
33003C. dsigma/dq**2 (10**-38 cm+2/GeV**2)
33004C------------------------------------------------------------------
33005
33006 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33007 SAVE
33008
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)
33014C COMMON /CAXIAL/ FA0, AXIAL2
33015**
33016
33017 DIMENSION SS(6)
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
33021
33022 FA0=-1.253D0
33023 CSI = 3.71D0 ! ???
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
33027 XA = X/4.D0
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
33031 FFA = FA*FA
33032 FFV1 = FV1*FV1
33033 FFV2 = FV2*FV2
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
33043
33044 RETURN
33045 END
33046*
33047*===prepola============================================================*
33048*
33049CDECK ID>, DT_PREPOLA
33050 SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
33051
33052 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33053 SAVE
33054c
33055c By G. Battistoni and E. Scapparone (sept. 1997)
33056c According to:
33057c Albright & Jarlskog, Nucl Phys B84 (1975) 467
33058c
33059c
33060
33061 PARAMETER (MAXLND=4000)
33062 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33063
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)
33072C COMMON /CAXIAL/ FA0, AXIAL2
33073C COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
33074C & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
33075**
33076 REAL*8 POL(4,4),BB2(3)
33077 DIMENSION SS(6)
33078C 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
33082**
33083
33084 RML=P(4,5)
33085 RMM=0.93960D+00
33086 FM2 = RMM**2
33087 MPI = 0.135D+00
33088 OLDQ2=Q2
33089 FA0=-1.253D+00
33090 CSI = 3.71D+00 !
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
33094 XA = X/4.D0
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
33098 FFA = FA*FA
33099 FFV1 = FV1*FV1
33100 FFV2 = FV2*FV2
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)
33109
33110 OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2 ) ! articolo di ll...-smith
33111 OMEGA2=4.D+00*CC
33112 OMEGA3=2.D+00*FA*(FV1+FV2)
33113 OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
33114 1 (Q2/FM2))*FP**2)
33115 OMEGA5=OMEGA2
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
33122
33123 DO I=1,3
33124 BB2(I)=-P(4,I)/P(4,4)
33125 END DO
33126c WRITE(*,*)
33127c WRITE(*,*)
33128c WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
33129 N=5
33130
33131 CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
33132
33133* NOW PARTICLES ARE IN THE SCATTERED LEPTON REST FRAME
33134c WRITE(*,*)
33135c WRITE(*,*)
33136c WRITE(*,*) 'Prepola: now in lepton rest frame'
33137 EE=ENU
33138 QM2=Q2+RML**2
33139 U=Q2/(2.*RMM)
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!!
33143
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!!
33146
33147 FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
33148
33149 DO I=1,3
33150 POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
33151 POLARX(I)=POL(4,I)
33152 END DO
33153
33154 PMODUL=0.D0
33155 DO I=1,3
33156 PMODUL=PMODUL+POL(4,I)**2
33157 END DO
33158
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),
33162 + ETL,PXL,PYL,PZL,
33163 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33164c
33165c Tau has decayed in muon
33166c
33167 ENDIF
33168 IF(NEUDEC.EQ.2) THEN
33169 CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
33170 + ETL,PXL,PYL,PZL,
33171 + ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33172c
33173c Tau has decayed in electron
33174c
33175 ENDIF
33176 K(4,1)=15
33177 K(4,4) = 6
33178 K(4,5) = 8
33179 N=N+3
33180c
33181c fill common for muon(electron)
33182c
33183 P(6,1)=PXL
33184 P(6,2)=PYL
33185 P(6,3)=PZL
33186 P(6,4)=ETL
33187 K(6,1)=1
33188 IF(JTYP.EQ.5) THEN
33189 IF(NEUDEC.EQ.1) THEN
33190 P(6,5)=EML(JTYP-2)
33191 K(6,2)=13
33192 ELSEIF(NEUDEC.EQ.2) THEN
33193 P(6,5)=EML(JTYP-4)
33194 K(6,2)=11
33195 ENDIF
33196 ELSEIF(JTYP.EQ.6) THEN
33197 IF(NEUDEC.EQ.1) THEN
33198 K(6,2)=-13
33199 ELSEIF(NEUDEC.EQ.2) THEN
33200 K(6,2)=-11
33201 ENDIF
33202 END IF
33203 K(6,3)=4
33204 K(6,4)=0
33205 K(6,5)=0
33206c
33207c fill common for tau_(anti)neutrino
33208c
33209 P(7,1)=PXB
33210 P(7,2)=PYB
33211 P(7,3)=PZB
33212 P(7,4)=ETB
33213 P(7,5)=0.
33214 K(7,1)=1
33215 IF(JTYP.EQ.5) THEN
33216 K(7,2)=16
33217 ELSEIF(JTYP.EQ.6) THEN
33218 K(7,2)=-16
33219 END IF
33220 K(7,3)=4
33221 K(7,4)=0
33222 K(7,5)=0
33223c
33224c Fill common for muon(electron)_(anti)neutrino
33225c
33226 P(8,1)=PXN
33227 P(8,2)=PYN
33228 P(8,3)=PZN
33229 P(8,4)=ETN
33230 P(8,5)=0.
33231 K(8,1)=1
33232 IF(JTYP.EQ.5) THEN
33233 IF(NEUDEC.EQ.1) THEN
33234 K(8,2)=-14
33235 ELSEIF(NEUDEC.EQ.2) THEN
33236 K(8,2)=-12
33237 ENDIF
33238 ELSEIF(JTYP.EQ.6) THEN
33239 IF(NEUDEC.EQ.1) THEN
33240 K(8,2)=14
33241 ELSEIF(NEUDEC.EQ.2) THEN
33242 K(8,2)=12
33243 ENDIF
33244 END IF
33245 K(8,3)=4
33246 K(8,4)=0
33247 K(8,5)=0
33248 ENDIF
33249c WRITE(*,*)
33250c WRITE(*,*)
33251
33252c IF(PMODUL.GE.1.D+00) THEN
33253c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33254c write(*,*) pmodul
33255c DO I=1,3
33256c POL(4,I)=POL(4,I)/PMODUL
33257c POLARX(I)=POL(4,I)
33258c END DO
33259c PMODUL=0.
33260c DO I=1,3
33261c PMODUL=PMODUL+POL(4,I)**2
33262c END DO
33263c WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
33264c
33265c ENDIF
33266
33267c WRITE(*,*) 'PMODUL = ',PMODUL
33268
33269c WRITE(*,*)
33270c WRITE(*,*)
33271c WRITE(*,*) 'prepola: Now back to nucl rest frame'
33272
33273 CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
33274
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)
33278 DO NDC =6,8
33279 V(NDC,1) = XDC
33280 V(NDC,2) = YDC
33281 V(NDC,3) = ZDC
33282 END DO
33283
33284 RETURN
33285 END
33286*
33287*===testrot============================================================*
33288*
33289CDECK ID>, DT_TESTROT
33290 SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
33291
33292 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33293 SAVE
33294
33295 DIMENSION ROT(3,3),PI(3),PO(3)
33296
33297 IF (MODE.EQ.1) THEN
33298 ROT(1,1) = 1.D0
33299 ROT(1,2) = 0.D0
33300 ROT(1,3) = 0.D0
33301 ROT(2,1) = 0.D0
33302 ROT(2,2) = COS(PHI)
33303 ROT(2,3) = -SIN(PHI)
33304 ROT(3,1) = 0.D0
33305 ROT(3,2) = SIN(PHI)
33306 ROT(3,3) = COS(PHI)
33307 ELSEIF (MODE.EQ.2) THEN
33308 ROT(1,1) = 0.D0
33309 ROT(1,2) = 1.D0
33310 ROT(1,3) = 0.D0
33311 ROT(2,1) = COS(PHI)
33312 ROT(2,2) = 0.D0
33313 ROT(2,3) = -SIN(PHI)
33314 ROT(3,1) = SIN(PHI)
33315 ROT(3,2) = 0.D0
33316 ROT(3,3) = COS(PHI)
33317 ELSEIF (MODE.EQ.3) THEN
33318 ROT(1,1) = 0.D0
33319 ROT(2,1) = 1.D0
33320 ROT(3,1) = 0.D0
33321 ROT(1,2) = COS(PHI)
33322 ROT(2,2) = 0.D0
33323 ROT(3,2) = -SIN(PHI)
33324 ROT(1,3) = SIN(PHI)
33325 ROT(2,3) = 0.D0
33326 ROT(3,3) = COS(PHI)
33327 ELSEIF (MODE.EQ.4) THEN
33328 ROT(1,1) = 1.D0
33329 ROT(2,1) = 0.D0
33330 ROT(3,1) = 0.D0
33331 ROT(1,2) = 0.D0
33332 ROT(2,2) = COS(PHI)
33333 ROT(3,2) = -SIN(PHI)
33334 ROT(1,3) = 0.D0
33335 ROT(2,3) = SIN(PHI)
33336 ROT(3,3) = COS(PHI)
33337 ELSE
33338 STOP ' TESTROT: mode not supported!'
33339 ENDIF
33340 DO 1 J=1,3
33341 PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
33342 1 CONTINUE
33343
33344 RETURN
33345 END
33346*
33347*===lepdcyp============================================================*
33348*
33349CDECK ID>, DT_LEPDCYP
33350 SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
33351 & ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
33352C
33353C-----------------------------------------------------------------
33354C
33355C Author :- G. Battistoni 10-NOV-1995
33356C
33357C=================================================================
33358C
33359C Purpose : performs decay of polarized lepton in
33360C its rest frame: a => b + l + anti-nu
33361C (Example: mu- => nu-mu + e- + anti-nu-e)
33362C Polarization is assumed along Z-axis
33363C WARNING:
33364C 1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
33365C OF NEGLIGIBLE MASS
33366C 2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
33367C IN THIS VERSION
33368C
33369C Method : modifies phase space distribution obtained
33370C by routine EXPLOD using a rejection against the
33371C matrix element for unpolarized lepton decay
33372C
33373C Inputs : Mass of a : AMA
33374C Mass of l : AML
33375C Polar. of a: POL
33376C (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
33377C POL = -1)
33378C
33379C Outputs : kinematic variables in the rest frame of decaying lepton
33380C ETL,PXL,PYL,PZL 4-moment of l
33381C ETB,PXB,PYB,PZB 4-moment of b
33382C ETN,PXN,PYN,PZN 4-moment of anti-nu
33383C
33384C============================================================
33385C +
33386C Declarations.
33387C -
33388 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33389 SAVE
33390
33391 PARAMETER ( LINP = 5 ,
33392 & LOUT = 6 ,
33393 & LDAT = 9 )
33394
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 )
33448C +
33449C variables for EXPLOD
33450C -
33451 PARAMETER ( KPMX = 10 )
33452 DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
33453 & PZEXPL (KPMX), ETEXPL (KPMX)
33454C +
33455C test variables
33456C -
33457**sr - removed (not needed)
33458C COMMON /GBATNU/ ELERAT,NTRY
33459**
33460C +
33461C Initializes test variables
33462C -
33463 NTRY = 0
33464 ELERAT = 0.D+00
33465C +
33466C Maximum value for matrix element
33467C -
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 ) )
33470C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
33471C Inputs for EXPLOD
33472C part. no. 1 is l (e- in mu- decay)
33473C part. no. 2 is b (nu-mu in mu- decay)
33474C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
33475C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
33476 NPEXPL = 3
33477 ETOTEX = AMA
33478 AMEXPL(1) = AML
33479 AMEXPL(2) = 0.D+00
33480 AMEXPL(3) = 0.D+00
33481C +
33482C phase space distribution
33483C -
33484 100 CONTINUE
33485 NTRY = NTRY + 1
33486
33487 CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
33488 & PYEXPL, PZEXPL )
33489
33490C +
33491C Calculates matrix element:
33492C 64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
33493C Here CTH is the cosine of the angle between anti-nu and Z axis
33494C -
33495 CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
33496 & PZEXPL(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
33503 STOP
33504 ENDIF
33505C +
33506C Here performs the rejection
33507C -
33508 TEST = DT_RNDM(ETOTEX) * ELEMAX
33509 IF ( TEST .GT. ELEMAT ) GO TO 100
33510C +
33511C final assignment of variables
33512C -
33513 ELERAT = ELEMAT/ELEMAX
33514 ETL = ETEXPL(1)
33515 PXL = PXEXPL(1)
33516 PYL = PYEXPL(1)
33517 PZL = PZEXPL(1)
33518 ETB = ETEXPL(2)
33519 PXB = PXEXPL(2)
33520 PYB = PYEXPL(2)
33521 PZB = PZEXPL(2)
33522 ETN = ETEXPL(3)
33523 PXN = PXEXPL(3)
33524 PYN = PYEXPL(3)
33525 PZN = PZEXPL(3)
33526 999 RETURN
33527 END
33528
33529C==================================================================
33530C. Generation of Delta resonance events
33531C==================================================================
33532*
33533*===gen_delta==========================================================*
33534*
33535CDECK ID>, DT_GEN_DELTA
33536 SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
33537
33538 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33539 SAVE
33540
33541 PARAMETER ( LINP = 5 ,
33542 & LOUT = 6 ,
33543 & LDAT = 9 )
33544
33545C...Generate a Delta-production neutrino/antineutrino
33546C. CC-interaction on a nucleon
33547C
33548C. INPUT ENU (GeV) = Neutrino Energy
33549C. LLEP = neutrino type
33550C. LTARG = nucleon target type 1=p, 2=n.
33551C. JINT = 1:CC, 2::NC
33552C.
33553C. OUTPUT PPL(4) 4-monentum of final lepton
33554C----------------------------------------------------
33555
33556 PARAMETER (MAXLND=4000)
33557 COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
33558
33559**sr - removed (not needed)
33560C COMMON /CBAD/ LBAD, NBAD
33561**
33562
33563 DIMENSION PI(3),PO(3)
33564C 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/
33569
33570c WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
33571 LBAD = 0
33572C...Final lepton mass
33573 IF (JINT.EQ.1) THEN
33574 AML = AML0(LLEP)
33575 ELSE
33576 AML = 0.
33577 ENDIF
33578 AML2 = AML**2
33579
33580C...Particle labels (LUND)
33581 N = 5
33582 K(1,1) = 21
33583 K(2,1) = 21
33584 K(3,1) = 21
33585 K(4,1) = 1
33586 K(3,3) = 1
33587 K(4,3) = 1
33588 IF (LTARG .EQ. 1) THEN
33589 K(2,2) = 2212
33590 ELSE
33591 K(2,2) = 2112
33592 ENDIF
33593 K0 = (LLEP-1)/2
33594 K1 = LLEP/2
33595 KA = 12 + 2*K0
33596 IS = -1 + 2*LLEP - 4*K1
33597 LNU = 2 - LLEP + 2*K1
33598 K(1,2) = IS*KA
33599 K(5,1) = 1
33600 K(5,3) = 2
33601 IF (JINT .EQ. 1) THEN ! CC interactions
33602 K(3,2) = IS*24
33603 K(4,2) = IS*(KA-1)
33604 IF(LNU.EQ.1) THEN
33605 IF (LTARG .EQ. 1) THEN
33606 K(5,2) = 2224
33607 ELSE
33608 K(5,2) = 2214
33609 ENDIF
33610 ELSE
33611 IF (LTARG .EQ. 1) THEN
33612 K(5,2) = 2114
33613 ELSE
33614 K(5,2) = 1114
33615 ENDIF
33616 ENDIF
33617 ELSE
33618 K(3,2) = 23 ! NC (Z0) interactions
33619 K(4,2) = K(1,2)
33620**sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
33621* Delta0 for neutron (LTARG=2)
33622C IF (LTARG .EQ. 1) THEN
33623C K(5,2) = 2114
33624C ELSE
33625C K(5,2) = 2214
33626C ENDIF
33627 IF (LTARG .EQ. 1) THEN
33628 K(5,2) = 2214
33629 ELSE
33630 K(5,2) = 2114
33631 ENDIF
33632**
33633 ENDIF
33634
33635C...4-momentum initial lepton
33636 P(1,5) = 0.
33637 P(1,4) = ENU
33638 P(1,1) = 0.
33639 P(1,2) = 0.
33640 P(1,3) = ENU
33641C...4-momentum initial nucleon
33642 P(2,5) = AMN(LTARG)
33643C P(2,4) = P(2,5)
33644C P(2,1) = 0.
33645C P(2,2) = 0.
33646C P(2,3) = 0.
33647 P(2,1) = P21
33648 P(2,2) = P22
33649 P(2,3) = P23
33650 P(2,4) = P24
33651 P(2,5) = P25
33652 N=2
33653 beta1=-p(2,1)/p(2,4)
33654 beta2=-p(2,2)/p(2,4)
33655 beta3=-p(2,3)/p(2,4)
33656 N=2
33657
33658 CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
33659
33660C print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
33661
33662 phi11=atan(p(1,2)/p(1,3))
33663 pi(1)=p(1,1)
33664 pi(2)=p(1,2)
33665 pi(3)=p(1,3)
33666
33667 CALL DT_TESTROT(PI,Po,PHI11,1)
33668 DO ll=1,3
33669 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33670 END DO
33671 p(1,1)=po(1)
33672 p(1,2)=po(2)
33673 p(1,3)=po(3)
33674 phi12=atan(p(1,1)/p(1,3))
33675
33676 pi(1)=p(1,1)
33677 pi(2)=p(1,2)
33678 pi(3)=p(1,3)
33679 CALL DT_TESTROT(Pi,Po,PHI12,2)
33680 DO ll=1,3
33681 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33682 END DO
33683 p(1,1)=po(1)
33684 p(1,2)=po(2)
33685 p(1,3)=po(3)
33686
33687 ENUU=P(1,4)
33688
33689C...Generate the Mass of the Delta
33690 NTRY = 0
33691100 R = PYR(0)
33692 AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
33693 NTRY = NTRY + 1
33694 IF (NTRY .GT. 1000) THEN
33695 LBAD = 1
33696 WRITE (LOUT,1001) NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
33697 RETURN
33698 ENDIF
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
33702
33703C...Kinematical limits in Q**2
33704 S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
33705 SQS = SQRT(S)
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.
33712
33713 DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
33714200 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
33717
33718C...Generate the kinematics of the final particles
33719 EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
33720 GAM = EISTAR/AMN(LTARG)
33721 BET = PSTAR/EISTAR
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)
33730 P(4,3) = PLZ
33731 P(4,4) = EL
33732 P(4,5) = AML
33733
33734C...4-momentum of Delta
33735 P(5,1) = -P(4,1)
33736 P(5,2) = -P(4,2)
33737 P(5,3) = ENUU-P(4,3)
33738 P(5,4) = ENUU+AMN(LTARG)-P(4,4)
33739 P(5,5) = AMD
33740
33741C...4-momentum of intermediate boson
33742 P(3,5) = -Q2
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)
33747 N=5
33748
33749 DO kw=1,5
33750 pi(1)=p(kw,1)
33751 pi(2)=p(kw,2)
33752 pi(3)=p(kw,3)
33753 CALL DT_TESTROT(Pi,Po,PHI12,3)
33754 DO ll=1,3
33755 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33756 END DO
33757 p(kw,1)=po(1)
33758 p(kw,2)=po(2)
33759 p(kw,3)=po(3)
33760 END DO
33761
33762c********************************************
33763
33764 DO kw=1,5
33765 pi(1)=p(kw,1)
33766 pi(2)=p(kw,2)
33767 pi(3)=p(kw,3)
33768 CALL DT_TESTROT(Pi,Po,PHI11,4)
33769 DO ll=1,3
33770 IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
33771 END DO
33772 p(kw,1)=po(1)
33773 p(kw,2)=po(2)
33774 p(kw,3)=po(3)
33775 END DO
33776c********************************************
33777C transform back into Lab.
33778
33779 CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
33780
33781C WRITE(6,*)' Lab fram ( fermi incl.) '
33782 N=5
33783 CALL PYEXEC
33784
33785 RETURN
337861001 FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5, 6G10.3)
33787 END
33788*
33789*===dsigma_delta=======================================================*
33790*
33791CDECK ID>, DT_DSIGMA_DELTA
33792 DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
33793
33794 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33795 SAVE
33796
33797C...Reaction nu + N -> lepton + Delta
33798C. returns the cross section
33799C. dsigma/dt
33800C. INPUT LNU = 1, 2 (neutrino-antineutrino)
33801C. QQ = t (always negative) GeV**2
33802C. S = (c.m energy)**2 GeV**2
33803C. OUTPUT = 10**-38 cm+2/GeV**2
33804C-----------------------------------------------------
33805 REAL*8 MN, MN2, MN4, MD,MD2, MD4
33806 DATA MN /0.938/
33807 DATA PI /3.1415926/
33808
33809 GF = (1.1664 * 1.97)
33810 GF2 = GF*GF
33811 MN2 = MN*MN
33812 MN4 = MN2*MN2
33813 MD2 = MD*MD
33814 MD4 = MD2*MD2
33815 AML2 = AML*AML
33816 AML4 = AML2*AML2
33817 VQ = (MN2 - MD2 - QQ)/2.
33818 VPI = (MN2 + MD2 - QQ)/2.
33819 VK = (S + QQ - MN2 - AML2)/2.
33820 PIK = (S - MN2)/2.
33821 QK = (AML2 - QQ)/2.
33822 PIQ = (QQ + MN2 - MD2)/2.
33823 Q = SQRT(-QQ)
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
33828 C32 = C3**2
33829 C42 = C4**2
33830 C5A2 = C5A**2
33831
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
33856 ELSE
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
33880 ENDIF
33881 ANS1=32.*ANS2
33882 ANS=ANS1/(3.*MD2)
33883 P1CM = (S-MN2)/(2.*SQRT(S))
33884 DT_DSIGMA_DELTA = GF2/2. * ANS/(64.*PI*S*P1CM**2)
33885
33886 RETURN
33887 END
33888*
33889*===qgaus==============================================================*
33890*
33891CDECK ID>, DT_QGAUS
33892 SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
33893
33894 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33895 SAVE
33896
33897 DIMENSION X(5),W(5)
33898 DATA X/.1488743389D0,.4333953941D0,
33899 & .6794095682D0,.8650633666D0,.9739065285D0
33900 */
33901 DATA W/.2955242247D0,.2692667193D0,
33902 & .2190863625D0,.1494513491D0,.0666713443D0
33903 */
33904 XM=0.5D0*(B+A)
33905 XR=0.5D0*(B-A)
33906 SS=0
33907 DO 11 J=1,5
33908 DX=XR*X(J)
33909 SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
33910 * DT_DSQEL_Q2(LTYP,ENU,XM-DX))
3391111 CONTINUE
33912 SS=XR*SS
33913
33914 RETURN
33915 END
33916*
33917*===diqbrk=============================================================*
33918*
33919CDECK ID>, DT_DIQBRK
33920 SUBROUTINE DT_DIQBRK
33921
33922 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33923 SAVE
33924
33925* event history
33926
33927 PARAMETER (NMXHKK=200000)
33928
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),
33935 & IHIST(2,NMXHKK)
33936* event flag
33937 COMMON /DTEVNO/ NEVENT,ICASCA
33938
33939C IF(DT_RNDM(VV).LE.0.5D0)THEN
33940C CALL GSQBS1(NHKK)
33941C CALL GSQBS2(NHKK)
33942C CALL USQBS1(NHKK)
33943C CALL USQBS2(NHKK)
33944C CALL GSABS1(NHKK)
33945C CALL GSABS2(NHKK)
33946C CALL USABS1(NHKK)
33947C CALL USABS2(NHKK)
33948C ELSE
33949C CALL GSQBS2(NHKK)
33950C CALL GSQBS1(NHKK)
33951C CALL USQBS2(NHKK)
33952C CALL USQBS1(NHKK)
33953C CALL GSABS2(NHKK)
33954C CALL GSABS1(NHKK)
33955C CALL USABS2(NHKK)
33956C CALL USABS1(NHKK)
33957C ENDIF
33958
33959 IF(DT_RNDM(VV).LE.0.5D0) THEN
33960 CALL DT_DBREAK(1)
33961 CALL DT_DBREAK(2)
33962 CALL DT_DBREAK(3)
33963 CALL DT_DBREAK(4)
33964 CALL DT_DBREAK(5)
33965 CALL DT_DBREAK(6)
33966 CALL DT_DBREAK(7)
33967 CALL DT_DBREAK(8)
33968 ELSE
33969 CALL DT_DBREAK(2)
33970 CALL DT_DBREAK(1)
33971 CALL DT_DBREAK(4)
33972 CALL DT_DBREAK(3)
33973 CALL DT_DBREAK(6)
33974 CALL DT_DBREAK(5)
33975 CALL DT_DBREAK(8)
33976 CALL DT_DBREAK(7)
33977 ENDIF
33978
33979 RETURN
33980 END
33981C
33982C
33983C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
33984 SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
33985 * IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
33986C
33987C USQBS-2 diagram (split target diquark)
33988C
33989 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33990 SAVE
33991
33992 PARAMETER ( LINP = 5 ,
33993 & LOUT = 6 ,
33994 & LDAT = 9 )
33995
33996* event history
33997
33998 PARAMETER (NMXHKK=200000)
33999
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),
34006 & IHIST(2,NMXHKK)
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
34012
34013C
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
34017 +(4,NTMHKK)
34018*KEEP,XSEADI.
34019 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34020 +SSMIMQ,VVMTHR
34021*KEEP,DPRIN.
34022 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34023 COMMON /EVFLAG/ NUMEV
34024C
34025C USQBS-2 diagram (split target diquark)
34026C
34027C
34028C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34029C Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
34030C
34031C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34032C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34033C
34034C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34035C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34036C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34037C
34038C
34039C Put new chains into COMMON /HKKTMP/
34040C
34041 IIGLU1=NC1T-NC1P-1
34042 IIGLU2=NC2T-NC2P-1
34043 IGCOUN=0
34044C WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34045 CVQ=1.D0
34046 IREJ=0
34047 IF(IPIP.EQ.2)THEN
34048C IF(NUMEV.EQ.-324)THEN
34049C WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34050C * 'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
34051C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34052C * IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
34053 ENDIF
34054C
34055C
34056C
34057C determine x-values of NC1T diquark
34058 XDIQT=PHKK(4,NC1T)*2.D0/UMO
34059 XVQP=PHKK(4,NC1P)*2.D0/UMO
34060C
34061C determine x-values of sea quark pair
34062C
34063 IPCO=1
34064 ICOU=0
34065 2234 CONTINUE
34066 ICOU=ICOU+1
34067 IF(ICOU.GE.500)THEN
34068 IREJ=1
34069 IF(ISQ.EQ.3)IREJ=3
34070 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
34071 IPCO=0
34072 RETURN
34073 ENDIF
34074 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
34075 * UMO, XDIQT,XVQP
34076 XSQ=0.D0
34077 XSAQ=0.D0
34078**NEW
34079C 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
34083 ELSE
34084 XQMAX = 2.D0*XVQP/3.0D0
34085 XAQMAX = XDIQT/2.0D0
34086 ENDIF
34087 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34088 ISAQ = 6+ISQ
34089C write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34090**
34091 IF(IPCO.GE.3)
34092 & WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34093 IF(IREJ.GE.1)THEN
34094 IF(IPCO.GE.3)
34095 & WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34096 IPCO=0
34097 RETURN
34098 ENDIF
34099 IF(IPIP.EQ.1)THEN
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
34103 ENDIF
34104 IF(IPCO.GE.3)THEN
34105 WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34106 * XDIQT,XVQP,XSQ,XSAQ
34107 ENDIF
34108C
34109C subtract xsq,xsaq from NC1T diquark and NC1P quark
34110C
34111C XSQ=0.D0
34112 IF(IPIP.EQ.1)THEN
34113 XDIQT=XDIQT-XSQ
34114 XVQP =XVQP -XSAQ
34115 ELSEIF(IPIP.EQ.2)THEN
34116 XDIQT=XDIQT-XSAQ
34117 XVQP =XVQP -XSQ
34118 ENDIF
34119 IF(IPCO.GE.3)
34120 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34121C
34122C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34123C
34124 XVTHRO=CVQ/UMO
34125 IVTHR=0
34126 3466 CONTINUE
34127 IF(IVTHR.EQ.10)THEN
34128 IREJ=1
34129 IF(ISQ.EQ.3)IREJ=3
34130 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
34131 IPCO=0
34132 RETURN
34133 ENDIF
34134 IVTHR=IVTHR+1
34135 XVTHR=XVTHRO/(201-IVTHR)
34136 UNOPRV=UNON
34137 380 CONTINUE
34138 IF(XVTHR.GT.0.66D0*XDIQT)THEN
34139 IREJ=1
34140 IF(ISQ.EQ.3)IREJ=3
34141 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR large ',
34142 * XVTHR
34143 IPCO=0
34144 RETURN
34145 ENDIF
34146 IF(DT_RNDM(V).LT.0.5D0)THEN
34147 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34148 XVTQII=XDIQT-XVTQI
34149 ELSE
34150 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34151 XVTQI=XDIQT-XVTQII
34152 ENDIF
34153 IF(IPCO.GE.3)THEN
34154 WRITE(LOUT,'(A,2E12.4)')' MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34155 ENDIF
34156C
34157C Prepare 4 momenta of new chains and chain ends
34158C
34159C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34160C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34161C +(4,NTMHKK)
34162C
34163C Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
34164C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34165C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34166C
34167C SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34168C * IP1,IP21,IP22,IPP1,IPP2)
34169C
34170 IF(IPIP.EQ.1)THEN
34171 XSQ1=XSQ
34172 XSAQ1=XSAQ
34173 ISQ1=ISQ
34174 ISAQ1=ISAQ
34175 ELSEIF(IPIP.EQ.2)THEN
34176 XSQ1=XSAQ
34177 XSAQ1=XSQ
34178 ISQ1=ISAQ
34179 ISAQ1=ISQ
34180 ENDIF
34181 IDHKT(1) =IPP1
34182 ISTHKT(1) =951
34183 JMOHKT(1,1)=NC2P
34184 JMOHKT(2,1)=0
34185 JDAHKT(1,1)=3+IIGLU1
34186 JDAHKT(2,1)=0
34187C 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)
34192C PHKT(5,1) =PHKK(5,NC2P)
34193 XMIST =(PHKT(4,1)**2-
34194 * PHKT(3,1)**2-PHKT(2,1)**2-
34195 *PHKT(1,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-
34198 *PHKT(1,1)**2)
34199 ELSE
34200C WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
34201 PHKT(5,1)=0.D0
34202 ENDIF
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)
34211C Add here IIGLU1 gluons to this chaina
34212 PG1=0.D0
34213 PG2=0.D0
34214 PG3=0.D0
34215 PG4=0.D0
34216 IF(IIGLU1.GE.1)THEN
34217 JJG=NC1P
34218 DO 61 IIG=2,2+IIGLU1-1
34219 KKG=JJG+IIG-1
34220 IDHKT(IIG) =IDHKK(KKG)
34221 ISTHKT(IIG) =921
34222 JMOHKT(1,IIG)=KKG
34223 JMOHKT(2,IIG)=0
34224 JDAHKT(1,IIG)=3+IIGLU1
34225 JDAHKT(2,IIG)=0
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)
34243 61 CONTINUE
34244 ENDIF
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)
34255C 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)
34263 ELSE
34264C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34265 PHKT(5,5+IIGLU1)=0.D0
34266 ENDIF
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
34285 XMIST
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
34289 PHKT(5,3+IIGLU1)
34290 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
34291 * -PHKT(3,3+IIGLU1)**2)
34292 ELSE
34293C WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
34294 PHKT(5,5+IIGLU1)=0.D0
34295 ENDIF
34296 IF(IPIP.GE.2)THEN
34297C IF(NUMEV.EQ.-324)THEN
34298C WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
34299C * JDAHKT(1,1),
34300C *JDAHKT(2,1),(PHKT(III,1),III=1,5)
34301 DO 71 IIG=2,2+IIGLU1-1
34302C WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
34303C & JMOHKT(1,IIG),JMOHKT(2,IIG),
34304C * JDAHKT(1,IIG),
34305C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34306 71 CONTINUE
34307C WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
34308C * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
34309C *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
34310C WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
34311C * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
34312C *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
34313 ENDIF
34314 CHAMAL=CHAM1
34315 IF(IPIP.EQ.1)THEN
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
34319 ENDIF
34320 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
34321C IREJ=1
34322 IPCO=0
34323C RETURN
34324C WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
34325 GO TO 3466
34326 ENDIF
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)
34335 IF(IPIP.EQ.1)THEN
34336 IDHKT(4+IIGLU1) =-(ISAQ1-6)
34337 ELSEIF(IPIP.EQ.2)THEN
34338 IDHKT(4+IIGLU1) =ISAQ1
34339 ENDIF
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
34345C 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)
34350C 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)
34358 ELSE
34359C WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
34360 PHKT(5,4+IIGLU1)=0.D0
34361 ENDIF
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)
34380C 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)
34388 ELSE
34389C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34390 PHKT(5,5+IIGLU1)=0.D0
34391 ENDIF
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)
34410 XMIST
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
34414 PHKT(5,6+IIGLU1)
34415 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34416 * -PHKT(3,6+IIGLU1)**2)
34417 ELSE
34418C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34419 PHKT(5,5+IIGLU1)=0.D0
34420 ENDIF
34421C IF(IPIP.GE.2)THEN
34422C IF(NUMEV.EQ.-324)THEN
34423C WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
34424C * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
34425C *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
34426C WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
34427C * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
34428C *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
34429C WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
34430C * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
34431C *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
34432C ENDIF
34433 CHAMAL=CHAM1
34434 IF(IPIP.EQ.1)THEN
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
34438 ENDIF
34439 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34440C IREJ=1
34441 IPCO=0
34442C RETURN
34443C WRITE(6,*)' MUSQBS1 jump back from chain 6',
34444C * CHAMAL,PHKT(5,6+IIGLU1)
34445 GO TO 3466
34446 ENDIF
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)
34455C 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
34460**NEW
34461C JDAHKT(1,7+IIGLU1)=9+IIGLU1
34462 JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
34463**
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)
34469C 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)
34477 ELSE
34478C WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
34479 PHKT(5,7+IIGLU1)=0.D0
34480 ENDIF
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)
34489C Insert here the IIGLU2 gluons
34490 PG1=0.D0
34491 PG2=0.D0
34492 PG3=0.D0
34493 PG4=0.D0
34494 IF(IIGLU2.GE.1)THEN
34495 JJG=NC2P
34496 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34497 KKG=JJG+IIG-7-IIGLU1
34498 IDHKT(IIG) =IDHKK(KKG)
34499 ISTHKT(IIG) =921
34500 JMOHKT(1,IIG)=KKG
34501 JMOHKT(2,IIG)=0
34502 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
34503 JDAHKT(2,IIG)=0
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)
34521 81 CONTINUE
34522 ENDIF
34523 IF(IPIP.EQ.1)THEN
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
34533 ENDIF
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)
34547C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
34548C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
34549 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
34550C IREJ=1
34551C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
34552C * ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
34553 IPCO=0
34554C RETURN
34555 GO TO 3466
34556 ENDIF
34557C 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)
34565 ELSE
34566C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34567 PHKT(5,5+IIGLU1)=0.D0
34568 ENDIF
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
34583**NEW
34584C PHKT(1,9+IIGLU1+IIGLU2)
34585C * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
34586C PHKT(2,9+IIGLU1+IIGLU2)
34587C * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
34588C PHKT(3,9+IIGLU1+IIGLU2)
34589C * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
34590C PHKT(4,9+IIGLU1+IIGLU2)
34591C * =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
34600**
34601 XMIST
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)
34610 ELSE
34611C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
34612 PHKT(5,5+IIGLU1)=0.D0
34613 ENDIF
34614 IF(IPIP.GE.2)THEN
34615C IF(NUMEV.EQ.-324)THEN
34616C WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
34617C * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
34618C *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
34619C DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
34620C WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
34621C * JDAHKT(1,IIG),
34622C *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
34623C 91 CONTINUE
34624C WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
34625C * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
34626C *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
34627C *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
34628C WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
34629C * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
34630C *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
34631C *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
34632 ENDIF
34633 CHAMAL=CHAB1
34634 IF(IPIP.EQ.1)THEN
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
34638 ENDIF
34639 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
34640C IREJ=1
34641 IPCO=0
34642C RETURN
34643C WRITE(6,*)' MUSQBS1 jump back from chain 9',
34644C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
34645 GO TO 3466
34646 ENDIF
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)
34655C
34656 IPCO=0
34657 IGCOUN=9+IIGLU1+IIGLU2
34658 RETURN
34659 END
34660C
34661C
34662C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
34663 SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34664 * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
34665C
34666C GSQBS-2 diagram (split target diquark)
34667C
34668 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34669 SAVE
34670
34671 PARAMETER ( LINP = 5 ,
34672 & LOUT = 6 ,
34673 & LDAT = 9 )
34674
34675* event history
34676
34677 PARAMETER (NMXHKK=200000)
34678
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),
34685 & IHIST(2,NMXHKK)
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
34691
34692C
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
34696 +(4,NTMHKK)
34697
34698*KEEP,XSEADI.
34699 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
34700 +SSMIMQ,VVMTHR
34701*KEEP,DPRIN.
34702 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
34703C
34704C GSQBS-2 diagram (split target diquark)
34705C
34706C
34707C Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
34708C Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
34709C
34710C Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
34711C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34712C
34713C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34714C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34715C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34716C
34717C
34718C
34719C Put new chains into COMMON /HKKTMP/
34720C
34721 IIGLU1=NC1T-NC1P-1
34722 IIGLU2=NC2T-NC2P-1
34723 IGCOUN=0
34724C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
34725 CVQ=1.D0
34726 IREJ=0
34727C IF(IPIP.EQ.2)THEN
34728C WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
34729C * 'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
34730C *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34731C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
34732C ENDIF
34733C
34734C
34735C
34736C determine x-values of NC1T diquark
34737 XDIQT=PHKK(4,NC1T)*2.D0/UMO
34738 XVQP=PHKK(4,NC1P)*2.D0/UMO
34739C
34740C determine x-values of sea quark pair
34741C
34742 IPCO=1
34743 ICOU=0
34744 2234 CONTINUE
34745 ICOU=ICOU+1
34746 IF(ICOU.GE.500)THEN
34747 IREJ=1
34748 IF(ISQ.EQ.3)IREJ=3
34749 IF(IPCO.GE.3)
34750 & WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
34751 IPCO=0
34752 RETURN
34753 ENDIF
34754 IF(IPCO.GE.3)
34755 & WRITE(LOUT,*)'MGSQBS2 call XSEAPA: UMO,XDIQT,XVQP ',
34756 * UMO, XDIQT,XVQP
34757 XSQ=0.D0
34758 XSAQ=0.D0
34759**NEW
34760C 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
34764 ELSE
34765 XQMAX = 2.D0*XVQP/3.0D0
34766 XAQMAX = XDIQT/2.0D0
34767 ENDIF
34768 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
34769 ISAQ = 6+ISQ
34770C write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
34771**
34772 IF(IPCO.GE.3)
34773 & WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34774 IF(IREJ.GE.1)THEN
34775 IF(IPCO.GE.3)
34776 & WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
34777 IPCO=0
34778 RETURN
34779 ENDIF
34780 IF(IPIP.EQ.1)THEN
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
34784 ENDIF
34785 IF(IPCO.GE.3)THEN
34786 WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
34787 * XDIQT,XVQP,XSQ,XSAQ
34788 ENDIF
34789C
34790C subtract xsq,xsaq from NC1T diquark and NC1P quark
34791C
34792C XSQ=0.D0
34793 IF(IPIP.EQ.1)THEN
34794 XDIQT=XDIQT-XSQ
34795 XVQP =XVQP -XSAQ
34796 ELSEIF(IPIP.EQ.2)THEN
34797 XDIQT=XDIQT-XSAQ
34798 XVQP =XVQP -XSQ
34799 ENDIF
34800 IF(IPCO.GE.3)
34801 & WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
34802C
34803C Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
34804C
34805 XVTHRO=CVQ/UMO
34806 IVTHR=0
34807 3466 CONTINUE
34808 IF(IVTHR.EQ.10)THEN
34809 IREJ=1
34810 IF(ISQ.EQ.3)IREJ=3
34811 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
34812 IPCO=0
34813 RETURN
34814 ENDIF
34815 IVTHR=IVTHR+1
34816 XVTHR=XVTHRO/(201-IVTHR)
34817 UNOPRV=UNON
34818 380 CONTINUE
34819 IF(XVTHR.GT.0.66D0*XDIQT)THEN
34820 IREJ=1
34821 IF(ISQ.EQ.3)IREJ=3
34822 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR large ',
34823 * XVTHR
34824 IPCO=0
34825 RETURN
34826 ENDIF
34827 IF(DT_RNDM(V).LT.0.5D0)THEN
34828 XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34829 XVTQII=XDIQT-XVTQI
34830 ELSE
34831 XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
34832 XVTQI=XDIQT-XVTQII
34833 ENDIF
34834 IF(IPCO.GE.3)THEN
34835 WRITE(LOUT,'(A,2E12.4)')' MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
34836 ENDIF
34837C
34838C Prepare 4 momenta of new chains and chain ends
34839C
34840C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
34841C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
34842C +(4,NTMHKK)
34843C
34844C Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
34845C 6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
34846C 9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
34847C
34848C SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
34849C * IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
34850C
34851 IF(IPIP.EQ.1)THEN
34852 XSQ1=XSQ
34853 XSAQ1=XSAQ
34854 ISQ1=ISQ
34855 ISAQ1=ISAQ
34856 ELSEIF(IPIP.EQ.2)THEN
34857 XSQ1=XSAQ
34858 XSAQ1=XSQ
34859 ISQ1=ISAQ
34860 ISAQ1=ISQ
34861 ENDIF
34862 KK11=IP21
34863C IDHKT(1) =1000*IPP11+100*IPP12+1
34864 KK21=IPP11
34865 KK22=IPP12
34866 XGIVE=0.D0
34867 IF(IPIP.EQ.1)THEN
34868 IDHKT(4+IIGLU1) =-(ISAQ1-6)
34869 ELSEIF(IPIP.EQ.2)THEN
34870 IDHKT(4+IIGLU1) =ISAQ1
34871 ENDIF
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
34877C 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)
34882C 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)
34888 ELSE
34889 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
34890 XXMIST=ABS(XXMIST)
34891 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
34892 ENDIF
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)
34911C 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)
34917 ELSE
34918 WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
34919 XXMIST=ABS(XXMIST)
34920 PHKT(5,5+IIGLU1) =SQRT(XXMIST)
34921 ENDIF
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)
34940 PHKT(5,6+IIGLU1)
34941 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
34942 * -PHKT(3,6+IIGLU1)**2)
34943 CHAMAL=CHAM1
34944 IF(IPIP.EQ.1)THEN
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
34948 ENDIF
34949C---------------------------------------------------
34950 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
34951 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
34952C we drop chain 6 and give the energy to chain 3
34953 IDHKT(6+IIGLU1)=22888
34954 XGIVE=1.D0
34955C WRITE(6,*)' drop chain 6 xgive=1'
34956 GO TO 7788
34957 ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
34958C we drop chain 6 and give the energy to chain 3
34959C and change KK11 to IDHKT(5)
34960 IDHKT(6+IIGLU1)=22888
34961 XGIVE=1.D0
34962C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
34963 KK11=IDHKT(5+IIGLU1)
34964 GO TO 7788
34965 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
34966C we drop chain 6 and give the energy to chain 3
34967C and change KK21 to IDHKT(5+IIGLU1)
34968C IDHKT(1) =1000*IPP11+100*IPP12+1
34969 IDHKT(6+IIGLU1)=22888
34970 XGIVE=1.D0
34971C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
34972 KK21=IDHKT(5+IIGLU1)
34973 GO TO 7788
34974 ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
34975C we drop chain 6 and give the energy to chain 3
34976C and change KK22 to IDHKT(5)
34977C IDHKT(1) =1000*IPP11+100*IPP12+1
34978 IDHKT(6+IIGLU1)=22888
34979 XGIVE=1.D0
34980C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
34981 KK22=IDHKT(5+IIGLU1)
34982 GO TO 7788
34983 ENDIF
34984C IREJ=1
34985 IPCO=0
34986C RETURN
34987 GO TO 3466
34988 ENDIF
34989 7788 CONTINUE
34990C---------------------------------------------------
34991 IF(IPIP.GE.3)THEN
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)
35001 ENDIF
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)
35010C IDHKT(1) =1000*IPP11+100*IPP12+1
35011 IF(IPIP.EQ.1)THEN
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
35021 ENDIF
35022 ISTHKT(1) =961
35023 JMOHKT(1,1)=NC2P
35024 JMOHKT(2,1)=0
35025 JDAHKT(1,1)=3+IIGLU1
35026 JDAHKT(2,1)=0
35027C 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)
35036C PHKT(5,1) =PHKK(5,NC2P)
35037 XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35038 *PHKT(1,1)**2
35039 IF(XXMIST.GT.0.D0)THEN
35040 PHKT(5,1) =SQRT(XXMIST)
35041 ELSE
35042 WRITE(LOUT,*)'MGSQBS2',XXMIST
35043 XXMIST=ABS(XXMIST)
35044 PHKT(5,1) =SQRT(XXMIST)
35045 ENDIF
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)
35054C Add here IIGLU1 gluons to this chaina
35055 PG1=0.D0
35056 PG2=0.D0
35057 PG3=0.D0
35058 PG4=0.D0
35059 IF(IIGLU1.GE.1)THEN
35060 JJG=NC1P
35061 DO 61 IIG=2,2+IIGLU1-1
35062 KKG=JJG+IIG-1
35063 IDHKT(IIG) =IDHKK(KKG)
35064 ISTHKT(IIG) =921
35065 JMOHKT(1,IIG)=KKG
35066 JMOHKT(2,IIG)=0
35067 JDAHKT(1,IIG)=3+IIGLU1
35068 JDAHKT(2,IIG)=0
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)
35086 61 CONTINUE
35087 ENDIF
35088C IDHKT(2) =IP21
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)
35096C * +0.5D0*PHKK(1,NC2T)
35097 *+XGIVE*PHKT(1,5+IIGLU1)
35098 PHKT(2,2+IIGLU1) =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35099C *+0.5D0*PHKK(2,NC2T)
35100 *+XGIVE*PHKT(2,5+IIGLU1)
35101 PHKT(3,2+IIGLU1) =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35102C *+0.5D0*PHKK(3,NC2T)
35103 *+XGIVE*PHKT(3,5+IIGLU1)
35104 PHKT(4,2+IIGLU1) =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35105C *+0.5D0*PHKK(4,NC2T)
35106 *+XGIVE*PHKT(4,5+IIGLU1)
35107C 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)
35113 ELSE
35114 WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
35115 XXMIST=ABS(XXMIST)
35116 PHKT(5,2+IIGLU1) =SQRT(XXMIST)
35117 ENDIF
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
35136 PHKT(5,3+IIGLU1)
35137 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35138 * -PHKT(3,3+IIGLU1)**2)
35139 IF(IPIP.EQ.3)THEN
35140 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35141 * JDAHKT(1,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),
35146 * JDAHKT(1,IIG),
35147 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35148 71 CONTINUE
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)
35155 ENDIF
35156 CHAMAL=CHAB1
35157 IF(IPIP.EQ.1)THEN
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
35161 ENDIF
35162 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35163C IREJ=1
35164 IPCO=0
35165C RETURN
35166 GO TO 3466
35167 ENDIF
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)
35176C 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)
35187C 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)
35193 ELSE
35194 WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
35195 XXMIST=ABS(XXMIST)
35196 PHKT(5,7+IIGLU1) =SQRT(XXMIST)
35197 ENDIF
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)
35206C IDHKT(7) =1000*IPP1+100*ISQ+1
35207C Insert here the IIGLU2 gluons
35208 PG1=0.D0
35209 PG2=0.D0
35210 PG3=0.D0
35211 PG4=0.D0
35212 IF(IIGLU2.GE.1)THEN
35213 JJG=NC2P
35214 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35215 KKG=JJG+IIG-7-IIGLU1
35216 IDHKT(IIG) =IDHKK(KKG)
35217 ISTHKT(IIG) =921
35218 JMOHKT(1,IIG)=KKG
35219 JMOHKT(2,IIG)=0
35220 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35221 JDAHKT(2,IIG)=0
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)
35239 81 CONTINUE
35240 ENDIF
35241 IF(IPIP.EQ.1)THEN
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
35247**NEW
35248C IDHKT(8) =1000*IPP2+100*(-ISQ1+6)-3
35249 IDHKT(8+IIGLU1+IIGLU2) =1000*IPP2+100*(-ISQ1+6)-3
35250**
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
35254 ENDIF
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
35260C PHKT(1,8) =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
35261C PHKT(2,8) =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
35262C PHKT(3,8) =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
35263C 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)
35272C WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
35273C * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
35274 IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
35275C IREJ=1
35276C WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
35277 IPCO=0
35278C RETURN
35279 GO TO 3466
35280 ENDIF
35281C 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)
35311 IF(IPIP.GE.3)THEN
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),
35318 * JDAHKT(1,IIG),
35319 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35320 91 CONTINUE
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)
35329 ENDIF
35330 CHAMAL=CHAB1
35331 IF(IPIP.EQ.1)THEN
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
35335 ENDIF
35336 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35337C IREJ=1
35338 IPCO=0
35339C RETURN
35340 GO TO 3466
35341 ENDIF
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)
35350C
35351 IPCO=0
35352 IGCOUN=9+IIGLU1+IIGLU2
35353 RETURN
35354 END
35355C
35356C
35357C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35358 SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35359 * IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35360C
35361C USQBS-1 diagram (split projectile diquark)
35362C
35363 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35364 SAVE
35365
35366 PARAMETER ( LINP = 5 ,
35367 & LOUT = 6 ,
35368 & LDAT = 9 )
35369
35370* event history
35371
35372 PARAMETER (NMXHKK=200000)
35373
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),
35380 & IHIST(2,NMXHKK)
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
35386
35387C
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
35391 +(4,NTMHKK)
35392*KEEP,XSEADI.
35393 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35394 +SSMIMQ,VVMTHR
35395*KEEP,DPRIN.
35396 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35397 COMMON /EVFLAG/ NUMEV
35398C
35399C USQBS-1 diagram (split projectile diquark)
35400C
35401C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
35402C Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
35403C
35404C Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
35405C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35406C
35407C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35408C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35409C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35410C
35411C Put new chains into COMMON /HKKTMP/
35412C
35413 IIGLU1=NC1T-NC1P-1
35414 IIGLU2=NC2T-NC2P-1
35415 IGCOUN=0
35416C WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
35417 CVQ=1.D0
35418 IREJ=0
35419 IF(IPIP.EQ.3)THEN
35420C 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
35425 ENDIF
35426C
35427C
35428C
35429C determine x-values of NC1P diquark
35430 XDIQP=PHKK(4,NC1P)*2.D0/UMO
35431 XVQT=PHKK(4,NC1T)*2.D0/UMO
35432C
35433C determine x-values of sea quark pair
35434C
35435 IPCO=1
35436 ICOU=0
35437 2234 CONTINUE
35438 ICOU=ICOU+1
35439 IF(ICOU.GE.500)THEN
35440 IREJ=1
35441 IF(ISQ.EQ.3)IREJ=3
35442 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
35443 IPCO=0
35444 RETURN
35445 ENDIF
35446 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
35447 * UMO, XDIQP,XVQT
35448 XSQ=0.D0
35449 XSAQ=0.D0
35450**NEW
35451C 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
35455 ELSE
35456 XQMAX = 2.D0*XVQT/3.0D0
35457 XAQMAX = XDIQP/2.0D0
35458 ENDIF
35459 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35460 ISAQ = 6+ISQ
35461C write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
35462**
35463 IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35464 IF(IREJ.GE.1)THEN
35465 IF(IPCO.GE.3)
35466 & WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35467 IPCO=0
35468 RETURN
35469 ENDIF
35470 IF(IPIP.EQ.1)THEN
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
35474 ENDIF
35475 IF(IPCO.GE.3)THEN
35476 WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
35477 * XDIQP,XVQT,XSQ,XSAQ
35478 ENDIF
35479C
35480C subtract xsq,xsaq from NC1P diquark and NC1T quark
35481C
35482C XSQ=0.D0
35483 IF(IPIP.EQ.1)THEN
35484 XDIQP=XDIQP-XSQ
35485 XVQT =XVQT -XSAQ
35486 ELSEIF(IPIP.EQ.2)THEN
35487 XDIQP=XDIQP-XSAQ
35488 XVQT =XVQT -XSQ
35489 ENDIF
35490 IF(IPCO.GE.3)
35491 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
35492C
35493C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
35494C
35495 XVTHRO=CVQ/UMO
35496 IVTHR=0
35497 3466 CONTINUE
35498 IF(IVTHR.EQ.10)THEN
35499 IREJ=1
35500 IF(ISQ.EQ.3)IREJ=3
35501 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
35502 IPCO=0
35503 RETURN
35504 ENDIF
35505 IVTHR=IVTHR+1
35506 XVTHR=XVTHRO/(201-IVTHR)
35507 UNOPRV=UNON
35508 380 CONTINUE
35509 IF(XVTHR.GT.0.66D0*XDIQP)THEN
35510 IREJ=1
35511 IF(ISQ.EQ.3)IREJ=3
35512 IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR large ',
35513 * XVTHR
35514 IPCO=0
35515 RETURN
35516 ENDIF
35517 IF(DT_RNDM(V).LT.0.5D0)THEN
35518 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35519 XVPQII=XDIQP-XVPQI
35520 ELSE
35521 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
35522 XVPQI=XDIQP-XVPQII
35523 ENDIF
35524 IF(IPCO.GE.3)THEN
35525 WRITE(LOUT,'(A,2E12.4)')' MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
35526 ENDIF
35527C
35528C Prepare 4 momenta of new chains and chain ends
35529C
35530C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35531C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35532C +(4,NTMHKK)
35533C Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
35534C 6 valence quark(vq2P 4)-sea-quark(aqsT 5)
35535C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
35536 IF(IPIP.EQ.1)THEN
35537 XSQ1=XSQ
35538 XSAQ1=XSAQ
35539 ISQ1=ISQ
35540 ISAQ1=ISAQ
35541 ELSEIF(IPIP.EQ.2)THEN
35542 XSQ1=XSAQ
35543 XSAQ1=XSQ
35544 ISQ1=ISAQ
35545 ISAQ1=ISQ
35546 ENDIF
35547 IDHKT(1) =IP11
35548 ISTHKT(1) =931
35549 JMOHKT(1,1)=NC1P
35550 JMOHKT(2,1)=0
35551 JDAHKT(1,1)=3+IIGLU1
35552 JDAHKT(2,1)=0
35553C 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)
35558C PHKT(5,1) =PHKK(5,NC1P)
35559 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35560 *PHKT(1,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-
35563 *PHKT(1,1)**2)
35564 ELSE
35565C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35566 PHKT(5,1)=0.D0
35567 ENDIF
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)
35576C Add here IIGLU1 gluons to this chaina
35577 PG1=0.D0
35578 PG2=0.D0
35579 PG3=0.D0
35580 PG4=0.D0
35581 IF(IIGLU1.GE.1)THEN
35582 JJG=NC1P
35583 DO 61 IIG=2,2+IIGLU1-1
35584 KKG=JJG+IIG-1
35585 IDHKT(IIG) =IDHKK(KKG)
35586 ISTHKT(IIG) =921
35587 JMOHKT(1,IIG)=KKG
35588 JMOHKT(2,IIG)=0
35589 JDAHKT(1,IIG)=3+IIGLU1
35590 JDAHKT(2,IIG)=0
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)
35608 61 CONTINUE
35609 ENDIF
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)
35620C 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)
35628 ELSE
35629C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35630 PHKT(5,2+IIGLU1)=0.D0
35631 ENDIF
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
35650 XMIST
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
35654 PHKT(5,3+IIGLU1)
35655 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35656 * -PHKT(3,3+IIGLU1)**2)
35657 ELSE
35658C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35659 PHKT(5,1)=0.D0
35660 ENDIF
35661 IF(IPIP.GE.3)THEN
35662C 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),
35669 * JDAHKT(1,IIG),
35670 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35671 71 CONTINUE
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)
35678 ENDIF
35679 CHAMAL=CHAM1
35680 IF(IPIP.EQ.1)THEN
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
35684 ENDIF
35685 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35686C IREJ=1
35687 IPCO=0
35688C RETURN
35689C WRITE(6,*)' MUSQBS1 jump back from chain 3'
35690 GO TO 3466
35691 ENDIF
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
35706C 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)
35711C 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)
35719 ELSE
35720C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35721 PHKT(5,4+IIGLU1)=0.D0
35722 ENDIF
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)
35731 IF(IPIP.EQ.1)THEN
35732 IDHKT(5+IIGLU1) =-(ISAQ1-6)
35733 ELSEIF(IPIP.EQ.2)THEN
35734 IDHKT(5+IIGLU1) =ISAQ1
35735 ENDIF
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)
35745C IF( PHKT(4,5).EQ.0.D0)THEN
35746C IREJ=1
35747CIPCO=0
35748CRETURN
35749C ENDIF
35750C 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)
35758 ELSE
35759C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35760 PHKT(5,5+IIGLU1)=0.D0
35761 ENDIF
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)
35780 XMIST
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
35784 PHKT(5,6+IIGLU1)
35785 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
35786 * -PHKT(3,6+IIGLU1)**2)
35787 ELSE
35788C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35789 PHKT(5,1)=0.D0
35790 ENDIF
35791C IF(IPIP.EQ.3)THEN
35792 CHAMAL=CHAM1
35793 IF(IPIP.EQ.1)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
35797 ENDIF
35798 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
35799C IREJ=1
35800 IPCO=0
35801C RETURN
35802C WRITE(6,*)' MGSQBS1 jump back from chain 6',
35803C * CHAMAL,PHKT(5,6+IIGLU1)
35804 GO TO 3466
35805 ENDIF
35806 IF(IPIP.GE.3)THEN
35807C 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)
35817 ENDIF
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)
35826 IF(IPIP.EQ.1)THEN
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
35836C WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
35837 ENDIF
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
35843C 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)
35848C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
35849C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
35850 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
35851C IREJ=1
35852C WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
35853 IPCO=0
35854C RETURN
35855 GO TO 3466
35856 ENDIF
35857C 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)
35869C Insert here the IIGLU2 gluons
35870 PG1=0.D0
35871 PG2=0.D0
35872 PG3=0.D0
35873 PG4=0.D0
35874 IF(IIGLU2.GE.1)THEN
35875 JJG=NC2P
35876 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
35877 KKG=JJG+IIG-7-IIGLU1
35878 IDHKT(IIG) =IDHKK(KKG)
35879 ISTHKT(IIG) =921
35880 JMOHKT(1,IIG)=KKG
35881 JMOHKT(2,IIG)=0
35882 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
35883 JDAHKT(2,IIG)=0
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)
35901 81 CONTINUE
35902 ENDIF
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)
35913C 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)
35921 ELSE
35922C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
35923 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
35924 ENDIF
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
35947 XMIST
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)
35956 ELSE
35957C WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
35958 PHKT(5,1)=0.D0
35959 ENDIF
35960 IF(IPIP.GE.3)THEN
35961C 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),
35968 * JDAHKT(1,IIG),
35969 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35970 91 CONTINUE
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)
35980 ENDIF
35981 CHAMAL=CHAB1
35982 IF(IPIP.EQ.1)THEN
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
35986 ENDIF
35987 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
35988C IREJ=1
35989 IPCO=0
35990C RETURN
35991C WRITE(6,*)' MGSQBS1 jump back from chain 9',
35992C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
35993 GO TO 3466
35994 ENDIF
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)
36003C
36004 IPCO=0
36005 IGCOUN=9+IIGLU1+IIGLU2
36006 RETURN
36007 END
36008C
36009C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36010 SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36011 * IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
36012C
36013C GSQBS-1 diagram (split projectile diquark)
36014C
36015 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36016 SAVE
36017
36018 PARAMETER ( LINP = 5 ,
36019 & LOUT = 6 ,
36020 & LDAT = 9 )
36021
36022* event history
36023
36024 PARAMETER (NMXHKK=200000)
36025
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),
36032 & IHIST(2,NMXHKK)
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
36038
36039C
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
36043 +(4,NTMHKK)
36044*KEEP,XSEADI.
36045 COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36046 +SSMIMQ,VVMTHR
36047*KEEP,DPRIN.
36048 COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36049C
36050C GSQBS-1 diagram (split projectile diquark)
36051C
36052C
36053C Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
36054C Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
36055C
36056C Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
36057C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36058C
36059C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36060C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36061C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36062C
36063C Put new chains into COMMON /HKKTMP/
36064C
36065 IIGLU1=NC1T-NC1P-1
36066 IIGLU2=NC2T-NC2P-1
36067 IGCOUN=0
36068C WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36069 CVQ=1.D0
36070 NNNC1=IDHKK(NC1)/1000
36071 MMMC1=IDHKK(NC1)-NNNC1*1000
36072 KKKC1=ISTHKK(NC1)
36073 NNNC2=IDHKK(NC2)/1000
36074 MMMC2=IDHKK(NC2)-NNNC2*1000
36075 KKKC2=ISTHKK(NC2)
36076 IREJ=0
36077 IF(IPIP.EQ.3)THEN
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
36082 ENDIF
36083C
36084C
36085C
36086C determine x-values of NC1P diquark
36087 XDIQP=PHKK(4,NC1P)*2.D0/UMO
36088 XVQT=PHKK(4,NC1T)*2.D0/UMO
36089C
36090C determine x-values of sea quark pair
36091C
36092 IPCO=1
36093 ICOU=0
36094 2234 CONTINUE
36095 ICOU=ICOU+1
36096 IF(ICOU.GE.500)THEN
36097 IREJ=1
36098 IF(ISQ.EQ.3)IREJ=3
36099 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
36100 IPCO=0
36101 RETURN
36102 ENDIF
36103 IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call XSEAPA: UMO,XDIQP,XVQT ',
36104 * UMO, XDIQP,XVQT
36105 XSQ=0.D0
36106 XSAQ=0.D0
36107**NEW
36108C 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
36112 ELSE
36113 XQMAX = 2.D0*XVQT/3.0D0
36114 XAQMAX = XDIQP/2.0D0
36115 ENDIF
36116 CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36117 ISAQ = 6+ISQ
36118C write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
36119**
36120 IF(IPCO.GE.3)
36121 & WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36122 IF(IREJ.GE.1)THEN
36123 IF(IPCO.GE.3)
36124 & WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36125 IPCO=0
36126 RETURN
36127 ENDIF
36128 IF(IPIP.EQ.1)THEN
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
36132 ENDIF
36133 IF(IPCO.GE.3)THEN
36134 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
36135 * XDIQP,XVQT,XSQ,XSAQ
36136 ENDIF
36137C
36138C subtract xsq,xsaq from NC1P diquark and NC1T quark
36139C
36140C XSQ=0.D0
36141 IF(IPIP.EQ.1)THEN
36142 XDIQP=XDIQP-XSQ
36143**NEW
36144C IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
36145**
36146 XVQT =XVQT -XSAQ
36147 ELSEIF(IPIP.EQ.2)THEN
36148 XDIQP=XDIQP-XSAQ
36149 XVQT =XVQT -XSQ
36150 ENDIF
36151 IF(IPCO.GE.3)
36152 & WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
36153C
36154C Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
36155C
36156 XVTHRO=CVQ/UMO
36157 IVTHR=0
36158 3466 CONTINUE
36159 IF(IVTHR.EQ.10)THEN
36160 IREJ=1
36161 IF(ISQ.EQ.3)IREJ=3
36162 IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
36163 IPCO=0
36164 RETURN
36165 ENDIF
36166 IVTHR=IVTHR+1
36167 XVTHR=XVTHRO/(201-IVTHR)
36168 UNOPRV=UNON
36169 380 CONTINUE
36170 IF(XVTHR.GT.0.66D0*XDIQP)THEN
36171 IREJ=1
36172 IF(ISQ.EQ.3)IREJ=3
36173 IF(IPCO.GE.3)
36174 & WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR large ',
36175 * XVTHR
36176 IPCO=0
36177 RETURN
36178 ENDIF
36179 IF(DT_RNDM(V).LT.0.5D0)THEN
36180 XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36181 XVPQII=XDIQP-XVPQI
36182 ELSE
36183 XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
36184 XVPQI=XDIQP-XVPQII
36185 ENDIF
36186 IF(IPCO.GE.3)THEN
36187 WRITE(LOUT,'(A,4E12.4)')' MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
36188 * XVTHR,XDIQP,XVPQI,XVPQII
36189 ENDIF
36190C
36191C Prepare 4 momenta of new chains and chain ends
36192C
36193C COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36194C +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36195C +(4,NTMHKK)
36196C Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
36197C 6 valence quark(vq2P 4)-sea-quark(aqsP 5)
36198C 9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
36199 IF(IPIP.EQ.1)THEN
36200 XSQ1=XSQ
36201 XSAQ1=XSAQ
36202 ISQ1=ISQ
36203 ISAQ1=ISAQ
36204 ELSEIF(IPIP.EQ.2)THEN
36205 XSQ1=XSAQ
36206 XSAQ1=XSQ
36207 ISQ1=ISAQ
36208 ISAQ1=ISQ
36209 ENDIF
36210 KK11=IP11
36211C IDHKT(2) =1000*IPP21+100*IPP22+1
36212 KK21= IPP21
36213 KK22= IPP22
36214 XGIVE=0.D0
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
36221**NEW
36222 IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
36223 & (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
36224**
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)
36229C 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)
36235 ELSE
36236 WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
36237 XXMIST=ABS(XXMIST)
36238 PHKT(5,4+IIGLU1) =SQRT(XXMIST)
36239 ENDIF
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)
36248 IF(IPIP.EQ.1)THEN
36249 IDHKT(5+IIGLU1) =-(ISAQ1-6)
36250 ELSEIF(IPIP.EQ.2)THEN
36251 IDHKT(5+IIGLU1) =ISAQ1
36252 ENDIF
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
36258**NEW
36259 IF ((XSAQ1.LT.0.0D0).OR.(XVQT .LT.0.0D0))
36260 & WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
36261**
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)
36266C 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)
36274 ELSE
36275C WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36276 PHKT(5,5+IIGLU1)=0.D0
36277 ENDIF
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
36287C IDHKT(6) =1000*NNNC1+MMMC1
36288 ISTHKT(6+IIGLU1) =93
36289C ISTHKT(6) =KKKC1
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)
36298 PHKT(5,6+IIGLU1)
36299 * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36300 * -PHKT(3,6+IIGLU1)**2)
36301 CHAMAL=CHAM1
36302 IF(IPIP.EQ.1)THEN
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
36306 ENDIF
36307 IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36308 IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36309C we drop chain 6 and give the energy to chain 3
36310 IDHKT(6+IIGLU1)=33888
36311 XGIVE=1.D0
36312C WRITE(6,*)' drop chain 6 xgive=1'
36313 GO TO 7788
36314 ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
36315C we drop chain 6 and give the energy to chain 3
36316C and change KK11 to IDHKT(4)
36317 IDHKT(6+IIGLU1)=33888
36318 XGIVE=1.D0
36319C WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
36320 KK11=IDHKT(4+IIGLU1)
36321 GO TO 7788
36322 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
36323C we drop chain 6 and give the energy to chain 3
36324C and change KK21 to IDHKT(4)
36325C IDHKT(2) =1000*IPP21+100*IPP22+1
36326 IDHKT(6+IIGLU1)=33888
36327 XGIVE=1.D0
36328C WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
36329 KK21=IDHKT(4+IIGLU1)
36330 GO TO 7788
36331 ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
36332C we drop chain 6 and give the energy to chain 3
36333C and change KK22 to IDHKT(4)
36334C IDHKT(2) =1000*IPP21+100*IPP22+1
36335 IDHKT(6+IIGLU1)=33888
36336 XGIVE=1.D0
36337C WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
36338 KK22=IDHKT(4+IIGLU1)
36339 GO TO 7788
36340 ENDIF
36341C IREJ=1
36342 IPCO=0
36343C RETURN
36344C WRITE(6,*)' MGSQBS1 jump back from chain 6'
36345 GO TO 3466
36346 ENDIF
36347 7788 CONTINUE
36348 IF(IPIP.GE.3)THEN
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)
36361 ENDIF
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)
36370C IDHKT(1) =IP11
36371 IDHKT(1) =KK11
36372 ISTHKT(1) =921
36373 JMOHKT(1,1)=NC1P
36374 JMOHKT(2,1)=0
36375 JDAHKT(1,1)=3+IIGLU1
36376 JDAHKT(2,1)=0
36377 PHKT(1,1) =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
36378C * +0.5D0*PHKK(1,NC2P)
36379 *+XGIVE*PHKT(1,4+IIGLU1)
36380 PHKT(2,1) =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
36381C * +0.5D0*PHKK(2,NC2P)
36382 *+XGIVE*PHKT(2,4+IIGLU1)
36383 PHKT(3,1) =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
36384C * +0.5D0*PHKK(3,NC2P)
36385 *+XGIVE*PHKT(3,4+IIGLU1)
36386 PHKT(4,1) =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
36387C * +0.5D0*PHKK(4,NC2P)
36388 *+XGIVE*PHKT(4,4+IIGLU1)
36389C PHKT(5,1) =PHKK(5,NC1P)
36390 XMIST =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36391 *PHKT(1,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-
36394 *PHKT(1,1)**2)
36395 ELSE
36396C WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
36397 PHKT(5,1)=0.D0
36398 ENDIF
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)
36407C Add here IIGLU1 gluons to this chaina
36408 PG1=0.D0
36409 PG2=0.D0
36410 PG3=0.D0
36411 PG4=0.D0
36412 IF(IIGLU1.GE.1)THEN
36413 JJG=NC1P
36414 DO 61 IIG=2,2+IIGLU1-1
36415 KKG=JJG+IIG-1
36416 IDHKT(IIG) =IDHKK(KKG)
36417 ISTHKT(IIG) =921
36418 JMOHKT(1,IIG)=KKG
36419 JMOHKT(2,IIG)=0
36420 JDAHKT(1,IIG)=3+IIGLU1
36421 JDAHKT(2,IIG)=0
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)
36439 61 CONTINUE
36440 ENDIF
36441C IDHKT(2) =1000*IPP21+100*IPP22+1
36442 IF(IPIP.EQ.1)THEN
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
36452 ENDIF
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)
36466C 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)
36474 ELSE
36475C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36476 PHKT(5,2+IIGLU1)=0.D0
36477 ENDIF
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
36487C IDHKT(3) =1000*NNNC1+MMMC1+10
36488 ISTHKT(3+IIGLU1) =93
36489C ISTHKT(3) =KKKC1
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
36498 PHKT(5,3+IIGLU1)
36499 * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36500 * -PHKT(3,3+IIGLU1)**2)
36501 IF(IPIP.GE.3)THEN
36502 WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36503 * JDAHKT(1,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),
36508 * JDAHKT(1,IIG),
36509 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36510 71 CONTINUE
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)
36519 ENDIF
36520 CHAMAL=CHAB1
36521**NEW
36522C IF(IPIP.EQ.1)THEN
36523C IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
36524C ELSEIF(IPIP.EQ.2)THEN
36525C IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
36526C ENDIF
36527 IF(IPIP.EQ.1)THEN
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
36531 ENDIF
36532**
36533 IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36534C IREJ=1
36535 IPCO=0
36536C RETURN
36537C WRITE(6,*)' MGSQBS1 jump back from chain 3'
36538 GO TO 3466
36539 ENDIF
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)
36548 IF(IPIP.EQ.1)THEN
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
36558C WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
36559 ENDIF
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
36565C PHKT(1,7) =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
36566C PHKT(2,7) =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
36567C PHKT(3,7) =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
36568C PHKT(4,7+IIGLU1) =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
36569**NEW
36570 IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
36571 & WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
36572**
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)
36577C WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
36578C * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
36579 IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
36580C IREJ=1
36581C WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
36582 IPCO=0
36583C RETURN
36584 GO TO 3466
36585 ENDIF
36586C 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)
36598C Insert here the IIGLU2 gluons
36599 PG1=0.D0
36600 PG2=0.D0
36601 PG3=0.D0
36602 PG4=0.D0
36603 IF(IIGLU2.GE.1)THEN
36604 JJG=NC2P
36605 DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36606 KKG=JJG+IIG-7-IIGLU1
36607 IDHKT(IIG) =IDHKK(KKG)
36608 ISTHKT(IIG) =921
36609 JMOHKT(1,IIG)=KKG
36610 JMOHKT(2,IIG)=0
36611 JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36612 JDAHKT(2,IIG)=0
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)
36630 81 CONTINUE
36631 ENDIF
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
36638**NEW
36639 IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
36640 & WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
36641**
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)
36646C 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)
36654 ELSE
36655C WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
36656 PHKT(5,8+IIGLU1+IIGLU2)=0.D0
36657 ENDIF
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
36667C IDHKT(9) =1000*NNNC2+MMMC2+10
36668 ISTHKT(9+IIGLU1+IIGLU2) =93
36669C ISTHKT(9) =KKKC2
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)
36686 IF(IPIP.GE.3)THEN
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),
36694 * JDAHKT(1,IIG),
36695 *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36696 91 CONTINUE
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)
36707 ENDIF
36708 CHAMAL=CHAB1
36709 IF(IPIP.EQ.1)THEN
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
36713 ENDIF
36714 IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36715C IREJ=1
36716 IPCO=0
36717C RETURN
36718C WRITE(6,*)' MGSQBS1 jump back from chain 9',
36719C * 'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36720 GO TO 3466
36721 ENDIF
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)
36730C
36731 IGCOUN=9+IIGLU1+IIGLU2
36732 IPCO=0
36733 RETURN
36734 END
36735C
36736C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36737C
36738 SUBROUTINE HKKHKT(I,J)
36739 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36740 SAVE
36741
36742* event history
36743
36744 PARAMETER (NMXHKK=200000)
36745
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),
36752 & IHIST(2,NMXHKK)
36753
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
36757 +(4,NTMHKK)
36758C
36759 ISTHKK(I) =ISTHKT(J)
36760 IDHKK(I) =IDHKT(J)
36761C IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
36762 IF(IDHKK(I).EQ.88888)THEN
36763C JMOHKK(1,I)=I-2
36764C JMOHKK(2,I)=I-1
36765 JMOHKK(1,I)=I-(J-JMOHKT(1,J))
36766 JMOHKK(2,I)=I-(J-JMOHKT(2,J))
36767 ELSE
36768 JMOHKK(1,I)=JMOHKT(1,J)
36769 JMOHKK(2,I)=JMOHKT(2,J)
36770 ENDIF
36771 JDAHKK(1,I)=JDAHKT(1,J)
36772 JDAHKK(2,I)=JDAHKT(2,J)
36773C IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
36774C JDAHKK(1,I)=I+2
36775C ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
36776C JDAHKK(1,I)=I+1
36777C ENDIF
36778 IF(JDAHKT(1,J).GT.0)THEN
36779 JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
36780 ENDIF
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)
36794 RETURN
36795 END
36796*
36797*===dbreak=============================================================*
36798*
36799CDECK ID>, DT_DBREAK
36800 SUBROUTINE DT_DBREAK(MODE)
36801
36802************************************************************************
36803* This is the steering subroutine for the different diquark breaking *
36804* mechanisms. *
36805* *
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 *
36822* *
36823* Original version by J. Ranft. *
36824* This version dated 17.5.00 is written by S. Roesler. *
36825************************************************************************
36826
36827 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36828 SAVE
36829
36830 PARAMETER ( LINP = 5 ,
36831 & LOUT = 6 ,
36832 & LDAT = 9 )
36833
36834* event history
36835
36836 PARAMETER (NMXHKK=200000)
36837
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),
36844 & IHIST(2,NMXHKK)
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
36858
36859*
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/
36866*
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/
36883
36884 IF (NCHAIN.LE.0) RETURN
36885 DO 1 I=1,NCHAIN
36886 IDX1 = IDXCHN(1,I)
36887 IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
36888 IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
36889 IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
36890 & .AND.
36891 & ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
36892 & (IS1P.EQ.ISP1P(MODE,3)))
36893 & .AND.
36894 & ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
36895 & (IS1T.EQ.ISP1T(MODE,3)))
36896 & ) THEN
36897 DO 2 J=1,NCHAIN
36898 IDX2 = IDXCHN(1,J)
36899 IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
36900 IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
36901 IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
36902 & .AND.
36903 & ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
36904 & .OR.(IS2P.EQ.ISP2P(MODE,3)))
36905 & .AND.
36906 & ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
36907 & .OR.(IS2T.EQ.ISP2T(MODE,3)))
36908 & ) THEN
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
36913 IANCES = 1
36914 ELSE
36915 IANCES = 2
36916 ENDIF
36917 IDXMO1 = JMOHKK(IANCES,IDX1)
36918 4 CONTINUE
36919 IF ((JMOHKK(1,IDXMO1).NE.0).AND.
36920 & (JMOHKK(2,IDXMO1).NE.0)) THEN
36921 IANC = IANCES
36922 ELSE
36923 IANC = 1
36924 ENDIF
36925 IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
36926 IDXMO1 = JMOHKK(IANC,IDXMO1)
36927 GOTO 4
36928 ENDIF
36929 IDXMO2 = JMOHKK(IANCES,IDX2)
36930 5 CONTINUE
36931 IF ((JMOHKK(1,IDXMO2).NE.0).AND.
36932 & (JMOHKK(2,IDXMO2).NE.0)) THEN
36933 IANC = IANCES
36934 ELSE
36935 IANC = 1
36936 ENDIF
36937 IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
36938 IDXMO2 = JMOHKK(IANC,IDXMO2)
36939 GOTO 5
36940 ENDIF
36941 IF (IDXMO1.NE.IDXMO2) GOTO 2
36942* quark content of projectile parton
36943 IP1 = IDHKK(JMOHKK(1,IDX1))
36944 IP11 = IP1/1000
36945 IP12 = (IP1-1000*IP11)/100
36946 IP2 = IDHKK(JMOHKK(2,IDX1))
36947 IP21 = IP2/1000
36948 IP22 = (IP2-1000*IP21)/100
36949* quark content of target parton
36950 IT1 = IDHKK(JMOHKK(1,IDX2))
36951 IT11 = IT1/1000
36952 IT12 = (IT1-1000*IT11)/100
36953 IT2 = IDHKK(JMOHKK(2,IDX2))
36954 IT21 = IT2/1000
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)
36993 ENDIF
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
36999 ELSE
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)
37006 ELSE
37007 WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
37008 STOP
37009 ENDIF
37010 IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
37011 DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
37012 IACC = 1
37013 ELSE
37014 DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
37015 IACC = 0
37016 ENDIF
37017* new chains have been accepted and are now copied into HKKEVT
37018 IF (IACC.EQ.1) THEN
37019 IF (LEMCCK) THEN
37020 CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
37021 & PHKK(3,IDX1),PHKK(4,IDX1),
37022 & 1,IDUM1,IDUM2)
37023 CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
37024 & PHKK(3,IDX2),PHKK(4,IDX2),
37025 & 2,IDUM1,IDUM2)
37026 ENDIF
37027 IDHKK(IDX1) = 99888
37028 IDHKK(IDX2) = 99888
37029 IDXCHN(2,I) = -1
37030 IDXCHN(2,J) = -1
37031 DO 3 K=1,IGCOUN
37032 NHKK = NHKK+1
37033 CALL HKKHKT(NHKK,K)
37034 IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
37035 PX = -PHKK(1,NHKK)
37036 PY = -PHKK(2,NHKK)
37037 PZ = -PHKK(3,NHKK)
37038 PE = -PHKK(4,NHKK)
37039 CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
37040 ENDIF
37041 3 CONTINUE
37042 IF (LEMCCK) THEN
37043 CHKLEV = 0.1D0
37044 CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
37045 & IREJ)
37046 IF (IREJ.NE.0) CALL DT_EVTOUT(4)
37047 ENDIF
37048 GOTO 1
37049 ENDIF
37050 ENDIF
37051 ENDIF
37052 2 CONTINUE
37053 ENDIF
37054 1 CONTINUE
37055 RETURN
37056 END
37057*
37058*===cqpair=============================================================*
37059*
37060CDECK ID>, DT_CQPAIR
37061 SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
37062
37063************************************************************************
37064* This subroutine Creates a Quark-antiquark PAIR from the sea. *
37065* *
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) *
37071* *
37072* This version dated 14.5.00 is written by S. Roesler. *
37073************************************************************************
37074
37075 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37076 SAVE
37077
37078 PARAMETER ( LINP = 5 ,
37079 & LOUT = 6 ,
37080 & LDAT = 9 )
37081
37082* Lorentz-parameters of the current interaction
37083 COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37084 & UMO,PPCM,EPROJ,PPROJ
37085
37086*
37087 IREJ = 0
37088 XQ = 0.0D0
37089 XAQ = 0.0D0
37090*
37091* sample quark flavour
37092*
37093* set seasq here (the one from DTCHAI should be used in the future)
37094 SEASQ = 0.5D0
37095 IFLV = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
37096*
37097* sample energy fractions of sea pair
37098* we first sample the energy fraction of a gluon and then split the gluon
37099*
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
37107 XGMAX = 0.3D0
37108 XGMAX = MIN(XGMAXI,XGMAX)
37109 IF (XGMIN.GE.XGMAX) THEN
37110 IREJ = 1
37111 RETURN
37112 ENDIF
37113*
37114* sample energy fraction of the gluon
37115 NLOOP = 0
37116 1 CONTINUE
37117 NLOOP = NLOOP+1
37118 IF (NLOOP.GE.50) THEN
37119 IREJ = 1
37120 RETURN
37121 ENDIF
37122 XGLUON = DT_SAMSQX(XGMIN,XGMAX)
37123 EGLUON = XGLUON*UMO/2.0D0
37124*
37125* split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
37126 ZMIN = MIN(0.1D0,0.5D0/EGLUON)
37127 ZMAX = 1.0D0-ZMIN
37128 RZ = DT_RNDM(ZMAX)
37129 XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
37130 RQ = DT_RNDM(ZMAX)
37131 IF (RQ.LT.0.5D0) THEN
37132 XQ = XGLUON*XHLP
37133 XAQ = XGLUON-XQ
37134 ELSE
37135 XAQ = XGLUON*XHLP
37136 XQ = XGLUON-XAQ
37137 ENDIF
37138 IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
37139
37140 RETURN
37141 END