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