Geant4  9.6.p02
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
dpm25nuc1.f
Go to the documentation of this file.
1 C***********************************************************************
2  PROGRAM dpmjet
3  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4  SAVE
5 *KEEP,HKKEVT.
6 c INCLUDE (HKKEVT)
7  parameter(nmxhkk= 89998)
8 c PARAMETER (NMXHKK=25000)
9  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
10  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
11  +(4,nmxhkk)
12  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
13  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
14 C
15 C DO 7777 KK=1,NHKK
16 C WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4)')KK,ISTHKK(KK),IDHKK(KK),
17 C *JMOHKK(1,KK),JMOHKK(2,KK),JDAHKK(1,KK),JDAHKK(2,KK),
18 C *(PHKK(LL,KK),LL=1,5),IDRES(KK),IDXRES(KK),NOBAM(KK),IDBAM(KK)
19 C7777 CONTINUE
20 C
21 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
22 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
23 C THE POSITIONS OF THE PROJECTILE NUCLEONS
24 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
25 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
26 C COMPLETELY CONSISTENT. THE TIMES IN THE
27 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
28 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
29 C
30 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
31 C
32 C NMXHKK: maximum numbers of entries (partons/particles) that can be
33 C stored in the commonblock.
34 C
35 C NHKK: the actual number of entries stored in current event. These are
36 C found in the first NHKK positions of the respective arrays below.
37 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
38 C entry.
39 C
40 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
41 C = 0 : null entry.
42 C = 1 : an existing entry, which has not decayed or fragmented.
43 C This is the main class of entries which represents the
44 C "final state" given by the generator.
45 C = 2 : an entry which has decayed or fragmented and therefore
46 C is not appearing in the final state, but is retained for
47 C event history information.
48 C = 3 : a documentation line, defined separately from the event
49 C history. (incoming reacting
50 C particles, etc.)
51 C = 4 - 10 : undefined, but reserved for future standards.
52 C = 11 - 20 : at the disposal of each model builder for constructs
53 C specific to his program, but equivalent to a null line in the
54 C context of any other program. One example is the cone defining
55 C vector of HERWIG, another cluster or event axes of the JETSET
56 C analysis routines.
57 C = 21 - : at the disposal of users, in particular for event tracking
58 C in the detector.
59 C
60 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
61 C standard.
62 C
63 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
64 C The value is 0 for initial entries.
65 C
66 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
67 C one mother exist, in which case the value 0 is used. In cluster
68 C fragmentation models, the two mothers would correspond to the q
69 C and qbar which join to form a cluster. In string fragmentation,
70 C the two mothers of a particle produced in the fragmentation would
71 C be the two endpoints of the string (with the range in between
72 C implied).
73 C
74 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
75 C entry has not decayed, this is 0.
76 C
77 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
78 C entry has not decayed, this is 0. It is assumed that the daughters
79 C of a particle (or cluster or string) are stored sequentially, so
80 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
81 C daughters. Even in cases where only one daughter is defined (e.g.
82 C K0 -> K0S) both values should be defined, to make for a uniform
83 C approach in terms of loop constructions.
84 C
85 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
86 C
87 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
88 C
89 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
90 C
91 C PHKK(4,IHKK) : energy, in GeV.
92 C
93 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
94 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
95 C
96 C VHKK(1,IHKK) : production vertex x position, in mm.
97 C
98 C VHKK(2,IHKK) : production vertex y position, in mm.
99 C
100 C VHKK(3,IHKK) : production vertex z position, in mm.
101 C
102 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
103 C********************************************************************
104 *KEEP,DPAR.
105 C /DPAR/ CONTAINS PARTICLE PROPERTIES
106 C ANAME = LITERAL NAME OF THE PARTICLE
107 C AAM = PARTICLE MASS IN GEV
108 C GA = DECAY WIDTH
109 C TAU = LIFE TIME OF INSTABLE PARTICLES
110 C IICH = ELECTRIC CHARGE OF THE PARTICLE
111 C IIBAR = BARYON NUMBER
112 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
113 C
114  CHARACTER*8 aname
115  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
116  +iibar(210),k1(210),k2(210)
117 C------------------
118 *KEEP,NUCC.
119 C COMMON /NUCCC/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
120 C COMMON /NUCC/ JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG
121  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
122  COMMON /nuccc/ jt,jtz,jp,jpz,jjproj,jbproj,jjtarg,jbtarg
123 *KEEP,CMHICO.
124  COMMON /cmhico/ cmhis
125 *KEEP,RESONA.
126  COMMON /resona/ ireso
127 *KEEP,TRAFOP.
128  COMMON /trafop/ gamp,bgamp,betp
129 *KEEP,DPRIN.
130  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
131 *KEEP,REJEC.
132  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
133  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
134  +irvs14, irvv11,irvv12,irvv13,irvv14
135 *KEEP,DROPPT.
136  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
137  +ishmal,lpauli
138  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
139  +ipadis,ishmal,lpauli
140 *KEEP,DNUN.
141  COMMON /dnun/ nn,np,nt
142 *KEEP,NSHMAK.
143  COMMON /nshmak/ nnshma,npshma,ntshma,nshmac,nshma2
144 *KEEP,DSHM.
145  COMMON /dshm/ rash,rbsh,bmax,bstep,sigsh,rosh,gsh,
146  * bsite(0:1,200),nstatb,nsiteb
147 *KEND.
148  COMMON /seaqxx/ seaqx,seaqxn
149  COMMON /diffra/ isingd,idiftp,ioudif,iflagd
150  COMMON /evflag/ numev
151  COMMON /neutyy/ neutyp,neudec
152  COMMON /fluctu/ifluct
153  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
154  *idzre(3),izdre(3),idiqrz(7)
155  COMMON /intneu/ndzsu,nzdsu
156  COMMON /hboo/ihbook
157  COMMON /final/ifinal
158 C modified DPMJET
159  COMMON /bufues/ bnnvv,bnnss,bnnsv,bnnvs,bnncc,
160  * bnndv,bnnvd,bnnds,bnnsd,
161  * bnnhh,bnnzz,
162  * bptvv,bptss,bptsv,bptvs,bptcc,bptdv,
163  * bptvd,bptds,bptsd,
164  * bpthh,bptzz,
165  * beevv,beess,beesv,beevs,beecc,beedv,
166  * beevd,beeds,beesd,
167  * beehh,beezz
168  * ,bnndi,bptdi,beedi
169  * ,bnnzd,bnndz,bptzd,bptdz,beezd,beedz
170  COMMON /ncoucs/ bcouvv,bcouss,bcousv,bcouvs,
171  * bcouzz,bcouhh,bcouds,bcousd,
172  * bcoudz,bcouzd,bcoudi,
173  * bcoudv,bcouvd,bcoucc
174  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
175  * anndv,annvd,annds,annsd,
176  * annhh,annzz,
177  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
178  * pthh,ptzz,
179  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
180  * eehh,eezz
181  * ,anndi,ptdi,eedi
182  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
183  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
184  * acouzz,acouhh,acouds,acousd,
185  * acoudz,acouzd,acoudi,
186  * acoudv,acouvd,acoucc
187  common/popcck/pdbck,pdbse,pdbseu,
188  * ijpock,irejck,ick4,ihad4,ick6,ihad6
189  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
190  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
191  *isea43,isea63,irejao
192  COMMON /nstari/nstart
193  COMMON /ncshxx/ncouxh,ncouxt
194  dimension pp(4)
195  COMMON /nucros/dsigsu,dsigmc,ndsig
196  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
197  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
198  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
199  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
200  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
201  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
202  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
203  COMMON /hdjase/nhse1,nhse2,nhse3,nhase1,nhase2,nhase3
204  COMMON /casadi/casaxx,icasad
205  COMMON /vxsvd/vxsp(50),vxst(50),vxsap(50),vxsat(50),
206  * vxvp(50),vxvt(50),vxdp(50),vxdt(50),
207  * nxsp,nxst,nxsap,nxsat,nxvp,nxvt,nxdp,nxdt
208  dimension vxsss(50,6),vxvvv(50,6),xxxx(50,6)
209  dimension xb(200),bimpp(200)
210  parameter(intmx=2488,intmd=252)
211  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
212  COMMON /infore/ifrej
213  CHARACTER*80 titled
214  CHARACTER*8 projty,targty
215  COMMON /user1/titled,projty,targty
216  COMMON /user2/cmener,sdfrac,ptlar,istruf,isingx,idubld
217  COMMON /strufu/istrum,istrut
218  COMMON /ptsamp/ isampt
219  common/collis/s,ijprox,ijtar,ptthr,ptthr2,iophrd,ijprlu,ijtalu
220  COMMON /dropjj/dropjt,dropva
221  COMMON /pomtyp/ipim,icon,isig,lmax,mmax,nmax,difel,difnu
222  common/pshow/ipshow
223  COMMON /zentra/ icentr
224  COMMON /evappp/ievap
225  COMMON /seasu3/seasq
226  COMMON /recom/irecom
227  COMMON /taufo/ taufor,ktauge,itauve,incmod
228  common/popcor/pdb,ajsdef
229  COMMON /diquax/amedd,idiqua,idiquu
230  COMMON /colle/nevhad,nvers,ihadrz,nfile
231  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
232  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
233  +prebin,taebin,fermod,etacou
234  COMMON /cronin/cronco,mkcron
235  COMMON /xseadi/ xseacu,unon,unom,unosea, cvq,cdq,csea,ssmima,
236  +ssmimq,vvmthr
237  COMMON /secint/isecin
238 C---------------------
239 *
240  DATA ncount/0/
241 C from DTUJET93
242 C from DTUJET93
243 C ON DOUBLE PRECISION UNDERFLOW IGNORE
244 C ON DOUBLE PRECISION OVERFLOW IGNORE
245 C ON DOUBLE PRECISION INEXACT IGNORE
246 C ON DOUBLE PRECISION ILLEGAL IGNORE
247 C ON DOUBLE PRECISION DIV 0 IGNORE
248 C ON REAL UNDERFLOW IGNORE
249 C ON REAL OVERFLOW IGNORE
250 C ON INTEGER OVERFLOW IGNORE
251 C ON REAL INEXACT IGNORE
252 C ON REAL ILLEGAL IGNORE
253 C ON REAL DIV 0 IGNORE
254 C from DTUJET93
255 *---extended error handling on RISC 6000
256 C include 'fexcp.h'
257 C call signal(SIGTRAP,xl_trce)
258 C***********************************************************************a
259 C OPEN(47,FILE='/u1/ranft/dtunuc44/GLAUBTAR.DAT',
260 C *STATUS='UNKNOWN')
261 C OPEN(47,FILE='/nfs/hptrack/user/ran/dtunuc44/GLAUBTAR.DAT',
262 C OPEN(47,FILE='/user/ran/dtunuc44/GLAUBTAR.DAT',
263 C *STATUS='UNKNOWN')
264 C OPEN(47,FILE='/lapphp11_2/users/ranft/dtunuc44/GLAUBTAR.DAT',
265 C *STATUS='UNKNOWN')
266  OPEN(47,file='GLAUBTAR.DAT',
267  *status='UNKNOWN')
268  OPEN(37,file='GLAUBCROSSPB.DAT',
269  *status='UNKNOWN')
270 C OPEN( 2,FILE='HIBLD.DAT',STATUS='OLD')
271  aam(5)=0.001d0
272  aam(6)=0.001d0
273  aam(133)=0.001d0
274  aam(134)=0.001d0
275  aam(135)=0.001d0
276  aam(136)=0.001d0
277 C Initialize x-distribtion survey
278  nxsp=0
279  nxst=0
280  nxsap=0
281  nxsat=0
282  nxvp=0
283  nxvt=0
284  nxdp=0
285  nxdt=0
286  axsp=0.
287  axst=0.
288  axsap=0.
289  axsat=0.
290  axvp=0.
291  axvt=0.
292  axdp=0.
293  axdt=0.
294  DO 5271 ii=1,50
295  vxsp(ii)=1.d-8
296  vxst(ii)=1.d-8
297  vxsap(ii)=1.d-8
298  vxsat(ii)=1.d-8
299  vxvp(ii)=1.d-8
300  vxvt(ii)=1.d-8
301  vxdp(ii)=1.d-8
302  vxst(ii)=1.d-8
303  5271 CONTINUE
304 C
305 * random number initialization for LEPTO
306  CALL rluxgo(lux_level,iseed,0,0)
307  idiqre(1)=0
308  idiqre(2)=0
309  idiqre(3)=0
310  idiqre(4)=0
311  idiqre(5)=0
312  idiqre(6)=0
313  idiqre(7)=0
314  idiqrz(1)=0
315  idiqrz(2)=0
316  idiqrz(3)=0
317  idiqrz(4)=0
318  idiqrz(5)=0
319  idiqrz(6)=0
320  idiqrz(7)=0
321  idvre(1)=0
322  idvre(2)=0
323  idvre(3)=0
324  ivdre(1)=0
325  ivdre(2)=0
326  ivdre(3)=0
327  idsre(1)=0
328  idsre(2)=0
329  idsre(3)=0
330  isdre(1)=0
331  isdre(2)=0
332  isdre(3)=0
333  idzre(1)=0
334  idzre(2)=0
335  idzre(3)=0
336  izdre(1)=0
337  izdre(2)=0
338  izdre(3)=0
339  ndvuu=0
340  ndvus=0
341  ndvss=0
342  nvduu=0
343  nvdus=0
344  nvdss=0
345  ndsuu=0
346  ndsus=0
347  ndsss=0
348  nsduu=0
349  nsdus=0
350  nsdss=0
351  ndzuu=0
352  ndzus=0
353  ndzss=0
354  nzduu=0
355  nzdus=0
356  nzdss=0
357  nadvuu=0
358  nadvus=0
359  nadvss=0
360  navduu=0
361  navdus=0
362  navdss=0
363  nadsuu=0
364  nadsus=0
365  nadsss=0
366  nasduu=0
367  nasdus=0
368  nasdss=0
369  nadzuu=0
370  nadzus=0
371  nadzss=0
372  nazduu=0
373  nazdus=0
374  nazdss=0
375  nhse1=0
376  nhse2=0
377  nhse3=0
378  nhase1=0
379  nhase2=0
380  nhase3=0
381  1000 CONTINUE
382  ncount=ncount+1
383 * initialisation routine:
384 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
385 C Parton pt distribution
386  CALL parpt(1,pt1,pt2,ipt,nevt)
387 C-------------------------------------------------------------
388  CALL dminit(ncases,epn,ppn,ncount,iglaub)
389 C----------------------------------------------------------------
390 C----------------------------------------------------------------
391 C---now starts the real work
392  nhkkh1=1
393  ishmal=.true.
394 C
395  ttot=0.
396  tmax=0.
397 C CALL TIMEL (TCPU)
398 C TLIM=MAX(TCPU/100.,15.)
399 C CALL TIMED(TDIFF)
400  iit=it
401  iitz=itz
402  iip=ip
403  iipz=ipz
404  iiproj=ijproj
405  iitarg=ijtarg
406  IF( iglaub.EQ.1) THEN
407  kkmat=0
408  ELSE
409  kkmat=1
410  ENDIF
411 C===============================================================
412 C Printout of important Parameters (defaults and input cards)
413 C===============================================================
414  WRITE(6,*)' Printout of important Parameters before DPMJET run.'
415  *,' Please note for DPMJET input all numbers are floating point!'
416  WRITE(6,*)'PROJPAR ',ip,ipz
417  WRITE(6,*)'TARPAR ',it,itz
418  WRITE(6,*)'MOMENTUM ',ppn
419  WRITE(6,*)'ENERGY ',epn
420  WRITE(6,*)'CMENERGY ',umo
421  WRITE(6,*)'NOFINALE ',ifinal
422  WRITE(6,*)'EVAPORAT ',ievap
423  WRITE(6,*)'OUTLEVEL ',ipri,ipev,ippa,ipco,init,iphkk
424  auauau=rd2out(iseed1,iseed2)
425  WRITE(6,*)'RANDOMIZ ',iseed1,iseed2, ' Initial RNDM (RM48) seeds'
426  WRITE(6,*)'STRUCFUN ',istruf+100*istrut
427  WRITE(6,*)'SAMPT ',isampt
428  WRITE(6,*)'SELHARD ',0,iophrd, 0,dropjt,ptthr,ptthr2
429  WRITE(6,*)'SIGMAPOM ',0,isig,ipim+10*icon,imax,mmax,nmax
430  WRITE(6,*)'PSHOWER ',ipshow
431  WRITE(6,*)'CENTRAL ',icentr
432  WRITE(6,*)'CMHISTO ',cmhis
433  WRITE(6,*)'SEASU3 ',seasq
434  WRITE(6,*)'RECOMBIN ',irecom
435  WRITE(6,*)'SINGDIFF ',isingd
436  WRITE(6,*)'TAUFOR ',taufor,ktauge,itauve
437  WRITE(6,*)'POPCORN ',pdb
438  WRITE(6,*)'POPCORCK ',ijpock,pdbck
439  WRITE(6,*)'POPCORSE ',pdbse,pdbseu
440  WRITE(6,*)'CASADIQU ',icasad,casaxx
441  WRITE(6,*)'DIQUARKS ',idiqua,idiquu,amedd
442  WRITE(6,*)'HADRONIZ ',ihadrz
443  WRITE(6,*)'INTPT ',intpt
444  WRITE(6,*)'PAULI ',lpauli
445  WRITE(6,*)'FERMI ',fermp,fermod
446  WRITE(6,*)'CRONINPT ',mkcron,cronco
447  WRITE(6,*)'SEADISTR ',xseacu+0.95d0,unon,unom,unosea
448  WRITE(6,*)'SEAQUARK ',seaqx,seaqxn
449  WRITE(6,*)'SECINTER ',isecin
450  WRITE(6,*)'XCUTS ',cvq,cdq,csea,ssmima
451  WRITE(6,*)' Printout of important Parameters before DPMJET run.'
452  *,' Please note for DPMJET input all numbers are floating point!'
453 C===============================================================
454 C Printout of important Parameters (defaults and input cards)
455 C===============================================================
456  ncaset=ncases/10
457  DO 181 iiii=1,10
458  ndone=(iiii-1)*ncaset
459  WRITE(6,1111)ndone
460  WRITE(6,'(A,4I5)')' KKINC call ',iit,iitz,iip,iipz
461  CALL timdat
462  1111 FORMAT(' NDONE= ',i10)
463  DO 180 i=1,ncaset
464  765 CONTINUE
465  numev = i+(iiii-1)*ncaset
466  IF ((i.EQ.486).OR.(i.EQ.803).OR.(i.EQ.1368).OR.
467  & (i.EQ.1465).OR.(i.EQ.1693).OR.(i.EQ.1808)) THEN
468 C IPEV = 7
469 C IPCO = 7
470 C IPHKK = 7
471  ENDIF
472 C INITIALIZE COUNTERS
473  annvv=0.001
474  annss=0.001
475  annsv=0.001
476  annvs=0.001
477  anncc=0.001
478  anndv=0.001
479  annvd=0.001
480  annds=0.001
481  annsd=0.001
482  annhh=0.001
483  annzz=0.001
484  anndi=0.001
485  annzd=0.001
486  anndz=0.001
487  ptvv=0.
488  ptss=0.
489  ptsv=0.
490  ptvs=0.
491  ptcc=0.
492  ptdv=0.
493  ptvd=0.
494  ptds=0.
495  ptsd=0.
496  pthh=0.
497  ptzz=0.
498  ptdi=0.
499  ptzd=0.
500  ptdz=0.
501  eevv=0.
502  eess=0.
503  eesv=0.
504  eevs=0.
505  eecc=0.
506  eedv=0.
507  eevd=0.
508  eeds=0.
509  eesd=0.
510  eehh=0.
511  eezz=0.
512  eedi=0.
513  eezd=0.
514  eedz=0.
515 C COMMON /NCOUCH/ ACOUVV,ACOUSS,ACOUSV,ACOUVS,
516 C * ACOUZZ,ACOUHH,ACOUDS,ACOUSD,
517 C * ACOUDZ,ACOUZD,ACOUDI
518  acouvv=0.
519  acouss=0.
520  acousv=0.
521  acouvs=0.
522  acouzz=0.
523  acouhh=0.
524  acouds=0.
525  acousd=0.
526  acoudz=0.
527  acouzd=0.
528  acoudi=0.
529  acoudv=0.
530  acouvd=0.
531  acoucc=0.
532 *
533 C IIP=IP+1-IIII
534 C WRITE(6,'(A,4I5)')' KKINC call ',IIT,IITZ,IIP,IIPZ
535  CALL kkinc(epn,iit,iitz,iip,iipz,iiproj,kkmat,
536  * iitarg,nhkkh1,irej)
537 C CALL TIMDAT
538  IF(irej.EQ.1)go to 765
539 C IPEV = 0
540 C IPCO = 0
541 C IPHKK = 0
542 C INITIALIZE COUNTERS
543  bnnvv=bnnvv+annvv
544  bnnss=bnnss+annss
545  bnnsv=bnnsv+annsv
546  bnnvs=bnnvs+annvs
547  bnncc=bnncc+anncc
548  bnndv=bnndv+anndv
549  bnnvd=bnnvd+annvd
550  bnnds=bnnds+annds
551  bnnsd=bnnsd+annsd
552  bnnhh=bnnhh+annhh
553  bnnzz=bnnzz+annzz
554  bnndi=bnndi+anndi
555  bnnzd=bnnzd+annzd
556  bnndz=bnndz+anndz
557  bptvv=bptvv+ptvv
558  bptss=bptss+ptss
559  bptsv=bptsv+ptsv
560  bptvs=bptvs+ptvs
561  bptcc=bptcc+ptcc
562  bptdv=bptdv+ptdv
563  bptvd=bptvd+ptvd
564  bptds=bptds+ptds
565  bptsd=bptsd+ptsd
566  bpthh=bpthh+pthh
567  bptzz=bptzz+ptzz
568  bptdi=bptdi+ptdi
569  bptzd=bptdz+ptdz
570  bptdz=bptdz+ptdz
571  beevv=beevv+eevv
572  beess=beess+eess
573  beesv=beesv+eesv
574  beevs=beevs+eevs
575  beecc=beecc+eecc
576  beedv=beedv+eedv
577  beevd=beevd+eevd
578  beeds=beeds+eeds
579  beesd=beesd+eesd
580  beehh=beehh+eehh
581  beezz=beezz+eezz
582  beedi=beedi+eedi
583  beezd=beezd+eezd
584  beedz=beedz+eedz
585 C COMMON /NCOUCH/ ACOUVV,ACOUSS,ACOUSV,ACOUVS,
586 C * ACOUZZ,ACOUHH,ACOUDS,ACOUSD,
587 C * ACOUDZ,ACOUZD,ACOUDI
588  bcouvv=bcouvv+acouvv
589  bcouss=bcouss+acouss
590  bcousv=bcousv+acousv
591  bcouvs=bcouvs+acouvs
592  bcouzz=bcouzz+acouzz
593  bcouhh=bcouhh+acouhh
594  bcouds=bcouds+acouds
595  bcousd=bcousd+acousd
596  bcoudz=bcoudz+acoudz
597  bcouzd=bcouzd+acouzd
598  bcoudi=bcoudi+acoudi
599  bcoudv=bcoudv+acoudv
600  bcouvd=bcouvd+acouvd
601  bcoucc=bcoucc+acoucc
602 *
603 C HOW LONG DID IT TAKE TO PROCESS THIS ONE?
604 C
605 C CALL TIMED(TDIFF)
606 C IF(TDIFF.GT.TMAX)TMAX=TDIFF
607 C TTOT=TTOT+TDIFF
608 C TMEAN=TTOT/FLOAT(I)
609 C
610 C CONDITIONS FOR LOOP TERMINATION
611 C
612 C CALL TIMEL(TLEFT)
613 C IF ( TLEFT .LE. 3.*TMAX+TLIM ) GO TO 190
614  IF(numev.LE.-5)THEN
615  WRITE(6,'(A,4I5)')' KKINC call ',iit,iitz,iip,iipz
616  DO 7779 kk=1,nhkk
617  WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4)')kk,isthkk(kk),idhkk(kk),
618  *jmohkk(1,kk),jmohkk(2,kk),jdahkk(1,kk),jdahkk(2,kk),
619  *(phkk(ll,kk),ll=1,5),idres(kk),idxres(kk),nobam(kk),idbam(kk)
620  7779 CONTINUE
621  ENDIF
622  180 CONTINUE
623 C
624  IF(numev.LE.-5)THEN
625  WRITE(6,'(A,4I5)')' KKINC call ',iit,iitz,iip,iipz
626  DO 7777 kk=1,nhkk
627  WRITE(6,'(2I4,I6,4I4,5F10.2,2I3,I2,I4)')kk,isthkk(kk),idhkk(kk),
628  *jmohkk(1,kk),jmohkk(2,kk),jdahkk(1,kk),jdahkk(2,kk),
629  *(phkk(ll,kk),ll=1,5),idres(kk),idxres(kk),nobam(kk),idbam(kk)
630  7777 CONTINUE
631  ENDIF
632 C
633  181 CONTINUE
634 C===============================================================
635 C Printout of important Parameters (defaults and input cards)
636 C===============================================================
637  WRITE(6,*)' Printout of important Parameters after DPMJET run.'
638  *,' Please note for DPMJET input all numbers are floating point!'
639  WRITE(6,*)'PROJPAR ',ip,ipz
640  WRITE(6,*)'TARPAR ',it,itz
641  WRITE(6,*)'MOMENTUM ',ppn
642  WRITE(6,*)'ENERGY ',epn
643  WRITE(6,*)'CMENERGY ',umo
644  WRITE(6,*)'NOFINALE ',ifinal
645  WRITE(6,*)'EVAPORAT ',ievap
646  WRITE(6,*)'OUTLEVEL ',ipri,ipev,ippa,ipco,init,iphkk
647  auauau=rd2out(iseed1,iseed2)
648  WRITE(6,*)'RANDOMIZ ',iseed1,iseed2, ' Final RNDM (RM48) seeds'
649  WRITE(6,*)'STRUCFUN ',istruf+100*istrut
650  WRITE(6,*)'SAMPT ',isampt
651  WRITE(6,*)'SELHARD ',0,iophrd, 0,dropjt,ptthr,ptthr2
652  WRITE(6,*)'SIGMAPOM ',0,isig,ipim+10*icon,imax,mmax,nmax
653  WRITE(6,*)'PSHOWER ',ipshow
654  WRITE(6,*)'CENTRAL ',icentr
655  WRITE(6,*)'CMHISTO ',cmhis
656  WRITE(6,*)'SEASU3 ',seasq
657  WRITE(6,*)'RECOMBIN ',irecom
658  WRITE(6,*)'SINGDIFF ',isingd
659  WRITE(6,*)'TAUFOR ',taufor,ktauge,itauve
660  WRITE(6,*)'POPCORN ',pdb
661  WRITE(6,*)'POPCORCK ',ijpock,pdbck
662  WRITE(6,*)'POPCORSE ',pdbse,pdbseu
663  WRITE(6,*)'CASADIQU ',icasad,casaxx
664  WRITE(6,*)'DIQUARKS ',idiqua,idiquu,amedd
665  WRITE(6,*)'HADRONIZ ',ihadrz
666  WRITE(6,*)'INTPT ',intpt
667  WRITE(6,*)'PAULI ',lpauli
668  WRITE(6,*)'FERMI ',fermp,fermod
669  WRITE(6,*)'CRONINPT ',mkcron,cronco
670  WRITE(6,*)'SEADISTR ',xseacu+0.95d0,unon,unom,unosea
671  WRITE(6,*)'SEAQUARK ',seaqx,seaqxn
672  WRITE(6,*)'SECINTER ',isecin
673  WRITE(6,*)'XCUTS ',cvq,cdq,csea,ssmima
674  WRITE(6,*)' Printout of important Parameters after DPMJET run.'
675  *,' Please note for DPMJET input all numbers are floating point!'
676 C===============================================================
677 C Printout of important Parameters (defaults and input cards)
678 C===============================================================
679 
680 C OUTPUT of RNDM seeds
681  auauau=rd2out(iseed1,iseed2)
682  WRITE (6,*)' Final RNDM seeds (RM48) ',iseed1,iseed2
683  WRITE (6,*)' Final RNDM seeds (RM48) ',iseed1,iseed2
684  WRITE (6,*)' Final RNDM seeds (RM48) ',iseed1,iseed2
685  WRITE (6,*)' Final RNDM seeds (RM48) ',iseed1,iseed2
686  go to 200
687  190 CONTINUE
688 C WRITE(6,*)' STOPPED FOR CPUTIME LIMIT: ',I,' EVENTS ',
689 C +'INSTEAD OF ',NCASES,' PRODUCED'
690 C NCASES = I
691  200 CONTINUE
692 C WRITE (6,1090)TTOT,TMAX,TCPU,TLIM,TDIF,TMEAN,TLEFT
693 C1090 FORMAT (' TTOT,TMAX,TCPU,TLIM,TDIF,TMEAN.TLEFT '/7F10.2)
694 C
695  IF(ipev.GE.-1) THEN
696  IF(ifrej.EQ.1)THEN
697  WRITE(6,1100) irvv11,irvv12,irvv13,irvv14, irsv11,irsv12,irsv13,
698  + irsv14, irvs11,irvs12,irvs13,irvs14, irss11,irss12,irss13,irss14
699  1100 FORMAT (' REJECTION COUNTERS FROM KKEVT',/, 5x,' V-V CHAINS',4i6/
700  +5x,' S-V CHAINS',4i6/ 5x,' V-S CHAINS',4i6/ 5x,' S-S CHAINS',4i6)
701  WRITE(6,'(A,4I10)')' POPCCK/SE/S3/S0 rejections ',
702  * irejck,irejse,irejs3,irejs0
703  WRITE(6,'(A,4I10)')' POPCCK/ASE/AS3/AS0 rejections ',
704  * irejsa,ireja3,ireja0
705  WRITE(6,'(2A,8I6)')' POPCCK ICK4,ICK6,IHAD4,IHAD6,ISE4,ISE6 ',
706  * 'ISE43,ISE63 ', ick4,ick6,ihad4,ihad6,ise4,ise6,ise43,ise63
707  WRITE(6,'(2A,8I6)')' POPCSAQ IHADA4,IHADA6,ISEA4,ISEA6 ',
708  * 'ISEA43,ISEA63 ', ihada4,ihada6,isea4,isea6,isea43,isea63
709  WRITE(6,*) ' NDVUU,NDVUS,NDVSS,NVDUU,NVDUS,NVDSS',
710  * ' NDSUU,NDSUS,NDSSS,NSDUU,NSDUS,NSDSS',
711  * ' NDZUU,NDZUS,NDZSS,NZDUU,NZDUS,NZDSS' ,
712  * ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
713  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
714  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
715  WRITE(6,*) ' NADVUU,NADVUS,NADVSS,NAVDUU,NAVDUS,NAVDSS',
716  * ' NADSUU,NADSUS,NADSSS,NASDUU,NASDUS,NASDSS',
717  * ' NADZUU,NADZUS,NADZSS,NAZDUU,NAZDUS,NAZDSS' ,
718  * nadvuu,nadvus,nadvss,navduu,navdus,navdss,
719  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
720  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
721  WRITE(6,*)' NHSE1,NHSE2,NHSE3,NHASE1,NHASE2,NHASE3 ',
722  * nhse1,nhse2,nhse3,nhase1,nhase2,nhase3
723  ENDIF
724  ENDIF
725 C
726  CALL timdat
727 C****************** PRINTOUT********************************
728  IF(ifrej.EQ.1)THEN
729  WRITE(6,'(A/7I8)')' Diquark rejection IDIQRE(1-7),N,ss,su,ud',
730  & (idiqre(jj),jj=1,7)
731  WRITE(6,'(A/7I8)')' Diquark rejection IDIQRZ(1-7),N,ss,su,ud',
732  & (idiqrz(jj),jj=1,7)
733  WRITE(6,*)' Diquark rej. IDVRE(1-3),ud,us,ss ',(idvre(jj),jj=1,3)
734  WRITE(6,*)' Diquark rej. IVDRE(1-3),ud,us,ss ',(ivdre(jj),jj=1,3)
735  WRITE(6,*)' Diquark rej. IDSRE(1-3),ud,us,ss ',(idsre(jj),jj=1,3)
736  WRITE(6,*)' Diquark rej. ISDRE(1-3),ud,us,ss ',(isdre(jj),jj=1,3)
737  WRITE(6,*)' Diquark rej. IDZRE(1-3),ud,us,ss ',(idzre(jj),jj=1,3)
738  WRITE(6,*)' Diquark rej. IZDRE(1-3),ud,us,ss ',(izdre(jj),jj=1,3)
739  WRITE(6,*)' NDZSU,NZDSU ',ndzsu,nzdsu
740  ENDIF
741  IF ((cmhis.EQ.1.d0).AND.(ioudif.EQ.1))
742  & CALL diadif(3,nhkkh1)
743 C Output of x-distribution survey
744  IF(ifrej.EQ.1)THEN
745  WRITE(6,*)' Output of x-distribution survey',
746  * 'VXSP(II),VXST(II),VXSAP(II),VXSAT(II),',
747  *'VXVP(II),VXVT(II),VXDP(II),VXDT(II)' ,
748  *nxsp,nxst,nxsap,nxsat,nxvp,nxvt,nxdp,nxdt
749  DO 6671 ii=1,50
750  IF(nxsp.GE.1)vxsp(ii)=50.d0*vxsp(ii)/nxsp
751  IF(nxst.GE.1)vxst(ii)=50.d0*vxst(ii)/nxst
752  IF(nxsap.GE.1)vxsap(ii)=50.d0*vxsap(ii)/nxsap
753  IF(nxsat.GE.1)vxsat(ii)=50.d0*vxsat(ii)/nxsat
754  IF(nxvp.GE.1)vxvp(ii)=50.d0*vxvp(ii)/nxvp
755  IF(nxvt.GE.1)vxvt(ii)=50.d0*vxvt(ii)/nxvt
756  IF(nxdp.GE.1)vxdp(ii)=50.d0*vxdp(ii)/nxdp
757  IF(nxdt.GE.1)vxdt(ii)=50.d0*vxdt(ii)/nxdt
758  xxxxx=ii*0.02d0-0.01d0
759  xxxx(ii,1)=xxxxx
760  xxxx(ii,2)=xxxxx
761  xxxx(ii,3)=xxxxx
762  xxxx(ii,4)=xxxxx
763  xxxx(ii,5)=xxxxx
764  xxxx(ii,6)=xxxxx
765  fxvvv=(1.-xxxxx)**3/sqrt(xxxxx)
766  fxddd=2.d0*xxxxx**3.0d0/sqrt(1.d0-xxxxx)
767  vxsss(ii,1)=log10(vxsp(ii))
768  vxsss(ii,2)=log10(vxst(ii))
769  vxsss(ii,3)=log10(vxsap(ii))
770  vxsss(ii,4)=log10(vxsat(ii))
771  vxvvv(ii,1)=log10(vxvp(ii))
772  vxvvv(ii,2)=log10(vxvt(ii))
773  vxvvv(ii,3)=log10(vxdp(ii))
774  vxvvv(ii,4)=log10(vxdt(ii))
775  vxvvv(ii,5)=log10(fxvvv)
776  vxvvv(ii,6)=log10(fxddd)
777  axsp=axsp+0.02d0*vxsp(ii)*xxxxx
778  axst=axst+0.02d0*vxst(ii)*xxxxx
779  axsap=axsap+0.02d0*vxsap(ii)*xxxxx
780  axsat=axsat+0.02d0*vxsat(ii)*xxxxx
781  axvp=axvp+0.02d0*vxvp(ii)*xxxxx
782  axvt=axvt+0.02d0*vxvt(ii)*xxxxx
783  axdp=axdp+0.02d0*vxdp(ii)*xxxxx
784  axdt=axdt+0.02d0*vxdt(ii)*xxxxx
785  WRITE(6,*)vxsp(ii),vxst(ii),vxsap(ii),vxsat(ii),
786  * vxvp(ii),vxvt(ii),vxdp(ii),vxdt(ii)
787  6671 CONTINUE
788  WRITE(6,*)
789  *axsp,axst,axsap,axsat,axvp,axvt,axdp,axdt
790  CALL plot(xxxx,vxsss,200,4,50,0.d0,0.02d0,-3.d0,0.05d0)
791  CALL plot(xxxx,vxvvv,300,6,50,0.d0,0.02d0,-3.d0,0.05d0)
792  ENDIF
793 *
794  IF(ipadis) CALL distpa(3)
795  CALL parpt(3,pt1,pt2,ipt,ncases)
796  fracxs=0.d0
797  IF(nstart.EQ.1)THEN
798  IF(ncouxh.GE.0)THEN
799  fracxs=float(ncouxh)/(float(ncouxh)+float(ncouxt))
800  ENDIF
801  WRITE(6,*)' Fraction of x-sect: ',fracxs,ncouxh,ncouxt
802  ENDIF
803  IF(nstart.EQ.2)THEN
804 C print neutrino-nucleon cross section
805  dsigmc=0.
806  IF(ndsig.GE.1) dsigmc=dsigsu/ndsig
807  WRITE(6,*)' Neutrino-nucleon cross section DSIGMC,NDSIG ',
808  & dsigmc,' *10**(-38) cm**2 ',ndsig,' evts'
809  ENDIF
810 C---------------------------------------------------------------
811 C
812 C plot impact parameter distribution
813 C
814 C----------------------------------------------------------------
815 C DO 7784 II=1,200
816 C BIMPP(II)=0.D0
817 CXB(II)=0.1D0*II
818 C7784 CONTINUE
819 C IP=207
820 C IT=207
821 C KKMAT=1
822 C PPROJ=PPN
823 C DO 7785 II=1,100000
824 C CALL SHMAKO(IP,IT,BIMP,NN,NP,NT,JSSH,JTSH,PPROJ,KKMAT)
825 C IF(II.LE.1000)WRITE(6,*)' IP,IT,BIMP,NN,NP,NT ',
826 C * IP,IT,BIMP,NN,NP,NT
827 C IB=BIMP/0.1D0+1.D0
828 C IF(IB.GE.200)IB=200
829 C BIMPP(IB)=BIMPP(IB)+1
830 C7785 CONTINUE
831 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
832 C DO 7786 II=1,200
833 C WRITE(6,*)XB(II),BIMPP(II)
834 C7786 CONTINUE
835 C---------------------------------------------------------------
836 C
837 C plot impact parameter distribution
838 C
839 C---------------------------------------------------------------
840 C IF(IFREJ.EQ.1)THEN
841  IF(ishmal) CALL shmak(3,nshmac,np,nt,ip,it,umo,bimp)
842  IF(ishmal) CALL shmak1(3,nshma2,np,nt,ip,it,umo,bimp)
843 C ENDIF
844  IF (ireso.EQ.1) CALL distrp(3,ncases,ppn)
845  IF (cmhis.EQ.0.d0) CALL distr(3,ncases,ppn,idummy)
846  IF (cmhis.EQ.1.d0) CALL distrc(3,ncases,ppn,idummy)
847  IF (cmhis.EQ.2.d0) CALL distco(3,ncases,ppn,idummy)
848  IF (ireso.EQ.1) CALL disres(3,ncases,ppn)
849 C HBOOK HISTOGRAMS
850 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
851  IF(ihbook.EQ.1.AND.cmhis.EQ.0.d0)THEN
852  CALL plomb(5,pp,char,xfxfxf,itif,ijproj)
853  ENDIF
854  IF(ihbook.EQ.1.AND.cmhis.EQ.1.d0)THEN
855  CALL plombc(5,pp,char,xfxfxf,itif,ijproj)
856  ENDIF
857 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
858  CALL timdat
859 C
860 C----------------------------------------------------------------
861  go to 1000
862  END
863 C
864 C*****************************************************************
865 C
866  SUBROUTINE dminit(NCASES,EPN,PPN,NCOUNT,IGLAUB)
867  IMPLICIT DOUBLE PRECISION (a-h,o-z)
868  SAVE
869 C UNITARIZED HARD AND SOFT MULTICHAIN FRAGMENTATION MODEL
870 C
871 C CODE DPMJET-II.5
872 C
873 C********************************************************************
874 C
875 C
876 C AUTHORS:
877 C J. RANFT, (Johannes.Ranft@cern.ch)
878 C
879 C
880 C
881 C THE CODE
882 C D P M J E T
883 C
884 C IS A CODE TO CALCULATE PARTICLE PRODUCTION
885 C
886 C IN HADRON-NUCLEUS AND NUCLEUS-NUCLEUS COLLISIONS
887 C
888 C USING THE DUAL PARTON MODEL AND THE FORMATION ZONE
889 C
890 C INTRANUCLEAR CASCADE
891 C
892 C Minijets and soft multijets (DTUJET like)
893 C
894 C
895 C D P M J E T PYTHIA-6.1
896 C
897 C REVISION HISTORY: OCTOBER 1989: FORMATION ZONE CASCADE
898 C IMPLEMENTED IN TARGET NUCLEUS
899 C ONLY. THIS IS SUFFICIENT FOR
900 C HADRON-NUCLEUS COLLISIONS
901 C
902 C JANUARY 1990: FORMATION ZONE CASCADE IN PROJEC.
903 C PAULI PRINCIPLE
904 C ELASTIC COLLISIONS IN FORMATION
905 C ZONE CASCADE
906 C
907 C DUAL PARTON MODEL FOR H-A AND A-A
908 C
909 C
910 C JULY 1991: PROPERTIES OF RESIDUAL NUCLEI
911 C WORKED OUT
912 C
913 C 1992 HP-UX Version with minijets
914 C
915 C and multiple soft jets
916 C
917 C 1995/6 introduction of Evaporation
918 C and residual nuclei
919 C (with S.Roesler, A.Ferrari, P.Sala)
920 C
921 C 1997 extension to sqet(s)=2000 TeV
922 C Using GRV94LO and CTEQ96 structure functions
923 C
924 C
925 C Up to Version 2.3 string fragmentation using
926 C the jetset-7.3 code
927 C
928 C Version 2.4 uses the double precision
929 C PYTHIA-6.1 code for jet
930 C fragmentation
931 C
932 C********************************************************************
933 C
934 C
935 C D P M J E T
936 C
937 C
938 C
939 C I-------I
940 C I BEGIN I
941 C I-------I
942 C I
943 C I
944 C I---------------------------I I----------------I
945 C I I I COMMON BLOCKS I
946 C I INITIALISATION I I----------------I
947 C I I I BLOCK DATA I
948 C I---------------------------I I----------------I
949 C I
950 C I-------------------<------------I
951 C I I
952 C I---------------------------I I
953 C I I I
954 C I READ A CONTROL CARD I I
955 C I I I
956 C ---------------------------------------------- I
957 C / / I \ \ I
958 C / / I \ \ I
959 C I------I I------I I------I I------I I------I I
960 C I 100 I I 200 I I 300 I . . . I 3900 I I 4000 I I
961 C ITITLE I IPROJPAR ITARPARI I I I STOP I I
962 C I------I I------I I------I I------I I------I I
963 C I I I I I I
964 C I I I I I------I I
965 C I I I I I STOP I I
966 C I I I I I------I I
967 C I I I I I
968 C I--->---------->------------->------------------>---------I
969 C
970 C
971 C
972 C
973 C
974 C***********************************************************************
975 *KEEP,HKKEVT.
976 c INCLUDE (HKKEVT)
977  parameter(nmxhkk= 89998)
978 c PARAMETER (NMXHKK=25000)
979  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
980  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
981  +(4,nmxhkk)
982 C
983 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
984 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
985 C THE POSITIONS OF THE PROJECTILE NUCLEONS
986 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
987 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
988 C COMPLETELY CONSISTENT. THE TIMES IN THE
989 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
990 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
991 C
992 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
993 C
994 C NMXHKK: maximum numbers of entries (partons/particles) that can be
995 C stored in the commonblock.
996 C
997 C NHKK: the actual number of entries stored in current event. These are
998 C found in the first NHKK positions of the respective arrays below.
999 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
1000 C entry.
1001 C
1002 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
1003 C = 0 : null entry.
1004 C = 1 : an existing entry, which has not decayed or fragmented.
1005 C This is the main class of entries which represents the
1006 C "final state" given by the generator.
1007 C = 2 : an entry which has decayed or fragmented and therefore
1008 C is not appearing in the final state, but is retained for
1009 C event history information.
1010 C = 3 : a documentation line, defined separately from the event
1011 C history. (incoming reacting
1012 C particles, etc.)
1013 C = 4 - 10 : undefined, but reserved for future standards.
1014 C = 11 - 20 : at the disposal of each model builder for constructs
1015 C specific to his program, but equivalent to a null line in the
1016 C context of any other program. One example is the cone defining
1017 C vector of HERWIG, another cluster or event axes of the JETSET
1018 C analysis routines.
1019 C = 21 - : at the disposal of users, in particular for event tracking
1020 C in the detector.
1021 C
1022 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
1023 C standard.
1024 C
1025 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
1026 C The value is 0 for initial entries.
1027 C
1028 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
1029 C one mother exist, in which case the value 0 is used. In cluster
1030 C fragmentation models, the two mothers would correspond to the q
1031 C and qbar which join to form a cluster. In string fragmentation,
1032 C the two mothers of a particle produced in the fragmentation would
1033 C be the two endpoints of the string (with the range in between
1034 C implied).
1035 C
1036 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
1037 C entry has not decayed, this is 0.
1038 C
1039 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
1040 C entry has not decayed, this is 0. It is assumed that the daughters
1041 C of a particle (or cluster or string) are stored sequentially, so
1042 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
1043 C daughters. Even in cases where only one daughter is defined (e.g.
1044 C K0 -> K0S) both values should be defined, to make for a uniform
1045 C approach in terms of loop constructions.
1046 C
1047 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
1048 C
1049 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
1050 C
1051 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
1052 C
1053 C PHKK(4,IHKK) : energy, in GeV.
1054 C
1055 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
1056 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
1057 C
1058 C VHKK(1,IHKK) : production vertex x position, in mm.
1059 C
1060 C VHKK(2,IHKK) : production vertex y position, in mm.
1061 C
1062 C VHKK(3,IHKK) : production vertex z position, in mm.
1063 C
1064 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
1065 C********************************************************************
1066 *KEEP,DPAR.
1067 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1068 C ANAME = LITERAL NAME OF THE PARTICLE
1069 C AAM = PARTICLE MASS IN GEV
1070 C GA = DECAY WIDTH
1071 C TAU = LIFE TIME OF INSTABLE PARTICLES
1072 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1073 C IIBAR = BARYON NUMBER
1074 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1075 C
1076  CHARACTER*8 aname
1077  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1078  +iibar(210),k1(210),k2(210)
1079 C------------------
1080 *KEEP,PANAME.
1081 C------------------
1082 C
1083 C /PANAME/ CONTAINS PARTICLE NAMES
1084 C BTYPE = LITERAL NAME OF THE PARTICLE
1085 C
1086  CHARACTER*8 btype
1087  COMMON /paname/ btype(30)
1088 *KEEP,DINPDA.
1089  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
1090  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
1091 *KEEP,FACTMO.
1092  COMMON /factmo/ ifacto
1093 *KEEP,TAUFO.
1094  COMMON /taufo/ taufor,ktauge,itauve,incmod
1095 *KEEP,RPTSHM.
1096  COMMON /rptshm/ rproj,rtarg,bimpac
1097 *KEEP,TRAFOP.
1098  COMMON /trafop/ gamp,bgamp,betp
1099 *KEEP,REJEC.
1100  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
1101  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
1102  +irvs14, irvv11,irvv12,irvv13,irvv14
1103 *KEEP,DPRIN.
1104  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1105 *KEEP,DNUN.
1106  COMMON /dnun/ nn,np,nt
1107 *KEEP,NSHMAK.
1108  COMMON /nshmak/ nnshma,npshma,ntshma,nshmac,nshma2
1109 *KEEP,DSHM.
1110  COMMON /dshm/ rash,rbsh,bmax,bstep,sigsh,rosh,gsh,
1111  * bsite(0:1,200),nstatb,nsiteb
1112 *KEEP,HADTHR.
1113  COMMON /hadthr/ ehadth,inthad
1114 *KEEP,NUCC.
1115 C COMMON /NUCCC/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
1116 C COMMON /NUCC/ JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG
1117  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1118  COMMON /nuccc/ jt,jtz,jp,jpz,jjproj,jbproj,jjtarg,jbtarg
1119 *KEEP,ZENTRA.
1120  COMMON /zentra/ icentr
1121 *KEEP,CMHICO.
1122  COMMON /cmhico/ cmhis
1123 *KEEP,RESONA.
1124  COMMON /resona/ ireso
1125 *KEEP,DROPPT.
1126  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
1127  +ishmal,lpauli
1128  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
1129  +ipadis,ishmal,lpauli
1130 *KEEP,XSEADI.
1131  COMMON /xseadi/ xseacu,unon,unom,unosea, cvq,cdq,csea,ssmima,
1132  +ssmimq,vvmthr
1133 *KEEP,NUCIMP.
1134  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
1135  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
1136  +prebin,taebin,fermod,etacou
1137 *KEEP,COULO.
1138  common/coulo/icoul
1139 *KEEP,EDENS.
1140  common/edens/ieden
1141 *KEEP,PROJK.
1142  COMMON /projk/ iprojk
1143 *KEEP,INTMX.
1144  parameter(lunber=14)
1145  parameter(intmx=2488,intmd=252)
1146 *KEND.
1147  COMMON /seaqxx/ seaqx,seaqxn
1148  COMMON /cronin/cronco,mkcron
1149  LOGICAL lseadi
1150  COMMON /seadiq/lseadi
1151  COMMON /final/ifinal
1152  COMMON /recom/irecom
1153  COMMON /hboo/ihbook
1154  COMMON /neutyy/ neutyp,neudec
1155  COMMON /nstari/nstart
1156  common/popcor/pdb,ajsdef
1157  common/popcck/pdbck,pdbse,pdbseu,
1158  * ijpock,irejck,ick4,ihad4,ick6,ihad6
1159  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
1160  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
1161  *isea43,isea63,irejao
1162 C modified DPMJET
1163  COMMON /bufues/ bnnvv,bnnss,bnnsv,bnnvs,bnncc,
1164  * bnndv,bnnvd,bnnds,bnnsd,
1165  * bnnhh,bnnzz,
1166  * bptvv,bptss,bptsv,bptvs,bptcc,bptdv,
1167  * bptvd,bptds,bptsd,
1168  * bpthh,bptzz,
1169  * beevv,beess,beesv,beevs,beecc,beedv,
1170  * beevd,beeds,beesd,
1171  * beehh,beezz
1172  * ,bnndi,bptdi,beedi
1173  * ,bnnzd,bnndz,bptzd,bptdz,beezd,beedz
1174  COMMON /ncoucs/ bcouvv,bcouss,bcousv,bcouvs,
1175  * bcouzz,bcouhh,bcouds,bcousd,
1176  * bcoudz,bcouzd,bcoudi,
1177  * bcoudv,bcouvd,bcoucc
1178  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
1179  * anndv,annvd,annds,annsd,
1180  * annhh,annzz,
1181  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
1182  * pthh,ptzz,
1183  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
1184  * eehh,eezz
1185  * ,anndi,ptdi,eedi
1186  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
1187  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
1188  * acouzz,acouhh,acouds,acousd,
1189  * acoudz,acouzd,acoudi,
1190  * acoudv,acouvd,acoucc
1191  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
1192  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
1193  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
1194  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
1195  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
1196  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
1197  COMMON /hdjase/nhse1,nhse2,nhse3,nhase1,nhase2,nhase3
1198 C---------------------
1199  COMMON /diffra/ isingd,idiftp,ioudif,iflagd
1200  COMMON /seasu3/seasq
1201  COMMON /ifragm/ifrag
1202  COMMON /fluctu/ifluct
1203  COMMON /diquax/amedd,idiqua,idiquu
1204  COMMON /vxsvd/vxsp(50),vxst(50),vxsap(50),vxsat(50),
1205  * vxvp(50),vxvt(50),vxdp(50),vxdt(50),
1206  * nxsp,nxst,nxsap,nxsat,nxvp,nxvt,nxdp,nxdt
1207 *
1208 *KEEP,NNCMS.
1209  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
1210 C---------------------
1211 C from DTUJET93
1212  COMMON /xsecpt/ ptcut,sigs,dsigh
1213  COMMON /kglaub/jglaub
1214  COMMON /xsecnu/ecmuu,ecmoo,ngritt,nevtt
1215  dimension ppnpn(4)
1216 *
1217 * **********************************************************************
1218 * * DESCRIPTION OF THE COMMON BLOCK(S), VARIABLE(S) AND DECLARATIONS *
1219 * **********************************************************************
1220 *
1221 *
1222 * the following two COMMON blocks are prepared
1223 *
1224 * *** for normal user ***
1225 *
1226 * who wants to use his own histogramming, detector progams ect.
1227 * without going into details
1228 *
1229 * *********************************************************************
1230 * /USER/ contains the parameters, expected to be modified by normal user
1231 * TITLE is a litteral string TITLE printet in the OUTPUT
1232 * PROJTY resp. TARGTY specify the type of particle scattering
1233 * The projectile moves in positive z-direction.
1234 * (Particle type specifications numbers for scatterers are stored
1235 * in COMMON /BOOKLT/ in BLOCKDATA on the end of this file.
1236 * Our comlete particle and resonance numbering is given in
1237 * the file DTUTCB in BLOCK DATA partic DATA ANAME
1238 * Also a list of our particle numbering
1239 * is obtained running the code word PARTICLE)
1240 * CMENERGY the center of mass energy in GeV
1241 * ISTRUF specifies the structure function as
1242 C ISTRUF=21: GLUECK,REYA,VOGT GRV94LO with K=1.
1243 C ISTRUF=22: GLUECK,REYA,VOGT GRV98LO with K=2.
1244 C ISTRUF=23: CTEQ Collab. CTEQ96 with K=2.
1245 * ISINGD (ISINGX)specifies what is done with diffractive events
1246 * ISINGD=0: Single diffraction surpressed
1247 * ISINGD=1: Single diffraction included to fraction SDFRAC
1248 * ISINGD=2: Only single diffraction with target excited
1249 * ISINGD=3: Only single diffraction with projectile excited
1250 * IDUBLD specifies what is done with double diffractive events
1251 * ISINGD=0: Double diffraction included
1252 * ISINGD=1: Only double diffraction
1253 * SDFRAC see ISINGD
1254 * PTLAR cutoff parameter requiring minijet of given size??
1255 
1256 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1257  CHARACTER*80 titled
1258  CHARACTER*8 projty,targty
1259 C COMMON /USER/TITLED,PROJTY,TARGTY,CMENER,ISTRUF
1260 C & ,ISINGX,IDUBLD,SDFRAC,PTLAR
1261  COMMON /user1/titled,projty,targty
1262  COMMON /user2/cmener,sdfrac,ptlar,istruf,isingx,idubld
1263 *
1264 * *********************************************************************
1265 *
1266 *
1267 * the following alphabetically ordered COMMON blocks are discribed
1268 *
1269 * *** for insider use ***
1270 *
1271 * (parameters of interest to outsiders are explained below
1272 * in the description of "input card" input)
1273 *
1274 *
1275 * *********************************************************************
1276 * /COLLE/ contains the input specifying the MC. run
1277 * NEVHAD = is the number of events
1278 C in older version NCASES
1279 * NVERS = 1 all hard partons considered to be gluons
1280 * rejection method for soft x-selection
1281 * NVERS = 2 all hard partons considered to be gluons
1282 * Aurenche-Maire method for soft x and pt selection
1283 * IHADRZ =
1284 * NFILE =
1285 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1286  COMMON /colle/nevhad,nvers,ihadrz,nfile
1287 *
1288 * *********************************************************************
1289 * /COLLIS/ contains the input specifying the considered event
1290 C ECM dropped as now in /USER/CMENER
1291 * S = is the Mandelstam s variable (=ECM**2)
1292 * IJPROJ,IJTARG = specifies the projectile rsp. target Q.N.
1293 * PTTHR = the minimum pt still hard
1294 * PTTHR2 = the pt of the first sampled hard scattering
1295 * IOPHRD = the option chosen for the hard scatterring
1296 * IJPRLU,IJTALU =
1297 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1298  common/collis/s,ijprox,ijtar,ptthr,ptthr2,iophrd,ijprlu,ijtalu
1299 *
1300 * *********************************************************************
1301 * /BOOKLT/ contains the final particle names and PPDB-numbers
1302 * BTYPEX = literal name of the particle
1303 * NBOOK = the number of the particle
1304 * proposed in the particle data booklet (90)
1305 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1306  CHARACTER*8 btypex
1307  common/booklt/btypex(30),nbook(30)
1308 * *********************************************************************
1309 * /POLMN/ stores arrays describing probabilities of parton
1310 * split in /..0 et al. configurations determined in
1311 * AILMN = "I(L,M,N)" amplidude matrix with L soft, M hard,
1312 * N trippel pomeron exchanges used for ISIG=2,4..
1313 * PLMN = probability of L soft and M hard cut Pomeron
1314 * and N cut tripple Pomeron (or similar)
1315 * PLMNCU = cummulative PLMN
1316 * PDIFR = probability that quasielastic is diffractive
1317 * PSOFT = sum of PLMN(l,m=0,n)
1318 * PHARD = 1-AAAH
1319 * ALFAH = SIGHIN/SIGIN
1320 * BETAH = 1-ALFAH
1321 * SIGTOT,SIGQEL,SIGEL,SIGINE,SIGHIN,SIGD,SIGDD =
1322 * total, quasielastic, elastic, inelastic,
1323 * hard inelsatic, single & double diffractiv X-sec
1324 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1325  COMMON /polmn0/pdifr,phard,psoft,alfah,betah,
1326  * sigtot,sigqel,sigel,sigine,sighin,sigd,sigdd
1327 *
1328 * *********************************************************************
1329 * /POMTYP/ contains parameters determining X-sections
1330 * IPIM,ICON,ISIG,DIFEL,DIFNU resp.
1331 * IPIM,ICON,ISIG,LMAX,MMAX,NMAX as described at "CODEWD=SIGMAPOM"
1332 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1333  COMMON /pomtyp/ipim,icon,isig,lmax,mmax,nmax,difel,difnu
1334 *
1335 * *********************************************************************
1336 * various smaller commons
1337 * in alphabetical order
1338 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1339 C-dtp COMMON /DIFFRA/ISINGD,IDUBLD,SDFRAC dropped as in /USER/
1340  COMMON /dropjj/dropjt,dropva
1341  COMMON /gluspl/nugluu,nsgluu
1342 C-dtu90 COMMON /PTLARG/PTLAR dropped as in /USER/
1343 C-dtp COMMON /PTLARG/PTLAR, XSMAX contains addition kept:
1344  COMMON /ptlarg/xsmax
1345 C-dtp addition next line:
1346  COMMON /ptsamp/ isampt
1347  COMMON /stars/istar2,istar3
1348 C-dtu90 COMMON /STRUFU/ISTRUF dropped as in /USER/
1349 C-dtp COMMON /STRUFU/ISTRUF,ISTRUM contains addition kept:
1350  COMMON /strufu/istrum,istrut
1351  COMMON /cutofn/ncutox
1352  common/pshow/ipshow
1353 C COMMON/HARLUN/IHARLU,QLUN
1354  COMMON /harlun/ qlun,iharlu
1355  COMMON /pomtab/ipomta
1356  COMMON /sincha/isichaa
1357 * evaporation module
1358  COMMON /evappp/ievap
1359 *$ CREATE PAREVT.ADD
1360  parameter( frdiff = 0.2d+00 )
1361  parameter( ethsea = 1.0d+00 )
1362 
1363  LOGICAL ldiffr, linctv, levprt, lheavy, ldeexg, lgdhpr, lpreex,
1364  & lhlfix, lprfix, lparwv, lpower, lsngch, llvmod, lschdf
1365  COMMON / parevt / dpower, fsprd0, fshpfn, rn1gsc, rn2gsc,
1366  & ldiffr(39),lpower, linctv, levprt, lheavy,
1367  & ldeexg, lgdhpr, lpreex, lhlfix, lprfix, lparwv,
1368  & ilvmod, jlvmod, llvmod, lsngch, lschdf
1369 **
1370 *$ CREATE FRBKCM.ADD
1371  parameter( mxffbk = 6 )
1372  parameter( mxzfbk = 9 )
1373  parameter( mxnfbk = 10 )
1374  parameter( mxafbk = 16 )
1375  parameter( nxzfbk = mxzfbk + mxffbk / 3 )
1376  parameter( nxnfbk = mxnfbk + mxffbk / 3 )
1377  parameter( nxafbk = mxafbk + 1 )
1378  parameter( mxpsst = 300 )
1379  parameter( mxpsfb = 41000 )
1380  LOGICAL lfrmbk, lncmss
1381  COMMON / frbkcm / amufbk, eexfbk(mxpsst), amfrbk(mxpsst),
1382  & exfrbk(mxpsfb), sdmfbk(mxpsfb), coufbk(mxpsfb),
1383  & exmxfb, r0frbk, r0cfbk, c1cfbk, c2cfbk,
1384  & ifrbkn(mxpsst), ifrbkz(mxpsst),
1385  & ifbksp(mxpsst), ifbkpr(mxpsst), ifbkst(mxpsst),
1386  & ipsind(0:mxnfbk,0:mxzfbk,2), jpsind(0:mxafbk),
1387  & ifbind(0:nxnfbk,0:nxzfbk,2), jfbind(0:nxafbk),
1388  & ifbcha(5,mxpsfb), iposst, iposfb, ifbstf,
1389  & ifbfrb, nbufbk, lfrmbk, lncmss
1390 *$ CREATE INPFLG.ADD
1391  COMMON /inpflg/ iang,ifiss,ib0,igeom,istrag,keydk
1392  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
1393  COMMON /secint/isecin
1394  COMMON /nuclea/ pfermp(2),pfermn(2),fermdd,
1395  & ebindp(2),ebindn(2),epot(2,210),
1396  & etacoo(2),icoull
1397  COMMON /ferfor/iferfo
1398  COMMON /casadi/casaxx,icasad
1399  COMMON /infore/ifrej
1400 
1401 C---------------------
1402 *
1403 * ********************************************************************
1404 *
1405 C from DTUJET93
1406 C from DTUJET93
1407 
1408  CHARACTER*80 title
1409  CHARACTER*8 code,codewd,blank,sdum
1410  dimension what(6),code(65)
1411  DATA code/
1412  1'TITLE ','PROJPAR ','TARPAR ','ENERGY ','HADRONIZ',
1413  2'RANDOMIZ','FERMI ','EVENTAPE','START ','PARTEV ',
1414  3'INTPT ','TECALBAM','RESONANC','VALVAL ','COMMENT ',
1415  4'OUTLEVEL','LEPTOEVT','SEASEA ','PARTICLE','ALLPART ',
1416  5'TAUFOR ','SEAVAL ','VALSEA ','MOMENTUM','PAULI ',
1417  6'PROJKASK','CENTRAL ','SEADISTR','CMHISTO ','SIGTEST ',
1418  7'XCUTS ','HADRIN ','FACTOMOM','COULOMB ','GLAUBERI',
1419  8'EDENSITY','CMENERGY','INFOREJE','RECOMBIN','SINGDIFF',
1420  9'NOFINALE','SEASU3 ','CRONINPT','POPCORN ','STOP ',
1421  9'FLUCTUAT','DIQUARKS','HBOOKHIS','GLAUBERA','POMTABLE',
1422  9'SINGLECH','HADRINTH','EVAPORAT','SEAQUARK','SECINTER',
1423  9'POPCORCK','CASADIQU','POPCORSE','NEUTRINO','DIFFNUC ',
1424  9'XSECNUC ',' ',' ',' ',' '/
1425 *
1426 C-------------------
1427  DATA blank/' '/
1428  DATA title/' '/
1429 C DATA TITLED/' '/
1430 C----------------------------------------------------------------------
1431  istart=0
1432  ieof=0
1433 C OPEN(5,FILE='DTUNUC.DAT',STATUS='OLD')
1434 C OPEN(6,FILE='DTUNUC.OUT',STATUS='UNKNOWN')
1435 C OPEN(11,FILE='../dtunuc4/BBLO.DAT', STATUS='OLD')
1436 C OPEN(47,FILE='/u1/ranft/dtunuc44/GLAUBTAR.DAT',
1437 C *STATUS='UNKNOWN')
1438 C OPEN(47,FILE='/nfs/hptrack/user/ran/dtunuc44/GLAUBTAR.DAT',
1439 C OPEN(47,FILE='/user/ran/dtunuc44/GLAUBTAR.DAT',
1440 C *STATUS='UNKNOWN')
1441 C OPEN(47,FILE='/lapphp11_2/users/ranft/dtunuc44/GLAUBTAR.DAT',
1442 C *STATUS='UNKNOWN')
1443 C OPEN(47,FILE='GLAUBTAR.DAT',
1444 C *STATUS='UNKNOWN')
1445 C OPEN(37,FILE='GLAUBCROSS.DAT',
1446 C *STATUS='UNKNOWN')
1447 C OPEN( 2,FILE='HIBLD.DAT',STATUS='OLD')
1448 C
1449 C from DTUJET93
1450 C from DTUJET93
1451 C OPEN(7,FILE='DPMJET.TOP')
1452 C OPEN(18,FILE='DPMJET.EVT')
1453 C from DTUJET93
1454  IF (ncount.EQ.1)THEN
1455 *---initialization of DECAY and HADRIN
1456  CALL ddatar
1457  CALL dhadde
1458  CALL dchant
1459  CALL dchanh
1460 *---print the title
1461  WRITE(6,1000)
1462  1000 FORMAT( '1 **************************************************',
1463  +'**************************************************', //
1464  +' DPMJET VERSION II.5 (Sept. 1999) ' /
1465  +' DUAL PARTON MODEL FOR HADRON NUCLEUS COLLISIONS '/ /
1466  +' AND NUCLEUS NUCLEUS COLLISIONS '/
1467  +' INCLUDING A FORMATION TIME INTRANUCLEAR CASCADE'/
1468  4' Minijets and DTUJET like multiple soft jets '/
1469  4' Nuclear evaporation and residual target and '/
1470  4' projectile nuclei '/
1471  +' **************************************************',
1472  +'**************************************************',//)
1473  ENDIF
1474 *---set default parameters not initialized in BLOCK DATA BLKDT1
1475  CALL defaul(epn,ppn)
1476  CALL defaux(epn,ppn)
1477 C
1478 C********************************************************************
1479  icoul=1
1480  icoull=1
1481 C EDENSITY
1482  ieden=0
1483 C TOPDRAW (option removed)
1484  itopd=0
1485 C TAUFOR
1486 *---formation zone intranuclear cascade
1487  taufor=105.d0
1488  ktauge=0
1489  itauve=1
1490  incmod=1
1491 C SEADISTR
1492 *---definition of soft quark distributions
1493  xseaco=1.00d0
1494  xseacu=1.05-xseaco
1495  unon=3.50d0
1496  unom=1.11d0
1497  unosea=5.0d0
1498 C FERMI
1499  fermp=.true.
1500  fermod=0.6d0
1501  fermdd=0.6d0
1502  iferfo=1
1503 C PAULI
1504  ipaupr=0
1505  lpauli=.true.
1506 C XCUTS
1507 *---cutoff parameters for x-sampling
1508  cvq=1.8d0
1509  cdq=2.0d0
1510  csea=0.5d0
1511  ssmima=1.201d0
1512  ssmimq=ssmima**2
1513  vvmthr=0.d0
1514 Cc NOFINALE
1515  ifinal=0
1516 C OUTLEVEL
1517  ipri = 0
1518  ipev = 0
1519  ippa = 0
1520  ipco = -2
1521  init = 0
1522  iphkk= 0
1523 C RECOMBIN
1524  irecom=0
1525  lseadi=.true.
1526 C SEASU3
1527  seasq=0.50d0
1528 C CRONINPT
1529  mkcron=1
1530  cronco=0.64d0
1531 C ALLPART
1532  ihada=.true.
1533 C POPCORCK
1534  pdbck=0.
1535  ijpock=0
1536 C CASADIQU
1537  icasad=1
1538  casaxx=0.5d0
1539 C POPCORSE
1540  pdbse=0.45d0
1541  pdbseu=0.45d0
1542 C
1543  irejck=0
1544  irejse=0
1545  irejs3=0
1546  irejs0=0
1547  ick4=0
1548  ise4=0
1549  ise43=0
1550  ihad4=0
1551  ick6=0
1552  ise6=0
1553  ise63=0
1554  ihad6=0
1555  irejsa=0
1556  ireja3=0
1557  ireja0=0
1558  isea4=0
1559  isea43=0
1560  ihada4=0
1561  isea6=0
1562  isea63=0
1563  ihada6=0
1564 C POPCORN
1565  pdb=0.10d0
1566  ajsdef=0.d0
1567 C FLUCTUAT
1568  ifluct=0
1569 * INTPT
1570  intpt=.true.
1571 * HADRONIZ
1572  ihadrz=2
1573  ifrag=1
1574  IF (ihadrz.GE.2)THEN
1575  ifrag=ihadrz-1
1576  CALL lundin
1577  ENDIF
1578 C DIQUARKS
1579  idiqua=1
1580  idiquu=1
1581  amedd=0.9d0
1582 C SINGLECH
1583  isicha=0
1584 C EVAPORAT
1585  ievap=0
1586 C SEAQUARK
1587 C sea quarks in multiple chains
1588  seaqx=0.5d0
1589 C sea quarks in Glauber events
1590  seaqxn=0.5d0
1591 C GLAUBERI
1592 C GLAUBERA
1593 C change JGLAUB in dpmjet25 to JGLAUB=1 (was 2 in dpmjet241)
1594  jglaub=1
1595 C HADRINTH
1596  ehadth=5.d0
1597 C HBOOKHIS
1598  ihbook=1
1599 C POMTABLE
1600  ipomta=0
1601 C-------------------
1602 C from DTUJET93
1603 * ********************************************************************
1604 * Initialize defaults for "input card" input parameters
1605 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1606 *
1607 * (to understand the meaning of parameters, we recommend
1608 * description of "input card" input provided below)
1609 *
1610 * *** the following initialisation involve normal user input cards
1611 *
1612 * CMENERGY
1613  cmener=540.
1614  s=cmener**2
1615  IF(istrut.EQ.1)THEN
1616  ptthr=2.1+0.15*(log10(cmener/50.))**3
1617  ptthr2=ptthr
1618  ELSEIF(istrut.EQ.2)THEN
1619  ptthr=2.5+0.12*(log10(cmener/50.))**3
1620  ptthr2=ptthr
1621  ENDIF
1622 * PROJPAR
1623  projty='PROTON '
1624  ijproj=1
1625  ijprox=1
1626  ibproj=1
1627  ip=1
1628  ipz=1
1629  jjproj=1
1630  jjprox=1
1631  jbproj=1
1632  jp=1
1633  jpz=1
1634 * MOMENTUM
1635  ppn=100000.
1636  nnpp=1
1637  IF(ijproj.NE.0) nnpp=ijproj
1638  epn=sqrt(ppn**2+aam(nnpp)**2)
1639 * nucleon-nucleon cms
1640 C IBPROJ=1
1641  eproj=epn
1642  amproj=aam(nnpp)
1643  amtar=aam(1)
1644  pproj = sqrt((epn-amproj)*(epn+amproj))
1645  umo = sqrt(amproj**2 + amtar**2 + 2.*amtar*eproj)
1646  cmener=umo
1647  gamcm = (eproj+amtar)/umo
1648  bgcm=pproj/umo
1649  ecm=umo
1650  pcm=gamcm*pproj - bgcm*eproj
1651  IF(istrut.EQ.1)THEN
1652  ptthr=2.1+0.15*(log10(cmener/50.))**3
1653  ptthr2=ptthr
1654  ELSEIF(istrut.EQ.2)THEN
1655  ptthr=2.5+0.12*(log10(cmener/50.))**3
1656  ptthr2=ptthr
1657  ENDIF
1658 C
1659 * TARPAR
1660  targty=blank
1661  ijtar=1
1662  it=14
1663  itz=7
1664  ijtarg=1
1665  ibtarg=1
1666  jjtar=1
1667  jt=14
1668  jtz=7
1669  jjtarg=1
1670  jbtarg=1
1671 * CMHISTO
1672  cmhis=0.d0
1673 * CENTRAL
1674  icentr=0
1675 * STRUCFUN
1676  istruf=222
1677  istrum=0
1678  istrut=istruf/100
1679  istruf=istruf-istrut*100
1680  istrum=istruf
1681 * SINGDIFF
1682  isingd=1
1683  isingx=1
1684  idubld=0
1685  sdfrac=1.
1686 * START
1687 C NEVNTS passed to DTMAI as argument, NEVHAD in COMMON
1688  nfile=0
1689  nstart=1
1690  istar2=0
1691  istar3=0
1692  ptlar=2.
1693  iglaub=0
1694 *
1695 * *** the following initialisation involve input cards for internal use
1696 * (in alphabetical order)
1697 *
1698 * INFOREJE
1699  ifrej=0
1700 * COMBIJET
1701 C NCUTOF=50
1702 C NCUTOX=50
1703 * GLUSPLIT
1704  nugluu=1
1705  nsgluu=0
1706 * PARTEV
1707 * ITEST=0 (see SIGMAPOM)
1708  npev=30
1709  nvers=1
1710 * SAMPT
1711  isampt=4
1712 * SELHARD
1713 *
1714  dropjt=0.
1715 * ITEST=0 (see SIGMAPOM)
1716  iophrd=2
1717  ptthr=3.
1718  ptthr2=ptthr
1719 * SIGMAPOM
1720 *
1721  itest=0
1722  ipim=2
1723  icon=48
1724  isig=10
1725 C only ISIG=10 possible since dpmjet--II.5
1726 C default changed in relation to DPT =4
1727  lmax=30
1728  mmax=100
1729  nmax= 2
1730  difel = 0.
1731  difnu = 1.
1732 * some options use special routines for MMAX=0 so far NMAX=0
1733 * PSHOWER
1734  ipshow=1
1735 C SECINTER
1736  isecin=0
1737 * RANDOM
1738  iseed1=12
1739  iseed2=34
1740  iseed3=56
1741  iseed4=78
1742 C EVAPORATE
1743 * set default if EVAP requested without "what-values"
1744  levprt = .true.
1745  ilvmod = 1
1746  ldeexg = .true.
1747  lheavy = .true.
1748  lfrmbk = .false.
1749  lfrmbk = .true.
1750  ifiss = 0
1751 * Initialize random generator
1752 C CALL RNDMST(ISEED1,ISEED2,ISEED3,ISEED4)
1753 C* test random generator (C as not to be understood by user)
1754 C CALL RNDMTE(1)
1755 *
1756 * starting parameters not read in
1757  istart=0
1758  xsmax=0.8
1759  itopd=0
1760 *
1761 * *********************************************************************
1762 *
1763 C from DTUJET93
1764 C from DTUJET93
1765 C
1766 C********************************************************************
1767 C READ A CONTROL CARD
1768 C
1769 C
1770 C CONSTRUCTION OF THESE CARDS:
1771 C CODEWD (WHAT(I),I=1,6) SDUM
1772 C FORMAT(A8, 2X, 6E10.0, A8 )
1773 C********************************************************************
1774 C
1775  10 CONTINUE
1776  IF(ieof.EQ.1) go to 40
1777 C READ(5,1010,END=40)CODEWD,(WHAT(I),I=1,6),SDUM
1778  READ(5,1010)codewd,(what(i),i=1,6),sdum
1779  WRITE(6,1020)codewd,(what(i),i=1,6),sdum
1780  DO 20 isw=1,65
1781 *
1782  IF(codewd.EQ.code(isw)) go to 30
1783  20 CONTINUE
1784  isw=66
1785  WRITE(6,1030)
1786 C GO TO 10
1787  30 go to(
1788 C------------------------------------------------------------
1789 C TITLE , PROJPAR , TARPAR , ENERGY , HADRONIZ,
1790  + 50 , 60 , 90 , 120 , 130 ,
1791 C
1792 C------------------------------------------------------------
1793 C RANDOMIZ, FERMI , EVENTAPE, START , PARTEV ,
1794  + 140 , 150 , 160 , 170 , 210 ,
1795 C
1796 C------------------------------------------------------------
1797 C INTPT , TECALBAM, RESONANC, VALVAL , COMMENT ,
1798  + 220 , 230 , 240 , 250 , 260 ,
1799 C
1800 C------------------------------------------------------------
1801 C OUTLEVEL, LEPTOEVT, SEASEA , PARTICLE, ALLPART ,
1802  + 280 , 290 , 300 , 310 , 320 ,
1803 C
1804 C------------------------------------------------------------
1805 C TAUFOR , SEAVAL , VALSEA , MOMENTUM, PAULI ,
1806  + 330 , 340 , 350 , 360 , 370 ,
1807 C
1808 C------------------------------------------------------------
1809 C PROJKASK, CENTRAL , SEADISTR, CMHISTO , SIGTEST ,
1810  + 380 , 390 , 400 , 410 , 420 ,
1811 C
1812 C------------------------------------------------------------
1813 C XCUTS , HADRIN , FACTOMOM , COULOMB , GLAUBERI ,
1814  + 430 , 440 , 450 , 460 , 470 ,
1815 C
1816 C------------------------------------------------------------
1817 C EDENSITY, CMENERGY, INFOREJE , RECOMBIN , SINGDIFF )
1818  + 480 , 490 , 500 , 510 , 520 ,
1819 C
1820 C------------------------------------------------------------
1821 C NOFINALE, SEASU3 CRONINPT POPCORN , STOP )
1822  + 530 , 535 , 538, 539, 540 ,
1823 C
1824 C------------------------------------------------------------
1825 C FLUCTUAT,DIQUARKS HBOOKHIS,GLAUBERA,POMTABLE )
1826  + 541 , 542 , 543, 544, 545,
1827 C
1828 C------------------------------------------------------------
1829 Ch
1830 C SINGLECH, HADRINTH ,EVAPORAT ,SEAQUARK, SECINTER )
1831  + 551 , 552 , 553 , 554 ,555 ,
1832 C
1833 C------------------------------------------------------------
1834 C POPCORCK ,CASADIQU ,POPCORSE ,NEUTRINO,DIFFNUC )
1835  + 556 , 557 ,558 , 559 ,560,
1836 C
1837 C------------------------------------------------------------
1838 C XSECNUC , , , , )
1839  + 620 , 630 ,640 , 650 ,660,610),isw
1840 C
1841 C------------------------------------------------------------
1842 *
1843  go to 10
1844  40 CONTINUE
1845  what(1)=0.0d0
1846  what(2)=0.0d0
1847  what(3)=0.0d0
1848  what(4)=0.0d0
1849  what(5)=0.0d0
1850  what(6)=0.0d0
1851  sdum=blank
1852  ieof=1
1853  istart=1
1854  IF(istart.GT.0)THEN
1855  WRITE(6,1040)
1856  go to 540
1857  ELSE
1858  WRITE(6,1050)
1859  go to 170
1860  ENDIF
1861  1010 FORMAT(a8,2x,6e10.0,a8 )
1862  1020 FORMAT(' *****NEXT CONTROL CARD ***** ',a10,6(1x,g11.4), 2x,a10)
1863 
1864  1030 FORMAT(/,' UNKNOWN CODEWORD - CONTROL CARD IGNORED')
1865  1040 FORMAT(/,' UNEXPECTED END OF INPUT - STOP ASSUMED.')
1866  1050 FORMAT(/,' UNEXPECTED END OF INPUT - START ASSUMED.')
1867 C
1868 C********************************************************************
1869 C CONTROL CARD: CODEWD = TITLE
1870 C DEFINES THE TITLE OF THE JOB
1871 C
1872 C WHAT(1...6),SDUM HAVE NO MEANING
1873 C THIS CARD MUST BE FOLLOWED BY THE CARD GIVING THE TITLE
1874 C OF THE RUN.
1875 C********************************************************************
1876 C
1877  610 CONTINUE
1878 C from DTUJET93
1879 *
1880 * The following CODEWD options are used by normal users:
1881 * to overwrite initial values:
1882 * CMENERGY PROJPAR TARPAR
1883 * STRUCFUN SINGDIFF
1884 * to order tasks:
1885 * START STOP
1886 * PARTICLE XSECTION TITLE)+ COMMENT)+
1887 * Cards marked with )+ have to be followed by data cards of special format
1888 *
1889 * Exemplaric imput cards inside dotts:
1890 *...............................................................................
1891 *.TITLE .
1892 *.TEST NORMAL RUN PTCUT= 3 GEV/C .
1893 *.PROJPAR APROTON.
1894 *.CMENERGY 1800. .
1895 *.START 10000. 0. 0. 0. 2.0 .
1896 *.STOP .
1897 *.........................................................ignore dotts..........
1898 *
1899 *- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1900 *
1901 *
1902 *********************************************************************
1903 * printout in case input card to be considered
1904 * (1st empty or dashed cards are ignored)
1905 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1906  IF (codewd.GT.'-zzzzzzz')
1907  1 WRITE(6,91) codewd,(what(i),i=1,6),sdum
1908  91 FORMAT(' ---- control input card : ----'
1909  1 /1x,a8,2x,6(f10.3),a8)
1910  2 CONTINUE
1911 *
1912 * *********************************************************************
1913 * input card: CODEWD = STRUCFUN
1914 * defines the structure functions for hard scatter
1915 *
1916 * WHAT(1) ISTRUF default: 222
1917 C ISTRUF=21: GLUECK,REYA,VOGT GRV94LO with K=1.
1918 C ISTRUF=22: GLUECK,REYA,VOGT GRV98LO with K=2.
1919 C ISTRUF=23: CTEQ Collab. CTEQ96 with K=2.
1920 * ISTRUF=ISTRUF+200 signal for Energy dependent ptcut
1921 *****************************************************************
1922 * Only ISTRUF=222 makes sense in dpmjet-II.5
1923 *****************************************************************
1924 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1925 *
1926  IF(codewd.EQ.'STRUCFUN') THEN
1927 *
1928  istruf=int(what(1))
1929 C not in DT90 new in DTP
1930  istrum=int(what(2))
1931  istrut=istruf/100
1932  istruf=istruf-istrut*100
1933  istrum=istruf
1934  WRITE(6,*)' ISTRUF,ISTRUT ',istruf,istrut
1935  go to 10
1936 *
1937 *
1938 * *********************************************************************
1939 * input card: CODEWD = PSHOWER
1940 * Demands showering of hard partons
1941 * Only with JETSET fragnentation
1942 * WHAT(1)=IPSHOW Default:1.
1943 * Hard partons showering
1944 * with IPSHOW=1 not showering with
1945 * IPSHOW=0
1946 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1947 *
1948  ELSEIF(codewd.EQ.'PSHOWER ') THEN
1949 *
1950  ipshow=what(1)
1951  go to 10
1952  ENDIF
1953  CALL dttest(codewd,what,sdum)
1954  go to 10
1955 * *********************************************************************
1956 *
1957 ************************************************************************
1958 C from DTUJET93
1959 C from DTUJET93
1960 C
1961 C********************************************************************
1962 C CONTROL CARD: CODEWD =TITLE
1963 C DEFINES THE TITLE OF THE JOB
1964 C
1965 C WHAT(1...6),SDUM HAVE NO MEANING
1966 C THIS CARD MUST BE FOLLOWED BY THE CARD GIVING THE TITLE
1967 C OF THE RUN.
1968 C********************************************************************
1969 C
1970  50 CONTINUE
1971  READ(5,1060)title
1972  titled=title
1973  WRITE(6,1070)title
1974  go to 10
1975  1060 FORMAT(a80)
1976  1070 FORMAT(//,5x,a80,//)
1977 C
1978 C********************************************************************
1979 C CONTROL CARD: CODEWD = PROJPAR
1980 C DEFINES THE PROJECTILE PARTICLE / NUCLEUS
1981 C
1982 C SDUM = IF DEFINED - PROJECTILE PARTICLE TYPE
1983 C OTHERWIZE
1984 C WHAT(1) = IP MASS NUMBER OF PROJECTILE NUCLEUS
1985 C WHAT(2) = IPZ CHARGE OF PROJECTILE NUCLEUS
1986 C
1987 C********************************************************************
1988 C
1989  60 CONTINUE
1990  projty=sdum
1991  IF(sdum.EQ.blank) THEN
1992  ip=int(what(1))
1993  ipz=int(what(2))
1994  ibproj=1
1995  ijproj=1
1996  ijprox=1
1997  IF(ip.EQ.1) ijproj=1
1998  IF(ip.EQ.1) ijprox=1
1999  jp=int(what(1))
2000  jpz=int(what(2))
2001  jbproj=1
2002  jjproj=1
2003  jjprox=1
2004  IF(ip.EQ.1) jjproj=1
2005  IF(ip.EQ.1) jjprox=1
2006  ELSE
2007  DO 70 ii=1,30
2008  IF(sdum.EQ.btype(ii)) THEN
2009  ijproj=ii
2010  ijprox=ii
2011  ibproj=iibar(ijproj)
2012  ipz=1
2013  ip=1
2014  jjproj=ii
2015  jjprox=ii
2016  jbproj=iibar(ijproj)
2017  jpz=1
2018  jp=1
2019  goto 80
2020  ENDIF
2021  70 CONTINUE
2022  WRITE(6,'(A)') ' WRONG STRUCTURE OF PROJPAR CARD'
2023  stop
2024  ENDIF
2025  80 CONTINUE
2026  go to 10
2027 C
2028 C********************************************************************
2029 C CONTROL CARD: CODEWD = TARPAR
2030 C DEFINES THE TARGET NUCLEUS
2031 C
2032 C WHAT(1) = IT MASS NUMBER OF TARGET NUCLEUS
2033 C WHAT(2) = ITZ CHARGE OF TARGET NUCLEUS
2034 C
2035 C********************************************************************
2036 C
2037  90 CONTINUE
2038  targty=sdum
2039  IF(sdum.EQ.blank) THEN
2040  it=int(what(1))
2041  itz=int(what(2))
2042  jt=int(what(1))
2043  jtz=int(what(2))
2044  ELSE
2045  DO 100 ii=1,30
2046  IF(sdum.EQ.btype(ii)) THEN
2047  itz=1
2048  it=1
2049  ijtar=ii
2050  jtz=1
2051  jt=1
2052  jjtar=ii
2053  goto 110
2054  ENDIF
2055  100 CONTINUE
2056  WRITE(6,'(A)') ' WRONG STRUCTURE OF TARPAR CARD'
2057  stop
2058  ENDIF
2059  110 CONTINUE
2060  go to 10
2061 C
2062 C********************************************************************
2063 C CONTROL CARD: CODEWD = ENERGY
2064 C DEFINES THE LAB ENERGY OF THE PROJECTILE
2065 C
2066 C WHAT(1) = LAB ENERGY IN GEV DEFAULT: 200.
2067 C
2068 C********************************************************************
2069  120 CONTINUE
2070  epn=what(1)
2071  nnpp=1
2072  IF(ijproj.NE.0) nnpp=ijproj
2073  ppn=sqrt((epn-aam(nnpp))*(epn+aam(nnpp)))
2074 
2075 * nucleon-nucleon cms
2076 C IBPROJ=1
2077  eproj=epn
2078  amproj=aam(nnpp)
2079  amtar=aam(1)
2080  pproj = sqrt((epn-amproj)*(epn+amproj))
2081  umo = sqrt(amproj**2 + amtar**2 + 2.*amtar*eproj)
2082  cmener=umo
2083  IF(istrut.EQ.1)THEN
2084  ptthr=2.1+0.15*(log10(cmener/50.))**3
2085  ptthr2=ptthr
2086  ELSEIF(istrut.EQ.2)THEN
2087  ptthr=2.5+0.12*(log10(cmener/50.))**3
2088  ptthr2=ptthr
2089  ENDIF
2090  gamcm = (eproj+amtar)/umo
2091  bgcm=pproj/umo
2092  ecm=umo
2093  pcm=gamcm*pproj - bgcm*eproj
2094 C
2095  print 1033, eproj,pproj,
2096  +amproj,amtar,umo,gamcm,bgcm,pcm
2097  1033 FORMAT(' CMS: ' ,
2098  +' EPROJ,PPROJ,AMPROJ,AMTAR,UMO,GAMCM,BGCM,PCM'/8e22.13)
2099 
2100  go to 10
2101 C
2102 C********************************************************************
2103 C
2104 C CONTROL CARD: CODEWD = HADRONIZ
2105 C DEFINES THE CODE USED FOR HADRONIZATION
2106 C
2107 C WHAT(1) = IHADRZ: DEFINES THE HADRONIZATION CODE DEFAULT: 2
2108 C IHADRZ=2 JETSET HADRONIZATION OF CHAINS
2109 C IHADRZ=11 alternative JETSET HADRONIZATION OF CHAINS
2110 C WHAT(2) =
2111 C WHAT(3) =
2112 C
2113 C
2114 C********************************************************************
2115 C
2116  130 CONTINUE
2117  ihadrz=int(what(1))
2118  ifrag=0
2119  IF (ihadrz.GE.2)THEN
2120  ifrag=ihadrz-1
2121  CALL lundin
2122  ENDIF
2123  go to 10
2124 C
2125 C********************************************************************
2126 C CONTROL CARD: CODEWD = RANDOMIZE
2127 C SETS THE SEED FOR THE RANDOM NUMBER GENERATOR RM48
2128 C
2129 C What(1): ISEED1
2130 C What(1): ISEED1
2131 C
2132 C
2133 C********************************************************************
2134 C
2135  140 CONTINUE
2136  iseed1=what(1)
2137  iseed2=what(2)
2138  auauau=rd2in(iseed1,iseed2)
2139 
2140  go to 10
2141 C
2142 C********************************************************************
2143 C CONTROL CARD: CODEWD = FERMI
2144 C ALLOWS TO SWITCH FERMI MOTION ON OR OFF
2145 C
2146 C WHAT(1) = 1. FERMI MOTION ON DEFAULT ON
2147 C ELSE FERMI MOTION OFF
2148 C WHAT(2) = SCALE FACTOR FOR FERMI MOMENTUM (KKINC)
2149 C DEFAULT = 0.6
2150 C WHAT(3) = 1. Zero temperature Fermi distr. DEFAULT 1
2151 C 2. Function from C.C.d.Atti PRD53(96)1689
2152 C
2153 C********************************************************************
2154 C
2155  150 CONTINUE
2156  IF (what(1).EQ.1.d0)THEN
2157  fermp=.true.
2158  ELSE
2159  fermp=.false.
2160  ENDIF
2161  fermdd=what(2)
2162  fermod=what(2)
2163  IF(fermod.LT.0.0d0.OR.scafer.GT.2.0d0) scafer=1.0d0
2164  iferfo=1
2165  IF(what(3).NE.0.d0)iferfo=what(3)
2166 C
2167  go to 10
2168 C
2169 C********************************************************************
2170 C CONTROL CARD: CODEWD = EVENTAPE
2171 C WRITES THE EVENTS TO A FILE DTUJET EVENTS
2172 C
2173 C WHAT(1) =
2174 C WHAT(2) =
2175 C
2176 C********************************************************************
2177 C
2178  160 CONTINUE
2179 C WRITE (11,1080)
2180 C WRITE(11,1070)TITLE
2181  1080 FORMAT (' THIS FILE CONTAINS EVENTS FROM KKEVT ')
2182  go to 10
2183 C
2184 C********************************************************************
2185 C CONTROL CARD: CODEWD = START
2186 C STARTS THE SAMPLING OF EVENTS AND STANDARD HISTOGRAM
2187 C OUTPUT
2188 C
2189 C WHAT(1)=NUMBER OF EVENTS NCASES, DEFAULT: 1000.0
2190 C WHAT(2)=IGLAUB
2191 * controls Glauber initialization default: 0. *
2192 * IGLAUB=1 : initialization via SHMAKI forced
2193 C WHAT(3)=
2194 C
2195 C********************************************************************
2196 C
2197  170 CONTINUE
2198  nstart=1
2199 C---histogram initialization
2200  IF (ireso.EQ.1) CALL distrp(1,ijproj,ppn)
2201  IF (cmhis.EQ.0.d0) CALL distr(1,ijproj,ppn,idummy)
2202  IF (cmhis.EQ.1.d0) CALL distrc(1,ijproj,ppn,idummy)
2203  IF (cmhis.EQ.2.d0) CALL distco(1,ijproj,ppn,idummy)
2204  IF (ireso.EQ.1) CALL disres(1,nhkkh1,ppn)
2205  IF (ipadis) CALL distpa(1)
2206  IF (ioudif.EQ.1) CALL diadif(1,0)
2207  CALL shmak(1,nn,np,nt,ip,it,umo,bimp)
2208  CALL shmak1(1,nn,np,nt,ip,it,umo,bimp)
2209 * initialization of evaporation-module
2210  WRITE(6,*)' before NUCLEAR.BIN opened LUNBER= ',lunber
2211 * initialization of evaporation-module
2212  OPEN(unit=lunber,file='NUCLEAR.BIN',status='OLD'
2213  * ,form='UNFORMATTED')
2214 C OPEN(UNIT=LUNBER,FILE='NUCLEAR.BIN',STATUS='OLD'
2215 C * ,READONLY,FORM='UNFORMATTED')
2216 C * ,FORM='UNFORMATTED')
2217  WRITE(6,*)'NUCLEAR.BIN opened LUNBER= ',lunber
2218  CALL berttp
2219  IF(ievap.EQ.1)THEN
2220 C CALL ZEROIN
2221 C OPEN(UNIT=LUNBER,FILE='NUCLEAR.BIN',STATUS='OLD'
2222 C * ,READONLY,FORM='UNFORMATTED')
2223 C CALL BERTTP
2224  CALL incini
2225  ENDIF
2226 C HBOOK HISTOGRAMS
2227 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2228  IF(ihbook.EQ.1.AND.cmhis.EQ.0.d0)THEN
2229  CALL plomb(1,ppnpn,char,xfxfxf,itif,ijproj)
2230  ENDIF
2231  IF(ihbook.EQ.1.AND.cmhis.EQ.1.d0)THEN
2232  CALL plombc(1,ppnpn,char,xfxfxf,itif,ijproj)
2233  ENDIF
2234 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2235 C IF(NCOUNT.EQ.1) THEN
2236 *---initialization and test of the random number generator
2237 C CALL RNDMST(12,34,56,78)
2238 C CALL RNDMTE(1)
2239 C ENDIF
2240 *---CONSISTENCY TEST FOR FERMI/PAULI OPTIONS
2241  IF(lpauli .AND. (.NOT.fermp)) THEN
2242  WRITE(6,'(/2A/A/)')
2243  + ' ACTIVATION OF PAULI PRINCIPLE ONLY REASONABLE',
2244  + ' IF FERMI ACTIVE', ' LPAULI CHANGED TO .FALSE.'
2245  lpauli=.false.
2246  ENDIF
2247 C CLOSE (UNIT=5)
2248 C CLOSE (UNIT=11)
2249  ncases=int(what(1))
2250  nevnts=int(what(1))
2251  IF(nevnts.LE.0) nevnts=1000
2252  nevhad=nevnts
2253 C why 2: NEVNTS passed to DTMAI as argument, NEVHAD in COMMON
2254 C in DTP NCASES <- NEVNTS
2255  IF(ncases.LE.0) ncases=100
2256  iglaub=int(what(2))
2257 C IGLAUB=1
2258  IF(iglaub.NE.1) iglaub=0
2259 *---INITIALIZE GLAUBER THEORY A LA SHMAKOV
2260  CALL timdat
2261  IF(iglaub.EQ.1) THEN
2262 C change JGLAUB in dpmjet25 to JGLAUB=1 (was 2 in dpmjet241)
2263  jglaub=1
2264  CALL shmaki(ip,ipz,it,itz,rproj,rtarg,ppn)
2265 C CALL SHMAKI(4,2,12,6,RPROJ,RTARG,PPN)
2266  ELSE
2267  CALL shmakf(ip,ipz,it,itz)
2268  ENDIF
2269 C WRITE(6,*)'call xsglau'
2270 C CALL XSGLAU(IP,IT,IJPROJ,1)
2271 *
2272 * Parton level initialisation
2273 * (PARTEV call prior to START no longer required)
2274 C userfriendly! , as DT90, not as DTP
2275 * initialize NSOFT-NHARD event selection
2276  IF(ipim.EQ.2)CALL prblm2(cmener)
2277 * initialize hard scattering
2278  CALL jtdtu(0)
2279 * initialize transverse momenta for soft scattering
2280  CALL samppt(0,pt)
2281  nn=1
2282  np=1
2283  nt=1
2284 C INITIALIZE COUNTERS
2285  bnnvv=0.001
2286  bnnss=0.001
2287  bnnsv=0.001
2288  bnnvs=0.001
2289  bnncc=0.001
2290  bnndv=0.001
2291  bnnvd=0.001
2292  bnnds=0.001
2293  bnnsd=0.001
2294  bnnhh=0.001
2295  bnnzz=0.001
2296  bnndi=0.001
2297  bnnzd=0.001
2298  bnndz=0.001
2299  bptvv=0.
2300  bptss=0.
2301  bptsv=0.
2302  bptvs=0.
2303  bptcc=0.
2304  bptdv=0.
2305  bptvd=0.
2306  bptds=0.
2307  bptsd=0.
2308  bpthh=0.
2309  bptzz=0.
2310  bptdi=0.
2311  bptzd=0.
2312  bptdz=0.
2313  beevv=0.
2314  beess=0.
2315  beesv=0.
2316  beevs=0.
2317  beecc=0.
2318  beedv=0.
2319  beevd=0.
2320  beeds=0.
2321  beesd=0.
2322  beehh=0.
2323  beezz=0.
2324  beedi=0.
2325  beezd=0.
2326  beedz=0.
2327 C COMMON /NCOUCH/ ACOUVV,ACOUSS,ACOUSV,ACOUVS,
2328 C * ACOUZZ,ACOUHH,ACOUDS,ACOUSD,
2329 C * ACOUDZ,ACOUZD,ACOUDI
2330  bcouvv=0.
2331  bcouss=0.
2332  bcousv=0.
2333  bcouvs=0.
2334  bcouzz=0.
2335  bcouhh=0.
2336  bcouds=0.
2337  bcousd=0.
2338  bcoudz=0.
2339  bcouzd=0.
2340  bcoudi=0.
2341  bcoudv=0.
2342  bcouvd=0.
2343  bcoucc=0.
2344  IF(istrut.EQ.1)THEN
2345  ptthr=2.1+0.15*(log10(cmener/50.))**3
2346  ptthr2=ptthr
2347  ELSEIF(istrut.EQ.2)THEN
2348  ptthr=2.5+0.12*(log10(cmener/50.))**3
2349  ptthr2=ptthr
2350  ENDIF
2351  CALL timdat
2352  RETURN
2353 C
2354 C********************************************************************
2355 C CONTROL CARD: CODEWD = PARTEV
2356 C DEMANDS HISTOGRAMS OF PARTONS AT CHAIN ENDS
2357 C
2358 C WHAT(1) = 1.: HISTOGRAMS ; OTHER VALUES: NO HISTOGRAMS
2359 C WHAT(2) =
2360 C WHAT(3) =
2361 C SDUM =
2362 C
2363 C********************************************************************
2364 C
2365  210 CONTINUE
2366  IF (what(1).EQ.1.d0) THEN
2367  ipadis=.true.
2368  ELSE
2369  ipadis=.false.
2370  ENDIF
2371  go to 10
2372 C
2373 C********************************************************************
2374 C CONTROL CARD: CODEWD = INTPT
2375 C SWITCHES INTRINSIC TRANSVERSE MOMENTA OF PARTONS
2376 C ON AND OFF
2377 C
2378 C WHAT(1) = 1. ON ELSE OFF DEFAULT ON
2379 C WHAT(2) =
2380 C
2381 C********************************************************************
2382 C
2383  220 CONTINUE
2384  IF (what(1).EQ.1.d0) THEN
2385  intpt=.true.
2386  ELSE
2387  intpt=.false.
2388  ENDIF
2389  go to 10
2390 C
2391 C********************************************************************
2392 C
2393 C CONTROL CARD: CODEWD = TECALBAM
2394 C TESTS ROUTINES FOR
2395 C SOFT JET FRAGMENTATION
2396 C
2397 C TECALBAM DEMANDS ONE OR SEVERAL INPUTCARDS, WHICH SHOULD FOLLOW
2398 C AFTER THE TECALBAM CARD
2399 C
2400 C********************************************************************
2401 C
2402  230 CONTINUE
2403 C IF(NCOUNT.EQ.1) THEN
2404 *---initialization and test of the random number generator
2405 C CALL RNDMST(12,34,56,78)
2406 C CALL RNDMTE(1)
2407 C ENDIF
2408  CALL tecalb
2409 C OPEN(26,FILE='PART.JS',
2410 C *STATUS='UNKNOWN')
2411 C CALL JSPARR
2412 C OPEN(25,FILE='JETSET.DEC',
2413 C *STATUS='UNKNOWN')
2414 C CALL PYUPDA(1,25)
2415  go to 10
2416 C
2417 C********************************************************************
2418 C CONTROL CARD: CODEWD = RESONANC
2419 C SAMPLING OF RESONANCES IN FINAL STATE
2420 C NOTE: presently done before particle decay after KKEVT,
2421 C i.e. before the treatment of secondary interactions
2422 C WHAT(1)
2423 C
2424 C********************************************************************
2425 C
2426  240 CONTINUE
2427  IF(what(1).GT.0.5d0) ireso=1
2428  go to 10
2429 C
2430 C********************************************************************
2431 C CONTROL CARD: CODEWD = VALVAL
2432 C DEMANDS SAMPLING OF HISTOGRAMS FROM HADRONIZED
2433 C VALENCE-VALENCE STRINGS SEPARATELY
2434 C
2435 C WHAT(1) = 1. SAMPLING ELSE NO SAMPLING DEFAULT NO
2436 C
2437 C********************************************************************
2438 C
2439  250 CONTINUE
2440  IF (what(1).EQ.1.d0) THEN
2441  ihadvv=.true.
2442  ELSE
2443  ihadvv=.false.
2444  ENDIF
2445  go to 10
2446 C
2447 C********************************************************************
2448 C CONTROL CARD: CODEWD = COMMENT
2449 C MAKES POSSIBLE TO ADD COMMENTS IN THE INPUT
2450 C
2451 C WHAT(1) = NUMBER OF COMMENT CARDS FOLLOWING THIS CONTROL CARD
2452 C (DEFAULT: 1 COMMENT CARD)
2453 C
2454 C********************************************************************
2455 C
2456  260 CONTINUE
2457  ncom=int(what(1))
2458  IF(ncom.LE.0)ncom=1
2459  DO 270 j=1,ncom
2460  READ(5,1110)title
2461  titled=title
2462  270 WRITE(6,1120)title
2463  go to 10
2464  1110 FORMAT(a80)
2465  1120 FORMAT(1x,a80)
2466 C
2467 C********************************************************************
2468 C CONTROL CARD: CODEWD = OUTLEVEL
2469 C DEFINES THE AMOUNT OF OUTPUT WANTED
2470 C
2471 C WHAT(1) = IPRI DEFAULT = 0
2472 C WHAT(2) = IPEV DEFAULT = 0
2473 C WHAT(3) = IPPA DEFAULT = 0
2474 C WHAT(4) = IPCO DEFAULT = -2
2475 C WHAT(5) = INIT DEFAULT = 0
2476 C WHAT(6) = IPHKK DEFAULT = 0
2477 C
2478 C 1.0 = MINIMUM OUTPUT
2479 C 2.0 = VERY SHORT OUTPUT
2480 C 3.0 = SHORT OUTPUT
2481 C 4.0 = MEDIUM OUTPUT
2482 C 5.0 = LONG OUTPUT
2483 C 6.0 = VERY LONG OUTPUT
2484 C 7.0 = MAXIMUM OUTPUT
2485 C DEFAULT: 0.0
2486 C
2487 C********************************************************************
2488 C
2489  280 CONTINUE
2490  ipri =int(what(1))
2491  ipev =int(what(2))
2492  ippa =int(what(3))
2493  ipco =int(what(4))
2494  init =int(what(5))
2495  iphkk =int(what(6))
2496  go to 10
2497 C
2498 C********************************************************************
2499 C
2500 C CONTROL CARD: CODEWD = LEPTOEVT
2501 C STARTS THE SAMPLING OF EVENTS AND STANDARD HISTOGRAM
2502 C OUTPUT FOR NEUTRINO INTERACTIONS (lepto code)
2503 C
2504 C WHAT(1)=NUMBER OF EVENTS NCASES, DEFAULT: 1000.0
2505 C WHAT(2)= NEUTYP
2506 C 11=e- -11=e+
2507 C 12=nu-e -12=anu-e
2508 C 13=mu- -13=mu+
2509 C 14=nu-mu -14=anu-mu
2510 C
2511 C
2512 C********************************************************************
2513 C
2514  290 CONTINUE
2515  OPEN(29,file='lepto.evt',
2516  *status='UNKNOWN')
2517  nstart=4
2518 C---histogram initialization
2519  IF (ireso.EQ.1) CALL distrp(1,ijproj,ppn)
2520  IF (cmhis.EQ.0.d0) CALL distr(1,ijproj,ppn,idummy)
2521  IF (cmhis.EQ.1.d0) CALL distrc(1,ijproj,ppn,idummy)
2522  IF (cmhis.EQ.2.d0) CALL distco(1,ijproj,ppn,idummy)
2523  IF (ireso.EQ.1) CALL disres(1,nhkkh1,ppn)
2524  IF (ipadis) CALL distpa(1)
2525  IF (ioudif.EQ.1) CALL diadif(1,0)
2526 * initialization of evaporation-module
2527  WRITE(6,*)' before NUCLEAR.BIN opened LUNBER= ',lunber
2528 * initialization of evaporation-module
2529  OPEN(unit=lunber,file='NUCLEAR.BIN',status='OLD'
2530  * ,form='UNFORMATTED')
2531 C OPEN(UNIT=LUNBER,FILE='NUCLEAR.BIN',STATUS='OLD'
2532 C * ,READONLY,FORM='UNFORMATTED')
2533 C * ,FORM='UNFORMATTED')
2534  WRITE(6,*)'NUCLEAR.BIN opened LUNBER= ',lunber
2535  CALL berttp
2536  IF(ievap.EQ.1)THEN
2537  CALL incini
2538  WRITE(6,*)' NEUTRINO: after INCINI call'
2539  ENDIF
2540 C HBOOK HISTOGRAMS
2541 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2542  IF(ihbook.EQ.1.AND.cmhis.EQ.0.d0)THEN
2543  CALL plomb(1,ppnpn,char,xfxfxf,itif,ijproj)
2544  ENDIF
2545  IF(ihbook.EQ.1.AND.cmhis.EQ.1.d0)THEN
2546  CALL plombc(1,ppnpn,char,xfxfxf,itif,ijproj)
2547  ENDIF
2548 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2549 C IF(NCOUNT.EQ.1) THEN
2550 *---initialization and test of the random number generator
2551 C CALL RNDMST(12,34,56,78)
2552 C CALL RNDMTE(1)
2553 C ENDIF
2554 *---CONSISTENCY TEST FOR FERMI/PAULI OPTIONS
2555  IF(lpauli .AND. (.NOT.fermp)) THEN
2556  WRITE(6,'(/2A/A/)')
2557  + ' ACTIVATION OF PAULI PRINCIPLE ONLY REASONABLE',
2558  + ' IF FERMI ACTIVE', ' LPAULI CHANGED TO .FALSE.'
2559  lpauli=.false.
2560  ENDIF
2561  ncases=int(what(1))
2562  neutyp=int(what(2))
2563  nevnts=int(what(1))
2564  IF(nevnts.LE.0) nevnts=1000
2565  nevhad=nevnts
2566 C why 2: NEVNTS passed to DTMAI as argument, NEVHAD in COMMON
2567 C in DTP NCASES <- NEVNTS
2568  IF(ncases.LE.0) ncases=100
2569  CALL luinol
2570  CALL timdat
2571 *---INITIALIZE GLAUBER THEORY A LA SHMAKOV
2572 C change JGLAUB in dpmjet25 to JGLAUB=1 (was 2 in dpmjet241)
2573  jglaub=1
2574  CALL shmaki(ip,ipz,it,itz,rproj,rtarg,ppn)
2575 *
2576  nn=1
2577  np=1
2578  nt=1
2579 C INITIALIZE COUNTERS
2580  bnnvv=0.001
2581  bnnss=0.001
2582  bnnsv=0.001
2583  bnnvs=0.001
2584  bnncc=0.001
2585  bnndv=0.001
2586  bnnvd=0.001
2587  bnnds=0.001
2588  bnnsd=0.001
2589  bnnhh=0.001
2590  bnnzz=0.001
2591  bnndi=0.001
2592  bnnzd=0.001
2593  bnndz=0.001
2594  bptvv=0.
2595  bptss=0.
2596  bptsv=0.
2597  bptvs=0.
2598  bptcc=0.
2599  bptdv=0.
2600  bptvd=0.
2601  bptds=0.
2602  bptsd=0.
2603  bpthh=0.
2604  bptzz=0.
2605  bptdi=0.
2606  bptzd=0.
2607  bptdz=0.
2608  beevv=0.
2609  beess=0.
2610  beesv=0.
2611  beevs=0.
2612  beecc=0.
2613  beedv=0.
2614  beevd=0.
2615  beeds=0.
2616  beesd=0.
2617  beehh=0.
2618  beezz=0.
2619  beedi=0.
2620  beezd=0.
2621  beedz=0.
2622  bcouvv=0.
2623  bcouss=0.
2624  bcousv=0.
2625  bcouvs=0.
2626  bcouzz=0.
2627  bcouhh=0.
2628  bcouds=0.
2629  bcousd=0.
2630  bcoudz=0.
2631  bcouzd=0.
2632  bcoudi=0.
2633  bcoudv=0.
2634  bcouvd=0.
2635  bcoucc=0.
2636  CALL timdat
2637  WRITE(6,*)' NEUTRINO initialization finished'
2638  RETURN
2639 C
2640 C
2641 C
2642 C********************************************************************
2643 C
2644 C CONTROL CARD: CODEWD = SEASEA
2645 C DEMANDS SAMPLING OF HISTOGRAMS FROM HADRONIZED
2646 C SEA-SEA STRINGS SEPARATELY
2647 C
2648 C
2649 C WHAT(1) = 1. SAMPLING ELSE NO SAMPLING DEFAULT NO
2650 C
2651 C********************************************************************
2652 C
2653  300 CONTINUE
2654  IF (what(1).EQ.1.d0) THEN
2655  ihadss=.true.
2656  ELSE
2657  ihadss=.false.
2658  ENDIF
2659  go to 10
2660 C
2661 C********************************************************************
2662 C
2663 C CONTROL CARD: CODEWD = PARTICLE
2664 C PRINTS A TABLE OF THE PROPERTIES AND DECAYS
2665 C OF THE PARTICLES DEFINED IN DTUJET BAMJET-DECAY FRAGMENTATION
2666 C
2667 C********************************************************************
2668 C
2669  310 CONTINUE
2670  CALL ddates
2671  go to 10
2672 C
2673 C********************************************************************
2674 C
2675 C CONTROL CARD: CODEWD = ALLPART
2676 C DEMANDS SAMPLING OF HISTOGRAMS FROM COMPLETE
2677 C HADRONIZED EVENTS
2678 C
2679 C WHAT(1) = 1. SAMPLING ELSE NO SAMPLING DEFAULT 1
2680 C
2681 C********************************************************************
2682 C
2683  320 CONTINUE
2684  IF (what(1).EQ.1.d0) THEN
2685  ihada=.true.
2686  ELSE
2687  ihada=.false.
2688  ENDIF
2689  go to 10
2690 C
2691 C********************************************************************
2692 C
2693 C CONTROL CARD: CODEWD = TAUFOR
2694 C READ THE FORMATION TIME
2695 C
2696 C WHAT(1) = TAUFOR FORMATION TIME IN FERMI/C DEFAULT 105.
2697 C TAUFOR=10 CORRESPONDS ROUGHELY TO AN AVARAGE
2698 C FORMATION TIME OF 1 FM/C
2699 C WHAT(2) = KTAUGE NUMER OF GENERATIONS ALLOWED DEFAULT 0.
2700 C IN FORMATION ZONE KASKADE MAXIMUM=10
2701 C WHAT(3) = ITAUVE ITAUVE = 1 pt dependent formation zone (Default)
2702 C ITAUVE = 2 constant formation zone = TAUFOR
2703 C
2704 C********************************************************************
2705 C
2706  330 CONTINUE
2707  taufor=what(1)
2708  ktauge=what(2)
2709  itauve=1
2710  IF(what(3).NE.0.d0)itauve=what(3)
2711  go to 10
2712 C
2713 C********************************************************************
2714 C CONTROL CARD: CODEWD = SEAVAL
2715 C DEMANDS SAMPLING OF HISTOGRAMS FROM HADRONIZED
2716 C SEA-VALENCE STRINGS SEPARATELY
2717 C
2718 C
2719 C WHAT(1) = 1. SAMPLING ELSE NO SAMPLING DEFAULT NO
2720 C
2721 C********************************************************************
2722 C
2723  340 CONTINUE
2724  IF (what(1).EQ.1.d0) THEN
2725  ihadsv=.true.
2726  ELSE
2727  ihadsv=.false.
2728  ENDIF
2729  go to 10
2730 C
2731 C********************************************************************
2732 C CONTROL CARD: CODEWD = VALSEA
2733 C DEMANDS SAMPLING OF HISTOGRAMS FROM HADRONIZED
2734 C VALENCE-SEA STRINGS SEPARATELY
2735 C
2736 C WHAT(1) = 1. SAMPLING ELSE NO SAMPLING DEFAULT NO
2737 C
2738 C********************************************************************
2739 C
2740  350 CONTINUE
2741  IF (what(1).EQ.1.d0) THEN
2742  ihadvs=.true.
2743  ELSE
2744  ihadvs=.false.
2745  ENDIF
2746  go to 10
2747 C
2748 C********************************************************************
2749 C CONTROL CARD: CODEWD = MOMENTUM
2750 C DEFINES THE LAB MOMENTUM OF THE PROJECTILE
2751 C
2752 C WHAT(1) = LAB MOMENTUM IN GEV/C DEFAULT: 200.
2753 C
2754 C********************************************************************
2755  360 CONTINUE
2756  ppn=what(1)
2757  nnpp=1
2758  IF(ijproj.NE.0) nnpp=ijproj
2759  epn=sqrt(ppn**2+aam(nnpp)**2)
2760 * nucleon-nucleon cms
2761 C IBPROJ=1
2762  eproj=epn
2763  amproj=aam(nnpp)
2764  amtar=aam(1)
2765  pproj = sqrt((epn-amproj)*(epn+amproj))
2766  umo = sqrt(amproj**2 + amtar**2 + 2.*amtar*eproj)
2767  cmener=umo
2768  IF(istrut.EQ.1)THEN
2769  ptthr=2.1+0.15*(log10(cmener/50.))**3
2770  ptthr2=ptthr
2771  ELSEIF(istrut.EQ.2)THEN
2772  ptthr=2.5+0.12*(log10(cmener/50.))**3
2773  ptthr2=ptthr
2774  ENDIF
2775  gamcm = (eproj+amtar)/umo
2776  bgcm=pproj/umo
2777  ecm=umo
2778  pcm=gamcm*pproj - bgcm*eproj
2779 C
2780  print 1033, eproj,pproj,
2781  +amproj,amtar,umo,gamcm,bgcm,pcm
2782  go to 10
2783 C
2784 C********************************************************************
2785 C
2786 C CONTROL CARD: CODEWD = PAULI
2787 C MONITORING THE INCLUSION OF PAULI'S PRINCIPLE
2788 C FOR SECONDARY INTERACTIONS INSIDE THE NUCLEUS
2789 C WHAT(1) = 1. ON ELSE OFF DEFAULT OFF
2790 C WHAT(2) GT 0. VARIOUS TEST PRINTS DEFAULT: NO PRINTS
2791 C
2792 C********************************************************************
2793 C
2794  370 CONTINUE
2795  IF (what(1).EQ.1.d0) THEN
2796  lpauli=.true.
2797  ELSE
2798  lpauli=.false.
2799  ENDIF
2800  ipaupr=int(what(2))
2801  go to 10
2802 C
2803 C********************************************************************
2804 C CONTROL CARD: CODEWD = PROJKASK
2805 C DEMANDS THE FORMATION ZONE CASCADE IN THE PROJECTILE NUCLEUS
2806 C
2807 C WHAT(1) = IPROJK DEFAULT: 1
2808 C 0 = NO CASCADE
2809 C 1 = CASCADE
2810 C********************************************************************
2811 C
2812  380 CONTINUE
2813  iprojk=what(1)
2814  go to 10
2815 C
2816 C********************************************************************
2817 C CONTROL CARD: CODEWD = CENTRAL
2818 C
2819 C DEMANDS CENTRAL NUCLEUS-NUCLEUS COLLISIONS
2820 C
2821 C WHAT(1) = ICENTR DEFAULT: 0
2822 C 0 = NORMAL PRODUCTION
2823 C 1 = CENTRAL PRODUCTION (impact parameter condition
2824 C in dpm25nuc7.f and NA
2825 C condition in dpm25nuc2.f)
2826 C 2 = DIFFERENT CENTRAL PRODUCTION (Only NA
2827 C condition in dpm25nuc2.f)
2828 C 3 = DIFFERENT CENTRAL PRODUCTION (Only NA
2829 C condition in dpm25nuc2.f)
2830 C Less central for Pb-Pb than 2
2831 C 10 = PERIPHERAL PRODUCTION
2832 C********************************************************************
2833 C
2834  390 CONTINUE
2835  icentr=what(1)
2836  go to 10
2837 C
2838 C********************************************************************
2839 C CONTROL CARD: CODEWD = SEADISTR
2840 C REDEFINES THE SEA DISTRIBUTIONS
2841 C
2842 C WHAT(1) = XSEACO DEFAULT: 1.
2843 C SEA(X)=1/X**XSEACO
2844 C WHAT(2) = UNON DEFAULT: 3.5
2845 C WHAT(3) = UNOM DEFAULT: 1.11
2846 C WHAT(4) = UNOSEA DEFAULT: 5.0
2847 C QDIS(X) PROP. (1-X)**UNO...
2848 C
2849 C********************************************************************
2850 C
2851  400 CONTINUE
2852  xseaco=what(1)
2853  xseacu=1.05-xseaco
2854  unon=what(2)
2855  IF(unon.LT.0.1d0) unon=2.0
2856  unom=what(3)
2857  IF(unom.LT.0.1d0) unom=1.5
2858  unosea=what(4)
2859  IF(unosea.LT.0.1d0) unosea=2.0
2860  go to 10
2861 C
2862 C********************************************************************
2863 C
2864 C CONTROL CARD: CODEWD = CMHISTO
2865 C events in COMMON/HKKEVT/ are defined in the nucleon-nucleon cms
2866 C (to calculate HISTOGRAMS IN THE CMS)
2867 C NOTE: if CMHIS=1.0 no treatment of formation zone cascade
2868 C if CMHIS=0.0 formation zone cascade can be demanded,
2869 C see TAUFOR
2870 C
2871 C WHAT(1) = CMHIS DEFAULT: 0.
2872 C
2873 C********************************************************************
2874 C
2875  410 CONTINUE
2876  cmhis=what(1)
2877  go to 10
2878 C********************************************************************
2879 C
2880 C CONTROL CARD: CODEWD = SIGTEST
2881 C REQUIRES A TEST PRINT OF CROSS SECTION AS APPLIED IN THE PROGRAM
2882 C
2883 C********************************************************************
2884 C
2885  420 CONTINUE
2886  CALL sigtes
2887  go to 10
2888 C
2889 C********************************************************************
2890 C
2891 C CONTROL CARD: CODEWD = XCUTS
2892 C
2893 C WHAT(1) = CVQ
2894 C WHAT(2) = CDQ
2895 C WHAT(3) = CSEA
2896 C WHAT(4) = SSMIMA
2897 C WHAT(5) = XXVTHR
2898 C
2899 C MINIMUM ALLOWED X-VALUES = CXXX/SQRT(S)
2900 C
2901 C********************************************************************
2902 C
2903  430 CONTINUE
2904  cvq=what(1)
2905  IF(cvq.LT.0.5d0) cvq=1.0
2906  cdq=what(2)
2907  IF(cdq.LT.1.0d0) cdq=2.0
2908  csea=what(3)
2909  IF(csea.LT.0.1d0) csea =0.1
2910  ssmima=what(4)
2911  IF(ssmima.LT.0.0d0) ssmima=0.14
2912  ssmimq=ssmima**2
2913  IF(what(5).GT.2.0d0) vvmthr=what(5)
2914  go to 10
2915 C
2916 C********************************************************************
2917 C
2918 C CONTROL CARD: CODEWD = HADRIN
2919 C TEST OPTION - DEFINES THE TYPE OF INTERACTION
2920 C GENERATED BY HADRIN
2921 C
2922 C WHAT(1) = 0. : ELASTIC/INELASTIC AS MONITORED BY FOZOKL
2923 C = 1. : ONLY INELASTIC INTERACTIONS
2924 C = 2. : ONLY ELASTIC INTERACTIONS
2925 C WHAT(2)
2926 C
2927 C********************************************************************
2928 C
2929  440 CONTINUE
2930  inthad=int(what(1))
2931  IF(inthad.LT.0 .OR. inthad.GT.2) inthad=0
2932  IF(inthad.EQ.1) WRITE(6,'(/5X,A/)')
2933  +' FHAD: INELASTIC INTERACTION FORCED'
2934  IF(inthad.EQ.2) WRITE(6,'(/5X,A/)')
2935  +' FHAD: ELASTIC INTERACTION FORCED'
2936  go to 10
2937 C
2938 C********************************************************************
2939 C
2940 C CONTROL CARD: CODEWD = FACTOMOM
2941 C DEMANDS THE CALCULATION OF FACTORIAL MOMENTSN
2942 C
2943 C WHAT(1) = IFACTO =1 Factorial moments calculated DEFAULT 0
2944 C
2945 C********************************************************************
2946 C
2947  450 CONTINUE
2948  ifacto=what(1)
2949  go to 10
2950 C
2951 C********************************************************************
2952 C
2953 C
2954 C CONTROL CARD: CODEWD = COULOMB
2955 C TO DEMAND COULOMB ENERGY FOR ICOUL=1
2956 C
2957 C WHAT(1) = ICOUL DEFAULT=0
2958 C WHAT(2)
2959 C WHAT(3)
2960 C
2961 C
2962 C********************************************************************
2963 C
2964  460 CONTINUE
2965  icoul=int(what(1))
2966  icoull=int(what(1))
2967  go to 10
2968 C
2969 C********************************************************************
2970 C
2971 C CONTROL CARD: CODEWD = GLAUBERI
2972 C
2973 C WHAT(1) = JGLAUB default:1
2974 C change JGLAUB in dpmjet25 to JGLAUB=1 (was 2 in dpmjet241)
2975 C JGLAUB = 1 prepare GLAUBTAR.DAT file
2976 C
2977 C Test Glauber and output file for impact parameter selectiom
2978 C presently written for hadron-nucleus interactions
2979 C
2980 C Actually 2000 events are used for initialization in SHMAKI
2981 C this is sufficient for most purposes, if not change NSTATB
2982 C in SHMAKI
2983 C
2984 C********************************************************************
2985 C
2986  470 CONTINUE
2987  IF(what(1).NE.0.d0)jglaub=what(1)
2988 C CALL RNDMST(12,34,56,78)
2989 C CALL RNDMTE(1)
2990  ip=1.
2991  ipz=1.
2992  jp=1.
2993  jpz=1.
2994  Write(47,473)ip,ipz,it,itz
2995  473 FORMAT(' NUCLEUS ',4i10)
2996  ijproj=1
2997  ijprox=1
2998  ip=1
2999  ipz=1
3000  jjproj=1
3001  jjprox=1
3002  jp=1
3003  jpz=1
3004  ishc=0
3005  wu10=sqrt(10.)
3006  DO 471 ig=1,24
3007  ppn=wu10**(ig+1)
3008  CALL shmaki(ip,ipz,it,itz,rproj,rtarg,ppn)
3009  ishc=ishc+1
3010  IF(ishc.EQ.1)THEN
3011  WRITE(47,'(4F10.5)') bmax,bstep,rproj,rtarg
3012  ENDIF
3013  WRITE(47,'(5E16.8)') (bsite(1,ib),ib=1,200)
3014  471 CONTINUE
3015  ijproj=13
3016  ijprox=13
3017  jjproj=13
3018  jjprox=13
3019  DO 472 ig=1,24
3020  ppn=wu10**(ig+1)
3021  CALL shmaki(ip,ipz,it,itz,rproj,rtarg,ppn)
3022  WRITE(47,'(5E16.8)') (bsite(1,ib),ib=1,200)
3023  472 CONTINUE
3024  go to 10
3025 C
3026 C********************************************************************
3027 C
3028 C CONTROL CARD: CODEWD = EDENSITY
3029 C Calculate energy density for IEDEN=1
3030 C before resonance decay
3031 C Please note, that this option is inconsistent
3032 C with the formation zone cascade!
3033 C
3034 C WHAT(1) = IEDEN DEFAULT=0
3035 C WHAT(2)
3036 C
3037 C********************************************************************
3038 C
3039  480 CONTINUE
3040  ieden=what(1)
3041  go to 10
3042 C
3043 C********************************************************************
3044 C
3045 C CONTROL CARD: CODEWD = CMENERGY
3046 C Input of nucleon-nucleon cms energy
3047 C
3048 C WHAT(1) = CMENER = SQRT(s)
3049 C WHAT(2)
3050 C
3051 C********************************************************************
3052 C
3053  490 CONTINUE
3054  cmener=what(1)
3055  IF(istrut.EQ.1)THEN
3056  ptthr=2.1+0.15*(log10(cmener/50.))**3
3057  ptthr2=ptthr
3058  ELSEIF(istrut.EQ.2)THEN
3059  ptthr=2.5+0.12*(log10(cmener/50.))**3
3060  ptthr2=ptthr
3061  ENDIF
3062  s=cmener**2
3063  umo=cmener
3064  nnpp=1
3065  idp=nnpp
3066  IF(ijproj.NE.0) nnpp=ijproj
3067  epn=(cmener**2 + aam(nnpp)**2 - aam(1)**2)/(2.*aam(1))
3068  ppn=sqrt((epn-aam(nnpp))*(epn+aam(nnpp)))
3069  ecm = sqrt(aam(idp)**2+aam(1)**2+2.0d0*aam(1)*epn)
3070  cmener=ecm
3071  s=cmener**2
3072  umo=cmener
3073  amproj=aam(nnpp)
3074  pproj = sqrt((epn-amproj)*(epn+amproj))
3075  eproj=sqrt(pproj**2+amproj**2)
3076  eproj = epn
3077  pproj = ppn
3078  amtar=aam(1)
3079  gamcm = (eproj+amtar)/umo
3080  bgcm=pproj/umo
3081  gamcm = (eproj+aam(1))/umo
3082  bgcm = pproj/umo
3083  pcm=gamcm*pproj - bgcm*eproj
3084  print 1033, eproj,pproj,
3085  +amproj,amtar,umo,gamcm,bgcm,pcm
3086 C COMMON /NNCMS/ GAMCM,BGCM,UMO,PCM,EPROJ,PPROJ
3087  go to 10
3088 C
3089 C********************************************************************
3090 C
3091 C CONTROL CARD: CODEWD = INFOREJEC
3092 C Option to combine q-aq to color ropes
3093 C
3094 C WHAT(1) = 0 : no rejection diagnostics IFREJ=0
3095 C 1 : rejection diagnostics DEFAULT:IFREJ= 0
3096 C
3097 C********************************************************************
3098 C
3099  500 CONTINUE
3100  ifrej=what(1)
3101  go to 10
3102 C
3103 C********************************************************************
3104 C
3105 C
3106 C********************************************************************
3107 C
3108 C CONTROL CARD: CODEWD = RECOMBIN
3109 C Option to s-s and v-v chains to s-v and v-s chains
3110 C
3111 C WHAT(1) = 0 : no recombination
3112 C 1 : recombination DEFAULT: 0
3113 C
3114 C********************************************************************
3115 C
3116  510 CONTINUE
3117  IF (what(1).EQ.1.d0) irecom=1
3118  IF (what(1).NE.1.d0) irecom=0
3119  IF (what(1).EQ.1.d0) lseadi=.true.
3120  go to 10
3121 C ********************************************************************
3122 C parameter card: CODEWD = SINGDIFF
3123 C Calls or supresses single diffractive events
3124 C
3125 C WHAT(1)=ISINGD = 0 Single diffraction supressed default: 0.
3126 C = 1 Single diffraction included
3127 C = 2 Only single Diffraction
3128 C = 3 Only single Diffraction Target excited
3129 C = 4 Only single Diffraction Projectile excited
3130 C = 5 Only single Diffraction HMSD Target excited
3131 C = 6 Only single Diffraction HMSD Projectile excited
3132 C = 7 Only single Diffraction LMSD Target excited
3133 C = 8 Only single Diffraction LMSD Projectile excited
3134 C
3135 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3136 *
3137  520 CONTINUE
3138  isingd = what(1)
3139  isingx = what(1)
3140  go to 10
3141 *
3142 C********************************************************************
3143 C
3144 C CONTROL CARD: CODEWD = NOFINALE
3145 C
3146 C WHAT(1) = 1 : no FINALE call
3147 C WHAT(1) = 0 : FINALE call
3148 C DEFAULT: 0
3149 C
3150 C********************************************************************
3151 C
3152  530 CONTINUE
3153  IF (what(1).EQ.1.d0) ifinal=1
3154  IF (what(1).EQ.0.d0) ifinal=0
3155  go to 10
3156 C
3157 *
3158 C********************************************************************
3159 C
3160 C CONTROL CARD: CODEWD = SEASU3
3161 C
3162 C WHAT(1) = SEASQ
3163 C DEFAULT: 0.5
3164 C
3165 C********************************************************************
3166 C
3167  535 CONTINUE
3168  seasq=what(1)
3169  go to 10
3170 C
3171 *
3172 C********************************************************************
3173 C
3174 C CONTROL CARD: CODEWD = CRONINPT
3175 C
3176 C WHAT(1) = MKCRON
3177 C DEFAULT: 1.
3178 C WHAT(2) = CRONCO
3179 C DEFAULT: 0.64
3180 C
3181 C********************************************************************
3182 C
3183  538 CONTINUE
3184  mkcron=what(1)
3185  cronco=what(2)
3186  go to 10
3187 C
3188 *
3189 C********************************************************************
3190 C
3191 C CONTROL CARD: CODEWD = POPCORN
3192 C
3193 C WHAT(1) = PDB DEFAULT: 0.10
3194 C JETSET fragmenting directly into baryons
3195 C
3196 C WHAT(2) = AJSDEF DEFAULT=0.
3197 C AJSDEF=1. SETS default values for all jetset
3198 C parameters
3199 C
3200 C********************************************************************
3201 C
3202  539 CONTINUE
3203  pdb=what(1)
3204  IF(what(2).NE.0.d0)ajsdef=what(2)
3205  go to 10
3206 C******************************************************************
3207 C CONTROLCARD: CODEW = FLUCTUAT
3208 C Introduces cross section fluctuations
3209 C a la Frankfurt and Strikman
3210 C
3211 C WHAT(1) = IFLUCT default:0
3212 C Fluctuations for IFLUCT=1
3213 C
3214 C*****************************************************************
3215 C
3216  541 CONTINUE
3217  ifluct=what(1)
3218  IF(ifluct.EQ.1)CALL fluini
3219  go to 10
3220 C******************************************************************
3221 C CONTROLCARD: CODEW = DIQUARKS
3222 C WHAT(1) = IDIQUA Glauber diquarks default:1
3223 C WHAT(2) = IDIQUU unitary diquarks default:1
3224 C WHAT(3) = AMEDD default:0.9D0
3225 C
3226 C*****************************************************************
3227 C
3228  542 CONTINUE
3229  idiqua=what(1)
3230  idiquu=what(2)
3231  IF(what(3).GT.0.d0)THEN
3232  amedd=what(3)
3233  ENDIF
3234  go to 10
3235 C******************************************************************
3236 C CONTROLCARD: CODEW = HBOOKHIS
3237 C
3238 C Serves to switch off HBOOK Histograms
3239 C
3240 C WHAT(1) = IHBOOK default:1
3241 C
3242 C*****************************************************************
3243 C
3244  543 CONTINUE
3245  ihbook=what(1)
3246  go to 10
3247 C
3248 C********************************************************************
3249 C
3250 C CONTROL CARD: CODEWD = GLAUBERA
3251 C
3252 C WHAT(1) = JGLAUB default:1
3253 C change JGLAUB in dpmjet25 to JGLAUB=1 (was 2 in dpmjet241)
3254 C JGLAUB = 1 prepare GLAUBTAR.DAT file
3255 C
3256 C Test Glauber and output file for impact parameter selectiom
3257 C presently written for nucleus-nucleus interactions
3258 C
3259 C Actually 2000 events are used for initialization in SHMAKI
3260 C this is sufficient for most purposes, if not change NSTATB
3261 C in SHMAKI
3262 C
3263 C********************************************************************
3264 C
3265  544 CONTINUE
3266  IF(what(1).NE.0.d0)jglaub=what(1)
3267 C CALL RNDMST(12,34,56,78)
3268 C CALL RNDMTE(1)
3269  Write(47,1473)ip,ipz,it,itz
3270  1473 FORMAT(' NUCLEUS ',4i10)
3271  ijproj=1
3272  ijprox=1
3273  jjproj=1
3274  jjprox=1
3275  ishc=0
3276  wu10=sqrt(10.)
3277  DO 1471 ig=1,24
3278  ppn=wu10**(ig+1)
3279  CALL shmaki(ip,ipz,it,itz,rproj,rtarg,ppn)
3280  ishc=ishc+1
3281  IF(ishc.EQ.1)THEN
3282  WRITE(47,'(4F10.5)') bmax,bstep,rproj,rtarg
3283  ENDIF
3284  WRITE(47,'(5E16.8)') (bsite(1,ib),ib=1,200)
3285  1471 CONTINUE
3286  ijproj=13
3287  ijprox=13
3288  jjproj=13
3289  jjprox=13
3290  DO 1472 ig=1,24
3291  ppn=wu10**(ig+1)
3292  CALL shmaki(ip,ipz,it,itz,rproj,rtarg,ppn)
3293  WRITE(47,'(5E16.8)') (bsite(1,ib),ib=1,200)
3294  1472 CONTINUE
3295  go to 10
3296 C
3297 C******************************************************************
3298 C CONTROLCARD: CODEW =POMTABLE
3299 C
3300 C WHAT(1)=IPOMTA DEFAULT:0.
3301 c IPOMTA=0 PMERON TABLES FOR 20 ENERGIES
3302 C CALCULATED AND WRITTEN TO
3303 C filE pomtab.dat
3304 C IPOMTA=1 POMERON TABLES READ FROM
3305 C pomtab.dat
3306 C
3307 C*****************************************************************
3308 C
3309  545 CONTINUE
3310  ipomta=what(1)
3311  go to 10
3312 C******************************************************************
3313 C CONTROLCARD: CODEW = SINGLECH
3314 C include Regge contributions (single Chains)
3315 C
3316 C WHAT(1)=ISICHA Default:0
3317 C ISICHA=1: Single chains included
3318 C
3319 C*****************************************************************
3320 C
3321  551 CONTINUE
3322  isicha=what(1)
3323  go to 10
3324 C******************************************************************
3325 C CONTROLCARD: CODEW =HADRINTH
3326 C
3327 C WHAT(1) = EHADTH Default: 5.
3328 C
3329 C*****************************************************************
3330 C
3331  552 CONTINUE
3332  ehadth=what(1)
3333  WRITE(6,'(A,F10.2)')' Threshold for HADRIN events = (GeV)',
3334  * ehadth
3335  go to 10
3336 C******************************************************************
3337 C CONTROLCARD: CODEW =EVAPORAT
3338 C
3339 C These were the options before May 1995:
3340 C
3341 C evaporation module
3342 C
3343 C what (1) >= 1 ==> evaporation is performed
3344 C if what (1) >= 10 then the high energy fis-
3345 C sion module is invoked and what(1)-10 is used
3346 C according to the previous table
3347 C what (2) =< -1 ==> deexcitation gammas are not produced
3348 C (if the evaporation step is not performed
3349 C they are never produced)
3350 C
3351 C
3352 C*****************************************************************
3353 C
3354 *======================================================================*
3355 * May 95: *
3356 * For the "evap" model: *
3357 * *
3358 * Evaporation is performed if the EVAPORAT card is present
3359 * Default:No evaporatiom
3360 *
3361 * what (1) = i1 + i2*10 + i3*100 + i4*10000
3362 * (i1, i2, i3, i4 >= 0 ) *
3363 * i1 is the flag for selecting the T=0 level *
3364 * density option used *
3365 * i1 = 1: standard EVAP level densities with Cook *
3366 * pairing energies *
3367 * = 2: Z,N-dependent Gilbert & Cameron level *
3368 * densities (default) *
3369 * = 3: Julich A-dependent level densities *
3370 * = 4: Z,N-dependent Brancazio & Cameron level *
3371 * densities *
3372 * i2 >= 1: high energy fission activated (default *
3373 * high energy fission activated) *
3374 * i3 = 0: No energy dependence for level densities *
3375 * = 1: Standard Ignyatuk (1975, 1st) energy de- *
3376 * pendence for level densities (default) *
3377 * = 2: Standard Ignyatuk (1975, 1st) energy de- *
3378 * pendence for level densities with NOT used*
3379 * set of parameters *
3380 * = 3: Standard Ignyatuk (1975, 1st) energy de- *
3381 * pendence for level densities with NOT used*
3382 * set of parameters *
3383 * = 4: Second Ignyatuk (1975, 2nd) energy de- *
3384 * pendence for level densities *
3385 * = 5: Second Ignyatuk (1975, 2nd) energy de- *
3386 * pendence for level densities with fit 1 *
3387 * Iljinov & Mebel set of parameters *
3388 * = 6: Second Ignyatuk (1975, 2nd) energy de- *
3389 * pendence for level densities with fit 2 *
3390 * Iljinov & Mebel set of parameters *
3391 * = 7: Second Ignyatuk (1975, 2nd) energy de- *
3392 * pendence for level densities with fit 3 *
3393 * Iljinov & Mebel set of parameters *
3394 * = 8: Second Ignyatuk (1975, 2nd) energy de- *
3395 * pendence for level densities with fit 4 *
3396 * Iljinov & Mebel set of parameters *
3397 * i4 >= 1: Original Gilbert and Cameron pairing ener-*
3398 * gies used (default Cook's modified pairing*
3399 * energies) *
3400 * what (2) = ig + 10 * if (ig and if must have the same *
3401 * sign) *
3402 * ig =< -1 ==> deexcitation gammas are not produced *
3403 * (if the evaporation step is not performed *
3404 * they are never produced) *
3405 * if =< -1 ==> Fermi Break Up is not invoked *
3406 * (if the evaporation step is not performed *
3407 * it is never invoked) *
3408 * The default is: deexcitation gamma produced *
3409 * and Fermi break up activated for the new *
3410 * preequilibrium, not activated otherwise. *
3411 * what (3) >= 1 ==> "heavies" put on their own stack *
3412 * *
3413 *======================================================================*
3414 *
3415  553 CONTINUE
3416  whtsav = what(1)
3417  IF ( nint(what(1)) .GE. 10000 ) THEN
3418  llvmod = .false.
3419  jlvhlp = nint(what(1)) / 10000
3420  what(1) = what(1) - 10000.d+00 * jlvhlp
3421  END IF
3422  IF ( nint(what(1)) .GE. 100 ) THEN
3423  jlvmod = nint(what(1)) / 100
3424  what(1) = what(1) - 100.d+00 * jlvmod
3425  END IF
3426  IF ( nint(what(1)) .GE. 10 ) THEN
3427  ifiss = 1
3428  jlvhlp = nint(what(1)) / 10
3429  what(1) = what(1) - 10.d+00 * jlvhlp
3430  ELSE IF ( nint(whtsav) .NE. 0 ) THEN
3431  ifiss = 0
3432  END IF
3433  IF ( nint(what(1)) .GE. 0 ) THEN
3434  levprt = .true.
3435  ilvmod = nint(what(1))
3436  IF ( abs(nint(what(2))) .GE. 10 ) THEN
3437  lfrmbk = .true.
3438  jlvhlp = nint(what(2)) / 10
3439  what(2) = what(2) - 10.d+00 * jlvhlp
3440  ELSE IF ( nint(what(2)) .NE. 0 ) THEN
3441  lfrmbk = .false.
3442  END IF
3443  IF ( nint(what(2)) .GE. 0 ) THEN
3444  ldeexg = .true.
3445  ELSE
3446  ldeexg = .false.
3447  END IF
3448  IF ( nint(what(3)) .GE. 1 ) THEN
3449  lheavy = .true.
3450  ELSE
3451  lheavy = .false.
3452  END IF
3453  ELSE
3454  levprt = .false.
3455  ldeexg = .false.
3456  lheavy = .false.
3457  END IF
3458 C--------------------------------------------------------------
3459 C--------------------------------------------------------------
3460 C--------------------------------------------------------------
3461  IF(what(1).EQ.0.)THEN
3462  ievap=0
3463  levprt = .false.
3464  ilvmod = 1
3465  ldeexg = .false.
3466  lheavy = .false.
3467  lfrmbk = .false.
3468  ifiss = 0
3469  go to 10
3470  ENDIF
3471  ievap=1
3472 * set default if EVAP requested without "what-values"
3473  levprt = .true.
3474  ilvmod = 1
3475  ldeexg = .true.
3476  lheavy = .true.
3477  lfrmbk = .false.
3478  lfrmbk = .true.
3479  ifiss = 0
3480 * check if fission is requested
3481  IF ( nint(what(1)) .GE. 10 ) THEN
3482  ifiss = 1
3483  what(1) = what(1) - 10.d+00
3484  END IF
3485 * get level density treatment
3486  IF ( nint(what(1)) .GE. 1 ) ilvmod = nint(what(1))
3487 * switch off deexcitation gammas
3488  IF ( nint(what(2)) .LT. 0 ) ldeexg = .false.
3489 * check if heavy recoil treatment is requested
3490 *sr 31.1.95: since heavy fragments are always included this is obsolete
3491 C IF ( NINT (WHAT(3)) .GE. 1 ) LHEAVY = .TRUE.
3492 
3493  go to 10
3494 C******************************************************************
3495 C CONTROLCARD: CODEW = SEAQUARK
3496 C
3497 C SEAQX=WHAT(1) Default:0.5
3498 C SEAQXN=WHAT(2) Default:0.5
3499 C
3500 C*****************************************************************
3501 C
3502  554 CONTINUE
3503  seaqx=what(1)
3504  seaqxn=what(2)
3505  go to 10
3506 C******************************************************************
3507 C CONTROLCARD: CODEW = SECINTER
3508 C
3509 C Controls secondary interaction of final state
3510 C particles of type pi + N ---> K + Hyperon
3511 C
3512 C WHAT(1) = ISECIN Default 0
3513 C
3514 C ISECIN=1 demands these secondary interactions
3515 C
3516 C*****************************************************************
3517 C
3518  555 CONTINUE
3519  isecin=what(1)
3520  go to 10
3521 C******************************************************************
3522 C CONTROLCARD: CODEW =POPCORCK
3523 C
3524 C Capella-Kopeliovich POPCORN effect
3525 C
3526 C WHAT(1)= IJPOCK Default 0
3527 C WHAT(2)= PDBCK Default 0.0
3528 C
3529 C*****************************************************************
3530 C
3531  556 CONTINUE
3532  ijpock=what(1)
3533  pdbck=what(2)
3534  go to 10
3535 C******************************************************************
3536 C CONTROLCARD: CODEW =CASADIQU
3537 C
3538 C Casado sea diquarks
3539 C
3540 C WHAT(1)= ICASAD default : 1
3541 C WHAT(2)= CASAXX default : 0.5
3542 C
3543 C
3544 C*****************************************************************
3545 C
3546  557 CONTINUE
3547  icasad=what(1)
3548  IF(what(2).GE.0.1d0)THEN
3549  casaxx=what(2)
3550  ENDIF
3551  go to 10
3552 C******************************************************************
3553 C CONTROLCARD: CODEW =POPCORSE
3554 C
3555 C Diquark breaking POPCORN Sea-effect
3556 C
3557 C WHAT(1)= PDBSE Default 0.45
3558 C WHAT(2)= PDBSEU Default 0.45
3559 C
3560 C
3561 C*****************************************************************
3562 C
3563  558 CONTINUE
3564  pdbse=what(1)
3565  pdbseu=what(2)
3566  go to 10
3567 C
3568 C********************************************************************
3569 C CONTROL CARD: CODEWD = NEUTRINO
3570 C STARTS THE SAMPLING OF EVENTS AND STANDARD HISTOGRAM
3571 C OUTPUT FOR NEUTRINO INTERACTIONS (qel code)
3572 C
3573 C WHAT(1)=NUMBER OF EVENTS NCASES, DEFAULT: 1000.0
3574 C WHAT(2)= NEUTYP
3575 C (1=nu-2, 2=anu-e, 3=nu-mu, 4=anu-mu, 5=nu-tau, 6=anu-tau)
3576 C WHAT(3)= NEUDEC DEFAULT: 0
3577 C Tau lepton decays into mu... for NEUDEC=1
3578 C Tau lepton decays into e... for NEUDEC=2
3579 C decays not for NEUDEC=0
3580 C NEUDEC=10 call Gen_Delta CC events on p and n
3581 C NEUDEC=11 call Gen_Delta NC events on p and n
3582 C NEUDEC=20 call FILENU to read nu-N interactions
3583 C from a file (each event with different energy)
3584 C
3585 C********************************************************************
3586 C
3587  559 CONTINUE
3588 
3589  OPEN(29,file='qel.evt',
3590  *status='UNKNOWN')
3591  nstart=2
3592 C---histogram initialization
3593  IF (ireso.EQ.1) CALL distrp(1,ijproj,ppn)
3594  IF (cmhis.EQ.0.d0) CALL distr(1,ijproj,ppn,idummy)
3595  IF (cmhis.EQ.1.d0) CALL distrc(1,ijproj,ppn,idummy)
3596  IF (cmhis.EQ.2.d0) CALL distco(1,ijproj,ppn,idummy)
3597  IF (ireso.EQ.1) CALL disres(1,nhkkh1,ppn)
3598  IF (ipadis) CALL distpa(1)
3599  IF (ioudif.EQ.1) CALL diadif(1,0)
3600 * initialization of evaporation-module
3601  WRITE(6,*)' before NUCLEAR.BIN opened LUNBER= ',lunber
3602 * initialization of evaporation-module
3603  OPEN(unit=lunber,file='NUCLEAR.BIN',status='OLD'
3604  * ,form='UNFORMATTED')
3605 C OPEN(UNIT=LUNBER,FILE='NUCLEAR.BIN',STATUS='OLD'
3606 C * ,READONLY,FORM='UNFORMATTED')
3607 C * ,FORM='UNFORMATTED')
3608  WRITE(6,*)'NUCLEAR.BIN opened LUNBER= ',lunber
3609  CALL berttp
3610  IF(ievap.EQ.1)THEN
3611 C CALL ZEROIN
3612 C OPEN(UNIT=LUNBER,FILE='NUCLEAR.BIN',STATUS='OLD'
3613 C * ,READONLY,FORM='UNFORMATTED')
3614 C CALL BERTTP
3615  CALL incini
3616  WRITE(6,*)' NEUTRINO: after INCINI call'
3617  ENDIF
3618 C HBOOK HISTOGRAMS
3619 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3620  IF(ihbook.EQ.1.AND.cmhis.EQ.0.d0)THEN
3621  CALL plomb(1,ppnpn,char,xfxfxf,itif,ijproj)
3622  ENDIF
3623  IF(ihbook.EQ.1.AND.cmhis.EQ.1.d0)THEN
3624  CALL plombc(1,ppnpn,char,xfxfxf,itif,ijproj)
3625  ENDIF
3626 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3627 C IF(NCOUNT.EQ.1) THEN
3628 *---initialization and test of the random number generator
3629 C CALL RNDMST(12,34,56,78)
3630 C CALL RNDMTE(1)
3631 C ENDIF
3632 *---CONSISTENCY TEST FOR FERMI/PAULI OPTIONS
3633  IF(lpauli .AND. (.NOT.fermp)) THEN
3634  WRITE(6,'(/2A/A/)')
3635  + ' ACTIVATION OF PAULI PRINCIPLE ONLY REASONABLE',
3636  + ' IF FERMI ACTIVE', ' LPAULI CHANGED TO .FALSE.'
3637  lpauli=.false.
3638  ENDIF
3639  ncases=int(what(1))
3640  neutyp=int(what(2))
3641  neudec=int(what(3))
3642  nevnts=int(what(1))
3643  IF(nevnts.LE.0) nevnts=1000
3644  nevhad=nevnts
3645 C why 2: NEVNTS passed to DTMAI as argument, NEVHAD in COMMON
3646 C in DTP NCASES <- NEVNTS
3647  IF(ncases.LE.0) ncases=100
3648  CALL timdat
3649 *---INITIALIZE GLAUBER THEORY A LA SHMAKOV
3650 C change JGLAUB in dpmjet25 to JGLAUB=1 (was 2 in dpmjet241)
3651  jglaub=1
3652  CALL shmaki(ip,ipz,it,itz,rproj,rtarg,ppn)
3653 *
3654  nn=1
3655  np=1
3656  nt=1
3657 C INITIALIZE COUNTERS
3658  bnnvv=0.001
3659  bnnss=0.001
3660  bnnsv=0.001
3661  bnnvs=0.001
3662  bnncc=0.001
3663  bnndv=0.001
3664  bnnvd=0.001
3665  bnnds=0.001
3666  bnnsd=0.001
3667  bnnhh=0.001
3668  bnnzz=0.001
3669  bnndi=0.001
3670  bnnzd=0.001
3671  bnndz=0.001
3672  bptvv=0.
3673  bptss=0.
3674  bptsv=0.
3675  bptvs=0.
3676  bptcc=0.
3677  bptdv=0.
3678  bptvd=0.
3679  bptds=0.
3680  bptsd=0.
3681  bpthh=0.
3682  bptzz=0.
3683  bptdi=0.
3684  bptzd=0.
3685  bptdz=0.
3686  beevv=0.
3687  beess=0.
3688  beesv=0.
3689  beevs=0.
3690  beecc=0.
3691  beedv=0.
3692  beevd=0.
3693  beeds=0.
3694  beesd=0.
3695  beehh=0.
3696  beezz=0.
3697  beedi=0.
3698  beezd=0.
3699  beedz=0.
3700  bcouvv=0.
3701  bcouss=0.
3702  bcousv=0.
3703  bcouvs=0.
3704  bcouzz=0.
3705  bcouhh=0.
3706  bcouds=0.
3707  bcousd=0.
3708  bcoudz=0.
3709  bcouzd=0.
3710  bcoudi=0.
3711  bcoudv=0.
3712  bcouvd=0.
3713  bcoucc=0.
3714  CALL timdat
3715  WRITE(6,*)' NEUTRINO initialization finished'
3716  RETURN
3717 C
3718 C
3719 C********************************************************************
3720 C CONTROL CARD: CODEWD = DIFFNUC
3721 C STARTS THE SAMPLING OF EVENTS AND STANDARD HISTOGRAM
3722 C OUTPUT FOR NEUTRINO INTERACTIONS
3723 C
3724 C WHAT(1)=NUMBER OF EVENTS NCASES, DEFAULT: 1000.0
3725 C
3726 C********************************************************************
3727 C
3728  560 CONTINUE
3729  OPEN(29,file='diffnuc.evt',
3730  *status='UNKNOWN')
3731  nstart=3
3732 C---histogram initialization
3733  IF (ireso.EQ.1) CALL distrp(1,ijproj,ppn)
3734  IF (cmhis.EQ.0.d0) CALL distr(1,ijproj,ppn,idummy)
3735  IF (cmhis.EQ.1.d0) CALL distrc(1,ijproj,ppn,idummy)
3736  IF (cmhis.EQ.2.d0) CALL distco(1,ijproj,ppn,idummy)
3737  IF (ireso.EQ.1) CALL disres(1,nhkkh1,ppn)
3738  IF (ipadis) CALL distpa(1)
3739  IF (ioudif.EQ.1) CALL diadif(1,0)
3740 * initialization of evaporation-module
3741  WRITE(6,*)' before NUCLEAR.BIN opened LUNBER= ',lunber
3742 * initialization of evaporation-module
3743  OPEN(unit=lunber,file='NUCLEAR.BIN',status='OLD'
3744  * ,form='UNFORMATTED')
3745 C OPEN(UNIT=LUNBER,FILE='NUCLEAR.BIN',STATUS='OLD'
3746 C * ,READONLY,FORM='UNFORMATTED')
3747 C * ,FORM='UNFORMATTED')
3748  WRITE(6,*)'NUCLEAR.BIN opened LUNBER= ',lunber
3749  CALL berttp
3750  IF(ievap.EQ.1)THEN
3751 C CALL ZEROIN
3752 C OPEN(UNIT=LUNBER,FILE='NUCLEAR.BIN',STATUS='OLD'
3753 C * ,READONLY,FORM='UNFORMATTED')
3754 C CALL BERTTP
3755  CALL incini
3756  ENDIF
3757 C HBOOK HISTOGRAMS
3758 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3759  IF(ihbook.EQ.1.AND.cmhis.EQ.0.d0)THEN
3760  CALL plomb(1,ppnpn,char,xfxfxf,itif,ijproj)
3761  ENDIF
3762  IF(ihbook.EQ.1.AND.cmhis.EQ.1.d0)THEN
3763  CALL plombc(1,ppnpn,char,xfxfxf,itif,ijproj)
3764  ENDIF
3765 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3766 C IF(NCOUNT.EQ.1) THEN
3767 *---initialization and test of the random number generator
3768 C CALL RNDMST(12,34,56,78)
3769 C CALL RNDMTE(1)
3770 C ENDIF
3771 *---CONSISTENCY TEST FOR FERMI/PAULI OPTIONS
3772  IF(lpauli .AND. (.NOT.fermp)) THEN
3773  WRITE(6,'(/2A/A/)')
3774  + ' ACTIVATION OF PAULI PRINCIPLE ONLY REASONABLE',
3775  + ' IF FERMI ACTIVE', ' LPAULI CHANGED TO .FALSE.'
3776  lpauli=.false.
3777  ENDIF
3778 C CLOSE (UNIT=5)
3779 C CLOSE (UNIT=11)
3780  ncases=int(what(1))
3781  nevnts=int(what(1))
3782  IF(nevnts.LE.0) nevnts=1000
3783  nevhad=nevnts
3784 C why 2: NEVNTS passed to DTMAI as argument, NEVHAD in COMMON
3785 C in DTP NCASES <- NEVNTS
3786  IF(ncases.LE.0) ncases=100
3787  CALL timdat
3788 *---INITIALIZE GLAUBER THEORY A LA SHMAKOV
3789 C change JGLAUB in dpmjet25 to JGLAUB=1 (was 2 in dpmjet241)
3790  jglaub=1
3791  CALL shmaki(ip,ipz,it,itz,rproj,rtarg,ppn)
3792 *
3793  nn=1
3794  np=1
3795  nt=1
3796 C INITIALIZE COUNTERS
3797  bnnvv=0.001
3798  bnnss=0.001
3799  bnnsv=0.001
3800  bnnvs=0.001
3801  bnncc=0.001
3802  bnndv=0.001
3803  bnnvd=0.001
3804  bnnds=0.001
3805  bnnsd=0.001
3806  bnnhh=0.001
3807  bnnzz=0.001
3808  bnndi=0.001
3809  bnnzd=0.001
3810  bnndz=0.001
3811  bptvv=0.
3812  bptss=0.
3813  bptsv=0.
3814  bptvs=0.
3815  bptcc=0.
3816  bptdv=0.
3817  bptvd=0.
3818  bptds=0.
3819  bptsd=0.
3820  bpthh=0.
3821  bptzz=0.
3822  bptdi=0.
3823  bptzd=0.
3824  bptdz=0.
3825  beevv=0.
3826  beess=0.
3827  beesv=0.
3828  beevs=0.
3829  beecc=0.
3830  beedv=0.
3831  beevd=0.
3832  beeds=0.
3833  beesd=0.
3834  beehh=0.
3835  beezz=0.
3836  beedi=0.
3837  beezd=0.
3838  beedz=0.
3839  bcouvv=0.
3840  bcouss=0.
3841  bcousv=0.
3842  bcouvs=0.
3843  bcouzz=0.
3844  bcouhh=0.
3845  bcouds=0.
3846  bcousd=0.
3847  bcoudz=0.
3848  bcouzd=0.
3849  bcoudi=0.
3850  bcoudv=0.
3851  bcouvd=0.
3852  bcoucc=0.
3853  CALL timdat
3854  RETURN
3855 C
3856 C********************************************************************
3857 C CONTROL CARD: CODEWD = XSECNUC
3858 C Calculation of h-A and A-B nuclear X-sects.
3859 C
3860 C
3861 C WHAT(1)= ECMUU
3862 C WHAT(2)= ECMOO
3863 C WHAT(3)= NGRITT
3864 C WHAT(3)= NEVTT
3865 C
3866 C********************************************************************
3867 C
3868  620 CONTINUE
3869  ecmuu = what(1)
3870  ecmoo = what(2)
3871  ngritt= what(3)
3872  nevtt = what(4)
3873  WRITE(6,*)'call xsglau'
3874  CALL xsglau(ip,it,ijproj,1)
3875  stop
3876 C
3877 C
3878 C********************************************************************
3879 C CONTROL CARD: CODEWD =
3880 C
3881 C
3882 C
3883 C WHAT(1)= DEFAULT: 1000.0
3884 C
3885 C********************************************************************
3886 C
3887  630 CONTINUE
3888  RETURN
3889 C
3890 C
3891 C********************************************************************
3892 C CONTROL CARD: CODEWD =
3893 C
3894 C
3895 C
3896 C WHAT(1)= DEFAULT: 1000.0
3897 C
3898 C********************************************************************
3899 C
3900  640 CONTINUE
3901  RETURN
3902 C
3903 C
3904 C********************************************************************
3905 C CONTROL CARD: CODEWD =
3906 C
3907 C
3908 C
3909 C WHAT(1)= DEFAULT: 1000.0
3910 C
3911 C********************************************************************
3912 C
3913  650 CONTINUE
3914  RETURN
3915 C
3916 C
3917 C********************************************************************
3918 C CONTROL CARD: CODEWD =
3919 C
3920 C
3921 C
3922 C WHAT(1)= DEFAULT: 1000.0
3923 C
3924 C********************************************************************
3925 C
3926  660 CONTINUE
3927  RETURN
3928 C
3929 C********************************************************************
3930 C CONTROL CARD: CODEWD = STOP
3931 C STOPS THE EXECUTION OF THE PROGRAM
3932 C********************************************************************
3933 C
3934  540 CONTINUE
3935 *
3936  stop
3937 C
3938  END
3939 C
3940 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3941 C
3942  BLOCK DATA blkd41
3943  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3944  SAVE
3945 C
3946 *KEEP,PANAME.
3947 C------------------
3948 C
3949 C /PANAME/ CONTAINS PARTICLE NAMES
3950 C BTYPE = LITERAL NAME OF THE PARTICLE
3951 C
3952  CHARACTER*8 btype
3953  COMMON /paname/ btype(30)
3954 *KEEP,NUCIMP.
3955  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
3956  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
3957  +prebin,taebin,fermod,etacou
3958 *KEEP,DPRIN.
3959  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3960 *KEEP,DROPPT.
3961  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
3962  +ishmal,lpauli
3963  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
3964  +ipadis,ishmal,lpauli
3965 *KEEP,HADTHR.
3966  COMMON /hadthr/ ehadth,inthad
3967 *KEEP,NSHMAK.
3968  COMMON /nshmak/ nnshma,npshma,ntshma,nshmac,nshma2
3969 *KEEP,REJEC.
3970  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
3971  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
3972  +irvs14, irvv11,irvv12,irvv13,irvv14
3973 *KEEP,DSHM.
3974  COMMON /dshm/ rash,rbsh,bmax,bstep,sigsh,rosh,gsh,
3975  * bsite(0:1,200),nstatb,nsiteb
3976 *KEEP,DAMP.
3977  COMPLEX*16 ca,ci
3978  COMMON /damp/ ca,ci,ga
3979 *KEEP,INTMX.
3980  parameter(intmx=2488,intmd=252)
3981 *KEND.
3982  COMMON /diffra/ isingd,idiftp,ioudif,iflagd
3983  COMMON /nomije/ ptmije(10),nnmije(10)
3984  DATA ptmije /5.d0,7.d0,9.d0,11.d0,13.d0,15.d0,17.d0
3985  +,19.d0,21.d0,23.d0 /
3986 *
3987 *---rejection counters
3988  DATA irco1,irco2,irco3,irco4,irco5 /5*0/
3989  DATA irss11,irss12,irss13,irss14,irsv11,irsv12,irsv13,irsv14 /8*0/
3990  DATA irvs11,irvs12,irvs13,irvs14,irvv11,irvv12,irvv13,irvv14 /8*0/
3991 C-------------------
3992  DATA inthad /0/
3993 *---predefinition of nuclear potentials, average binding energies, ...
3994  DATA prepot /210*0.0/
3995  DATA taepot /210*0.0/
3996  DATA taebin,prebin,fermod /2*0.0d0,0.6d0/
3997 *---internal particle names
3998  DATA btype /'PROTON ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
3999  +'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
4000  +'MUON+ ' , 'MUON- ' , 'KAONLONG' , 'PION+ ' , 'PION- ' ,
4001  +'KAON+ ' , 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' , 'KAONSHRT' ,
4002  +'SIGMA- ' , 'SIGMA+ ' , 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
4003  +'AKAONZER' , 'RESERVED' , 'BLANK ' , 'BLANK ' , 'BLANK ' ,
4004  +'BLANK ' /
4005 *---print options
4006  DATA ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr /0, 0, 0, -1, 0,
4007  +0, 0, 0/
4008 C-------------------
4009  DATA intpt, fermp, ihadss,ihadsv,ihadvs,ihadvv, ihada /.true.,
4010  +.true., 4*.false., .true./
4011  DATA ipadis, ishmal, lpauli /.false., .false., .true./
4012 C----------------------------------
4013  DATA nshmac /0/
4014  DATA nshma2 /0/
4015 *---parameters for Glauber initialization / calculation
4016  DATA nstatb, nsiteb /2000, 200/
4017  DATA ci /(1.0,0.0)/
4018 *---parameters for combination of q-aq chains to color ropes
4019 C DATA LCOMBI /.FALSE./, NCUTOF /100/
4020  DATA isingd,idiftp,ioudif,iflagd /0,0,0,0/
4021 *
4022  END
4023 ************************************************************************
4024 ************************************************************************
4025 *
4026  SUBROUTINE dttest(CODEWD,WHAT,SDUM)
4027 *
4028 * -- not for normal user --
4029 * contains input options unrecognized by DTPREP and
4030 * performs special initialisations or tasks for program devoloping
4031 *
4032 C COMMON fully commented in DTPREP
4033 *
4034 * **********************************************************************
4035 * * DESCRIPTION OF THE COMMON BLOCK(S), VARIABLE(S) AND DECLARATIONS *
4036 * **********************************************************************
4037 *
4038 *
4039 * /USER/ contains the parameters, expected to be modified by normal user
4040 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4041  IMPLICIT DOUBLE PRECISION(a-h,o-z)
4042  SAVE
4043  CHARACTER*80 title
4044  CHARACTER*8 projty,targty
4045 C COMMON /USER/TITLE,PROJTY,TARGTY,CMENER,ISTRUF
4046 C & ,ISINGD,IDUBLD,SDFRAC,PTLAR
4047  COMMON /user1/title,projty,targty
4048  COMMON /user2/cmener,sdfrac,ptlar,istruf,isingd,idubld
4049 *
4050 * /COLLE/ contains the input specifying the MC. run
4051 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4052  COMMON /colle/nevhad,nvers,ihadrz,nfile
4053 *
4054 * /COLLIS/ contains the input specifying the considered event
4055 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4056  common/collis/s,ijproj,ijtar,ptthr,ptthr2,iophrd,ijprlu,ijtalu
4057 *
4058 *
4059 * /BOOKLT/ contains the final particle names and PPDB-numbers
4060 * of 30 final particle types
4061 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4062  CHARACTER*8 btype
4063  common/booklt/btype(30),nbook(30)
4064 *
4065 * /POLMN/ stores arrays describing probabilities of parton
4066 * configurations
4067 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4068  COMMON /polmn0/pdifr,phard,psoft,alfah,betah,
4069  * sigtot,sigqel,sigel,sigine,sighin,sigd,sigdd
4070 *
4071 * /POMTYP/ contains parameters determining X-sections
4072 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4073  COMMON /pomtyp/ipim,icon,isig,lmax,mmax,nmax,difel,difnu
4074 *
4075 * various smaller commons
4076 * in alphabetical order
4077 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4078  COMMON /dropjj/dropjt,dropva
4079  COMMON /gluspl/nugluu,nsgluu
4080  COMMON /ptlarg/xsmax
4081  COMMON /ptsamp/ isampt
4082  COMMON /stars/istar2,istar3
4083  COMMON /strufu/istrum,istrut
4084  COMMON /popcor/pdb,ajsdef
4085 *
4086 * ********************************************************************
4087 * declarations outside of commons
4088 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4089  CHARACTER*8 codewd,sdum
4090  dimension what(6)
4091 * ********************************************************************
4092 *
4093 *
4094 * **********************************************************************
4095 * * Print the warning that no normal codeword *
4096 * **********************************************************************
4097 *
4098  WRITE(6,9)
4099  9 FORMAT( ' special code word was used ')
4100 *
4101 *
4102 * The following additional CODEWD options exist at the moment:
4103 * RANDOMIZ SIGMAPOM PARTEV SELHARD
4104 * GLUSPLIT
4105 *
4106 * The cards marked with )+ have to be followed by data cards of
4107 * special format
4108 *
4109 *
4110 *
4111 * **********************************************************************
4112 * * parse stored imput card *
4113 * **********************************************************************
4114 *
4115 *
4116 *
4117 * *********************************************************************
4118 * input card: CODEWD = RANDOMIZE
4119 * Sets the SEED for the random number generators
4120 *
4121 * WHAT(1) = 1: gets testrun otherwise: reset
4122 * WHAT(2,3,4,5) = giving the SEED for the random number generators.
4123 * Default ISEED1/2/3/4=12,34,56,78
4124 * Note. It is advisable to use only the seeds given by the
4125 * program in earlier runs. Otherwise the number sequence might
4126 * have defects in its randomness.
4127 C Since 1999 RANDOMIZE initializes the RM48 generator
4128 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4129 *
4130 C IF(CODEWD.EQ.'RANDOMIZ') THEN
4131 *
4132 * Reinitialize random generator
4133 C IF(WHAT(2).NE.0.D0) THEN
4134 C ISEED1=WHAT(2)
4135 C ISEED2=WHAT(3)
4136 C ISEED3=WHAT(4)
4137 C ISEED4=WHAT(5)
4138 C CALL RNDMST(ISEED1,ISEED2,ISEED3,ISEED4)
4139 C ENDIF
4140 * Test random generator and test
4141 C IF(WHAT(1).EQ.1) CALL RNDMTE(1)
4142 *
4143 C GO TO 1
4144 *
4145 *
4146 * *********************************************************************
4147 * input card: CODEWD = SIGMAPOM
4148 * Defines the options for the calculation of the u
4149 * tarized hard and soft multi-pomeron cross sectio
4150 * and demands a testrun
4151 *
4152 * WHAT(1) = ITEST testrun for ITEST = 1
4153 * WHAT(2) = ISIG characterizing X sections, see SIGSHD
4154 * default: 10
4155 * Only ISIG=10 kept in dpmjet-II.5
4156 *
4157 * WHAT(3) = characterizes the method to calculate
4158 * the cut pomeron X-section SIGMA(Lsoft,Mhard,Ntrp) and
4159 * how to attribute them to strings
4160 C!!!!!!!!!!!!!!!!!!!
4161 C!!!!!!!!!!!!!!!!!!! THE FOLLOWING DISTRIBUTIONS WITH 2 CHANNEL
4162 C!!!!!!!!!!!!!!!!!!! EIKONAL + H. MASS DIFFRACTION + HARD SCATTERING
4163 C!!!!!!!!!!!!!!!!!!!
4164 C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11
4165 C
4166 C =482: SEE PRBLM2
4167 C
4168 * DEFAULT: 482
4169 * for all cases
4170 * WHAT(4) = LMAX maximal considered number soft Pomerons
4171 * WHAT(5) = MMAX maximal considered number hard Pomerons
4172 * WHAT(6) = NMAX maximal considered number trippel Pomerons
4173 *
4174 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4175 *
4176 C ELSEIF(CODEWD.EQ.'SIGMAPOM') THEN
4177  IF(codewd.EQ.'SIGMAPOM') THEN
4178 *
4179  itest = what(1)
4180  IF(what(2).NE.0.) isig =int(what(2))
4181  IF(what(3).NE.0.) ipim =int(what(3))
4182  IF(ipim.GT.10) THEN
4183  icon = ipim /10
4184  ipim = ipim-10*icon
4185  ENDIF
4186  IF(ipim.EQ.1) THEN
4187  difel = what(4)
4188  difnu = what(5)
4189  lmax =int(what(6))
4190  mmax = lmax
4191  ELSE
4192  lmax =int(what(4))
4193  mmax =int(what(5))
4194  nmax =int(what(6))
4195  ENDIF
4196  IF (itest.EQ.1)CALL pomdi
4197  go to 1
4198 *
4199 * ********************************************************************
4200 * input card: CODEWD = GLUSPLIT
4201 * Prevents the splitting of Gluons
4202 *
4203 * WHAT(1)=NUGLUU Default: 1.
4204 * =1. only one jet in hard gluon scattering
4205 * WHAT(2)=NSGLUU Default: 0.
4206 * =0. two jets in soft sea gluons
4207 * =1. only one jet in soft sea gluons
4208 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4209 *
4210  ELSEIF(codewd.EQ.'GLUSPLIT') THEN
4211 *
4212  nugluu = what(1)
4213  nsgluu = what(2)
4214  go to 1
4215 *
4216 * ********************************************************************
4217 *
4218 * *********************************************************************
4219 * input card: CODEWD = PARTEV
4220 * defines the parton level collision events
4221 * the X's PT's and flavors and
4222 * demands a test run
4223 *
4224 * WHAT(1) = 1.: testrun ; other values: no testrun
4225 * WHAT(2) = number of events is NPEV default: 30
4226 * WHAT(3) = version of PARTEV is NVERS default: 1
4227 * NVERS=1 all hard partons considered to be gluons
4228 * SOFT X-VALUEA BY REJECTION
4229 * NVERS=2 all hard partons considered to be gluons
4230 * SOFT X-VALUEA BY AURENCHE -MAIRE METHOD
4231 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4232 *
4233  ELSEIF(codewd.EQ.'PARTEV ') THEN
4234 *
4235  itest = int(what(1))
4236  IF (what(2).EQ.0.d0)npev=30
4237  IF (what(2).NE.0.d0)npev=int(what(2))
4238  IF (what(3).EQ.0.d0)nvers=1
4239  IF (what(3).NE.0.d0)nvers=int(what(3))
4240 * first initialize NSOFT-NHARD event selection
4241 * corresponing to choosen one options
4242  IF(itest.EQ.1) THEN
4243  IF(ipim.EQ.2)CALL prblm2(cmener)
4244 * initialize hard scattering
4245  CALL jtdtu(0)
4246  CALL samppt(0,pt)
4247 C CALL PARTEV(NPEV)
4248  CALL timdat
4249  ENDIF
4250  go to 1
4251 *
4252 * *********************************************************************
4253 * input card: CODEWD = SELHARD
4254 * defines the selection of X's,PT's and
4255 * flavors for hard scattering
4256 *
4257 * WHAT(2) = IOPHRD selects the model default: 2
4258 * WHAT(4) = DROPJT=10:DROP FIRST HARD JET PAIR DEFAULT: 0
4259 * THIS OPTION SHOULD ALLOW TO SIMULATE DRELL-YAN
4260 * OR W OR Z PRODUCTION EVENTS
4261 * WHAT(5) = PTTHR threshold PT for hard scattering default: 3.
4262 * WHAT(6) = PTTHR2 threshold PT for FIRST HARD scattering default: 3.
4263 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4264 *
4265  ELSEIF(codewd.EQ.'SELHARD ') THEN
4266 *
4267  IF(what(2).NE.0.d0)iophrd=int(what(2))
4268  IF(what(4).NE.0.d0)dropjt=what(4)
4269  IF(what(6).NE.0.d0)ptthr2=what(6)
4270  IF(what(5).NE.0.d0)THEN
4271  ptthr=what(5)
4272  IF(cmener.LT.2000.0d0.AND.isig.EQ.3)ptthr=what(5)
4273  IF (cmener.GE.2000.0d0.AND.isig.EQ.3)
4274  * ptthr=0.25*log(cmener/2000.)+2.
4275  IF(ptthr2.LT.ptthr)ptthr2=ptthr
4276  IF(istrut.EQ.1)THEN
4277  ptthr=2.1+0.15*(log10(cmener/50.))**3
4278  ptthr2=ptthr
4279  ELSEIF(istrut.EQ.2)THEN
4280  ptthr=2.5+0.12*(log10(cmener/50.))**3
4281  ptthr2=ptthr
4282  ENDIF
4283  WRITE(6,1244)ptthr
4284  1244 FORMAT (' THRESHOLD PT FOR HARD SCATTERING PTTHR=',f12.2)
4285  ENDIF
4286  go to 1
4287 *
4288 * *********************************************************************
4289 * input card: CODEWD = XSLAPT
4290 * calculates inclusive large PT cross sections
4291 * and testrun of the large pt and minijet sampling
4292 * in file laptabr
4293 *
4294 * WHAT(I) = not used at this level
4295 * special DATA CARDS are required
4296 * see description at beginning of LAPTABR
4297 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ----
4298 *
4299  ELSEIF(codewd.EQ.'XSLAPT ') THEN
4300 *
4301  CALL timdat
4302  CALL laptab
4303  CALL timdat
4304  go to 1
4305 *
4306 * *********************************************************************
4307 * parameter card: CODEWD = SAMPT
4308 * defines the options of soft pt sampling in
4309 * subroutine SAMPPT
4310 * WHAT(1) = number defining the option of soft pt sampling
4311 * (default: 4 )
4312 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ----
4313 *
4314  ELSEIF(codewd.EQ.'SAMPT ') THEN
4315 *
4316  isampt = int( what(1) )
4317  IF( isampt.LT.0 .OR. isampt.GT.4 ) isampt=0
4318  go to 1
4319 *
4320 * *********************************************************************
4321 * ending special parsing the code word of "input card"
4322 *
4323  ENDIF
4324 *
4325 * 1) not recognized cards
4326 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ----
4327 * a warning will be issued in DTPREP
4328  RETURN
4329 *
4330 * 2) recognized cards
4331 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ----
4332 * action was done,
4333 * CODEWD is set to a value ignored in DTPREP
4334 *
4335  1 codewd='-zzzzzzz'
4336  RETURN
4337  END
4338 *
4339 ************************************************************************
4340 ************************************************************************
4341 *
4342  BLOCK DATA bookle
4343 *
4344 * *********************************************************************
4345 * /BOOKLT/
4346 *
4347 * neeeded in the following routines: DTUMAIN
4348 *
4349 * description
4350 * /BOOKLT/ contains the final particle names and PPDB-numbers
4351 * BTYPE = literal name of the particle
4352 * NBOOK = the number of the particle
4353 * proposed in the particle data booklet (90)
4354 * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4355  IMPLICIT DOUBLE PRECISION(a-h,o-z)
4356  SAVE
4357  CHARACTER*8 btype
4358  common/booklt/btype(30),nbook(30)
4359 *
4360  DATA btype /'PROTON ' , 'APROTON ' , 'ELECTRON' ,
4361  1 'POSITRON' , 'NEUTRIE ' , 'ANEUTRIE' ,
4362  2 'PHOTON ' , 'NEUTRON ' , 'ANEUTRON' ,
4363  3 'MUON+ ' , 'MUON- ' , 'KAONLONG' ,
4364  4 'PION+ ' , 'PION- ' , 'KAON+ ' ,
4365  5 'KAON- ' , 'LAMBDA ' , 'ALAMBDA ' ,
4366  6 'KAONSHRT' , 'SIGMA- ' , 'SIGMA+ ' ,
4367  7 'SIGMAZER' , 'PIZERO ' , 'KAONZERO' ,
4368  9 'AKAONZER' , ' ' , ' ' ,
4369  z ' ' , ' ' , ' ' /
4370 *
4371 *
4372  DATA nbook / 2212 , -2212 , 11 ,
4373  1 -11 , 14 , -14 ,
4374  2 22 , 2112 , -2112 ,
4375  3 -13 , 13 , 130 ,
4376  4 211 , -211 , 321 ,
4377  5 -321 , 3122 , -3122 ,
4378  6 310 , 3114 , 3224 ,
4379  7 3214 , 111 , 311 ,
4380  9 -311 , 0 , 0 ,
4381  z 0 , 0 , 0 /
4382 *
4383  END
4384 
4385 
4386 C______________________________________________________________________
4387  SUBROUTINE samppt(MODE,PT)
4388 * pt for partons at the end of soft chains
4389 * this pt is sampled from the distribution
4390 * exp(-b*pt^2) with pt=0..ptcut
4391 * MODE = 0 - initialization to determine parameter b from total soft
4392 * and differential hard cross section
4393 * MODE = 1 - sample pt
4394 * MODE = 2 - PLOT PT DISTRIBUTION SAMPLED
4395 *
4396  IMPLICIT DOUBLE PRECISION(a-h,o-z)
4397  SAVE
4398  parameter( zero=0.d0, one=1.d0)
4399  parameter( alfa=0.56268d-01, beta=0.17173d+03 )
4400  parameter( acc = 0.0001d0 )
4401  COMMON /xsecpt/ ptcut,sigs,dsigh
4402  COMMON /sigma / sigsof,bs,zsof,sighar,fill(7)
4403  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
4404 C repl. COMMON/COLLIS/ECM,S,IJPROJ,IJTAR,PTTHR,IOPHRD,IJ1LU,IJ2LU,PTTHR2
4405  common/collis/s,ijproj,ijtar,ptthr,ptthr2,iophrd,ijprlu,ijtalu
4406  CHARACTER*80 title
4407  CHARACTER*8 projty,targty
4408 C COMMON /USER/TITLE,PROJTY,TARGTY,CMENER,ISTRUF
4409 C & ,ISINGD,IDUBLD,SDFRAC,PTLAR
4410  COMMON /user1/title,projty,targty
4411  COMMON /user2/cmener,sdfrac,ptlar,istruf,isingd,idubld
4412 *
4413  common/ptsamp/ isampt
4414  dimension pptt(50),dpptt(50)
4415 C to keep identical commons for patchy ect
4416  ecm=cmener
4417  IF ( mode.EQ.0 ) THEN
4418  DO 201 ii=1,50
4419  pptt(ii)=ii*ptcut/50.
4420  dpptt(ii)=0.
4421  201 CONTINUE
4422  sigs = 0.15*sigsof
4423  IF(ecm.LT.1000.)THEN
4424  aacucu=0.85*(ecm-400.)/600.
4425  sigs=(1.-aacucu)*sigsof
4426  ENDIF
4427 C*************************************************************
4428 C
4429 C OPTIONS FOR SOFT PT SAMPLING
4430 C
4431  WRITE(6,'(A,4E12.4)')' SAMPPT:ECM,PTCUT,SIGS,DSIGH',
4432  * ecm,ptcut,sigs,dsigh
4433  IF( isampt.EQ.0 ) THEN
4434  c = dsigh/(2.*sigs*ptcut)
4435  b = bsofpt(acc,c,ptcut)
4436  IF( ioutpa.GE.1 )WRITE(6,9010)mode,isampt,ptcut,sigs,dsigh,b
4437  * ,c,sigsof,sighar,rmin
4438  ELSEIF( isampt.EQ.1 ) THEN
4439  eb = ecm/beta
4440  c = alfa*log(eb)
4441  b = bsofpt(acc,c,ptcut)
4442  IF( ioutpa.GE.1 )WRITE(6,9010)mode,isampt,ptcut,sigs,dsigh,b
4443  * ,c,sigsof,sighar,rmin
4444  ELSEIF( isampt.EQ.2 ) THEN
4445  b=-6.
4446  IF( ioutpa.GE.1 )WRITE(6,9010)mode,isampt,ptcut,sigs,dsigh,b
4447  * ,c,sigsof,sighar,rmin
4448  ELSEIF( isampt.EQ.3 ) THEN
4449  b=1.e-06
4450  IF( ioutpa.GE.1 )WRITE(6,9010)mode,isampt,ptcut,sigs,dsigh,b
4451  * ,c,sigsof,sighar,rmin
4452  ELSEIF( isampt.EQ.4)THEN
4453  aaaa=ptcut**2*(sigsof+sighar)
4454  IF (aaaa.LE.0.00001d0) THEN
4455  aaaa=abs(aaaa)+0.0002
4456  WRITE(6,5559)ptcut,sigsof,sighar
4457  5559 FORMAT(' SAMPPT:PTCUT,SIDSOF.SIGHATD:',3e12.3)
4458  ENDIF
4459  c=sighar/aaaa
4460  b = 0.5*bsofpt(acc,c,ptcut)
4461  IF( ioutpa.GE.1 )WRITE(6,9010)mode,isampt,ptcut,sigs,dsigh,b
4462  * ,c,sigsof,sighar,rmin
4463  ENDIF
4464 c*************************************************************
4465  rmin = exp(b*ptcut**2)
4466 C
4467 C IOUTPO=IOUTPA
4468 C IOUTPA=1
4469  IF( ioutpa.GE.-1 )WRITE(6,9010)mode,isampt,ptcut,sigs,dsigh,b
4470  * ,c,sigsof,sighar,rmin
4471 9010 FORMAT(' SAMPPT MODE,ISAMPT,PTCUT,SIGS,DSIGH,B,C,SIGSOF',
4472  *' SIGHAR,RMIN ',
4473  * 2i2,f5.2,7e13.6)
4474 C IOUTPA=IOUTPO
4475  ELSEIF ( mode.EQ.1 ) THEN
4476  IF( ioutpa.GE.1 )WRITE(6,9010)mode,isampt,ptcut,sigs,dsigh,b
4477  * ,c,sigsof,sighar,rmin
4478  ptt =log(1.0-rndm(v)*(1.0-rmin))/(b+0.00001d0)
4479  pt=sqrt(ptt)
4480  iipt=pt*50./ptcut+1.
4481  iipt=min( iipt,50 )
4482  dpptt(iipt)=dpptt(iipt)+1./(pt+0.000001d0)
4483 C WRITE(6,111)MODE,PTT,PT,B,RMIN
4484 C 111 FORMAT ('SAMPPT: MODE,PTT,PT,B RMIN',I5,4E15.8)
4485  ELSEIF(mode.EQ.2)THEN
4486  DO 202 ii=1,50
4487  dpptt(ii)=log10(1.e-8+dpptt(ii))
4488  202 CONTINUE
4489  IF(iouxev.GE.-1)THEN
4490  WRITE (6,203)
4491  203 FORMAT(' PT DISTRIBUTION OF SOFT PARTONS AS SAMPLED IN BSOFPT')
4492  CALL plot(pptt,dpptt,50,1,50,zero,ptcut/50.d0,zero,0.05d0*one)
4493  ENDIF
4494  ENDIF
4495  RETURN
4496  END
4497 C****************************************************************8****
4498  real
4499  * * 8
4500  * FUNCTION bsofpt(ACC,CC,PPTCUT)
4501  IMPLICIT DOUBLE PRECISION(a-h,o-z)
4502  SAVE
4503  LOGICAL succes
4504  COMMON /bsoff1/c,ptcut
4505  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
4506  EXTERNAL bsofc1,bsof1
4507  dimension x(50),y(50)
4508  c=cc
4509  ptcut=pptcut
4510  DO 100 i=1,50
4511  x(i)=-2.5+i*0.1
4512  y(i)=bsof1(x(i))
4513  100 CONTINUE
4514 C CALL PLOT (X,Y,50,1,50,-2.5D0,0.1D0,-1.D0,0.02D0)
4515  IF(c.LT.1.d-10) THEN
4516  bb=-30.
4517  go to 999
4518  ENDIF
4519 C IF (C.GT.1.) THEN
4520  kkkk=0
4521  jjjj=0
4522  b1=c+3.
4523  b2=0.0001
4524  go to 300
4525  400 CONTINUE
4526  kkkk=kkkk+1
4527 C ENDIF
4528 C IF (C.LT.1.)THEN
4529  b1=-0.00001
4530  b2=-3.
4531 C ENDIF
4532  300 CONTINUE
4533  CALL zbrac(bsof1,b1,b2,succes)
4534  IF (.NOT.succes)THEN
4535  IF (kkkk.EQ.0)go to 400
4536  jjjj=1
4537  ENDIF
4538  IF(iouxev.GE.1)WRITE(6,111)b1,b2
4539  111 FORMAT(2f10.4)
4540  IF (succes)THEN
4541  bb=rtsafe(bsofc1,b1,b2,acc)
4542  ENDIF
4543  IF (jjjj.EQ.1)bb=0.
4544  999 CONTINUE
4545  bsofpt=bb
4546  RETURN
4547  END
4548  SUBROUTINE bsofc1(B,F,DF)
4549  IMPLICIT DOUBLE PRECISION(a-h,o-z)
4550  SAVE
4551  COMMON /bsoff1/c,ptcut
4552  aaa=exp(b*ptcut**2)
4553  f=c*(aaa-1.)-b*aaa
4554  df=c*ptcut**2*aaa-aaa
4555  * -b*ptcut**2*aaa
4556  RETURN
4557  END
4558 *
4559 *******************************************************************
4560 *
4561  real
4562  * * 8
4563  * FUNCTION bsof1(B)
4564  IMPLICIT DOUBLE PRECISION(a-h,o-z)
4565  SAVE
4566  COMMON /bsoff1/c,ptcut
4567  qqq=b*ptcut**2
4568  aaa=0.
4569  IF(qqq.GT.-60.) THEN
4570  aaa=exp(b*ptcut**2)
4571  ENDIF
4572  bsof1=c*(aaa-1.)-b*aaa
4573 C WRITE(6,10)B,PTCUT,BSOF1,C
4574 C 10 FORMAT (4E15.4)
4575  RETURN
4576  END
4577 *
4578 *******************************************************************************
4579  real
4580  * * 8
4581  * FUNCTION rtsafe(FUNCD,X1,X2,XACC)
4582  IMPLICIT DOUBLE PRECISION(a-h,o-z)
4583  SAVE
4584  parameter(maxit=200,itepri=0)
4585  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
4586  CALL funcd(x1,fl,df)
4587 C IF(IOUXEV.GE.0.AND.ITEPRI.EQ.1) WRITE(6,9999) FL,DF
4588  CALL funcd(x2,fh,df)
4589 C IF(IOUXEV.GE.0.AND.ITEPRI.EQ.1) WRITE(6,9999) FH,DF
4590  IF(fl*fh.GE.0.) pause 'ROOT MUST BE BRACKETED'
4591  IF(fl.LT.0.)THEN
4592  xl=x1
4593  xh=x2
4594  ELSE
4595  xh=x1
4596  xl=x2
4597  swap=fl
4598  fl=fh
4599  fh=swap
4600  ENDIF
4601  rtsafe=.5*(x1+x2)
4602  dxold=abs(x2-x1)
4603  dx=dxold
4604  CALL funcd(rtsafe,f,df)
4605 C IF(IOUXEV.GE.0.AND.ITEPRI.EQ.1) WRITE(6,9998) RTSAFE,F,DF
4606 C IF(IOUXEV.GE.0.AND.ITEPRI.EQ.1) WRITE(6,9996)
4607  DO 11 j=1,maxit
4608 C IF(IOUXEV.GE.0.AND.ITEPRI.EQ.1)
4609 C * WRITE(6,9997) RTSAFE,XH,XL,DXOLD,F,DF
4610  vr1 = var( rtsafe,xh,df,f )
4611  vr2 = var( rtsafe,xl,df,f )
4612 C IF(IOUXEV.GE.0.AND.ITEPRI.EQ.1) WRITE(6,9995) VR1,VR2
4613 C IF(((RTSAFE-XH)*DF-F)*((RTSAFE-XL)*DF-F).GE.0.
4614 C * .OR. ABS(2.*F).GT.ABS(DXOLD*DF) ) THEN
4615  IF( vr1*vr2 .GE. 0.
4616  * .OR. abs(2.*f).GT.abs(dxold*df) ) THEN
4617  dxold=dx
4618  dx=0.5*(xh-xl)
4619  rtsafe=xl+dx
4620  IF(xl.EQ.rtsafe)RETURN
4621  ELSE
4622  dxold=dx
4623 C IF(IOUXEV.GE.0.AND.ITEPRI.EQ.1) WRITE(6,9999) F,DF
4624  dx=f/df
4625  temp=rtsafe
4626  rtsafe=rtsafe-dx
4627  IF(temp.EQ.rtsafe)RETURN
4628  ENDIF
4629  IF(abs(dx).LT.xacc) RETURN
4630  CALL funcd(rtsafe,f,df)
4631  IF(f.LT.0.) THEN
4632  xl=rtsafe
4633  fl=f
4634  ELSE
4635  xh=rtsafe
4636  fh=f
4637  ENDIF
4638 11 CONTINUE
4639  pause 'RTSAFE EXCEEDING MAXIMUM ITERATIONS'
4640  RETURN
4641 9995 FORMAT(' VR1,VR2:',2e12.5)
4642 9996 FORMAT(' RTSAFE,XH,XL,DXOLD,F,DF IN LOOP 11 J=1,MAXIT')
4643 9997 FORMAT(3x,6e10.3)
4644 9998 FORMAT(' RTSAFE: RTSAFE,F,DF =',3e12.5)
4645 9999 FORMAT(' RTSAFE: F,DF =',2e12.5)
4646  END
4647 *
4648 *****************************************************************
4649  real
4650  * * 8
4651  * FUNCTION var(A,B,C,D)
4652  IMPLICIT DOUBLE PRECISION(a-h,o-z)
4653  SAVE
4654  parameter( ambmax = 1.0d+38, epsi = 1.2d-38, one=1.d0 )
4655  amb = a - b
4656  siab= sign(one,amb)
4657  abl = abs(amb)
4658  abl = log10( abl + epsi )
4659  sicc= sign(one, c )
4660  ccl = abs( c )
4661  ccl = log10( ccl + epsi )
4662  rcheck=abl + ccl
4663  IF( rcheck .LE. 38.d0 ) THEN
4664  var = amb*c-d
4665  ELSE
4666  var = ambmax*siab*sicc - d
4667  ENDIF
4668  IF( var .GT. 1.0d+18 ) var = 1.0e+18
4669  IF( var .LT. -1.0d+18 ) var = -1.0e+18
4670  RETURN
4671  END
4672 C
4673  SUBROUTINE zbrac(FUNC,X1,X2,SUCCES)
4674  IMPLICIT DOUBLE PRECISION(a-h,o-z)
4675  SAVE
4676  EXTERNAL func
4677  parameter(factor=1.6d0,ntry=50)
4678  LOGICAL succes
4679  IF(x1.EQ.x2)pause 'You have to guess an initial range'
4680  f1=func(x1)
4681  f2=func(x2)
4682  succes=.true.
4683  DO 11 j=1,ntry
4684  IF(f1*f2.LT.0.d0)RETURN
4685  IF(abs(f1).LT.abs(f2))THEN
4686  x1=x1+factor*(x1-x2)
4687  f1=func(x1)
4688  ELSE
4689  x2=x2+factor*(x2-x1)
4690  f2=func(x2)
4691  ENDIF
4692 11 CONTINUE
4693  succes=.false.
4694  RETURN
4695  END
4696 *
4697 C
4698 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4699 C
4700 C
4701 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4702 C
4703 c subroutine hibldr
4704 c COMMON /DREAC/ umo(296),plabf(296),siin(296),wk(5184),
4705 c * nrk(2,268),nure(30,2)
4706 c read(2,1)umo,plabf,siin,wk
4707 c 1 format (5e16.7)
4708 c read(2,2)nrk,nure
4709 c 2 format (8i10)
4710 c return
4711 c end
4712 C
4713 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4714 
4715 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4716 C
4717  SUBROUTINE checkf(EPN,PPN,IREJ,IORIG)
4718  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4719  SAVE
4720 *KEEP,HKKEVT.
4721 c INCLUDE (HKKEVT)
4722  parameter(amuamu=0.93149432d0)
4723  parameter(nmxhkk= 89998)
4724 c PARAMETER (NMXHKK=25000)
4725  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
4726  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
4727  +(4,nmxhkk)
4728 C
4729 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
4730 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
4731 C THE POSITIONS OF THE PROJECTILE NUCLEONS
4732 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
4733 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
4734 C COMPLETELY CONSISTENT. THE TIMES IN THE
4735 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
4736 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
4737 C
4738 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
4739 C
4740 C NMXHKK: maximum numbers of entries (partons/particles) that can be
4741 C stored in the commonblock.
4742 C
4743 C NHKK: the actual number of entries stored in current event. These are
4744 C found in the first NHKK positions of the respective arrays below.
4745 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
4746 C entry.
4747 C
4748 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
4749 C = 0 : null entry.
4750 C = 1 : an existing entry, which has not decayed or fragmented.
4751 C This is the main class of entries which represents the
4752 C "final state" given by the generator.
4753 C = 2 : an entry which has decayed or fragmented and therefore
4754 C is not appearing in the final state, but is retained for
4755 C event history information.
4756 C = 3 : a documentation line, defined separately from the event
4757 C history. (incoming reacting
4758 C particles, etc.)
4759 C = 4 - 10 : undefined, but reserved for future standards.
4760 C = 11 - 20 : at the disposal of each model builder for constructs
4761 C specific to his program, but equivalent to a null line in the
4762 C context of any other program. One example is the cone defining
4763 C vector of HERWIG, another cluster or event axes of the JETSET
4764 C analysis routines.
4765 C = 21 - : at the disposal of users, in particular for event tracking
4766 C in the detector.
4767 C
4768 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
4769 C standard.
4770 C
4771 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
4772 C The value is 0 for initial entries.
4773 C
4774 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
4775 C one mother exist, in which case the value 0 is used. In cluster
4776 C fragmentation models, the two mothers would correspond to the q
4777 C and qbar which join to form a cluster. In string fragmentation,
4778 C the two mothers of a particle produced in the fragmentation would
4779 C be the two endpoints of the string (with the range in between
4780 C implied).
4781 C
4782 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
4783 C entry has not decayed, this is 0.
4784 C
4785 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
4786 C entry has not decayed, this is 0. It is assumed that the daughters
4787 C of a particle (or cluster or string) are stored sequentially, so
4788 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
4789 C daughters. Even in cases where only one daughter is defined (e.g.
4790 C K0 -> K0S) both values should be defined, to make for a uniform
4791 C approach in terms of loop constructions.
4792 C
4793 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
4794 C
4795 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
4796 C
4797 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
4798 C
4799 C PHKK(4,IHKK) : energy, in GeV.
4800 C
4801 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
4802 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
4803 C
4804 C VHKK(1,IHKK) : production vertex x position, in mm.
4805 C
4806 C VHKK(2,IHKK) : production vertex y position, in mm.
4807 C
4808 C VHKK(3,IHKK) : production vertex z position, in mm.
4809 C
4810 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
4811 C********************************************************************
4812 *KEEP,DELP.
4813  COMMON /delp/ delpx,delpy,delpz,delpe
4814 *KEEP,TANUIN.
4815  COMMON /tanuin/ tasuma,tasubi,tabi,tamasu,tama,taimma
4816 *KEEP,NUCC.
4817  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
4818 *KEEP,DPRIN.
4819  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4820 *KEND.
4821  DATA icheck/0/
4822  help=log10(epn)
4823  phelp=0.
4824  IF(help.GT.5.d0)phelp=help-5.
4825  pthelp=12.+phelp*5.
4826  irej=0
4827  irejj=0
4828  px=0.
4829  py=0.
4830  pz=0.
4831  pe=0.
4832  eext=0.
4833  eexp=0.
4834  eee1=0.
4835  eeem1=0.
4836  ee1001=0.
4837  DO 10 i=1,nhkk
4838 C Projectiles
4839  IF(isthkk(i).EQ.11.OR.isthkk(i).EQ.13) THEN
4840  gam=epn/phkk(5,i)
4841  bgam=ppn/phkk(5,i)
4842  px=px - phkk(1,i)
4843  py=py - phkk(2,i)
4844  pz=pz - gam*phkk(3,i) - bgam*phkk(4,i)
4845  pe=pe - gam*phkk(4,i) - bgam*phkk(3,i)
4846  ENDIF
4847 C Target
4848  IF(isthkk(i).EQ.12.OR.isthkk(i).EQ.14) THEN
4849  px=px - phkk(1,i)
4850  py=py - phkk(2,i)
4851  pz=pz - phkk(3,i)
4852  pe=pe - phkk(4,i)
4853  ENDIF
4854 * sum final state momenta
4855  IF(isthkk(i).EQ.1) THEN
4856  px=px + phkk(1,i)
4857  py=py + phkk(2,i)
4858  pz=pz + phkk(3,i)
4859  pe=pe + phkk(4,i)
4860  ENDIF
4861 C noninteracting Projectiles
4862  IF(isthkk(i).EQ.13.AND.jdahkk(2,i).EQ.0) THEN
4863  gam=epn/phkk(5,i)
4864  bgam=ppn/phkk(5,i)
4865  px=px + phkk(1,i)
4866  py=py + phkk(2,i)
4867  pz=pz + gam*phkk(3,i) + bgam*phkk(4,i)
4868  pe=pe + gam*phkk(4,i) + bgam*phkk(3,i)
4869  ENDIF
4870  IF(isthkk(i).EQ.14.AND.jdahkk(2,i).EQ.0) THEN
4871 C noninteracting Targets
4872  px=px + phkk(1,i)
4873  py=py + phkk(2,i)
4874  pz=pz + phkk(3,i)
4875  pe=pe + phkk(4,i)
4876  ENDIF
4877  IF(isthkk(i).EQ.16) THEN
4878  imo=jmohkk(1,i)
4879  px=px + phkk(1,i)
4880  py=py + phkk(2,i)
4881  pz=pz + phkk(3,i)
4882  pe=pe + phkk(4,i)
4883  eext=eext + phkk(4,i) - phkk(4,imo)
4884  ENDIF
4885  IF(isthkk(i).EQ.15) THEN
4886  imo=jmohkk(1,i)
4887  gam=epn/phkk(5,i)
4888  bgam=ppn/phkk(5,i)
4889  px=px + phkk(1,i)
4890  py=py + phkk(2,i)
4891  pz=pz + gam*phkk(3,i) + bgam*phkk(4,i)
4892  pe=pe + gam*phkk(4,i) + bgam*phkk(3,i)
4893  eext=eext + phkk(4,i) - phkk(4,imo)
4894  ENDIF
4895  IF(isthkk(i).EQ.1) THEN
4896  eee1=eee1+phkk(4,i)
4897  ENDIF
4898  IF(isthkk(i).EQ.-1) THEN
4899  eeem1=eeem1+phkk(4,i)
4900  ENDIF
4901  IF(isthkk(i).EQ.1001) THEN
4902  ee1001=ee1001+phkk(4,i)
4903  ENDIF
4904  10 CONTINUE
4905  eee=eee1+eeem1+ee1001
4906  epnto=epn*ip
4907  aeee=eee/epnto
4908  eeee=eee-epn*ip
4909  aeeee=eee/epn-ip
4910  aeee1=eee1/epnto
4911  aeeem1=eeem1/epnto
4912  aee101=ee1001/epnto
4913  aip=1
4914  ait=it
4915  aitz=itz
4916  aip=aip+(ait*amuamu+1.d-3*energy(ait,aitz))/epnto
4917  delle=abs(aip-aeee)
4918  elle=delle*epnto
4919  tole=0.030
4920 C TOLE=0.012
4921  IF(it.LE.50)THEN
4922  IF(it.EQ.ip)tole=0.02
4923 C IF(IT.EQ.IP)TOLE=0.05
4924  ENDIF
4925  IF(delle.GE.tole)irej=1
4926  IF(irej.EQ.1)THEN
4927  icheck=icheck+1
4928  IF(icheck.LE.100)THEN
4929  WRITE(6,'(A,I5,E10.3,5F10.4)')
4930  * ' IP,EPN,AEEE,AEEEE,AEEE1,AEEEM1,AEE101:',
4931  * ip,epn,aeee,aeeee,aeee1,aeeem1,aee101
4932  WRITE(6,'(A,I5,E10.3,7E12.4)')
4933  * ' IP,EPN,EEE,EEEE,EEE1,EEEM1,EE1001,DELLE,ELLE:',
4934  * ip,epn,eee,eeee,eee1,eeem1,ee1001,delle,elle
4935  ENDIF
4936  ENDIF
4937 C PX=PX + DELPX
4938 C PY=PY + DELPY
4939 C PZ=PZ + DELPZ
4940 C PE=PE + DELPE
4941 C IF(IPRI.GT.1) THEN
4942 C IF (ABS(PX).GT.PTHELP.OR. ABS(PY).GT.PTHELP.OR.
4943 C * ABS(PZ)/EPN.GT.0.025*IP.
4944 C + OR. ABS(PE)/EPN.GT.0.025*IP) THEN
4945 C IREJJ=1
4946 C ICHECK=ICHECK+1
4947 C IF(ICHECK.LE.500.AND.IREJJ.EQ.1)THEN
4948 C WRITE(6,1000) PX,PY,PZ,PE,EEXT,EEXP,DELPX,DELPY,DELPZ,DELPE,IORIG
4949 C ENDIF
4950  1000 FORMAT(' CHECKF: PX,PY,PZ,PE,EEXT,EEXP',2f7.3,2e12.3,2f7.3
4951  * / 8x,' DELPX/Y/Z/E',4f7.3,i10,' IORIG')
4952 C WRITE(6,'(8X,A,6F8.3)') ' TASUMA,TASUBI,TABI,TAMASU,TAMA,TAIMMA',
4953 C +TASUMA,TASUBI,TABI,TAMASU,TAMA,TAIMMA
4954 
4955  IF(ipri.GT.1) THEN
4956  DO 20 i=1,nhkk
4957  IF(isthkk(i).EQ.11) THEN
4958  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
4959  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
4960  + (vhkk(khkk,i),khkk=1,4)
4961 
4962  ENDIF
4963  IF(isthkk(i).EQ.12) THEN
4964  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
4965  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
4966  + (vhkk(khkk,i),khkk=1,4)
4967 
4968  ENDIF
4969  IF(isthkk(i).EQ.1) THEN
4970  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
4971  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
4972  + (vhkk(khkk,i),khkk=1,4)
4973 
4974  1010 FORMAT (i6,i4,5i6,9(1pe10.2))
4975  ENDIF
4976  IF(isthkk(i).EQ.16) THEN
4977  imo=jmohkk(1,i)
4978  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
4979  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
4980  + (vhkk(khkk,i),khkk=1,4)
4981 
4982  ENDIF
4983  20 CONTINUE
4984  ENDIF
4985 C ENDIF
4986  RETURN
4987  END
4988 C
4989 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4990 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4991 C
4992  SUBROUTINE checkn(EPN,PPN,IREJ,IORIG)
4993  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4994  SAVE
4995 *KEEP,HKKEVT.
4996 c INCLUDE (HKKEVT)
4997  parameter(amuamu=0.93149432d0)
4998  parameter(nmxhkk= 89998)
4999 c PARAMETER (NMXHKK=25000)
5000  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
5001  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
5002  +(4,nmxhkk)
5003 C
5004 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
5005 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
5006 C THE POSITIONS OF THE PROJECTILE NUCLEONS
5007 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
5008 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
5009 C COMPLETELY CONSISTENT. THE TIMES IN THE
5010 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
5011 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
5012 C
5013 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
5014 C
5015 C NMXHKK: maximum numbers of entries (partons/particles) that can be
5016 C stored in the commonblock.
5017 C
5018 C NHKK: the actual number of entries stored in current event. These are
5019 C found in the first NHKK positions of the respective arrays below.
5020 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
5021 C entry.
5022 C
5023 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
5024 C = 0 : null entry.
5025 C = 1 : an existing entry, which has not decayed or fragmented.
5026 C This is the main class of entries which represents the
5027 C "final state" given by the generator.
5028 C = 2 : an entry which has decayed or fragmented and therefore
5029 C is not appearing in the final state, but is retained for
5030 C event history information.
5031 C = 3 : a documentation line, defined separately from the event
5032 C history. (incoming reacting
5033 C particles, etc.)
5034 C = 4 - 10 : undefined, but reserved for future standards.
5035 C = 11 - 20 : at the disposal of each model builder for constructs
5036 C specific to his program, but equivalent to a null line in the
5037 C context of any other program. One example is the cone defining
5038 C vector of HERWIG, another cluster or event axes of the JETSET
5039 C analysis routines.
5040 C = 21 - : at the disposal of users, in particular for event tracking
5041 C in the detector.
5042 C
5043 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
5044 C standard.
5045 C
5046 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
5047 C The value is 0 for initial entries.
5048 C
5049 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
5050 C one mother exist, in which case the value 0 is used. In cluster
5051 C fragmentation models, the two mothers would correspond to the q
5052 C and qbar which join to form a cluster. In string fragmentation,
5053 C the two mothers of a particle produced in the fragmentation would
5054 C be the two endpoints of the string (with the range in between
5055 C implied).
5056 C
5057 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
5058 C entry has not decayed, this is 0.
5059 C
5060 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
5061 C entry has not decayed, this is 0. It is assumed that the daughters
5062 C of a particle (or cluster or string) are stored sequentially, so
5063 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
5064 C daughters. Even in cases where only one daughter is defined (e.g.
5065 C K0 -> K0S) both values should be defined, to make for a uniform
5066 C approach in terms of loop constructions.
5067 C
5068 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
5069 C
5070 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
5071 C
5072 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
5073 C
5074 C PHKK(4,IHKK) : energy, in GeV.
5075 C
5076 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
5077 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
5078 C
5079 C VHKK(1,IHKK) : production vertex x position, in mm.
5080 C
5081 C VHKK(2,IHKK) : production vertex y position, in mm.
5082 C
5083 C VHKK(3,IHKK) : production vertex z position, in mm.
5084 C
5085 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
5086 C********************************************************************
5087 *KEEP,DELP.
5088  COMMON /delp/ delpx,delpy,delpz,delpe
5089 *KEEP,TANUIN.
5090  COMMON /tanuin/ tasuma,tasubi,tabi,tamasu,tama,taimma
5091 *KEEP,NUCC.
5092  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
5093 *KEEP,DPRIN.
5094  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5095 *KEND.
5096  DATA icheck/0/
5097  help=log10(epn)
5098  phelp=0.
5099  IF(help.GT.5.d0)phelp=help-5.d0
5100  pthelp=12.d0+phelp*5.d0
5101  irej=0
5102  irejj=0
5103  px=0.d0
5104  py=0.d0
5105  pz=0.d0
5106  pe=0.d0
5107  eext=0.d0
5108  eexp=0.d0
5109  eee1=0.d0
5110  eeem1=0.d0
5111  ee1001=0.d0
5112  pz1=0.d0
5113  pzm1=0.d0
5114  pz1001=0.d0
5115  px1=0.d0
5116  pxm1=0.0
5117  px1001=0.d0
5118  DO 10 i=1,nhkk
5119 C Projectiles
5120  IF(isthkk(i).EQ.11.OR.isthkk(i).EQ.13) THEN
5121  gam=epn/phkk(5,i)
5122  bgam=ppn/phkk(5,i)
5123  px=px - phkk(1,i)
5124  py=py - phkk(2,i)
5125  pz=pz - gam*phkk(3,i) - bgam*phkk(4,i)
5126  pe=pe - gam*phkk(4,i) - bgam*phkk(3,i)
5127  ENDIF
5128 C Target
5129  IF(isthkk(i).EQ.12.OR.isthkk(i).EQ.14) THEN
5130  px=px - phkk(1,i)
5131  py=py - phkk(2,i)
5132  pz=pz - phkk(3,i)
5133  pe=pe - phkk(4,i)
5134  ENDIF
5135 * sum final state momenta
5136  IF(isthkk(i).EQ.1) THEN
5137  px=px + phkk(1,i)
5138  py=py + phkk(2,i)
5139  pz=pz + phkk(3,i)
5140  pe=pe + phkk(4,i)
5141  ENDIF
5142 C noninteracting Projectiles
5143  IF(isthkk(i).EQ.13.AND.jdahkk(2,i).EQ.0) THEN
5144  gam=epn/phkk(5,i)
5145  bgam=ppn/phkk(5,i)
5146  px=px + phkk(1,i)
5147  py=py + phkk(2,i)
5148  pz=pz + gam*phkk(3,i) + bgam*phkk(4,i)
5149  pe=pe + gam*phkk(4,i) + bgam*phkk(3,i)
5150  ENDIF
5151  IF(isthkk(i).EQ.14.AND.jdahkk(2,i).EQ.0) THEN
5152 C noninteracting Targets
5153  px=px + phkk(1,i)
5154  py=py + phkk(2,i)
5155  pz=pz + phkk(3,i)
5156  pe=pe + phkk(4,i)
5157  ENDIF
5158  IF(isthkk(i).EQ.16) THEN
5159  imo=jmohkk(1,i)
5160  px=px + phkk(1,i)
5161  py=py + phkk(2,i)
5162  pz=pz + phkk(3,i)
5163  pe=pe + phkk(4,i)
5164  eext=eext + phkk(4,i) - phkk(4,imo)
5165  ENDIF
5166  IF(isthkk(i).EQ.15) THEN
5167  imo=jmohkk(1,i)
5168  gam=epn/phkk(5,i)
5169  bgam=ppn/phkk(5,i)
5170  px=px + phkk(1,i)
5171  py=py + phkk(2,i)
5172  pz=pz + gam*phkk(3,i) + bgam*phkk(4,i)
5173  pe=pe + gam*phkk(4,i) + bgam*phkk(3,i)
5174  eext=eext + phkk(4,i) - phkk(4,imo)
5175  ENDIF
5176  IF(isthkk(i).EQ.1) THEN
5177  eee1=eee1+phkk(4,i)
5178  pz1=pz1+phkk(3,i)
5179  px1=px1+phkk(1,i)
5180  ENDIF
5181  IF(isthkk(i).EQ.-1) THEN
5182  eeem1=eeem1+phkk(4,i)
5183  pzm1=pzm1+phkk(3,i)
5184  pxm1=pxm1+phkk(1,i)
5185  ENDIF
5186  IF(isthkk(i).EQ.1001) THEN
5187  ee1001=ee1001+phkk(4,i)
5188  pz1001=pz1001+phkk(3,i)
5189  px1001=px1001+phkk(1,i)
5190  ENDIF
5191  10 CONTINUE
5192  eee=eee1+eeem1+ee1001
5193  pzpz=pz1+pzm1+pz1001
5194  pxpx=px1+pxm1+px1001
5195 C--------------------------------------------------------------
5196 C
5197 C patch to correct pz of residual nuclei
5198 C
5199 C--------------------------------------------------------------
5200  delpz=ppn-pzpz
5201  pzpz=pzpz+delpz
5202  pz1001=pz1001+delpz
5203  ee1001=0.d0
5204  DO 101 i=1,nhkk
5205  IF(isthkk(i).EQ.1001) THEN
5206  phkk(3,i)=phkk(3,i)+delpz
5207  phkk(4,i)=sqrt(phkk(1,i)**2+phkk(2,i)**2+phkk(3,i)**2
5208  * +phkk(5,i)**2)
5209  ee1001=ee1001+phkk(4,i)
5210  ENDIF
5211  101 CONTINUE
5212  eee=eee1+eeem1+ee1001
5213 C--------------------------------------------------------------
5214  aip=1
5215  epnto=epn*aip
5216  eeee=eee-epn*aip
5217  aip=1
5218  ait=it
5219  aitz=itz
5220  bip=epn+(ait*amuamu+1.d-3*energy(ait,aitz))
5221  bmi=1.d-3*energy(ait,aitz)
5222  delle=abs(bip-eee)
5223 C TOLE=EPN/450000.D0
5224 C TOLE=EPN/2500.D0
5225  tole=0.16d0
5226  IF(delle.GE.tole)irej=1
5227  IF(irej.EQ.1)THEN
5228  icheck=icheck+1
5229  IF(icheck.LE.20)THEN
5230  WRITE(6,'(A,I5,E10.3,4F10.4)')
5231  * ' IP,EPN,PXPX,PX1,PXM1,PX1001:',
5232  * ip,epn,pxpx,px1,pxm1,px1001
5233  WRITE(6,'(A,I5,E10.3,6F10.4)')
5234  * ' IP,PPN,PZPZ,PZ1,PZM1,PZ1001,BIP,BMI:',
5235  * ip,ppn,pzpz,pz1,pzm1,pz1001,bip,bmi
5236  WRITE(6,'(A,I5,E10.3,5E12.4)')
5237  * ' IP,EPN,EEE,EEE1,EEEM1,EE1001,DELLE:',
5238  * ip,epn,eee,eee1,eeem1,ee1001,delle
5239  ENDIF
5240  ENDIF
5241 C PX=PX + DELPX
5242 C PY=PY + DELPY
5243 C PZ=PZ + DELPZ
5244 C PE=PE + DELPE
5245 C IF(IPRI.GT.1) THEN
5246 C IF (ABS(PX).GT.PTHELP.OR. ABS(PY).GT.PTHELP.OR.
5247 C * ABS(PZ)/EPN.GT.0.025D0*IP.
5248 C + OR. ABS(PE)/EPN.GT.0.025D0*IP) THEN
5249 C IREJJ=1
5250 C ICHECK=ICHECK+1
5251 C IF(ICHECK.LE.500.AND.IREJJ.EQ.1)THEN
5252 C WRITE(6,1000) PX,PY,PZ,PE,EEXT,EEXP,DELPX,DELPY,DELPZ,DELPE,IORIG
5253 C ENDIF
5254  1000 FORMAT(' CHECKF: PX,PY,PZ,PE,EEXT,EEXP',2f7.3,2e12.3,2f7.3
5255  * / 8x,' DELPX/Y/Z/E',4f7.3,i10,' IORIG')
5256 C WRITE(6,'(8X,A,6F8.3)') ' TASUMA,TASUBI,TABI,TAMASU,TAMA,TAIMMA',
5257 C +TASUMA,TASUBI,TABI,TAMASU,TAMA,TAIMMA
5258 
5259  IF(ipri.GT.1) THEN
5260  DO 20 i=1,nhkk
5261  IF(isthkk(i).EQ.11) THEN
5262  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5263  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5264  + (vhkk(khkk,i),khkk=1,4)
5265 
5266  ENDIF
5267  IF(isthkk(i).EQ.12) THEN
5268  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5269  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5270  + (vhkk(khkk,i),khkk=1,4)
5271 
5272  ENDIF
5273  IF(isthkk(i).EQ.1) THEN
5274  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5275  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5276  + (vhkk(khkk,i),khkk=1,4)
5277 
5278  1010 FORMAT (i6,i4,5i6,9(1pe10.2))
5279  ENDIF
5280  IF(isthkk(i).EQ.16) THEN
5281  imo=jmohkk(1,i)
5282  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5283  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5284  + (vhkk(khkk,i),khkk=1,4)
5285 
5286  ENDIF
5287  20 CONTINUE
5288  ENDIF
5289 C ENDIF
5290  RETURN
5291  END
5292 C
5293 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5294 C
5295  SUBROUTINE checko(EPN,PPN,IREJ,IORIG)
5296  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5297  SAVE
5298 *KEEP,HKKEVT.
5299 c INCLUDE (HKKEVT)
5300  parameter(amuamu=0.93149432d0)
5301  parameter(nmxhkk= 89998)
5302 c PARAMETER (NMXHKK=25000)
5303  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
5304  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
5305  +(4,nmxhkk)
5306 C
5307 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
5308 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
5309 C THE POSITIONS OF THE PROJECTILE NUCLEONS
5310 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
5311 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
5312 C COMPLETELY CONSISTENT. THE TIMES IN THE
5313 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
5314 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
5315 C
5316 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
5317 C
5318 C NMXHKK: maximum numbers of entries (partons/particles) that can be
5319 C stored in the commonblock.
5320 C
5321 C NHKK: the actual number of entries stored in current event. These are
5322 C found in the first NHKK positions of the respective arrays below.
5323 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
5324 C entry.
5325 C
5326 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
5327 C = 0 : null entry.
5328 C = 1 : an existing entry, which has not decayed or fragmented.
5329 C This is the main class of entries which represents the
5330 C "final state" given by the generator.
5331 C = 2 : an entry which has decayed or fragmented and therefore
5332 C is not appearing in the final state, but is retained for
5333 C event history information.
5334 C = 3 : a documentation line, defined separately from the event
5335 C history. (incoming reacting
5336 C particles, etc.)
5337 C = 4 - 10 : undefined, but reserved for future standards.
5338 C = 11 - 20 : at the disposal of each model builder for constructs
5339 C specific to his program, but equivalent to a null line in the
5340 C context of any other program. One example is the cone defining
5341 C vector of HERWIG, another cluster or event axes of the JETSET
5342 C analysis routines.
5343 C = 21 - : at the disposal of users, in particular for event tracking
5344 C in the detector.
5345 C
5346 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
5347 C standard.
5348 C
5349 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
5350 C The value is 0 for initial entries.
5351 C
5352 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
5353 C one mother exist, in which case the value 0 is used. In cluster
5354 C fragmentation models, the two mothers would correspond to the q
5355 C and qbar which join to form a cluster. In string fragmentation,
5356 C the two mothers of a particle produced in the fragmentation would
5357 C be the two endpoints of the string (with the range in between
5358 C implied).
5359 C
5360 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
5361 C entry has not decayed, this is 0.
5362 C
5363 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
5364 C entry has not decayed, this is 0. It is assumed that the daughters
5365 C of a particle (or cluster or string) are stored sequentially, so
5366 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
5367 C daughters. Even in cases where only one daughter is defined (e.g.
5368 C K0 -> K0S) both values should be defined, to make for a uniform
5369 C approach in terms of loop constructions.
5370 C
5371 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
5372 C
5373 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
5374 C
5375 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
5376 C
5377 C PHKK(4,IHKK) : energy, in GeV.
5378 C
5379 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
5380 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
5381 C
5382 C VHKK(1,IHKK) : production vertex x position, in mm.
5383 C
5384 C VHKK(2,IHKK) : production vertex y position, in mm.
5385 C
5386 C VHKK(3,IHKK) : production vertex z position, in mm.
5387 C
5388 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
5389 C********************************************************************
5390  COMMON /zentra/ icentr
5391 *KEEP,DELP.
5392  COMMON /delp/ delpx,delpy,delpz,delpe
5393 *KEEP,TANUIN.
5394  COMMON /tanuin/ tasuma,tasubi,tabi,tamasu,tama,taimma
5395 *KEEP,NUCC.
5396  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
5397 *KEEP,DPRIN.
5398  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5399 *KEND.
5400  DATA icheck/0/
5401  help=log10(epn)
5402  phelp=0.
5403  IF(help.GT.5.d0)phelp=help-5.
5404  pthelp=12.+phelp*5.
5405  irej=0
5406  irejj=0
5407  px=0.
5408  py=0.
5409  pz=0.
5410  pe=0.
5411  eext=0.
5412  eexp=0.
5413  eee1=0.
5414  eeem1=0.
5415  ee1001=0.
5416  DO 10 i=1,nhkk
5417 C Projectiles
5418  IF(isthkk(i).EQ.11.OR.isthkk(i).EQ.13) THEN
5419  gam=epn/phkk(5,i)
5420  bgam=ppn/phkk(5,i)
5421  px=px - phkk(1,i)
5422  py=py - phkk(2,i)
5423  pz=pz - gam*phkk(3,i) - bgam*phkk(4,i)
5424  pe=pe - gam*phkk(4,i) - bgam*phkk(3,i)
5425  ENDIF
5426 C Target
5427  IF(isthkk(i).EQ.12.OR.isthkk(i).EQ.14) THEN
5428  px=px - phkk(1,i)
5429  py=py - phkk(2,i)
5430  pz=pz - phkk(3,i)
5431  pe=pe - phkk(4,i)
5432  ENDIF
5433 * sum final state momenta
5434  IF(isthkk(i).EQ.1) THEN
5435  px=px + phkk(1,i)
5436  py=py + phkk(2,i)
5437  pz=pz + phkk(3,i)
5438  pe=pe + phkk(4,i)
5439  ENDIF
5440 C noninteracting Projectiles
5441  IF(isthkk(i).EQ.13.AND.jdahkk(2,i).EQ.0) THEN
5442  gam=epn/phkk(5,i)
5443  bgam=ppn/phkk(5,i)
5444  px=px + phkk(1,i)
5445  py=py + phkk(2,i)
5446  pz=pz + gam*phkk(3,i) + bgam*phkk(4,i)
5447  pe=pe + gam*phkk(4,i) + bgam*phkk(3,i)
5448  ENDIF
5449  IF(isthkk(i).EQ.14.AND.jdahkk(2,i).EQ.0) THEN
5450 C noninteracting Targets
5451  px=px + phkk(1,i)
5452  py=py + phkk(2,i)
5453  pz=pz + phkk(3,i)
5454  pe=pe + phkk(4,i)
5455  ENDIF
5456  IF(isthkk(i).EQ.16) THEN
5457  imo=jmohkk(1,i)
5458  px=px + phkk(1,i)
5459  py=py + phkk(2,i)
5460  pz=pz + phkk(3,i)
5461  pe=pe + phkk(4,i)
5462  eext=eext + phkk(4,i) - phkk(4,imo)
5463  ENDIF
5464  IF(isthkk(i).EQ.15) THEN
5465  imo=jmohkk(1,i)
5466  gam=epn/phkk(5,i)
5467  bgam=ppn/phkk(5,i)
5468  px=px + phkk(1,i)
5469  py=py + phkk(2,i)
5470  pz=pz + gam*phkk(3,i) + bgam*phkk(4,i)
5471  pe=pe + gam*phkk(4,i) + bgam*phkk(3,i)
5472  eext=eext + phkk(4,i) - phkk(4,imo)
5473  ENDIF
5474  IF(isthkk(i).EQ.1) THEN
5475  eee1=eee1+phkk(3,i)
5476  ENDIF
5477  10 CONTINUE
5478  eee=eee1
5479  epnto=ppn*ip
5480  aeee=eee/epnto
5481  eeee=eee-ppn*ip
5482  aeeee=eee/ppn-ip
5483  aeee1=eee1/epnto
5484  aip=1
5485  ait=it
5486  aitz=itz
5487  aip=aip
5488  delle=abs(aip-aeee)
5489  elle=delle*epnto
5490 C IF(DELLE.GE.0.025)IREJ=1
5491 C IF(IREJ.EQ.1)
5492 C * WRITE(6,'(A,I5,E10.3,3F10.4)')
5493 C *' IP,EPN,AEEE,AEEEE,AEEE1:',
5494 C * IP,EPN,AEEE,AEEEE,AEEE1
5495 C IF(IREJ.EQ.1)
5496 C * WRITE(6,'(A,I5,E10.3,5F10.4)')
5497 C *' IP,EPN,EEE,EEEE,EEE1,DELLE,ELLE:',
5498 C * IP,EPN,EEE,EEEE,EEE1,DELLE,ELLE
5499  px=px + delpx
5500  py=py + delpy
5501  pz=pz + delpz
5502  pe=pe + delpe
5503  tole=0.025d0*ip
5504  IF(ip.EQ.it.AND.it.GT.1)tole=0.05d0*ip
5505 C IF(ICENTR.EQ.1)TOLE=TOLE*2.
5506  IF(epn.LE.5.d0)tole=3.d0*tole
5507 C IF(IPRI.GT.1) THEN
5508  IF (abs(px).GT.pthelp.OR. abs(py).GT.pthelp.OR.
5509  * abs(pz)/epn.GT.tole.
5510  + or. abs(pe)/epn.GT.tole) THEN
5511  irej=1
5512  icheck=icheck+1
5513  IF(icheck.LE.50.AND.irej.EQ.1)THEN
5514  WRITE(6,1000) px,py,pz,pe,eext,eexp,delpx,delpy,delpz,delpe,iorig
5515  ENDIF
5516  1000 FORMAT(' CHECKO: PX,PY,PZ,PE,EEXT,EEXP',2f7.3,2e12.3,2f7.3
5517  * / 8x,' DELPX/Y/Z/E',4f7.3,i10,' IORIG')
5518 C WRITE(6,'(8X,A,6F8.3)') ' TASUMA,TASUBI,TABI,TAMASU,TAMA,TAIMMA',
5519 C +TASUMA,TASUBI,TABI,TAMASU,TAMA,TAIMMA
5520  IF(ipri.GE.1)THEN
5521  WRITE(6,1000) px,py,pz,pe,eext,eexp,delpx,delpy,delpz,delpe,iorig
5522  ENDIF
5523  IF(ipri.GT.1) THEN
5524  DO 20 i=1,nhkk
5525  IF(isthkk(i).EQ.11) THEN
5526  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5527  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5528  + (vhkk(khkk,i),khkk=1,4)
5529 
5530  ENDIF
5531  IF(isthkk(i).EQ.12) THEN
5532  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5533  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5534  + (vhkk(khkk,i),khkk=1,4)
5535 
5536  ENDIF
5537  IF(isthkk(i).EQ.1) THEN
5538  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5539  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5540  + (vhkk(khkk,i),khkk=1,4)
5541 
5542  1010 FORMAT (i6,i4,5i6,9(1pe10.2))
5543  ENDIF
5544  IF(isthkk(i).EQ.16) THEN
5545  imo=jmohkk(1,i)
5546  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5547  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5548  + (vhkk(khkk,i),khkk=1,4)
5549 
5550  ENDIF
5551  20 CONTINUE
5552  ENDIF
5553  ENDIF
5554  IF(ipri.GE.1)THEN
5555  WRITE(6,1000) px,py,pz,pe,eext,eexp,delpx,delpy,delpz,delpe,iorig
5556  ENDIF
5557  RETURN
5558  END
5559 C
5560  SUBROUTINE checke(EPN,PPN)
5561  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5562  SAVE
5563 *KEEP,HKKEVT.
5564 c INCLUDE (HKKEVT)
5565  parameter(nmxhkk= 89998)
5566 c PARAMETER (NMXHKK=25000)
5567  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
5568  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
5569  +(4,nmxhkk)
5570 C
5571 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
5572 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
5573 C THE POSITIONS OF THE PROJECTILE NUCLEONS
5574 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
5575 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
5576 C COMPLETELY CONSISTENT. THE TIMES IN THE
5577 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
5578 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
5579 C
5580 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
5581 C
5582 C NMXHKK: maximum numbers of entries (partons/particles) that can be
5583 C stored in the commonblock.
5584 C
5585 C NHKK: the actual number of entries stored in current event. These are
5586 C found in the first NHKK positions of the respective arrays below.
5587 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
5588 C entry.
5589 C
5590 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
5591 C = 0 : null entry.
5592 C = 1 : an existing entry, which has not decayed or fragmented.
5593 C This is the main class of entries which represents the
5594 C "final state" given by the generator.
5595 C = 2 : an entry which has decayed or fragmented and therefore
5596 C is not appearing in the final state, but is retained for
5597 C event history information.
5598 C = 3 : a documentation line, defined separately from the event
5599 C history. (incoming reacting
5600 C particles, etc.)
5601 C = 4 - 10 : undefined, but reserved for future standards.
5602 C = 11 - 20 : at the disposal of each model builder for constructs
5603 C specific to his program, but equivalent to a null line in the
5604 C context of any other program. One example is the cone defining
5605 C vector of HERWIG, another cluster or event axes of the JETSET
5606 C analysis routines.
5607 C = 21 - : at the disposal of users, in particular for event tracking
5608 C in the detector.
5609 C
5610 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
5611 C standard.
5612 C
5613 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
5614 C The value is 0 for initial entries.
5615 C
5616 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
5617 C one mother exist, in which case the value 0 is used. In cluster
5618 C fragmentation models, the two mothers would correspond to the q
5619 C and qbar which join to form a cluster. In string fragmentation,
5620 C the two mothers of a particle produced in the fragmentation would
5621 C be the two endpoints of the string (with the range in between
5622 C implied).
5623 C
5624 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
5625 C entry has not decayed, this is 0.
5626 C
5627 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
5628 C entry has not decayed, this is 0. It is assumed that the daughters
5629 C of a particle (or cluster or string) are stored sequentially, so
5630 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
5631 C daughters. Even in cases where only one daughter is defined (e.g.
5632 C K0 -> K0S) both values should be defined, to make for a uniform
5633 C approach in terms of loop constructions.
5634 C
5635 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
5636 C
5637 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
5638 C
5639 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
5640 C
5641 C PHKK(4,IHKK) : energy, in GeV.
5642 C
5643 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
5644 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
5645 C
5646 C VHKK(1,IHKK) : production vertex x position, in mm.
5647 C
5648 C VHKK(2,IHKK) : production vertex y position, in mm.
5649 C
5650 C VHKK(3,IHKK) : production vertex z position, in mm.
5651 C
5652 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
5653 C********************************************************************
5654 *KEEP,DELP.
5655  COMMON /delp/ delpx,delpy,delpz,delpe
5656 *KEEP,TANUIN.
5657  COMMON /tanuin/ tasuma,tasubi,tabi,tamasu,tama,taimma
5658 *KEEP,DPRIN.
5659  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5660 *KEND.
5661  px=0.
5662  py=0.
5663  pz=0.
5664  pe=0.
5665  eext=0.
5666  eexp=0.
5667  DO 10 i=1,nhkk
5668 C Projectiles
5669  IF(isthkk(i).EQ.11.OR.isthkk(i).EQ.13) THEN
5670  gam=epn/phkk(5,i)
5671  bgam=ppn/phkk(5,i)
5672  px=px - phkk(1,i)
5673  py=py - phkk(2,i)
5674  pz=pz - gam*phkk(3,i) - bgam*phkk(4,i)
5675  pe=pe - gam*phkk(4,i) - bgam*phkk(3,i)
5676  ENDIF
5677 C Target
5678  IF(isthkk(i).EQ.12.OR.isthkk(i).EQ.14) THEN
5679  px=px - phkk(1,i)
5680  py=py - phkk(2,i)
5681  pz=pz - phkk(3,i)
5682  pe=pe - phkk(4,i)
5683  ENDIF
5684 * sum final state momenta
5685  IF(isthkk(i).EQ.1) THEN
5686  px=px + phkk(1,i)
5687  py=py + phkk(2,i)
5688  pz=pz + phkk(3,i)
5689  pe=pe + phkk(4,i)
5690  ENDIF
5691 C noninteracting Projectiles
5692  IF(isthkk(i).EQ.13.AND.jdahkk(1,i).EQ.0) THEN
5693  gam=epn/phkk(5,i)
5694  bgam=ppn/phkk(5,i)
5695  px=px + phkk(1,i)
5696  py=py + phkk(2,i)
5697  pz=pz + gam*phkk(3,i) + bgam*phkk(4,i)
5698  pe=pe + gam*phkk(4,i) + bgam*phkk(3,i)
5699  ENDIF
5700  IF(isthkk(i).EQ.14.AND.jdahkk(1,i).EQ.0) THEN
5701 C noninteracting Targets
5702  px=px + phkk(1,i)
5703  py=py + phkk(2,i)
5704  pz=pz + phkk(3,i)
5705  pe=pe + phkk(4,i)
5706  ENDIF
5707  IF(isthkk(i).EQ.16) THEN
5708  imo=jmohkk(1,i)
5709  px=px + phkk(1,i)
5710  py=py + phkk(2,i)
5711  pz=pz + phkk(3,i)
5712  pe=pe + phkk(4,i)
5713  eext=eext + phkk(4,i) - phkk(4,imo)
5714  ENDIF
5715  IF(isthkk(i).EQ.15) THEN
5716  imo=jmohkk(1,i)
5717  px=px + phkk(1,i)
5718  py=py + phkk(2,i)
5719  pz=pz + phkk(3,i)
5720  pe=pe + phkk(4,i)
5721  eext=eext + phkk(4,i) - phkk(4,imo)
5722  ENDIF
5723  10 CONTINUE
5724  px=px + delpx
5725  py=py + delpy
5726  pz=pz + delpz
5727  pe=pe + delpe
5728  WRITE(6,1000) px,py,pz,pe,eext,eexp,delpx,delpy,delpz,delpe
5729  1000 FORMAT(' CHECKE: PX,PY,PZ,PE,EEXT,EEXP',6f7.3/ 8x,' DELPX/Y/Z/E',4
5730  +f7.3)
5731  WRITE(6,'(8X,A,6F8.3)') ' TASUMA,TASUBI,TABI,TAMASU,TAMA,TAIMMA',
5732  +tasuma,tasubi,tabi,tamasu,tama,taimma
5733  IF(ipri.GT.1) THEN
5734  IF (abs(px).GT.0.004.OR. abs(py).GT.0.004.OR. abs(pz).GT.0.004.
5735  + or. abs(pe).GT.0.004) THEN
5736 
5737 
5738  DO 20 i=1,nhkk
5739  IF(isthkk(i).EQ.11) THEN
5740  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5741  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5742  + (vhkk(khkk,i),khkk=1,4)
5743 
5744  ENDIF
5745  IF(isthkk(i).EQ.12) THEN
5746  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5747  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5748  + (vhkk(khkk,i),khkk=1,4)
5749 
5750  ENDIF
5751  IF(isthkk(i).EQ.1) THEN
5752  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5753  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5754  + (vhkk(khkk,i),khkk=1,4)
5755 
5756  1010 FORMAT (i6,i4,5i6,9(1pe10.2))
5757  ENDIF
5758  IF(isthkk(i).EQ.16) THEN
5759  imo=jmohkk(1,i)
5760  WRITE(6,1010) i,isthkk(i),idhkk(i),jmohkk(1,i),jmohkk
5761  + (2,i), jdahkk(1,i),jdahkk(2,i),(phkk(khkk,i),khkk=1,5),
5762  + (vhkk(khkk,i),khkk=1,4)
5763 
5764  ENDIF
5765  20 CONTINUE
5766  ENDIF
5767  ENDIF
5768  RETURN
5769  END
5770 C######################################################################
5771 C######################################################################
5772 C######################################################################
5773 *
5774 C######################################################################
5775 C######################################################################
5776 C######################################################################
5777 C
5778 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5779 C
5780 C######################################################################
5781 C######################################################################
5782 C######################################################################
5783 C######################################################################
5784 C######################################################################
5785 C######################################################################
5786 C
5787 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5788 C
5789  DOUBLE PRECISION FUNCTION ebind(IA,IZ)
5790  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5791  SAVE
5792 C***
5793 C Binding energy for nuclei with mass number IA
5794 C and atomic number IZ
5795 C from Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972
5796 C***
5797  DATA a1,a2,a3,a4,a5 /0.01575, 0.0178, 0.000710, 0.0237, 0.034/
5798 C
5799 C WRITE (6,'(A,2I5)')' EBIND IA,IZ ',IA,IZ
5800  IF(ia.LE.1.OR.iz.EQ.0)THEN
5801  ebind=0
5802  RETURN
5803  ENDIF
5804  aa=ia
5805  ebind = a1*aa - a2*aa**0. 666667- a3*iz*iz*aa**(-0.333333) - a4
5806  +*(ia-2*iz)**2/aa
5807  IF (mod(ia,2).EQ.1) THEN
5808  ia5=0
5809  ELSEIF (mod(iz,2).EQ.1) THEN
5810  ia5=1
5811  ELSE
5812  ia5=-1
5813  ENDIF
5814  ebind=ebind - ia5*a5*aa**(-0.75)
5815  RETURN
5816  END
5817 C
5818 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5819 C
5820  SUBROUTINE defaul(EPN,PPN)
5821  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5822  SAVE
5823 *---set default values for some parameters
5824 *KEEP,HKKEVT.
5825 c INCLUDE (HKKEVT)
5826  parameter(nmxhkk= 89998)
5827 c PARAMETER (NMXHKK=25000)
5828  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
5829  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
5830  +(4,nmxhkk)
5831 C
5832 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
5833 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
5834 C THE POSITIONS OF THE PROJECTILE NUCLEONS
5835 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
5836 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
5837 C COMPLETELY CONSISTENT. THE TIMES IN THE
5838 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
5839 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
5840 C
5841 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
5842 C
5843 C NMXHKK: maximum numbers of entries (partons/particles) that can be
5844 C stored in the commonblock.
5845 C
5846 C NHKK: the actual number of entries stored in current event. These are
5847 C found in the first NHKK positions of the respective arrays below.
5848 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
5849 C entry.
5850 C
5851 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
5852 C = 0 : null entry.
5853 C = 1 : an existing entry, which has not decayed or fragmented.
5854 C This is the main class of entries which represents the
5855 C "final state" given by the generator.
5856 C = 2 : an entry which has decayed or fragmented and therefore
5857 C is not appearing in the final state, but is retained for
5858 C event history information.
5859 C = 3 : a documentation line, defined separately from the event
5860 C history. (incoming reacting
5861 C particles, etc.)
5862 C = 4 - 10 : undefined, but reserved for future standards.
5863 C = 11 - 20 : at the disposal of each model builder for constructs
5864 C specific to his program, but equivalent to a null line in the
5865 C context of any other program. One example is the cone defining
5866 C vector of HERWIG, another cluster or event axes of the JETSET
5867 C analysis routines.
5868 C = 21 - : at the disposal of users, in particular for event tracking
5869 C in the detector.
5870 C
5871 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
5872 C standard.
5873 C
5874 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
5875 C The value is 0 for initial entries.
5876 C
5877 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
5878 C one mother exist, in which case the value 0 is used. In cluster
5879 C fragmentation models, the two mothers would correspond to the q
5880 C and qbar which join to form a cluster. In string fragmentation,
5881 C the two mothers of a particle produced in the fragmentation would
5882 C be the two endpoints of the string (with the range in between
5883 C implied).
5884 C
5885 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
5886 C entry has not decayed, this is 0.
5887 C
5888 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
5889 C entry has not decayed, this is 0. It is assumed that the daughters
5890 C of a particle (or cluster or string) are stored sequentially, so
5891 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
5892 C daughters. Even in cases where only one daughter is defined (e.g.
5893 C K0 -> K0S) both values should be defined, to make for a uniform
5894 C approach in terms of loop constructions.
5895 C
5896 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
5897 C
5898 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
5899 C
5900 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
5901 C
5902 C PHKK(4,IHKK) : energy, in GeV.
5903 C
5904 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
5905 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
5906 C
5907 C VHKK(1,IHKK) : production vertex x position, in mm.
5908 C
5909 C VHKK(2,IHKK) : production vertex y position, in mm.
5910 C
5911 C VHKK(3,IHKK) : production vertex z position, in mm.
5912 C
5913 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
5914 C********************************************************************
5915 *KEEP,DPAR.
5916 C /DPAR/ CONTAINS PARTICLE PROPERTIES
5917 C ANAME = LITERAL NAME OF THE PARTICLE
5918 C AAM = PARTICLE MASS IN GEV
5919 C GA = DECAY WIDTH
5920 C TAU = LIFE TIME OF INSTABLE PARTICLES
5921 C IICH = ELECTRIC CHARGE OF THE PARTICLE
5922 C IIBAR = BARYON NUMBER
5923 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
5924 C
5925  CHARACTER*8 aname
5926  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
5927  +iibar(210),k1(210),k2(210)
5928 C------------------
5929 *KEEP,FACTMO.
5930  COMMON /factmo/ ifacto
5931 *KEEP,TAUFO.
5932  COMMON /taufo/ taufor,ktauge,itauve,incmod
5933 *KEEP,HADTHR.
5934  COMMON /hadthr/ ehadth,inthad
5935 *KEEP,NUCC.
5936 C COMMON /NUCCC/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5937 C COMMON /NUCC/ JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG
5938  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
5939  COMMON /nuccc/ jt,jtz,jp,jpz,jjproj,jbproj,jjtarg,jbtarg
5940 *KEEP,ZENTRA.
5941  COMMON /zentra/ icentr
5942 *KEEP,CMHICO.
5943  COMMON /cmhico/ cmhis
5944 *KEEP,RESONA.
5945  COMMON /resona/ ireso
5946 *KEEP,XSEADI.
5947  COMMON /xseadi/ xseacu,unon,unom,unosea, cvq,cdq,csea,ssmima,
5948  +ssmimq,vvmthr
5949 *KEEP,COULO.
5950  common/coulo/icoul
5951 *KEEP,EDENS.
5952  common/edens/ieden
5953 *KEEP,PROJK.
5954  COMMON /projk/ iprojk
5955 *KEEP,NUCIMP.
5956  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
5957  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
5958  +prebin,taebin,fermod,etacou
5959 *KEND.
5960  COMMON /recom/irecom
5961 C---------------------
5962 *---minimum bias interactions
5963  icentr=0
5964 *---threshold for the use of HADRIN in the primary hadron-nucleon collision
5965  ehadth=5.
5966 *---lab energy and momentum of the projectile: pion+
5967  epn=200.
5968  ijproj=13
5969  jjproj=13
5970  ppn=sqrt((epn-aam(ijproj))*(epn+aam(ijproj)))
5971  ibproj=iibar(ijproj)
5972  ip=1
5973  ipz=1
5974  jbproj=iibar(ijproj)
5975  jp=1
5976  jpz=1
5977 *---copper target
5978  it=14
5979  itz=7
5980  jt=14
5981  jtz=7
5982 *---formation zone intranuclear cascade
5983  taufor=105.
5984  ktauge=0
5985  itauve=1
5986 *---inclusion of Coulomb potential for hA interactions
5987  icoul=1
5988  icoull=1
5989 *---cascade within projectile switched off
5990  iprojk=1
5991 *---nucleus independent meson potential
5992  potmes=0.002
5993  taepot(13)=potmes
5994  taepot(14)=potmes
5995  taepot(15)=potmes
5996  taepot(16)=potmes
5997  taepot(23)=potmes
5998  taepot(24)=potmes
5999  taepot(25)=potmes
6000 *---definition of soft quark distributions
6001  xseacu=0.05
6002  unon=1.11d0
6003  unom=1.11d0
6004  unosea=5.0d0
6005 *---cutoff parameters for x-sampling
6006  cvq=2.0d0
6007  cdq=2.0d0
6008  csea=0.3d0
6009  ssmima=0.90d0
6010  ssmimq=ssmima**2
6011 *---
6012  ireso=0
6013  cmhis=0.d0
6014  ieden=0
6015  ifacto=0
6016 C---Chain recombination
6017 C IRECOM=1
6018  RETURN
6019  END
6020 C
6021 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6022 C
6023 C
6024 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6025 C
6026  SUBROUTINE hadhad(EPN,PPN,NHKKH1,IHTAWW,ITTA,IREJFO)
6027  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6028  SAVE
6029 C*** AT LOW ENERGIES EPN.LE.EHADTH HADRIN IS USED WITH ONE INTERACTION
6030 C*** IN THE NUCLEUS INSTEAD OF THE DUAL PARTON MODEL (GLAUBER CASCADE)
6031 C*** ONLY FOR HADRON-NUCLEUS COLLISIONS!
6032 C
6033 *KEEP,HKKEVT.
6034 c INCLUDE (HKKEVT)
6035  parameter(nmxhkk= 89998)
6036 c PARAMETER (NMXHKK=25000)
6037  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
6038  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
6039  +(4,nmxhkk)
6040 C
6041 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
6042 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
6043 C THE POSITIONS OF THE PROJECTILE NUCLEONS
6044 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
6045 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
6046 C COMPLETELY CONSISTENT. THE TIMES IN THE
6047 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
6048 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
6049 C
6050 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
6051 C
6052 C NMXHKK: maximum numbers of entries (partons/particles) that can be
6053 C stored in the commonblock.
6054 C
6055 C NHKK: the actual number of entries stored in current event. These are
6056 C found in the first NHKK positions of the respective arrays below.
6057 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
6058 C entry.
6059 C
6060 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
6061 C = 0 : null entry.
6062 C = 1 : an existing entry, which has not decayed or fragmented.
6063 C This is the main class of entries which represents the
6064 C "final state" given by the generator.
6065 C = 2 : an entry which has decayed or fragmented and therefore
6066 C is not appearing in the final state, but is retained for
6067 C event history information.
6068 C = 3 : a documentation line, defined separately from the event
6069 C history. (incoming reacting
6070 C particles, etc.)
6071 C = 4 - 10 : undefined, but reserved for future standards.
6072 C = 11 - 20 : at the disposal of each model builder for constructs
6073 C specific to his program, but equivalent to a null line in the
6074 C context of any other program. One example is the cone defining
6075 C vector of HERWIG, another cluster or event axes of the JETSET
6076 C analysis routines.
6077 C = 21 - : at the disposal of users, in particular for event tracking
6078 C in the detector.
6079 C
6080 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
6081 C standard.
6082 C
6083 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
6084 C The value is 0 for initial entries.
6085 C
6086 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
6087 C one mother exist, in which case the value 0 is used. In cluster
6088 C fragmentation models, the two mothers would correspond to the q
6089 C and qbar which join to form a cluster. In string fragmentation,
6090 C the two mothers of a particle produced in the fragmentation would
6091 C be the two endpoints of the string (with the range in between
6092 C implied).
6093 C
6094 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
6095 C entry has not decayed, this is 0.
6096 C
6097 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
6098 C entry has not decayed, this is 0. It is assumed that the daughters
6099 C of a particle (or cluster or string) are stored sequentially, so
6100 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
6101 C daughters. Even in cases where only one daughter is defined (e.g.
6102 C K0 -> K0S) both values should be defined, to make for a uniform
6103 C approach in terms of loop constructions.
6104 C
6105 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
6106 C
6107 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
6108 C
6109 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
6110 C
6111 C PHKK(4,IHKK) : energy, in GeV.
6112 C
6113 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
6114 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
6115 C
6116 C VHKK(1,IHKK) : production vertex x position, in mm.
6117 C
6118 C VHKK(2,IHKK) : production vertex y position, in mm.
6119 C
6120 C VHKK(3,IHKK) : production vertex z position, in mm.
6121 C
6122 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
6123 C********************************************************************
6124 *KEEP,NUCC.
6125  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
6126 *KEEP,DPAR.
6127 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6128 C ANAME = LITERAL NAME OF THE PARTICLE
6129 C AAM = PARTICLE MASS IN GEV
6130 C GA = DECAY WIDTH
6131 C TAU = LIFE TIME OF INSTABLE PARTICLES
6132 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6133 C IIBAR = BARYON NUMBER
6134 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6135 C
6136  CHARACTER*8 aname
6137  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
6138  +iibar(210),k1(210),k2(210)
6139 C------------------
6140 *KEEP,DPRIN.
6141  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6142 *KEEP,DFINLS.
6143  parameter(maxfin=10)
6144  COMMON /dfinls/ itrh(maxfin),cxrh(maxfin),cyrh(maxfin), czrh
6145  +(maxfin),elrh(maxfin),plrh(maxfin),irh
6146 *KEEP,NUCIMP.
6147  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
6148  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
6149  +prebin,taebin,fermod,etacou
6150 *KEND.
6151 C------------------------------------------------------------------
6152 C PPN=SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
6153 c ipaupr=2
6154 c ipri=3
6155  irejfo=0
6156  IF(ipri.GE.2) WRITE(6,1001) ijproj,ijproj,ppn,epn,cccxp,cccyp,
6157  +ccczp,ihtaww,itta,ieline
6158  1001 FORMAT(' HADHAD 1:',
6159  +' IJPROJ,IJPROJ,PPN,EPN,CCCXP,CCCYP,CCCZP,IHTAWW,ITTA,IELINE'/ 2
6160  +i3,2e12.3,3f7.3,3i4)
6161  cccxp=0.
6162  cccyp=0.
6163  ccczp=1.
6164  ieline=0
6165  CALL sihnin(ijproj,itta,ppn,sight)
6166  CALL sihnel(ijproj,itta,ppn,sighte)
6167  sigtot=sight + sighte
6168  IF (sigtot*rndm(bb).LE.sighte)ieline=1
6169  IF(ipri.GE.2) WRITE(6,1000) ijproj,ijproj,ppn,epn,cccxp,cccyp,
6170  +ccczp,ihtaww,itta,ieline
6171  1000 FORMAT(' HADHAD 2 nach si...:',
6172  +' IJPROJ,IJPROJ,PPN,EPN,CCCXP,CCCYP,CCCZP,IHTAWW,ITTA,IELINE'/ 2
6173  +i3,2e12.3,3f7.3,3i4)
6174  ihadha=0
6175  12 CONTINUE
6176  ihadha=ihadha+1
6177  IF(ipri.GE.2) WRITE(6,1012) ijproj,ijproj,ppn,epn,cccxp,cccyp,
6178  +ccczp,ihtaww,itta,ieline
6179  1012 FORMAT(' HADHAD 12 loop:',
6180  +' IJPROJ,IJPROJ,PPN,EPN,CCCXP,CCCYP,CCCZP,IHTAWW,ITTA,IELINE'/ 2
6181  +i3,2e12.3,3f7.3,3i4)
6182  IF(ipri.GE.3) THEN
6183  do 1212 ii=1,irh
6184  WRITE(6,'(I3,5(1PE12.4),I5/3X,5(1PE12.4))') ii,elrh(ii),plrh
6185  + (ii),cxrh(ii),cyrh(ii),czrh(ii),itrh(ii), (phkk(jjj,nhkk),jjj
6186  + =1,5)
6187  1212 continue
6188  ENDIF
6189 * repeated entry if Pauli blocking was active
6190  CALL fhad(ijproj,ijproj,ppn,epn,cccxp,cccyp,ccczp, ihtaww,itta,
6191  +ieline,irejfh)
6192  IF(irejfh.EQ.1)THEN
6193  irejfo=1
6194  IF(ipri.GE.3)
6195  + WRITE(6,'(A)')' exit from hadhad with irejfo=1 '
6196  RETURN
6197  ENDIF
6198 *
6199 * require Pauli blocking for final state nucleons
6200 *
6201  IF (ihadha.LT.3)THEN
6202  DO 11 ii=1,irh
6203  itsec=itrh(ii)
6204  IF(itsec.EQ.1.AND.elrh(ii).LE.taefep+aam(itsec)) goto 12
6205  IF(itsec.EQ.8.AND.elrh(ii).LE.taefen+aam(itsec)) goto 12
6206  IF(iibar(itsec).NE.1.AND.elrh(ii)-aam(itsec)
6207  + .LE.taepot(itsec)) goto 12
6208  11 CONTINUE
6209  ENDIF
6210  nhkkh1=nhkk
6211 C
6212  IF (ipri.GE.2) WRITE (6,1010)irh,nhkkh1,ihtaww,itta
6213  1010 FORMAT (' HADHAD IRH,NHKKH1,IHTAWW,ITTA = ',4i5)
6214 C
6215  IF(ipri.GE.3) THEN
6216  WRITE(6,'(A/5X,A)')
6217  + ' HADHAD - PARTICLE TRANSFER FROM /FINLSP/ INTO /HKKEVT/',
6218  + ' II, ELRH, PLRH, CXRH, CYRH, CZRH / PHKK(1-5)'
6219  ENDIF
6220 C
6221  isthkk(1)=11
6222  DO 10 ii=1,irh
6223 C IF( (ITSEC.EQ.1.AND.ELRH(II).GE.TAEFEP+AAM(ITSEC)) .OR.
6224 C + (ITSEC.EQ.8.AND.ELRH(II).GE.TAEFEN+AAM(ITSEC)) )THEN
6225  nhkk=nhkk+1
6226  IF (nhkk.EQ.nmxhkk)THEN
6227  WRITE (6,'(A,2I5)') .EQ.' HADHAD:NHKKNMXHKK ',nhkk,nmxhkk
6228  RETURN
6229  ENDIF
6230  itsec=itrh(ii)
6231  idhkk(nhkk)=mpdgha(itsec)
6232  jmohkk(1,nhkk)=1
6233  jmohkk(2,nhkk)=ihtaww
6234  jdahkk(1,nhkk)=0
6235  jdahkk(2,nhkk)=0
6236  phkk(1,nhkk)=plrh(ii)*cxrh(ii)
6237  phkk(2,nhkk)=plrh(ii)*cyrh(ii)
6238  phkk(3,nhkk)=plrh(ii)*czrh(ii)
6239  phkk(4,nhkk)=elrh(ii)
6240  IF(phkk(4,nhkk)-aam(itsec).LE.taepot(itsec).
6241  + and.iibar(itsec).EQ.1)THEN
6242  isthkk(nhkk)=16
6243  ELSE
6244  isthkk(nhkk)=1
6245  ENDIF
6246  phkk(5,nhkk)=aam(itrh(ii))
6247 C
6248  IF(ipri.GE.3) THEN
6249  WRITE(6,'(I3,5(1PE12.4),I5/3X,5(1PE12.4),I5)')
6250  + ii,elrh(ii),plrh
6251  + (ii),cxrh(ii),cyrh(ii),czrh(ii),itrh(ii), (phkk(jjj,nhkk),jjj
6252  + =1,5),irejfo
6253  ENDIF
6254  vhkk(1,nhkk)=vhkk(1,ihtaww)
6255  vhkk(2,nhkk)=vhkk(2,ihtaww)
6256  vhkk(3,nhkk)=vhkk(3,ihtaww)
6257  vhkk(4,nhkk)=vhkk(4,1)
6258 C ENDIF
6259  10 CONTINUE
6260  jdahkk(1,1)=nhkkh1+1
6261  jdahkk(2,1)=nhkk
6262  jdahkk(1,ihtaww)=nhkkh1+1
6263  jdahkk(2,ihtaww)=nhkk
6264 c ipaupr=0
6265 c ipri=0
6266  IF(ipri.GE.3)
6267  + WRITE(6,'(A)')' exit from hadhad with irejfo=0 '
6268  RETURN
6269  END
6270  SUBROUTINE chebch(IREJ,NHKKH1)
6271  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6272  SAVE
6273 *KEEP,HKKEVT.
6274 c INCLUDE (HKKEVT)
6275  parameter(nmxhkk= 89998)
6276 c PARAMETER (NMXHKK=25000)
6277  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
6278  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
6279  +(4,nmxhkk)
6280  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
6281  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
6282 C
6283 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
6284 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
6285 C THE POSITIONS OF THE PROJECTILE NUCLEONS
6286 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
6287 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
6288 C COMPLETELY CONSISTENT. THE TIMES IN THE
6289 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
6290 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
6291 C
6292 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
6293 C
6294 C NMXHKK: maximum numbers of entries (partons/particles) that can be
6295 C stored in the commonblock.
6296 C
6297 C NHKK: the actual number of entries stored in current event. These are
6298 C found in the first NHKK positions of the respective arrays below.
6299 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
6300 C entry.
6301 C
6302 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
6303 C = 0 : null entry.
6304 C = 1 : an existing entry, which has not decayed or fragmented.
6305 C This is the main class of entries which represents the
6306 C "final state" given by the generator.
6307 C = 2 : an entry which has decayed or fragmented and therefore
6308 C is not appearing in the final state, but is retained for
6309 C event history information.
6310 C = 3 : a documentation line, defined separately from the event
6311 C history. (incoming reacting
6312 C particles, etc.)
6313 C = 4 - 10 : undefined, but reserved for future standards.
6314 C = 11 - 20 : at the disposal of each model builder for constructs
6315 C specific to his program, but equivalent to a null line in the
6316 C context of any other program. One example is the cone defining
6317 C vector of HERWIG, another cluster or event axes of the JETSET
6318 C analysis routines.
6319 C = 21 - : at the disposal of users, in particular for event tracking
6320 C in the detector.
6321 C
6322 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
6323 C standard.
6324 C
6325 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
6326 C The value is 0 for initial entries.
6327 C
6328 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
6329 C one mother exist, in which case the value 0 is used. In cluster
6330 C fragmentation models, the two mothers would correspond to the q
6331 C and qbar which join to form a cluster. In string fragmentation,
6332 C the two mothers of a particle produced in the fragmentation would
6333 C be the two endpoints of the string (with the range in between
6334 C implied).
6335 C
6336 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
6337 C entry has not decayed, this is 0.
6338 C
6339 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
6340 C entry has not decayed, this is 0. It is assumed that the daughters
6341 C of a particle (or cluster or string) are stored sequentially, so
6342 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
6343 C daughters. Even in cases where only one daughter is defined (e.g.
6344 C K0 -> K0S) both values should be defined, to make for a uniform
6345 C approach in terms of loop constructions.
6346 C
6347 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
6348 C
6349 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
6350 C
6351 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
6352 C
6353 C PHKK(4,IHKK) : energy, in GeV.
6354 C
6355 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
6356 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
6357 C
6358 C VHKK(1,IHKK) : production vertex x position, in mm.
6359 C
6360 C VHKK(2,IHKK) : production vertex y position, in mm.
6361 C
6362 C VHKK(3,IHKK) : production vertex z position, in mm.
6363 C
6364 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
6365 C********************************************************************
6366 *KEEP,DPAR.
6367 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6368 C ANAME = LITERAL NAME OF THE PARTICLE
6369 C AAM = PARTICLE MASS IN GEV
6370 C GA = DECAY WIDTH
6371 C TAU = LIFE TIME OF INSTABLE PARTICLES
6372 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6373 C IIBAR = BARYON NUMBER
6374 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6375 C
6376  CHARACTER*8 aname
6377  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
6378  +iibar(210),k1(210),k2(210)
6379 C------------------
6380 *KEEP,NUCC.
6381  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
6382 *KEEP,DPRIN.
6383  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6384 *KEND.
6385  COMMON /chabai/chargi,barnui
6386  COMMON /evappp/ievap
6387 C-----------------------------------------------------------------------
6388  DATA ievl /0/
6389 C----------------------------------------------------------------------
6390  zero=0
6391  oneone=1
6392  twotwo=2
6393  nhad=0
6394  nip=ip
6395  aip=ip
6396  ievl=ievl+1
6397  chaeve=0.
6398  baeve=0.
6399  IF(ievap.EQ.0)THEN
6400  DO 1171 i=1,nhkkh1
6401  IF (isthkk(i).EQ.13)THEN
6402  baeve=baeve+1
6403  IF(idhkk(i).EQ.2212)chaeve=chaeve+1.d0
6404  ENDIF
6405  IF (isthkk(i).EQ.14)THEN
6406  baeve=baeve+1
6407  IF(idhkk(i).EQ.2212)chaeve=chaeve+1.d0
6408  ENDIF
6409  1171 CONTINUE
6410  DO 521 i=nhkkh1,nhkk
6411  IF (isthkk(i).EQ.1.OR.isthkk(i).EQ.15.OR.isthkk(i).EQ.16)THEN
6412  nhad=nhad+1
6413  nrhkk=mcihad(idhkk(i))
6414  IF (nrhkk.LE.0.OR.nrhkk.GT.410)THEN
6415  WRITE(6,1389)nrhkk,i,idhkk(i),nhkkh1,nhkk
6416  1389 FORMAT (' distr: NRHKK ERROR ',5i10)
6417  nrhkk=1
6418  ENDIF
6419  ichhkk=iich(nrhkk)
6420  ibhkk=iibar(nrhkk)
6421  chaeve=chaeve+ichhkk
6422  baeve=baeve+ibhkk
6423  ENDIF
6424  521 CONTINUE
6425  ELSEIF(ievap.EQ.1)THEN
6426  DO 1521 i=1,nhkk
6427  IF (isthkk(i).EQ.1)THEN
6428  nrhkk=mcihad(idhkk(i))
6429  ichhkk=iich(nrhkk)
6430  ibhkk=iibar(nrhkk)
6431  chaeve=chaeve+ichhkk
6432  baeve=baeve+ibhkk
6433  ENDIF
6434  1521 CONTINUE
6435 C WRITE(6,'(A,2F12.1)')' after isthkk=1 ',CHAEVE,BAEVE
6436  DO 2521 i=1,nhkk
6437  IF (isthkk(i).EQ.-1)THEN
6438  IF(idhkk(i).EQ.2112)THEN
6439  baeve=baeve+1
6440 C WRITE(6,'(A,2F12.1)')' evap isthkk=-1',CHAEVE,BAEVE
6441  ENDIF
6442  IF(idhkk(i).EQ.2212)THEN
6443  chaeve=chaeve+1
6444  baeve=baeve+1
6445 C WRITE(6,'(A,2F12.1)')' evap isthkk=-1',CHAEVE,BAEVE
6446  ENDIF
6447  ENDIF
6448  IF((idhkk(i).EQ.80000).AND.(isthkk(i).NE.1000))THEN
6449  chaeve=chaeve+idxres(i)
6450  baeve=baeve+idres(i)
6451 C WRITE(6,'(A,2F12.1,2I5)')' h.f.',CHAEVE,BAEVE,IDXRES(I),IDRES(I)
6452  ENDIF
6453  2521 CONTINUE
6454  ENDIF
6455  IF(ievl.LE.10)WRITE(6,'(2A,4F10.2)')' Event charge and B-number',
6456  * '=',chaeve,baeve,chargi,barnui
6457  IF(chaeve-chargi.NE.0.d0.OR.baeve-barnui.NE.0.d0)THEN
6458 C DO 775 JJJ=1,200
6459  IF(ievl.LE.1000)WRITE(6,'(2A,4F10.2)')'Event charge and B-numb',
6460  *'(violated) =',chaeve,baeve,chargi,barnui
6461 C 775 CONTINUE
6462  irej=1
6463  ENDIF
6464  RETURN
6465  END
6466 C****************************************************************
6467 C
6468  SUBROUTINE parpt(IFL,PT1,PT2,IPT,NEVT)
6469 C Plot parton pt distribution
6470 C
6471  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6472  SAVE
6473  dimension pt(50,10),ypt(50,10)
6474  go to(1,2,3),ifl
6475  1 CONTINUE
6476  dpt=0.1
6477  DO 10 i=1,10
6478  DO 10 j=1,50
6479  pt(j,i)=j*dpt-dpt/2.
6480  ypt(j,i)=1.d-50
6481  10 CONTINUE
6482  RETURN
6483  2 CONTINUE
6484  ipt1=pt1/dpt+1.
6485  ipt2=pt2/dpt+1.
6486  IF(ipt1.GT.50)ipt1=50
6487  IF(ipt2.GT.50)ipt2=50
6488  ypt(ipt1,ipt)=ypt(ipt1,ipt)+1.
6489  ypt(ipt2,ipt)=ypt(ipt2,ipt)+1.
6490  ypt(ipt1,10)=ypt(ipt1,10)+1.
6491  ypt(ipt2,10)=ypt(ipt2,10)+1.
6492  RETURN
6493  3 CONTINUE
6494  DO 30 i=1,10
6495  DO 30 j=1,50
6496  ypt(j,i)=ypt(j,i)/nevt
6497  ypt(j,i)=log10(ypt(j,i)+1.d-18)
6498  30 CONTINUE
6499 C WRITE(6,*)' Parton pt distribution,vv=1,vsr=+2,sv=3,ss=4,zz=5,
6500 C * hh=6,10=all'
6501 C CALL PLOT(PT,YPT,500,10,50,0.D0,DPT,-5.D0,0.1D0)
6502  RETURN
6503  END
6504 *
6505 *
6506 *
6507 *===hkkfil=============================================================*
6508 *
6509  SUBROUTINE hkkfil(IST,ID,M1,M2,PX,PY,PZ,E,NHKKAU,KORMO,ICALL)
6510 
6511  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6512  SAVE
6513  parameter(lout=6,llook=9)
6514  parameter(tiny10=1.0d-10,tiny4=1.0d-3)
6515 
6516 *KEEP,HKKEVT.
6517 c INCLUDE (HKKEVT)
6518  parameter(nmxhkk= 89998)
6519 c PARAMETER (NMXHKK=25000)
6520  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
6521  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
6522  +(4,nmxhkk)
6523 C
6524 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
6525 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
6526 C THE POSITIONS OF THE PROJECTILE NUCLEONS
6527 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
6528 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
6529 C COMPLETELY CONSISTENT. THE TIMES IN THE
6530 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
6531 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
6532 C
6533 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
6534 C
6535 C NMXHKK: maximum numbers of entries (partons/particles) that can be
6536 C stored in the commonblock.
6537 C
6538 C NHKK: the actual number of entries stored in current event. These are
6539 C found in the first NHKK positions of the respective arrays below.
6540 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
6541 C entry.
6542 C
6543 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
6544 C = 0 : null entry.
6545 C = 1 : an existing entry, which has not decayed or fragmented.
6546 C This is the main class of entries which represents the
6547 C "final state" given by the generator.
6548 C = 2 : an entry which has decayed or fragmented and therefore
6549 C is not appearing in the final state, but is retained for
6550 C event history information.
6551 C = 3 : a documentation line, defined separately from the event
6552 C history. (incoming reacting
6553 C particles, etc.)
6554 C = 4 - 10 : undefined, but reserved for future standards.
6555 C = 11 - 20 : at the disposal of each model builder for constructs
6556 C specific to his program, but equivalent to a null line in the
6557 C context of any other program. One example is the cone defining
6558 C vector of HERWIG, another cluster or event axes of the JETSET
6559 C analysis routines.
6560 C = 21 - : at the disposal of users, in particular for event tracking
6561 C in the detector.
6562 C
6563 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
6564 C standard.
6565 C
6566 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
6567 C The value is 0 for initial entries.
6568 C
6569 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
6570 C one mother exist, in which case the value 0 is used. In cluster
6571 C fragmentation models, the two mothers would correspond to the q
6572 C and qbar which join to form a cluster. In string fragmentation,
6573 C the two mothers of a particle produced in the fragmentation would
6574 C be the two endpoints of the string (with the range in between
6575 C implied).
6576 C
6577 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
6578 C entry has not decayed, this is 0.
6579 C
6580 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
6581 C entry has not decayed, this is 0. It is assumed that the daughters
6582 C of a particle (or cluster or string) are stored sequentially, so
6583 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
6584 C daughters. Even in cases where only one daughter is defined (e.g.
6585 C K0 -> K0S) both values should be defined, to make for a uniform
6586 C approach in terms of loop constructions.
6587 C
6588 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
6589 C
6590 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
6591 C
6592 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
6593 C
6594 C PHKK(4,IHKK) : energy, in GeV.
6595 C
6596 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
6597 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
6598 C
6599 C VHKK(1,IHKK) : production vertex x position, in mm.
6600 C
6601 C VHKK(2,IHKK) : production vertex y position, in mm.
6602 C
6603 C VHKK(3,IHKK) : production vertex z position, in mm.
6604 C
6605 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
6606 C********************************************************************
6607  COMMON /nncms/ gacms,bgcms,umo,pcm,eproj,pproj
6608  COMMON /trafop/galab,bglab,blab
6609  COMMON /projk/ iprojk
6610 
6611 C IF (MODE.GT.100) THEN
6612 C WRITE(LOUT,'(1X,A,I5,A,I5)')
6613 C & 'HKKFIL: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
6614 C NHKK = NHKK-MODE+100
6615 C RETURN
6616 C ENDIF
6617  mo1 = m1
6618  mo2 = m2
6619  nhkk = nhkk+1
6620  IF (nhkk.GT.nmxhkk) THEN
6621  WRITE(lout,1000) nhkk
6622  1000 FORMAT(1x,'HKKFIL: NHKK exeeds NMXHKK = ',i7,
6623  & '! program execution stopped..')
6624  stop
6625  ENDIF
6626  IF (m1.LT.0) mo1 = nhkk+m1
6627  IF (m2.LT.0) mo2 = nhkk+m2
6628  isthkk(nhkk) = ist
6629  idhkk(nhkk) = id
6630  IF(kormo.EQ.999)THEN
6631  jmohkk(1,nhkk) = mo1
6632  jmohkk(2,nhkk) = mo2
6633  ELSE
6634  jmohkk(1,nhkk)=nhkkau+kormo-1
6635  jmohkk(2,nhkk)=0
6636  ENDIF
6637  jdahkk(1,nhkk) = 0
6638  jdahkk(2,nhkk) = 0
6639  IF (mo1.GT.0) THEN
6640  IF (jdahkk(1,mo1).NE.0) THEN
6641  jdahkk(2,mo1) = nhkk
6642  ELSE
6643  jdahkk(1,mo1) = nhkk
6644  ENDIF
6645  jdahkk(1,mo1)=nhkkau
6646  ENDIF
6647  IF (mo2.GT.0) THEN
6648  IF (jdahkk(1,mo2).NE.0) THEN
6649  jdahkk(2,mo2) = nhkk
6650  ELSE
6651  jdahkk(1,mo2) = nhkk
6652  ENDIF
6653  jdahkk(1,mo2) = nhkkau
6654  ENDIF
6655  phkk(1,nhkk) = px
6656  phkk(2,nhkk) = py
6657  phkk(3,nhkk) = pz
6658  phkk(4,nhkk) = e
6659  phkk(5,nhkk) = phkk(4,nhkk)**2-phkk(1,nhkk)**2-
6660  & phkk(2,nhkk)**2-phkk(3,nhkk)**2
6661  IF ((phkk(5,nhkk).LT.0.0d0).AND.(abs(phkk(5,nhkk)).GT.tiny4))
6662  & WRITE(lout,'(1X,A,G10.3)')
6663  & 'HKKFIL: negative mass**2 ',phkk(5,nhkk)
6664  phkk(5,nhkk) = sqrt(abs(phkk(5,nhkk)))
6665  IF (ist.EQ.88888.OR.ist.EQ.88887.OR.ist.EQ.88889) THEN
6666 * special treatment for chains:
6667 * position of chain in Lab = pos. of target nucleon
6668 * time of chain-creation in Lab = time of passage of projectile
6669 * nucleus at pos. of taget nucleus
6670  DO 1 i=1,3
6671  vhkk(i,nhkk) = vhkk(i,mo2)
6672  1 CONTINUE
6673  vhkk(4,nhkk) = vhkk(3,mo2)/blab-vhkk(3,mo1)/bglab
6674  ELSE
6675  IF(mo1.GE.1)THEN
6676  DO 2 i=1,4
6677  vhkk(i,nhkk) = vhkk(i,mo1)
6678  IF (iprojk.EQ.1) THEN
6679  whkk(i,nhkk) = whkk(i,mo1)
6680  ENDIF
6681  2 CONTINUE
6682  ENDIF
6683  ENDIF
6684 
6685  RETURN
6686  END
6687 
6688 C*********************************************************************
6689 C*********************************************************************
6690 
6691  SUBROUTINE jsparr
6692  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6693  SAVE
6694  INTEGER pycomp
6695 
6696 C...Purpose: to give program heading, or list an event, or particle
6697 C...data, or current parameter values.
6698  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
6699  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
6700  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
6701  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
6702  SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
6703  CHARACTER chap*16,chan*16,chad(5)*16
6704  dimension kbamdp(5)
6705 
6706 C...List parton/particle data table. Check whether to be listed.
6707  WRITE(mstu(11),6800)
6708  mstj24=mstj(24)
6709  mstj(24)=0
6710  kfmax=20883
6711  IF(mstu(2).NE.0) kfmax=mstu(2)
6712 C KF = PDG Particle number
6713  DO 220 kf=100,kfmax
6714 C KC = Lund particle number
6715  kc=pycomp(kf)
6716  IF(kc.EQ.0) goto 220
6717  IF(mstu(14).EQ.0.AND.kf.GT.100.AND.kc.LE.100) goto 220
6718  IF(mstu(14).GT.0.AND.kf.GT.100.AND.max(mod(kf/1000,10),
6719  & mod(kf/100,10)).GT.mstu(14)) goto 220
6720 C BAMJET particle number
6721  kbam=mcihad(kf)
6722 C BAMJET antiparticle number
6723  kabam=mcihad(-kf)
6724 
6725 C...Find Lund particle name and mass. Print information.
6726  CALL pyname(kf,chap)
6727  IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) goto 220
6728 C Lund Antiparticle Name
6729  CALL pyname(-kf,chan)
6730  pm=pymass(kf)
6731  idc1=mdcy(kc,2)
6732  idc2=mdcy(kc,2)+mdcy(kc,3)-1
6733  WRITE(mstu(11),6900)kbam,
6734  & kf,kc,idc1,idc2,chap,chan,kchg(kc,1),kchg(kc,2),
6735  & kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)
6736  WRITE(26,6900)kbam,
6737  & kf,kc,idc1,idc2,chap,chan,kchg(kc,1),kchg(kc,2),
6738  & kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)
6739 
6740 C...Particle decay: channel number, branching ration, matrix element,
6741 C...decay products.
6742  IF(kf.GT.100.AND.kc.LE.100) goto 220
6743  DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
6744  DO 200 j=1,5
6745 C Lund names of decay products
6746  CALL pyname(kfdp(idc,j),chad(j))
6747 C Bamjet numbers of decay products
6748  kbamdp(j)=mcihad(kfdp(idc,j))
6749  IF(kbamdp(j).EQ.26)kbamdp(j)=0
6750  200 CONTINUE
6751  WRITE(26,7001) idc,mdme(idc,1),mdme(idc,2),brat(idc),
6752  & (kbamdp(j),j=1,5)
6753  210 WRITE(mstu(11),7000) idc,mdme(idc,1),mdme(idc,2),brat(idc),
6754  & (chad(j),j=1,5)
6755 C The same for the antiparticle, if it exists
6756  IF(kabam.NE.410)THEN
6757  WRITE(mstu(11),6900)kabam,
6758  & -kf,-kc,idc1,idc2,chan,chap,-kchg(kc,1),kchg(kc,2),
6759  & kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)
6760  WRITE(26,6900)kabam,
6761  & -kf,-kc,idc1,idc2,chan,chap,-kchg(kc,1),kchg(kc,2),
6762  & kchg(kc,3),pm,pmas(kc,2),pmas(kc,3),pmas(kc,4),mdcy(kc,1)
6763  DO 211 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
6764  DO 201 j=1,5
6765 C KC = Lund particle number
6766  kcdp=pycomp(kfdp(idc,j))
6767  IF(kcdp.LE.0.OR.kcdp.GT.500)THEN
6768 C WRITE(MSTU(11),'(A,I10)')' KCDP= ',KCDP
6769  kcdp=1
6770  ENDIF
6771 C Bamjet numbers of decay products
6772  kfdpm=-kfdp(idc,j)
6773  IF(kchg(kcdp,3).EQ.0)kfdpm=kfdp(idc,j)
6774  kbamdp(j)=mcihad(kfdpm)
6775  IF(kbamdp(j).EQ.26)kbamdp(j)=0
6776 C Lund names of decay products
6777  CALL pyname(kfdpm,chad(j))
6778  201 CONTINUE
6779  WRITE(26,7001) idc,mdme(idc,1),mdme(idc,2),brat(idc),
6780  & (kbamdp(j),j=1,5)
6781  211 WRITE(mstu(11),7000) idc,mdme(idc,1),mdme(idc,2),brat(idc),
6782  & (chad(j),j=1,5)
6783  ENDIF
6784  220 CONTINUE
6785  mstj(24)=mstj24
6786 
6787 
6788 C...Format statements for output on unit MSTU(11) (by default 6).
6789  6800 FORMAT(///30x,'Particle/parton data table'//1x,'BAM',
6790  &1x,'ABAM',1x,'KF',1x,'KC',1x,'DCF',1x,'DCL',1x,
6791  &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
6792  &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
6793  &1x,'ME',3x,'Br.rat.',4x,'decay products')
6794  6900 FORMAT(/1x,i4,i6,i4,2i5,a16,a16,3i3,1x,f12.5,2(1x,f11.5),
6795  &1x,f12.5,1x,i2)
6796  7000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f8.5,4x,5a16)
6797  7001 FORMAT(10x,i4,2x,i3,2x,i3,2x,f8.5,4x,5i5)
6798 
6799  RETURN
6800  END
6801 
6802 C*********************************************************************
6803 
Generated on Sat May 25 2013 14:32:28 for Geant4 by   doxygen 1.8.4