Geant4_10
dpm25nuc3dpm.f
Go to the documentation of this file.
1  SUBROUTINE saptre(AM1,G1,BGX1,BGY1,BGZ1,
2  & am2,g2,bgx2,bgy2,bgz2)
3  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4  SAVE
5 C SELECT PT FOR CHAIN PAIRS, WHICH ARE RESONANCES
6  b3=4.
7  e1=g1*am1
8  px1=bgx1*am1
9  py1=bgy1*am1
10  pz1=bgz1*am1
11  e2=g2*am2
12  px2=bgx2*am2
13  py2=bgy2*am2
14  pz2=bgz2*am2
15 C SAMPLE TRANSVERSE MOMENTUM LIKE IN BAMJET
16 C ES DEFINED AS ES=SQRT(PT**2+AM**2)-AM
17  esmax1=e1-am1
18  esmax2=e2-am2
19  esmax=min(esmax1,esmax2)
20  IF(esmax.LE.0.05d0) RETURN
21  hma=am1
22  IF (b3*esmax.GT.60.d0)THEN
23  exeb=0.
24  ELSE
25  exeb=exp(-b3*esmax)
26  ENDIF
27  bexp=hma*(1.-exeb)/b3
28  axexp=(1.d0-(b3*esmax-1.d0)*exeb)/b3**2
29  wa=axexp/(bexp+axexp)
30  xab=rndm(wu)
31  10 CONTINUE
32  IF (xab.LT.wa)THEN
33  x=rndm(v)
34  y=rndm(v)
35  es=-2./(b3**2)*log(x*y+1.e-7)
36  ELSE
37  x=rndm(v)
38  es=abs(-log(x+1.e-7)/b3)
39  END IF
40  IF(es.GT.esmax) goto10
41  es=es+hma
42  hps=sqrt((es-hma)*(es+hma))
43  20 CONTINUE
44  CALL dsfecf(sfe,cfe)
45  sip=sfe
46  cop=cfe
47  hpx=hps*cop
48  hpy=hps*sip
49  pz1nsq=pz1**2-hps**2-2.*px1*hpx-2.*py1*hpy
50  pz2nsq=pz2**2-hps**2+2.*px2*hpx+2.*py2*hpy
51  IF(pz1nsq.LT.0.001d0.OR.pz2nsq.LT.0.001d0) RETURN
52  pz1=sign(sqrt(pz1nsq),pz1)
53  pz2=sign(sqrt(pz2nsq),pz2)
54  px1=px1+hpx
55  py1=py1+hpy
56  px2=px2-hpx
57  py2=py2-hpy
58  bgx1=px1/am1
59  bgy1=py1/am1
60  bgz1=pz1/am1
61  bgx2=px2/am2
62  bgy2=py2/am2
63  bgz2=pz2/am2
64 C WRITE(6,1001) HPX,HPY
65 C1001 FORMAT(' HPX,HPY ',2F10.3)
66  RETURN
67  END
68 *-- Author :
69 C
70 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
71 C
72  SUBROUTINE sltraf(GA,BGA,EIN,PZIN,EOUT,PZOUT)
73  IMPLICIT DOUBLE PRECISION (a-h,o-z)
74  SAVE
75  pzout=ga*pzin - bga*ein
76  eout=ga*ein - bga*pzin
77  RETURN
78  END
79 *-- Author :
80 C
81 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
82 C
83  SUBROUTINE nucmom
84  IMPLICIT DOUBLE PRECISION (a-h,o-z)
85  SAVE
86 C***
87 C FERMI-MOMENTA FOR ALL NUCLEONS
88 C TRANSFORMED INTO NN-CMS
89 C FOR INCIDENT HADRONS USE CMS MOMENTUM
90 C***
91 *KEEP,INTMX.
92  parameter(intmx=2488,intmd=252)
93 *KEEP,DXQX.
94 C INCLUDE (XQXQ)
95 * NOTE: INTMX set via INCLUDE(INTMX)
96  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
97  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
98  * ,xpsu(248),xtsu(248)
99  * ,xpsut(248),xtsut(248)
100 *KEEP,INTNEW.
101  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
102  +ixpv,ixps,ixtv,ixts, intvv1(248),
103  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
104  +intss1(intmx),intss2(intmx),
105  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
106  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
107 
108 C /INTNEW/
109 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
110 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
111 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
112 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
113 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
114 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
115 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
116 C FROM PROJECTILE/TARGET NUCLEI
117 C-------------------
118 *KEEP,IFROTO.
119  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
120  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
121  +jhkknt
122  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
123  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
124  & mhkkhh(intmx),
125  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
126 *KEEP,LOZUO.
127  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
128  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
129  +intlo(intmx),inloss(intmx)
130 C /LOZUO/
131 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
132 C REJECTED IN KKEVT
133 C------------------
134 *KEEP,DIQI.
135  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
136  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
137  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
138  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
139 *KEEP,HKKEVT.
140 c INCLUDE (HKKEVT)
141  parameter(nmxhkk= 89998)
142 c PARAMETER (NMXHKK=25000)
143  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
144  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
145  +(4,nmxhkk)
146 C
147 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
148 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
149 C THE POSITIONS OF THE PROJECTILE NUCLEONS
150 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
151 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
152 C COMPLETELY CONSISTENT. THE TIMES IN THE
153 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
154 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
155 C
156 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
157 C
158 C NMXHKK: maximum numbers of entries (partons/particles) that can be
159 C stored in the commonblock.
160 C
161 C NHKK: the actual number of entries stored in current event. These are
162 C found in the first NHKK positions of the respective arrays below.
163 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
164 C entry.
165 C
166 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
167 C = 0 : null entry.
168 C = 1 : an existing entry, which has not decayed or fragmented.
169 C This is the main class of entries which represents the
170 C "final state" given by the generator.
171 C = 2 : an entry which has decayed or fragmented and therefore
172 C is not appearing in the final state, but is retained for
173 C event history information.
174 C = 3 : a documentation line, defined separately from the event
175 C history. (incoming reacting
176 C particles, etc.)
177 C = 4 - 10 : undefined, but reserved for future standards.
178 C = 11 - 20 : at the disposal of each model builder for constructs
179 C specific to his program, but equivalent to a null line in the
180 C context of any other program. One example is the cone defining
181 C vector of HERWIG, another cluster or event axes of the JETSET
182 C analysis routines.
183 C = 21 - : at the disposal of users, in particular for event tracking
184 C in the detector.
185 C
186 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
187 C standard.
188 C
189 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
190 C The value is 0 for initial entries.
191 C
192 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
193 C one mother exist, in which case the value 0 is used. In cluster
194 C fragmentation models, the two mothers would correspond to the q
195 C and qbar which join to form a cluster. In string fragmentation,
196 C the two mothers of a particle produced in the fragmentation would
197 C be the two endpoints of the string (with the range in between
198 C implied).
199 C
200 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
201 C entry has not decayed, this is 0.
202 C
203 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
204 C entry has not decayed, this is 0. It is assumed that the daughters
205 C of a particle (or cluster or string) are stored sequentially, so
206 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
207 C daughters. Even in cases where only one daughter is defined (e.g.
208 C K0 -> K0S) both values should be defined, to make for a uniform
209 C approach in terms of loop constructions.
210 C
211 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
212 C
213 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
214 C
215 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
216 C
217 C PHKK(4,IHKK) : energy, in GeV.
218 C
219 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
220 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
221 C
222 C VHKK(1,IHKK) : production vertex x position, in mm.
223 C
224 C VHKK(2,IHKK) : production vertex y position, in mm.
225 C
226 C VHKK(3,IHKK) : production vertex z position, in mm.
227 C
228 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
229 C********************************************************************
230 *KEEP,DPRIN.
231  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
232 *KEEP,NNCMS.
233  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
234 *KEEP,NUCC.
235  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
236 *KEEP,DPAR.
237 C /DPAR/ CONTAINS PARTICLE PROPERTIES
238 C ANAME = LITERAL NAME OF THE PARTICLE
239 C AAM = PARTICLE MASS IN GEV
240 C GA = DECAY WIDTH
241 C TAU = LIFE TIME OF INSTABLE PARTICLES
242 C IICH = ELECTRIC CHARGE OF THE PARTICLE
243 C IIBAR = BARYON NUMBER
244 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
245 C
246  CHARACTER*8 aname
247  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
248  +iibar(210),k1(210),k2(210)
249 C------------------
250 *KEEP,NUCIMP.
251  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
252  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
253  +prebin,taebin,fermod,etacou
254 *KEEP,PROJK.
255  COMMON /projk/ iprojk
256 *KEND.
257  IF(ijproj.EQ.5)RETURN
258 C
259 C****************************** PROJECTILE
260 C - INTERACTING PROJECTILES ISTHKK=11
261  DO 10 j=1,ip
262 C IF(ISTHKK(J).EQ.11) THEN
263  kk=kkproj(j)
264  prmom(1,j)=phkk(1,j)
265  prmom(2,j)=phkk(2,j)
266  gaproj=eproj/aam(kk)
267  bgproj=pproj/aam(kk)
268  CALL sltraf(gaproj,-bgproj, phkk(4,j),phkk(3,j),prmom4,prmom3)
269 
270  CALL sltraf(gamcm,+bgcm, prmom4,prmom3,prmom(4,j),prmom(3,j))
271 
272  prmom(5,j)=sqrt( abs((prmom(4,j)-aam(kk)) *(prmom(4,j)+aam(kk)
273  + )))
274 C ENDIF
275  10 CONTINUE
276 C
277 C------------------------------ TARGET
278 C INTERACTING TARGET NUCLEONS ISTHKK=12
279  ihkk=ip
280  DO 20 j=1,it
281  ihkk=ihkk + 1
282 C IF(ISTHKK(IHKK).EQ.12) THEN
283  kk=kktarg(j)
284  tamom(1,j)=phkk(1,ihkk)
285  tamom(2,j)=phkk(2,ihkk)
286  CALL sltraf(gamcm,bgcm, phkk(4,ihkk),phkk(3,ihkk),tamom(4,j),
287  + tamom(3,j))
288  tamom(5,j)=sqrt(abs( (tamom(4,j)-aam(kk))
289  + *(tamom(4,j)+aam(kk))))
290 
291 C ENDIF
292  20 CONTINUE
293 C
294  IF(ipev.GE.6) THEN
295  WRITE(6,'(/A,I5/5X,A)') ' NUCMOM: IP=',ip,
296  + ' J,IPVQ(J),IPPV1(J),IPPV2(J),ISTHKK,KKPROJ,PRMOM'
297  DO 30 j=1,ip
298  WRITE(6,'(I4,5I3,5(1PE11.3))') j,isthkk(j),kkproj(j), ipvq(j),
299  + ippv1(j),ippv2(j), (prmom(jj,j),jj=1,5)
300 
301  30 CONTINUE
302 C
303  WRITE(6,'(/A,I5/5X,A)') ' NUCMOM: IT=',it,
304  + ' J,ITVQ(J),ITTV1(J),ITTV2(J),ISTHKK,KKTARG,TAMOM'
305  ihkk=ip
306  DO 40 j=1,it
307  ihkk=ihkk + 1
308  WRITE(6,'(I4,5I3,5(1PE11.3))') j,isthkk(ihkk),kktarg(j), itvq
309  + (j),ittv1(j),ittv2(j), (tamom(jj,j),jj=1,5)
310 
311  40 CONTINUE
312  ENDIF
313 C
314  RETURN
315  END
316 *-- Author :
317 C
318 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
319 C
320  SUBROUTINE fer4m(PFERM,PXT,PYT,PZT,ET,KT)
321  IMPLICIT DOUBLE PRECISION (a-h,o-z)
322  SAVE
323 C
324 C SAMPLE FERMI MOMENTUM FROM DISTRIBUTION WITH T=0
325 C-----------
326 *KEEP,DPAR.
327 C /DPAR/ CONTAINS PARTICLE PROPERTIES
328 C ANAME = LITERAL NAME OF THE PARTICLE
329 C AAM = PARTICLE MASS IN GEV
330 C GA = DECAY WIDTH
331 C TAU = LIFE TIME OF INSTABLE PARTICLES
332 C IICH = ELECTRIC CHARGE OF THE PARTICLE
333 C IIBAR = BARYON NUMBER
334 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
335 C
336  CHARACTER*8 aname
337  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
338  +iibar(210),k1(210),k2(210)
339 C------------------
340 *KEEP,DROPPT.
341  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
342  +ishmal,lpauli
343  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
344  +ipadis,ishmal,lpauli
345 *KEND.
346 C-----------
347  IF (fermp) THEN
348  CALL dfermi(pabs)
349  pabs=pferm*pabs
350 C SAMPLE ANGLES
351  CALL dpoli(polc,pols)
352  CALL dsfecf(sfe,cfe)
353 C
354  cxta=pols*cfe
355  cyta=pols*sfe
356  czta=polc
357  et=sqrt(pabs*pabs+aam(kt)**2)
358  pxt=cxta*pabs
359  pyt=cyta*pabs
360  pzt=czta*pabs
361 C
362  ELSE
363  et=aam(kt)
364  pxt=0.
365  pyt=0.
366  pzt=0.
367  ENDIF
368 C
369  RETURN
370  END
371 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
372 C
373  SUBROUTINE fer4mp(IP,PFERM,PXT,PYT,PZT,ET,KT)
374  IMPLICIT DOUBLE PRECISION (a-h,o-z)
375  SAVE
376  COMMON /ferfor/iferfo
377 C
378 C SAMPLE FERMI MOMENTUM FROM DISTRIBUTION WITH T=0
379 C-----------
380 *KEEP,DPAR.
381 C /DPAR/ CONTAINS PARTICLE PROPERTIES
382 C ANAME = LITERAL NAME OF THE PARTICLE
383 C AAM = PARTICLE MASS IN GEV
384 C GA = DECAY WIDTH
385 C TAU = LIFE TIME OF INSTABLE PARTICLES
386 C IICH = ELECTRIC CHARGE OF THE PARTICLE
387 C IIBAR = BARYON NUMBER
388 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
389 C
390  CHARACTER*8 aname
391  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
392  +iibar(210),k1(210),k2(210)
393 C------------------
394 *KEEP,DROPPT.
395  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
396  +ishmal,lpauli
397  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
398  +ipadis,ishmal,lpauli
399 *KEND.
400 C-----------
401  IF (fermp) THEN
402  IF(iferfo.EQ.1)THEN
403  CALL dfermi(pabs)
404  pabs=pferm*pabs
405  ENDIF
406  IF(iferfo.EQ.2)CALL dfatpr(ip,pabs)
407 C SAMPLE ANGLES
408  CALL dpoli(polc,pols)
409  CALL dsfecf(sfe,cfe)
410 C
411  cxta=pols*cfe
412  cyta=pols*sfe
413  czta=polc
414  et=sqrt(pabs*pabs+aam(kt)**2)
415  pxt=cxta*pabs
416  pyt=cyta*pabs
417  pzt=czta*pabs
418 C
419  ELSE
420  et=aam(kt)
421  pxt=0.
422  pyt=0.
423  pzt=0.
424  ENDIF
425 C
426  RETURN
427  END
428 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
429 C
430  SUBROUTINE fer4mt(IT,PFERM,PXT,PYT,PZT,ET,KT)
431  IMPLICIT DOUBLE PRECISION (a-h,o-z)
432  SAVE
433  COMMON /ferfor/iferfo
434 C
435 C SAMPLE FERMI MOMENTUM FROM DISTRIBUTION WITH T=0
436 C-----------
437 *KEEP,DPAR.
438 C /DPAR/ CONTAINS PARTICLE PROPERTIES
439 C ANAME = LITERAL NAME OF THE PARTICLE
440 C AAM = PARTICLE MASS IN GEV
441 C GA = DECAY WIDTH
442 C TAU = LIFE TIME OF INSTABLE PARTICLES
443 C IICH = ELECTRIC CHARGE OF THE PARTICLE
444 C IIBAR = BARYON NUMBER
445 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
446 C
447  CHARACTER*8 aname
448  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
449  +iibar(210),k1(210),k2(210)
450 C------------------
451 *KEEP,DROPPT.
452  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
453  +ishmal,lpauli
454  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
455  +ipadis,ishmal,lpauli
456 *KEND.
457 C-----------
458 C WRITE(6,*)' FERMP',FERMP
459  IF (fermp) THEN
460  IF(iferfo.EQ.1)THEN
461  CALL dfermi(pabs)
462 CWRITE(6,*)' PABS',PABS
463  pabs=pferm*pabs
464 CWRITE(6,*)' PABS',PABS
465  ENDIF
466  IF(iferfo.EQ.2)CALL dfatta(it,pabs)
467 C SAMPLE ANGLES
468 CWRITE(6,*)' PABS',PABS
469  CALL dpoli(polc,pols)
470  CALL dsfecf(sfe,cfe)
471 C
472  cxta=pols*cfe
473  cyta=pols*sfe
474  czta=polc
475  et=sqrt(pabs*pabs+aam(kt)**2)
476  pxt=cxta*pabs
477  pyt=cyta*pabs
478  pzt=czta*pabs
479 C
480  ELSE
481  et=aam(kt)
482  pxt=0.
483  pyt=0.
484  pzt=0.
485  ENDIF
486 C
487  RETURN
488  END
489  SUBROUTINE dfatta(IT,PABS)
490  IMPLICIT DOUBLE PRECISION (a-h,o-z)
491  SAVE
492 C FERMI MOMENTUM A LA C. CIOFI DEGLI ATTI ET AL PRC53(96)1689
493  dimension par10(6),par20(6),par30(6),par40(6),par50(6),
494  * par60(6),par11(6),par21(6),par31(6),par41(6),
495  * aia(6),att(101),catt(101),aka(101)
496  common/fattad/daka(101),fatt(101)
497  DATA par10/1.61d0,2.74d0,3.24d0,3.57d0,1.80d0,0.d0/
498  DATA par20/2.66d0,3.33d0,3.72d0,4.97d0,4.77d0,0.d0/
499  DATA par30/3.54d0,6.66d0,0.d0,0.d0,0.d0,0.d0/
500  DATA par40/0.d0,0.d0,11.1d0,19.8d0,25.5d0,0.d0/
501  DATA par50/0.d0,0.d0,0.d0,15.d0,0.d0,0.d0/
502  DATA par60/0.d0,0.d0,0.d0,0.d0,40.3d0,0.d0/
503  DATA par11/.426d0,.326d0,.419d0,.230d0,.275d0,0.d0/
504  DATA par21/1.6d0,1.4d0,1.77d0,1.2d0,1.01d0,0.d0/
505  DATA par31/.0237d0,.0263d0,.0282d0,.0286d0,.0304d0,0.d0/
506  DATA par41/.22d0,.22d0,.22d0,.22d0,.22d0,0.d0/
507  DATA aia/12.d0,16.d0,40.d0,56.d0,208.d0,209.d0/
508  DATA init/0/
509  ait=it
510  IF(init.EQ.0)THEN
511 C INITIALIZATION
512 C INTERPOLATE PARAMETERS
513  DO 1 i=1,4
514  IF(ait.GE.aia(i).AND.ait.LT.aia(i+1))THEN
515  dait=(ait-aia(i))/(aia(i+1)-aia(i))
516  dbit=1.d0-dait
517  iii=i
518  ENDIF
519  1 CONTINUE
520  IF(ait.LT.aia(1))THEN
521  dbit=1.d0
522  dait=0.d0
523  iii=1
524  ENDIF
525  IF(ait.GE.aia(5))THEN
526  dbit=1.d0
527  dait=0.d0
528  iii=5
529  ENDIF
530  a0=dbit*par10(iii)+dait*par10(iii+1)
531  b0=dbit*par20(iii)+dait*par20(iii+1)
532  c0=dbit*par30(iii)+dait*par30(iii+1)
533  d0=dbit*par40(iii)+dait*par40(iii+1)
534  e0=dbit*par50(iii)+dait*par50(iii+1)
535  f0=dbit*par60(iii)+dait*par60(iii+1)
536  a1=dbit*par11(iii)+dait*par11(iii+1)
537  b1=dbit*par21(iii)+dait*par21(iii+1)
538  c1=dbit*par31(iii)+dait*par31(iii+1)
539  d1=dbit*par41(iii)+dait*par41(iii+1)
540  init=1
541  dk=0.04d0
542  catt(1)=0.d0
543  DO 2 i=1,101
544  ai=i
545  ak=(ai-1.d0)*dk
546  aka(i)=ak
547  daka(i)=aka(i)
548  att(i)=ak**2*(a0*exp(-b0*ak**2)*(1.d0+c0*ak**2+
549  * d0*ak**4+e0*ak**6+f0*ak**8)+
550  * a1*exp(-b1*ak**2)+c1*exp(-d1*ak**2))
551  IF(i.GT.1)catt(i)=catt(i-1)+att(i)
552  2 CONTINUE
553  DO 3 i=1,101
554  catt(i)=catt(i)/catt(101)
555  fatt(i)=0.d0
556  3 CONTINUE
557  ENDIF
558 C END INITIALIZATION
559  rndfa=rndm(v)
560  DO 10 i=1,101
561  IF(rndfa.LT.catt(i))THEN
562  iatt=i
563  go to 11
564  ENDIF
565  10 CONTINUE
566  11 CONTINUE
567  pabs=aka(iatt)*0.197d0
568  fatt(iatt)=fatt(iatt)+1.d0/pabs**2
569  RETURN
570  END
571  SUBROUTINE dfatpr(IP,PABS)
572  IMPLICIT DOUBLE PRECISION (a-h,o-z)
573  SAVE
574 C FERMI MOMENTUM A LA C. CIOFI DEGLI ATTI ET AL PRC53(96)1689
575  dimension par10(6),par20(6),par30(6),par40(6),par50(6),
576  * par60(6),par11(6),par21(6),par31(6),par41(6),
577  * aia(6),att(101),catt(101),aka(101)
578  DATA par10/1.61d0,2.74d0,3.24d0,3.57d0,1.80d0,0.d0/
579  DATA par20/2.66d0,3.33d0,3.72d0,4.97d0,4.77d0,0.d0/
580  DATA par30/3.54d0,6.66d0,0.d0,0.d0,0.d0,0.d0/
581  DATA par40/0.d0,0.d0,11.1d0,19.8d0,25.5d0,0.d0/
582  DATA par50/0.d0,0.d0,0.d0,15.d0,0.d0,0.d0/
583  DATA par60/0.d0,0.d0,0.d0,0.d0,40.3d0,0.d0/
584  DATA par11/.426d0,.326d0,.419d0,.230d0,.275d0,0.d0/
585  DATA par21/1.6d0,1.4d0,1.77d0,1.2d0,1.01d0,0.d0/
586  DATA par31/.0237d0,.0263d0,.0282d0,.0286d0,.0304d0,0.d0/
587  DATA par41/.22d0,.22d0,.22d0,.22d0,.22d0,0.d0/
588  DATA aia/12.d0,16.d0,40.d0,56.d0,208.d0,209.d0/
589  DATA init/0/
590  ait=ip
591  IF(init.EQ.0)THEN
592 C INITIALIZATION
593 C INTERPOLATE PARAMETERS
594  DO 1 i=1,4
595  IF(ait.GE.aia(i).AND.ait.LT.aia(i+1))THEN
596  dait=(ait-aia(i))/(aia(i+1)-aia(i))
597  dbit=1.d0-dait
598  iii=i
599  ENDIF
600  1 CONTINUE
601  IF(ait.LT.aia(1))THEN
602  dbit=1.d0
603  dait=0.d0
604  iii=1
605  ENDIF
606  IF(ait.GE.aia(5))THEN
607  dbit=1.d0
608  dait=0.d0
609  iii=5
610  ENDIF
611  a0=dbit*par10(iii)+dait*par10(iii+1)
612  b0=dbit*par20(iii)+dait*par20(iii+1)
613  c0=dbit*par30(iii)+dait*par30(iii+1)
614  d0=dbit*par40(iii)+dait*par40(iii+1)
615  e0=dbit*par50(iii)+dait*par50(iii+1)
616  f0=dbit*par60(iii)+dait*par60(iii+1)
617  a1=dbit*par11(iii)+dait*par11(iii+1)
618  b1=dbit*par21(iii)+dait*par21(iii+1)
619  c1=dbit*par31(iii)+dait*par31(iii+1)
620  d1=dbit*par41(iii)+dait*par41(iii+1)
621  init=1
622  dk=0.04d0
623  catt(1)=0.d0
624  DO 2 i=1,101
625  ai=i
626  ak=(ai-1.d0)*dk
627  aka(i)=ak
628  att(i)=ak**2*(a0*exp(-b0*ak**2)*(1.d0+c0*ak**2+
629  * d0*ak**4+e0*ak**6+f0*ak**8)+
630  * a1*exp(-b1*ak**2)+c1*exp(-d1*ak**2))
631  IF(i.GT.1)catt(i)=catt(i-1)+att(i)
632  2 CONTINUE
633  DO 3 i=1,101
634  catt(i)=catt(i)/catt(101)
635  3 CONTINUE
636  ENDIF
637 C END INITIALIZATION
638  rndfa=rndm(v)
639  DO 10 i=1,101
640  IF(rndfa.LT.catt(i))THEN
641  iatt=i
642  go to 11
643  ENDIF
644  10 CONTINUE
645  11 CONTINUE
646  pabs=aka(iatt)*0.197d0
647  RETURN
648  END
649 *-- Author :
650 C
651 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
652 C
653  SUBROUTINE flksam
654  IMPLICIT DOUBLE PRECISION (a-h,o-z)
655  SAVE
656 C QUARK CONTENT
657 C OF PROJECTILE AND TARGET
658 C (HADRONS / ALL NUCLEONS)
659 C---------------------------------------------------------------------
660 *KEEP,INTMX.
661  parameter(intmx=2488,intmd=252)
662 *KEEP,DXQX.
663 C INCLUDE (XQXQ)
664 * NOTE: INTMX set via INCLUDE(INTMX)
665  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
666  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
667  * ,xpsu(248),xtsu(248)
668  * ,xpsut(248),xtsut(248)
669 *KEEP,INTNEW.
670  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
671  +ixpv,ixps,ixtv,ixts, intvv1(248),
672  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
673  +intss1(intmx),intss2(intmx),
674  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
675  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
676 
677 C /INTNEW/
678 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
679 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
680 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
681 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
682 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
683 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
684 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
685 C FROM PROJECTILE/TARGET NUCLEI
686 C-------------------
687 *KEEP,IFROTO.
688  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
689  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
690  +jhkknt
691  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
692  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
693  & mhkkhh(intmx),
694  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
695 *KEEP,LOZUO.
696  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
697  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
698  +intlo(intmx),inloss(intmx)
699 C /LOZUO/
700 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
701 C REJECTED IN KKEVT
702 C------------------
703 *KEEP,DIQI.
704  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
705  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
706  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
707  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
708 *KEEP,HKKEVT.
709 c INCLUDE (HKKEVT)
710  parameter(nmxhkk= 89998)
711 c PARAMETER (NMXHKK=25000)
712  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
713  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
714  +(4,nmxhkk)
715 C
716 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
717 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
718 C THE POSITIONS OF THE PROJECTILE NUCLEONS
719 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
720 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
721 C COMPLETELY CONSISTENT. THE TIMES IN THE
722 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
723 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
724 C
725 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
726 C
727 C NMXHKK: maximum numbers of entries (partons/particles) that can be
728 C stored in the commonblock.
729 C
730 C NHKK: the actual number of entries stored in current event. These are
731 C found in the first NHKK positions of the respective arrays below.
732 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
733 C entry.
734 C
735 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
736 C = 0 : null entry.
737 C = 1 : an existing entry, which has not decayed or fragmented.
738 C This is the main class of entries which represents the
739 C "final state" given by the generator.
740 C = 2 : an entry which has decayed or fragmented and therefore
741 C is not appearing in the final state, but is retained for
742 C event history information.
743 C = 3 : a documentation line, defined separately from the event
744 C history. (incoming reacting
745 C particles, etc.)
746 C = 4 - 10 : undefined, but reserved for future standards.
747 C = 11 - 20 : at the disposal of each model builder for constructs
748 C specific to his program, but equivalent to a null line in the
749 C context of any other program. One example is the cone defining
750 C vector of HERWIG, another cluster or event axes of the JETSET
751 C analysis routines.
752 C = 21 - : at the disposal of users, in particular for event tracking
753 C in the detector.
754 C
755 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
756 C standard.
757 C
758 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
759 C The value is 0 for initial entries.
760 C
761 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
762 C one mother exist, in which case the value 0 is used. In cluster
763 C fragmentation models, the two mothers would correspond to the q
764 C and qbar which join to form a cluster. In string fragmentation,
765 C the two mothers of a particle produced in the fragmentation would
766 C be the two endpoints of the string (with the range in between
767 C implied).
768 C
769 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
770 C entry has not decayed, this is 0.
771 C
772 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
773 C entry has not decayed, this is 0. It is assumed that the daughters
774 C of a particle (or cluster or string) are stored sequentially, so
775 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
776 C daughters. Even in cases where only one daughter is defined (e.g.
777 C K0 -> K0S) both values should be defined, to make for a uniform
778 C approach in terms of loop constructions.
779 C
780 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
781 C
782 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
783 C
784 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
785 C
786 C PHKK(4,IHKK) : energy, in GeV.
787 C
788 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
789 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
790 C
791 C VHKK(1,IHKK) : production vertex x position, in mm.
792 C
793 C VHKK(2,IHKK) : production vertex y position, in mm.
794 C
795 C VHKK(3,IHKK) : production vertex z position, in mm.
796 C
797 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
798 C********************************************************************
799 *KEEP,NUCC.
800  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
801 *KEEP,DPAR.
802 C /DPAR/ CONTAINS PARTICLE PROPERTIES
803 C ANAME = LITERAL NAME OF THE PARTICLE
804 C AAM = PARTICLE MASS IN GEV
805 C GA = DECAY WIDTH
806 C TAU = LIFE TIME OF INSTABLE PARTICLES
807 C IICH = ELECTRIC CHARGE OF THE PARTICLE
808 C IIBAR = BARYON NUMBER
809 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
810 C
811  CHARACTER*8 aname
812  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
813  +iibar(210),k1(210),k2(210)
814 C------------------
815 *KEEP,DPRIN.
816  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
817 *KEEP,PROJK.
818  COMMON /projk/ iprojk
819 *KEND.
820 C----------
821  dimension ihkkq(-6:6),ihkkqq(-3:3,-3:3)
822  DATA ihkkq/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
823  DATA ihkkqq/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
824  +-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
825  +0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
826 C----------------------------------------------------------------------
827 C
828 C FLAVORS OF VALENCE QUARKS FROM PROJECTILE HADRON/NUCLEONS
829 C
830 C-----
831 C
832  IF(ipev.GE.3) WRITE(6,'(A,6I4)')
833  +' FLKSAM-ENTRY: IT,ITZ, IP,IPZ, IJPROJ,IBPROJ', it,itz,ip,ipz,
834  +ijproj,ibproj
835 C
836  ixpss=ixps
837  ixtss=ixts
838  ixpvv=ixpv
839  ixtvv=ixtv
840  DO 10 jp=1,ixpvv
841  ifr=ifrovp(jp)
842  kproj=kkproj(ifr)
843  CALL flahad(kproj,ibproj,ipvq(jp),ippv1(jp),ippv2(jp))
844 C
845  IF (ipev.GE.6) WRITE (6,1000)ipvq(jp),ippv1(jp),ippv2(jp)
846  1000 FORMAT (' FLKSAM: IPVQ,IPPV1,IPPV2 ',3i4)
847 C
848  jhkk=jhkkpv(jp)
849  jhkkq=jhkk - 1
850  idhkk(jhkkq)=ihkkq(ipvq(jp))
851  IF(ibproj.EQ.0) THEN
852  idhkk(jhkk)=ihkkq(ippv1(jp))
853  ELSE
854  idhkk(jhkk)=ihkkqq(ippv1(jp),ippv2(jp))
855  ENDIF
856 C
857  10 CONTINUE
858 C
859 C*********************************************************************
860 C
861 C-------------------------------SAMPLING PROJECTILE SEA FLAVORS-------
862 C
863 C*********************************************************************
864 C
865  DO 20 n=1,ixpss
866 C
867  jhkkaq=jhkkps(n)
868  jhkkq=jhkkaq - 1
869  idhkk(jhkkq)=ihkkq(ipsq(n))
870  idhkk(jhkkaq)=ihkkq(ipsaq(n))
871 C
872  20 CONTINUE
873 C--------------------------------------------------------------------
874 C
875 C FLAVORS OF VALENCE QUARKS FROM TARGET HADRON / ALL NUCLEONS
876 C
877 C-----
878 C
879  DO 30 jt=1,ixtvv
880  ifr=ifrovt(jt)
881  ktarg=kktarg(ifr)
882  ibtarg=iibar(ktarg)
883  CALL flahad(ktarg,ibtarg,itvq(jt),ittv1(jt),ittv2(jt))
884 C
885  jhkk=jhkktv(jt)
886  jhkkq=jhkk - 1
887  idhkk(jhkkq)=ihkkq(itvq(jt))
888  IF(ibtarg.EQ.0) THEN
889  idhkk(jhkk)=ihkkq(ittv1(jt))
890  ELSE
891  idhkk(jhkk)=ihkkqq(ittv1(jt),ittv2(jt))
892  ENDIF
893  IF (ipev.GE.8) WRITE (6,'(A,8I4)')
894  + ' FLKSAM: KTARG,ITVQ(JT),ITTV1(JT),ITTV2(JT)', ktarg,itvq(jt),
895  + ittv1(jt),ittv2(jt), idhkk(jhkkq),jhkkq,idhkk(jhkk),jhkk
896 
897 C
898 C
899  30 CONTINUE
900 C
901 C*********************************************************************
902 C
903 C-------------------------------SAMPLING TARGET SEA FLAVORS-------
904 C
905 C*********************************************************************
906 C
907  DO 40 n=1,ixtss
908 C
909  jhkkaq=jhkkts(n)
910  jhkkq=jhkkaq - 1
911  idhkk(jhkkq)=ihkkq(itsq(n))
912  idhkk(jhkkaq)=ihkkq(itsaq(n))
913 C
914  40 CONTINUE
915 C
916  RETURN
917  END
918 *-- Author :
919 C
920 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
921 C
922  SUBROUTINE flksaa(NN,ECM)
923  IMPLICIT DOUBLE PRECISION (a-h,o-z)
924  SAVE
925 C QUARK CONTENT
926 C OF PROJECTILE AND TARGET
927 C (HADRONS / ALL NUCLEONS)
928 C first run sea quark flavors
929 C---------------------------------------------------------------------
930 *KEEP,INTMX.
931  parameter(intmx=2488,intmd=252)
932 *KEEP,DXQX.
933 C INCLUDE (XQXQ)
934 * NOTE: INTMX set via INCLUDE(INTMX)
935  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
936  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
937  * ,xpsu(248),xtsu(248)
938  * ,xpsut(248),xtsut(248)
939 *KEEP,INTNEW.
940  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
941  +ixpv,ixps,ixtv,ixts, intvv1(248),
942  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
943  +intss1(intmx),intss2(intmx),
944  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
945  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
946 
947 C /INTNEW/
948 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
949 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
950 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
951 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
952 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
953 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
954 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
955 C FROM PROJECTILE/TARGET NUCLEI
956 C-------------------
957 *KEEP,IFROTO.
958  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
959  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
960  +jhkknt
961  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
962  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
963  & mhkkhh(intmx),
964  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
965 *KEEP,LOZUO.
966  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
967  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
968  +intlo(intmx),inloss(intmx)
969 C /LOZUO/
970 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
971 C REJECTED IN KKEVT
972 C------------------
973 *KEEP,DIQI.
974  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
975  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
976  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
977  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
978 *KEEP,HKKEVT.
979 c INCLUDE (HKKEVT)
980  parameter(nmxhkk= 89998)
981 c PARAMETER (NMXHKK=25000)
982  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
983  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
984  +(4,nmxhkk)
985 C
986 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
987 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
988 C THE POSITIONS OF THE PROJECTILE NUCLEONS
989 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
990 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
991 C COMPLETELY CONSISTENT. THE TIMES IN THE
992 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
993 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
994 C
995 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
996 C
997 C NMXHKK: maximum numbers of entries (partons/particles) that can be
998 C stored in the commonblock.
999 C
1000 C NHKK: the actual number of entries stored in current event. These are
1001 C found in the first NHKK positions of the respective arrays below.
1002 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
1003 C entry.
1004 C
1005 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
1006 C = 0 : null entry.
1007 C = 1 : an existing entry, which has not decayed or fragmented.
1008 C This is the main class of entries which represents the
1009 C "final state" given by the generator.
1010 C = 2 : an entry which has decayed or fragmented and therefore
1011 C is not appearing in the final state, but is retained for
1012 C event history information.
1013 C = 3 : a documentation line, defined separately from the event
1014 C history. (incoming reacting
1015 C particles, etc.)
1016 C = 4 - 10 : undefined, but reserved for future standards.
1017 C = 11 - 20 : at the disposal of each model builder for constructs
1018 C specific to his program, but equivalent to a null line in the
1019 C context of any other program. One example is the cone defining
1020 C vector of HERWIG, another cluster or event axes of the JETSET
1021 C analysis routines.
1022 C = 21 - : at the disposal of users, in particular for event tracking
1023 C in the detector.
1024 C
1025 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
1026 C standard.
1027 C
1028 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
1029 C The value is 0 for initial entries.
1030 C
1031 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
1032 C one mother exist, in which case the value 0 is used. In cluster
1033 C fragmentation models, the two mothers would correspond to the q
1034 C and qbar which join to form a cluster. In string fragmentation,
1035 C the two mothers of a particle produced in the fragmentation would
1036 C be the two endpoints of the string (with the range in between
1037 C implied).
1038 C
1039 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
1040 C entry has not decayed, this is 0.
1041 C
1042 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
1043 C entry has not decayed, this is 0. It is assumed that the daughters
1044 C of a particle (or cluster or string) are stored sequentially, so
1045 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
1046 C daughters. Even in cases where only one daughter is defined (e.g.
1047 C K0 -> K0S) both values should be defined, to make for a uniform
1048 C approach in terms of loop constructions.
1049 C
1050 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
1051 C
1052 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
1053 C
1054 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
1055 C
1056 C PHKK(4,IHKK) : energy, in GeV.
1057 C
1058 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
1059 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
1060 C
1061 C VHKK(1,IHKK) : production vertex x position, in mm.
1062 C
1063 C VHKK(2,IHKK) : production vertex y position, in mm.
1064 C
1065 C VHKK(3,IHKK) : production vertex z position, in mm.
1066 C
1067 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
1068 C********************************************************************
1069 *KEEP,NUCC.
1070  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1071 *KEEP,DPAR.
1072 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1073 C ANAME = LITERAL NAME OF THE PARTICLE
1074 C AAM = PARTICLE MASS IN GEV
1075 C GA = DECAY WIDTH
1076 C TAU = LIFE TIME OF INSTABLE PARTICLES
1077 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1078 C IIBAR = BARYON NUMBER
1079 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1080 C
1081  CHARACTER*8 aname
1082  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1083  +iibar(210),k1(210),k2(210)
1084 C------------------
1085 *KEEP,DPRIN.
1086  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1087 *KEEP,PROJK.
1088  COMMON /projk/ iprojk
1089  COMMON /seasu3/seasq
1090 C COMMON /PCHARM/PCCCC
1091  parameter(ummm=0.3d0)
1092  parameter(smmm=0.5d0)
1093  parameter(cmmm=1.3d0)
1094  DATA pc/0.0001d0/
1095 *KEND.
1096 C----------
1097 C DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
1098 C DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
1099 C DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
1100 C +-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
1101 C +0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
1102 C----------------------------------------------------------------------
1103 C
1104 C FLAVORS OF VALENCE QUARKS FROM PROJECTILE HADRON/NUCLEONS
1105 C
1106 C-----
1107 C
1108  DATA inicha/0/
1109 C----------------------------------------------------------------------
1110 C Initialize Charm selection at soft chain ends
1111 C
1112  IF(inicha.EQ.0)THEN
1113  rx=8.
1114  x1=rx
1115  gm=2.140
1116  x2=ummm
1117  betoo=7.5d0
1118  ENDIF
1119  rx=8.
1120  x1=rx
1121  betcha=betoo+1.3-log10(ecm)
1122  pu=dbeta(x1,x2,betcha)
1123  x2=smmm
1124  ps=dbeta(x1,x2,betcha)
1125  x2=cmmm
1126  pc=dbeta(x1,x2,betcha)
1127 C PU1=PU/(2*PU+PS+PC)
1128 C PS1=PS/(2*PU+PS+PC)
1129  pc1=pc/(2*pu+ps+pc)
1130 C changed j.r.7.12.94
1131 C PC=PC1/2.9
1132 C changed j.r.14.12.94
1133 C PC=PC1/5.0
1134 C PC=PC1/10.0
1135  pc=pc1/7.0
1136  pu1=pu/(2*pu+ps+pc)
1137  ps1=ps/(2*pu+ps+pc)
1138  IF(inicha.EQ.0)THEN
1139  inicha=1
1140  WRITE(6,4567)pc,betcha,pu1,ps1
1141  4567 FORMAT(' Charm at chain ends FLKSAA: PC,BETCHA,PU,PS ',4f10.5)
1142  ENDIF
1143 C----------------------------------------------------------------------
1144 C
1145  IF(ipev.GE.3) WRITE(6,'(A,6I4)')
1146  +' FLKSAA-ENTRY: IT,ITZ, IP,IPZ, IJPROJ,IBPROJ', it,itz,ip,ipz,
1147  +ijproj,ibproj
1148 C
1149  ixpss=nn
1150  ixtss=nn
1151 C
1152 C*********************************************************************
1153 C
1154 C-------------------------------SAMPLING PROJECTILE SEA FLAVORS-------
1155 C
1156 C*********************************************************************
1157 C
1158  DO 20 n=1,ixpss
1159  is=1
1160  rr=rndm(v)
1161  is=1.d0+rndm(v1)*(2.d0+seasq)
1162  IF(rr.LT.pc)is=4
1163  ipsq(n)=is
1164  ipsaq(n)=-is
1165  IF (ipev.GE.8) WRITE (6,1010) n,ipsq(n),ipsaq(n)
1166  1010 FORMAT (' FLKSAA: N,IPSQ(N),IPSAQ(N) ',3i4)
1167 C
1168  20 CONTINUE
1169 C
1170 C*********************************************************************
1171 C
1172 C-------------------------------SAMPLING TARGET SEA FLAVORS-------
1173 C
1174 C*********************************************************************
1175 C
1176  DO 40 n=1,ixtss
1177  is=1
1178  rr=rndm(v)
1179  is=1.d0+rndm(v1)*(2.d0+seasq)
1180  IF(rr.LT.pc)is=4
1181  itsq(n)=is
1182  itsaq(n)=-is
1183  IF (ipev.GE.8) WRITE (6,1020) n,itsq(n),itsaq(n)
1184  1020 FORMAT (' FLKSAA: N,ITSQ(N),ITSAQ(N) ',3i4)
1185 C
1186  40 CONTINUE
1187 C
1188  RETURN
1189  END
1190 *-- Author :
1191 C
1192 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1193 C
1194  SUBROUTINE flahad(ITYP,IBAR,IF1,IF2,IF3)
1195  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1196  SAVE
1197 C
1198 C QUARK FLAVOR COMPOSITION FOR HADRONS
1199 C ITYP : NUMBERING AS FOR BAMJET ...
1200 C LE.30 !!!!!!!!!!
1201 C
1202 C----------------------------------------------------------------------
1203 C
1204 *KEEP,DPRIN.
1205  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1206 *KEND.
1207  dimension mquark(3,30)
1208  DATA mquark/ 2,1,1, -2,-1,-1, 0,0,0, 0,0,0, 0,0,0, 0,0,0, 0,0,0,
1209  +2,2,1, -2,-2,-1, 0,0,0, 0,0,0, 0,0,0, 1,-2,0, 2,-1,0, 1,-3,0, 3,
1210  +-1,0, 1,2,3, -1,-2,-3, 0,0,0, 2,2,3, 1,1,3, 1,2,3, 1,-1,0, 2,-3,0,
1211  +3,-2,0, 2,-2,0, 3,-3,0, 0,0,0, 0,0,0, 0,0,0/
1212 C----------------------------------------------------------------------
1213  IF(ibar.NE.0) THEN
1214  ipq1 = mquark(1,ityp)
1215  ipq2 = mquark(2,ityp)
1216  ipq3 = mquark(3,ityp)
1217 C
1218  IF(ipev.GE.3) print 1000, ityp,ibar
1219  1000 FORMAT(' FLAHAD: ITYP,IBAR',2i5)
1220 C
1221  isam5=1. + 6.*rndm(v)
1222  go to(10,20,30,40,50,60),isam5
1223  10 CONTINUE
1224  if1=ipq1
1225  if2=ipq2
1226  if3=ipq3
1227  go to 70
1228  20 CONTINUE
1229  if1=ipq2
1230  if2=ipq3
1231  if3=ipq1
1232  go to 70
1233  30 CONTINUE
1234  if1=ipq3
1235  if2=ipq1
1236  if3=ipq2
1237  go to 70
1238  40 CONTINUE
1239  if1=ipq1
1240  if2=ipq3
1241  if3=ipq2
1242  go to 70
1243  50 CONTINUE
1244  if1=ipq2
1245  if2=ipq1
1246  if3=ipq3
1247  go to 70
1248  60 CONTINUE
1249  if1=ipq3
1250  if2=ipq2
1251  if3=ipq1
1252  70 CONTINUE
1253  IF (ipev.GE.3) WRITE (6,1010) if1,if2,if3
1254  1010 FORMAT (' FLAHAD: IF1,IF2,IF3 ',3i4)
1255  ELSE
1256 C VALENCE QUARK FLAVORS FOR MESONS
1257  if1=mquark(1,ityp)
1258  if2=mquark(2,ityp)
1259  if3=0
1260  IF(ipev.GE.3) THEN
1261  WRITE(6,'(A,6I4)') ' FLAHAD (MESON): IF1,IF2,IF3', if1,if2,if3
1262 
1263 
1264  ENDIF
1265  ENDIF
1266 C
1267  RETURN
1268  END
1269 *-- Author :
1270 C
1271 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1272 C
1273  SUBROUTINE xksamp(NN,ECM)
1274  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1275  SAVE
1276 *-----------------------------------------------------------
1277 * SAMPLING MOMENTUM FRACTIONS OF QUARKS AND DIQUARKS
1278 *-----------------------------------------------------------
1279 *KEEP,DINPDA.
1280  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
1281  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
1282 *KEEP,INTMX.
1283  parameter(intmx=2488,intmd=252)
1284  parameter(amis=0.8d0,amas=2.6d0,amiu=0.5d0,amau=2.6d0)
1285 *KEEP,DXQX.
1286 C INCLUDE (XQXQ)
1287 * NOTE: INTMX set via INCLUDE(INTMX)
1288  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
1289  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
1290  * ,xpsu(248),xtsu(248)
1291  * ,xpsut(248),xtsut(248)
1292 *KEEP,INTNEW.
1293  COMMON /intnez/ndz,nzd
1294  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
1295  +ixpv,ixps,ixtv,ixts, intvv1(248),
1296  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
1297  +intss1(intmx),intss2(intmx),
1298  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
1299  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
1300 
1301 C /INTNEW/
1302 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
1303 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
1304 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
1305 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
1306 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
1307 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
1308 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
1309 C FROM PROJECTILE/TARGET NUCLEI
1310 C-------------------
1311 *KEEP,IFROTO.
1312  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
1313  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
1314  +jhkknt
1315  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
1316  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
1317  & mhkkhh(intmx),
1318  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
1319 *KEEP,LOZUO.
1320  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
1321  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
1322  +intlo(intmx),inloss(intmx)
1323 C /LOZUO/
1324 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
1325 C REJECTED IN KKEVT
1326 C------------------
1327 *KEEP,DIQI.
1328  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
1329  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
1330  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
1331  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
1332 *KEEP,HKKEVT.
1333 c INCLUDE (HKKEVT)
1334  parameter(nmxhkk= 89998)
1335 c PARAMETER (NMXHKK=25000)
1336  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
1337  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
1338  +(4,nmxhkk)
1339 C
1340 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
1341 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
1342 C THE POSITIONS OF THE PROJECTILE NUCLEONS
1343 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
1344 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
1345 C COMPLETELY CONSISTENT. THE TIMES IN THE
1346 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
1347 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
1348 C
1349 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
1350 C
1351 C NMXHKK: maximum numbers of entries (partons/particles) that can be
1352 C stored in the commonblock.
1353 C
1354 C NHKK: the actual number of entries stored in current event. These are
1355 C found in the first NHKK positions of the respective arrays below.
1356 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
1357 C entry.
1358 C
1359 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
1360 C = 0 : null entry.
1361 C = 1 : an existing entry, which has not decayed or fragmented.
1362 C This is the main class of entries which represents the
1363 C "final state" given by the generator.
1364 C = 2 : an entry which has decayed or fragmented and therefore
1365 C is not appearing in the final state, but is retained for
1366 C event history information.
1367 C = 3 : a documentation line, defined separately from the event
1368 C history. (incoming reacting
1369 C particles, etc.)
1370 C = 4 - 10 : undefined, but reserved for future standards.
1371 C = 11 - 20 : at the disposal of each model builder for constructs
1372 C specific to his program, but equivalent to a null line in the
1373 C context of any other program. One example is the cone defining
1374 C vector of HERWIG, another cluster or event axes of the JETSET
1375 C analysis routines.
1376 C = 21 - : at the disposal of users, in particular for event tracking
1377 C in the detector.
1378 C
1379 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
1380 C standard.
1381 C
1382 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
1383 C The value is 0 for initial entries.
1384 C
1385 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
1386 C one mother exist, in which case the value 0 is used. In cluster
1387 C fragmentation models, the two mothers would correspond to the q
1388 C and qbar which join to form a cluster. In string fragmentation,
1389 C the two mothers of a particle produced in the fragmentation would
1390 C be the two endpoints of the string (with the range in between
1391 C implied).
1392 C
1393 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
1394 C entry has not decayed, this is 0.
1395 C
1396 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
1397 C entry has not decayed, this is 0. It is assumed that the daughters
1398 C of a particle (or cluster or string) are stored sequentially, so
1399 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
1400 C daughters. Even in cases where only one daughter is defined (e.g.
1401 C K0 -> K0S) both values should be defined, to make for a uniform
1402 C approach in terms of loop constructions.
1403 C
1404 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
1405 C
1406 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
1407 C
1408 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
1409 C
1410 C PHKK(4,IHKK) : energy, in GeV.
1411 C
1412 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
1413 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
1414 C
1415 C VHKK(1,IHKK) : production vertex x position, in mm.
1416 C
1417 C VHKK(2,IHKK) : production vertex y position, in mm.
1418 C
1419 C VHKK(3,IHKK) : production vertex z position, in mm.
1420 C
1421 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
1422 C********************************************************************
1423 *KEEP,SHMAKL.
1424 C INCLUDE (SHMAKL)
1425 * NOTE: INTMX set via INCLUDE(INTMX)
1426  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
1427 *KEEP,NUCC.
1428  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1429 *KEEP,DPAR.
1430 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1431 C ANAME = LITERAL NAME OF THE PARTICLE
1432 C AAM = PARTICLE MASS IN GEV
1433 C GA = DECAY WIDTH
1434 C TAU = LIFE TIME OF INSTABLE PARTICLES
1435 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1436 C IIBAR = BARYON NUMBER
1437 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1438 C
1439  CHARACTER*8 aname
1440  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1441  +iibar(210),k1(210),k2(210)
1442 C------------------
1443 *KEEP,DPRIN.
1444  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1445 *KEEP,NUCKOO.
1446  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
1447  +tpoo(3,intmx)
1448 *KEEP,PROJK.
1449  COMMON /projk/ iprojk
1450 *KEEP,XSEADI.
1451  COMMON /xseadi/ xseacu,unon,unom,unosea, cvq,cdq,csea,ssmima,
1452  +ssmimq,vvmthr
1453 *
1454 *KEEP,ABRVV.
1455  COMMON /abrvv/ amcvv1(248),amcvv2(248),gacvv1(248),gacvv2(248),
1456  +bgxvv1(248),bgyvv1(248),bgzvv1(248), bgxvv2(248),bgyvv2(248),
1457  +bgzvv2(248), nchvv1(248),nchvv2(248),ijcvv1(248),ijcvv2(248),
1458  +pqvva1(248,4),pqvva2(248,4), pqvvb1(248,4),pqvvb2(248,4)
1459 *KEEP,ABRSS.
1460 C INCLUDE (ABRSS)
1461  COMMON /abrss/ amcss1(intmx),amcss2(intmx), gacss1(intmx),gacss2
1462  +(intmx), bgxss1(intmx),bgyss1(intmx),bgzss1(intmx), bgxss2(intmx),
1463  +bgyss2(intmx),bgzss2(intmx), nchss1(intmx),nchss2(intmx), ijcss1
1464  +(intmx),ijcss2(intmx), pqssa1(intmx,4),pqssa2(intmx,4), pqssb1
1465  +(intmx,4),pqssb2(intmx,4)
1466 *KEEP,ABRVS.
1467  COMMON /abrvs/ amcvs1(248),amcvs2(248),gacvs1(248),gacvs2(248),
1468  +bgxvs1(248),bgyvs1(248),bgzvs1(248), bgxvs2(248),bgyvs2(248),
1469  +bgzvs2(248), nchvs1(248),nchvs2(248),ijcvs1(248),ijcvs2(248),
1470  +pqvsa1(248,4),pqvsa2(248,4), pqvsb1(248,4),pqvsb2(248,4)
1471 *KEEP,ABRSV.
1472  COMMON /abrsv/ amcsv1(248),amcsv2(248),gacsv1(248),gacsv2(248),
1473  +bgxsv1(248),bgysv1(248),bgzsv1(248), bgxsv2(248),bgysv2(248),
1474  +bgzsv2(248), nchsv1(248),nchsv2(248),ijcsv1(248),ijcsv2(248),
1475  +pqsva1(248,4),pqsva2(248,4), pqsvb1(248,4),pqsvb2(248,4)
1476 *KEND.
1477  LOGICAL lseadi
1478  COMMON /seadiq/lseadi
1479  common/recom/irecom
1480  common/diquax/amedd,idiqua,idiquu
1481  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
1482  COMMON /seaqxx/ seaqx,seaqxn
1483  dimension isxpvq(248),isxpvd(248),isxtvq(248),isxtvd(248)
1484  parameter(sqma=0.7d0)
1485 C*******************************************************************"
1486 C*** ACTUAL STANDARD VALUES FROM BLOCK DATA:
1487 C
1488 C CSEA=1.0, CVQ=1., CDQ=2.
1489 C UNON=2., UNOM=1.5, UNOSEA=2.0
1490 C----------------------------------
1491  parameter(nsea=3,nval=10)
1492  DATA icoun /0/
1493  DATA jcoun /0/
1494 * NSEA: maximum number of trials to generate x's for the required number
1495 * of sea quark pairs for a given hadron
1496 * changed from 10 to 3 22/04/92
1497 C---------------------------------------------------------------------
1498  jcoun=jcoun+1
1499  DO 10 i=1,ip
1500  jsshs(i)=0
1501  10 CONTINUE
1502  DO 20 i=1,it
1503  jtshs(i)=0
1504  20 CONTINUE
1505  DO 30 i=1,intmx
1506  zuosp(i)=.false.
1507  zuost(i)=.false.
1508  IF (i.GT.248) go to 30
1509  zuovp(i)=.false.
1510  zuovt(i)=.false.
1511  30 CONTINUE
1512  IF(ecm.LE.1.d-3)THEN
1513  WRITE(6,*)' xksamp: ECM=0.D0 '
1514  ecm=ecm+1.d-3
1515  ENDIF
1516  xsthr=csea/ecm
1517  IF(xsthr.LE.1.d-12)THEN
1518  WRITE(6,*)' xksamp 30 : XSTHR=0.D0 ',csea,ecm,xsthr
1519  xsthr=xsthr+1.d-12
1520  ENDIF
1521 C-----------------------------------------------------------------
1522 C
1523 C J.R.21.2.94
1524 C
1525 C----------------------------------------------------------------
1526 C j.r.12.3.97
1527 C j.r.11.4.97 part restored
1528  IF(ip.EQ.1) xsthr=4./ecm**2
1529 C test 28.4.97
1530 C IF(IP.EQ.1) XSTHR=4./ECM**2
1531  IF(xsthr.LE.1.d-12)THEN
1532  xsthr=xsthr+1.d-12
1533  ENDIF
1534 C----------------------------------------------------------------
1535 C-----------------------------------------------------------------
1536 C
1537 C J.R.16.3.95
1538 C
1539 C----------------------------------------------------------------
1540  IF(ip.GE.150.AND.it.GE.150) xsthr=2.5/(ecm*sqrt(ecm))
1541 C----------------------------------------------------------------
1542  bsqma=sqma/ecm
1543 C before 28.8.97
1544 C IF (ECM.LT.10.D0) XSTHR=((12.-ECM)/5.+1.)*CSEA/ECM
1545 C 28.4.97 test
1546  IF (ecm.LT.10.d0.AND.ip.GT.1)xsthr=((12.-ecm)/5.+1.)*csea/ecm
1547  xvthr=cvq/ecm
1548  xdthr=cdq/ecm
1549  IF (xvthr+xdthr.GT.0.90d0)THEN
1550  xvthr=0.95-xdthr
1551  IF(xvthr.LE.0.05d0)THEN
1552  WRITE (6,1000)ecm
1553  ENDIF
1554  ENDIF
1555  IF(ecm.LE.1.d-3)THEN
1556  WRITE(6,*)' xksamp: ECM=0.D0 '
1557  ecm=ecm+1.d-3
1558  ENDIF
1559  xssthr=ssmima/ecm
1560 C------------------------- 20.12.91.j.r.
1561  IF(jcoun.EQ.1)WRITE(6,'(A,4E15.5)')
1562  *' XKSAMP: XSTHR,XVTHR,XDTHR,XSSTHR ',
1563  * xsthr,xvthr,xdthr,xssthr
1564  IF(ipev.GE.1)WRITE(6,'(A,4E15.5)')
1565  *' XKSAMP: XSTHR,XVTHR,XDTHR,XSSTHR ',
1566  * xsthr,xvthr,xdthr,xssthr
1567 C-------------------------
1568 C TEST KINEMATICAL LIMITS
1569  IF (xvthr+xdthr.GT.0.95d0)THEN
1570  WRITE (6,1000)ecm
1571  1000 FORMAT (' PROGRAMM STOPPED IN XSAMP1 ECM = ',f6.2,' TOO SMALL')
1572  stop
1573  ENDIF
1574 C MAXIMUM NUMBER OF SEA-PAIRS ALLOWED KINEMATICALLY
1575 C XXSEAM=1.0 - XVTHR*(1.D0+RNDM(V1)) - XDTHR*(1.D0+RNDM(V2))
1576 C * -0.01*(1.D0+5.D0*RNDM(V3))
1577 C 28.4.97 test
1578  xxseam=1.0 - xvthr*(1.d0+0.3d0*rndm(v1))
1579  * - xdthr*(1.d0+0.3d0*rndm(v2))
1580  * -0.01*(1.d0+1.5d0*rndm(v3))
1581 C..............................................................
1582 C 1/x seaquarks
1583  IF(seaqxn.GE.0.75d0)THEN
1584  xsthr=8.*csea/ecm
1585 C 23.5.95
1586  xsthr=4.*csea/ecm
1587  xxseam=1.d0-xvthr-xdthr
1588 C MAXIMUM NUMBER OF SEA-PAIRS ALLOWED KINEMATICALLY
1589  xxseam=1.0 - xvthr*(1.d0+rndm(v1)) - xdthr*(1.d0+rndm(v2))
1590  * -0.01*(1.d0+5.d0*rndm(v3))
1591  ENDIF
1592 C..............................................................
1593  IF(xsthr.LE.1.d-12)THEN
1594  icoun=icoun+1
1595  IF(icoun.LE.50)THEN
1596  WRITE(6,*)' xksamp: XSTHR=0.D0 '
1597  WRITE(6,'(A,2E20.5,I10)')
1598  * ' XXSEAM,XSTHR,NSMAX',xxseam,xsthr,nsmax
1599  ENDIF
1600  xsthr=xsthr+1.d-9
1601  ENDIF
1602  nsmax=0.50*xxseam / xsthr
1603  IF(ipev.GE.1)WRITE(6,'(A,E15.5,I10)')
1604  * ' XXSEAM,NSMAX',xxseam,nsmax
1605 *--------------------------------------------------------------------
1606 *-------------------------------------------------------------------
1607 C Change XVTHR and XDTHR at low energies
1608 C TEST j.r. 9.2.95
1609  IF (xdthr.GT.0.14d0)xdthr=0.14d0
1610  IF (xvthr.GT.0.14d0)xvthr=0.14d0
1611 *--------------------------------------------------------------------
1612 C PARTON X-VALUES OF INTERACTING
1613 C PROJECTILE HADRON / NUCLEONS
1614  ixpv=0
1615  ixps=0
1616  unoprv=unon
1617  IF(ijproj.NE.0.AND.ibproj.EQ.0) unoprv=unom
1618  IF(jcoun.EQ.1)WRITE(6,'(A,4E15.5)')
1619  *' XKSAMP: XSTHR,XVTHR,XDTHR,XSSTHR ',
1620  * xsthr,xvthr,xdthr,xssthr
1621 * loop over projectile nucleons
1622  DO 100 ipp=1,ip
1623  IF (jssh(ipp).NE.0) THEN
1624 C--------------------------------------------------------------
1625 C prepare diquark rejection
1626 C--------------------------------------------------------------
1627  iixpss=ixps
1628  iixpvv=ixpv
1629  99 CONTINUE
1630  ixps=iixpss
1631  ixpv=iixpvv
1632 C--------------------------------------------------------------
1633  jipp=jssh(ipp)-1
1634  jipp=min(jipp,nsmax)
1635  41 CONTINUE
1636  xxsea=0.0
1637  IF(jipp.GT.0) THEN
1638 C j.r.11.12.97
1639  xsmax=xxseam - 1.5*jipp*xsthr
1640 C XSMAX=XXSEAM - 2.*JIPP*XSTHR
1641  IF(xsthr.GE.xsmax) THEN
1642  jipp=jipp-1
1643  goto 41
1644  ENDIF
1645 * x-values of sea-quark pairs
1646  nscoun=0
1647  40 CONTINUE
1648  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-40'
1649  xxsea=0.0
1650  nscoun=nscoun+1
1651  IF (nscoun.GT.nsea) THEN
1652  jipp=jipp-1
1653  nscoun=0
1654  ENDIF
1655  DO 70 isq=1,jipp
1656 C j.r.29.4.93---
1657  IF(ipsq(ixps+1).LE.2)THEN
1658 C..............................................................
1659 C 1/sqrt(x) seaquarks
1660  IF(seaqxn.LE.0.75d0)THEN
1661  xpsqi=sampex(xsthr,xsmax)
1662 C 1/x seaquarks
1663  ELSEIF(seaqxn.GT.0.75d0)THEN
1664  xpsqi=sampey(xsthr,xsmax)
1665  ENDIF
1666 C..............................................................
1667  IF(ipev.GE.1)WRITE(6,'(A,3E15.5)')
1668  * 'XPSQI 1:XPSQI,XSTHR,XSMAX',
1669  * xpsqi,xsthr,xsmax
1670  ELSE
1671  IF(xsmax.GT.xsthr+bsqma)THEN
1672  xpsqi=sampxb(xsthr+bsqma,xsmax,bsqma)
1673  IF(ipev.GE.1)WRITE(6,'(A,4E15.5)')
1674  * 'XPSQI 2:XPSQI,XSTHR,XSMAX,BSQMA',
1675  * xpsqi,xsthr,xsmax,bsqma
1676  ELSE
1677 C..............................................................
1678 C 1/sqrt(x) seaquarks
1679  IF(seaqxn.LE.0.75d0)THEN
1680  xpsqi=sampex(xsthr,xsmax)
1681 C 1/x seaquarks
1682  ELSEIF(seaqxn.GT.0.75d0)THEN
1683  xpsqi=sampey(xsthr,xsmax)
1684  ENDIF
1685 C..............................................................
1686  IF(ipev.GE.1)WRITE(6,'(A,3E15.5)')
1687  * 'XPSQI 3:XPSQI,XSTHR,XSMAX',
1688  * xpsqi,xsthr,xsmax
1689  ENDIF
1690  ENDIF
1691 C
1692  IF(ipsaq(ixps+1).GE.-2)THEN
1693 C..............................................................
1694 C 1/sqrt(x) seaquarks
1695  IF(seaqxn.LE.0.75d0)THEN
1696  xpsaqi=sampex(xsthr,xsmax)
1697 C 1/x seaquarks
1698  ELSEIF(seaqxn.GT.0.75d0)THEN
1699  xpsaqi=sampey(xsthr,xsmax)
1700  ENDIF
1701 C..............................................................
1702  IF(ipev.GE.1)WRITE(6,'(A,3E15.5)')
1703  * 'XPSAQI 1:XPSAQI,XSTHR,XSMAX',
1704  * xpsaqi,xsthr,xsmax
1705  ELSE
1706  IF(xsmax.GT.xsthr+bsqma)THEN
1707  xpsaqi=sampxb(xsthr+bsqma,xsmax,bsqma)
1708  IF(ipev.GE.1)WRITE(6,'(A,4E15.5)')
1709  * 'XPSAQI 2:XPSAQI,XSTHR,XSMAX,BSQMA',
1710  * xpsaqi,xsthr,xsmax,bsqma
1711  ELSE
1712 C..............................................................
1713 C 1/sqrt(x) seaquarks
1714  IF(seaqxn.LE.0.75d0)THEN
1715  xpsaqi=sampex(xsthr,xsmax)
1716 C 1/x seaquarks
1717  ELSEIF(seaqxn.GT.0.75d0)THEN
1718  xpsaqi=sampey(xsthr,xsmax)
1719  ENDIF
1720 C..............................................................
1721  IF(ipev.GE.1)WRITE(6,'(A,3E15.5)')
1722  * 'XPSAQI 3:XPSAQI,XSTHR,XSMAX',
1723  * xpsaqi,xsthr,xsmax
1724  ENDIF
1725  ENDIF
1726 C ---
1727  50 CONTINUE
1728  IF(ipev.GE.1)
1729  * WRITE(6,'(A,3E15.4)') ' XKSAMP-50: XPSQI,XSTHR,XSMAX',
1730  & xpsqi,xsthr,xsmax
1731  60 CONTINUE
1732  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-60'
1733  IF(ipev.GE.1)
1734  * WRITE(6,'(A,3E15.4)') ' XKSAMP-60: XPSAQI,XSTHR,XSMAX',
1735  & xpsaqi,xsthr,xsmax
1736  xxsea=xxsea + xpsqi + xpsaqi
1737  IF(xxsea.GE.xxseam) THEN
1738  ixps=ixps - isq + 1
1739  goto 40
1740  ENDIF
1741  ixps=ixps+1
1742  IF(ipev.GE.1)WRITE(6,'(A,I10)') ' XKSAMP-60: IXPS',ixps
1743  xpsq(ixps)=xpsqi
1744  xpsaq(ixps)=xpsaqi
1745 C Test 14.4.99
1746  xpsq(ixps)=xpsaqi
1747  xpsaq(ixps)=xpsqi
1748  ifrosp(ixps)=ipp
1749  zuosp(ixps)=.true.
1750  70 CONTINUE
1751  ENDIF
1752  jsshs(ipp)=jipp
1753 * projectile valence quarks
1754  80 CONTINUE
1755  IF(xvthr.GT.0.05d0)THEN
1756  IF(xvthr.GT.1.d0-xxsea-xdthr)THEN
1757  WRITE(6,*)' xvthr,xxsea,xdthr ', xvthr,xxsea,xdthr
1758  ENDIF
1759 C TEST 15.4.99
1760 C XPVQI=BETREJ(0.5D0,UNOPRV,XVTHR,1.D0-XXSEA-XDTHR)
1761  xpvqi=betrej(0.1d0,unoprv,xvthr,1.d0-xxsea-xdthr)
1762  81 CONTINUE
1763  ELSE
1764  90 CONTINUE
1765  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-90'
1766 C TEST 15.4.99
1767 C XPVQI=DBETAR(0.5D0,UNOPRV)
1768  xpvqi=dbetar(0.1d0,unoprv)
1769  IF ((xpvqi.LT.xvthr).OR.(1.d0-xpvqi-xxsea.LT.xdthr))
1770  * goto 90
1771  ENDIF
1772  xpvdi=1. - xpvqi - xxsea
1773 C CONSISTENCY TEST
1774 C TO BE FULFILLED AUTOMATICALLY
1775  IF(xpvdi.LT.xdthr) THEN
1776  WRITE(6,'(A/A/E12.3,4I4,3E11.3)')
1777  + ' INCONSISTENT X-SAMPLING / XKSAMP / PROJECTILE',
1778  + ' ECM, IP, IPP, JSSH(IPP), JIPP, XPVQI, XPVDI, XXSEA', ecm,
1779  + ip, ipp, jssh(ipp), jipp, xpvqi, xpvdi, xxsea
1780  stop
1781  ENDIF
1782 C
1783 C--------------------------------------------------------------
1784 C diquark rejection
1785 C Here we have a projectile diquark
1786 C Reject it according to xd**1.5 rule
1787 C--------------------------------------------------------------
1788  xtest=xpvdi**1.5
1789  vv=ipp
1790 C--------------------------------------------------------------
1791  ixpv=ixpv+1
1792  xpvq(ixpv)=xpvqi
1793  xpvd(ixpv)=xpvdi
1794  isxpvq(ixpv)=0
1795  isxpvd(ixpv)=0
1796  ifrovp(ixpv)=ipp
1797  itovp(ipp)=ixpv
1798  zuovp(ixpv)=.true.
1799  ENDIF
1800  100 CONTINUE
1801 C******************************
1802 C PARTON X-VALUES OF INTERACTING TARGET NUCLEONS
1803  ixtv=0
1804  ixts=0
1805  DO 170 itt=1,it
1806  IF (jtsh(itt).NE.0) THEN
1807 C--------------------------------------------------------------
1808 C prepare diquark rejection
1809 C--------------------------------------------------------------
1810  iixtss=ixts
1811  iixtvv=ixtv
1812  169 CONTINUE
1813  ixts=iixtss
1814  ixtv=iixtvv
1815 C--------------------------------------------------------------
1816  jitt=jtsh(itt)-1
1817  jitt=min(jitt,nsmax)
1818  111 CONTINUE
1819  xxsea=0.0
1820  IF(jitt.GT.0) THEN
1821 C j.r.11.12.97
1822  xsmax=xxseam -1.5*jitt*xsthr
1823 C XSMAX=XXSEAM - 2.*JITT*XSTHR
1824  IF(xsthr.GE.xsmax) THEN
1825  jitt=jitt-1
1826  goto 111
1827  ENDIF
1828  nscoun=0
1829  110 CONTINUE
1830  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-110'
1831  xxsea=0.0
1832  nscoun=nscoun+1
1833  IF (nscoun.GT.nsea)THEN
1834  jitt=jitt-1
1835  nscoun=0
1836  ENDIF
1837  DO 140 isq=1,jitt
1838 C CHANGE 23.5.90 / 13.9.90
1839 C IF(XSTHR.GT.0.05D0)THEN
1840 C J.R.29.4.93---
1841  IF(itsq(ixts+1).LE.2)THEN
1842 C..............................................................
1843 C 1/sqrt(x) seaquarks
1844  IF(seaqxn.LE.0.75d0)THEN
1845  xtsqi=sampex(xsthr,xsmax)
1846 C 1/x seaquarks
1847  ELSEIF(seaqxn.GT.0.75d0)THEN
1848  xtsqi=sampey(xsthr,xsmax)
1849  ENDIF
1850 C..............................................................
1851  ELSE
1852  IF(xsmax.GT.xsthr+bsqma)THEN
1853  xtsqi=sampxb(xsthr+bsqma,xsmax,bsqma)
1854  ELSE
1855 C..............................................................
1856 C 1/sqrt(x) seaquarks
1857  IF(seaqxn.LE.0.75d0)THEN
1858  xtsqi=sampex(xsthr,xsmax)
1859 C 1/x seaquarks
1860  ELSEIF(seaqxn.GT.0.75d0)THEN
1861  xtsqi=sampey(xsthr,xsmax)
1862  ENDIF
1863 C..............................................................
1864  ENDIF
1865  ENDIF
1866 C
1867  IF(itsaq(ixts+1).GE.-2)THEN
1868 C..............................................................
1869 C 1/sqrt(x) seaquarks
1870  IF(seaqxn.LE.0.75d0)THEN
1871  xtsaqi=sampex(xsthr,xsmax)
1872 C 1/x seaquarks
1873  ELSEIF(seaqxn.GT.0.75d0)THEN
1874  xtsaqi=sampey(xsthr,xsmax)
1875  ENDIF
1876 C..............................................................
1877  ELSE
1878  IF(xsmax.GT.xsthr+bsqma)THEN
1879  xtsaqi=sampxb(xsthr+bsqma,xsmax,bsqma)
1880  ELSE
1881 C..............................................................
1882 C 1/sqrt(x) seaquarks
1883  IF(seaqxn.LE.0.75d0)THEN
1884  xtsaqi=sampex(xsthr,xsmax)
1885 C 1/x seaquarks
1886  ELSEIF(seaqxn.GT.0.75d0)THEN
1887  xtsaqi=sampey(xsthr,xsmax)
1888  ENDIF
1889 C..............................................................
1890  ENDIF
1891  ENDIF
1892 C ---
1893 C XTSQI=SAMPEX(XSTHR,XSMAX)
1894 C
1895 C XTSAQI=SAMPEX(XSTHR,XSMAX)
1896 C ELSE
1897  120 CONTINUE
1898  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-120'
1899 C XTSQI=SAMPEX(XSTHR,XSMAX)
1900 C IF (XTSQI.LT.XSTHR.OR.XTSQI.GE.XSMAX) GOTO 120
1901  130 CONTINUE
1902  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-130'
1903 C XTSAQI=SAMPEX(XSTHR,XSMAX)
1904 C IF (XTSAQI.LT.XSTHR.OR.XTSAQI.GE.XSMAX) GOTO 130
1905 C ENDIF
1906  xxsea=xxsea + xtsqi + xtsaqi
1907  IF(xxsea.GE.xxseam) THEN
1908  ixts=ixts - isq + 1
1909  goto 110
1910  ENDIF
1911  ixts=ixts+1
1912  IF(ipev.GE.1)WRITE(6,'(A,I10)')' XKSAMP-130: IXTS',ixts
1913  xtsq(ixts)=xtsqi
1914  xtsaq(ixts)=xtsaqi
1915  ifrost(ixts)=itt
1916  zuost(ixts)=.true.
1917  140 CONTINUE
1918  ENDIF
1919  jtshs(itt)=jitt
1920 C
1921 C*** TARGET VALENCE QUARKS
1922  150 CONTINUE
1923  IF(xvthr.GT.0.05d0)THEN
1924  IF(xvthr.GT.1.d0-xxsea-xdthr)THEN
1925  WRITE(6,*)' xvthr,xxsea,xdthr ', xvthr,xxsea,xdthr
1926  ENDIF
1927 C TEST 15.4.99
1928 C XTVQI=BETREJ(0.5D0,UNON,XVTHR,1.-XXSEA-XDTHR)
1929  xtvqi=betrej(0.1d0,unon,xvthr,1.-xxsea-xdthr)
1930  151 CONTINUE
1931  ELSE
1932  160 CONTINUE
1933  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-160'
1934 C TEST 15.4.99
1935 C XTVQI=DBETAR(0.5D0,UNON)
1936  xtvqi=dbetar(0.1d0,unon)
1937  xmist=1.-xtvqi-xxsea
1938  IF(ipev.GE.1)WRITE(6,'(A,5E15.5)')
1939  * ' XTVQI,XVTHR,XXSEA,XMIST,XDTHR',
1940  * xtvqi,xvthr,xxsea,xmist,xdthr
1941  IF((xtvqi.LT.xvthr).OR.(1.d0-xtvqi-xxsea.LT.xdthr+0.0001d0))
1942  * goto 160
1943  ENDIF
1944  xtvdi=1. - xtvqi - xxsea
1945 C CONSISTENCY TEST
1946 C TO BE FULFILLED AUTOMATICALLY
1947  IF(xtvdi.LT.xdthr) THEN
1948  WRITE(6,'(A/A/E12.3,4I4,3E11.3)')
1949  + ' INCONSISTENT X-SAMPLING / XKSAMP / TARGET',
1950  + ' ECM, IT, ITT, JTSH(ITT), JITT, XTVQI, XTVDI, XXSEA', ecm,
1951  + it, itt, jtsh(itt), jitt, xtvqi, xtvdi, xxsea
1952  stop
1953  ENDIF
1954 C
1955 C--------------------------------------------------------------
1956 C diquark rejection
1957 C Here we have a target diquark
1958 C Reject it according to xd**1.5 rule
1959 C--------------------------------------------------------------
1960  xtest=xtvdi**1.5
1961  vv=itt
1962 C IF(RNDM(VV).GT.XTEST)GO TO 169
1963 C--------------------------------------------------------------
1964  ixtv=ixtv+1
1965  xtvq(ixtv)=xtvqi
1966  xtvd(ixtv)=xtvdi
1967  isxtvq(ixtv)=0
1968  isxtvd(ixtv)=0
1969  ifrovt(ixtv)=itt
1970  itovt(itt)=ixtv
1971  zuovt(ixtv)=.true.
1972  ENDIF
1973  170 CONTINUE
1974 C
1975  IF (ipev.GE.6) THEN
1976  WRITE(6,1010)
1977  1010 FORMAT(' XKSAMP:',
1978  +' I,XPVQ(I),XPVD(I),IFROVP(I),ITOVP(I),ZUOVP(I),KKPROJ(I)')
1979  DO 180 i=1,ixpv
1980  WRITE(6,1020) i,xpvq(i),xpvd(i),ifrovp(i),itovp(i),zuovp(i),
1981  + kkproj(i)
1982  1020 FORMAT(i5,2e15.5,2i5,l5,i5)
1983  180 CONTINUE
1984  WRITE(6,1030)
1985  1030 FORMAT(' XKSAMP : I,XPSQ(I),XPSAQ(I),IFROSP(I),ZUOSP(I)')
1986  DO 190 i=1,ixps
1987  WRITE(6,1040) i,xpsq(i),xpsaq(i),ifrosp(i),zuosp(i)
1988  1040 FORMAT(i5,2e15.5,i5,l5)
1989  190 CONTINUE
1990 C
1991  WRITE(6,1050)
1992  1050 FORMAT(' XKSAMP:',
1993  +' I,XTVQ(I),XTVD(I),IFROVT(I),ITOVT(I),ZUOVT(I),KKTARG(I)')
1994  DO 200 i=1,ixtv
1995  WRITE(6,1020) i,xtvq(i),xtvd(i),ifrovt(i),itovt(i),zuovt(i),
1996  + kktarg(i)
1997  200 CONTINUE
1998  WRITE(6,1060)
1999  1060 FORMAT(' XKSAMP : I,XTSQ(I),XTSAQ(I),IFROST(I),ZUOST(I)')
2000  DO 210 i=1,ixts
2001  WRITE(6,1040) i,xtsq(i),xtsaq(i),ifrost(i),zuost(i)
2002  210 CONTINUE
2003  ENDIF
2004  IF(ipev.GE.6) THEN
2005  WRITE(6,'(A)')
2006  + ' XKSAMP : I,ITOVP(I),ITOVT(I),JSSHS(I),JTSHS(I)'
2007  ima=max(ip,it)
2008  DO 220 i=1,ima
2009  WRITE(6,1070) i,itovp(i),itovt(i),jsshs(i),jtshs(i)
2010  1070 FORMAT(5i5)
2011  220 CONTINUE
2012  DO 181 i=1,ixpv
2013  WRITE(6,*)' I,IPVQ(I),IPPV1(I),IPPV2(I) ',
2014  * i,ipvq(i),ippv1(i),ippv2(i)
2015  181 CONTINUE
2016  DO 182 i=1,ixtv
2017  WRITE(6,*)' I,ITVQ(I),ITTV1(I),ITTV2(I) ',
2018  * i,itvq(i),ittv1(i),ittv2(i)
2019  182 CONTINUE
2020  DO 183 i=1,ixps
2021  WRITE(6,*)' I,IPSQ(I),IPSAQ(I) ',
2022  * i,ipsq(i),ipsaq(i)
2023  183 CONTINUE
2024  DO 184 i=1,ixts
2025  WRITE(6,*)' I,ITSQ(I),ITSAQ(I) ',
2026  * i,itsq(i),itsaq(i)
2027  184 CONTINUE
2028  ENDIF
2029 C
2030 C----------------------------------------------------------------------
2031 C COLLECTION OF VALENCE-VALENCE PAIRS
2032  nvv=0
2033  IF(ipev.GE.4)WRITE(6,*)' collect v-v pairs NVV',nvv
2034  DO 230 i=1,nn
2035  intlo(i)=.true.
2036  230 CONTINUE
2037  DO 240 i=1,nn
2038  iipp=inter1(i)
2039  iitt=inter2(i)
2040  iippv=itovp(iipp)
2041  iittv=itovt(iitt)
2042  IF(zuovp(iippv).AND.zuovt(iittv)) THEN
2043  intlo(i)=.false.
2044  IF(ipev.GE.6)WRITE(6,'(A,5I5)')
2045  * ' XKSAMP v-v loop IIPP,IITT,IIPPV,IITTV,NVV',iipp,iitt,iippv,iittv,nvv
2046  zuovp(iippv)=.false.
2047  zuovt(iittv)=.false.
2048  nvv=nvv + 1
2049  IF(ipev.GE.4)WRITE(6,*)' collect v-v pairs NVV',nvv
2050  nchvv1(nvv)=0
2051  nchvv2(nvv)=0
2052  intvv1(nvv)=iippv
2053  intvv2(nvv)=iittv
2054 C -----------------------------------------------------J.R. 6.1.92
2055 C AMVVP2=XTVQ(IITTV)*XPVD(IIPPV)*ECM*ECM
2056 C IF(AMVVP2.GT.6.D0)THEN
2057 C RESAMPLE XTVQ
2058 C XTVQTH=6./(XPVD(IIPPV)*ECM*ECM)
2059 C XTVQXX=BETREJ(0.5D0,UNOPRV,XTVQTH,XTVQ(IITTV))
2060 C DXTVQ=XTVQ(IITTV)-XTVQXX
2061 C XTVQ(IITTV)=XTVQ(IITTV)-DXTVQ
2062 C XTVD(IITTV)=XTVD(IITTV)+DXTVQ
2063 C ENDIF
2064 C AMVVT2=XTVD(IITTV)*XPVQ(IIPPV)*ECM*ECM
2065 C IF(AMVVT2.GT.6.D0)THEN
2066 C RESAMPLE XPVQ
2067 C XPVQTH=6./(XTVD(IITTV)*ECM*ECM)
2068 C XPVQXX=BETREJ(0.5D0,UNOPRV,XPVQTH,XPVQ(IIPPV))
2069 C DXPVQ=XPVQ(IIPPV)-XPVQXX
2070 C XPVQ(IIPPV)=XPVQ(IIPPV)-DXPVQ
2071 C XPVD(IIPPV)=XPVD(IIPPV)+DXPVQ
2072 C ENDIF
2073 C--------------------------------------------------------------
2074  ENDIF
2075  240 CONTINUE
2076 C
2077 C COLLECTION OF THE SEA-VALENCE PAIRS
2078  ndv=0
2079  nsv=0
2080  DO 270 i=1,nn
2081  IF(intlo(i)) THEN
2082  iipp=inter1(i)
2083  iitt=inter2(i)
2084  iittv=itovt(iitt)
2085  DO 250 j=1,ixps
2086  IF(zuosp(j).AND.(ifrosp(j).EQ.iipp).AND.zuovt(iittv)) THEN
2087  zuosp(j)=.false.
2088  IF(ipev.GE.6)WRITE(6,'(A,6I5)')
2089  *' XKSAMP s-v loop I(NN),J(IXPS),iitt,iittv,NSV,NDV',
2090  + i,j, iitt,iittv,nsv,ndv
2091  zuovt(iittv)=.false.
2092  intlo(i)=.false.
2093 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2094  IF(rndm(v).GT.amedd.AND.idiqua.EQ.1)THEN
2095 C DEFINE D-V CHAINS (SEA-DIQUARK-VALENCE)
2096  CALL diqsv(ecm,iittv,j,irej)
2097  IF(irej.EQ.0)go to 260
2098  ENDIF
2099  nsv=nsv + 1
2100  nchsv1(nsv)=0
2101  nchsv2(nsv)=0
2102  intsv1(nsv)=j
2103  intsv2(nsv)=iittv
2104 C----------------correct sv chains to get minimum mass ------
2105 C IF(IP.GE.2)GO TO 5270
2106  amsvq1=xpsq(j)*xtvd(iittv)*ecm**2
2107  amsvq2=xpsaq(j)*xtvq(iittv)*ecm**2
2108  jxpv=itovp(iipp)
2109  IF(ipsq(j).EQ.3)THEN
2110  IF(amsvq1.GT.amas)THEN
2111  xpsqxx=(xtvd(iittv)*ecm**2)
2112  IF(xpsqxx.LE.1.d-1)xpsqxx=1.d-1
2113  xpsqth=amas/xpsqxx
2114  xpsqxx=sampex(xpsqth,xpsq(j))
2115  dxpsq=xpsq(j)-xpsqxx
2116  xpsq(j)=xpsq(j)-dxpsq
2117  xpvd(jxpv)=xpvd(jxpv)+dxpsq
2118  ELSEIF(amsvq1.LT.amas)THEN
2119  IF(xtvd(iittv)*ecm**2.LE.1.d-12)THEN
2120  WRITE(6,*)' xksamp: XTVD(IITTV)=0 ',iittv
2121  xtvd(iittv)=0.1d0
2122  ENDIF
2123  xpsqw=amas/(xtvd(iittv)*ecm**2)
2124  dxpsq=xpsqw-xpsq(j)
2125  isxtvd(iittv)=1
2126  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2127  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2128  xpsq(j)=xpsqw
2129  ENDIF
2130  ENDIF
2131  IF(amsvq2.GT.amis)THEN
2132  ELSEIF(amsvq2.LT.amis)THEN
2133  IF(xtvq(iittv)*ecm**2.LE.1.d-12)THEN
2134  WRITE(6,*)' xksamp: XTVQ(IITTV)=0 ',iittv
2135  xtvq(iittv)=0.1d0
2136  ENDIF
2137  xpsqw=amis/(xtvq(iittv)*ecm**2)
2138  dxpsq=xpsqw-xpsaq(j)
2139  isxtvq(iittv)=1
2140  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2141  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2142  xpsaq(j)=xpsqw
2143  ENDIF
2144  ENDIF
2145  ELSE
2146  IF(amsvq1.GT.amau)THEN
2147  IF(xtvd(iittv)*ecm**2.LE.1.d-12)THEN
2148  WRITE(6,*)' xksamp: XTVD(IITTV)=0 ',iittv
2149  xtvd(iittv)=0.1d0
2150  ENDIF
2151  xpsqth=amau/(xtvd(iittv)*ecm**2)
2152  xpsqxx=sampex(xpsqth,xpsq(j))
2153  dxpsq=xpsq(j)-xpsqxx
2154  xpsq(j)=xpsq(j)-dxpsq
2155  xpvd(jxpv)=xpvd(jxpv)+dxpsq
2156  ELSEIF(amsvq1.LT.amau)THEN
2157  IF(xtvd(iittv)*ecm**2.LE.1.d-12)THEN
2158  WRITE(6,*)' xksamp: XTVD(IITTV)=0 ',iittv
2159  xtvd(iittv)=0.1d0
2160  ENDIF
2161  xpsqw=amau/(xtvd(iittv)*ecm**2)
2162  dxpsq=xpsqw-xpsq(j)
2163  isxtvd(iittv)=1
2164  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2165  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2166  xpsq(j)=xpsqw
2167  ENDIF
2168  ENDIF
2169  IF(amsvq2.GT.amiu)THEN
2170  ELSEIF(amsvq2.LT.amiu)THEN
2171  IF(xtvq(iittv)*ecm**2.LE.1.d-12)THEN
2172  WRITE(6,*)' xksamp: XTVQ(IITTV)=0 ',iittv
2173  xtvq(iittv)=0.1d0
2174  ENDIF
2175  xpsqw=amiu/(xtvq(iittv)*ecm**2)
2176  dxpsq=xpsqw-xpsaq(j)
2177  isxtvq(iittv)=1
2178  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2179  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2180  xpsaq(j)=xpsqw
2181  ENDIF
2182  ENDIF
2183  ENDIF
2184 C5270 CONTINUE
2185 C-----------------------------------------------------------------
2186  goto 260
2187  ENDIF
2188  IF(ipev.GE.6)WRITE(6,'(A,6I5)')
2189  *' XKSAMP s-v loop I(NN),J(IXPS),iitt,iittv,NSV,NDV',
2190  + i,j, iitt,iittv,nsv,ndv
2191  250 CONTINUE
2192  ENDIF
2193  260 CONTINUE
2194  270 CONTINUE
2195 C
2196 C COLLECTION OF THE VALENCE-SEA PAIRS
2197  nvs=0
2198  nvd=0
2199  DO 300 i=1,nn
2200  IF(intlo(i)) THEN
2201  iipp=inter1(i)
2202  iitt=inter2(i)
2203  iippv=itovp(iipp)
2204  DO 280 j=1,ixts
2205  IF(zuovp(iippv).AND.zuost(j).AND.(ifrost(j).EQ.iitt)) THEN
2206  zuost(j)=.false.
2207  IF(ipev.GE.6)WRITE(6,*)
2208  * ' XKSAMP v-s loop IIPP,IITT,IIPPV,NVS,NVD,I,J,IXTS',
2209  * iipp,iitt,iippv,nvs,nvd,i,j,ixts
2210  zuovp(iippv)=.false.
2211  intlo(i)=.false.
2212 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2213  IF(rndm(v).GT.amedd.AND.idiqua.EQ.1)THEN
2214 C DEFINE V-D CHAINS (valence - sea diquark)
2215  CALL diqvs(ecm,iippv,j,irej)
2216  IF(ipev.GE.6)WRITE(6,*)
2217  * ' XKSAMP v-s loop IIPP,IITT,IIPPV,NVS,NVD,I,J,IXTS,JXTV'
2218  * ,iipp,iitt,iippv,nvs,nvd,i,j,ixts,jxtv
2219  IF(irej.EQ.0)go to 290
2220  ENDIF
2221  nvs=nvs + 1
2222  nchvs1(nvs)=0
2223  nchvs2(nvs)=0
2224  intvs1(nvs)=iippv
2225  intvs2(nvs)=j
2226 C----------------correct vs chains to get minimum mass ------
2227  amvsq1=xpvq(iippv)*xtsaq(j)*ecm**2
2228  amvsq2=xpvd(iippv)*xtsq(j)*ecm**2
2229  jxtv=itovt(iitt)
2230  IF(itsq(j).EQ.3)THEN
2231 C IF(AMVSQ1.GT.AMIS)THEN
2232  IF(amvsq1.LT.amis)THEN
2233  IF(xpvq(iippv)*ecm**2.LE.1.d-12)THEN
2234  WRITE(6,*)' xksamp: XPVQ(IIPPV)=0 ',iippv
2235  xpvq(iippv)=0.1d0
2236  ENDIF
2237  xtsqw=amis/(xpvq(iippv)*ecm**2)
2238  dxtsq=xtsqw-xtsaq(j)
2239  isxpvq(iippv)=1
2240  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2241  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2242  xtsaq(j)=xtsqw
2243  ENDIF
2244  ENDIF
2245  IF(amvsq2.GT.amas)THEN
2246  IF(xpvd(iippv)*ecm**2.LE.1.d-12)THEN
2247  WRITE(6,*)' xksamp: XPVD(IIPPV)=0 ',iippv
2248  xpvd(iippv)=0.1d0
2249  ENDIF
2250  xtsqth=amas/(xpvd(iippv)*ecm**2)
2251  xtsqxx=sampex(xtsqth,xtsq(j))
2252  dxtsq=xtsq(j)-xtsqxx
2253  xtsq(j)=xtsq(j)-dxtsq
2254  xtvd(jxtv)=xtvd(jxtv)+dxtsq
2255  ELSEIF(amvsq2.LT.amas)THEN
2256  IF(xpvd(iippv)*ecm**2.LE.1.d-12)THEN
2257  WRITE(6,*)' xksamp: XPVD(IIPPV)=0 ',iippv
2258  xpvd(iippv)=0.1d0
2259  ENDIF
2260  xtsqw=amas/(xpvd(iippv)*ecm**2)
2261  dxtsq=xtsqw-xtsq(j)
2262  isxpvd(iippv)=1
2263  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2264  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2265  xtsq(j)=xtsqw
2266  ENDIF
2267  ENDIF
2268  ELSE
2269 C IF(AMVSQ1.GT.AMIU)THEN
2270  IF(amvsq1.LT.amiu)THEN
2271  IF(xpvq(iippv)*ecm**2.LE.1.d-12)THEN
2272  WRITE(6,*)' xksamp: XPVQ(IIPPV)=0 ',iippv
2273  xpvq(iippv)=0.1d0
2274  ENDIF
2275  xtsqw=amiu/(xpvq(iippv)*ecm**2)
2276  dxtsq=xtsqw-xtsaq(j)
2277  isxpvq(iippv)=1
2278  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2279  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2280  xtsaq(j)=xtsqw
2281  ENDIF
2282  ENDIF
2283  IF(amvsq2.GT.amau)THEN
2284  IF(xpvd(iippv)*ecm**2.LE.1.d-12)THEN
2285  WRITE(6,*)' xksamp: XPVD(IIPPV)=0 ',iippv
2286  xpvd(iippv)=0.1d0
2287  ENDIF
2288  xtsqth=amau/(xpvd(iippv)*ecm**2)
2289  xtsqxx=sampex(xtsqth,xtsq(j))
2290  dxtsq=xtsq(j)-xtsqxx
2291  xtsq(j)=xtsq(j)-dxtsq
2292  xtvd(jxtv)=xtvd(jxtv)+dxtsq
2293  ELSEIF(amvsq2.LT.amau)THEN
2294  IF(xpvd(iippv)*ecm**2.LE.1.d-12)THEN
2295  WRITE(6,*)' xksamp: XPVD(IIPPV)=0 ',iippv
2296  xpvd(iippv)=0.1d0
2297  ENDIF
2298  xtsqw=amau/(xpvd(iippv)*ecm**2)
2299  dxtsq=xtsqw-xtsq(j)
2300  isxpvd(iippv)=1
2301  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2302  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2303  xtsq(j)=xtsqw
2304  ENDIF
2305  ENDIF
2306  ENDIF
2307 C-----------------------------------------------------------------
2308  goto 290
2309  ENDIF
2310  280 CONTINUE
2311  ENDIF
2312  290 CONTINUE
2313  300 CONTINUE
2314 C End loop: COLLECTION OF THE VALENCE-SEA PAIRS
2315 C
2316 C COLLECTION OF THE SEA-SEA PAIRS
2317 *--------------------- new version 8/03/1991 hjm
2318  nss=0
2319  nds=0
2320  nsd=0
2321  ndz=0
2322  nzd=0
2323  DO 420 i=1,nn
2324  IF(intlo(i)) THEN
2325  iipp=inter1(i)
2326  iitt=inter2(i)
2327  DO 400 j=1,ixts
2328  IF(zuost(j).AND.(ifrost(j).EQ.iitt)) THEN
2329  DO 390 jj=1,ixps
2330  IF(zuosp(jj).AND.(ifrosp(jj).EQ.iipp)) THEN
2331  nss=nss+1
2332  IF(ipev.GE.6)WRITE(6,'(A,5I5)')
2333  * ' XKSAMP s-s loop IIPP,IITT,NSS',iipp,iitt,nss
2334  nchss1(nss)=0
2335  nchss2(nss)=0
2336  IF(ipev.GE.6)WRITE(6,*)
2337  * ' XKSAMP s-s loop ,NCHSS1(NSS),NCHSS2(NSS),NSS ',
2338  * nchss1(nss),nchss2(nss),nss
2339  intss1(nss)=jj
2340  intss2(nss)=j
2341  intlo(i)=.false.
2342  zuost(j)=.false.
2343  zuosp(jj)=.false.
2344 C-------------------------------------------Mass check j.r.12/94-------
2345  ssma1q=xpsq(jj)*xtsaq(j)*ecm**2
2346  ssma2q=xpsaq(jj)*xtsq(j)*ecm**2
2347  IF(ssma1q.LT.1.2d0.OR.ssma2q.LT.1.2d0) THEN
2348  zuost(j)=.true.
2349  zuosp(jj)=.true.
2350  nss=nss-1
2351  go to 410
2352  ENDIF
2353 C-------------------------------------------Mass check j.r.12/94-------
2354 C**********************************************************************
2355 C**********************************************************************
2356 C
2357 C Chain recombination option
2358 C
2359  allket=(nvv+ixps+ixts)
2360  IF(allket.LE.1.d-5)THEN
2361  WRITE(6,*)' xksamp ALLKET=0' , allket
2362  allket=1.
2363  ENDIf
2364 C VALFRA=NVV/ALLKET
2365 C j.r.31.3.95
2366  anvvo=min(ixpv,ixtv)
2367  ansvo=ixtv-anvvo
2368  anvso=ixpv-anvvo
2369  ansso=(ixpv+ixps)-anvvo-ansvo-anvso
2370  IF(anvvo+ansso.LE.1.d-5)THEN
2371  WRITE(6,*)' xksamp (...)=0' ,anvvo,ansso
2372  ansso=1.
2373  ENDIf
2374 C VALFRA=1.D0
2375  IF(anvvo+ansso.GT.1.d-5)valfra=anvvo/(anvvo+ansso)
2376 C IF(IRECOM.EQ.1.AND.RNDM(VALFRA).GT.VALFRA)THEN
2377  IF(irecom.EQ.1)THEN
2378 C--- sea-sea pair found, is there a v-v pair suitable for recombination
2379 C 1. is there a v-v chain pair belonging to same projectile
2380 C 2. is there a v-v chain pair belonging to same target
2381  DO 4201 ivv=1,nvv
2382  IF (nchvv1(ivv).NE.99.AND.nchvv2(ivv).NE.99)THEN
2383  ixvpr=intvv1(ivv)
2384  inucpr=ifrovp(ixvpr)
2385  ixvta=intvv2(ivv)
2386  inucta=ifrovt(ixvta)
2387  IF(iipp.EQ.inucpr.OR.iitt.EQ.inucta)THEN
2388 C suitable v-v chain pair found, calculate masses of recombined ch's
2389 C old chains:
2390 C SSMA1Q=XPSQ(JJ)*XTSAQ(J)*ECM**2
2391 C SSMA2Q=XPSAQ(JJ)*XTSQ(J)*ECM**2
2392 C VVMA1Q=XPVQ(IXVPR)*XTVD(IXVTA)*ECM**2
2393 C VVMA2Q=XPVD(IXVPR)*XTVQ(IXVTA)*ECM**2
2394 C new chains:
2395 C SVMA1Q=XPSQ(JJ)*XTVD(IXVTA)*ECM**2
2396 C SVMA2Q=XPSAQ(JJ)*XTVQ(IXVTA)*ECM**2
2397 C VSMA1Q=XPVQ(IXVPR)*XTSAQ(J)*ECM**2
2398 C VSMA2Q=XPVD(IXVPR)*XTSQ(J)*ECM**2
2399 C
2400 C drop old v-v and s-s chains
2401 C
2402  nchss1(nss)=99
2403  nchss2(nss)=99
2404  nchvv1(ivv)=99
2405  nchvv2(ivv)=99
2406  IF(ipev.GE.6)WRITE(6,*)
2407  * ' XKSAMP before DIQSV ,NCHSS1(NSS),',
2408  * 'NCHSS2(NSS),NSS ',
2409  * nchss1(nss),nchss2(nss),nss
2410 C
2411 C assign new s-v and v-s chains
2412 C
2413 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2414  IF(rndm(v).GT.amedd.AND.idiqua.EQ.1)THEN
2415 C DEFINE D-V CHAINS (SEA-DIQUARK-VALENCE)
2416  CALL diqsv(ecm,ixvta,jj,irej)
2417  IF(irej.EQ.0)go to 4202
2418  ENDIF
2419  IF(ipev.GE.6)WRITE(6,*)
2420  * ' XKSAMP: NSS,NSV,NVS ',nss,nsv,nvs
2421  nsv=nsv+1
2422  intsv1(nsv)=jj
2423  intsv2(nsv)=ixvta
2424  IF(ipev.GE.6)WRITE(6,*)
2425  * ' XKSAMP: NSS,NSV,NVS ',nss,nsv,nvs
2426 C----------------correct sv chains to get minimum mass ------
2427  amsvq1=xpsq(jj)*xtvd(ixvta)*ecm**2
2428  amsvq2=xpsaq(jj)*xtvq(ixvta)*ecm**2
2429  jxpv=itovp(iipp)
2430  IF(ipev.GE.6)WRITE(6,'(A,5I5)')
2431  *' XKSAMP s-s loop rec sv,vs IXVTA,JXPV,JJ',ixvta,jxpv,jj
2432  IF(ipsq(jj).EQ.3)THEN
2433  IF(amsvq1.GT.amas)THEN
2434  IF(xtvd(ixvta)*ecm**2.LE.1.d-12)THEN
2435  WRITE(6,*)
2436  * ' xksamp: XTVD(IXVTA)=0 ',ixvta
2437  xtvd(ixvta)=0.1d0
2438  ENDIF
2439  xpsqth=amas/(xtvd(ixvta)*ecm**2)
2440  xpsqxx=sampex(xpsqth,xpsq(jj))
2441  dxpsq=xpsq(jj)-xpsqxx
2442  xpsq(jj)=xpsq(jj)-dxpsq
2443  xpvd(jxpv)=xpvd(jxpv)+dxpsq
2444  ELSEIF(amsvq1.LT.amas)THEN
2445  IF(xtvd(ixvta)*ecm**2.LE.1.d-12)THEN
2446  WRITE(6,*)
2447  * 'xksamp: XTVD(IXVTA)=0 ',ixvta
2448  xtvd(ixvta)=0.1d0
2449  ENDIF
2450  xpsqw=amas/(xtvd(ixvta)*ecm**2)
2451  dxpsq=xpsqw-xpsq(jj)
2452  isxtvd(ixvta)=1
2453  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2454  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2455  xpsq(jj)=xpsqw
2456  ENDIF
2457  ENDIF
2458 C IF(AMSVQ2.GT.AMIS)THEN
2459  IF(amsvq2.LT.amis)THEN
2460  IF(xtvq(ixvta)*ecm**2.LE.1.d-12)THEN
2461  WRITE(6,*)
2462  * ' xksamp: XTVQ(IXVTA)=0 ',ixvta
2463  xtvq(ixvta)=0.1d0
2464  ENDIF
2465  xpsqw=amis/(xtvq(ixvta)*ecm**2)
2466  dxpsq=xpsqw-xpsaq(jj)
2467  isxtvq(ixvta)=1
2468  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2469  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2470 C s.r.xpsaq statt xpsq! 1294
2471  xpsaq(jj)=xpsqw
2472  ENDIF
2473  ENDIF
2474  ELSE
2475  IF(amsvq1.GT.amau)THEN
2476  IF(xtvd(ixvta)*ecm**2.LE.1.d-12)THEN
2477  WRITE(6,*)
2478  * ' xksamp: XTVD(IXVTA)=0 ',ixvta
2479  xtvd(ixvta)=0.1d0
2480  ENDIF
2481  xpsqth=amau/(xtvd(ixvta)*ecm**2)
2482  xpsqxx=sampex(xpsqth,xpsq(jj))
2483  dxpsq=xpsq(jj)-xpsqxx
2484  xpsq(jj)=xpsq(jj)-dxpsq
2485  xpvd(jxpv)=xpvd(jxpv)+dxpsq
2486  ELSEIF(amsvq1.LT.amau)THEN
2487  IF(xtvd(ixvta)*ecm**2.LE.1.d-12)THEN
2488  WRITE(6,*)
2489  * ' xksamp: XTVD(IXVTA)=0 ',ixvta
2490  xtvd(ixvta)=0.1d0
2491  ENDIF
2492  xpsqw=amau/(xtvd(ixvta)*ecm**2)
2493  dxpsq=xpsqw-xpsq(jj)
2494  isxtvd(ixvta)=1
2495  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2496  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2497  xpsq(jj)=xpsqw
2498  ENDIF
2499  ENDIF
2500 C IF(AMSVQ2.GT.AMIU)THEN
2501  IF(amsvq2.LT.amiu)THEN
2502  IF(xtvq(ixvta)*ecm**2.LE.1.d-12)THEN
2503  WRITE(6,*)
2504  * ' xksamp: XTVQ(IXVTA)=0 ',ixvta
2505  xtvq(ixvta)=0.1d0
2506  ENDIF
2507  xpsqw=amiu/(xtvq(ixvta)*ecm**2)
2508  dxpsq=xpsqw-xpsaq(jj)
2509  isxtvq(ixvta)=1
2510  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2511  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2512 C s.r.xpsaq statt xpsq! 1294
2513  xpsaq(jj)=xpsqw
2514  ENDIF
2515  ENDIF
2516  ENDIF
2517  4202 CONTINUE
2518 C-----------------------------------------------------------------
2519 C
2520 C assign new s-v and v-s chains
2521 C
2522 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2523  IF(rndm(v).GT.amedd.AND.idiqua.EQ.1)THEN
2524 C DEFINE V-D CHAINS (valence - sea diquark)
2525  CALL diqvs(ecm,ixvpr,j,irej)
2526  IF(irej.EQ.0)go to 4203
2527  ENDIF
2528  IF(ipev.GE.6)WRITE(6,*)
2529  * ' XKSAMP: NSS,NSV,NVS ',nss,nsv,nvs
2530  nvs=nvs+1
2531  intvs1(nvs)=ixvpr
2532  intvs2(nvs)=j
2533  IF(ipev.GE.6)WRITE(6,*)
2534  * ' XKSAMP: NSS,NSV,NVS ',nss,nsv,nvs
2535 C------###-------correct vs chains to get minimum mass ------
2536  amvsq1=xpvq(ixvpr)*xtsaq(j)*ecm**2
2537  amvsq2=xpvd(ixvpr)*xtsq(j)*ecm**2
2538  jxtv=itovt(iitt)
2539  IF(ipev.GE.6)WRITE(6,'(A,5I5)')
2540  *' XKSAMP s-s loop rec vs IXVTA,JXPV,JJ',ixvta,jxpv,jj
2541  IF(itsq(j).EQ.3)THEN
2542 C IF(AMVSQ1.GT.AMIS)THEN
2543  IF(amvsq1.LT.amis)THEN
2544  IF(xpvq(ixvpr)*ecm**2.LE.1.d-12)THEN
2545  WRITE(6,*)
2546  * ' xksamp: XPVQ(IXVPR)=0 ',ixvpr
2547  xpvq(ixvpr)=0.1d0
2548  ENDIF
2549  xtsqw=amis/(xpvq(ixvpr)*ecm**2)
2550  dxtsq=xtsqw-xtsaq(j)
2551  isxpvq(ixvpr)=1
2552  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2553  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2554  xtsaq(j)=xtsqw
2555  ENDIF
2556  ENDIF
2557  IF(amvsq2.GT.amas)THEN
2558  IF(xpvd(ixvpr)*ecm**2.LE.1.d-12)THEN
2559  WRITE(6,*)
2560  * ' xksamp: XPVD(IXVPR)=0 ',ixvpr
2561  xpvd(ixvpr)=0.1d0
2562  ENDIF
2563  xtsqth=amas/(xpvd(ixvpr)*ecm**2)
2564  xtsqxx=sampex(xtsqth,xtsq(j))
2565  dxtsq=xtsq(j)-xtsqxx
2566  xtsq(j)=xtsq(j)-dxtsq
2567  xtvd(jxtv)=xtvd(jxtv)+dxtsq
2568  ELSEIF(amvsq2.LT.amas)THEN
2569  IF(xpvd(ixvpr)*ecm**2.LE.1.d-12)THEN
2570  WRITE(6,*)
2571  * ' xksamp: XPVD(IXVPR)=0 ',ixvpr
2572  xpvd(ixvpr)=0.1d0
2573  ENDIF
2574  xtsqw=amas/(xpvd(ixvpr)*ecm**2)
2575  isxpvd(ixvpr)=1
2576  dxtsq=xtsqw-xtsq(j)
2577  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2578  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2579  xtsq(j)=xtsqw
2580  ENDIF
2581  ENDIF
2582  ELSE
2583 C IF(AMVSQ1.GT.AMIU)THEN
2584  IF(amvsq1.LT.amiu)THEN
2585  IF(xpvq(ixvpr)*ecm**2.LE.1.d-12)THEN
2586  WRITE(6,*)
2587  * ' xksamp: XPVQ(IXVPR)=0 ',ixvpr
2588  xpvq(ixvpr)=0.1d0
2589  ENDIF
2590  xtsqw=amiu/(xpvq(ixvpr)*ecm**2)
2591  dxtsq=xtsqw-xtsaq(j)
2592  isxpvq(ixvpr)=1
2593  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2594  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2595  xtsaq(j)=xtsqw
2596  ENDIF
2597  ENDIF
2598  IF(amvsq2.GT.amau)THEN
2599  IF(xpvd(ixvpr)*ecm**2.LE.1.d-12)THEN
2600  WRITE(6,*)
2601  * ' xksamp: XPVD(IXVPR)=0 ',ixvpr
2602  xpvd(ixvpr)=0.1d0
2603  ENDIF
2604  xtsqth=amau/(xpvd(ixvpr)*ecm**2)
2605  xtsqxx=sampex(xtsqth,xtsq(j))
2606  dxtsq=xtsq(j)-xtsqxx
2607  xtsq(j)=xtsq(j)-dxtsq
2608  xtvd(jxtv)=xtvd(jxtv)+dxtsq
2609  ELSEIF(amvsq2.LT.amau)THEN
2610  IF(xpvd(ixvpr)*ecm**2.LE.1.d-12)THEN
2611  WRITE(6,*)
2612  * ' xksamp: XPVD(IXVPR)=0 ',ixvpr
2613  xpvd(ixvpr)=0.1d0
2614  ENDIF
2615  xtsqw=amau/(xpvd(ixvpr)*ecm**2)
2616  dxtsq=xtsqw-xtsq(j)
2617  isxpvd(ixvpr)=1
2618  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2619  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2620  xtsq(j)=xtsqw
2621  ENDIF
2622  ENDIF
2623  ENDIF
2624  4203 CONTINUE
2625 C-----------------------------------------------------------------
2626 C
2627 C jump out of s-s chain loop
2628 C
2629  go to 420
2630  ENDIF
2631  ENDIF
2632  4201 CONTINUE
2633  ENDIF
2634 C of loop recombination IF(IRECOM.EQ.1)THEN
2635 C**********************************************************************
2636 C we continue in s-s loop
2637 C**********************************************************************
2638 C
2639 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2640  IF(rndm(v).GT.2.d0*amedd-1.d0.AND.idiqua.EQ.1)THEN
2641 C DEFINE D-S CHAINS (SEA-DIQUARK---SEA)
2642  CALL diqdss(ecm,j,jj,irej)
2643  IF(irej.EQ.0) THEN
2644  nchss1(nss)=99
2645  nchss2(nss)=99
2646  IF(ipev.GE.6)WRITE(6,*)
2647  * ' XKSAMP AFTER DIQDSS IREJ=0',
2648  * ',NCHSS1(NSS),NCHSS2(NSS),NSS ',
2649  * nchss1(nss),nchss2(nss),nss
2650  go to 410
2651  ENDIF
2652  ENDIF
2653 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2654  IF(rndm(v).GT.2.d0*amedd-1.d0.AND.idiqua.EQ.1)THEN
2655 C DEFINE S-D CHAINS (SEA---SEA-DIQUARK)
2656  CALL diqssd(ecm,j,jj,irej)
2657  IF(irej.EQ.0) THEN
2658  nchss1(nss)=99
2659  nchss2(nss)=99
2660  IF(ipev.GE.6)WRITE(6,*)
2661  * ' XKSAMP AFTER DIQSSD IREJ=0',
2662  * ',NCHSS1(NSS),NCHSS2(NSS),NSS ',
2663  * nchss1(nss),nchss2(nss),nss
2664  go to 410
2665  ENDIF
2666  ENDIF
2667  ssma1q=xpsq(jj)*xtsaq(j)*ecm**2
2668  ssma2q=xpsaq(jj)*xtsq(j)*ecm**2
2669  IF(ssma1q.LT.ssmimq.OR.ssma2q.LT.ssmimq) THEN
2670  jxpv=itovp(iipp)
2671  jxtv=itovt(iitt)
2672  IF((xtvd(jxtv).GT.xdthr+3.5d0*xssthr)
2673  * .AND.(xpvd(jxpv)
2674  + .GT.xdthr+3.5d0*xssthr)) THEN
2675 * maximum allowed x values for sea quarks
2676  xspmax=1.0 - xpvq(jxpv) - xdthr - 1.2*xssthr
2677  xstmax=1.0 - xtvq(jxtv) - xdthr - 1.2*xssthr
2678 * resampling of x values not possible / discard s-s interaction
2679  IF((xspmax.LE.xssthr+0.05d0) .OR.(xstmax.LE.xssthr
2680  + +0.05d0)) goto 380
2681 * resampling for projectile sea quark pair
2682  icous=0
2683  310 CONTINUE
2684  icous=icous + 1
2685  IF(xssthr.GT.0.05d0) THEN
2686  xpsqi=betrej(xseacu,unosea,xssthr,xspmax)
2687  xpsaqi=betrej(xseacu,unosea,xssthr,xspmax)
2688  ELSE
2689  320 CONTINUE
2690  xpsqi=dbetar(xseacu,unosea)
2691  IF(xpsqi.LT.xssthr.OR.xpsqi.GT.xspmax) goto 320
2692  330 CONTINUE
2693  xpsaqi=dbetar(xseacu,unosea)
2694  IF(xpsaqi.LT.xssthr.OR.xpsaqi.GT.xspmax)
2695  + goto 330
2696  ENDIF
2697 * final test of remaining x for projectile diquark
2698  xpvdco=xpvd(jxpv) - xpsqi - xpsaqi + xpsq(jj) +
2699  + xpsaq(jj)
2700  IF(xpvdco.GT.xdthr) THEN
2701 * projectile x sampling ok / continue with target sea
2702  goto 340
2703  ELSEIF(icous.LT.5) THEN
2704  goto 310
2705  ELSE
2706 * too many unsuccessful attempts / discard s-s interaction
2707  goto 380
2708  ENDIF
2709 * resampling for target sea quark pair
2710  340 CONTINUE
2711  icous=0
2712  350 CONTINUE
2713  icous=icous + 1
2714  IF(xssthr.GT.0.05d0)THEN
2715  xtsqi=betrej(xseacu,unosea,xssthr,xstmax)
2716  xtsaqi=betrej(xseacu,unosea,xssthr,xstmax)
2717  ELSE
2718  360 CONTINUE
2719  xtsqi=dbetar(xseacu,unosea)
2720  IF(xtsqi.LT.xssthr.OR.xtsqi.GT.xstmax) goto 360
2721  370 CONTINUE
2722  xtsaqi=dbetar(xseacu,unosea)
2723  IF(xtsaqi.LT.xssthr.OR.xtsaqi.GT.xstmax)
2724  + goto 370
2725  ENDIF
2726 * final test of remaining x for target diquark
2727  xtvdco=xtvd(jxtv) - xtsqi - xtsaqi + xtsq(j) +
2728  + xtsaq(j)
2729  IF(xtvdco.LT.xdthr) THEN
2730 * repeat x sampling for target sea quarks
2731  IF(icous.LT.5) goto 350
2732 * discard s-s interaction / too many unsuccessful trials
2733  goto 380
2734  ENDIF
2735 * modification of x values acceptable
2736  xpvd(jxpv)=xpvdco
2737  xtvd(jxtv)=xtvdco
2738  xpsq(jj)=xpsqi
2739  xpsaq(jj)=xpsaqi
2740  xtsq(j)=xtsqi
2741  xtsaq(j)=xtsaqi
2742  goto 410
2743 * consider next s-s interaction
2744  ENDIF
2745 * discard s-s interaction
2746 * resampling of x values not allowed or unsuccessful
2747  380 CONTINUE
2748  intlo(i)=.false.
2749  zuost(j)=.true.
2750  zuosp(jj)=.true.
2751  nss=nss - 1
2752  ENDIF
2753 * consider next s-s interaction
2754  goto 410
2755  ENDIF
2756  390 CONTINUE
2757  ENDIF
2758  400 CONTINUE
2759  ENDIF
2760  410 CONTINUE
2761  420 CONTINUE
2762 C
2763 C CORRECT X-VALUES OF VALENCE QUARKS
2764 C FOR NON-MATCHING SEA QUARKS
2765  DO 430 i=1,ixps
2766  IF(zuosp(i)) THEN
2767  iifrop=ifrosp(i)
2768  iitop=itovp(iifrop)
2769  xpvq(iitop)=xpvq(iitop) + xpsq(i) + xpsaq(i)
2770  zuosp(i)=.false.
2771  ENDIF
2772  430 CONTINUE
2773  DO 440 i=1,ixts
2774  IF(zuost(i)) THEN
2775  iifrot=ifrost(i)
2776  iitot=itovt(iifrot)
2777  xtvq(iitot)=xtvq(iitot) + xtsq(i) + xtsaq(i)
2778  zuost(i)=.false.
2779  ENDIF
2780  440 CONTINUE
2781 C
2782  DO 450 i=1,ixpv
2783  IF(zuovp(i)) THEN
2784  ipip=ifrovp(i)
2785  isthkk(ipip)=13
2786  ENDIF
2787  450 CONTINUE
2788  DO 460 i=1,ixtv
2789  IF(zuovt(i)) THEN
2790  itit=ifrovt(i)
2791  isthkk(itit+ip)=14
2792  ENDIF
2793  460 CONTINUE
2794 C
2795  IF(ipev.GE.6) THEN
2796  WRITE(6,'(A)') ' XKSAMP: I,INTVV1,INTVV2,IFROVP,IFROVT'
2797  DO 470 i=1,nvv
2798  inup=intvv1(i)
2799  inut=intvv2(i)
2800  WRITE(6,'(5I5)') i,inup,inut,ifrovp(inup),ifrovt(inut)
2801  470 CONTINUE
2802  WRITE(6,'(A)')'XKSAMP:I(NSV),INTSV1,INTSV2,IFROSP,IFROVT'
2803  DO 480 i=1,nsv
2804  inup=intsv1(i)
2805  inut=intsv2(i)
2806  WRITE(6,'(5I5)') i,inup,inut,ifrosp(inup),ifrovt(inut)
2807  480 CONTINUE
2808  WRITE(6,'(A)') ' XKSAMP: I,INTVS1,INTVS2,IFROVP,IFROST'
2809  DO 490 i=1,nvs
2810  inup=intvs1(i)
2811  inut=intvs2(i)
2812  WRITE(6,'(5I5)') i,inup,inut,ifrovp(inup),ifrost(inut)
2813  490 CONTINUE
2814  WRITE(6,'(A)') ' XKSAMP: I,INTSS1,INTSS2,IFROSP,IFROST'
2815  DO 500 i=1,nss
2816  inup=intss1(i)
2817  inut=intss2(i)
2818  WRITE(6,'(5I5)') i,inup,inut,ifrosp(inup),ifrost(inut)
2819  500 CONTINUE
2820 C
2821  WRITE(6,'(A)')
2822  + ' XKSAMP : FINAL X-VALUES AFTER POTENTIAL CORRECTION'
2823  WRITE(6,1010)
2824  DO 510 i=1,ixpv
2825  WRITE(6,1020) i,xpvq(i),xpvd(i),ifrovp(i),itovp(i),zuovp(i)
2826  WRITE(6,*)' I(1-IXPV),IPVQ(I),IPPV1(I),IPPV2(I) ',
2827  * i,ipvq(i),ippv1(i),ippv2(i)
2828  510 CONTINUE
2829  WRITE(6,1030)
2830  DO 520 i=1,ixps
2831  WRITE(6,1040) i,xpsq(i),xpsaq(i),ifrosp(i),zuosp(i)
2832  WRITE(6,*)' I(1-IXPS),IPSQ(I),IPSAQ(I) ',
2833  * i,ipsq(i),ipsaq(i)
2834  520 CONTINUE
2835  WRITE(6,1050)
2836  DO 530 i=1,ixtv
2837  WRITE(6,1020) i,xtvq(i),xtvd(i),ifrovt(i),itovt(i),zuovt(i)
2838  WRITE(6,*)' I(1-IXTV),ITVQ(I),ITTV1(I),ITTV2(I) ',
2839  * i,itvq(i),ittv1(i),ittv2(i)
2840  530 CONTINUE
2841  WRITE(6,1060)
2842  DO 540 i=1,ixts
2843  WRITE(6,1040) i,xtsq(i),xtsaq(i),ifrost(i),zuost(i)
2844  WRITE(6,*)' I(1-IXTS),ITSQ(I),ITSAQ(I) ',
2845  * i,itsq(i),itsaq(i)
2846  540 CONTINUE
2847  ENDIF
2848  IF(ipev.GE.6)WRITE(6,'(A,6I5)')
2849  *' XKSAMP NSV,NDV,NVS,NVD',
2850  + nsv,ndv,nvs,nvd
2851 * store properties of interacting partons into /HKKEVT/
2852  CALL parhkk
2853  RETURN
2854  END
2855 *-- Author :
2856 *
2857 *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2858 *
2859  SUBROUTINE parhkk
2860  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2861  SAVE
2862 C
2863 C STORE INTERACTING PARTONS IN /HKKEVT/
2864 C X-VALUES STORED IN PHKK(3,...) AND PHKK(4,...)
2865 C POSITIONS OF NUCLEONS STORED IN VHKK
2866 C FLAG FOR PROJECTILE VALENCE: ISTHKK=21
2867 C PROJECTILE SEA : ISTHKK=31
2868 C FLAG FOR TARGET VALENCE : ISTHKK=22
2869 C TARGET SEA : ISTHKK=32
2870 *KEEP,INTMX.
2871  parameter(intmx=2488,intmd=252)
2872 *KEEP,DXQX.
2873 C INCLUDE (XQXQ)
2874 * NOTE: INTMX set via INCLUDE(INTMX)
2875  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
2876  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
2877  * ,xpsu(248),xtsu(248)
2878  * ,xpsut(248),xtsut(248)
2879 *KEEP,INTNEW.
2880  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
2881  +ixpv,ixps,ixtv,ixts, intvv1(248),
2882  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
2883  +intss1(intmx),intss2(intmx),
2884  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
2885  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
2886 
2887 C /INTNEW/
2888 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
2889 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
2890 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
2891 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
2892 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
2893 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
2894 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
2895 C FROM PROJECTILE/TARGET NUCLEI
2896 C-------------------
2897 *KEEP,IFROTO.
2898  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
2899  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
2900  +jhkknt
2901  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
2902  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
2903  & mhkkhh(intmx),
2904  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
2905 *KEEP,LOZUO.
2906  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
2907  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
2908  +intlo(intmx),inloss(intmx)
2909 C /LOZUO/
2910 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
2911 C REJECTED IN KKEVT
2912 C------------------
2913 *KEEP,DIQI.
2914  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
2915  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
2916  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
2917  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
2918 *KEEP,HKKEVT.
2919 c INCLUDE (HKKEVT)
2920  parameter(nmxhkk= 89998)
2921 c PARAMETER (NMXHKK=25000)
2922  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
2923  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
2924  +(4,nmxhkk)
2925 C
2926 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
2927 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
2928 C THE POSITIONS OF THE PROJECTILE NUCLEONS
2929 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
2930 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
2931 C COMPLETELY CONSISTENT. THE TIMES IN THE
2932 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
2933 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
2934 C
2935 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
2936 C
2937 C NMXHKK: maximum numbers of entries (partons/particles) that can be
2938 C stored in the commonblock.
2939 C
2940 C NHKK: the actual number of entries stored in current event. These are
2941 C found in the first NHKK positions of the respective arrays below.
2942 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
2943 C entry.
2944 C
2945 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
2946 C = 0 : null entry.
2947 C = 1 : an existing entry, which has not decayed or fragmented.
2948 C This is the main class of entries which represents the
2949 C "final state" given by the generator.
2950 C = 2 : an entry which has decayed or fragmented and therefore
2951 C is not appearing in the final state, but is retained for
2952 C event history information.
2953 C = 3 : a documentation line, defined separately from the event
2954 C history. (incoming reacting
2955 C particles, etc.)
2956 C = 4 - 10 : undefined, but reserved for future standards.
2957 C = 11 - 20 : at the disposal of each model builder for constructs
2958 C specific to his program, but equivalent to a null line in the
2959 C context of any other program. One example is the cone defining
2960 C vector of HERWIG, another cluster or event axes of the JETSET
2961 C analysis routines.
2962 C = 21 - : at the disposal of users, in particular for event tracking
2963 C in the detector.
2964 C
2965 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
2966 C standard.
2967 C
2968 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
2969 C The value is 0 for initial entries.
2970 C
2971 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
2972 C one mother exist, in which case the value 0 is used. In cluster
2973 C fragmentation models, the two mothers would correspond to the q
2974 C and qbar which join to form a cluster. In string fragmentation,
2975 C the two mothers of a particle produced in the fragmentation would
2976 C be the two endpoints of the string (with the range in between
2977 C implied).
2978 C
2979 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
2980 C entry has not decayed, this is 0.
2981 C
2982 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
2983 C entry has not decayed, this is 0. It is assumed that the daughters
2984 C of a particle (or cluster or string) are stored sequentially, so
2985 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
2986 C daughters. Even in cases where only one daughter is defined (e.g.
2987 C K0 -> K0S) both values should be defined, to make for a uniform
2988 C approach in terms of loop constructions.
2989 C
2990 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
2991 C
2992 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
2993 C
2994 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
2995 C
2996 C PHKK(4,IHKK) : energy, in GeV.
2997 C
2998 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
2999 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
3000 C
3001 C VHKK(1,IHKK) : production vertex x position, in mm.
3002 C
3003 C VHKK(2,IHKK) : production vertex y position, in mm.
3004 C
3005 C VHKK(3,IHKK) : production vertex z position, in mm.
3006 C
3007 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
3008 C********************************************************************
3009 *KEEP,SHMAKL.
3010 C INCLUDE (SHMAKL)
3011 * NOTE: INTMX set via INCLUDE(INTMX)
3012  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
3013 *KEEP,DPRIN.
3014  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3015 *KEND.
3016 C----------------------------------
3017  DO 10 i=1,ixpv
3018  nhkk=nhkk+1
3019  IF (nhkk.EQ.nmxhkk)THEN
3020  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3021  RETURN
3022  ENDIF
3023  isthkk(nhkk)=21
3024  kkkhkk=ifrovp(i)
3025  kkk=jhkknp(kkkhkk)
3026  jmohkk(1,nhkk)=kkk
3027  jmohkk(2,nhkk)=0
3028  jdahkk(1,nhkk)=0
3029  jdahkk(2,nhkk)=0
3030  phkk(1,nhkk)=0.
3031  phkk(2,nhkk)=0.
3032  phkk(3,nhkk)=xpvq(i)
3033  phkk(4,nhkk)=xpvq(i)
3034  phkk(5,nhkk)=0.
3035 C Add here position of parton in hadron
3036  vhkk(1,nhkk)=vhkk(1,kkk)
3037  vhkk(2,nhkk)=vhkk(2,kkk)
3038  vhkk(3,nhkk)=vhkk(3,kkk)
3039  vhkk(4,nhkk)=0.
3040 C
3041  IF (iphkk.GE.3) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3042  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3043  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3044 
3045 C
3046  nhkk=nhkk+1
3047  IF (nhkk.EQ.nmxhkk)THEN
3048  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3049  RETURN
3050  ENDIF
3051  isthkk(nhkk)=21
3052 C KKKHKK=IFROVP(I)
3053  kkk=jhkknp(kkkhkk)
3054  jmohkk(1,nhkk)=kkk
3055  jmohkk(2,nhkk)=0
3056  jdahkk(1,nhkk)=0
3057  jdahkk(2,nhkk)=0
3058  phkk(1,nhkk)=0.
3059  phkk(2,nhkk)=0.
3060  phkk(3,nhkk)=xpvd(i)
3061  phkk(4,nhkk)=xpvd(i)
3062  phkk(5,nhkk)=0.
3063 C Add here position of parton in hadron
3064  vhkk(1,nhkk)=vhkk(1,kkk)
3065  vhkk(2,nhkk)=vhkk(2,kkk)
3066  vhkk(3,nhkk)=vhkk(3,kkk)
3067  vhkk(4,nhkk)=0.
3068  jhkkpv(i)=nhkk
3069 C
3070  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3071  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3072  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3073 
3074  1000 FORMAT (i6,i4,5i6,9e10.2)
3075  10 CONTINUE
3076 C **** PROJECTILE SEA
3077  DO 20 i=1,ixps
3078  nhkk=nhkk+1
3079  IF (nhkk.EQ.nmxhkk)THEN
3080  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3081  RETURN
3082  ENDIF
3083  isthkk(nhkk)=31
3084  kkkhkk=ifrosp(i)
3085  kkk=jhkknp(kkkhkk)
3086  jmohkk(1,nhkk)=kkk
3087  jmohkk(2,nhkk)=0
3088  jdahkk(1,nhkk)=0
3089  jdahkk(2,nhkk)=0
3090  phkk(1,nhkk)=0.
3091  phkk(2,nhkk)=0.
3092  phkk(3,nhkk)=xpsq(i)
3093  phkk(4,nhkk)=xpsq(i)
3094  phkk(5,nhkk)=0.
3095 C Add here position of parton in hadron
3096  vhkk(1,nhkk)=vhkk(1,kkk)
3097  vhkk(2,nhkk)=vhkk(2,kkk)
3098  vhkk(3,nhkk)=vhkk(3,kkk)
3099  vhkk(4,nhkk)=0.
3100 C
3101  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3102  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3103  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3104 
3105 C
3106  nhkk=nhkk+1
3107  IF (nhkk.EQ.nmxhkk)THEN
3108  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3109  RETURN
3110  ENDIF
3111  isthkk(nhkk)=31
3112  kkkhkk=ifrosp(i)
3113  kkk=jhkknp(kkkhkk)
3114  jmohkk(1,nhkk)=kkk
3115  jmohkk(2,nhkk)=0
3116  jdahkk(1,nhkk)=0
3117  jdahkk(2,nhkk)=0
3118  phkk(1,nhkk)=0.
3119  phkk(2,nhkk)=0.
3120  phkk(3,nhkk)=xpsaq(i)
3121  phkk(4,nhkk)=xpsaq(i)
3122  phkk(5,nhkk)=0.
3123 C Add here position of parton in hadron
3124  vhkk(1,nhkk)=vhkk(1,kkk)
3125  vhkk(2,nhkk)=vhkk(2,kkk)
3126  vhkk(3,nhkk)=vhkk(3,kkk)
3127  vhkk(4,nhkk)=0.
3128  jhkkps(i)=nhkk
3129 C
3130  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3131  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3132  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3133 
3134  20 CONTINUE
3135 C ***** TARGET VALENCE
3136  DO 30 i=1,ixtv
3137  nhkk=nhkk+1
3138  IF (nhkk.EQ.nmxhkk)THEN
3139  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3140  RETURN
3141  ENDIF
3142  isthkk(nhkk)=22
3143  kkkhkk=ifrovt(i)
3144  kkk=jhkknt(kkkhkk)
3145  jmohkk(1,nhkk)=kkk
3146  jmohkk(2,nhkk)=0
3147  jdahkk(1,nhkk)=0
3148  jdahkk(2,nhkk)=0
3149  phkk(1,nhkk)=0.
3150  phkk(2,nhkk)=0.
3151  phkk(3,nhkk)=xtvq(i)
3152  phkk(4,nhkk)=xtvq(i)
3153  phkk(5,nhkk)=0.
3154 C Add here position of parton in hadron
3155  vhkk(1,nhkk)=vhkk(1,kkk)
3156  vhkk(2,nhkk)=vhkk(2,kkk)
3157  vhkk(3,nhkk)=vhkk(3,kkk)
3158  vhkk(4,nhkk)=0.
3159 C
3160  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3161  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3162  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3163 
3164 C
3165  nhkk=nhkk+1
3166  IF (nhkk.EQ.nmxhkk)THEN
3167  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3168  RETURN
3169  ENDIF
3170  isthkk(nhkk)=22
3171  kkkhkk=ifrovt(i)
3172  kkk=jhkknt(kkkhkk)
3173  jmohkk(1,nhkk)=kkk
3174  jmohkk(2,nhkk)=0
3175  jdahkk(1,nhkk)=0
3176  jdahkk(2,nhkk)=0
3177  phkk(1,nhkk)=0.
3178  phkk(2,nhkk)=0.
3179  phkk(3,nhkk)=xtvd(i)
3180  phkk(4,nhkk)=xtvd(i)
3181  phkk(5,nhkk)=0.
3182 C Add here position of parton in hadron
3183  vhkk(1,nhkk)=vhkk(1,kkk)
3184  vhkk(2,nhkk)=vhkk(2,kkk)
3185  vhkk(3,nhkk)=vhkk(3,kkk)
3186  vhkk(4,nhkk)=0.
3187  jhkktv(i)=nhkk
3188 C
3189  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3190  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3191  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3192 
3193  30 CONTINUE
3194 C ***** TARGET SEA
3195  DO 40 i=1,ixts
3196  nhkk=nhkk+1
3197  IF (nhkk.EQ.nmxhkk)THEN
3198  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3199  RETURN
3200  ENDIF
3201  isthkk(nhkk)=32
3202  kkkhkk=ifrost(i)
3203  kkk=jhkknt(kkkhkk)
3204  jmohkk(1,nhkk)=kkk
3205  jmohkk(2,nhkk)=0
3206  jdahkk(1,nhkk)=0
3207  jdahkk(2,nhkk)=0
3208  phkk(1,nhkk)=0.
3209  phkk(2,nhkk)=0.
3210  phkk(3,nhkk)=xtsq(i)
3211  phkk(4,nhkk)=xtsq(i)
3212  phkk(5,nhkk)=0.
3213 C Add here position of parton in hadron
3214  vhkk(1,nhkk)=vhkk(1,kkk)
3215  vhkk(2,nhkk)=vhkk(2,kkk)
3216  vhkk(3,nhkk)=vhkk(3,kkk)
3217  vhkk(4,nhkk)=0.
3218 C
3219  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3220  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3221  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3222 
3223 C
3224  nhkk=nhkk+1
3225  IF (nhkk.EQ.nmxhkk)THEN
3226  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3227  RETURN
3228  ENDIF
3229  isthkk(nhkk)=32
3230  kkkhkk=ifrost(i)
3231  kkk=jhkknt(kkkhkk)
3232  jmohkk(1,nhkk)=kkk
3233  jmohkk(2,nhkk)=0
3234  jdahkk(1,nhkk)=0
3235  jdahkk(2,nhkk)=0
3236  phkk(1,nhkk)=0.
3237  phkk(2,nhkk)=0.
3238  phkk(3,nhkk)=xtsaq(i)
3239  phkk(4,nhkk)=xtsaq(i)
3240  phkk(5,nhkk)=0.
3241 C Add here position of parton in hadron
3242  vhkk(1,nhkk)=vhkk(1,kkk)
3243  vhkk(2,nhkk)=vhkk(2,kkk)
3244  vhkk(3,nhkk)=vhkk(3,kkk)
3245  vhkk(4,nhkk)=0.
3246  jhkkts(i)=nhkk
3247 C
3248  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3249  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3250  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3251 
3252  40 CONTINUE
3253  RETURN
3254  END
3255 *-- Author :
3256 C
3257 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3258 C
3259  SUBROUTINE hadrkk(NHKKH1,PPN)
3260  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3261  SAVE
3262 C
3263 C HADRKK CONSTRUCTS ONE HADRONIZED EVENT FOR KK-COLLISIONS
3264 C ALL TYPES OF CHAINS ARE CONSIDERED
3265 C OPTONALLY GIVEN TYPES ARE SELECTED ACCORDING TO /DROPPT/
3266 C
3267 C--------------------------------------------------------------------
3268 *KEEP,INTMX.
3269  parameter(intmx=2488,intmd=252)
3270 *KEEP,DXQX.
3271 C INCLUDE (XQXQ)
3272 * NOTE: INTMX set via INCLUDE(INTMX)
3273  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
3274  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
3275  * ,xpsu(248),xtsu(248)
3276  * ,xpsut(248),xtsut(248)
3277 *KEEP,INTNEW.
3278  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
3279  +ixpv,ixps,ixtv,ixts, intvv1(248),
3280  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
3281  +intss1(intmx),intss2(intmx),
3282  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
3283  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
3284 
3285 C /INTNEW/
3286 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
3287 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
3288 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
3289 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
3290 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
3291 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
3292 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
3293 C FROM PROJECTILE/TARGET NUCLEI
3294 C-------------------
3295 *KEEP,IFROTO.
3296  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
3297  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
3298  +jhkknt
3299  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
3300  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
3301  & mhkkhh(intmx),
3302  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
3303 *KEEP,LOZUO.
3304  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
3305  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
3306  +intlo(intmx),inloss(intmx)
3307 C /LOZUO/
3308 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
3309 C REJECTED IN KKEVT
3310 C------------------
3311 *KEEP,DIQI.
3312  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
3313  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
3314  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
3315  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
3316 *KEEP,HKKEVT.
3317 c INCLUDE (HKKEVT)
3318  parameter(nmxhkk= 89998)
3319 c PARAMETER (NMXHKK=25000)
3320  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
3321  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
3322  +(4,nmxhkk)
3323 C
3324 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
3325 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
3326 C THE POSITIONS OF THE PROJECTILE NUCLEONS
3327 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
3328 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
3329 C COMPLETELY CONSISTENT. THE TIMES IN THE
3330 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
3331 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
3332 C
3333 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
3334 C
3335 C NMXHKK: maximum numbers of entries (partons/particles) that can be
3336 C stored in the commonblock.
3337 C
3338 C NHKK: the actual number of entries stored in current event. These are
3339 C found in the first NHKK positions of the respective arrays below.
3340 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
3341 C entry.
3342 C
3343 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
3344 C = 0 : null entry.
3345 C = 1 : an existing entry, which has not decayed or fragmented.
3346 C This is the main class of entries which represents the
3347 C "final state" given by the generator.
3348 C = 2 : an entry which has decayed or fragmented and therefore
3349 C is not appearing in the final state, but is retained for
3350 C event history information.
3351 C = 3 : a documentation line, defined separately from the event
3352 C history. (incoming reacting
3353 C particles, etc.)
3354 C = 4 - 10 : undefined, but reserved for future standards.
3355 C = 11 - 20 : at the disposal of each model builder for constructs
3356 C specific to his program, but equivalent to a null line in the
3357 C context of any other program. One example is the cone defining
3358 C vector of HERWIG, another cluster or event axes of the JETSET
3359 C analysis routines.
3360 C = 21 - : at the disposal of users, in particular for event tracking
3361 C in the detector.
3362 C
3363 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
3364 C standard.
3365 C
3366 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
3367 C The value is 0 for initial entries.
3368 C
3369 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
3370 C one mother exist, in which case the value 0 is used. In cluster
3371 C fragmentation models, the two mothers would correspond to the q
3372 C and qbar which join to form a cluster. In string fragmentation,
3373 C the two mothers of a particle produced in the fragmentation would
3374 C be the two endpoints of the string (with the range in between
3375 C implied).
3376 C
3377 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
3378 C entry has not decayed, this is 0.
3379 C
3380 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
3381 C entry has not decayed, this is 0. It is assumed that the daughters
3382 C of a particle (or cluster or string) are stored sequentially, so
3383 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
3384 C daughters. Even in cases where only one daughter is defined (e.g.
3385 C K0 -> K0S) both values should be defined, to make for a uniform
3386 C approach in terms of loop constructions.
3387 C
3388 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
3389 C
3390 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
3391 C
3392 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
3393 C
3394 C PHKK(4,IHKK) : energy, in GeV.
3395 C
3396 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
3397 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
3398 C
3399 C VHKK(1,IHKK) : production vertex x position, in mm.
3400 C
3401 C VHKK(2,IHKK) : production vertex y position, in mm.
3402 C
3403 C VHKK(3,IHKK) : production vertex z position, in mm.
3404 C
3405 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
3406 C********************************************************************
3407 *KEEP,SHMAKL.
3408 C INCLUDE (SHMAKL)
3409 * NOTE: INTMX set via INCLUDE(INTMX)
3410  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
3411 *KEEP,NNCMS.
3412  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
3413 *KEEP,DROPPT.
3414  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
3415  +ishmal,lpauli
3416  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
3417  +ipadis,ishmal,lpauli
3418 *KEEP,CMHICO.
3419  COMMON /cmhico/ cmhis
3420 *KEEP,DPRIN.
3421  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3422 *KEEP,DPAR.
3423 C /DPAR/ CONTAINS PARTICLE PROPERTIES
3424 C ANAME = LITERAL NAME OF THE PARTICLE
3425 C AAM = PARTICLE MASS IN GEV
3426 C GA = DECAY WIDTH
3427 C TAU = LIFE TIME OF INSTABLE PARTICLES
3428 C IICH = ELECTRIC CHARGE OF THE PARTICLE
3429 C IIBAR = BARYON NUMBER
3430 C K1,K1 = BEGIN AND END OF DECAY CHANNELS OF PARTICLE
3431 C
3432  CHARACTER*8 aname
3433  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
3434  +iibar(210),k1(210),k2(210)
3435 C------------------
3436 *KEND.
3437 C modified DPMJET
3438  COMMON /bufues/ bnnvv,bnnss,bnnsv,bnnvs,bnncc,
3439  * bnndv,bnnvd,bnnds,bnnsd,
3440  * bnnhh,bnnzz,
3441  * bptvv,bptss,bptsv,bptvs,bptcc,bptdv,
3442  * bptvd,bptds,bptsd,
3443  * bpthh,bptzz,
3444  * beevv,beess,beesv,beevs,beecc,beedv,
3445  * beevd,beeds,beesd,
3446  * beehh,beezz
3447  * ,bnndi,bptdi,beedi
3448  * ,bnnzd,bnndz,bptzd,bptdz,beezd,beedz
3449  COMMON /ncoucs/ bcouvv,bcouss,bcousv,bcouvs,
3450  * bcouzz,bcouhh,bcouds,bcousd,
3451  * bcoudz,bcouzd,bcoudi,
3452  * bcoudv,bcouvd,bcoucc
3453  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
3454  * anndv,annvd,annds,annsd,
3455  * annhh,annzz,
3456  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
3457  * pthh,ptzz,
3458  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
3459  * eehh,eezz
3460  * ,anndi,ptdi,eedi
3461  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
3462  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
3463  * acouzz,acouhh,acouds,acousd,
3464  * acoudz,acouzd,acoudi,
3465  * acoudv,acouvd,acoucc
3466 C---------------------
3467  COMMON /jspa/pxs(40000),pys(40000),pzs(40000),hes(40000),nnnps
3468 C---------------------
3469  COMMON /bamco/ nvdd
3470  LOGICAL lseadi
3471  COMMON /seadiq/ lseadi
3472  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
3473  common/diquax/amedd,idiqua,idiquu
3474  COMMON /secint/isecin
3475  DATA ievcou/0/
3476 C-------------
3477  nnnps=0
3478  ievcou=ievcou+1
3479  nhkkh1=nhkk
3480  IF (ipco.GE.1) WRITE(6,1000) nvv,nvs,nsv,nss
3481  1000 FORMAT (' ENTERING HADRKK NVV,NVS,NSV,NSS '/5i5)
3482 C----------------------------------------------------------------------
3483 C++++++++++++++ HADRONIZE SOFT SEA-SEA CHAINS ++++++++++++++++++++++
3484 C---
3485 C INITIALIZE COUNTERS
3486  annvv=0.001
3487  annss=0.001
3488  annsv=0.001
3489  annvs=0.001
3490  anncc=0.001
3491  anndv=0.001
3492  annvd=0.001
3493  annds=0.001
3494  annsd=0.001
3495  annhh=0.001
3496  annzz=0.001
3497  anndi=0.001
3498  annzd=0.001
3499  anndz=0.001
3500  ptvv=0.
3501  ptss=0.
3502  ptsv=0.
3503  ptvs=0.
3504  ptcc=0.
3505  ptdv=0.
3506  ptvd=0.
3507  ptds=0.
3508  ptsd=0.
3509  pthh=0.
3510  ptzz=0.
3511  ptdi=0.
3512  ptzd=0.
3513  ptdz=0.
3514  eevv=0.
3515  eess=0.
3516  eesv=0.
3517  eevs=0.
3518  eecc=0.
3519  eedv=0.
3520  eevd=0.
3521  eeds=0.
3522  eesd=0.
3523  eehh=0.
3524  eezz=0.
3525  eedi=0.
3526  eezd=0.
3527  eedz=0.
3528 C COMMON /NCOUCH/ ACOUVV,ACOUSS,ACOUSV,ACOUVS,
3529 C * ACOUZZ,ACOUHH,ACOUDS,ACOUSD,
3530 C * ACOUDZ,ACOUZD,ACOUDI
3531  acouvv=0.
3532  acouss=0.
3533  acousv=0.
3534  acouvs=0.
3535  acouzz=0.
3536  acouhh=0.
3537  acouds=0.
3538  acousd=0.
3539  acoudz=0.
3540  acouzd=0.
3541  acoudi=0.
3542  acoudv=0.
3543  acouvd=0.
3544  acoucc=0.
3545 *
3546  IF(ihada.OR.ihadss) THEN
3547  nvdd=0
3548  CALL hadrss
3549  ENDIF
3550  IF(ihada.OR.ihadsv) THEN
3551  CALL casasv
3552  ENDIF
3553  IF(ihada.OR.ihadvs) THEN
3554  CALL casavs
3555  ENDIF
3556  IF (iminij.EQ.1) CALL hadrhh
3557  CALL hadrzz
3558  IF(idiquu.EQ.1) CALL hadrdz
3559  IF(idiquu.EQ.1) CALL hadrzd
3560 C
3561 C
3562 C---------------------------------------------------------------
3563 C+++++++++++++++++++ HADRONIZE sea diquark - sea CHAINS +++++++
3564 C
3565 C IF(IHADA.OR.LSEADI) THEN
3566  IF(ihada) THEN
3567  nvdd=0
3568  IF(idiqua.EQ.1) CALL hadrds
3569  ENDIF
3570 C
3571 C+++++++++++++++++++ HADRONIZE sea - sea diquark CHAINS +++++++
3572 C
3573 C IF(IHADA.OR.LSEADI) THEN
3574  IF(ihada) THEN
3575  nvdd=0
3576  IF(idiqua.EQ.1) CALL hadrsd
3577  ENDIF
3578 C
3579 C
3580 C---------------------------------------------------------------
3581 C+++++++++++++++++++ HADRONIZE SEA-VALENCE CHAINS +++++++++++++++++
3582 C
3583  IF(ihada.OR.ihadsv) THEN
3584  nvdd=0
3585  CALL hadrsv
3586  ENDIF
3587 C
3588 C---------------------------------------------------------------
3589 C+++++++++++++++++++ HADRONIZE sea diquark - VALENCE CHAINS +++++++
3590 C
3591 C IF(IHADA.OR.LSEADI) THEN
3592  IF(ihada) THEN
3593  nvdd=0
3594  IF(idiqua.EQ.1) CALL hadrdv
3595  ENDIF
3596 C
3597 C----------------------------------------------------------------------
3598 C+++++++++++++++++++ HADRONIZE VALENCE-SEA CHAINS +++++++++++++++++
3599 C
3600  IF(ihada.OR.ihadvs) THEN
3601  nvdd=0
3602  CALL hadrvs
3603  ENDIF
3604 C
3605 C+++++++++++++++++++ HADRONIZE valence - sea diquark CHAINS +++++++
3606 C
3607 C IF(IHADA.OR.LSEADI) THEN
3608  IF(ihada) THEN
3609  nvdd=0
3610  IF(idiqua.EQ.1) CALL hadrvd
3611  ENDIF
3612 C
3613 C----------------------------------------------------------------------
3614 C HADRONIZE VALENCE-VALENCE CHAINS
3615 C---
3616  IF(ihada.OR.ihadvv) THEN
3617  nvdd=0
3618  CALL hadrvv
3619  ENDIF
3620 C
3621 C----------------------------------------------------------------------
3622 C HADRONIZE combined (qq)-(aqaq) chains
3623 C---
3624 C IF(IHADA.AND.LCOMBI) THEN
3625 C NVDD=15
3626 C CALL HADRCC
3627 C ENDIF
3628 C
3629 C---------------------------------------------------------------
3630 C OPTIONAL TEST OF
3631 C ENERGY-MOMENTUM CONSERVATION
3632 C IN NUCLEON-NUCLEON CMS
3633  IF (ipco.GE.1)THEN
3634  pxsu=0.
3635  pysu=0.
3636  pzsu=0.
3637  esum=0.
3638  ichsu=0
3639  ibasu=0
3640  WRITE(6,'(A)') ' HADRONS FROM HADRKK / NUCLEON-NUCLEON CMS'
3641  DO 10 i=nhkkh1+1,nhkk
3642  IF(isthkk(i).EQ.1)THEN
3643  pxsu=pxsu + phkk(1,i)
3644  pysu=pysu + phkk(2,i)
3645  pzsu=pzsu + phkk(3,i)
3646  esum=esum + phkk(4,i)
3647  nref=mcihad(idhkk(i))
3648  ichsu=ichsu + iich(nref)
3649  ibasu=ibasu + iibar(nref)
3650  IF (ipco.GE.7)
3651  * WRITE(6,1010)i,(phkk(j,i),j=1,5), iich(nref),iibar(nref),nref,
3652  + aname(nref)
3653  1010 FORMAT(5x,i4,5(1pe11.3),2i2,i5,a10)
3654  ENDIF
3655  10 CONTINUE
3656  WRITE(6,1020) pxsu,pysu,pzsu,esum,ichsu,ibasu
3657  1020 FORMAT(' PXSU,PYSU,PZSU,ESUM,ICHSU,IBASU'/4f10.3,2i5)
3658  ENDIF
3659 C
3660  CALL dechkk(nhkkh1)
3661 C
3662 C----------------------------------------------------------------------
3663 C LT FROM NUCLEON-NUCLEON CMS INTO LAB
3664 C PUT LAB SYSTEM PARTICLES INTO /HKKEVT/
3665  cmhiss=1.d0
3666  DO 20 i=nhkkh1+1,nhkk
3667  pznn=phkk(3,i)
3668  enn =phkk(4,i)
3669  IF (cmhiss.EQ.0.d0)THEN
3670 C PHKK(3,I) = GAMCM*PZNN + BGCM*ENN
3671 C PHKK(4,I) = GAMCM*ENN + BGCM*PZNN
3672  phkk(3,i) = gamcm*pznn + bgcm*enn
3673  phkk(4,i) = gamcm*enn + bgcm*pznn
3674  ENDIF
3675  ehecc=sqrt(phkk(1,i)** 2+ phkk(2,i)** 2+ phkk(3,i)** 2+ phkk
3676  + (5,i)**2)
3677  IF (abs(ehecc-phkk(4,i)).GT.0.001d0) THEN
3678 C WRITE(6,'(2A/3I5,3E16.6)')
3679 C & ' HADRKK: CORRECT INCONSISTENT ENERGY ',
3680 C * ' IEVCOU, I,IDHKK(I), PHKK(4,I),EHECC, PHKK(5,I)',
3681 C * IEVCOU, I,IDHKK(I), PHKK(4,I),EHECC, PHKK(5,I)
3682  phkk(4,i)=ehecc
3683  ENDIF
3684  20 CONTINUE
3685 C Secondary Interactions
3686  IF(isecin.EQ.1)CALL sewew(1,nhkkh1)
3687  ktauac=99
3688 C IF (CMHIS.EQ.0.D0) CALL DISTR(2,NHKKH1,PPN,KTAUAC)
3689 C
3690 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3691 C OPTIONAL TEST OF
3692 C ENERGY-MOMENTUM CONSERVATION IN LAB SYSTEM
3693  IF (ipco.GE.2)THEN
3694  pxsu=0.
3695  pysu=0.
3696  pzsu=0.
3697  esum=0.
3698  ichsu=0
3699  ibasu=0
3700  WRITE(6,'(A)') ' HADRONS FROM HADRKK / CMS SYSTEM'
3701  DO 30 i=nhkkh1+1,nhkk
3702  IF(isthkk(i).EQ.1)THEN
3703  pxsu=pxsu + phkk(1,i)
3704  pysu=pysu + phkk(2,i)
3705  pzsu=pzsu + phkk(3,i)
3706  esum=esum + phkk(4,i)
3707  nref=mcihad(idhkk(i))
3708  ichsu=ichsu + iich(nref)
3709  ibasu=ibasu + iibar(nref)
3710  IF (ipco.GE.7)
3711  * WRITE(6,1010) i, (phkk(j,i),j=1,5), iich(nref),iibar(nref),
3712  + nref,aname(nref)
3713  ENDIF
3714  30 CONTINUE
3715  WRITE(6,1020) pxsu,pysu,pzsu,esum,ichsu,ibasu
3716  ENDIF
3717 C
3718 C------------------------------------------------------------------
3719 C
3720  RETURN
3721  END
3722 *-- Author :
3723 C
3724 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3725 C
3726  SUBROUTINE hadrvv
3727  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3728  SAVE
3729 C
3730 C-------------------------
3731 C
3732 C HADRONIZE VALENCE-VALENCE CHAINS
3733 C
3734 C ADD GENERATED HADRONS TO /ALLPAR/
3735 C STARTING AT (NAUX + 1)
3736 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
3737 C
3738 C-------------------------
3739 *KEEP,INTMX.
3740  parameter(intmx=2488,intmd=252)
3741 *KEEP,DXQX.
3742 C INCLUDE (XQXQ)
3743 * NOTE: INTMX set via INCLUDE(INTMX)
3744  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
3745  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
3746  * ,xpsu(248),xtsu(248)
3747  * ,xpsut(248),xtsut(248)
3748 *KEEP,INTNEW.
3749  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
3750  +ixpv,ixps,ixtv,ixts, intvv1(248),
3751  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
3752  +intss1(intmx),intss2(intmx),
3753  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
3754  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
3755 
3756 C /INTNEW/
3757 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
3758 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
3759 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
3760 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
3761 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
3762 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
3763 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
3764 C FROM PROJECTILE/TARGET NUCLEI
3765 C-------------------
3766 *KEEP,IFROTO.
3767  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
3768  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
3769  +jhkknt
3770  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
3771  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
3772  & mhkkhh(intmx),
3773  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
3774 *KEEP,LOZUO.
3775  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
3776  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
3777  +intlo(intmx),inloss(intmx)
3778 C /LOZUO/
3779 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
3780 C REJECTED IN KKEVT
3781 C------------------
3782 *KEEP,DIQI.
3783  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
3784  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
3785  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
3786  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
3787 *KEEP,HKKEVT.
3788 c INCLUDE (HKKEVT)
3789  parameter(nmxhkk= 89998)
3790 c PARAMETER (NMXHKK=25000)
3791  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
3792  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
3793  +(4,nmxhkk)
3794 C
3795 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
3796 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
3797 C THE POSITIONS OF THE PROJECTILE NUCLEONS
3798 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
3799 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
3800 C COMPLETELY CONSISTENT. THE TIMES IN THE
3801 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
3802 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
3803 C
3804 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
3805 C
3806 C NMXHKK: maximum numbers of entries (partons/particles) that can be
3807 C stored in the commonblock.
3808 C
3809 C NHKK: the actual number of entries stored in current event. These are
3810 C found in the first NHKK positions of the respective arrays below.
3811 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
3812 C entry.
3813 C
3814 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
3815 C = 0 : null entry.
3816 C = 1 : an existing entry, which has not decayed or fragmented.
3817 C This is the main class of entries which represents the
3818 C "final state" given by the generator.
3819 C = 2 : an entry which has decayed or fragmented and therefore
3820 C is not appearing in the final state, but is retained for
3821 C event history information.
3822 C = 3 : a documentation line, defined separately from the event
3823 C history. (incoming reacting
3824 C particles, etc.)
3825 C = 4 - 10 : undefined, but reserved for future standards.
3826 C = 11 - 20 : at the disposal of each model builder for constructs
3827 C specific to his program, but equivalent to a null line in the
3828 C context of any other program. One example is the cone defining
3829 C vector of HERWIG, another cluster or event axes of the JETSET
3830 C analysis routines.
3831 C = 21 - : at the disposal of users, in particular for event tracking
3832 C in the detector.
3833 C
3834 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
3835 C standard.
3836 C
3837 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
3838 C The value is 0 for initial entries.
3839 C
3840 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
3841 C one mother exist, in which case the value 0 is used. In cluster
3842 C fragmentation models, the two mothers would correspond to the q
3843 C and qbar which join to form a cluster. In string fragmentation,
3844 C the two mothers of a particle produced in the fragmentation would
3845 C be the two endpoints of the string (with the range in between
3846 C implied).
3847 C
3848 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
3849 C entry has not decayed, this is 0.
3850 C
3851 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
3852 C entry has not decayed, this is 0. It is assumed that the daughters
3853 C of a particle (or cluster or string) are stored sequentially, so
3854 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
3855 C daughters. Even in cases where only one daughter is defined (e.g.
3856 C K0 -> K0S) both values should be defined, to make for a uniform
3857 C approach in terms of loop constructions.
3858 C
3859 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
3860 C
3861 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
3862 C
3863 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
3864 C
3865 C PHKK(4,IHKK) : energy, in GeV.
3866 C
3867 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
3868 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
3869 C
3870 C VHKK(1,IHKK) : production vertex x position, in mm.
3871 C
3872 C VHKK(2,IHKK) : production vertex y position, in mm.
3873 C
3874 C VHKK(3,IHKK) : production vertex z position, in mm.
3875 C
3876 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
3877 C********************************************************************
3878 *KEEP,NUCC.
3879  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
3880 *KEEP,ABRVV.
3881  COMMON /abrvv/ amcvv1(248),amcvv2(248),gacvv1(248),gacvv2(248),
3882  +bgxvv1(248),bgyvv1(248),bgzvv1(248), bgxvv2(248),bgyvv2(248),
3883  +bgzvv2(248), nchvv1(248),nchvv2(248),ijcvv1(248),ijcvv2(248),
3884  +pqvva1(248,4),pqvva2(248,4), pqvvb1(248,4),pqvvb2(248,4)
3885 *KEEP,DPRIN.
3886  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3887 *KEEP,DFINPA.
3888  CHARACTER*8 anf
3889  parameter(nfimax=249)
3890  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
3891  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
3892  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
3893  * istath(nfimax)
3894 *KEEP,PROJK.
3895  COMMON /projk/ iprojk
3896 *KEND.
3897 C modified DPMJET
3898  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
3899  * anndv,annvd,annds,annsd,
3900  * annhh,annzz,
3901  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
3902  * pthh,ptzz,
3903  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
3904  * eehh,eezz
3905  * ,anndi,ptdi,eedi
3906  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
3907  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
3908  * acouzz,acouhh,acouds,acousd,
3909  * acoudz,acouzd,acoudi,
3910  * acoudv,acouvd,acoucc
3911  common/popcck/pdbck,pdbse,pdbseu,
3912  * ijpock,irejck,ick4,ihad4,ick6,ihad6
3913  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
3914  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
3915  *isea43,isea63,irejao
3916 C---------------------
3917  COMMON /zsea/zseaav,zseasu,anzsea
3918 C---------------------
3919  dimension poj(4),pat(4)
3920  DATA ncalvv /0/
3921  IF(iphkk.GE.6)WRITE (6,'( A)') ' hadrVV'
3922 C-----------------------------------------------------------------
3923  ncalvv=ncalvv+1
3924  DO 50 i=1,nvv
3925 C-----------------------drop recombined chain pairs
3926  IF(nchvv1(i).EQ.99.AND.nchvv2(i).EQ.99) go to 50
3927  is1=intvv1(i)
3928  is2=intvv2(i)
3929 C
3930  IF (ipco.GE.1) WRITE (6,1000) ipvq(is1),ippv1(is1),ippv2(is1),
3931  + itvq(is2),ittv1(is2),ittv2(is2), amcvv1(i),amcvv2(i),gacvv1(i),
3932  + gacvv2(i), bgxvv1(i),bgyvv1(i),bgzvv1(i), bgxvv2(i),bgyvv2(i),
3933  + bgzvv2(i), nchvv1(i),nchvv2(i),ijcvv1(i),ijcvv2(i), pqvva1(i,4),
3934  + pqvva2(i,4),pqvvb1(i,4),pqvvb2(i,4)
3935 
3936 
3937 
3938  1000 FORMAT(6i5,10f9.2/10x,4i5,4f12.4)
3939 C
3940 C------------------------------ CHAIN 1:
3941 C INCIDENT BARYONS/MESONS: QUARK-DIQUARK
3942 C INCIDENT ANTIBARYONS : AQUARK-QUARK
3943  IF(ibproj.GE.0) THEN
3944  ifb1=ipvq(is1)
3945  ifb2=ittv1(is2)
3946  ifb3=ittv2(is2)
3947  nobam=4
3948  ELSE
3949  ifb1=ipvq(is1)
3950  ifb2=itvq(is2)
3951  ifb1=iabs(ifb1) + 6
3952  nobam=3
3953  ENDIF
3954 C
3955  DO 10 j=1,4
3956  poj(j)=pqvva1(i,j)
3957  pat(j)=pqvva2(i,j)
3958  10 CONTINUE
3959  pt1=sqrt(poj(1)**2+poj(2)**2)
3960  pt2=sqrt(pat(1)**2+pat(2)**2)
3961  CALL parpt(2,pt1,pt2,1,nevt)
3962 C------------------------------------------------------------------
3963 C------------------------------------------------------------------
3964 C------------------------------------------------------------------
3965 C check bookkeeping
3966 C-----------------------------------------------------------------
3967 C I= number of valence chain
3968 C Projectile Nr ipp = IFROVP(INTVV1(I))
3969 C Target Nr itt = IFROVT(INTVV2(I))
3970 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
3971 C No of Glauber sea q at Target JITT=JTSHS(ITT)
3972  ippp = ifrovp(intvv1(i))
3973  ittt = ifrovt(intvv2(i))
3974  jipp=jsshs(ippp)
3975  jitt=jtshs(ittt)
3976 C IF(NCHVV1(I).EQ.0)THEN
3977 C WRITE(6,'(A,5I5)')'HADRVV: I,IPPP,ITTT,JIPP,JITT ',
3978 C * I,IPPP,ITTT,JIPP,JITT
3979 C ENDIF
3980 C------------------------------------------------------------------
3981 C check bookkeeping
3982 C-----------------------------------------------------------------
3983  IF(ipco.GE.1)THEN
3984  WRITE(6,*)' VV q-qq ,IFB1,IFB2,IFB3,',
3985  * 'INTVV1=IS1,INTVV2=IS2,JIPP,JITT',
3986  * ifb1,ifb2,ifb3,intvv1(i),intvv2(i),jipp,jitt
3987  ENDIF
3988  IF(nobam.EQ.3.OR.nchvv1(i).NE.0)THEN
3989 C CALL HADJET(NHAD,AMCVV1(I),PAT,POJ,GACVV1(I),BGXVV1(I), BGYVV1
3990  CALL hadjet(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
3991  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
3992  + nchvv1(i),7)
3993  ENDIF
3994  aack=float(ick4)/float(ick4+ihad4+1)
3995  IF((nchvv1(i).EQ.0).AND.
3996  * (nobam.EQ.4))THEN
3997  zseawu=rndm(bb)*2.d0*zseaav
3998  rseack=float(jitt)*pdbse+ zseawu*pdbseu
3999  IF(ipco.GE.1)WRITE(6,*)'HADJSE JITT,RSEACK,PDBSE 1 dpmnuc3',
4000  + jitt,rseack,pdbse
4001  irejss=5
4002  IF(rndm(v).LE.rseack)THEN
4003  irejss=2
4004  IF(amcvv1(i).GT.2.3d0)THEN
4005  irejss=0
4006  CALL hadjse(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4007  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4008  + nchvv1(i),7,irejss,iissqq)
4009  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JITT,',
4010  * 'RSEACK,IREJSS 1 dpmnuc3 ',
4011  + jitt,rseack,irejss
4012  ENDIF
4013  IF(irejss.GE.1)THEN
4014  IF(irejss.EQ.1)irejse=irejse+1
4015  IF(irejss.EQ.3)irejs3=irejs3+1
4016  IF(irejss.EQ.2)irejs0=irejs0+1
4017  CALL hadjet(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4018  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4019  + nchvv1(i),7)
4020  ihad4=ihad4+1
4021  ENDIF
4022  IF(irejss.EQ.0)THEN
4023  IF(iissqq.EQ.3)THEN
4024  ise43=ise43+1
4025  ELSE
4026  ise4=ise4+1
4027  ENDIF
4028  ENDIF
4029  ELSEIF((ijpock.EQ.1).AND.
4030  * (aack.LE.pdbck))THEN
4031  irej=0
4032  CALL hadjck(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4033  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4034  + nchvv1(i),7,irej)
4035  IF(irej.EQ.1)THEN
4036  irejck=irejck+1
4037  CALL hadjet(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4038  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4039  + nchvv1(i),7)
4040  ihad4=ihad4+1
4041  ENDIF
4042  IF(irej.EQ.0)ick4=ick4+1
4043  ELSE
4044  CALL hadjet(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4045  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4046  + nchvv1(i),7)
4047  ihad4=ihad4+1
4048  ENDIF
4049  ENDIF
4050 C------------------------------------------------------------------
4051 C------------------------------------------------------------------
4052  acouvv=acouvv+1
4053 C*** REMOVED *** 31/07/90 *** ADD HADRONS/RESONANCES INTO
4054 C*** COMMON /ALLPAR/ STARTING AT NAUX
4055  nhkkau=nhkk+1
4056  DO 20 j=1,nhad
4057 C
4058 C NHKK=NHKK+1
4059  IF (nhkk.EQ.nmxhkk) THEN
4060  WRITE (6,'(A,2I5/A)') .EQ.' HADRVV: NHKKNMXHKK ',nhkk,nmxhkk
4061  RETURN
4062  ENDIF
4063 C
4064  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4065  IF (abs(ehecc-hef(j)).GT.0.001d0) THEN
4066 C WRITE(6,'(2A/3I5,3E15.6)')
4067 C & ' HADRVV / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
4068 C * ' NCALVV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4069 C * NCALVV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
4070  hef(j)=ehecc
4071  ENDIF
4072  annvv=annvv+1
4073  eevv=eevv+hef(j)
4074  ptvv=ptvv+sqrt(pxf(j)**2+pyf(j)**2)
4075 C PUT NN-CMS HADRONS INTO /HKKEVT/
4076  istist=1
4077  IF(ibarf(j).EQ.500)istist=2
4078  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvv(i)-3,0,
4079  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),1)
4080 C WRITE(6,*)' HKKFIL: NHKKAU,IORMO(J) ',ISTIST, NHKKAU,IORMO(J)
4081  IF(idhkk(nhkk).EQ.99999) WRITE (6,1010) nhkk,nref(j),idhkk
4082  + (nhkk)
4083  1010 FORMAT (' NHKK,NREF(J), ',3i10)
4084  imohkk=jmohkk(1,nhkk)
4085  IF(imohkk.LE.0.OR.imohkk.GT.nmxhkk)THEN
4086  WRITE(6,'(A,I10)')' HADRVV out of range IMOHKK= ',i10
4087  go to 2020
4088  ENDIF
4089  IF(irejss.LT.0)THEN
4090  WRITE(6,*)' From HADRVV 1 first chain after HKKFIL'
4091  IF (iphkk.GE.0) WRITE(6,1020) nhkk, isthkk(nhkk),idhkk(nhkk),
4092  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4093  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4094  ENDIF
4095  1020 FORMAT (i6,i4,5i6,9e10.2)
4096  20 CONTINUE
4097 C IF(NHAD.GT.0) THEN
4098 C JDAHKK(1,IMOHKK)=NHKKAU
4099 C JDAHKK(2,IMOHKK)=NHKK
4100 C ENDIF
4101  2020 CONTINUE
4102 C
4103 C------------------------------ CHAIN 2
4104 C INCIDENT BARYONS : DIQUARK-QUARK
4105 C INCIDENT MESONS : AQUARK-QUARKC
4106 C INCIDENT ANTIBARYONS: ADIQUARK-DIQUARK
4107 C
4108  IF(ibproj.GT.0) THEN
4109  ifb1=ippv1(is1)
4110  ifb2=ippv2(is1)
4111  ifb3=itvq(is2)
4112  nobam=6
4113  ELSEIF(ibproj.EQ.0) THEN
4114  ifb1=ippv1(is1)
4115  ifb2=itvq(is2)
4116  ifb1=iabs(ifb1) + 6
4117  nobam=3
4118  ELSE
4119  ifb1=ippv1(is1)
4120  ifb2=ippv2(is1)
4121  ifb1=iabs(ifb1) + 6
4122  ifb2=iabs(ifb2) + 6
4123  ifb3=ittv1(is2)
4124  ifb4=ittv2(is2)
4125  nobam=5
4126  ENDIF
4127 C
4128  DO 30 j=1,4
4129  poj(j)=pqvvb2(i,j)
4130  pat(j)=pqvvb1(i,j)
4131  30 CONTINUE
4132  pt1=sqrt(poj(1)**2+poj(2)**2)
4133  pt2=sqrt(pat(1)**2+pat(2)**2)
4134  CALL parpt(2,pt1,pt2,1,nevt)
4135 C*** POJ,PAT EXCHANGED J.R.15.2.90
4136 C*** RECHANGED 19/09/90 HJM
4137 C------------------------------------------------------------------
4138 C check bookkeeping
4139 C-----------------------------------------------------------------
4140 C I= number of valence chain
4141 C Projectile Nr ipp = IFROVP(INTVV1(I))
4142 C Target Nr itt = IFROVT(INTVV2(I))
4143 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
4144 C No of Glauber sea q at Target JITT=JTSHS(ITT)
4145  ippp = ifrovp(intvv1(i))
4146  ittt = ifrovt(intvv2(i))
4147  jipp=jsshs(ippp)
4148  jitt=jtshs(ittt)
4149 C IF(NCHVV2(I).EQ.0)THEN
4150 C WRITE(6,'(A,5I5)')'HadrVV: I,IPPP,ITTT,JIPP,JITT ',
4151 C * I,IPPP,ITTT,JIPP,JITT
4152 C ENDIF
4153 C------------------------------------------------------------------
4154 C check bookkeeping
4155 C-----------------------------------------------------------------
4156  IF(ipco.GE.1)THEN
4157  WRITE(6,*)' VV qq-q ,IFB1,IFB2,IFB3,',
4158  * 'INTVV1=IS1,INTVV2=IS2,JIPP,JITT',
4159  * ifb1,ifb2,ifb3,intvv1(i),intvv2(i),jipp,jitt
4160  ENDIF
4161  IF(nobam.EQ.5.OR.nobam.EQ.3.OR.nchvv2(i).NE.0)THEN
4162 C CALL HADJET(NHAD,AMCVV2(I),PAT,POJ,GACVV2(I),BGXVV2(I), BGYVV2
4163  CALL hadjet(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4164  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4165  + nchvv2(i),8)
4166  ENDIF
4167  aack=float(ick6)/float(ick6+ihad6+1)
4168  IF((nchvv2(i).EQ.0).AND.
4169  * (nobam.EQ.6))THEN
4170  zseawu=rndm(bb)*2.d0*zseaav
4171  rseack=float(jipp)*pdbse+ zseawu*pdbseu
4172  IF(ipco.GE.1)WRITE(6,*)'HADJSE JIPP,RSEACK,PDBSE 2 dpmnuc3',
4173  + jipp,rseack,pdbse
4174  irejss=5
4175  IF(rndm(v).LE.rseack)THEN
4176  irejss=2
4177  IF(amcvv2(i).GT.2.3d0)THEN
4178  irejss=0
4179  CALL hadjse(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4180  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4181  + nchvv2(i),8,irejss,iissqq)
4182  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JIPP,',
4183  * 'RSEACK,IREJSS 2 dpmnux3 ',
4184  + jipp,rseack,irejss
4185  ENDIF
4186  IF(irejss.GE.1)THEN
4187  IF(irejss.EQ.1)irejse=irejse+1
4188  IF(irejss.EQ.3)irejs3=irejs3+1
4189  IF(irejss.EQ.2)irejs0=irejs0+1
4190  CALL hadjet(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4191  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4192  + nchvv2(i),8)
4193  ihad6=ihad6+1
4194  ENDIF
4195  IF(irejss.EQ.0)THEN
4196  IF(iissqq.EQ.3)THEN
4197  ise63=ise63+1
4198  ELSE
4199  ise6=ise6+1
4200  ENDIF
4201  ENDIF
4202  ELSEIF((ijpock.EQ.1).AND.
4203  * (aack.LE.pdbck))THEN
4204  irej=0
4205  CALL hadjck(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4206  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4207  + nchvv2(i),8,irej)
4208  IF(irej.EQ.1)THEN
4209  irejck=irejck+1
4210  CALL hadjet(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4211  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4212  + nchvv2(i),8)
4213  ihad6=ihad6+1
4214  ENDIF
4215  IF(irej.EQ.0)ick6=ick6+1
4216  ELSE
4217  CALL hadjet(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4218  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4219  + nchvv2(i),8)
4220  ihad6=ihad6+1
4221  ENDIF
4222  ENDIF
4223 C ADD HADRONS/RESONANCES INTO
4224 C COMMON /ALLPAR/ STARTING AT NAUX
4225  nhkkau=nhkk+1
4226  DO 40 j=1,nhad
4227 C NHKK=NHKK+1
4228  IF (nhkk.EQ.nmxhkk) THEN
4229  WRITE (6,'(A,2I5/A)') .EQ.' HADRVV: NHKKNMXHKK ',nhkk,nmxhkk
4230  RETURN
4231  ENDIF
4232 C
4233  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4234  IF (abs(ehecc-hef(j)).GT.0.001d0) THEN
4235 C WRITE(6,'(2A/3I5,3E15.6)')
4236 C & ' HADRVV / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
4237 C * ' NCALVV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4238 C * NCALVV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
4239  hef(j)=ehecc
4240  ENDIF
4241 C PUT NN-CMS HADRONS INTO /HKKEVT/
4242  annvv=annvv+1
4243  eevv=eevv+hef(j)
4244  ptvv=ptvv+sqrt(pxf(j)**2+pyf(j)**2)
4245  istist=1
4246  IF(ibarf(j).EQ.500)istist=2
4247  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvv(i),0,
4248  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),2)
4249 C WRITE(6,*)' HKKFIL: NHKKAU,IORMO(J) ',ISTIST, NHKKAU,IORMO(J)
4250  IF(idhkk(nhkk).EQ.99999) WRITE (6,1010)nhkk,nref(j), idhkk
4251  + (nhkk)
4252  imohkk=jmohkk(1,nhkk)
4253  IF(imohkk.LE.0.OR.imohkk.GT.nmxhkk)THEN
4254  WRITE(6,'(A,I10)')' HADRVV out of range IMOHKK= ',i10
4255  go to 4040
4256  ENDIF
4257  IF(irejss.LT.0)THEN
4258  WRITE(6,*)' From HADRVV second chain after HKKFIL'
4259  IF (iphkk.GE.0) WRITE(6,1020) nhkk, isthkk(nhkk),idhkk(nhkk),
4260  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4261  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4262  ENDIF
4263  40 CONTINUE
4264 C IF(NHAD.GT.0) THEN
4265 C JDAHKK(1,IMOHKK)=NHKKAU
4266 C JDAHKK(2,IMOHKK)=NHKK
4267 C ENDIF
4268  4040 CONTINUE
4269  50 CONTINUE
4270 C
4271 C------------------------------------------------------------------
4272 C
4273  RETURN
4274  END
4275 *-- Author :
4276 C
4277 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4278 C
4279  SUBROUTINE hadrsv
4280  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4281  SAVE
4282 C-------------------------
4283 C
4284 C HADRONIZE SEA-VALENCE CHAINS
4285 C
4286 C ADD GENERATED HADRONS TO /ALLPAR/
4287 C STARTING AT (NAUX + 1)
4288 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
4289 C
4290 C---------------------------------------------------------
4291 *KEEP,INTMX.
4292  parameter(intmx=2488,intmd=252)
4293 *KEEP,DXQX.
4294 C INCLUDE (XQXQ)
4295 * NOTE: INTMX set via INCLUDE(INTMX)
4296  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
4297  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
4298  * ,xpsu(248),xtsu(248)
4299  * ,xpsut(248),xtsut(248)
4300  common/popcck/pdbck,pdbse,pdbseu,
4301  * ijpock,irejck,ick4,ihad4,ick6,ihad6
4302  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
4303  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
4304  *isea43,isea63,irejao
4305 *KEEP,INTNEW.
4306  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
4307  +ixpv,ixps,ixtv,ixts, intvv1(248),
4308  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
4309  +intss1(intmx),intss2(intmx),
4310  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
4311  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
4312 
4313 C /INTNEW/
4314 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
4315 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
4316 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
4317 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
4318 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
4319 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
4320 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
4321 C FROM PROJECTILE/TARGET NUCLEI
4322 C-------------------
4323 *KEEP,IFROTO.
4324  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
4325  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
4326  +jhkknt
4327  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
4328  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
4329  & mhkkhh(intmx),
4330  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
4331 *KEEP,LOZUO.
4332  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
4333  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
4334  +intlo(intmx),inloss(intmx)
4335 C /LOZUO/
4336 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
4337 C REJECTED IN KKEVT
4338 C------------------
4339 *KEEP,DIQI.
4340  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
4341  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
4342  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
4343  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
4344 *KEEP,HKKEVT.
4345 c INCLUDE (HKKEVT)
4346  parameter(nmxhkk= 89998)
4347 c PARAMETER (NMXHKK=25000)
4348  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
4349  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
4350  +(4,nmxhkk)
4351 C
4352 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
4353 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
4354 C THE POSITIONS OF THE PROJECTILE NUCLEONS
4355 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
4356 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
4357 C COMPLETELY CONSISTENT. THE TIMES IN THE
4358 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
4359 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
4360 C
4361 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
4362 C
4363 C NMXHKK: maximum numbers of entries (partons/particles) that can be
4364 C stored in the commonblock.
4365 C
4366 C NHKK: the actual number of entries stored in current event. These are
4367 C found in the first NHKK positions of the respective arrays below.
4368 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
4369 C entry.
4370 C
4371 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
4372 C = 0 : null entry.
4373 C = 1 : an existing entry, which has not decayed or fragmented.
4374 C This is the main class of entries which represents the
4375 C "final state" given by the generator.
4376 C = 2 : an entry which has decayed or fragmented and therefore
4377 C is not appearing in the final state, but is retained for
4378 C event history information.
4379 C = 3 : a documentation line, defined separately from the event
4380 C history. (incoming reacting
4381 C particles, etc.)
4382 C = 4 - 10 : undefined, but reserved for future standards.
4383 C = 11 - 20 : at the disposal of each model builder for constructs
4384 C specific to his program, but equivalent to a null line in the
4385 C context of any other program. One example is the cone defining
4386 C vector of HERWIG, another cluster or event axes of the JETSET
4387 C analysis routines.
4388 C = 21 - : at the disposal of users, in particular for event tracking
4389 C in the detector.
4390 C
4391 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
4392 C standard.
4393 C
4394 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
4395 C The value is 0 for initial entries.
4396 C
4397 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
4398 C one mother exist, in which case the value 0 is used. In cluster
4399 C fragmentation models, the two mothers would correspond to the q
4400 C and qbar which join to form a cluster. In string fragmentation,
4401 C the two mothers of a particle produced in the fragmentation would
4402 C be the two endpoints of the string (with the range in between
4403 C implied).
4404 C
4405 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
4406 C entry has not decayed, this is 0.
4407 C
4408 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
4409 C entry has not decayed, this is 0. It is assumed that the daughters
4410 C of a particle (or cluster or string) are stored sequentially, so
4411 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
4412 C daughters. Even in cases where only one daughter is defined (e.g.
4413 C K0 -> K0S) both values should be defined, to make for a uniform
4414 C approach in terms of loop constructions.
4415 C
4416 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
4417 C
4418 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
4419 C
4420 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
4421 C
4422 C PHKK(4,IHKK) : energy, in GeV.
4423 C
4424 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
4425 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
4426 C
4427 C VHKK(1,IHKK) : production vertex x position, in mm.
4428 C
4429 C VHKK(2,IHKK) : production vertex y position, in mm.
4430 C
4431 C VHKK(3,IHKK) : production vertex z position, in mm.
4432 C
4433 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
4434 C********************************************************************
4435 *KEEP,ABRSV.
4436  COMMON /abrsv/ amcsv1(248),amcsv2(248),gacsv1(248),gacsv2(248),
4437  +bgxsv1(248),bgysv1(248),bgzsv1(248), bgxsv2(248),bgysv2(248),
4438  +bgzsv2(248), nchsv1(248),nchsv2(248),ijcsv1(248),ijcsv2(248),
4439  +pqsva1(248,4),pqsva2(248,4), pqsvb1(248,4),pqsvb2(248,4)
4440 *KEEP,DFINPA.
4441  CHARACTER*8 anf
4442  parameter(nfimax=249)
4443  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
4444  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
4445  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
4446  * istath(nfimax)
4447 *KEEP,DPRIN.
4448  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4449 *KEEP,PROJK.
4450  COMMON /projk/ iprojk
4451 *KEEP,NUCC.
4452  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
4453 *KEND.
4454 C modified DPMJET
4455  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
4456  * anndv,annvd,annds,annsd,
4457  * annhh,annzz,
4458  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
4459  * pthh,ptzz,
4460  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
4461  * eehh,eezz
4462  * ,anndi,ptdi,eedi
4463  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
4464  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
4465  * acouzz,acouhh,acouds,acousd,
4466  * acoudz,acouzd,acoudi,
4467  * acoudv,acouvd,acoucc
4468 C---------------------
4469  COMMON /zsea/zseaav,zseasu,anzsea
4470  COMMON /casadi/casaxx,icasad
4471 C---------------------
4472  dimension poj(4),pat(4)
4473  DATA ncalsv /0/
4474 C-----------------------------------------------------------------------
4475  ncalsv=ncalsv+1
4476  DO 50 i=1,nsv
4477 C-----------------------drop recombined chain pairs
4478  IF(nchsv1(i).EQ.99.AND.nchsv2(i).EQ.99) go to 50
4479  is1=intsv1(i)
4480  is2=intsv2(i)
4481 C
4482  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itvq(is2),
4483  + ittv1(is2),ittv2(is2), amcsv1(i),amcsv2(i),gacsv1(i),gacsv2(i),
4484  + bgxsv1(i),bgysv1(i),bgzsv1(i), bgxsv2(i),bgysv2(i),bgzsv2(i),
4485  + nchsv1(i),nchsv2(i),ijcsv1(i),ijcsv2(i), pqsva1(i,4),pqsva2
4486  + (i,4),pqsvb1(i,4),pqsvb2(i,4)
4487  1000 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
4488 C
4489 C++++++++++++++++++++++++++++++ CHAIN 1: QUARK-DIQUARK +++++++++++
4490  ifb1=ipsq(is1)
4491  ifb2=ittv1(is2)
4492  ifb3=ittv2(is2)
4493  DO 10 j=1,4
4494  poj(j)=pqsva1(i,j)
4495  pat(j)=pqsva2(i,j)
4496  10 CONTINUE
4497  pt1=sqrt(poj(1)**2+poj(2)**2)
4498  pt2=sqrt(pat(1)**2+pat(2)**2)
4499  CALL parpt(2,pt1,pt2,3,nevt)
4500 C IF((NCHSV1(I).NE.0.OR.NCHSV2(I).NE.0).AND.IP.NE.1)
4501 C & CALL SAPTRE(AMCSV1(I),GACSV1(I),BGXSV1(I),BGYSV1(I),BGZSV1(I),
4502 C & AMCSV2(I),GACSV2(I),BGXSV2(I),BGYSV2(I),BGZSV2(I))
4503 C----------------------------------------------------------------
4504  IF (ipco.GE.6)WRITE (6,1244) poj,pat
4505  1244 FORMAT (' S-V QUARK-DIQUARK POJ,PAT ',8e12.3)
4506 C------------------------------------------------------------------
4507 C------------------------------------------------------------------
4508 C------------------------------------------------------------------
4509 C check bookkeeping
4510 C-----------------------------------------------------------------
4511 C I= number of valence chain
4512 C Target Nr itt = IFROVT(INTSV2(I))
4513 C No of Glauber sea q at Target JITT=JTSHS(ITT)
4514  ittt = ifrovt(intsv2(i))
4515  jitt=jtshs(ittt)
4516 C IF(NCHSV1(I).EQ.0)THEN
4517 C WRITE(6,'(A,3I5)')'HADRSV: I,ITTT,JITT ',
4518 C * I,ITTT,JITT
4519 C ENDIF
4520 C------------------------------------------------------------------
4521 C check bookkeeping
4522 C-----------------------------------------------------------------
4523  IF(ipco.GE.1)THEN
4524  WRITE(6,*)' SV q-qq ,IFB1,IFB2,IFB3,',
4525  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITT',
4526  * ifb1,ifb2,ifb3,intsv1(i),intsv2(i),jippx,jitt
4527  ENDIF
4528 C-------------------------------------------------------------------
4529 C-------------------------------------------------------------------
4530  IF((nchsv1(i).NE.0))THEN
4531  CALL hadjet(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4532  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4533  + (i),3)
4534  ENDIF
4535  aack=float(ick4)/float(ick4+ihad4+1)
4536  IF((nchsv1(i).EQ.0))THEN
4537  zseawu=rndm(bb)*2.d0*zseaav
4538  rseack=float(jitt)*pdbse+ zseawu*pdbseu
4539  IF(ipco.GE.1)WRITE(6,*)'HADJSE JITT,RSEACK,PDBSE 3 dpmnuc3',
4540  + jitt,rseack,pdbse
4541  irejss=5
4542  IF(rndm(v).LE.rseack)THEN
4543  irejss=2
4544  IF(amcsv1(i).GT.2.3d0)THEN
4545  irejss=0
4546  CALL hadjse(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i),
4547  * bgysv1
4548  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,
4549  * nchsv1
4550  + (i),3,irejss,iissqq)
4551  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JITT,',
4552  * 'RSEACK,IREJSS 3 dpmnuc3 ',
4553  + jitt,rseack,irejss
4554  ENDIF
4555  IF(irejss.GE.1)THEN
4556  IF(irejss.EQ.1)irejse=irejse+1
4557  IF(irejss.EQ.3)irejs3=irejs3+1
4558  IF(irejss.EQ.2)irejs0=irejs0+1
4559  CALL hadjet(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4560  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4561  + (i),3)
4562  ihad4=ihad4+1
4563  ENDIF
4564  IF(irejss.EQ.0)THEN
4565  IF(iissqq.EQ.3)THEN
4566  ise43=ise43+1
4567  ELSE
4568  ise4=ise4+1
4569  ENDIF
4570  ENDIF
4571  ELSEIF((ijpock.EQ.1).AND.
4572  * (aack.LE.pdbck))THEN
4573  irej=0
4574  CALL hadjck(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4575  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4576  + (i),3,irej)
4577  IF(irej.EQ.1)THEN
4578  irejck=irejck+1
4579  CALL hadjet(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4580  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4581  + (i),3)
4582  ihad4=ihad4+1
4583  ENDIF
4584  IF(irej.EQ.0)ick4=ick4+1
4585  ELSE
4586  CALL hadjet(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4587  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4588  + (i),3)
4589  ihad4=ihad4+1
4590  ENDIF
4591  ENDIF
4592 C------------------------------------------------------------------
4593 C------------------------------------------------------------------
4594  acousv=acousv+1
4595 C*** REMOVED 31/07/90 HJM *** ADD HADRONS/RESONANCES INTO
4596 C COMMON /ALLPAR/ STARTING AT NAUX
4597  nhkkau=nhkk+1
4598  pixu=0.
4599  piyu=0.
4600  pizu=0.
4601  pieu=0.
4602  DO 20 j=1,nhad
4603 C NHKK=NHKK+1
4604  IF (nhkk.EQ.nmxhkk) THEN
4605  WRITE (6,'(A,2I5/A)') .EQ.' HADRSV: NHKKNMXHKK ',nhkk,nmxhkk
4606  RETURN
4607  ENDIF
4608 C
4609  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4610  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
4611  WRITE(6,'(2A/3I5,3E15.6)')
4612  & ' HADRSV / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
4613  * ' NCALSV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4614  * ncalsv, nhkk,nref(j), hef(j),ehecc, amf(j)
4615  hef(j)=ehecc
4616  ENDIF
4617  annsv=annsv+1
4618  eesv=eesv+hef(j)
4619  ptsv=ptsv+sqrt(pxf(j)**2+pyf(j)**2)
4620 C PUT NN-CMS HADRONS INTO /HKKEVT/
4621  istist=1
4622  IF(ibarf(j).EQ.500)istist=2
4623  CALL hkkfil(istist,mpdgha(nref(j)),mhkksv(i)-3,0,
4624  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),3)
4625 C WRITE(6,*)' HKKFIL: NHKKAU,IORMO(J) ',ISTIST, NHKKAU,IORMO(J)
4626  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
4627  + (nhkk)
4628  pixu=pixu+pxf(j)
4629  piyu=piyu+pyf(j)
4630  pizu=pizu+pzf(j)
4631  pieu=pieu+hef(j)
4632  IF(irejss.LT.0)THEN
4633  WRITE(6,*)' HADRSV / CHAIN 1'
4634  IF (iphkk.GE.0) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
4635  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4636  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4637  ENDIF
4638  20 CONTINUE
4639  IF(ipco.GE.6)WRITE(6,1644)pixu,piyu,pizu,pieu
4640  1644 FORMAT(' HADRSV,ch1 PIXU,PIYU,PIZU,PIEU ',4f12.5)
4641 C IF(NHAD.GT.0) THEN
4642 C JDAHKK(1,IMOHKK)=NHKKAU
4643 C JDAHKK(2,IMOHKK)=NHKK
4644 C ENDIF
4645 C+++++++++++++++++++++++++++++ CHAIN 2: AQUARK-QUARK ++++++++++++++
4646  ifb1=ipsaq(is1)
4647  ifb2=itvq(is2)
4648  ifb1=iabs(ifb1)+6
4649  DO 30 j=1,4
4650  poj(j)=pqsvb2(i,j)
4651  pat(j)=pqsvb1(i,j)
4652  30 CONTINUE
4653  pt1=sqrt(poj(1)**2+poj(2)**2)
4654  pt2=sqrt(pat(1)**2+pat(2)**2)
4655  CALL parpt(2,pt1,pt2,3,nevt)
4656 C
4657  IF(ipco.GE.1)THEN
4658  WRITE(6,*)' SV aq-q ,IFB1,IFB2,',
4659  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITTX',
4660  * ifb1,ifb2,intsv1(i),intsv2(i),jippx,jittx
4661  ENDIF
4662 C-------------------------------------------------------------------
4663 C-------------------------------------------------------------------
4664  IF (ipco.GE.6)WRITE (6,1244) poj,pat
4665  CALL hadjet(nhad,amcsv2(i),poj,pat,gacsv2(i),bgxsv2(i), bgysv2
4666  + (i),bgzsv2(i),ifb1,ifb2,ifb3,ifb4, ijcsv2(i),ijcsv2(i),3,nchsv2
4667  + (i),4)
4668 C ADD HADRONS/RESONANCES INTO
4669 C COMMON /ALLPAR/ STARTING AT NAUX
4670  nhkkau=nhkk+1
4671  pixu=0.
4672  piyu=0.
4673  pizu=0.
4674  pieu=0.
4675  DO 40 j=1,nhad
4676  IF (nhkk.EQ.nmxhkk) THEN
4677  WRITE (6,'(A,2I5/A)') .EQ.' HADRSV: NHKKNMXHKK ', nhkk,
4678  + nmxhkk
4679  RETURN
4680  ENDIF
4681 C NHKK=NHKK+1
4682 C
4683  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4684  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
4685  WRITE(6,'(2A/3I5,3E15.6)')
4686  & ' HADRSV / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
4687  * ' NCALSV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4688  * ncalsv, nhkk,nref(j), hef(j),ehecc, amf(j)
4689  hef(j)=ehecc
4690  ENDIF
4691  annsv=annsv+1
4692  eesv=eesv+hef(j)
4693  ptsv=ptsv+sqrt(pxf(j)**2+pyf(j)**2)
4694 C PUT NN-CMS HADRONS INTO /HKKEVT/
4695  istist=1
4696  IF(ibarf(j).EQ.500)istist=2
4697  CALL hkkfil(istist,mpdgha(nref(j)),mhkksv(i),0,
4698  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),4)
4699  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
4700  + (nhkk)
4701  pixu=pixu+pxf(j)
4702  piyu=piyu+pyf(j)
4703  pizu=pizu+pzf(j)
4704  pieu=pieu+hef(j)
4705  IF (iphkk.GE.7) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
4706  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4707  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4708 
4709  40 CONTINUE
4710  IF(ipco.GE.6)WRITE(6,1644)pixu,piyu,pizu,pieu
4711 C IF(NHAD.GT.0) THEN
4712 C JDAHKK(1,IMOHKK)=NHKKAU
4713 C JDAHKK(2,IMOHKK)=NHKK
4714 C ENDIF
4715  50 CONTINUE
4716 C----------------------------------------------------------------
4717 C
4718  RETURN
4719  1010 FORMAT (i6,i4,5i6,9e10.2)
4720  1020 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
4721  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
4722  END
4723 *-- Author :
4724 C
4725 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4726 C
4727  SUBROUTINE hadrss
4728  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4729  SAVE
4730 *KEEP,INTMX.
4731  parameter(intmx=2488,intmd=252)
4732 *KEEP,DXQX.
4733 C INCLUDE (XQXQ)
4734 * NOTE: INTMX set via INCLUDE(INTMX)
4735  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
4736  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
4737  * ,xpsu(248),xtsu(248)
4738  * ,xpsut(248),xtsut(248)
4739 *KEEP,INTNEW.
4740  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
4741  +ixpv,ixps,ixtv,ixts, intvv1(248),
4742  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
4743  +intss1(intmx),intss2(intmx),
4744  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
4745  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
4746 
4747 C /INTNEW/
4748 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
4749 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
4750 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
4751 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
4752 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
4753 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
4754 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
4755 C FROM PROJECTILE/TARGET NUCLEI
4756 C-------------------
4757 *KEEP,IFROTO.
4758  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
4759  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
4760  +jhkknt
4761  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
4762  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
4763  & mhkkhh(intmx),
4764  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
4765 *KEEP,LOZUO.
4766  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
4767  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
4768  +intlo(intmx),inloss(intmx)
4769 C /LOZUO/
4770 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
4771 C REJECTED IN KKEVT
4772 C------------------
4773 *KEEP,DIQI.
4774  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
4775  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
4776  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
4777  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
4778 *KEEP,HKKEVT.
4779 c INCLUDE (HKKEVT)
4780  parameter(nmxhkk= 89998)
4781 c PARAMETER (NMXHKK=25000)
4782  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
4783  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
4784  +(4,nmxhkk)
4785 C
4786 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
4787 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
4788 C THE POSITIONS OF THE PROJECTILE NUCLEONS
4789 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
4790 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
4791 C COMPLETELY CONSISTENT. THE TIMES IN THE
4792 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
4793 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
4794 C
4795 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
4796 C
4797 C NMXHKK: maximum numbers of entries (partons/particles) that can be
4798 C stored in the commonblock.
4799 C
4800 C NHKK: the actual number of entries stored in current event. These are
4801 C found in the first NHKK positions of the respective arrays below.
4802 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
4803 C entry.
4804 C
4805 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
4806 C = 0 : null entry.
4807 C = 1 : an existing entry, which has not decayed or fragmented.
4808 C This is the main class of entries which represents the
4809 C "final state" given by the generator.
4810 C = 2 : an entry which has decayed or fragmented and therefore
4811 C is not appearing in the final state, but is retained for
4812 C event history information.
4813 C = 3 : a documentation line, defined separately from the event
4814 C history. (incoming reacting
4815 C particles, etc.)
4816 C = 4 - 10 : undefined, but reserved for future standards.
4817 C = 11 - 20 : at the disposal of each model builder for constructs
4818 C specific to his program, but equivalent to a null line in the
4819 C context of any other program. One example is the cone defining
4820 C vector of HERWIG, another cluster or event axes of the JETSET
4821 C analysis routines.
4822 C = 21 - : at the disposal of users, in particular for event tracking
4823 C in the detector.
4824 C
4825 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
4826 C standard.
4827 C
4828 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
4829 C The value is 0 for initial entries.
4830 C
4831 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
4832 C one mother exist, in which case the value 0 is used. In cluster
4833 C fragmentation models, the two mothers would correspond to the q
4834 C and qbar which join to form a cluster. In string fragmentation,
4835 C the two mothers of a particle produced in the fragmentation would
4836 C be the two endpoints of the string (with the range in between
4837 C implied).
4838 C
4839 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
4840 C entry has not decayed, this is 0.
4841 C
4842 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
4843 C entry has not decayed, this is 0. It is assumed that the daughters
4844 C of a particle (or cluster or string) are stored sequentially, so
4845 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
4846 C daughters. Even in cases where only one daughter is defined (e.g.
4847 C K0 -> K0S) both values should be defined, to make for a uniform
4848 C approach in terms of loop constructions.
4849 C
4850 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
4851 C
4852 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
4853 C
4854 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
4855 C
4856 C PHKK(4,IHKK) : energy, in GeV.
4857 C
4858 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
4859 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
4860 C
4861 C VHKK(1,IHKK) : production vertex x position, in mm.
4862 C
4863 C VHKK(2,IHKK) : production vertex y position, in mm.
4864 C
4865 C VHKK(3,IHKK) : production vertex z position, in mm.
4866 C
4867 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
4868 C********************************************************************
4869 *KEEP,ABRSS.
4870 C INCLUDE (ABRSS)
4871  COMMON /abrss/ amcss1(intmx),amcss2(intmx), gacss1(intmx),gacss2
4872  +(intmx), bgxss1(intmx),bgyss1(intmx),bgzss1(intmx), bgxss2(intmx),
4873  +bgyss2(intmx),bgzss2(intmx), nchss1(intmx),nchss2(intmx), ijcss1
4874  +(intmx),ijcss2(intmx), pqssa1(intmx,4),pqssa2(intmx,4), pqssb1
4875  +(intmx,4),pqssb2(intmx,4)
4876 *KEEP,NUCC.
4877  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
4878 *KEEP,DFINPA.
4879  CHARACTER*8 anf
4880  parameter(nfimax=249)
4881  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
4882  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
4883  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
4884  * istath(nfimax)
4885 *KEEP,DPRIN.
4886  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4887 *KEEP,PROJK.
4888  COMMON /projk/ iprojk
4889 *KEND.
4890  dimension poj(4),pat(4)
4891 C modified DPMJET
4892  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
4893  * anndv,annvd,annds,annsd,
4894  * annhh,annzz,
4895  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
4896  * pthh,ptzz,
4897  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
4898  * eehh,eezz
4899  * ,anndi,ptdi,eedi
4900  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
4901  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
4902  * acouzz,acouhh,acouds,acousd,
4903  * acoudz,acouzd,acoudi,
4904  * acoudv,acouvd,acoucc
4905 C---------------------
4906  COMMON /pshow/ ipshow
4907 C COMMON /HARLUN/ IHARLU,QLUN
4908  COMMON /harlun/ qlun,iharlu
4909  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
4910  COMMON /jspa/pxs(40000),pys(40000),pzs(40000),hes(40000),nnnps
4911  COMMON /nomije/ ptmije(10),nnmije(10)
4912  COMMON /casadi/casaxx,icasad
4913 C-----------------------------------------------------------------------
4914  DO 60 i=1,nss
4915 C-----------------------drop recombined chain pairs
4916  IF(nchss1(i).EQ.99.AND.nchss2(i).EQ.99) go to 60
4917  IF (inloss(i)) THEN
4918  is1=intss1(i)
4919  is2=intss2(i)
4920 C
4921  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itsq(is2),
4922  + itsaq(is2), amcss1(i),amcss2(i),gacss1(i),gacss2(i), bgxss1
4923  + (i),bgyss1(i),bgzss1(i), bgxss2(i),bgyss2(i),bgzss2(i), nchss1
4924  + (i),nchss2(i),ijcss1(i),ijcss2(i), pqssa1(i,4),pqssa2(i,4),
4925  + pqssb1(i,4),pqssb2(i,4)
4926  1000 FORMAT(10x,4i5,10f9.2/10x,4i5,4f12.4)
4927 C
4928 C+++++++++++++++++++++++++++++ CHAIN 1: QUARK-AQUARK ++++++++++
4929  ifb1=ipsq(is1)
4930  ifb2=itsaq(is2)
4931  ifb2=iabs(ifb2)+6
4932  DO 10 j=1,4
4933  poj(j)=pqssa1(i,j)
4934  pat(j)=pqssa2(i,j)
4935  10 CONTINUE
4936  pt1=sqrt(poj(1)**2+poj(2)**2)
4937  pt2=sqrt(pat(1)**2+pat(2)**2)
4938  CALL parpt(2,pt1,pt2,4,nevt)
4939 C--------------------------------------------------------------
4940  iharlu=0
4941  qlun=0.
4942  IF(ipshow.EQ.1)THEN
4943  pojpt=sqrt(poj(2)**2+poj(1)**2)
4944  patpt=sqrt(pat(1)**2+pat(2)**2)
4945  DO iiii=1,10
4946  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
4947  * nnmije(iiii)+1
4948  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
4949  * nnmije(iiii)+1
4950  ENDDO
4951  qlun=min(pojpt,patpt)
4952  IF((qlun.LT.2.5d0).OR.(amcss1(i).LT.5.d0))THEN
4953  qlun=0.
4954  iharlu=0
4955  ELSE
4956  iharlu=1
4957  ENDIF
4958  ENDIF
4959  IF(ipco.GE.1)THEN
4960  WRITE(6,*)' SS q-aq ,IFB1,IFB2,',
4961  * 'INTSS1=IS1,INTSS2=IS2',
4962  * ifb1,ifb2,intss1(i),intss2(i)
4963  WRITE (6,*)' projectile sea quark IFB1=',ifb1,
4964  * ' from IS1=',intss1(i)
4965  WRITE(6,*)' with IPSQ(IS1),XPSQ(IS1),IFROSP(IS1)',
4966  * ipsq(is1),xpsq(is1),ifrosp(is1)
4967  ENDIF
4968  DO 798 ii=1,ixpv
4969  IF(ifrosp(is1).EQ.ifrovp(ii))iii=ii
4970  798 CONTINUE
4971  IF(ipco.GE.1)THEN
4972  WRITE (6,*)' projectile III=',iii
4973  WRITE(6,*)' corresp. XPVQ(i),XPVD(i),IPVQ(I),IPPV1(I),IPPV2(I)',
4974  * xpvq(iii),xpvd(iii),ipvq(iii),ippv1(iii),ippv2(iii)
4975  ENDIF
4976 C-------------------------------------------------------------------
4977 C Casado diquark option
4978 C+++++++++++++++++++++++++++ SS CHAIN 1: QUARK-AQUARK ++++++++++
4979 C-------------------------------------------------------------------
4980  IF(icasad.EQ.1)THEN
4981  IF(rndm(vv).LE.casaxx)THEN
4982  IF(rndm(vvv).LE.0.5d0)THEN
4983  iscasa=ipsq(is1)
4984  ipvcas=ippv1(iii)
4985  ipsq(is1)=ipvcas
4986  ippv1(iii)=iscasa
4987  ifb1=ipsq(is1)
4988  IF(ipco.GE.1)THEN
4989  WRITE(6,*)' Cas SS1 q-aq 1 ,IFB1,IFB2,',
4990  * 'INTSS1=IS1,INTSS2=IS2,III',
4991  * ifb1,ifb2,intss1(i),intss2(i),iii
4992  * ,'-----------------------------------------------------'
4993  ENDIF
4994  ELSE
4995  iscasa=ipsq(is1)
4996  ipvcas=ippv2(iii)
4997  ipsq(is1)=ipvcas
4998  ippv2(iii)=iscasa
4999  ifb1=ipsq(is1)
5000  IF(ipco.GE.1)THEN
5001  WRITE(6,*)' Cas SS1 q-aq 2 ,IFB1,IFB2,',
5002  * 'INTSS1=IS1,INTSS2=IS2,III',
5003  * ifb1,ifb2,intss1(i),intss2(i),iii
5004  * ,'-----------------------------------------------------'
5005  ENDIF
5006  ENDIF
5007  ENDIF
5008  ENDIF
5009 C-------------------------------------------------------------------
5010 C Casado diquark option
5011 C-------------------------------------------------------------------
5012  CALL hadjet(nhad,amcss1(i),poj,pat,gacss1(i),bgxss1(i), bgyss1
5013  + (i),bgzss1(i),ifb1,ifb2,ifb3,ifb4, ijcss1(i),ijcss1(i),3,
5014  + nchss1(i),1)
5015  acouss=acouss+1
5016  iharlu=0
5017  qlun=0.
5018 C ADD HADRONS/RESONANCES INTO
5019 C COMMON /ALLPAR/ STARTING AT NAUX
5020  nhkkau=nhkk+1
5021  DO 20 j=1,nhad
5022  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5023  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
5024  WRITE(6,'(A,2I5,2E16.6)')
5025  + ' HADRSS: CORRECT INCONSISTENT PARTICLE ENERGY ', nhkk,
5026  + nref(j), hef(j),ehecc
5027  hef(j)=ehecc
5028  ENDIF
5029  annss=annss+1
5030  eess=eess+hef(j)
5031  ptss=ptss+sqrt(pxf(j)**2+pyf(j)**2)
5032 C PUT NN-CMS HADRONS INTO /HKKEVT/
5033 C NHKK=NHKK+1
5034  IF (nhkk.EQ.nmxhkk) THEN
5035  WRITE (6,'(A,2I5)') ' HADRSS: NHKK.EQ NMXHKK',nhkk,nmxhkk
5036  RETURN
5037  ENDIF
5038  istist=1
5039  IF(ibarf(j).EQ.500)istist=2
5040  CALL hkkfil(istist,mpdgha(nref(j)),mhkkss(i)-3,0,
5041  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),5)
5042  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030) nhkk,nref(j), idhkk
5043  + (nhkk)
5044 C WRITE(6,*)' First chain HADRSS'
5045  IF (iphkk.GE.7) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk
5046  + (nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk
5047  + (2,nhkk),(phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk
5048  + =1,4)
5049  20 CONTINUE
5050  30 CONTINUE
5051 C IF(NHAD.GT.0) THEN
5052 C JDAHKK(1,IMOHKK)=NHKKAU
5053 C JDAHKK(2,IMOHKK)=NHKK
5054 C ENDIF
5055  IF(nnnpj.GE.1)THEN
5056  nnnpso=nnnps
5057  nnnps=nnnps+1
5058  nnnpsu=nnnpso+nnnpj
5059  DO 137 j=nnnps,nnnpsu
5060  jj=j-nnnps+1
5061  IF(j.GT.40000.OR.jj.GT.1000)THEN
5062 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
5063  go to 137
5064  ENDIF
5065  pxs(j)=pxj(jj)
5066  pys(j)=pyj(jj)
5067  pzs(j)=pzj(jj)
5068  hes(j)=hej(jj)
5069  137 CONTINUE
5070  nnnps=nnnps+nnnpj-1
5071  ENDIF
5072 C
5073 C++++++++++++++++++++++++++++++++ CHAIN 2: AQUARK-QUARK +++++++++
5074  ifb1=ipsaq(is1)
5075  ifb2=itsq(is2)
5076  ifb1=iabs(ifb1)+6
5077  DO 40 j=1,4
5078  poj(j)=pqssb2(i,j)
5079  pat(j)=pqssb1(i,j)
5080  40 CONTINUE
5081  pt1=sqrt(poj(1)**2+poj(2)**2)
5082  pt2=sqrt(pat(1)**2+pat(2)**2)
5083  CALL parpt(2,pt1,pt2,4,nevt)
5084  iharlu=0
5085  qlun=0.
5086  IF(ipshow.EQ.1)THEN
5087  pojpt=sqrt(poj(2)**2+poj(1)**2)
5088  patpt=sqrt(pat(1)**2+pat(2)**2)
5089  DO iiii=1,10
5090  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
5091  * nnmije(iiii)+1
5092  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
5093  * nnmije(iiii)+1
5094  ENDDO
5095  qlun=min(pojpt,patpt)
5096  IF((qlun.LT.2.5d0).OR.(amcss2(i).LT.5.d0))THEN
5097  qlun=0.
5098  iharlu=0
5099  ELSE
5100  iharlu=1
5101  ENDIF
5102  ENDIF
5103 C,,
5104  IF(ipco.GE.1)THEN
5105  WRITE(6,*)' SS aq-q ,IFB1,IFB2,',
5106  * 'INTSS1=IS1,INTSS2=IS2',
5107  * ifb1,ifb2,intss1(i),intss2(i)
5108  WRITE (6,*)' target sea quark IFB2=',ifb2,
5109  * ' from IS2=',intss2(i)
5110  WRITE(6,*)' with ITSQ(IS2),XTSQ(IS2),IFROST(IS2)',
5111  * itsq(is2),xtsq(is2),ifrost(is2)
5112  ENDIF
5113  DO 797 ii=1,ixtv
5114  IF(ifrost(is2).EQ.ifrovt(ii))iii=ii
5115  797 CONTINUE
5116  IF(ipco.GE.1)THEN
5117  WRITE (6,*)' projectile III=',iii
5118  WRITE(6,*)' corresp. XTVQ(i),XTVD(i),ITVQ(I),ITTV1(I),ITTV2(I)',
5119  * xtvq(iii),xtvd(iii),itvq(iii),ittv1(iii),ittv2(iii)
5120  ENDIF
5121 C-------------------------------------------------------------------
5122 C Casado diquark option
5123 C+++++++++++++++++++++++++++++ SS CHAIN 2: AQUARK-QUARK +++++++++
5124 C-------------------------------------------------------------------
5125  IF(icasad.EQ.1)THEN
5126  IF(rndm(vv).LE.casaxx)THEN
5127  IF(rndm(vvv).LE.0.5d0)THEN
5128  iscasa=itsq(is2)
5129  itvcas=ittv1(iii)
5130  itsq(is2)=itvcas
5131  ittv1(iii)=iscasa
5132  ifb2=itsq(is2)
5133  IF(ipco.GE.1)THEN
5134  WRITE(6,*)' Cas SS2 aq-q 1 ,IFB1,IFB2,',
5135  * 'INTSS1=IS1,INTSS2=IS2,III',
5136  * ifb1,ifb2,intss1(i),intss2(i),iii
5137  * ,'-----------------------------------------------------'
5138  ENDIF
5139  ELSE
5140  iscasa=itsq(is2)
5141  itvcas=ittv2(iii)
5142  itsq(is2)=itvcas
5143  ittv2(iii)=iscasa
5144  ifb2=itsq(is2)
5145  IF(ipco.GE.1)THEN
5146  WRITE(6,*)' Cas SS2 aq-q 2 ,IFB1,IFB2,',
5147  * 'INTSS1=IS1,INTSS2=IS2,III',
5148  * ifb1,ifb2,intss1(i),intss2(i),iii
5149  * ,'-----------------------------------------------------'
5150  ENDIF
5151  ENDIF
5152  ENDIF
5153  ENDIF
5154 C-------------------------------------------------------------------
5155 C Casado diquark option
5156 C-------------------------------------------------------------------
5157  CALL hadjet(nhad,amcss2(i),poj,pat,gacss2(i),bgxss2(i), bgyss2
5158  + (i),bgzss2(i),ifb1,ifb2,ifb3,ifb4, ijcss2(i),ijcss2(i),3,
5159  + nchss2(i),2)
5160  iharlu=0
5161  qlun=0.
5162 C ADD HADRONS/RESONANCES INTO
5163 C COMMON /ALLPAR/ STARTING AT NAUX
5164  nhkkau=nhkk+1
5165  DO 50 j=1,nhad
5166  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5167  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
5168  WRITE(6,'(A,2I5,2E16.6)')
5169  + ' HADRSS: CORRECT INCONSISTENT PARTICLE ENERGY ', nhkk,
5170  + nref(j), hef(j),ehecc
5171  hef(j)=ehecc
5172  ENDIF
5173  annss=annss+1
5174  eess=eess+hef(j)
5175  ptss=ptss+sqrt(pxf(j)**2+pyf(j)**2)
5176 C PUT NN-CMS HADRONS INTO /HKKEVT/
5177 C NHKK=NHKK+1
5178  IF (nhkk.EQ.nmxhkk) THEN
5179  WRITE (6,'(A,2I5)') ' HADRSS: NHKK.EQ NMXHKK',nhkk,nmxhkk
5180  RETURN
5181  ENDIF
5182  istist=1
5183  IF(ibarf(j).EQ.500)istist=2
5184  CALL hkkfil(istist,mpdgha(nref(j)),mhkkss(i),0,
5185  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),6)
5186  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030) nhkk,nref(j), idhkk
5187  + (nhkk)
5188 C WRITE(6,*)' Second chain HADRSS'
5189  IF (iphkk.GE.7) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk
5190  + (nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk
5191  + (2,nhkk),(phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk
5192  + =1,4)
5193  50 CONTINUE
5194 C IF(NHAD.GT.0) THEN
5195 C JDAHKK(1,IMOHKK)=NHKKAU
5196 C JDAHKK(2,IMOHKK)=NHKK
5197 C ENDIF
5198  IF(nnnpj.GE.1)THEN
5199  nnnpso=nnnps
5200  nnnps=nnnps+1
5201  nnnpsu=nnnpso+nnnpj
5202  DO 187 j=nnnps,nnnpsu
5203  jj=j-nnnps+1
5204  IF(j.GT.40000.OR.jj.GT.1000)THEN
5205 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
5206  go to 187
5207  ENDIF
5208  pxs(j)=pxj(jj)
5209  pys(j)=pyj(jj)
5210  pzs(j)=pzj(jj)
5211  hes(j)=hej(jj)
5212  187 CONTINUE
5213  nnnps=nnnps+nnnpj-1
5214  ENDIF
5215  ENDIF
5216  60 CONTINUE
5217 C
5218 C--------------------------------------------------------------
5219 C
5220  RETURN
5221  1010 FORMAT (i6,i4,5i6,9e10.2)
5222  1020 FORMAT (.GT.' HADRVS JNAUMAX SKIP NEXT PARTICLES ',3i10)
5223  1030 FORMAT (' NHKK,NREF(J),IDHKK(NHKK) ',3i10)
5224  1040 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
5225  END
5226 *-- Author :
5227 C
5228 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5229 C
5230  SUBROUTINE hadrvs
5231  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5232  SAVE
5233 C
5234 C-------------------------
5235 C
5236 C HADRONIZE VALENCE-SEA CHAINS
5237 C
5238 C ADD GENERATED HADRONS TO /ALLPAR/
5239 C STARTING AT (NAUX + 1)
5240 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
5241 C
5242 C-------------------------
5243 *KEEP,INTMX.
5244  parameter(intmx=2488,intmd=252)
5245 *KEEP,DXQX.
5246 C INCLUDE (XQXQ)
5247 * NOTE: INTMX set via INCLUDE(INTMX)
5248  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
5249  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
5250  * ,xpsu(248),xtsu(248)
5251  * ,xpsut(248),xtsut(248)
5252  common/popcck/pdbck,pdbse,pdbseu,
5253  * ijpock,irejck,ick4,ihad4,ick6,ihad6
5254  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
5255  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
5256  *isea43,isea63,irejao
5257 *KEEP,INTNEW.
5258  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
5259  +ixpv,ixps,ixtv,ixts, intvv1(248),
5260  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
5261  +intss1(intmx),intss2(intmx),
5262  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
5263  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
5264 
5265 C /INTNEW/
5266 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
5267 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
5268 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
5269 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
5270 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
5271 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
5272 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
5273 C FROM PROJECTILE/TARGET NUCLEI
5274 C-------------------
5275 *KEEP,IFROTO.
5276  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
5277  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
5278  +jhkknt
5279  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
5280  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
5281  & mhkkhh(intmx),
5282  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
5283 *KEEP,LOZUO.
5284  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
5285  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
5286  +intlo(intmx),inloss(intmx)
5287 C /LOZUO/
5288 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
5289 C REJECTED IN KKEVT
5290 C------------------
5291 *KEEP,DIQI.
5292  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
5293  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
5294  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
5295  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
5296 *KEEP,HKKEVT.
5297 c INCLUDE (HKKEVT)
5298  parameter(nmxhkk= 89998)
5299 c PARAMETER (NMXHKK=25000)
5300  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
5301  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
5302  +(4,nmxhkk)
5303 C
5304 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
5305 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
5306 C THE POSITIONS OF THE PROJECTILE NUCLEONS
5307 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
5308 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
5309 C COMPLETELY CONSISTENT. THE TIMES IN THE
5310 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
5311 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
5312 C
5313 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
5314 C
5315 C NMXHKK: maximum numbers of entries (partons/particles) that can be
5316 C stored in the commonblock.
5317 C
5318 C NHKK: the actual number of entries stored in current event. These are
5319 C found in the first NHKK positions of the respective arrays below.
5320 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
5321 C entry.
5322 C
5323 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
5324 C = 0 : null entry.
5325 C = 1 : an existing entry, which has not decayed or fragmented.
5326 C This is the main class of entries which represents the
5327 C "final state" given by the generator.
5328 C = 2 : an entry which has decayed or fragmented and therefore
5329 C is not appearing in the final state, but is retained for
5330 C event history information.
5331 C = 3 : a documentation line, defined separately from the event
5332 C history. (incoming reacting
5333 C particles, etc.)
5334 C = 4 - 10 : undefined, but reserved for future standards.
5335 C = 11 - 20 : at the disposal of each model builder for constructs
5336 C specific to his program, but equivalent to a null line in the
5337 C context of any other program. One example is the cone defining
5338 C vector of HERWIG, another cluster or event axes of the JETSET
5339 C analysis routines.
5340 C = 21 - : at the disposal of users, in particular for event tracking
5341 C in the detector.
5342 C
5343 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
5344 C standard.
5345 C
5346 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
5347 C The value is 0 for initial entries.
5348 C
5349 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
5350 C one mother exist, in which case the value 0 is used. In cluster
5351 C fragmentation models, the two mothers would correspond to the q
5352 C and qbar which join to form a cluster. In string fragmentation,
5353 C the two mothers of a particle produced in the fragmentation would
5354 C be the two endpoints of the string (with the range in between
5355 C implied).
5356 C
5357 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
5358 C entry has not decayed, this is 0.
5359 C
5360 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
5361 C entry has not decayed, this is 0. It is assumed that the daughters
5362 C of a particle (or cluster or string) are stored sequentially, so
5363 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
5364 C daughters. Even in cases where only one daughter is defined (e.g.
5365 C K0 -> K0S) both values should be defined, to make for a uniform
5366 C approach in terms of loop constructions.
5367 C
5368 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
5369 C
5370 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
5371 C
5372 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
5373 C
5374 C PHKK(4,IHKK) : energy, in GeV.
5375 C
5376 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
5377 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
5378 C
5379 C VHKK(1,IHKK) : production vertex x position, in mm.
5380 C
5381 C VHKK(2,IHKK) : production vertex y position, in mm.
5382 C
5383 C VHKK(3,IHKK) : production vertex z position, in mm.
5384 C
5385 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
5386 C********************************************************************
5387 *KEEP,ABRVS.
5388  COMMON /abrvs/ amcvs1(248),amcvs2(248),gacvs1(248),gacvs2(248),
5389  +bgxvs1(248),bgyvs1(248),bgzvs1(248), bgxvs2(248),bgyvs2(248),
5390  +bgzvs2(248), nchvs1(248),nchvs2(248),ijcvs1(248),ijcvs2(248),
5391  +pqvsa1(248,4),pqvsa2(248,4), pqvsb1(248,4),pqvsb2(248,4)
5392 *KEEP,DFINPA.
5393  CHARACTER*8 anf
5394  parameter(nfimax=249)
5395  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
5396  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
5397  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
5398  * istath(nfimax)
5399 *KEEP,DPRIN.
5400  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5401 *KEEP,PROJK.
5402  COMMON /projk/ iprojk
5403 *KEEP,NUCC.
5404  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
5405 *KEND.
5406 C modified DPMJET
5407  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
5408  * anndv,annvd,annds,annsd,
5409  * annhh,annzz,
5410  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
5411  * pthh,ptzz,
5412  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
5413  * eehh,eezz
5414  * ,anndi,ptdi,eedi
5415  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
5416  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
5417  * acouzz,acouhh,acouds,acousd,
5418  * acoudz,acouzd,acoudi,
5419  * acoudv,acouvd,acoucc
5420 C---------------------
5421  COMMON /zsea/zseaav,zseasu,anzsea
5422  COMMON /casadi/casaxx,icasad
5423 C---------------------
5424  dimension poj(4),pat(4)
5425 C-----------------------------------------------------------------------
5426  DO 50 i=1,nvs
5427 C-----------------------drop recombined chain pairs
5428  IF(nchvs1(i).EQ.99.AND.nchvs2(i).EQ.99) go to 50
5429  is1=intvs1(i)
5430  is2=intvs2(i)
5431 C
5432  IF (ipco.GE.6) WRITE (6,1010) ipvq(is1),ippv1(is1),ippv2(is1),
5433  + itsq(is2),itsaq(is2), amcvs1(i),amcvs2(i),gacvs1(i),gacvs2(i),
5434  + bgxvs1(i),bgyvs1(i),bgzvs1(i), bgxvs2(i),bgyvs2(i),bgzvs2(i),
5435  + nchvs1(i),nchvs2(i),ijcvs1(i),ijcvs2(i), pqvsa1(i,4),pqvsa2
5436  + (i,4),pqvsb1(i,4),pqvsb2(i,4)
5437 C
5438 C+++++++++++++++++++++++++++++ CHAIN 1: QUARK-AQUARK ++++++++++
5439  ifb1=ipvq(is1)
5440  ifb2=itsaq(is2)
5441  ifb2=iabs(ifb2)+6
5442  DO 10 j=1,4
5443  poj(j)=pqvsa1(i,j)
5444  pat(j)=pqvsa2(i,j)
5445  10 CONTINUE
5446  pt1=sqrt(poj(1)**2+poj(2)**2)
5447  pt2=sqrt(pat(1)**2+pat(2)**2)
5448  CALL parpt(2,pt1,pt2,2,nevt)
5449 C IF((NCHVS1(I).NE.0.OR.NCHVS2(I).NE.0).AND.IP.NE.1)
5450 C & CALL SAPTRE(AMCVS2(I),GACVS2(I),BGXVS2(I),BGYVS2(I),BGZVS2(I),
5451 C & AMCVS1(I),GACVS1(I),BGXVS1(I),BGYVS1(I),BGZVS1(I))
5452 C-----------------------------------------------------------------
5453 C POJ,PAT EXCHANGED J.R.15.2.90
5454 C RECHANGED HJM 13/2/91
5455  IF(ipco.GE.1)THEN
5456  WRITE(6,*)' VS q-aq ,IFB1,IFB2,',
5457  * 'INTVS1=IS1,INTVS2=IS2,JIPPX,JITTX',
5458  * ifb1,ifb2,intvs1(i),intvs2(i),jippx,jittx
5459  ENDIF
5460  CALL hadjet(nhad,amcvs1(i),poj,pat,gacvs1(i),bgxvs1(i), bgyvs1
5461  + (i),bgzvs1(i),ifb1,ifb2,ifb3,ifb4, ijcvs1(i),ijcvs1(i),3,nchvs1
5462  + (i),5)
5463  acouvs=acouvs+1
5464 C ADD HADRONS/RESONANCES INTO
5465 C COMMON /ALLPAR/ STARTING AT NAUX
5466  nhkkau=nhkk+1
5467  DO 20 j=1,nhad
5468  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5469  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500)THEN
5470  WRITE(6,'(A,2I5,2E16.6)')
5471  + ' HADRVS: CORRECT INCONSISTENT PARTICLE ENERGY ', nhkk,nref
5472  + (j), hef(j),ehecc
5473  hef(j)=ehecc
5474  ENDIF
5475  annvs=annvs+1
5476  eevs=eevs+hef(j)
5477  ptvs=ptvs+sqrt(pxf(j)**2+pyf(j)**2)
5478 C PUT NN-CMS HADRONS INTO /HKKEVT/
5479 C NHKK=NHKK+1
5480  IF (nhkk.EQ.nmxhkk) THEN
5481  WRITE (6,'(A,2I5)') .EQ.' HADRVS: NHKKNMXHKK',nhkk,nmxhkk
5482  RETURN
5483  ENDIF
5484  istist=1
5485  IF(ibarf(j).EQ.500)istist=2
5486  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvs(i)-3,0,
5487  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),7)
5488  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030) nhkk, idhkk(nhkk)
5489 C WRITE(6,*)' Firt chain HADRVS'
5490  IF (iphkk.GE.7) WRITE(6,1000)nhkk, isthkk(nhkk),idhkk(nhkk),
5491  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
5492  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
5493 
5494  20 CONTINUE
5495 C IF(NHAD.GT.0) THEN
5496 C JDAHKK(1,IMOHKK)=NHKKAU
5497 C JDAHKK(2,IMOHKK)=NHKK
5498 C ENDIF
5499 C
5500 C++++++++++++++++++++++++++++++ CHAIN 2: DIQUARK-QUARK +++++++++++
5501  ifb1=ippv1(is1)
5502  ifb2=ippv2(is1)
5503  ifb3=itsq(is2)
5504  DO 30 j=1,4
5505  poj(j)=pqvsb2(i,j)
5506  pat(j)=pqvsb1(i,j)
5507  30 CONTINUE
5508  pt1=sqrt(poj(1)**2+poj(2)**2)
5509  pt2=sqrt(pat(1)**2+pat(2)**2)
5510  CALL parpt(2,pt1,pt2,2,nevt)
5511 C POJ,PAT EXCHANGED J.R.15.2.90
5512 C RECHANGED HJM 21/2/91
5513 C------------------------------------------------------------------
5514 C check bookkeeping
5515 C-----------------------------------------------------------------
5516 C I= number of valence chain
5517 C Projectile Nr ippp= IFROVP(INTVS1(I))
5518 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
5519  ippp = ifrovp(intvs1(i))
5520  jipp=jsshs(ippp)
5521 C IF(NCHVS2(I).EQ.0)THEN
5522 C WRITE(6,'(A,3I5)')'HADRVS: I,IPPP,JIPP ',
5523 C * I,IPPP,JIPP
5524 C ENDIF
5525 C------------------------------------------------------------------
5526 C check bookkeeping
5527 C-----------------------------------------------------------------
5528  IF(ipco.GE.1)THEN
5529  WRITE(6,*)' VS qq-q ,IFB1,IFB2,IFB3,',
5530  * 'INTVS1=IS1,INTVS2=IS2,JIPP,JITTX',
5531  * ifb1,ifb2,ifb3,intvs1(i),intvs2(i),jipp,jittx
5532  ENDIF
5533 C-------------------------------------------------------------------
5534 C-------------------------------------------------------------------
5535  IF((nchvs2(i).NE.0))THEN
5536  CALL hadjet(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i), bgyvs2
5537  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,nchvs2
5538  + (i),6)
5539  ENDIF
5540  aack=float(ick6)/float(ick6+ihad6+1)
5541  IF((nchvs2(i).EQ.0))THEN
5542  zseawu=rndm(bb)*2.d0*zseaav
5543  rseack=float(jipp)*pdbse+ zseawu*pdbseu
5544  IF(ipco.GE.1)WRITE(6,*)'HADJSE JIPP,RSEACK,PDBSE 4 dpmnuc3',
5545  + jipp,rseack,pdbse
5546  irejss=5
5547  IF(rndm(v).LE.rseack)THEN
5548  irejss=2
5549  IF(amcvs2(i).GT.2.3d0)THEN
5550  irejss=0
5551  CALL hadjse(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i),
5552  * bgyvs2
5553  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,
5554  * nchvs2
5555  + (i),6,irejss,iissqq)
5556  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JIPP,',
5557  * 'RSEACK,IREJSS 4 dpmnuc3',
5558  + jipp,rseack,irejss
5559  ENDIF
5560  IF(irejss.GE.1)THEN
5561  IF(irejss.EQ.1)irejse=irejse+1
5562  IF(irejss.EQ.3)irejs3=irejs3+1
5563  IF(irejss.EQ.2)irejs0=irejs0+1
5564  CALL hadjet(nhad,amcvs2(i),poj,pat,gacvs2(i),
5565  * bgxvs2(i), bgyvs2
5566  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),
5567  * ijcvs2(i),6,nchvs2
5568  + (i),6)
5569  ihad6=ihad6+1
5570  ENDIF
5571  IF(irejss.EQ.0)THEN
5572  IF(iissqq.EQ.3)THEN
5573  ise63=ise63+1
5574  ELSE
5575  ise6=ise6+1
5576  ENDIF
5577  ENDIF
5578  ELSEIF((ijpock.EQ.1).AND.
5579  * (aack.LE.pdbck))THEN
5580  irej=0
5581  CALL hadjck(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i), bgyvs2
5582  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,nchvs2
5583  + (i),6,irej)
5584  IF(irej.EQ.1)THEN
5585  irejck=irejck+1
5586  CALL hadjet(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i), bgyvs2
5587  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,nchvs2
5588  + (i),6)
5589  ihad6=ihad6+1
5590  ENDIF
5591  IF(irej.EQ.0)ick6=ick6+1
5592  ELSE
5593  CALL hadjet(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i), bgyvs2
5594  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,nchvs2
5595  + (i),6)
5596  ihad6=ihad6+1
5597  ENDIF
5598  ENDIF
5599 C------------------------------------------------------------------
5600 C------------------------------------------------------------------
5601 C ADD HADRONS/RESONANCES INTO
5602 C COMMON /ALLPAR/ STARTING AT NAUX
5603  nhkkau=nhkk+1
5604  DO 40 j=1,nhad
5605  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5606  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
5607  WRITE(6,'(A,2I5,2E16.6)')
5608  + ' HADRVS: CORRECT INCONSISTENT PARTICLE ENERGY ', nhkk,nref
5609  + (j), hef(j),ehecc
5610  hef(j)=ehecc
5611  ENDIF
5612  annvs=annvs+1
5613  eevs=eevs+hef(j)
5614  ptvs=ptvs+sqrt(pxf(j)**2+pyf(j)**2)
5615 C PUT NN-CMS HADRONS INTO /HKKEVT/
5616 C NHKK=NHKK+1
5617  IF (nhkk.EQ.nmxhkk) THEN
5618  WRITE (6,'(A,2I5)') .EQ.' HADRVS: NHKKNMXHKK ',nhkk,nmxhkk
5619  RETURN
5620  ENDIF
5621  istist=1
5622  IF(ibarf(j).EQ.500)istist=2
5623  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvs(i),0,
5624  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),8)
5625 C WRITE(6,*)' HKKFIL: NHKKAU,IORMO(J) ',ISTIST, NHKKAU,IORMO(J)
5626  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
5627  + (nhkk)
5628  IF(irejss.LT.0)THEN
5629  WRITE(6,*)' Second chain HADRVS'
5630  IF (iphkk.GE.0) WRITE(6,1000) nhkk, isthkk(nhkk),idhkk(nhkk),
5631  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
5632  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
5633  ENDIF
5634  40 CONTINUE
5635 C IF(NHAD.GT.0) THEN
5636 C JDAHKK(1,IMOHKK)=NHKKAU
5637 C JDAHKK(2,IMOHKK)=NHKK
5638 C ENDIF
5639  50 CONTINUE
5640 C
5641  RETURN
5642  1000 FORMAT (i6,i4,5i6,9e10.2)
5643  1010 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
5644  1020 FORMAT (.GT.' HADRVS JNAUMAX SKIP NEXT PARTICLES ',3i10)
5645  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
5646  END
5647 *-- Author :
5648 C
5649 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5650 C
5651  SUBROUTINE hadjet(NHAD,AMCH,PPR,PTA,GAM,BGX,BGY,BGZ, IFB1,IFB2,
5652  +ifb3,ifb4,i1,i2,nobam,nnch,norig)
5653  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5654  SAVE
5655 C
5656 C HADJET DOES ALL THE NECESSARY ROTATIONS AND LORENTZ TRANSFORMS AND
5657 C CALL CALBAM (BAMJET)
5658 C
5659 C NHAD = NUMBER OF HADRONS CREATED (OUTPUT) = IHAD (CALBAM)
5660 C******** PRODUCED PARTICLES IN COMMON /CMSRES/
5661 C NOTE: NOW IN /FINPAR/ HJM 21/06/90
5662 C AMCH = INVARIANT MASS OF JET (INPUT)
5663 C PPR = 4-MOMENTUM OF FORWARD GOING PARTON (PROJECTILE)(INPUT)
5664 C PTA = 4-MOMENTUM OF BACKWARD GOING PARTON (TARGET)(INPUT)
5665 C GAM,BGX,BGY,BGZ = LORENTZ PARAMETERS OF JET CMS RELATIVE TO
5666 C COLLISION CMS (INPUT)
5667 C
5668 C--------------------------------------------------------------------
5669 C CALBAM(NNCH,I1,I2,IFB1,IFB2,IFB3,IFB4,AMCH,NOBAM,IHAD)
5670 C SAMPLING OF Q-AQ, Q-QQ, QQ-AQQ CHAINS
5671 C USING BAMJET(IHAD,IFB1,IFB2,IFB3,IFB4,AMCH,NOBAM)-----FOR NNCH=0
5672 C OR PARJET(IHAD,ICH1=I1 OR I2)------FOR NNCH=-1 OR +1
5673 C-------------------------------------------------------------------
5674 C IHAD : NUMBER OF PRODUCED PARTICLES
5675 C NNCH : CALL BAMJET FOR NNCH=0
5676 C CALL PARJET FOR NNCH=+1 ICH1=I1
5677 C FOR NNCH=-1 ICH1=I2
5678 C jet not existing for NNCH=+/-99, i.e. IHAD=0
5679 C PRODUCED PARTICLES IN CHAIN REST FRAME ARE IN COMMON /FINPAR/
5680 C AMCH : INVARIANT MASS OF CHAIN (BAMJET)
5681 C
5682 C NOBAM : = 3 QUARK-ANTIQUARK JET QUARK FLAVORS : IFB1,IFB2
5683 C OR ANTIQUARK-QUARK JET IN ANY ORDER
5684 C
5685 C = 4 QUARK-DIQUARK JET, FLAVORS : QU : IFB1, DIQU :IFB2,IFB
5686 C OR ANTIQUARK-ANTIDIQUARK JET
5687 C
5688 C
5689 C = 5 DIQUARK-ANTIDIQUARK JET
5690 C OR ANTIDIQUARK-DIQUARK JET
5691 C FLAVORS : DIQU : IFB1,IFB2, ANTIDIQU : IFB3,IFB4
5692 C IN ANY ORDER
5693 C
5694 C = 6 DIQUARK-QUARK JET, FLAVORS : DIQU : IFB1,IFB2 QU: IFB
5695 C OR ANTIDIQUARK-ANTIQUARK JET
5696 C
5697 C IFBI : FLAVORS : 1,2,3,4 = U,D,S,C 7,8,9,10 = AU,AD,AS,AC
5698 C
5699 C I1,I2 : NUMBER LABEL OF A HADRON CREATED BY PARJET
5700 C
5701 C NORMALLY IN BAMJET THE QUARKS MOVE FORWARD (POSITIVE Z-DIRECTION)
5702 C THE QUARK FLAVORS ARE FIRST GIVEN
5703 C CALBAM ALLOWS EITHER THE QUARK OR ANTIQUARK (DIQU) TO MOVE FORWARD
5704 C THE FORWARD GOING FLAVORS ARE GIVEN FIRST
5705 C
5706 C =====================================================================
5707 *KEEP,DFINPA.
5708  CHARACTER*8 anf
5709  parameter(nfimax=249)
5710  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
5711  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
5712  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
5713  * istath(nfimax)
5714 *KEEP,DPRIN.
5715  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5716 *KEND.
5717 *--------------------------------------------------------------------
5718 *-------------------------------------------------------------------
5719  COMMON /jspart/pxp(1000),pyp(1000),pzp(1000),hepp(1000),nnnp
5720  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
5721 ************************************************************************
5722 ************************************************************************
5723  common/ifragm/ifrag
5724  dimension ppr(4),pta(4),pprj(4),ptaj(4)
5725  LOGICAL ltesha
5726  parameter(tiny=1.d-10)
5727  DATA icheco/0/
5728  DATA icheca/0/
5729 C IPCO=6
5730 C----------------------------------------------------------------------
5731 C
5732 C CHECK HADJET ENERGY CONSERVATION PPR(4)+PTA(4) EQ EHAD
5733 C TRANSFORM PROJECTILE INTO JET REST FRAME
5734 C IF(NOBAM.EQ.4.OR.NOBAM.EQ.6) IPCO=6
5735  IF(ipco.GE.6) THEN
5736  WRITE(6,1010) gam,bgx,bgy,bgz,ppr,pprj
5737  WRITE(6,1000) nhad,amch,pta, ifb1,ifb2,ifb3,ifb4,i1,i2,nobam,
5738  + nnch,norig
5739  1000 FORMAT(10x,i10,5f10.3/10x,9i10)
5740  ENDIF
5741  IF(abs(nnch).EQ.99) THEN
5742  nhad=0
5743 C IPCO=0
5744  RETURN
5745  ENDIF
5746 C
5747  CALL daltra(gam,-bgx,-bgy,-bgz,ppr(1),ppr(2),ppr(3),ppr(4),pprtot,
5748  +pprj(1),pprj(2),pprj(3),pprj(4))
5749  CALL daltra(gam,-bgx,-bgy,-bgz,pta(1),pta(2),pta(3),pta(4),ptatot,
5750  +ptaj(1),ptaj(2),ptaj(3),ptaj(4))
5751 C
5752  IF(ipco.GE.3) WRITE(6,1010)gam,bgx,bgy,bgz,ppr,pprj,pta,ptaj
5753  1010 FORMAT(' HADJET: GAM,BGX,BGY,BGZ,PPR(4),PPRJ(4) ',4f15.5/8f15.5/ 8
5754  +f15.5)
5755 C WORK OUT COD,SID,COF,SIF OF PROJECTILE
5756 C IN JET FRAME
5757  IF(pprtot.LT.tiny)pprtot=tiny
5758  cod= pprj(3)/pprtot
5759  IF(cod.GE.1.d0)cod=0.999999999999
5760  IF(cod.LE.-1.d0)cod=-0.999999999999
5761  sid=sqrt(abs((1.d0-cod)*(1.d0+cod)))
5762  cof=1.
5763  sif=0.
5764  IF((abs(pprj(1)).GT.0.d0).OR.(abs(pprj(2)).GT.0.d0))THEN
5765  IF(pprtot*sid.GT.1.d-9) THEN
5766  cof=pprj(1)/(sid*pprtot)
5767  sif=pprj(2)/(sid*pprtot)
5768  anorf=sqrt(abs(cof*cof+sif*sif))
5769  cof=cof/anorf
5770  sif=sif/anorf
5771  ENDIF
5772  ENDIF
5773  IF (ipco.GE.6) WRITE(6,1020)cod,sid,cof,sif
5774  1020 FORMAT(' COD,SID,COF,SIF ',4f15.8)
5775 C SAMPLE JET IN JET CMS
5776  CALL calbam(nnch,i1,i2,ifb1,ifb2,ifb3,ifb4,amch,nobam,ihad)
5777 C IF(IHAD.EQ.1)THEN
5778 C IPRI=1
5779 C IPCO=3
5780 C ELSE
5781 C IPRI=0
5782 C IPCO=-1
5783 C ENDIF
5784 C NOW WE HAVE IHAD PARTICLES/RESONANCES
5785 C IN COMMON /FINPAR/
5786 C CHECK CALBAM ENERGY CONSERVATION / jet cms
5787  ecal=0.
5788  pxcal=0.
5789  pycal=0.
5790  pzcal=0.
5791  ltesha=.false.
5792  DO 10 i=1,ihad
5793  IF(ibarf(i).EQ.500)go to 1011
5794  pxcal=pxcal + pxf(i)
5795  pycal=pycal + pyf(i)
5796  pzcal=pzcal + pzf(i)
5797  IF(ifrag.EQ.0)THEN
5798  ehecc=sqrt(abs(pxf(i)**2+pyf(i)**2+pzf(i)**2+amf(i)**2))
5799  IF (abs(ehecc-hef(i)).GT.0.0001d0) THEN
5800  IF(ipri.GE.1) WRITE(6,'(2A/A/3I5,3E16.6)')
5801  + ' HADJET / AFTER CALBAM:',
5802  + ' CORRECT INCONSISTENT ENERGY IN JET CMS',
5803  + ' I, IHAD,NREF(I), HEF(I),EHECC, AMF(I)',
5804  * i,ihad,nref(i), hef(i),ehecc, amf(i)
5805  hef(i)=ehecc
5806  ltesha=.true.
5807  ENDIF
5808  ENDIF
5809  ecal=ecal + hef(i)
5810  1011 CONTINUE
5811  10 CONTINUE
5812  IF (abs(ecal-amch).GT.0.005d0) ltesha=.true.
5813  IF (ltesha) THEN
5814  icheca=icheca+1
5815  IF (abs(ecal-amch).GT.0.005d0) THEN
5816  IF(icheca.LE.10)WRITE(6,'(A/10I4)')
5817  + ' HADJET/1:ICHECA,IFB1,IFB2,IFB3,IFB4,I1,I2,NOBAM,NNCH,NORIG',
5818  + icheca,ifb1,
5819  + ifb2,ifb3,ifb4,i1,i2,nobam,nnch,norig
5820  IF(icheca.LE.10)WRITE(6,1030) amch,ecal,pxcal,pycal,pzcal
5821  1030 FORMAT(' CALBAM E. CHECK (5 MeV) AMCH,ECAL,PXCAL,PYCAL,PZCAL=',
5822  + /5e20.8)
5823  ltesha=.false.
5824  ENDIF
5825  ENDIF
5826  IF (ipco.GE.3)THEN
5827  DO 20 i=1,ihad
5828  WRITE(6,1040)i,pxf(i),pyf(i),pzf(i),hef(i),amf(i), ichf(i),
5829  + ibarf(i),nref(i),anf(i)
5830  1040 FORMAT(' JET SYSTEM ',i5,5f12.4,3i5,a10)
5831  20 CONTINUE
5832  ENDIF
5833 C CALL DECAY(IHAD,2)
5834 C NHAD=IHAD
5835 C CHECK CALBAM+DECAY ENERGY CONSERVATION
5836 C ECAL=0.
5837 C PXCAL=0.
5838 C PYCAL=0.
5839 C PZCAL=0.
5840 C DO 1204 I=1,IHAD
5841 C ECAL=ECAL+HEF(I)
5842 C PXCAL=PXCAL+PXF(I)
5843 C PYCAL=PYCAL+PYF(I)
5844 C PZCAL=PZCAL+PZF(I)
5845 C1204 CONTINUE
5846 C IOUCHA=3
5847 C IF (ABS(ECAL-AMCH)/AMCH.GT.0.00001D0)IOUCHA=1
5848 C IF (IPCO.GE.IOUCHA)WRITE(6,1203)AMCH,ECAL,PXCAL,PYCAL,PZCAL
5849 C1203 FORMAT(' CALBAM+DECAY ENERGY CHECK AMCH,ECAL,PXCAL,PYCAL,PZCAL '
5850 C * /5E20.8)
5851 C IF (IPCO.GE.3)THEN
5852 C DO 143 I=1,IHAD
5853 C WRITE(6,144)I,PXF(I),PYF(I),PZF(I),HEF(I),AMF(I),
5854 C * ICHF(I),IBARF(I),NREF(I),ANF(I)
5855 C 144 FORMAT(' JET SYSTEM DECAY ',I5,5F12.4,3I5,A10)
5856 C 143 CONTINUE
5857 C ENDIF
5858 C ROTATE JET BY COD,SID,COF,SIF
5859  pxcal=0.
5860  pycal=0.
5861  pzcal=0.
5862  ltesha=.false.
5863  DO 30 i=1,ihad
5864  phec2=pxf(i)**2+pyf(i)**2+pzf(i)**2
5865  CALL dtrans(pxf(i),pyf(i),pzf(i),cod,sid,cof,sif,xx,yy,zz)
5866  prota2=xx**2 + yy**2 + zz**2
5867  pxf(i)=xx
5868  pyf(i)=yy
5869  pzf(i)=zz
5870  pxcal=pxcal + pxf(i)
5871  pycal=pycal + pyf(i)
5872  pzcal=pzcal + pzf(i)
5873 C EHECC=SQRT(ABS(PXF(I)**2+PYF(I)**2+PZF(I)**2+AMF(I)**2))
5874  IF(abs(phec2-prota2).GT.0.0001d0) THEN
5875  WRITE(6,'(2A/3I5,3E16.6)')
5876  & ' HADJET: INCONSISTENT MOMENTUM AFTER TRANS',
5877  * ' I, IHAD,NREF(I), PHEC2,PROTA2, AMF(I)',
5878  * i,ihad,nref(i), phec2,prota2, amf(i)
5879 C HEF(I)=EHECC
5880  ltesha=.true.
5881  ENDIF
5882  30 CONTINUE
5883  IF (ltesha) THEN
5884  WRITE(6,'(A/9I4)')
5885  + ' HADJET/2: IFB1,IFB2,IFB3,IFB4,I1,I2,NOBAM,NNCH,NORIG', ifb1,
5886  + ifb2,ifb3,ifb4,i1,i2,nobam,nnch,norig
5887  WRITE(6,1031) pxcal,pycal,pzcal
5888  1031 FORMAT(' CALBAM ENERGY CHECK/2: PXCAL,PYCAL,PZCAL='/3e20.8)
5889  ltesha=.false.
5890  ENDIF
5891  IF (ipco.GE.3)THEN
5892  DO 40 i=1,ihad
5893  WRITE(6,1050)i,pxf(i),pyf(i),pzf(i),hef(i),amf(i), ichf(i),
5894  + ibarf(i),nref(i),anf(i)
5895  1050 FORMAT(' ROTATET JET SYSTEM ',i5,5f12.4,3i5,a10)
5896  40 CONTINUE
5897  ENDIF
5898 ************************************************************************
5899 ************************************************************************
5900 C Rotate partons
5901  nnnnp=nnnp
5902  IF(nnnp.GT.1000)nnnnp=1000
5903  DO 1105 i=1,nnnnp
5904  CALL dtrans(pxp(i),pyp(i),pzp(i),cod,sid,cof,sif,xx,yy,zz)
5905  pxp(i)=xx
5906  pyp(i)=yy
5907  pzp(i)=zz
5908  1105 CONTINUE
5909 ************************************************************************
5910 ************************************************************************
5911 C TRANSFORM THIS JET BACK INTO CMS
5912 C************************ IN COMMON BLOCK/CMSRES/
5913 C LORTMO USES /FINPAR/ ONLY !!!!!
5914 C CALL LORTRA(IHAD,1,GAM,BGX,BGY,BGZ)
5915  CALL lortmo(ihad,gam,bgx,bgy,bgz)
5916  nhad=ihad
5917 C
5918  IF (ipco.GE.3)THEN
5919  DO 50 i=1,ihad
5920  WRITE(6,1060) i,pxf(i),pyf(i),pzf(i),hef(i),amf(i), ichf(i),
5921  + ibarf(i),nref(i),anf(i)
5922  1060 FORMAT(' CMS SYSTEM ',i5,5f12.4,3i5,a10)
5923  50 CONTINUE
5924  ENDIF
5925 C HADJET ENERGY CONSERVATION TEST
5926 C AND CONSISTENCY TEST OF PARTICLE 4-MOMENTUM
5927  ltesha=.false.
5928  ehad=0.
5929  DO 60 i=1,ihad
5930  IF(ibarf(i).EQ.500)go to 6060
5931  ehad=ehad+hef(i)
5932  ehecc=sqrt(abs(pxf(i)**2+pyf(i)**2+pzf(i)**2+amf(i)**2))
5933  IF (abs(ehecc-hef(i)).GT.0.001d0) THEN
5934  IF(abs(ehecc-hef(i)).GT.0.1d0)WRITE(6,'(2A/4I5,3E16.6)')
5935  & ' HADJET: CORRECT INCONSISTENT ENERGY AFTER LORTRA',
5936  * ' NORIG, I, IHAD,NREF(I), HEF(I),EHECC, AMF(I)',
5937  * norig, i,ihad,nref(i), hef(i),ehecc, amf(i)
5938  hef(i)=ehecc
5939 C LTESHA=.TRUE.
5940  ENDIF
5941  6060 CONTINUE
5942  60 CONTINUE
5943 ************************************************************************
5944 ************************************************************************
5945 C Transform partons
5946  nnnnp=nnnp
5947  IF(nnnp.GT.1000)nnnnp=1000
5948  nnnpj=nnnnp
5949  CALL lortrp(nnnnp,1,gam,bgx,bgy,bgz)
5950 ************************************************************************
5951 ************************************************************************
5952 C IOUCHA=3
5953 c EEIN=PPR(4)+PTA(4)
5954 c PXIN=PPR(1)+PTA(1)
5955 c PYIN=PPR(2)+PTA(2)
5956 c PZIN=PPR(3)+PTA(3)
5957 C PXIN=BGX*AMCH
5958 C PYIN=BGY*AMCH
5959 C PZIN=BGZ*AMCH
5960  eein=gam*amch
5961  IF (abs(eein-ehad).GT.0.005d0) THEN
5962  icheco=icheco+1
5963  IF (abs(eein-ehad).GT.0.005d0) THEN
5964  IF(icheco.LT.10)THEN
5965  WRITE(6,'(A/10I5)')
5966  + ' HADJET/3:ICHECO,IFB1,IFB2,IFB3,IFB4,I1,I2,NOBAM,NNCH,NORIG',
5967  + icheco,ifb1,
5968  + ifb2,ifb3,ifb4,i1,i2,nobam,nnch,norig
5969  WRITE (6,1070) eein,ehad,amch,gam,bgx,bgy,bgz
5970  1070 FORMAT(' HADJET ENERGY CHECK (5 MeV) EEIN,EHAD,AMCH',3e20.8/
5971  + 20x,' GAM,BGX,BGY,BGZ ',4e20.8)
5972 c WRITE(6,1010)GAM,BGX,BGY,BGZ,PPR,PPRJ
5973  ENDIF
5974  ENDIF
5975  ENDIF
5976 C IPCO=0
5977  RETURN
5978  END
5979 
5980 ************************************************************************
5981 ************************************************************************
5982 *
5983  SUBROUTINE lortrp(N,NAUX,GAM,BGX,BGY,BGZ)
5984 *
5985 * LORENTZ TRANSFORMATION OF N PARTICLES IN JSPART TO BE
5986 * STORED IN JSPAR STARTING AT NAUX
5987 *
5988 *********************************************************************
5989 *
5990  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5991  SAVE
5992 C impl. mxnupa after KNO cut solved 3.92
5993  parameter(mxnupa=2500)
5994  COMMON /jspart/pxp(1000),pyp(1000),pzp(1000),hepp(1000),nnnp
5995  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
5996 * CHANGED JUNE 1,1987
5997  parameter(one=1.d0)
5998  DATA ifirst/0/
5999  DATA num/0/
6000  ifirst=ifirst+1
6001  num=num+1
6002  pxsm=0.0
6003  pysm=0.0
6004  pzsm=0.0
6005  esum=0.
6006  pxsc=0.0
6007  pysc=0.0
6008  pzsc=0.0
6009  esmc=0.0
6010 * END OF CHANGE
6011  DO 1 i=1,n
6012  j = naux + i - 1
6013  pxsm=pxsm+pxp(i)
6014  pysm=pysm+pyp(i)
6015  pzsm=pzsm+pzp(i)
6016  esum=esum+hepp(i)
6017  CALL daltra(gam,bgx,bgy,bgz,pxp(i),pyp(i),pzp(i),hepp(i),
6018  *ppa,pxj(j),pyj(j),pzj(j),hej(j))
6019  pxsc=pxsc+pxj(j)
6020  pysc=pysc+pyj(j)
6021  pzsc=pzsc+pzj(j)
6022  esmc=esmc+hej(j)
6023 1 CONTINUE
6024 * PXSM,ETC,ARE SUMS FOR BAMJET FRAGMENTS IN JET CMS
6025  CALL daltra(gam,bgx,bgy,bgz,pxsm,pysm,pzsm,esum,
6026  *ppa,pxsm,pysm,pzsm,esum)
6027 * PXSC,ETC,ARE SUMS FOR BAMJET FRAGMENTS IN PROJ,TARGET CMS
6028 
6029  pxdif=pxsm-pxsc
6030  pydif=pysm-pysc
6031  pzdif=pzsm-pzsc
6032  edif=esum-esmc
6033  diffl=pxdif+pydif+pzdif+edif
6034  IF(diffl.GE.1.d-2*one)
6035  1WRITE(6,2)num,pxdif,pydif,pzdif,edif,pxsm,pxsc,
6036 C WRITE(6,2)NUM,PXDIF,PYDIF,PZDIF,EDIF,PXSM,PXSC,
6037  1pysm,pysc,pzsm,pzsc,esum,esmc
6038  2 FORMAT(' ',2x,'LORTRA:NUM=',i5,2x,'PXDIF=',1pe15.6,2x,'PYDIF=',
6039  21pe15.6,2x,'PZDIF=',1pe15.6,2x,'EDIF=',1pe15.6/2x,'PXSM=',1pe15.6,
6040  32x,'PXSC=',1pe15.6,2x,'PYSM=',1pe15.6,2x,'PYSC=',1pe15.6/2x,'PZSM'
6041  4,1pe15.6,2x,'PZSC=',1pe15.6,2x,'ESUM=',1pe15.6,2x,'ESMC=',1pe15.6/
6042  52x,'LORTRA DIFFERENCES DUE TO ALTRA'/)
6043  RETURN
6044  END
6045 *
6046 ************************************************************************
6047 ************************************************************************
6048 *-- Author :
6049  SUBROUTINE cobcma(IF1,IF2,IF3,IJNCH,NNCH,IREJ,AMCH,AMCHN,IKET)
6050  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6051  SAVE
6052 C
6053 C REPLACE SMALL MASS BARYON CHAINS (AMCH)
6054 C BY OCTETT OR DECUPLETT BARYONS
6055 C
6056 C HERE ONLY THE CHAIN MASS IS CHANGED
6057 C (AMCHN) BUT NO CORRECTION OF KINEMATICS!
6058 C
6059 C MASS CORRECTED FOR NNCH.NE.0
6060 C
6061 C IREJ=1: CHAIN GENERATION NOT ALLOWED BECAUSE OF TOO SMALL MASS
6062 C START FROM THE BEGINNING IN HAEVT
6063 *KEEP,DPAR.
6064 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6065 C ANAME = LITERAL NAME OF THE PARTICLE
6066 C AAM = PARTICLE MASS IN GEV
6067 C GA = DECAY WIDTH
6068 C TAU = LIFE TIME OF INSTABLE PARTICLES
6069 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6070 C IIBAR = BARYON NUMBER
6071 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6072 C
6073  CHARACTER*8 aname
6074  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
6075  +iibar(210),k1(210),k2(210)
6076 C------------------
6077 *KEEP,DPRIN.
6078  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6079 *KEEP,KETMAS.
6080  COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
6081 *KEND.
6082 C----------------
6083  CALL dbklas(if1,if2,if3,ib8,ibb10)
6084 C
6085  IF (ipev.GE.2)WRITE(6,1000)if1,if2,if3,ib8,ibb10
6086  1000 FORMAT (' COBCMA: IPQ,ITTQ1,ITTQ2,IB8,IBB10 ',5i5)
6087 C
6088  am81=aam(ib8)
6089  am101=aam(ibb10)
6090  am8(iket)=am81
6091  am10(iket)=am101
6092  ib88(iket)=ib8
6093  ib1010(iket)=ibb10
6094  nnch=0
6095  ijnch=0
6096  irej=0
6097  amff1=am101+0.3
6098 C
6099 C j.r.10.5.93
6100 C IF(AMCH.LT.AMFF1) THEN
6101 C IREJ=1
6102 C RETURN
6103 C ENDIF
6104 C -------------
6105  IF(amch.LT.am81) THEN
6106  irej=1
6107  ELSEIF (amch.LT.am101)THEN
6108 C PRODUCE OKTETT BARYON
6109 C CORRECT KINEMATICS
6110  ijnch=ib8
6111  nnch=-1
6112  amchn=am81
6113  ELSEIF(amch.LT.amff1) THEN
6114 C PRODUCE DECUPLETT BARYON
6115 C CORRECT KINEMATICS
6116  amchn=am101
6117  ijnch=ibb10
6118  nnch=1
6119  ELSE
6120  amchn=amch
6121  ENDIF
6122 C NO CORRECTIONS BUT DO CHAIN 2
6123  IF(ipev.GE.2) THEN
6124  WRITE(6,1010) amch,amchn,am81,am101
6125  WRITE(6,1020) if1,if2,if3,ib8,ibb10,ijnch,nnch,irej
6126  1010 FORMAT(' COBCMA: AMCH,AMCHN,AM81,AM101', 4f13.4)
6127  1020 FORMAT(' COBCMA: IF1,IF2,IF3,IB8,IBB10,IJNCH,NNCH,IREJ',8i4)
6128  ENDIF
6129  RETURN
6130  END
6131 *-- Author :
6132 C
6133 C++++++++++++++++++++++++++++++++++++++
6134 C
6135  SUBROUTINE comcma(IFQ,IFAQ,IJNCH,NNCH,IREJ,AMCH,AMCHN)
6136  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6137  SAVE
6138 C
6139 C REPLACE SMALL MASS MESON CHAINS BY PSEUDOSCALAR OR VECTOR MESONS
6140 C
6141 C HERE ONLY THE CHAIN MASS IS CHANGED
6142 C (AMCHN) BUT NO CORRECTION OF KINEMATICS!
6143 C
6144 C
6145 *KEEP,DPAR.
6146 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6147 C ANAME = LITERAL NAME OF THE PARTICLE
6148 C AAM = PARTICLE MASS IN GEV
6149 C GA = DECAY WIDTH
6150 C TAU = LIFE TIME OF INSTABLE PARTICLES
6151 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6152 C IIBAR = BARYON NUMBER
6153 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6154 C
6155  CHARACTER*8 aname
6156  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
6157  +iibar(210),k1(210),k2(210)
6158 C------------------
6159 *KEEP,DINPDA.
6160  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
6161  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
6162 *KEEP,DPRIN.
6163  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6164 *KEND.
6165 C------------------------
6166  iifaq=iabs(ifaq)
6167  ifps=imps(iifaq,ifq)
6168  ifv=imve(iifaq,ifq)
6169  IF (ipev.GE.2)WRITE (6,1000)iifaq,ifq,ifps,ifv
6170  1000 FORMAT (' COMCMA',5x,' IIPPAQ,ITQ,IFPS,IFV ',4i5)
6171  amps=aam(ifps)
6172  amv=aam(ifv)
6173  nnch=0
6174  ijnch=0
6175  irej=0
6176  amff=amv+0.3
6177  IF(ipev.GE.2) WRITE(6,1010) amch,amps,amv,ifps,ifv
6178  1010 FORMAT(' AMCH,AMPS,AMV,IFPS,IFV ',3f12.4,2i10)
6179 C j.r.10.5.93
6180 C IF(AMCH.LT.AMFF) THEN
6181 C IREJ=1
6182 C RETURN
6183 C ENDIF
6184 C ------------
6185 C
6186  IF(amch.LT.amps) THEN
6187  irej=1
6188  RETURN
6189  ENDIF
6190 C
6191  IF (amch.LT.amv) THEN
6192 C PRODUCE PSEUDO SCALAR
6193  ijnch=ifps
6194  nnch=-1
6195  amchn=amps
6196  ELSEIF(amch.LT.amff) THEN
6197 C PRODUCE VECTOR MESON
6198  ijnch=ifv
6199  nnch=1
6200  amchn=amv
6201  ELSE
6202  amchn=amch
6203  ENDIF
6204  IF(ipev.GE.2) THEN
6205  WRITE(6,1030) amch,amchn,amps,amv
6206  WRITE(6,1020) ifq,ifaq,ifps,ifv,ijnch,nnch,irej
6207  1030 FORMAT(' COMCMA: AMCH,AMCHN,AMPS,AMV', 4f13.4)
6208  1020 FORMAT(' COMCMA: IFQ,IFAQ,IFPS,IFV,IJNCH,NNCH,IREJ',8i4)
6209  ENDIF
6210 C
6211  RETURN
6212  END
6213 *-- Author :
6214 C
6215 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6216 C
6217 C 17/10/89 910191458 MEMBER NAME MCOMCM2 (KK89.S) F77
6218  SUBROUTINE comcm2(IQ1,IQ2,IAQ1,IAQ2,NNCH,IREJ,AMCH)
6219  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6220  SAVE
6221 
6222 C--------------------------------------------------------------------
6223 C (QQ)-(AQ AQ) CHAIN:
6224 C CHECK QUANTUM NUMBERS AND
6225 C CORRECT MASS IF NECESSARY
6226 C REJECT IF THERE IS NO CORRESPONDING PARTICLE
6227 C OR TOO LOW MASS
6228 C--------------------------------------------------------------------
6229 *KEEP,DPAR.
6230 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6231 C ANAME = LITERAL NAME OF THE PARTICLE
6232 C AAM = PARTICLE MASS IN GEV
6233 C GA = DECAY WIDTH
6234 C TAU = LIFE TIME OF INSTABLE PARTICLES
6235 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6236 C IIBAR = BARYON NUMBER
6237 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6238 C
6239  CHARACTER*8 aname
6240  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
6241  +iibar(210),k1(210),k2(210)
6242 C------------------
6243 *KEEP,DPRIN.
6244  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6245 *KEEP,DINPDA.
6246  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
6247  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
6248 *KEND.
6249 C--------------------------
6250  irej=0
6251  iiaq1=-iaq1
6252  iiaq2=-iaq2
6253  IF (iiaq1.EQ.iq1) go to 10
6254  IF (iiaq1.EQ.iq2) go to 20
6255  IF (iiaq2.EQ.iq1) go to 30
6256  IF (iiaq2.EQ.iq2) go to 40
6257 C REJECTION: NO CANCELLATION OF
6258 C ANY (Q-AQ) PAIR
6259  irej=1
6260  IF(ipev.GE.3) THEN
6261  WRITE(6,'(A/5X,4I5,1PE13.5)')
6262  + ' KKEVVV/COMCM2 (QU. NUMBERS): IQ1, IQ2, IAQ1, IAQ2, AMCH', iq1,
6263  + iq2, iaq1, iaq2, amch
6264  ENDIF
6265  RETURN
6266 C
6267  10 CONTINUE
6268 C IFPS=IMPS(IIAQ2,IQ2)
6269 C IFV =IMVE(IIAQ2,IQ2)
6270  go to 50
6271  20 CONTINUE
6272 C IFPS=IMPS(IIAQ2,IQ1)
6273 C IFV =IMVE(IIAQ2,IQ1)
6274  go to 50
6275  30 CONTINUE
6276 C IFPS=IMPS(IIAQ1,IQ2)
6277 C IFV =IMVE(IIAQ1,IQ2)
6278  go to 50
6279  40 CONTINUE
6280 C IFPS=IMPS(IIAQ1,IQ1)
6281 C IFV =IMVE(IIAQ1,IQ1)
6282 C
6283  50 CONTINUE
6284 C AMFPS=AAM(IFPS)
6285 C AMFV =AAM(IFV)
6286 C AMFF=AMFV+0.3
6287 C EMPIRICAL DEFINITION OF AMFF
6288 C TO ALLOW FOR (B-ANTIB) PAIR PRODUCTION
6289  amff=2.5
6290  nnch=0
6291  IF (amch.LT.amff) THEN
6292  irej=1
6293  IF(ipev.GE.3) THEN
6294  WRITE(6,'(A/5X,4I5,1PE13.5)')
6295  + ' KKEVVV/COMCM2 (MASS!): IQ1, IQ2, IAQ1, IAQ2, AMCH', iq1,
6296  + iq2, iaq1, iaq2, amch
6297  ENDIF
6298  ENDIF
6299  RETURN
6300  END
6301 *-- Author :
6302 C
6303 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6304 C
6305  SUBROUTINE cormom(AMCH1,AMCH2,AMCH1N,AMCH2N,
6306  +pq1x,pq1y,pq1z,pq1e,pa1x,pa1y,pa1z,pa1e, pq2x,pq2y,pq2z,pq2e,pa2x,
6307  +pa2y,pa2z,pa2e, pxch1,pych1,pzch1,ech1, pxch2,pych2,pzch2,ech2,
6308  +irej)
6309  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6310  SAVE
6311 C
6312 C CORRECT KINEMATICS IF MASS OF THE FIRST CHAIN HAS BEEN CHANGED
6313 C FROM AMCH1 TO AMCH1N
6314 C CHAIN 1: (XP,XTVD)
6315 C AMMM : TOTAL MASS OF TWO CHAIN SYSTEM
6316 C AMCH2N : RESULTING NEW MASS FOR CHAIN 2 (OUTPUT ONLY)
6317 C
6318 C--- RESCALING OF X-VALUES
6319 C ACCORDING TO THE MODIFIED MASS OF CHAIN 1
6320 *KEEP,DPRIN.
6321  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6322 *KEND.
6323 C------------------------------------
6324 C WRITE(6,'(A,4(7E15.5/))')' CORMOM IN',AMCH1,AMCH2,AMCH1N,AMCH2N,
6325 C +PQ1X,PQ1Y,PQ1Z,PQ1E,PA1X,PA1Y,PA1Z,PA1E, PQ2X,PQ2Y,PQ2Z,PQ2E,PA2X,
6326 C +PA2Y,PA2Z,PA2E, PXCH1,PYCH1,PZCH1,ECH1, PXCH2,PYCH2,PZCH2,ECH2
6327 C
6328  IF(amch1.EQ.0.d0)THEN
6329  irej=1
6330  WRITE(6,*) 'Error in CORMOM : AMCH1=0. Event rejected'
6331  RETURN
6332  ENDIF
6333  fak=amch1n/amch1
6334 C WRITE(6,'(A,F10.5)')' FAK ',FAK
6335  amch1=amch1n
6336 C
6337  pq1xol=pq1x
6338  pq1yol=pq1y
6339  pq1zol=pq1z
6340  pq1eol=pq1e
6341  pa1xol=pa1x
6342  pa1yol=pa1y
6343  pa1zol=pa1z
6344  pa1eol=pa1e
6345  pq2xol=pq2x
6346  pq2yol=pq2y
6347  pq2zol=pq2z
6348  pq2eol=pq2e
6349  pa2xol=pa2x
6350  pa2yol=pa2y
6351  pa2zol=pa2z
6352  pa2eol=pa2e
6353 C
6354  pxch1o=pxch1
6355  pych1o=pych1
6356  pzch1o=pzch1
6357  ech10=ech1
6358  pxch2o=pxch2
6359  pych2o=pych2
6360  pzch2o=pzch2
6361  ech20=ech2
6362 C
6363 C
6364 C--- RESCALING OF MOMENTA FOR PARTONS OF CHAIN 1
6365  pq1x=pq1x*fak
6366  pq1y=pq1y*fak
6367  pq1z=pq1z*fak
6368  pq1e=pq1e*fak
6369  pa2x=pa2x*fak
6370  pa2y=pa2y*fak
6371  pa2z=pa2z*fak
6372  pa2e=pa2e*fak
6373 C NEW MOMENTA OF PARTONS OF CHAIN 2
6374 C FROM MOMENTUM CONSERVATION
6375  pa1x=pa1xol+pq1xol-pq1x
6376  pa1y=pa1yol+pq1yol-pq1y
6377  pa1z=pa1zol+pq1zol-pq1z
6378  pa1e=pa1eol+pq1eol-pq1e
6379  pq2x=pq2xol+pa2xol-pa2x
6380  pq2y=pq2yol+pa2yol-pa2y
6381  pq2z=pq2zol+pa2zol-pa2z
6382  pq2e=pq2eol+pa2eol-pa2e
6383 C--- NEW MOMENTUM OF CHAIN 1
6384  pxch1=pq1x+pa2x
6385  pych1=pq1y+pa2y
6386  pzch1=pq1z+pa2z
6387  ech1 =pq1e+pa2e
6388 C
6389 C WRITE(6,'(A,4(7E15.5/))')' CORMOM MOD',AMCH1,AMCH2,AMCH1N,AMCH2N,
6390 C +PQ1X,PQ1Y,PQ1Z,PQ1E,PA1X,PA1Y,PA1Z,PA1E, PQ2X,PQ2Y,PQ2Z,PQ2E,PA2X,
6391 C +PA2Y,PA2Z,PA2E, PXCH1,PYCH1,PZCH1,ECH1, PXCH2,PYCH2,PZCH2,ECH2
6392 C
6393  root =(ech1-amch1)*(ech1+amch1)
6394  IF(root.LT.0.d0)THEN
6395  irej=1
6396  WRITE(6,*)'Error in CORMOM : ROOT<0. Event rejected'
6397  WRITE(6,*)'ECH1=',ech1,' AMCH1=',amch1,' ROOT=',root
6398  RETURN
6399  ENDIF
6400  pch1 = sqrt(root) + 0.000001
6401 C
6402 C--- NEW 4-MOMENTUM OF CHAIN 2
6403  pxch2=pa1x+pq2x
6404  pych2=pa1y+pq2y
6405  pzch2=pa1z+pq2z
6406  ech2 =pa1e+pq2e
6407  pch2 =sqrt(pxch2**2+pych2**2+pzch2**2)
6408  amch22=ech2**2-pxch2**2-pych2**2-pzch2**2
6409 C
6410  IF(amch22.LT.0.d0)THEN
6411  irej=1
6412  WRITE(6,*)'Error in CORMOM : AMCH22<0. Event rejected'
6413 C WRITE(6,*)'ECH2=',ECH2,' PXCH2=',PXCH2,' PYCH2=',PYCH2,
6414 C * ' PZCH2=',PZCH2
6415  RETURN
6416  ENDIF
6417  amch2n=sqrt(amch22)
6418 C---
6419  IF(ipri.GT.1) THEN
6420  pxsum=pq1x+pa1x+pq2x+pa2x
6421  pysum=pq1y+pa1y+pq2y+pa2y
6422  pzsum=pq1z+pa1z+pq2z+pa2z
6423  pesum=pq1e+pa1e+pq2e+pa2e
6424  WRITE(6,'(A)') ' CORMOM: KINEMATIC TEST FOR PARTONS'
6425  WRITE(6,'(A,4(1PE12.5))') ' PXSUM,PYSUM,PZSUM,PESUM', pxsum,
6426  + pysum,pzsum,pesum
6427  ENDIF
6428  RETURN
6429  END
6430 *-- Author :
6431 C
6432 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6433 
6434 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6435  SUBROUTINE selpt4( PTXSQ1,PTYSQ1,
6436  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6437  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,nselpt)
6438  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6439  SAVE
6440 C SELECT PT VALUES FOR A TWO CHAIN SYSTEM
6441 C SELECT SEA QUARK AND ANTIQUARK PT-VALUES
6442 *KEEP,DPRIN.
6443  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6444 *KEEP,DROPPT.
6445  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
6446  +ishmal,lpauli
6447  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
6448  +ipadis,ishmal,lpauli
6449 *KEND.
6450  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
6451 C--------------------------------
6452 C change j.r.6.5.93
6453  qtxsq1=ptxsq1
6454  qtxsa1=ptxsa1
6455  qtxsq2=ptxsq2
6456  qtxsa2=ptxsa2
6457  qtysq1=ptysq1
6458  qtysa1=ptysa1
6459  qtysq2=ptysq2
6460  qtysa2=ptysa2
6461  qlq1=plq1
6462  qlaq1=plaq1
6463  qlq2=plq2
6464  qlaq2=plaq2
6465  qeq1=eq1
6466  qeaq1=eaq1
6467  qeq2=eq2
6468  qeaq2=eaq2
6469 C ----------------
6470  ianfa=0
6471  itagpt=0
6472 C changed from 3. j.r.21.8.93
6473  b33=16.00
6474  IF (ikvala.EQ.1)b33=16.0
6475  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6476  hps=sqrt(es*es+2.*es*0.94)
6477 C............................................................
6478  IF (.NOT.intpt) hps=0.0000001
6479  icount=0
6480  irej=0
6481  10 CONTINUE
6482  icount=icount+1
6483  IF (icount.EQ.48)THEN
6484  hps=0.d0
6485  ENDIF
6486  IF (icount.EQ.50)THEN
6487 C REJECT EVENT
6488  irej=1
6489  RETURN
6490  ENDIF
6491  IF (icount.GE.1)THEN
6492  hps=hps*0.8
6493  CALL dsfecf(sfe,cfe)
6494  ptxsq1=qtxsq1+hps*cfe
6495  ptysq1=qtysq1+hps*sfe
6496  ptxsa1=qtxsa1-hps*cfe
6497  ptysa1=qtysa1-hps*sfe
6498  go to 111
6499  ENDIF
6500  b33=2.*b33
6501  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6502  hps=sqrt(es*es+2.*es*0.94)
6503 C............................................................
6504  110 CONTINUE
6505  IF (.NOT.intpt) hps=0.0000001
6506 C.............................................................
6507  CALL dsfecf(sfe,cfe)
6508 C change j.r.6.5.93
6509  ptxsq1=qtxsq1+hps*cfe
6510  ptysq1=qtysq1+hps*sfe
6511  ptxsa1=qtxsa1-hps*cfe
6512  ptysa1=qtysa1-hps*sfe
6513  111 CONTINUE
6514 C -----------------
6515  IF (ipev.GE.7)WRITE(6,1000)ptxsq1,ptysq1,ptxsa1,ptysa1 ,ptxsq2,
6516  +ptysq2,ptxsa2,ptysa2
6517  1000 FORMAT (' PT S ',8f12.6)
6518 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
6519  pttq1=ptxsq1**2+ptysq1**2
6520  ptta1=ptxsa1**2+ptysa1**2
6521  IF((eq1**2.LE.pttq1).OR. (eaq1**2.LE.ptta1)) go to 10
6522 C
6523  ianfa2=0
6524  itagp2=0
6525  b33=16.00
6526  IF (ikvala.EQ.1)b33=16.0
6527  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6528  hps=sqrt(es*es+2.*es*0.94)
6529 C............................................................
6530  IF (.NOT.intpt) hps=0.0000001
6531  icoun2=0
6532  irej=0
6533  12 CONTINUE
6534  icoun2=icoun2+1
6535  IF (icoun2.EQ.48)THEN
6536  hps=0.d0
6537  ENDIF
6538  IF (icoun2.EQ.50)THEN
6539  irej=1
6540 C REJECT EVENT
6541  RETURN
6542  ENDIF
6543  IF(icoun2.GE.1)THEN
6544  hps=hps*0.8
6545  CALL dsfecf(sfe,cfe)
6546  ptxsq2=qtxsq2+hps*cfe
6547  ptysq2=qtysq2+hps*sfe
6548  ptxsa2=qtxsa2-hps*cfe
6549  ptysa2=qtysa2-hps*sfe
6550  go to 113
6551  ENDIF
6552  b33=2.*b33
6553 C
6554  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6555  hps=sqrt(es*es+2.*es*0.94d0)
6556 C............................................................
6557  112 CONTINUE
6558  IF (.NOT.intpt) hps=0.0000001
6559 C.............................................................
6560  CALL dsfecf(sfe,cfe)
6561 C change j.r.6.5.93
6562  ptxsq2=qtxsq2+hps*cfe
6563  ptysq2=qtysq2+hps*sfe
6564  ptxsa2=qtxsa2-hps*cfe
6565  ptysa2=qtysa2-hps*sfe
6566  113 CONTINUE
6567 C -----------------
6568 C
6569  IF (ipev.GE.7)WRITE(6,1000)ptxsq1,ptysq1,ptxsa1,ptysa1 ,ptxsq2,
6570  +ptysq2,ptxsa2,ptysa2
6571 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
6572  pttq2=ptxsq2**2+ptysq2**2
6573  ptta2=ptxsa2**2+ptysa2**2
6574  IF((eq2**2.LE.pttq2).OR. (eaq2**2.LE.ptta2)) go to 12
6575 C
6576 C IF(IP.GE.1)GO TO 1779
6577  plq1=sqrt(eq1**2-pttq1)
6578  plaq1=sqrt(eaq1**2-ptta1)
6579  plq2=-sqrt(eq2**2-pttq2)
6580  plaq2=-sqrt(eaq2**2-ptta2)
6581  1779 CONTINUE
6582 C-----------
6583 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
6584  amch1q=(eq1+eaq2)**2-(ptxsq1+ptxsa2)** 2-(ptysq1+ptysa2)**2-(plq1
6585  ++plaq2)**2
6586  IF (amch1q.LE.0.d0)THEN
6587  WRITE(6,301)amch1q
6588  301 FORMAT(' inconsistent Kinematics in SELPT AMCH1Q=',e12.3)
6589  WRITE(6,305) qtxsq1,qtysq1,
6590  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
6591  +qtxsa2,
6592  +qtysa2,qlaq2,qeaq2, amch1,amch2
6593  305 FORMAT( 'PTXSQ1,PTYSQ1,
6594  +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,PTYSQ2,PLQ2,EQ2,PTXSA2,
6595  +PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2',5(4e15.5/))
6596  irej=1
6597  RETURN
6598  ENDIF
6599  amch1=sqrt(amch1q)
6600 C
6601 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
6602  amch2q=(eq2+eaq1)**2-(ptxsq2+ptxsa1)** 2-(ptysq2+ptysa1)**2-(plq2
6603  ++plaq1)**2
6604  IF (amch2q.LE.0.d0)THEN
6605  WRITE(6,302)amch2q
6606  302 FORMAT(' inconsistent Kinematics in SELPT AMCH2Q=',e12.3)
6607  WRITE(6,305) qtxsq1,qtysq1,
6608  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
6609  +qtxsa2,
6610  +qtysa2,qlaq2,qeaq2, amch1,amch2
6611 C IF(ITAGPT.EQ.0)GO TO !33
6612  irej=1
6613  RETURN
6614  ENDIF
6615  amch2=sqrt(amch2q)
6616  RETURN
6617  END
6618 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6619 
6620  SUBROUTINE selpt( PTXSQ1,PTYSQ1,
6621  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6622  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6623  * pttq2,ptta2, nselpt)
6624  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6625  SAVE
6626 C SELECT PT VALUES FOR A TWO CHAIN SYSTEM DPMJET (combined
6627 C DTUNUC/TUJET method)
6628 C SELECT SEA QUARK AND ANTIQUARK PT-VALUES
6629 *KEEP,DPRIN.
6630  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6631 *KEEP,DROPPT.
6632  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
6633  +ishmal,lpauli
6634  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
6635  +ipadis,ishmal,lpauli
6636 *KEND.
6637  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
6638  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
6639  data nusept /0/
6640  data musept /0/
6641  IF(ipev.GE.4)WRITE(6,6633) ptxsq1,ptysq1,
6642  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6643  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6644  * nselpt
6645  6633 FORMAT(' selpt input: ',
6646  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6647  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6648  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,2i5,2e12.4,i5)
6649 C--------------------------------
6650 C change j.r.6.5.93
6651  qtxsq1=ptxsq1
6652  qtxsa1=ptxsa1
6653  qtxsq2=ptxsq2
6654  qtxsa2=ptxsa2
6655  qtysq1=ptysq1
6656  qtysa1=ptysa1
6657  qtysq2=ptysq2
6658  qtysa2=ptysa2
6659  qlq1=plq1
6660  qlaq1=plaq1
6661  qlq2=plq2
6662  qlaq2=plaq2
6663  qeq1=eq1
6664  qeaq1=eaq1
6665  qeq2=eq2
6666  qeaq2=eaq2
6667 C ----------------
6668  ianfa=0
6669  itagpt=0
6670  ianfa2=0
6671  itagp2=0
6672  irej=0
6673  icount=0
6674  icoun2=0
6675  1 CONTINUE
6676  IF ( nselpt.EQ.0 .OR.umo.LE.20.d0) THEN
6677 C changed from 3. j.r.21.8.93
6678  b33=16.0
6679 C IF (IKVALA.EQ.1)B33=3.7
6680 C Test 12.2.96
6681 C IF (IKVALA.EQ.1)B33=(3.0+6.0/LOG10(UMO+10.))/2.
6682  IF (ikvala.EQ.1)b33=3.0+6.0/log10(umo+10.)
6683  IF (ikvala.EQ.2)b33=4.0+3.0/log10(umo+10.)
6684  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6685  hps=sqrt(es*es+2.*es*0.94)
6686 C............................................................
6687  110 CONTINUE
6688  IF (.NOT.intpt) hps=0.0000001
6689 C.............................................................
6690  10 CONTINUE
6691  icount=icount+1
6692  IF (icount.EQ.48)THEN
6693  hps=0.d0
6694  ENDIF
6695  IF (icount.EQ.50)THEN
6696 C REJECT EVENT
6697  irej=1
6698  RETURN
6699  ENDIF
6700  IF (icount.GE.2)THEN
6701  hps=hps*0.8
6702  ptxsq1=ptxsq1*0.8
6703  ptysq1=ptysq1*0.8
6704  ptxsa1=ptxsa1*0.8
6705  ptysa1=ptysa1*0.8
6706  CALL dsfecf(sfe,cfe)
6707 C PTXSQ1=QTXSQ1+HPS*CFE
6708 C PTYSQ1=QTYSQ1+HPS*SFE
6709 C PTXSA1=QTXSA1-HPS*CFE
6710 C PTYSA1=QTYSA1-HPS*SFE
6711  go to 111
6712  ENDIF
6713  b33=2.*b33
6714  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6715  hps=sqrt(es*es+2.*es*0.94)
6716 C............................................................
6717  IF (.NOT.intpt) hps=0.0000001
6718 C
6719  ELSEIF(nselpt.EQ.1)THEN
6720  CALL samppt(0,hps)
6721  CALL samppt(1,hps)
6722  IF(ipev.GE.4)WRITE(6,6638)hps
6723  ELSEIF(nselpt.EQ.2)THEN
6724  IF (nusept.EQ.0)THEN
6725  CALL samppt(0,hps)
6726  CALL samppt(1,hps)
6727  IF(ipev.GE.4)WRITE(6,6638)hps
6728  nusept=1
6729  usept=hps
6730  ELSEIF(nusept.EQ.1)THEN
6731  hps=usept
6732  ENDIF
6733  ENDIF
6734  CALL dsfecf(sfe,cfe)
6735 C change j.r.6.5.93
6736  ptxsq1=qtxsq1+hps*cfe
6737  ptysq1=qtysq1+hps*sfe
6738  ptxsa1=qtxsa1-hps*cfe
6739  ptysa1=qtysa1-hps*sfe
6740  qtxsq1=qtxsq1*0.8
6741  qtysq1=qtysq1*0.8
6742  qtxsa1=qtxsa1*0.8
6743  qtysa1=qtysa1*0.8
6744  111 CONTINUE
6745 C -----------------
6746 C
6747  IF (ipev.GE.7)WRITE(6,1000)ptxsq1,ptysq1,ptxsa1,ptysa1 ,ptxsq2,
6748  +ptysq2,ptxsa2,ptysa2
6749  1000 FORMAT (' PT S ',8f12.6)
6750 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
6751  pttq1=ptxsq1**2+ptysq1**2
6752  ptta1=ptxsa1**2+ptysa1**2
6753 C
6754  IF ( nselpt.EQ.0.OR.umo.LE.20.d0 ) THEN
6755  b33=16.0
6756 C IF (IKVALA.EQ.1)B33=3.7
6757  IF (ikvala.EQ.1)b33=3.0+6.0/log10(umo+10.)
6758  IF (ikvala.EQ.2)b33=4.0+3.0/log10(umo+10.)
6759  irej=0
6760  12 CONTINUE
6761  icoun2=icoun2+1
6762  IF (icoun2.EQ.48)THEN
6763  hps=0.d0
6764  ENDIF
6765  IF (icoun2.EQ.50)THEN
6766 C REJECT EVENT
6767  irej=1
6768  RETURN
6769  ENDIF
6770  IF(icoun2.GE.2)THEN
6771  hps=hps*0.8
6772  ptxsq2=ptxsq2*0.8
6773  ptysq2=ptysq2*0.8
6774  ptxsa2=ptxsa2*0.8
6775  ptysa2=ptysa2*0.8
6776  CALL dsfecf(sfe,cfe)
6777 C PTXSQ2=QTXSQ2+HPS*CFE
6778 C PTYSQ2=QTYSQ2+HPS*SFE
6779 C PTXSA2=QTXSA2-HPS*CFE
6780 C PTYSA2=QTYSA2-HPS*SFE
6781  go to 113
6782  ENDIF
6783  b33=2.*b33
6784 C
6785  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6786  hps=sqrt(es*es+2.*es*0.94)
6787 C............................................................
6788  112 CONTINUE
6789  IF (.NOT.intpt) hps=0.0000001
6790 C.............................................................
6791  ELSEIF(nselpt.EQ.1)THEN
6792  IF (musept.EQ.0)THEN
6793  CALL samppt(0,hps)
6794  CALL samppt(1,hps)
6795  IF(ipev.GE.4)WRITE(6,6638)hps
6796  6638 FORMAT (' SELPT:SAMPPT: HPS= ',e12.4)
6797  musept=1
6798  useptm=hps
6799  ELSEIF(musept.EQ.1)THEN
6800  hps=useptm
6801  ENDIF
6802  ENDIF
6803  CALL dsfecf(sfe,cfe)
6804 C change j.r.6.5.93
6805  ptxsq2=qtxsq2+hps*cfe
6806  ptysq2=qtysq2+hps*sfe
6807  ptxsa2=qtxsa2-hps*cfe
6808  ptysa2=qtysa2-hps*sfe
6809  qtxsq2=qtxsq2*0.8
6810  qtysq2=qtysq2*0.8
6811  qtxsa2=qtxsa2*0.8
6812  qtysa2=qtysa2*0.8
6813  113 CONTINUE
6814 C -----------------
6815 C
6816  IF (ipev.GE.7)WRITE(6,1000)ptxsq1,ptysq1,ptxsa1,ptysa1 ,ptxsq2,
6817  +ptysq2,ptxsa2,ptysa2
6818 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
6819  pttq1=ptxsq1**2+ptysq1**2
6820  ptta1=ptxsa1**2+ptysa1**2
6821  pttq2=ptxsq2**2+ptysq2**2
6822  ptta2=ptxsa2**2+ptysa2**2
6823  ptwq1=sqrt(pttq1)
6824  ptwa1=sqrt(ptta1)
6825  ptwq2=sqrt(pttq2)
6826  ptwa2=sqrt(ptta2)
6827  IF(plq1.GT.ptwq1.AND.abs(plaq2).GT.ptwq1)THEN
6828  plq1=qlq1-ptwq1
6829  plaq2=qlaq2+ptwq1
6830  ELSEIF(plq1.GT.ptwa2.AND.abs(plaq2).GT.ptwa2)THEN
6831  plq1=qlq1-ptwa2
6832  plaq2=qlaq2+ptwa2
6833  ENDIF
6834  IF(plaq1.GT.ptwa1.AND.abs(plq2).GT.ptwa1)THEN
6835  plaq1=qlaq1-ptwa1
6836  plq2=qlq2+ptwa1
6837  ELSEIF(plaq1.GT.ptwq2.AND.abs(plq2).GT.ptwq2)THEN
6838  plaq1=qlaq1-ptwq2
6839  plq2=qlq2+ptwq2
6840  ENDIF
6841  qlq1=plq1
6842  qlaq1=plaq1
6843  qlq2=plq2
6844  qlaq2=plaq2
6845  pttq1=pttq1+plq1**2
6846  ptta1=ptta1+plaq1**2
6847  pttq2=pttq2+plq2**2
6848  ptta2=ptta2+plaq2**2
6849  IF (intpt) THEN
6850  amte1=0.2
6851  IF(amte1.GE.eq1**2)amte1=eq1**2/2.
6852  amte2=0.2
6853  IF(amte2.GE.eq2**2)amte2=eq2**2/2.
6854  amte3=0.2
6855  IF(amte1.GE.eaq1**2)amte1=eaq1**2/2.
6856  amte4=0.2
6857  IF(amte2.GE.eaq2**2)amte2=eaq2**2/2.
6858  IF((eq1**2-amte1.LE.pttq1).OR.
6859  * (eq2**2-amte1.LE.pttq2)
6860  * .OR.(eaq1**2-amte3.LE.ptta1).OR.
6861  * (eaq2**2-amte4.LE.ptta2))THEN
6862  IF ( nselpt.EQ.0.OR.umo.LE.20.d0 ) THEN
6863  go to 1
6864  ELSE
6865  usept = usept * 0.7
6866  useptm = useptm * 0.7
6867  IF( usept.GT.0.01d0 .OR. useptm.GT.0.01d0 ) THEN
6868  IF (ipev.GE.6)THEN
6869  WRITE(6,*)' SELPT: JUMP AFTER REDUCTION OF USEPT'
6870  WRITE(6,*)' SELPT: USEPT,USEPTM,HPS',usept,useptm,hps
6871  ENDIF
6872  go to 1
6873  ELSE
6874  irej = 1
6875  IF(ipev.GE.4)WRITE(6,6634) ptxsq1,ptysq1,
6876  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6877  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6878  * nselpt
6879  6634 FORMAT(' selpt rejec: ',
6880  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6881  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6882  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,3i5)
6883  RETURN
6884  ENDIF
6885  ENDIF
6886  ENDIF
6887  ENDIF
6888  nusept=0
6889  musept=0
6890 C
6891  IF(ip.GE.1)go to 1779
6892  qqq1=qtxsq1**2+qtysq1**2+qlq1**2-pttq1
6893  IF(qqq1.GT.0.d0)THEN
6894  plq1=sqrt(qqq1)
6895  ELSE
6896  plq1=sqrt(eq1**2-pttq1)
6897  ENDIF
6898  qqa1=qtxsa1**2+qtysa1**2+qlaq1**2-ptta1
6899  IF(qqa1.GT.0.d0)THEN
6900  plaq1=sqrt(qqa1)
6901  ELSE
6902  plaq1=sqrt(eaq1**2-ptta1)
6903  ENDIF
6904  qqq2=qtxsq2**2+qtysq2**2+qlq2**2-pttq2
6905  IF(qqq2.GT.0.d0)THEN
6906  plq2=-sqrt(qqq2)
6907  ELSE
6908  plq2=-sqrt(eq2**2-pttq2)
6909  ENDIF
6910  qqa2=qtxsa2**2+qtysa2**2+qlaq2**2-ptta2
6911  IF(qqa2.GT.0.d0)THEN
6912  plaq2=-sqrt(qqa2)
6913  ELSE
6914  plaq2=-sqrt(eaq2**2-ptta2)
6915  ENDIF
6916  1779 CONTINUE
6917 C-----------
6918 C-----------
6919 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
6920  amch1q=(eq1+eaq2)**2-(ptxsq1+ptxsa2)** 2-(ptysq1+ptysa2)**2-(plq1
6921  ++plaq2)**2
6922  IF (amch1q.LE.0.d0)THEN
6923 C IF(IANFA.EQ.0)THEN
6924 C IANFA=1
6925 C ITAGPT=1
6926 C GO TO 110
6927 C ENDIF
6928 C GO TO 10
6929  WRITE(6,301)amch1q
6930  301 FORMAT(' inconsistent Kinematics in SELPT AMCH1Q=',e12.3)
6931  WRITE(6,305) qtxsq1,qtysq1,
6932  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
6933  +qtxsa2,
6934  +qtysa2,qlaq2,qeaq2, amch1,amch2
6935  305 FORMAT( 'PTXSQ1,PTYSQ1,
6936  +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,PTYSQ2,PLQ2,EQ2,PTXSA2,
6937  +PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2',5(4e15.5/))
6938 C IF(ITAGPT.EQ.0)GO TO !33
6939  irej=1
6940  IF(ipev.GE.4)WRITE(6,6635) ptxsq1,ptysq1,
6941  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6942  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6943  * nselpt
6944  6635 FORMAT(' selpt rejec: ',
6945  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6946  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6947  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,3i5)
6948  RETURN
6949  ENDIF
6950  amch1=sqrt(amch1q)
6951 C
6952 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
6953  amch2q=(eq2+eaq1)**2-(ptxsq2+ptxsa1)** 2-(ptysq2+ptysa1)**2-(plq2
6954  ++plaq1)**2
6955  IF (amch2q.LE.0.d0)THEN
6956 C IF(IANFA.EQ.0)THEN
6957 C IANFA=1
6958 C ITAGPT=1
6959 C GO TO 110
6960 C ENDIF
6961 C GO TO 10
6962  WRITE(6,302)amch2q
6963  302 FORMAT(' inconsistent Kinematics in SELPT AMCH2Q=',e12.3)
6964  WRITE(6,305) qtxsq1,qtysq1,
6965  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
6966  +qtxsa2,
6967  +qtysa2,qlaq2,qeaq2, amch1,amch2
6968 C IF(ITAGPT.EQ.0)GO TO !33
6969  irej=1
6970  IF(ipev.GE.4)WRITE(6,6636) ptxsq1,ptysq1,
6971  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6972  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6973  * nselpt
6974  6636 FORMAT(' selpt rejec: ',
6975  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6976  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6977  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,3i5)
6978  RETURN
6979  ENDIF
6980  amch2=sqrt(amch2q)
6981  IF(ipev.GE.4)WRITE(6,6637) ptxsq1,ptysq1,
6982  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6983  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6984  * nselpt
6985  6637 FORMAT(' selpt exit : ',
6986  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6987  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6988  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,2i5,2e12.4,i5)
6989  RETURN
6990  END
6991 *-- Author :
6992 C
6993 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6994 C
6995  SUBROUTINE dechkk(NHKKH1)
6996  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6997  SAVE
6998 *KEEP,HKKEVT.
6999 c INCLUDE (HKKEVT)
7000  parameter(nmxhkk= 89998)
7001 c PARAMETER (NMXHKK=25000)
7002  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
7003  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
7004  +(4,nmxhkk)
7005  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
7006  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
7007 C
7008 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
7009 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
7010 C THE POSITIONS OF THE PROJECTILE NUCLEONS
7011 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
7012 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
7013 C COMPLETELY CONSISTENT. THE TIMES IN THE
7014 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
7015 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
7016 C
7017 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
7018 C
7019 C NMXHKK: maximum numbers of entries (partons/particles) that can be
7020 C stored in the commonblock.
7021 C
7022 C NHKK: the actual number of entries stored in current event. These are
7023 C found in the first NHKK positions of the respective arrays below.
7024 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
7025 C entry.
7026 C
7027 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
7028 C = 0 : null entry.
7029 C = 1 : an existing entry, which has not decayed or fragmented.
7030 C This is the main class of entries which represents the
7031 C "final state" given by the generator.
7032 C = 2 : an entry which has decayed or fragmented and therefore
7033 C is not appearing in the final state, but is retained for
7034 C event history information.
7035 C = 3 : a documentation line, defined separately from the event
7036 C history. (incoming reacting
7037 C particles, etc.)
7038 C = 4 - 10 : undefined, but reserved for future standards.
7039 C = 11 - 20 : at the disposal of each model builder for constructs
7040 C specific to his program, but equivalent to a null line in the
7041 C context of any other program. One example is the cone defining
7042 C vector of HERWIG, another cluster or event axes of the JETSET
7043 C analysis routines.
7044 C = 21 - : at the disposal of users, in particular for event tracking
7045 C in the detector.
7046 C
7047 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
7048 C standard.
7049 C
7050 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
7051 C The value is 0 for initial entries.
7052 C
7053 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
7054 C one mother exist, in which case the value 0 is used. In cluster
7055 C fragmentation models, the two mothers would correspond to the q
7056 C and qbar which join to form a cluster. In string fragmentation,
7057 C the two mothers of a particle produced in the fragmentation would
7058 C be the two endpoints of the string (with the range in between
7059 C implied).
7060 C
7061 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
7062 C entry has not decayed, this is 0.
7063 C
7064 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
7065 C entry has not decayed, this is 0. It is assumed that the daughters
7066 C of a particle (or cluster or string) are stored sequentially, so
7067 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
7068 C daughters. Even in cases where only one daughter is defined (e.g.
7069 C K0 -> K0S) both values should be defined, to make for a uniform
7070 C approach in terms of loop constructions.
7071 C
7072 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
7073 C
7074 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
7075 C
7076 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
7077 C
7078 C PHKK(4,IHKK) : energy, in GeV.
7079 C
7080 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
7081 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
7082 C
7083 C VHKK(1,IHKK) : production vertex x position, in mm.
7084 C
7085 C VHKK(2,IHKK) : production vertex y position, in mm.
7086 C
7087 C VHKK(3,IHKK) : production vertex z position, in mm.
7088 C
7089 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
7090 C********************************************************************
7091 *KEEP,DDECAC.
7092  parameter(idmax9=602)
7093  CHARACTER*8 zkname
7094  COMMON /ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
7095 *KEEP,DPRIN.
7096  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7097 *KEEP,DPAR.
7098 C /DPAR/ CONTAINS PARTICLE PROPERTIES
7099 C ANAME = LITERAL NAME OF THE PARTICLE
7100 C AAM = PARTICLE MASS IN GEV
7101 C GA = DECAY WIDTH
7102 C TAU = LIFE TIME OF INSTABLE PARTICLES
7103 C IICH = ELECTRIC CHARGE OF THE PARTICLE
7104 C IIBAR = BARYON NUMBER
7105 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
7106 C
7107  CHARACTER*8 aname
7108  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
7109  +iibar(210),k1(210),k2(210)
7110 C------------------
7111 *KEND.
7112  dimension ecmf(3),pcmf(3),codf(3),coff(3),siff(3),itf(3)
7113  dimension ecmff(3),pcmff(3)
7114  dimension cxf(3),cyf(3),czf(3)
7115  DATA istab /2/
7116 C-----------------------------------------------------
7117  ihkk=nhkkh1
7118 C IPHKK=2
7119  IF (iphkk.GE.2) WRITE(6,1000) ihkk,nhkk
7120  1000 FORMAT(' DECHKK IHKK,NHKK= ',2i5)
7121 C
7122 C*** LOOP OVER ALL PARTICLES FROM THE STACK
7123  10 CONTINUE
7124  ihkk=ihkk+1
7125  IF (ihkk.GT.nhkk)THEN
7126 C IPHKK=0
7127  RETURN
7128  ENDIF
7129 C
7130  IF(abs(isthkk(ihkk)).NE.1) goto 10
7131  iqqqq=isthkk(ihkk)
7132 C
7133  it=mcihad(idhkk(ihkk))
7134 C
7135  IF (it.LT.1.OR.it.GT.210) THEN
7136  WRITE (6,1003)it
7137  1003 FORMAT (' DECHKK IT ',i10)
7138  ENDIF
7139 C
7140 C*****TEST STABLE OR UNSTABLE
7141 C ISTAB=2
7142 C ISTAB=1/2/3 MEANS STRONG + WEAK DECAYS / ONLY STRONG DECAYS /
7143 C STRONG DECAYS + WEAK DECAYS FOR CHARMED PARTICLES AND TAU LEPTONS
7144 C
7145 C GOTO 51 : THERE WAS NO DECAY RETURN TO STACK
7146 C
7147  IF(istab.EQ.1) THEN
7148  IF(it.EQ.135.OR.it.EQ.136) goto 10
7149  IF(it.GE.1.AND.it.LE.7) goto 10
7150  ELSEIF(istab.EQ.2) THEN
7151  IF(it.GE. 1.AND.it.LE. 30) goto 10
7152  IF(it.GE. 97.AND.it.LE.103) goto 10
7153  IF(it.GE.115.AND.it.LE.122) goto 10
7154  IF(it.GE.131.AND.it.LE.136) goto 10
7155  IF(it.EQ.109) goto 10
7156  IF(it.GE.137.AND.it.LE.160) goto 10
7157  ELSEIF(istab.EQ.3) THEN
7158  IF(it.GE.1.AND.it.LE.23) goto 10
7159  IF(it.GE. 97.AND.it.LE.103) goto 10
7160  IF(it.EQ.109.AND.it.EQ.115) goto 10
7161  IF(it.GE.133.AND.it.LE.136) goto 10
7162  ENDIF
7163 C*** DECAY TO BE HANDLED
7164 C
7165  pls=sqrt(abs(phkk(1,ihkk)**2+phkk(2,ihkk)**2+phkk(3,ihkk)**2))
7166 C
7167 C Consistency check of decaying hadron
7168 C
7169  amtest=sqrt(abs(phkk(4,ihkk)**2-pls**2))
7170  IF(abs(amtest-phkk(5,ihkk)).GE.1.d-3)THEN
7171 C WRITE(6,'(A,2E15.5,I10)')' DECHKK inconsistent resonance',
7172 C * AMTEST,PHKK(5,IHKK),IHKK
7173  plss=(phkk(4,ihkk)**2-phkk(5,ihkk))
7174  IF(plss.LE.0.d0)THEN
7175  WRITE(6,'(A)')' negative momentum square!'
7176  plss=0.d0
7177  ENDIF
7178  plsn=sqrt(plss)
7179  amodp=plsn/pls
7180  phkk(1,ihkk)=phkk(1,ihkk)*amodp
7181  phkk(2,ihkk)=phkk(2,ihkk)*amodp
7182  phkk(3,ihkk)=phkk(3,ihkk)*amodp
7183  pls=pls*amodp
7184  ENDIF
7185 C
7186  IF(pls.NE.0.d0) THEN
7187  cxs=phkk(1,ihkk)/pls
7188  cys=phkk(2,ihkk)/pls
7189  czs=phkk(3,ihkk)/pls
7190  ENDIF
7191  els=phkk(4,ihkk)
7192  eco=aam(it)
7193  gam=els/eco
7194  bgam=pls/eco
7195 C
7196  kz1=k1(it)
7197  vv=rndm(v) - 1.e-17
7198  iik=kz1-1
7199  20 iik=iik+1
7200  IF (vv.GT.wt(iik)) go to 20
7201 C
7202 C IIK IS THE DECAY CHANNEL
7203  itf(1)=nzk(iik,1)
7204  itf(2)=nzk(iik,2)
7205 C****************************** ?????????????????????
7206 C?? IF (ITF(2)-1.LT.0) GO TO 110
7207 C?? IF (IT2-1.LT.0) GO TO 305
7208  IF (itf(2).LT.1) go to 10
7209 C****************************** ????????????????????
7210  itf(3)=nzk(iik,3)
7211 C
7212  IF(iphkk.GE.1) WRITE(6,1010)it,iik,itf(1),itf(2),itf(3)
7213  1010 FORMAT(' DECHKK IT,IIK,IT1,IT2,IT3 ',5i5)
7214 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
7215 C
7216  IF(itf(3).EQ.0) THEN
7217  ndecpr=2
7218  CALL dtwopd(eco,ecmf(1),ecmf(2),pcmf(1),pcmf(2), codf(1),coff
7219  + (1),siff(1),codf(2),coff(2),siff(2), aam(itf(1)),aam(itf(2)))
7220  sid1=sqrt(abs((1.-codf(1))*(1.+codf(1))))
7221  sid2=sqrt(abs((1.-codf(2))*(1.+codf(2))))
7222  pix1=pcmf(1)*sid1*coff(1)
7223  piy1=pcmf(1)*sid1*siff(1)
7224  piz1=pcmf(1)*codf(1)
7225  pix2=pcmf(2)*sid2*coff(2)
7226  piy2=pcmf(2)*sid2*siff(2)
7227  piz2=pcmf(2)*codf(2)
7228  pix12=pix1+pix2
7229  piy12=piy1+piy2
7230  piz12=piz1+piz2
7231  ecm12=ecmf(1)+ecmf(2)-eco
7232  IF((abs(pix12).GT.0.000001d0).OR.
7233  + (abs(piy12).GT.0.000001d0).OR.
7234  + (abs(piz12).GT.0.000001d0).OR.
7235  + (abs(ecm12).GT.0.000001d0))THEN
7236  WRITE(6,778)pix12,piy12,piz12,ecm12
7237  778 FORMAT(' DWOPD px,py,pz,e',4f10.6)
7238  ENDIF
7239 
7240  ELSE
7241  ndecpr=3
7242  CALL dthrep(eco,ecmf(1),ecmf(2),ecmf(3),pcmf(1),pcmf(2),pcmf(3),
7243  + codf(1),coff(1),siff(1),codf(2),coff(2),siff(2), codf(3),coff
7244  + (3),siff(3), aam(itf(1)),aam(itf(2)),aam(itf(3)))
7245  sid1=sqrt((1.-codf(1))*(1.+codf(1)))
7246  sid2=sqrt((1.-codf(2))*(1.+codf(2)))
7247  sid3=sqrt((1.-codf(3))*(1.+codf(3)))
7248  pix1=pcmf(1)*sid1*coff(1)
7249  piy1=pcmf(1)*sid1*siff(1)
7250  piz1=pcmf(1)*codf(1)
7251  pix2=pcmf(2)*sid2*coff(2)
7252  piy2=pcmf(2)*sid2*siff(2)
7253  piz2=pcmf(2)*codf(2)
7254  pix3=pcmf(3)*sid3*coff(3)
7255  piy3=pcmf(3)*sid3*siff(3)
7256  piz3=pcmf(3)*codf(3)
7257  pix12=pix1+pix2+pix3
7258  piy12=piy1+piy2+piy3
7259  piz12=piz1+piz2+piz3
7260  ecm12=ecmf(1)+ecmf(2)+ecmf(3)-eco
7261  IF((abs(pix12).GT.0.000001d0).OR.
7262  + (abs(piy12).GT.0.000001d0).OR.
7263  + (abs(piz12).GT.0.000001d0).OR.
7264  + (abs(ecm12).GT.0.000001d0))THEN
7265  WRITE(6,779)pix12,piy12,piz12,ecm12
7266  779 FORMAT(' DTHEPD px,py,pz,e',4f10.6)
7267  ENDIF
7268 
7269  ENDIF
7270 C
7271  jdahkk(1,ihkk)=nhkk + 1
7272  jdahkk(2,ihkk)=nhkk + ndecpr
7273  DO 30 id=1,ndecpr
7274  ehecc=sqrt(abs(pcmf(id)** 2+ aam(itf(id))**2))
7275  IF (abs(ehecc-ecmf(id)).GT.0.0001d0) THEN
7276  WRITE(6,'(2A/3I5,3E15.6)')
7277  & ' DECHKK: CORRECT INCONSISTENT ENERGY ',
7278  * ' IHKK,NHKK,ITF(ID), ECMF(ID),EHECC, AAM(ITF(ID))',
7279  * ihkk,nhkk,itf(id), ecmf(id),ehecc, aam(itf(id))
7280  ENDIF
7281 C CALL DTRAFO(GAM,BGAM,CXS,CYS,CZS, CODF(ID),COFF(ID),
7282 C *SIFF(ID),PCMF
7283  CALL dtrafo(gam,bgam,cxs,cys,czs, codf(id),coff(id),
7284  * siff(id),pcmf(id),ecmf(id), pcmff(id),cxf(id),
7285  *cyf(id),czf(id),ecmff(id))
7286  IF (iphkk.GE.2) WRITE(6,'(A,7E15.5/8E15.5)')' DTRAFO ',
7287  * gam,bgam,cxs,cys,czs, codf(id),coff(id),
7288  * siff(id),pcmf(id),ecmf(id), pcmff(id),cxf(id),
7289  *cyf(id),czf(id),ecmff(id)
7290 
7291 C*******************
7292 C THERE WAS A DECAY, DROP MOTHER IHKK
7293 C AND PUT PARTICLE INTO HKK STACK
7294  isthkk(ihkk)=2
7295  IF (nhkk.EQ.nmxhkk)THEN
7296  WRITE (6,1020)nhkk,nmxhkk
7297  1020 FORMAT (.GT.' NHKKNMXHKK IN DECHKK RETURN ',2i10)
7298 C IPHKK=0
7299  RETURN
7300  ENDIF
7301 C
7302  nhkk=nhkk+1
7303  IF (nhkk.EQ.nmxhkk) THEN
7304  WRITE (6,'(A,2I5)') .EQ.' DECHKK: NHKKNMXHKK ',nhkk,nmxhkk
7305 C IPHKK=0
7306  RETURN
7307  ENDIF
7308  idbam(nhkk)=itf(id)
7309  isthkk(nhkk)=iqqqq
7310  idhkk(nhkk)=mpdgha(itf(id))
7311  jmohkk(1,nhkk)=ihkk
7312  jmohkk(2,nhkk)=0
7313  jdahkk(1,nhkk)=0
7314  jdahkk(2,nhkk)=0
7315  phkk(1,nhkk)=cxf(id)*pcmff(id)
7316  phkk(2,nhkk)=cyf(id)*pcmff(id)
7317  phkk(3,nhkk)=czf(id)*pcmff(id)
7318  ehecc=sqrt(abs(pcmff(id)** 2+ aam(itf(id))**2))
7319  IF (abs(ehecc-ecmff(id)).GT.0.003d0) THEN
7320  WRITE(6,'(2A/3I5,3E15.6)')
7321  & ' DECHKK: CORRECT INCONSISTENT ENERGY ',
7322  * ' IHKK,NHKK,ITF(ID), ECMF(ID),EHECC, AAM(ITF(ID))',
7323  * ihkk,nhkk,itf(id), ecmff(id),ehecc, aam(itf(id))
7324  ecmff(id)=ehecc
7325  ENDIF
7326  phkk(4,nhkk)=ecmff(id)
7327  phkk(5,nhkk)=aam(itf(id))
7328  vhkk(1,nhkk)=vhkk(1,ihkk)
7329  vhkk(2,nhkk)=vhkk(2,ihkk)
7330  vhkk(3,nhkk)=vhkk(3,ihkk)
7331  vhkk(4,nhkk)=vhkk(4,ihkk)
7332 C
7333  IF (iphkk.GE.7) WRITE(6,1030)nhkk, isthkk(nhkk),idhkk(nhkk),
7334  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
7335  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
7336 
7337  1030 FORMAT (i6,i4,5i6,9e10.2)
7338 C
7339  30 CONTINUE
7340 C
7341  goto 10
7342 C
7343 C RETURN
7344  END
7345 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7346 
7347 *=== trafo ============================================================*
7348 *
7349  SUBROUTINE dtrafo(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
7350  1pl,cxl,cyl,czl,el)
7351  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7352  SAVE
7353 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
7354  sid=sqrt(1.d0-cod*cod)
7355  plx=p*sid*cof
7356  ply=p*sid*sif
7357  pppt=sqrt(plx**2+ply**2)
7358  pcmz=p*cod
7359  plz=gam*pcmz+bgam*ecm
7360  pl=sqrt(plx*plx+ply*ply+plz*plz)
7361  el=gam*ecm+bgam*pcmz
7362 C ROTATION INTO THE ORIGINAL DIRECTION
7363  coz=plz/pl
7364 C SIZ=SQRT((1.D0-COZ)*(1.D0+COZ))
7365  siz=pppt/pl
7366 C WRITE(6,'(A,2E25.16)')' COZ,SIZ ',COZ,SIZ
7367  CALL sttran(cx,cy,cz,coz,siz,sif,cof,cxl,cyl,czl)
7368  RETURN
7369  END
7370 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7371 
7372  SUBROUTINE sttran(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
7373  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7374  SAVE
7375  DATA anglsq/1.d-14/
7376 C********************************************************************
7377 C VERSION BY J. RANFT
7378 C LEIPZIG
7379 C
7380 C THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES
7381 C
7382 C INPUT VARIABLES:
7383 C XO,YO,ZO = ORIGINAL DIRECTION COSINES
7384 C CDE,SDE = COSINE AND SINE OF THE POLAR (THETA)
7385 C ANGLE OF "SCATTERING"
7386 C SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"
7387 C SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE
7388 C OF "SCATTERING"
7389 C
7390 C OUTPUT VARIABLES:
7391 C X,Y,Z = NEW DIRECTION COSINES
7392 C
7393 C ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )
7394 C********************************************************************
7395 C
7396 *
7397 * Changed by A. Ferrari
7398 *
7399 * IF (ABS(XO)-0.0001D0) 1,1,2
7400 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
7401 * 3 CONTINUE
7402  a = xo**2 + yo**2
7403  IF ( a .LT. anglsq ) THEN
7404  x=sde*cfe
7405  y=sde*sfe
7406 C Z=CDE CORRECTED AUGUST 88 PA
7407  z=cde*zo
7408  ELSE
7409  xi=sde*cfe
7410  yi=sde*sfe
7411  zi=cde
7412  a=sqrt(a)
7413  x=-yo*xi/a-zo*xo*yi/a+xo*zi
7414  y=xo*xi/a-zo*yo*yi/a+yo*zi
7415  z=a*yi+zo*zi
7416  END IF
7417  RETURN
7418  END
7419 *-- Author :
7420 C
7421 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7422 C
7423  SUBROUTINE lortmo(N,GAM,BGX,BGY,BGZ)
7424  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7425  SAVE
7426 C
7427 C*** LORENTZ TRANSFORMATION OF THE N PARTICLES IN FINPAR
7428 C
7429 *KEEP,DFINPA.
7430  CHARACTER*8 anf
7431  parameter(nfimax=249)
7432  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
7433  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
7434  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
7435  * istath(nfimax)
7436 *KEND.
7437 C-------------------
7438  parameter(tiny=1.d-10)
7439  DATA ifirst/0/
7440  DATA num/0/
7441 C
7442  ifirst=ifirst+1
7443  num=num+1
7444  pxsm=0.0
7445  pysm=0.0
7446  pzsm=0.0
7447  esum=0.
7448  pxsc=0.0
7449  pysc=0.0
7450  pzsc=0.0
7451  esmc=0.0
7452 C END OF CHANGE
7453  DO 10 i=1,n
7454  pxi=pxf(i)
7455  pyi=pyf(i)
7456  pzi=pzf(i)
7457  eei=hef(i)
7458  pxsm=pxsm + pxi
7459  pysm=pysm + pyi
7460  pzsm=pzsm + pzi
7461  esum=esum + eei
7462  CALL daltra(gam,bgx,bgy,bgz,pxi,pyi,pzi,eei, ppa,pxf(i),pyf(i),
7463  + pzf(i),hef(i))
7464  pxsc=pxsc + pxf(i)
7465  pysc=pysc + pyf(i)
7466  pzsc=pzsc + pzf(i)
7467  esmc=esmc + hef(i)
7468  10 CONTINUE
7469 C
7470 C PXSM,ETC,ARE SUMS FOR BAMJET FRAGMENTS IN JET CMS
7471  CALL daltra(gam,bgx,bgy,bgz,pxsm,pysm,pzsm,esum, ppa,pxsm,pysm,
7472  +pzsm,esum)
7473 C
7474 C PXSC,ETC,ARE SUMS FOR BAMJET FRAGMENTS IN PROJ,TARGET CMS
7475 
7476  pxdif=pxsm-pxsc
7477  pydif=pysm-pysc
7478  pzdif=pzsm-pzsc
7479  edif=esum-esmc
7480  diffl=pxdif+pydif+pzdif+edif
7481  IF(esum.LT.tiny)esum=tiny
7482  diffl=diffl/esum
7483  IF(diffl.GE.1.d-4)WRITE(6,1000)num,pxdif,pydif,pzdif,edif,pxsm,
7484  +pxsc, pysm,pysc,pzsm,pzsc,esum,esmc
7485  1000 FORMAT(' ',2x,'LORTRA:NUM=',i5,2x,'PXDIF=',1pe15.6,2x,'PYDIF=', 1
7486  +pe15.6,2x,'PZDIF=',1pe15.6,2x,'EDIF=',1pe15.6/2x,'PXSM=',1pe15.6,2
7487  +x,'PXSC=',1pe15.6,2x,'PYSM=',1pe15.6,2x,'PYSC=',1pe15.6/2x,'PZSM',
7488  +1pe15.6,2x,'PZSC=',1pe15.6,2x,'ESUM=',1pe15.6,2x,'ESMC=',1pe15.6/2
7489  +x,'LORTRA DIFFERENCES DUE TO ALTRA'/)
7490  RETURN
7491  END
7492 *-- Author :
7493 C-------------------------------------------------------------------
7494 C
7495 C FILE DMNUC3.FOR
7496 C
7497 C-------------------------------------------------------------------
7498 C
7499  SUBROUTINE evtest(IREJ)
7500  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7501  SAVE
7502 C
7503 C TEST OF ENERGY MOMENTUM CONSERVATION ON NIVEAU OF CHAINS
7504 C AND ON NIVEAU OF CHAIN ENDS
7505 C
7506 *KEEP,HKKEVT.
7507 c INCLUDE (HKKEVT)
7508  parameter(nmxhkk= 89998)
7509 c PARAMETER (NMXHKK=25000)
7510  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
7511  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
7512  +(4,nmxhkk)
7513  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
7514  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
7515 C
7516 *KEEP,NUCIMP.
7517  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
7518  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
7519  +prebin,taebin,fermod,etacou
7520 *KEEP,DPAR.
7521 C /DPAR/ CONTAINS PARTICLE PROPERTIES
7522 C ANAME = LITERAL NAME OF THE PARTICLE
7523 C AAM = PARTICLE MASS IN GEV
7524 C GA = DECAY WIDTH
7525 C TAU = LIFE TIME OF INSTABLE PARTICLES
7526 C IICH = ELECTRIC CHARGE OF THE PARTICLE
7527 C IIBAR = BARYON NUMBER
7528 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
7529 C
7530  CHARACTER*8 aname
7531  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
7532  +iibar(210),k1(210),k2(210)
7533 *KEEP,INTMX.
7534  parameter(intmx=2488,intmd=252)
7535 *KEEP,DXQX.
7536 C INCLUDE (XQXQ)
7537 * NOTE: INTMX set via INCLUDE(INTMX)
7538  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
7539  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
7540  * ,xpsu(248),xtsu(248)
7541  * ,xpsut(248),xtsut(248)
7542  COMMON /intnez/ ndz,nzd
7543 *KEEP,INTNEW.
7544  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
7545  +ixpv,ixps,ixtv,ixts, intvv1(248),
7546  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
7547  +intss1(intmx),intss2(intmx),
7548  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
7549  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
7550 
7551 C /INTNEW/
7552 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
7553 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
7554 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
7555 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
7556 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
7557 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
7558 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
7559 C FROM PROJECTILE/TARGET NUCLEI
7560 C-------------------
7561 *KEEP,IFROTO.
7562  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
7563  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
7564  +jhkknt
7565  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
7566  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
7567  & mhkkhh(intmx),
7568  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
7569 *KEEP,LOZUO.
7570  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
7571  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
7572  +intlo(intmx),inloss(intmx)
7573 C /LOZUO/
7574 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
7575 C REJECTED IN KKEVT
7576 C------------------
7577 *KEEP,DIQI.
7578  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
7579  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
7580  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
7581  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
7582 *KEEP,ABRSS.
7583 C INCLUDE (ABRSS)
7584  COMMON /abrss/ amcss1(intmx),amcss2(intmx), gacss1(intmx),gacss2
7585  +(intmx), bgxss1(intmx),bgyss1(intmx),bgzss1(intmx), bgxss2(intmx),
7586  +bgyss2(intmx),bgzss2(intmx), nchss1(intmx),nchss2(intmx), ijcss1
7587  +(intmx),ijcss2(intmx), pqssa1(intmx,4),pqssa2(intmx,4), pqssb1
7588  +(intmx,4),pqssb2(intmx,4)
7589 *KEEP,NNCMS.
7590  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
7591 *KEEP,ABRSV.
7592  COMMON /abrsv/ amcsv1(248),amcsv2(248),gacsv1(248),gacsv2(248),
7593  +bgxsv1(248),bgysv1(248),bgzsv1(248), bgxsv2(248),bgysv2(248),
7594  +bgzsv2(248), nchsv1(248),nchsv2(248),ijcsv1(248),ijcsv2(248),
7595  +pqsva1(248,4),pqsva2(248,4), pqsvb1(248,4),pqsvb2(248,4)
7596 *KEEP,ABRVS.
7597  COMMON /abrvs/ amcvs1(248),amcvs2(248),gacvs1(248),gacvs2(248),
7598  +bgxvs1(248),bgyvs1(248),bgzvs1(248), bgxvs2(248),bgyvs2(248),
7599  +bgzvs2(248), nchvs1(248),nchvs2(248),ijcvs1(248),ijcvs2(248),
7600  +pqvsa1(248,4),pqvsa2(248,4), pqvsb1(248,4),pqvsb2(248,4)
7601 *KEEP,ABRVV.
7602  COMMON /abrvv/ amcvv1(248),amcvv2(248),gacvv1(248),gacvv2(248),
7603  +bgxvv1(248),bgyvv1(248),bgzvv1(248), bgxvv2(248),bgyvv2(248),
7604  +bgzvv2(248), nchvv1(248),nchvv2(248),ijcvv1(248),ijcvv2(248),
7605  +pqvva1(248,4),pqvva2(248,4), pqvvb1(248,4),pqvvb2(248,4)
7606 *KEEP,ABRDV.
7607  COMMON /abrdv/ amcdv1(248),amcdv2(248),gacdv1(248),gacdv2(248),
7608  +bgxdv1(248),bgydv1(248),bgzdv1(248), bgxdv2(248),bgydv2(248),
7609  +bgzdv2(248), nchdv1(248),nchdv2(248),ijcdv1(248),ijcdv2(248),
7610  +pqdva1(248,4),pqdva2(248,4), pqdvb1(248,4),pqdvb2(248,4)
7611 C-------------------
7612 *KEEP,ABRVD.
7613  COMMON /abrvd/ amcvd1(248),amcvd2(248),gacvd1(248),gacvd2(248),
7614  +bgxvd1(248),bgyvd1(248),bgzvd1(248), bgxvd2(248),bgyvd2(248),
7615  +bgzvd2(248), nchvd1(248),nchvd2(248),ijcvd1(248),ijcvd2(248),
7616  +pqvda1(248,4),pqvda2(248,4), pqvdb1(248,4),pqvdb2(248,4)
7617 *KEEP,ABRDS.
7618  COMMON /abrds/ amcds1(248),amcds2(248),gacds1(248),gacds2(248),
7619  +bgxds1(248),bgyds1(248),bgzds1(248), bgxds2(248),bgyds2(248),
7620  +bgzds2(248), nchds1(248),nchds2(248),ijcds1(248),ijcds2(248),
7621  +pqdsa1(248,4),pqdsa2(248,4), pqdsb1(248,4),pqdsb2(248,4)
7622 C-------------------
7623 *KEEP,ABRDS.
7624  COMMON /abrdz/ amcdz1(intmd),amcdz2(intmd),
7625  +gacdz1(intmd),gacdz2(intmd),
7626  +bgxdz1(intmd),bgydz1(intmd),bgzdz1(intmd),
7627  +bgxdz2(intmd),bgydz2(intmd),
7628  +bgzdz2(intmd), nchdz1(intmd),nchdz2(intmd),
7629  +ijcdz1(intmd),ijcdz2(intmd),
7630  +pqdza1(intmd,4),pqdza2(intmd,4),
7631  +pqdzb1(intmd,4),pqdzb2(intmd,4),
7632  +ipzq(intmd),ipzqq2(intmd),itzq(intmd),
7633  +ipzaq(intmd),izaqq2(intmd),itzaq(intmd)
7634  +,idzzz(intmd)
7635 C-------------------
7636 *KEEP,ABRSD.
7637  COMMON /abrsd/ amcsd1(248),amcsd2(248),gacsd1(248),gacsd2(248),
7638  +bgxsd1(248),bgysd1(248),bgzsd1(248), bgxsd2(248),bgysd2(248),
7639  +bgzsd2(248), nchsd1(248),nchsd2(248),ijcsd1(248),ijcsd2(248),
7640  +pqsda1(248,4),pqsda2(248,4), pqsdb1(248,4),pqsdb2(248,4)
7641 C-------------------
7642 *KEEP,ABRSD.
7643  COMMON /abrzd/ amczd1(intmd),amczd2(intmd),
7644  +gaczd1(intmd),gaczd2(intmd),
7645  +bgxzd1(intmd),bgyzd1(intmd),bgzzd1(intmd),
7646  +bgxzd2(intmd),bgyzd2(intmd),
7647  +bgzzd2(intmd), nchzd1(intmd),nchzd2(intmd),
7648  +ijczd1(intmd),ijczd2(intmd),
7649  +pqzda1(intmd,4),pqzda2(intmd,4),
7650  +pqzdb1(intmd,4),pqzdb2(intmd,4),
7651  +ipyq(intmd),ityq(intmd),ityq2(intmd),
7652  +ipyaq(intmd),ityaq(intmd),ityaq2(intmd)
7653  +,izdyy(intmd)
7654 C-------------------
7655 *KEEP,DROPPT.
7656  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
7657  +ishmal,lpauli
7658  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
7659  +ipadis,ishmal,lpauli
7660 *KEEP,DPRIN.
7661  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7662 *KEND.
7663  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
7664  COMMON /abrzz/ amczz1(intmx),amczz2(intmx),
7665  * gaczz1(intmx),gaczz2(intmx),
7666  * bgxzz1(intmx),bgyzz1(intmx),bgzzz1(intmx),
7667  * bgxzz2(intmx),bgyzz2(intmx),bgzzz2(intmx),
7668  * nchzz1(intmx),nchzz2(intmx),
7669  * ijczz1(intmx),ijczz2(intmx),
7670  * pqzza1(intmx,4),pqzza2(intmx,4),
7671  * pqzzb1(intmx,4),pqzzb2(intmx,4)
7672  COMMON /abrhh/ amchh1(intmx),amchh2(intmx),
7673  * gachh1(intmx),gachh2(intmx),
7674  * bgxhh1(intmx),bgyhh1(intmx),bgzhh1(intmx),
7675  * bgxhh2(intmx),bgyhh2(intmx),bgzhh2(intmx),
7676  * nchhh1(intmx),nchhh2(intmx),
7677  * ijchh1(intmx),ijchh2(intmx),
7678  * pqhha1(intmx,4),pqhha2(intmx,4),
7679  * pqhhb1(intmx,4),pqhhb2(intmx,4)
7680  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
7681  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
7682  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
7683  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
7684  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
7685  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
7686  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
7687  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
7688  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
7689  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
7690  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
7691  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
7692  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
7693  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
7694  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
7695  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
7696  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
7697  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
7698 C------------------------
7699 C WRITE(6,1298)NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,NOCC,NONUST,
7700 C * NONUJT
7701 C1298 FORMAT(' NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,NOCC,NONUST,NONUJT'
7702 C */11I8)
7703  irej=0
7704  pxbal=0.
7705  pybal=0.
7706  pzbal=0.
7707  pebal=0.
7708  pxss=0.
7709  pyss=0.
7710  pzss=0.
7711  pess=0.
7712  pxsv=0.
7713  pysv=0.
7714  pzsv=0.
7715  pesv=0.
7716  pxvs=0.
7717  pyvs=0.
7718  pzvs=0.
7719  pevs=0.
7720  pxvv=0.
7721  pyvv=0.
7722  pzvv=0.
7723  pevv=0.
7724  pxds=0.
7725  pyds=0.
7726  pzds=0.
7727  peds=0.
7728  pxsd=0.
7729  pysd=0.
7730  pzsd=0.
7731  pesd=0.
7732  pxdz=0.
7733  pydz=0.
7734  pzdz=0.
7735  pedz=0.
7736  pxzd=0.
7737  pyzd=0.
7738  pzzd=0.
7739  pezd=0.
7740  pxdv=0.
7741  pydv=0.
7742  pzdv=0.
7743  pedv=0.
7744  pxvd=0.
7745  pyvd=0.
7746  pzvd=0.
7747  pevd=0.
7748  pxcc=0.
7749  pycc=0.
7750  pzcc=0.
7751  pecc=0.
7752  pxzz=0.
7753  pyzz=0.
7754  pzzz=0.
7755  pezz=0.
7756  pxhh=0.
7757  pyhh=0.
7758  pzhh=0.
7759  pehh=0.
7760 C IF(IP.EQ.1)GAMCM=GAMCM+(NSV+NDV)*AAM(IJPROJ)/UMO
7761 C
7762 C IF(IHADA.OR.IHADSS) THEN
7763  DO 10 n=1,nss
7764  IF (inloss(n))THEN
7765  IF(abs(nchss1(n)).NE.99) THEN
7766  pxss=pxss + pqssa1(n,1) + pqssa2(n,1)
7767  pyss=pyss + pqssa1(n,2) + pqssa2(n,2)
7768  pzss=pzss + pqssa1(n,3) + pqssa2(n,3)
7769  pess=pess + pqssa1(n,4) + pqssa2(n,4)
7770  ENDIF
7771  IF(abs(nchss2(n)).NE.99) THEN
7772  pxss=pxss + pqssb1(n,1) + pqssb2(n,1)
7773  pyss=pyss + pqssb1(n,2) + pqssb2(n,2)
7774  pzss=pzss + pqssb1(n,3) + pqssb2(n,3)
7775  pess=pess + pqssb1(n,4) + pqssb2(n,4)
7776  ENDIF
7777  ENDIF
7778  10 CONTINUE
7779  pzbss=gamcm*pzss + bgcm*pess
7780  pebss=gamcm*pess + bgcm*pzss
7781  pxbal=pxss
7782  pybal=pyss
7783  pzbal=pzbss
7784  pebal=pebss
7785 C ENDIF
7786 C IF(IHADA.OR.IHADSV) THEN
7787  DO 20 n=1,nsv
7788  IF(abs(nchsv1(n)).NE.99) THEN
7789  pxsv=pxsv +pqsva1(n,1)+pqsva2(n,1)
7790  pysv=pysv +pqsva1(n,2)+pqsva2(n,2)
7791  pzsv=pzsv +pqsva1(n,3)+pqsva2(n,3)
7792  pesv=pesv +pqsva1(n,4)+pqsva2(n,4)
7793  IF (ipev.GE.1)THEN
7794  WRITE(6,2001)
7795  + pxsv,pysv,pzsv,pesv
7796  ENDIF
7797  2001 FORMAT (
7798  +' SV ',4e15.5)
7799 C
7800  ENDIF
7801  IF(abs(nchsv2(n)).NE.99) THEN
7802  pxsv=pxsv + pqsvb1(n,1)+pqsvb2(n,1)
7803  pysv=pysv + pqsvb1(n,2)+pqsvb2(n,2)
7804  pzsv=pzsv + pqsvb1(n,3)+pqsvb2(n,3)
7805  pesv=pesv + pqsvb1(n,4)+pqsvb2(n,4)
7806  IF (ipev.GE.1)THEN
7807  WRITE(6,2001)
7808  + pxsv,pysv,pzsv,pesv
7809  ENDIF
7810  ENDIF
7811  20 CONTINUE
7812  pzbsv=gamcm*pzsv + bgcm*pesv
7813  pebsv=gamcm*pesv + bgcm*pzsv
7814  IF (ipev.GE.1)THEN
7815  WRITE(6,2001)
7816  + pxsv,pysv,pzbsv,pebsv
7817  ENDIF
7818  pxbal=pxbal + pxsv
7819  pybal=pybal + pysv
7820  pzbal=pzbal + pzbsv
7821  pebal=pebal + pebsv
7822 C ENDIF
7823 C IF(IHADA.OR.IHADVS) THEN
7824  DO 30 n=1,nvs
7825  IF(abs(nchvs1(n)).NE.99) THEN
7826  pxvs=pxvs + pqvsa1(n,1) + pqvsa2(n,1)
7827  pyvs=pyvs + pqvsa1(n,2) + pqvsa2(n,2)
7828  pzvs=pzvs + pqvsa1(n,3) + pqvsa2(n,3)
7829  pevs=pevs + pqvsa1(n,4) + pqvsa2(n,4)
7830  ENDIF
7831  IF(abs(nchvs2(n)).NE.99) THEN
7832  pxvs=pxvs + pqvsb1(n,1) + pqvsb2(n,1)
7833  pyvs=pyvs + pqvsb1(n,2) + pqvsb2(n,2)
7834  pzvs=pzvs + pqvsb1(n,3) + pqvsb2(n,3)
7835  pevs=pevs + pqvsb1(n,4) + pqvsb2(n,4)
7836  ENDIF
7837  30 CONTINUE
7838  pzbvs=gamcm*pzvs + bgcm*pevs
7839  pebvs=gamcm*pevs + bgcm*pzvs
7840  pxbal=pxbal + pxvs
7841  pybal=pybal + pyvs
7842  pzbal=pzbal + pzbvs
7843  pebal=pebal + pebvs
7844  DO 31 n=1,nds
7845  IF(abs(nchds1(n)).NE.99) THEN
7846  pxds=pxds + pqdsa1(n,1) + pqdsa2(n,1)
7847  pyds=pyds + pqdsa1(n,2) + pqdsa2(n,2)
7848  pzds=pzds + pqdsa1(n,3) + pqdsa2(n,3)
7849  peds=peds + pqdsa1(n,4) + pqdsa2(n,4)
7850  ENDIF
7851  IF(abs(nchds2(n)).NE.99) THEN
7852  pxds=pxds + pqdsb1(n,1) + pqdsb2(n,1)
7853  pyds=pyds + pqdsb1(n,2) + pqdsb2(n,2)
7854  pzds=pzds + pqdsb1(n,3) + pqdsb2(n,3)
7855  peds=peds + pqdsb1(n,4) + pqdsb2(n,4)
7856  ENDIF
7857  31 CONTINUE
7858  pzbds=gamcm*pzds + bgcm*peds
7859  pebds=gamcm*peds + bgcm*pzds
7860  pxbal=pxbal + pxds
7861  pybal=pybal + pyds
7862  pzbal=pzbal + pzbds
7863  pebal=pebal + pebds
7864  DO 371 n=1,ndz
7865  IF(abs(nchdz1(n)).NE.99) THEN
7866  pxdz=pxdz + pqdza1(n,1) + pqdza2(n,1)
7867  pydz=pydz + pqdza1(n,2) + pqdza2(n,2)
7868  pzdz=pzdz + pqdza1(n,3) + pqdza2(n,3)
7869  pedz=pedz + pqdza1(n,4) + pqdza2(n,4)
7870  ENDIF
7871  IF(abs(nchdz2(n)).NE.99) THEN
7872  pxdz=pxdz + pqdzb1(n,1) + pqdzb2(n,1)
7873  pydz=pydz + pqdzb1(n,2) + pqdzb2(n,2)
7874  pzdz=pzdz + pqdzb1(n,3) + pqdzb2(n,3)
7875  pedz=pedz + pqdzb1(n,4) + pqdzb2(n,4)
7876  ENDIF
7877  371 CONTINUE
7878  pzbdz=gamcm*pzdz + bgcm*pedz
7879  pebdz=gamcm*pedz + bgcm*pzdz
7880  pxbal=pxbal + pxdz
7881  pybal=pybal + pydz
7882  pzbal=pzbal + pzbdz
7883  pebal=pebal + pebdz
7884  DO 32 n=1,nsd
7885  IF(abs(nchsd1(n)).NE.99) THEN
7886  pxsd=pxsd + pqsda1(n,1) + pqsda2(n,1)
7887  pysd=pysd + pqsda1(n,2) + pqsda2(n,2)
7888  pzsd=pzsd + pqsda1(n,3) + pqsda2(n,3)
7889  pesd=pesd + pqsda1(n,4) + pqsda2(n,4)
7890  ENDIF
7891  IF(abs(nchsd2(n)).NE.99) THEN
7892  pxsd=pxsd + pqsdb1(n,1) + pqsdb2(n,1)
7893  pysd=pysd + pqsdb1(n,2) + pqsdb2(n,2)
7894  pzsd=pzsd + pqsdb1(n,3) + pqsdb2(n,3)
7895  pesd=pesd + pqsdb1(n,4) + pqsdb2(n,4)
7896  ENDIF
7897  32 CONTINUE
7898  pzbsd=gamcm*pzsd + bgcm*pesd
7899  pebsd=gamcm*pesd + bgcm*pzsd
7900  pxbal=pxbal + pxsd
7901  pybal=pybal + pysd
7902  pzbal=pzbal + pzbsd
7903  pebal=pebal + pebsd
7904  DO 372 n=1,nzd
7905  IF(abs(nchzd1(n)).NE.99) THEN
7906  pxzd=pxzd + pqzda1(n,1) + pqzda2(n,1)
7907  pyzd=pyzd + pqzda1(n,2) + pqzda2(n,2)
7908  pzzd=pzzd + pqzda1(n,3) + pqzda2(n,3)
7909  pezd=pezd + pqzda1(n,4) + pqzda2(n,4)
7910  ENDIF
7911  IF(abs(nchzd2(n)).NE.99) THEN
7912  pxzd=pxzd + pqzdb1(n,1) + pqzdb2(n,1)
7913  pyzd=pyzd + pqzdb1(n,2) + pqzdb2(n,2)
7914  pzzd=pzzd + pqzdb1(n,3) + pqzdb2(n,3)
7915  pezd=pezd + pqzdb1(n,4) + pqzdb2(n,4)
7916  ENDIF
7917  372 CONTINUE
7918  pzbzd=gamcm*pzzd + bgcm*pezd
7919  pebzd=gamcm*pezd + bgcm*pzzd
7920  pxbal=pxbal + pxzd
7921  pybal=pybal + pyzd
7922  pzbal=pzbal + pzbzd
7923  pebal=pebal + pebzd
7924  DO 33 n=1,ndv
7925  IF(abs(nchdv1(n)).NE.99) THEN
7926  pxdv=pxdv + pqdva1(n,1) + pqdva2(n,1)
7927  pydv=pydv + pqdva1(n,2) + pqdva2(n,2)
7928  pzdv=pzdv + pqdva1(n,3) + pqdva2(n,3)
7929  pedv=pedv + pqdva1(n,4) + pqdva2(n,4)
7930  ENDIF
7931  IF(abs(nchdv2(n)).NE.99) THEN
7932  pxdv=pxdv + pqdvb1(n,1) + pqdvb2(n,1)
7933  pydv=pydv + pqdvb1(n,2) + pqdvb2(n,2)
7934  pzdv=pzdv + pqdvb1(n,3) + pqdvb2(n,3)
7935  pedv=pedv + pqdvb1(n,4) + pqdvb2(n,4)
7936  ENDIF
7937  33 CONTINUE
7938  pzbdv=gamcm*pzdv + bgcm*pedv
7939  pebdv=gamcm*pedv + bgcm*pzdv
7940  pxbal=pxbal + pxdv
7941  pybal=pybal + pydv
7942  pzbal=pzbal + pzbdv
7943  pebal=pebal + pebdv
7944  DO 34 n=1,nvd
7945  IF(abs(nchvd1(n)).NE.99) THEN
7946  pxvd=pxvd + pqvda1(n,1) + pqvda2(n,1)
7947  pyvd=pyvd + pqvda1(n,2) + pqvda2(n,2)
7948  pzvd=pzvd + pqvda1(n,3) + pqvda2(n,3)
7949  pevd=pevd + pqvda1(n,4) + pqvda2(n,4)
7950  ENDIF
7951  IF(abs(nchvd2(n)).NE.99) THEN
7952  pxvd=pxvd + pqvdb1(n,1) + pqvdb2(n,1)
7953  pyvd=pyvd + pqvdb1(n,2) + pqvdb2(n,2)
7954  pzvd=pzvd + pqvdb1(n,3) + pqvdb2(n,3)
7955  pevd=pevd + pqvdb1(n,4) + pqvdb2(n,4)
7956  ENDIF
7957  34 CONTINUE
7958  pzbvd=gamcm*pzvd + bgcm*pevd
7959  pebvd=gamcm*pevd + bgcm*pzvd
7960  pxbal=pxbal + pxvd
7961  pybal=pybal + pyvd
7962  pzbal=pzbal + pzbvd
7963  pebal=pebal + pebvd
7964 C ENDIF
7965 C IF(IHADA.OR.IHADVV) THEN
7966  DO 40 n=1,nvv
7967  IF((nchvv1(n).NE.99).AND.(nchvv2(n).NE.99)) THEN
7968  pxvv=pxvv+pqvva1(n,1)+pqvva2(n,1)+pqvvb1(n,1)+pqvvb2(n,1)
7969  pyvv=pyvv+pqvva1(n,2)+pqvva2(n,2)+pqvvb1(n,2)+pqvvb2(n,2)
7970  pzvv=pzvv+pqvva1(n,3)+pqvva2(n,3)+pqvvb1(n,3)+pqvvb2(n,3)
7971  pevv=pevv+pqvva1(n,4)+pqvva2(n,4)+pqvvb1(n,4)+pqvvb2(n,4)
7972  ENDIF
7973  40 CONTINUE
7974  pzbvv=gamcm*pzvv + bgcm*pevv
7975  pebvv=gamcm*pevv + bgcm*pzvv
7976  pxbal=pxbal + pxvv
7977  pybal=pybal + pyvv
7978  pzbal=pzbal + pzbvv
7979  pebal=pebal + pebvv
7980 C ENDIF
7981 C IF(IHADA.OR.IHADSS) THEN
7982 C WRITE(6,*)' evtest nocc ',NOCC
7983 C DO 120 N=1,NOCC
7984 C PXCC=PXCC + POJCC(1,N) + PATCC(1,N)
7985 C PYCC=PYCC + POJCC(2,N) + PATCC(2,N)
7986 C PZCC=PZCC + POJCC(3,N) + PATCC(3,N)
7987 C PECC=PECC + POJCC(4,N) + PATCC(4,N)
7988 C120 CONTINUE
7989 C PZBCC=GAMCM*PZCC + BGCM*PECC
7990 C PEBCC=GAMCM*PECC + BGCM*PZCC
7991 C PXBAL=PXBAL + PXCC
7992 C PYBAL=PYBAL + PYCC
7993 C PZBAL=PZBAL + PZBCC
7994 C PEBAL=PEBAL + PEBCC
7995 C ENDIF
7996 C WRITE(6,*)' evtest nonust ',NONUST
7997  DO 210 n=1,nonust
7998  IF(abs(nchzz1(n)).NE.99.AND.jhkksx(n).EQ.1) THEN
7999  IF(abs(nchzz1(n)).NE.88) THEN
8000  pxzz=pxzz + pqzza1(n,1) + pqzza2(n,1)
8001  pyzz=pyzz + pqzza1(n,2) + pqzza2(n,2)
8002  pzzz=pzzz + pqzza1(n,3) + pqzza2(n,3)
8003  pezz=pezz + pqzza1(n,4) + pqzza2(n,4)
8004  ENDIF
8005  ENDIF
8006  IF(abs(nchzz2(n)).NE.99.AND.jhkksx(n).EQ.1) THEN
8007  IF(abs(nchzz2(n)).NE.88) THEN
8008  pxzz=pxzz + pqzzb1(n,1) + pqzzb2(n,1)
8009  pyzz=pyzz + pqzzb1(n,2) + pqzzb2(n,2)
8010  pzzz=pzzz + pqzzb1(n,3) + pqzzb2(n,3)
8011  pezz=pezz + pqzzb1(n,4) + pqzzb2(n,4)
8012  ENDIF
8013  ENDIF
8014  210 CONTINUE
8015  pzbzz=gamcm*pzzz + bgcm*pezz
8016  pebzz=gamcm*pezz + bgcm*pzzz
8017  pxbal=pxbal + pxzz
8018  pybal=pybal + pyzz
8019  pzbal=pzbal + pzbzz
8020  pebal=pebal + pebzz
8021 C WRITE(6,*)' evtest nonujt ',NONUJT
8022  DO 220 n=1,nonujt
8023  IF(abs(nchhh1(n)).NE.99.AND.jhkkex(n).EQ.1) THEN
8024  pxhh=pxhh + pqhha1(n,1) + pqhha2(n,1)
8025  pyhh=pyhh + pqhha1(n,2) + pqhha2(n,2)
8026  pzhh=pzhh + pqhha1(n,3) + pqhha2(n,3)
8027  pehh=pehh + pqhha1(n,4) + pqhha2(n,4)
8028  ENDIF
8029  IF(abs(nchhh2(n)).NE.99.AND.jhkkex(n).EQ.1) THEN
8030  pxhh=pxhh + pqhhb1(n,1) + pqhhb2(n,1)
8031  pyhh=pyhh + pqhhb1(n,2) + pqhhb2(n,2)
8032  pzhh=pzhh + pqhhb1(n,3) + pqhhb2(n,3)
8033  pehh=pehh + pqhhb1(n,4) + pqhhb2(n,4)
8034  ENDIF
8035  220 CONTINUE
8036  pzbhh=gamcm*pzhh + bgcm*pehh
8037  pebhh=gamcm*pehh + bgcm*pzhh
8038  pxbal=pxbal + pxhh
8039  pybal=pybal + pyhh
8040  pzbal=pzbal + pzbhh
8041  pebal=pebal + pebhh
8042 C
8043  e0000=0.d0
8044  p0000=0.d0
8045 C WRITE(6,*)' evtest ip ',IP
8046  DO 7767 i=1,ip
8047  IF(isthkk(i).EQ.11)e0000=e0000+prmom(4,i)
8048  IF(isthkk(i).EQ.11)p0000=p0000+prmom(3,i)
8049  7767 CONTINUE
8050 C WRITE(6,*)' evtest it ',IT
8051  DO 7768 ii=1,it
8052  i=ii+ip
8053  IF(isthkk(i).EQ.12)e0000=e0000+tamom(4,ii)
8054  IF(isthkk(i).EQ.12)p0000=p0000+tamom(3,ii)
8055  7768 CONTINUE
8056  p000=gamcm*p0000+bgcm*e0000
8057  e000=gamcm*e0000+bgcm*p0000
8058  iprojo=(pzbal*1.001)/pproj
8059  residu=abs(e000-pebal)/(e000)
8060  IF (ipev.GE.1)THEN
8061  WRITE(6,'(A,2E15.5)')' E000,PEBAL', e000,pebal
8062  WRITE(6,1000)pxbal,pybal,pzbal,pebal, pxss,pyss,pzbss,pebss,
8063  + pxsv,pysv,pzbsv,pebsv, pxvs,pyvs,pzbvs,pebvs, pxvv,pyvv,pzbvv,
8064  + pebvv,pxcc,pycc,pzbcc,pebcc,
8065  + pxzz,pyzz,pzbzz,pebzz,
8066  + pxhh,pyhh,pzbhh,pebhh,
8067  + pxds,pyds,pzbds,pebds,
8068  + pxsd,pysd,pzbsd,pebsd,
8069  + pxdz,pydz,pzbdz,pebdz,
8070  + pxzd,pyzd,pzbzd,pebzd,
8071  + pxdv,pydv,pzbdv,pebdv,
8072  + pxvd,pyvd,pzbvd,pebvd
8073  ENDIF
8074  IF (residu.GT.0.02d0)THEN
8075  irej=1
8076  ENDIF
8077  IF (residu.GT.0.02d0.AND.iphkk.GE.2)THEN
8078  irej=1
8079  WRITE(6,'(A,2E15.5)')' E000,PEBAL', e000,pebal
8080  WRITE(6,1000)pxbal,pybal,pzbal,pebal, pxss,pyss,pzbss,pebss,
8081  + pxsv,pysv,pzbsv,pebsv, pxvs,pyvs,pzbvs,pebvs, pxvv,pyvv,pzbvv,
8082  + pebvv,pxcc,pycc,pzbcc,pebcc,
8083  + pxzz,pyzz,pzbzz,pebzz,
8084  + pxhh,pyhh,pzbhh,pebhh,
8085  + pxds,pyds,pzbds,pebds,
8086  + pxsd,pysd,pzbsd,pebsd,
8087  + pxdz,pydz,pzbdz,pebdz,
8088  + pxzd,pyzd,pzbzd,pebzd,
8089  + pxdv,pydv,pzbdv,pebdv,
8090  + pxvd,pyvd,pzbvd,pebvd
8091  ENDIF
8092  1000 FORMAT (' 4 MOMENTUM CONS.IN EVENT LEVEL OF PARTONS',/ ' ALL',4e15
8093  +.5/,' SS ',4e15.5/,' SV ',4e15.5/ ' VS ',4e15.5/,' VV ',4e15.5/,
8094  + ' CC ',4e15.5/
8095  + ' ZZ ',4e15.5/
8096  + ' HH ',4e15.5/
8097  + ' DS ',4e15.5/
8098  + ' SD ',4e15.5/
8099  + ' DZ ',4e15.5/
8100  + ' ZD ',4e15.5/
8101  + ' DV ',4e15.5/
8102  + ' VD ',4e15.5)
8103 C
8104  pxbal=0.
8105  pybal=0.
8106  pzbal=0.
8107  pebal=0.
8108  pxss=0.
8109  pyss=0.
8110  pzss=0.
8111  pess=0.
8112  pxsv=0.
8113  pysv=0.
8114  pzsv=0.
8115  pesv=0.
8116  pxvs=0.
8117  pyvs=0.
8118  pzvs=0.
8119  pevs=0.
8120  pxvv=0.
8121  pyvv=0.
8122  pzvv=0.
8123  pevv=0.
8124  pxcc=0.
8125  pycc=0.
8126  pzcc=0.
8127  pecc=0.
8128  pxds=0.
8129  pyds=0.
8130  pzds=0.
8131  peds=0.
8132  pxsd=0.
8133  pysd=0.
8134  pzsd=0.
8135  pesd=0.
8136  pxdv=0.
8137  pydv=0.
8138  pzdv=0.
8139  pedv=0.
8140  pxvd=0.
8141  pyvd=0.
8142  pzvd=0.
8143  pevd=0.
8144  pxzz=0.
8145  pyzz=0.
8146  pzzz=0.
8147  pezz=0.
8148  pxhh=0.
8149  pyhh=0.
8150  pzhh=0.
8151  pehh=0.
8152 C
8153 C IF(IHADA.OR.IHADSS) THEN
8154  DO 50 n=1,nss
8155  IF (inloss(n))THEN
8156  IF(abs(nchss1(n)).NE.99) THEN
8157  pxss=pxss+bgxss1(n)*amcss1(n)
8158  pyss=pyss+bgyss1(n)*amcss1(n)
8159  pzss=pzss+bgzss1(n)*amcss1(n)
8160  pess=pess+gacss1(n)*amcss1(n)
8161  ENDIF
8162  IF(abs(nchss2(n)).NE.99) THEN
8163  pxss=pxss+bgxss2(n)*amcss2(n)
8164  pyss=pyss+bgyss2(n)*amcss2(n)
8165  pzss=pzss+bgzss2(n)*amcss2(n)
8166  pess=pess+gacss2(n)*amcss2(n)
8167  ENDIF
8168  ENDIF
8169  50 CONTINUE
8170  pzbss=gamcm*pzss + bgcm*pess
8171  pebss=gamcm*pess + bgcm*pzss
8172 C DO 130 N=1,NOCC
8173 C PXCC=PXCC + BGXCC(N)*AMCC(N)
8174 C PYCC=PYCC + BGYCC(N)*AMCC(N)
8175 C PZCC=PZCC + BGZCC(N)*AMCC(N)
8176 C PECC=PECC + GACC(N)*AMCC(N)
8177 C130 CONTINUE
8178  pxbal=pxss
8179  pybal=pyss
8180  pzbal=pzbss
8181  pebal=pebss
8182 C PZBCC=GAMCM*PZCC + BGCM*PECC
8183 C PEBCC=GAMCM*PECC + BGCM*PZCC
8184 C PXBAL=PXBAL + PXCC
8185 C PYBAL=PYBAL + PYCC
8186 C PZBAL=PZBAL + PZBCC
8187 C PEBAL=PEBAL + PEBCC
8188 C ENDIF
8189 C IF(IHADA.OR.IHADSV) THEN
8190  DO 60 n=1,nsv
8191  IF(abs(nchsv1(n)).NE.99) THEN
8192  pxsv=pxsv+bgxsv1(n)*amcsv1(n)
8193  pysv=pysv+bgysv1(n)*amcsv1(n)
8194  pzsv=pzsv+bgzsv1(n)*amcsv1(n)
8195  pesv=pesv+gacsv1(n)*amcsv1(n)
8196  ENDIF
8197  IF(abs(nchsv2(n)).NE.99) THEN
8198  pxsv=pxsv+bgxsv2(n)*amcsv2(n)
8199  pysv=pysv+bgysv2(n)*amcsv2(n)
8200  pzsv=pzsv+bgzsv2(n)*amcsv2(n)
8201  pesv=pesv+gacsv2(n)*amcsv2(n)
8202  ENDIF
8203  60 CONTINUE
8204  pzbsv=gamcm*pzsv + bgcm*pesv
8205  pebsv=gamcm*pesv + bgcm*pzsv
8206  pxbal=pxbal + pxsv
8207  pybal=pybal + pysv
8208  pzbal=pzbal + pzbsv
8209  pebal=pebal + pebsv
8210  DO 61 n=1,nds
8211  IF(abs(nchds1(n)).NE.99) THEN
8212  pxds=pxds+bgxds1(n)*amcds1(n)
8213  pyds=pyds+bgyds1(n)*amcds1(n)
8214  pzds=pzds+bgzds1(n)*amcds1(n)
8215  peds=peds+gacds1(n)*amcds1(n)
8216  ENDIF
8217  IF(abs(nchds2(n)).NE.99) THEN
8218  pxds=pxds+bgxds2(n)*amcds2(n)
8219  pyds=pyds+bgyds2(n)*amcds2(n)
8220  pzds=pzds+bgzds2(n)*amcds2(n)
8221  peds=peds+gacds2(n)*amcds2(n)
8222  ENDIF
8223  61 CONTINUE
8224  pzbds=gamcm*pzds + bgcm*peds
8225  pebds=gamcm*peds + bgcm*pzds
8226  pxbal=pxbal + pxds
8227  pybal=pybal + pyds
8228  pzbal=pzbal + pzbds
8229  pebal=pebal + pebds
8230  DO 62 n=1,nsd
8231  IF(abs(nchsd1(n)).NE.99) THEN
8232  pxsd=pxsd+bgxsd1(n)*amcsd1(n)
8233  pysd=pysd+bgysd1(n)*amcsd1(n)
8234  pzsd=pzsd+bgzsd1(n)*amcsd1(n)
8235  pesd=pesd+gacsd1(n)*amcsd1(n)
8236  ENDIF
8237  IF(abs(nchsd2(n)).NE.99) THEN
8238  pxsd=pxsd+bgxsd2(n)*amcsd2(n)
8239  pysd=pysd+bgysd2(n)*amcsd2(n)
8240  pzsd=pzsd+bgzsd2(n)*amcsd2(n)
8241  pesd=pesd+gacsd2(n)*amcsd2(n)
8242  ENDIF
8243  62 CONTINUE
8244  pzbsd=gamcm*pzsd + bgcm*pesd
8245  pebsd=gamcm*pesd + bgcm*pzsd
8246  pxbal=pxbal + pxsd
8247  pybal=pybal + pysd
8248  pzbal=pzbal + pzbsd
8249  pebal=pebal + pebsd
8250  DO 63 n=1,ndv
8251  IF(abs(nchdv1(n)).NE.99) THEN
8252  pxdv=pxdv+bgxdv1(n)*amcdv1(n)
8253  pydv=pydv+bgydv1(n)*amcdv1(n)
8254  pzdv=pzdv+bgzdv1(n)*amcdv1(n)
8255  pedv=pedv+gacdv1(n)*amcdv1(n)
8256  ENDIF
8257  IF(abs(nchdv2(n)).NE.99) THEN
8258  pxdv=pxdv+bgxdv2(n)*amcdv2(n)
8259  pydv=pydv+bgydv2(n)*amcdv2(n)
8260  pzdv=pzdv+bgzdv2(n)*amcdv2(n)
8261  pedv=pedv+gacdv2(n)*amcdv2(n)
8262  ENDIF
8263  63 CONTINUE
8264  pzbdv=gamcm*pzdv + bgcm*pedv
8265  pebdv=gamcm*pedv + bgcm*pzdv
8266  pxbal=pxbal + pxdv
8267  pybal=pybal + pydv
8268  pzbal=pzbal + pzbdv
8269  pebal=pebal + pebdv
8270  DO 64 n=1,nvd
8271  IF(abs(nchvd1(n)).NE.99) THEN
8272  pxvd=pxvd+bgxvd1(n)*amcvd1(n)
8273  pyvd=pyvd+bgyvd1(n)*amcvd1(n)
8274  pzvd=pzvd+bgzvd1(n)*amcvd1(n)
8275  pevd=pevd+gacvd1(n)*amcvd1(n)
8276  ENDIF
8277  IF(abs(nchvd2(n)).NE.99) THEN
8278  pxvd=pxvd+bgxvd2(n)*amcvd2(n)
8279  pyvd=pyvd+bgyvd2(n)*amcvd2(n)
8280  pzvd=pzvd+bgzvd2(n)*amcvd2(n)
8281  pevd=pevd+gacvd2(n)*amcvd2(n)
8282  ENDIF
8283  64 CONTINUE
8284  pzbvd=gamcm*pzvd + bgcm*pevd
8285  pebvd=gamcm*pevd + bgcm*pzvd
8286  pxbal=pxbal + pxvd
8287  pybal=pybal + pyvd
8288  pzbal=pzbal + pzbvd
8289  pebal=pebal + pebvd
8290 C ENDIF
8291 C IF(IHADA.OR.IHADVS) THEN
8292  DO 70 n=1,nvs
8293  IF(abs(nchvs1(n)).NE.99) THEN
8294  pxvs=pxvs+bgxvs1(n)*amcvs1(n)
8295  pyvs=pyvs+bgyvs1(n)*amcvs1(n)
8296  pzvs=pzvs+bgzvs1(n)*amcvs1(n)
8297  pevs=pevs+gacvs1(n)*amcvs1(n)
8298  ENDIF
8299  IF(abs(nchvs2(n)).NE.99) THEN
8300  pxvs=pxvs+bgxvs2(n)*amcvs2(n)
8301  pyvs=pyvs+bgyvs2(n)*amcvs2(n)
8302  pzvs=pzvs+bgzvs2(n)*amcvs2(n)
8303  pevs=pevs+gacvs2(n)*amcvs2(n)
8304  ENDIF
8305  70 CONTINUE
8306  pzbvs=gamcm*pzvs + bgcm*pevs
8307  pebvs=gamcm*pevs + bgcm*pzvs
8308  pxbal=pxbal + pxvs
8309  pybal=pybal + pyvs
8310  pzbal=pzbal + pzbvs
8311  pebal=pebal + pebvs
8312 C ENDIF
8313  DO 250 n=1,nonust
8314  IF(abs(nchzz1(n)).NE.99.AND.jhkksx(n).EQ.1) THEN
8315  pxzz=pxzz+bgxzz1(n)*amczz1(n)
8316  pyzz=pyzz+bgyzz1(n)*amczz1(n)
8317  pzzz=pzzz+bgzzz1(n)*amczz1(n)
8318  pezz=pezz+gaczz1(n)*amczz1(n)
8319  ENDIF
8320  IF(abs(nchzz2(n)).NE.99.AND.jhkksx(n).EQ.1) THEN
8321  pxzz=pxzz+bgxzz2(n)*amczz2(n)
8322  pyzz=pyzz+bgyzz2(n)*amczz2(n)
8323  pzzz=pzzz+bgzzz2(n)*amczz2(n)
8324  pezz=pezz+gaczz2(n)*amczz2(n)
8325  ENDIF
8326  250 CONTINUE
8327  pzbzz=gamcm*pzzz + bgcm*pezz
8328  pebzz=gamcm*pezz + bgcm*pzzz
8329  pxbal=pxbal + pxzz
8330  pybal=pybal + pyzz
8331  pzbal=pzbal + pzbzz
8332  pebal=pebal + pebzz
8333  DO 260 n=1,nonujt
8334  IF(abs(nchhh1(n)).NE.99.AND.jhkkex(n).EQ.1) THEN
8335  pxhh=pxhh+bgxhh1(n)*amchh1(n)
8336  pyhh=pyhh+bgyhh1(n)*amchh1(n)
8337  pzhh=pzhh+bgzhh1(n)*amchh1(n)
8338  pehh=pehh+gachh1(n)*amchh1(n)
8339  ENDIF
8340  IF(abs(nchhh2(n)).NE.99.AND.jhkkex(n).EQ.1) THEN
8341  pxhh=pxhh+bgxhh2(n)*amchh2(n)
8342  pyhh=pyhh+bgyhh2(n)*amchh2(n)
8343  pzhh=pzhh+bgzhh2(n)*amchh2(n)
8344  pehh=pehh+gachh2(n)*amchh2(n)
8345  ENDIF
8346  260 CONTINUE
8347  pzbhh=gamcm*pzhh + bgcm*pehh
8348  pebhh=gamcm*pehh + bgcm*pzhh
8349  pxbal=pxbal + pxhh
8350  pybal=pybal + pyhh
8351  pzbal=pzbal + pzbhh
8352  pebal=pebal + pebhh
8353 C IF(IHADA.OR.IHADVV) THEN
8354  DO 80 n=1,nvv
8355  IF((nchvv1(n).NE.99).AND.(nchvv2(n).NE.99)) THEN
8356  pxvv=pxvv+bgxvv1(n)*amcvv1(n)+bgxvv2(n)*amcvv2(n)
8357  pyvv=pyvv+bgyvv1(n)*amcvv1(n)+bgyvv2(n)*amcvv2(n)
8358  pzvv=pzvv+bgzvv1(n)*amcvv1(n)+bgzvv2(n)*amcvv2(n)
8359  pevv=pevv+gacvv1(n)*amcvv1(n)+gacvv2(n)*amcvv2(n)
8360  ENDIF
8361  80 CONTINUE
8362  pzbvv=gamcm*pzvv + bgcm*pevv
8363  pebvv=gamcm*pevv + bgcm*pzvv
8364  pxbal=pxbal + pxvv
8365  pybal=pybal + pyvv
8366  pzbal=pzbal + pzbvv
8367  pebal=pebal + pebvv
8368 C ENDIF
8369 C
8370  IF (ipev.GE.1) WRITE(6,1010)pxbal,pybal,pzbal,
8371  +pebal, pxss,pyss,pzbss,pebss, pxsv,pysv,pzbsv,pebsv, pxvs,pyvs,
8372  +pzbvs,pebvs, pxvv,pyvv,pzbvv,pebvv, pxcc,pycc,pzbcc,pebcc,
8373  + pxds,pyds,pzbds,pebds,
8374  + pxzz,pyzz,pzbzz,pebzz,
8375  + pxhh,pyhh,pzbhh,pebhh,
8376  + pxsd,pysd,pzbsd,pebsd,
8377  + pxdv,pydv,pzbdv,pebdv,
8378  + pxvd,pyvd,pzbvd,pebvd
8379  1010 FORMAT (' 4 MOMENTUM CONS.IN EVENT LEVEL OF CHAINS',/ ' ALL',4e15.
8380  +5/,' SS ',4e15.5/,' SV ',4e15.5/ ' VS ',4e15.5/,' VV ',4e15.5/,
8381  + ' CC ',4e15.5/
8382  + ' DS ',4e15.5/
8383  + ' ZZ ',4e15.5/
8384  + ' HH ',4e15.5/
8385  + ' SD ',4e15.5/
8386  + ' DV ',4e15.5/
8387  + ' VD ',4e15.5)
8388 C
8389  RETURN
8390  END
8391 *-- Author :
8392 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8393  SUBROUTINE corval(AMMM,IREJ,AMCH1,AMCH2, QTX1,QTY1,QZ1,QE1,QTX2,
8394  +qty2,qz2,qe2,norig)
8395  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8396  SAVE
8397 C
8398 C KINEMATICAL CORRECTION OF TWO-VALENCE CHAIN SYSTEM
8399 C ACCORDING TO 2-PARTICLE KINEMATICS WITH FIXED MASSES
8400 C
8401 C**** WIR BRAUCHEN AUCH NOCH DIE NEUEN 4-IMPULSE DER KETTENENDEN
8402 C
8403 *KEEP,DPRIN.
8404  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8405 *KEND.
8406 C-----------------------------------------
8407  irej=0
8408  IF(ammm.LE.amch1+amch2+0.4d0) THEN
8409  irej=1
8410  RETURN
8411  ENDIF
8412 C
8413  ek1=(ammm**2-amch2**2 + amch1**2)/(2.*ammm)
8414  ek2=ammm - ek1
8415  pzk1=sqrt(ek1**2 - amch1**2)
8416  pzk1=sign(pzk1,qz1)
8417  pzk2=sqrt(ek2**2 - amch2**2)
8418  pzk2=sign(pzk2,qz2)
8419  pxk1=0.
8420  pyk1=0.
8421  pxk2=0.
8422  pyk2=0.
8423  qtx2=pxk2
8424  qty2=pyk2
8425  qz2=pzk2
8426  qe2=ek2
8427  qtx1=pxk1
8428  qty1=pyk1
8429  qz1=pzk1
8430  qe1=ek1
8431 C ROTATE NEW CHAIN MOMENTA
8432 C INTO DIRECTION OF CHAINS BEFORE CORRECTION
8433 C GAM=(QE1+QE2)/AMMM
8434 C BGX=(QTX1+QTX2)/AMMM
8435 C BGY=(QTY1+QTY2)/AMMM
8436 C BGZ=(QZ1+QZ2)/AMMM
8437 C
8438 C IF(ABS(GAM-1.D0).GT.1D-4) THEN
8439 C WRITE(6,'(A,I10,A/6(1PE15.5)/15X,5(1PE15.4))')
8440 C + ' CORVAL: INCONSISTENT KINEMATICS OF CHAINS NORIG= ',NORIG,
8441 C + ' AMMM,AMCH1,QE1,QTX1,QTY1, QZ1,AMCH2,QE2,QTX2,QTY2,QZ2',
8442 C + AMMM,
8443 C + AMCH1, QE1,
8444 C + QTX1, QTY1, QZ1, AMCH2,QE2, QTX2, QTY2, QZ2
8445 C IREJ=1
8446 C ENDIF
8447 C
8448 C CALL DALTRA(GAM,-BGX,-BGY,-BGZ,PXK1,PYK1,PZK1,EK1,PPPCH1, QTX1,
8449 C +QTY1,QZ1,QE1)
8450 C CALL DALTRA(GAM,-BGX,-BGY,-BGZ,PXK2,PYK2,PZK2,EK2,PPPCH2, QTX2,
8451 C +QTY2,QZ2,QE2)
8452 C IF(IPRI.GT.1) THEN
8453 CC WRITE(6,'(2A)') ' CORVAL - CORRECTION OF CHAIN MOMENTA',
8454 C + ' IF MASS OF CHAIN 2 HAD TO BE CHANGED'
8455 C ENDIF
8456  RETURN
8457  END
8458 
8459 C
8460 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8461 C
8462  SUBROUTINE hadrhh
8463  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8464  SAVE
8465 C-------------------------
8466 C
8467 C HADRONIZE HARD CHAINS
8468 C
8469 C ADD GENERATED HADRONS TO /ALLPAR/
8470 C STARTING AT (NAUX + 1)
8471 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
8472 C
8473 C---------------------------------------------------------
8474  parameter(intmx=2488,intmd=252)
8475  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
8476  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
8477  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
8478  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
8479  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
8480  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
8481  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
8482  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
8483 *KEEP,INTNEW.
8484  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
8485  +ixpv,ixps,ixtv,ixts, intvv1(248),
8486  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
8487  +intss1(intmx),intss2(intmx),
8488  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
8489  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
8490 
8491 C /INTNEW/
8492 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
8493 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
8494 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
8495 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
8496 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
8497 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
8498 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
8499 C FROM PROJECTILE/TARGET NUCLEI
8500 C-------------------
8501  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx),
8502  * ifrovt(248),itovt(248),ifrost(intmx),
8503  * jsshs(intmx),jtshs(intmx),jhkknp(248),jhkknt(248),
8504  * jhkkpv(intmx),jhkkps(intmx),
8505  * jhkktv(intmx),jhkkts(intmx),
8506  * mhkkvv(intmx),mhkkss(intmx),
8507  & mhkkvs(intmx),mhkksv(intmx),
8508  & mhkkhh(intmx),
8509  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
8510 C-------------------
8511 *KEEP,DIQI.
8512  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
8513  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
8514  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
8515  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
8516 C.....................................................................
8517  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
8518  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),
8519  *zuost(intmx),
8520  * intlo(intmx),inloss(intmx)
8521 C /LOZUO/
8522 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
8523 C REJECTED IN KKEVT
8524 C
8525  COMMON /abrhh/ amchh1(intmx),amchh2(intmx),
8526  * gachh1(intmx),gachh2(intmx),
8527  * bgxhh1(intmx),bgyhh1(intmx),bgzhh1(intmx),
8528  * bgxhh2(intmx),bgyhh2(intmx),bgzhh2(intmx),
8529  * nchhh1(intmx),nchhh2(intmx),
8530  * ijchh1(intmx),ijchh2(intmx),
8531  * pqhha1(intmx,4),pqhha2(intmx,4),
8532  * pqhhb1(intmx,4),pqhhb2(intmx,4)
8533  COMMON /hardha/nhard1,nhkkha
8534 C
8535 C modified DPMJET
8536  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
8537  * anndv,annvd,annds,annsd,
8538  * annhh,annzz,
8539  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
8540  * pthh,ptzz,
8541  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
8542  * eehh,eezz
8543  * ,anndi,ptdi,eedi
8544  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
8545  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
8546  * acouzz,acouhh,acouds,acousd,
8547  * acoudz,acouzd,acoudi,
8548  * acoudv,acouvd,acoucc
8549 C---------------------
8550  COMMON /pshow/ ipshow
8551 C COMMON /HARLUN/ IHARLU,QLUN
8552  COMMON /harlun/ qlun,iharlu
8553  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
8554  COMMON /jspa/pxs(40000),pys(40000),pzs(40000),hes(40000),nnnps
8555 C--------------------
8556 *KEEP,DFINPA.
8557  CHARACTER*8 anf
8558  parameter(nfimax=249)
8559  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
8560  +hep(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
8561  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
8562  * istath(nfimax)
8563 C-------------------
8564  parameter(nmxhkk= 89998)
8565  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
8566  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),phkk(5,nmxhkk),
8567  & vhkk(4,nmxhkk),whkk(4,nmxhkk)
8568 C
8569  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8570  COMMON /projk/ iprojk
8571  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
8572  COMMON /gluspl/nugluu,nsgluu
8573  COMMON /nomije/ ptmije(10),nnmije(10)
8574  COMMON /ndon/ndone
8575 C
8576  dimension poj(4),pat(4)
8577  DATA ncalhh /0/
8578 C-----------------------------------------------------------------------
8579  nhard1=nhkk+1
8580  DO 20 i=1,nonujt
8581  ncalhh=ncalhh+1
8582 C
8583  IF (iphkk.GE.2)WRITE(6,7789)nonujt,ncalhh
8584  7789 FORMAT (' HADRHH NONUJT,NCALHH ',2i10)
8585  IF (jhkkex(i).EQ.1)THEN
8586  IF (i.GT.intmx)THEN
8587  WRITE (6,7744)i,intmx
8588  7744 FORMAT (.GT.' HADRHH IINTMX ',2i10)
8589  RETURN
8590  ENDIF
8591 C
8592 C++++++++++++++++++++++++++++++ CHAIN 1: QUARK-ANTIQUARK +++++++
8593  ifb1=ijjq1(i)
8594  ifb2=ijjaq1(i)
8595  ifb2=iabs(ifb2)+6
8596  DO 21 j=1,4
8597  poj(j)=pjeta1(i,j)
8598  pat(j)=pjeta2(i,j)
8599  21 CONTINUE
8600  pt1=sqrt(poj(1)**2+poj(2)**2)
8601  pt2=sqrt(pat(1)**2+pat(2)**2)
8602  CALL parpt(2,pt1,pt2,6,nevt)
8603  iharlu=0
8604  qlun=0.
8605  IF(ipshow.EQ.1)THEN
8606  pojpt=sqrt(poj(2)**2+poj(1)**2)
8607  patpt=sqrt(pat(1)**2+pat(2)**2)
8608  DO iiii=1,10
8609  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
8610  * nnmije(iiii)+1
8611  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
8612  * nnmije(iiii)+1
8613  ENDDO
8614  qlun=min(pojpt,patpt)
8615  IF((qlun.LT.2.5d0).OR.(amjch1(i).LT.5.d0))THEN
8616  qlun=0.
8617  iharlu=0
8618  ELSE
8619  iharlu=1
8620  ENDIF
8621  ENDIF
8622 C----------------------------------------------------------------
8623  IF (gamjh1(i).LT.0.001d0.OR.amjch1(i).LT.2.d0)THEN
8624  WRITE (6,7788)
8625  * i,nhad,amjch1(i),poj,pat,gamjh1(i),bgxjh1(i),
8626  * bgyjh1(i),bgzjh1(i),ifb1,ifb2,ifb3,ifb4,jhkkex(i)
8627  7788 FORMAT (' HADRHH ',2i5,8e12.2/5e12.2,5i5)
8628  go to 9977
8629  ENDIF
8630  CALL hadjet(nhad,amjch1(i),poj,pat,gamjh1(i),bgxjh1(i),
8631  * bgyjh1(i),bgzjh1(i),ifb1,ifb2,ifb3,ifb4,
8632  * 13,13,3,0,13)
8633  acouhh=acouhh+1
8634  iharlu=0
8635  qlun=0.
8636  nhkkau=nhkk+1
8637  IF(iphkk.GE.3)WRITE(6,*)' HADRHH:NHKK,NHKKAU ',nhkk,nhkkau
8638  IF (nhad.GT.nfimax) THEN
8639  WRITE (6,7755)nhad,nfimax
8640  7755 FORMAT (.GT.' NHADNFIMAX ',2i10)
8641  RETURN
8642  ENDIF
8643  IF(ndone.EQ.-107801) WRITE(6,*)' First chain HADRHH'
8644  DO 22 j=1,nhad
8645 C NHKK=NHKK+1
8646  IF (nhkk.EQ.nmxhkk) THEN
8647  WRITE (*,'(A,2I5/A)') .EQ.' HADRHH: NHKKNMXHKK ',
8648  * nhkk,nmxhkk
8649  RETURN
8650  ENDIF
8651 C
8652  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
8653  IF (abs(ehecc-hep(j)).GT.0.001d0) THEN
8654 C WRITE(*,'(2A/3I5,3E15.6)')
8655 C & ' HADRSV / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
8656 C * ' NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)',
8657 C * NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)
8658  hep(j)=ehecc
8659  ENDIF
8660  annhh=annhh+1.
8661  eehh=eehh+hep(j)
8662  pthh=sqrt(pxf(j)**2+pyf(j)**2)+pthh
8663 C PUT NN-CMS HADRONS INTO /HKKEVT/
8664  istist=1
8665  IF(ibarf(j).EQ.500)istist=2
8666  CALL hkkfil(istist,mpdgha(nref(j)),mhkkhh(i)-3,0,
8667  * pxf(j),pyf(j),pzf(j),hep(j),nhkkau,iormo(j),9)
8668  IF(idhkk(nhkk).EQ.99999) WRITE (6,5009)nhkk,nref(j),
8669  * idhkk(nhkk)
8670 C IF(NDONE.EQ.-107801) WRITE(6,*)' First chain HADRHH'
8671  IF (ndone.EQ.-107801) WRITE(6,5001) j,nhkk,
8672  * isthkk(nhkk),idhkk(nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk),
8673  & jdahkk(1,nhkk),jdahkk(2,nhkk),(phkk(khkk,nhkk),khkk=1,5),
8674  & (vhkk(khkk,nhkk),khkk=1,4)
8675  IF(iphkk.GE.3) WRITE(6,*)' First chain HADRHH'
8676  IF (iphkk.GE.3) WRITE(6,5001) nhkk,
8677  * isthkk(nhkk),idhkk(nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk),
8678  & jdahkk(1,nhkk),jdahkk(2,nhkk),(phkk(khkk,nhkk),khkk=1,5),
8679  & (vhkk(khkk,nhkk),khkk=1,4)
8680  22 CONTINUE
8681 C JDAHKK(1,IMOHKK)=NHKKAU
8682 C JDAHKK(2,IMOHKK)=NHKK
8683  IF(nnnpj.GE.1)THEN
8684  nnnpso=nnnps
8685  nnnps=nnnps+1
8686  nnnpsu=nnnpso+nnnpj
8687  DO 137 j=nnnps,nnnpsu
8688  jj=j-nnnps+1
8689  IF(j.GT.40000.OR.jj.GT.1000)THEN
8690 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
8691  go to 137
8692  ENDIF
8693  pxs(j)=pxj(jj)
8694  pys(j)=pyj(jj)
8695  pzs(j)=pzj(jj)
8696  hes(j)=hej(jj)
8697  137 CONTINUE
8698  nnnps=nnnps+nnnpj-1
8699  ENDIF
8700  9977 continue
8701 C+++++++++++++++++++++++++++++ CHAIN 2: AQUARK-QUARK ++++++++++++++
8702  IF (nugluu.EQ.1) go to 5111
8703  ifb1=ijjaq2(i)
8704  ifb2=ijjq2(i)
8705  ifb1=iabs(ifb1)+6
8706  DO 23 j=1,4
8707  poj(j)=pjetb1(i,j)
8708  pat(j)=pjetb2(i,j)
8709  23 CONTINUE
8710  pt1=sqrt(poj(1)**2+poj(2)**2)
8711  pt2=sqrt(pat(1)**2+pat(2)**2)
8712  CALL parpt(2,pt1,pt2,6,nevt)
8713  iharlu=0
8714  qlun=0.
8715  IF(ipshow.EQ.1)THEN
8716  pojpt=sqrt(poj(2)**2+poj(1)**2)
8717  patpt=sqrt(pat(1)**2+pat(2)**2)
8718  DO iiii=1,10
8719  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
8720  * nnmije(iiii)+1
8721  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
8722  * nnmije(iiii)+1
8723  ENDDO
8724  qlun=min(pojpt,patpt)
8725  IF((qlun.LT.2.5d0).OR.(amjch2(i).LT.5.d0))THEN
8726  qlun=0.
8727  iharlu=0
8728  ELSE
8729  iharlu=1
8730  ENDIF
8731  ENDIF
8732 C
8733  CALL hadjet(nhad,amjch2(i),poj,pat,gamjh2(i),bgxjh2(i),
8734  * bgyjh2(i),bgzjh2(i),ifb1,ifb2,ifb3,ifb4,
8735  * 13,13,3,0,14)
8736  iharlu=0
8737  qlun=0.
8738 C ADD HADRONS/RESONANCES INTO
8739 C COMMON /ALLPAR/ STARTING AT NAUX
8740  nhkkau=nhkk+1
8741  DO 24 j=1,nhad
8742 C NHKK=NHKK+1
8743  IF (nhkk.EQ.nmxhkk) THEN
8744  WRITE (*,'(A,2I5/A)') .EQ.' HADRHH: NHKKNMXHKK ',
8745  & nhkk,nmxhkk
8746  RETURN
8747  ENDIF
8748 C
8749  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
8750  IF (abs(ehecc-hep(j)).GT.0.001d0) THEN
8751 C WRITE(*,'(2A/3I5,3E15.6)')
8752 C & ' HADRHH / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
8753 C * ' NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)',
8754 C * NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)
8755  hep(j)=ehecc
8756  ENDIF
8757  annhh=annhh+1.
8758  eehh=eehh+hep(j)
8759  pthh=sqrt(pxf(j)**2+pyf(j)**2)+pthh
8760 C PUT NN-CMS HADRONS INTO /HKKEVT/
8761  istist=1
8762  IF(ibarf(j).EQ.500)istist=2
8763  CALL hkkfil(istist,mpdgha(nref(j)),mhkkhh(i),0,
8764  * pxf(j),pyf(j),pzf(j),hep(j),nhkkau,iormo(j),10)
8765  IF(idhkk(nhkk).EQ.99999) WRITE (6,5009)nhkk,nref(j),
8766  * idhkk(nhkk)
8767 C WRITE(6,*)' Second chain HADRHH'
8768  IF (iphkk.GE.7) WRITE(6,5001) nhkk,
8769  * isthkk(nhkk),idhkk(nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk),
8770  & jdahkk(1,nhkk),jdahkk(2,nhkk),(phkk(khkk,nhkk),khkk=1,5),
8771  & (vhkk(khkk,nhkk),khkk=1,4)
8772  24 CONTINUE
8773 C JDAHKK(1,IMOHKK)=NHKKAU
8774 C JDAHKK(2,IMOHKK)=NHKK
8775  IF(nnnpj.GE.1)THEN
8776  nnnpso=nnnps
8777  nnnps=nnnps+1
8778  nnnpsu=nnnpso+nnnpj
8779  DO 187 j=nnnps,nnnpsu
8780  jj=j-nnnps+1
8781  IF(j.GT.40000.OR.jj.GT.1000)THEN
8782 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
8783  go to 187
8784  ENDIF
8785  pxs(j)=pxj(jj)
8786  pys(j)=pyj(jj)
8787  pzs(j)=pzj(jj)
8788  hes(j)=hej(jj)
8789  187 CONTINUE
8790  nnnps=nnnps+nnnpj-1
8791  ENDIF
8792  5111 CONTINUE
8793  ENDIF
8794  20 CONTINUE
8795  CALL dechkk(nhard1)
8796  nhkkha=nhkk
8797 C----------------------------------------------------------------
8798 C
8799  RETURN
8800  5001 FORMAT (i6,i6,5i6,9e10.2)
8801  5003 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
8802  5009 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
8803  END
8804 C
8805 C********************************************************************
8806 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8807 C
8808  SUBROUTINE hadrzz
8809  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8810  SAVE
8811 C-------------------------
8812 C
8813 C HADRONIZE HARD CHAINS
8814 C
8815 C ADD GENERATED HADRONS TO /ALLPAR/
8816 C STARTING AT (NAUX + 1)
8817 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
8818 C
8819 C---------------------------------------------------------
8820  parameter(intmx=2488,intmd=252)
8821  COMMON /abrzz/ amczz1(intmx),amczz2(intmx),
8822  * gaczz1(intmx),gaczz2(intmx),
8823  * bgxzz1(intmx),bgyzz1(intmx),bgzzz1(intmx),
8824  * bgxzz2(intmx),bgyzz2(intmx),bgzzz2(intmx),
8825  * nchzz1(intmx),nchzz2(intmx),
8826  * ijczz1(intmx),ijczz2(intmx),
8827  * pqzza1(intmx,4),pqzza2(intmx,4),
8828  * pqzzb1(intmx,4),pqzzb2(intmx,4)
8829  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
8830  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
8831  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
8832  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
8833  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
8834  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
8835  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
8836  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
8837  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
8838  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
8839 *KEEP,INTNEW.
8840  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
8841  +ixpv,ixps,ixtv,ixts, intvv1(248),
8842  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
8843  +intss1(intmx),intss2(intmx),
8844  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
8845  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
8846 
8847 C /INTNEW/
8848 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
8849 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
8850 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
8851 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
8852 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
8853 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
8854 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
8855 C FROM PROJECTILE/TARGET NUCLEI
8856 C-------------------
8857  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx),
8858  * ifrovt(248),itovt(248),ifrost(intmx),
8859  * jsshs(intmx),jtshs(intmx),jhkknp(248),jhkknt(248),
8860  * jhkkpv(intmx),jhkkps(intmx),
8861  * jhkktv(intmx),jhkkts(intmx),
8862  * mhkkvv(intmx),mhkkss(intmx),
8863  & mhkkvs(intmx),mhkksv(intmx),
8864  & mhkkhh(intmx),
8865  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
8866 C-------------------
8867 *KEEP,DIQI.
8868  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
8869  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
8870  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
8871  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
8872 C.....................................................................
8873  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
8874  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),
8875  *zuost(intmx),
8876  * intlo(intmx),inloss(intmx)
8877 C /LOZUO/
8878 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
8879 C REJECTED IN KKEVT
8880 C
8881 C
8882 C modified DPMJET
8883  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
8884  * anndv,annvd,annds,annsd,
8885  * annhh,annzz,
8886  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
8887  * pthh,ptzz,
8888  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
8889  * eehh,eezz
8890  * ,anndi,ptdi,eedi
8891  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
8892  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
8893  * acouzz,acouhh,acouds,acousd,
8894  * acoudz,acouzd,acoudi,
8895  * acoudv,acouvd,acoucc
8896 C---------------------
8897  COMMON /pshow/ ipshow
8898 C COMMON /HARLUN/ IHARLU,QLUN
8899  COMMON /harlun/ qlun,iharlu
8900  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
8901  COMMON /jspa/pxs(40000),pys(40000),pzs(40000),hes(40000),nnnps
8902 C--------------------
8903 *KEEP,DFINPA.
8904  CHARACTER*8 anf
8905  parameter(nfimax=249)
8906  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
8907  +hep(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
8908  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
8909  * istath(nfimax)
8910 C-------------------
8911  parameter(nmxhkk= 89998)
8912  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
8913  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),phkk(5,nmxhkk),
8914  & vhkk(4,nmxhkk),whkk(4,nmxhkk)
8915 C
8916  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8917  COMMON /projk/ iprojk
8918  COMMON /gluspl/nugluu,nsgluu
8919  COMMON /nomije/ ptmije(10),nnmije(10)
8920 C
8921  dimension poj(4),pat(4)
8922  DATA ncalzz /0/
8923 C-----------------------------------------------------------------------
8924  DO 20 i=1,nonust
8925  IF(nch1(i).EQ.99.OR.nch1(i).EQ.88)go to 20
8926  IF(nch2(i).EQ.99.OR.nch2(i).EQ.88)go to 20
8927  ncalzz=ncalzz+1
8928 C
8929  IF (iphkk.GE.7)WRITE(6,7789)nonust,ncalzz,jhkksx(i)
8930  7789 FORMAT (' HADRZZ NONUST,NCALZZ,Jhkksx(i) ',3i10)
8931  IF (jhkksx(i).EQ.1)THEN
8932  IF (i.GT.intmx)THEN
8933  WRITE (6,7744)i,intmx
8934  7744 FORMAT (.GT.' HADRZZ IINTMX ',2i10)
8935  RETURN
8936  ENDIF
8937 C
8938 C++++++++++++++++++++++++++++++ CHAIN 1: QUARK-DIQUARK +++++++++++
8939  ifb1=ijsq1(i)
8940  ifb2=ijsaq1(i)
8941  ifb2=iabs(ifb2)+6
8942  DO 21 j=1,4
8943  poj(j)=psofa1(i,j)
8944  pat(j)=psofa2(i,j)
8945  21 CONTINUE
8946  pt1=sqrt(poj(1)**2+poj(2)**2)
8947  pt2=sqrt(pat(1)**2+pat(2)**2)
8948  CALL parpt(2,pt1,pt2,5,nevt)
8949  iharlu=0
8950  qlun=0.
8951  IF(ipshow.EQ.1)THEN
8952  pojpt=sqrt(poj(2)**2+poj(1)**2)
8953  patpt=sqrt(pat(1)**2+pat(2)**2)
8954  DO iiii=1,10
8955  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
8956  * nnmije(iiii)+1
8957  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
8958  * nnmije(iiii)+1
8959  ENDDO
8960  qlun=min(pojpt,patpt)
8961  IF((qlun.LT.2.5d0).OR.(amcch1(i).LT.5.d0))THEN
8962  qlun=0.
8963  iharlu=0
8964  ELSE
8965  iharlu=1
8966  ENDIF
8967  ENDIF
8968 C----------------------------------------------------------------
8969  IF (gamch1(i).LT.0.001d0)WRITE (6,7788)
8970  * i,nhad,amcch1(i),poj,pat,gamch1(i),bgxch1(i),
8971  * bgych1(i),bgzch1(i),ifb1,ifb2,ifb3,ifb4,jhkksx(i)
8972  7788 FORMAT (' HADRZZ ',2i5,10e12.2/3e12.2,5i5)
8973  CALL hadjet(nhad,amcch1(i),poj,pat,gamch1(i),bgxch1(i),
8974  * bgych1(i),bgzch1(i),ifb1,ifb2,ifb3,ifb4,
8975  * ijczz1(i),ijczz1(i),3,nchzz1(i),23)
8976  acouzz=acouzz+1
8977  iharlu=0
8978  qlun=0.
8979  nhkkau=nhkk+1
8980  IF (nhad.GT.nfimax) THEN
8981  WRITE (6,7755)nhad,nfimax
8982  7755 FORMAT (.GT.' NHADNFIMAX ',2i10)
8983  RETURN
8984  ENDIF
8985  DO 22 j=1,nhad
8986 C NHKK=NHKK+1
8987  IF (nhkk.EQ.nmxhkk) THEN
8988  WRITE (*,'(A,2I5/A)') .EQ.' HADRZZ: NHKKNMXHKK ',
8989  * nhkk,nmxhkk
8990  RETURN
8991  ENDIF
8992 C
8993  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
8994  IF (abs(ehecc-hep(j)).GT.0.001d0) THEN
8995 C WRITE(*,'(2A/3I5,3E15.6)')
8996 C & ' HADRZZ / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
8997 C * ' NCALZZ, NHKK,NREF(J), HEP(J),EHECC, AMF(J)',
8998 C * NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)
8999  hep(j)=ehecc
9000  ENDIF
9001  annzz=annzz+1.
9002  eezz=eezz+hep(j)
9003  ptzz=sqrt(pxf(j)**2+pyf(j)**2)+ptzz
9004 C PUT NN-CMS HADRONS INTO /HKKEVT/
9005  istist=1
9006  IF(ibarf(j).EQ.500)istist=2
9007  CALL hkkfil(istist,mpdgha(nref(j)),mhkkhh(i)-3,0,
9008  * pxf(j),pyf(j),pzf(j),hep(j),nhkkau,iormo(j),11)
9009  IF(idhkk(nhkk).EQ.99999) WRITE (6,5009)nhkk,nref(j),
9010  * idhkk(nhkk)
9011 C WRITE(6,*)' First chain HADRZZ'
9012  IF (iphkk.GE.7) WRITE(6,5001) nhkk,
9013  * isthkk(nhkk),idhkk(nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk),
9014  & jdahkk(1,nhkk),jdahkk(2,nhkk),(phkk(khkk,nhkk),khkk=1,5),
9015  & (vhkk(khkk,nhkk),khkk=1,4)
9016  22 CONTINUE
9017 C JDAHKK(1,IMOHKK)=NHKKAU
9018 C JDAHKK(2,IMOHKK)=NHKK
9019  IF(nnnpj.GE.1)THEN
9020  nnnpso=nnnps
9021  nnnps=nnnps+1
9022  nnnpsu=nnnpso+nnnpj
9023  DO 137 j=nnnps,nnnpsu
9024  jj=j-nnnps+1
9025  IF(j.GT.40000.OR.jj.GT.1000)THEN
9026 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
9027  go to 137
9028  ENDIF
9029  pxs(j)=pxj(jj)
9030  pys(j)=pyj(jj)
9031  pzs(j)=pzj(jj)
9032  hes(j)=hej(jj)
9033  137 CONTINUE
9034  nnnps=nnnps+nnnpj-1
9035  ENDIF
9036 C+++++++++++++++++++++++++++++ CHAIN 2: AQUARK-QUARK ++++++++++++++
9037  ifb1=ijsaq2(i)
9038  ifb2=ijsq2(i)
9039  ifb1=iabs(ifb1)+6
9040  DO 23 j=1,4
9041  poj(j)=psofb1(i,j)
9042  pat(j)=psofb2(i,j)
9043  23 CONTINUE
9044  pt1=sqrt(poj(1)**2+poj(2)**2)
9045  pt2=sqrt(pat(1)**2+pat(2)**2)
9046  CALL parpt(2,pt1,pt2,5,nevt)
9047  iharlu=0
9048  qlun=0.
9049  IF(ipshow.EQ.1)THEN
9050  pojpt=sqrt(poj(2)**2+poj(1)**2)
9051  patpt=sqrt(pat(1)**2+pat(2)**2)
9052  DO iiii=1,10
9053  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
9054  * nnmije(iiii)+1
9055  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
9056  * nnmije(iiii)+1
9057  ENDDO
9058  qlun=min(pojpt,patpt)
9059  IF((qlun.LT.2.5d0).OR.(amcch2(i).LT.5.d0))THEN
9060  qlun=0.
9061  iharlu=0
9062  ELSE
9063  iharlu=1
9064  ENDIF
9065  ENDIF
9066 C TURN 20.8.91
9067  CALL hadjet(nhad,amcch2(i),pat,poj,gamch2(i),bgxch2(i),
9068  * bgych2(i),bgzch2(i),ifb1,ifb2,ifb3,ifb4,
9069  * ijczz2(i),ijczz2(i),3,nchzz2(i),24)
9070  iharlu=0
9071  qlun=0.
9072 C ADD HADRONS/RESONANCES INTO
9073 C COMMON /ALLPAR/ STARTING AT NAUX
9074  nhkkau=nhkk+1
9075  DO 24 j=1,nhad
9076 C NHKK=NHKK+1
9077  IF (nhkk.EQ.nmxhkk) THEN
9078  WRITE (*,'(A,2I5/A)') .EQ.' HADRZZ: NHKKNMXHKK ',
9079  & nhkk,nmxhkk
9080  RETURN
9081  ENDIF
9082 C
9083  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
9084  IF (abs(ehecc-hep(j)).GT.0.001d0) THEN
9085 C WRITE(*,'(2A/3I5,3E15.6)')
9086 C & ' HADRZZ / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
9087 C * ' NCALZZ, NHKK,NREF(J), HEP(J),EHECC, AMF(J)',
9088 C * NCALZZ, NHKK,NREF(J), HEP(J),EHECC, AMF(J)
9089  hep(j)=ehecc
9090  ENDIF
9091  annzz=annzz+1.
9092  eezz=eezz+hep(j)
9093  ptzz=sqrt(pxf(j)**2+pyf(j)**2)+ptzz
9094 C PUT NN-CMS HADRONS INTO /HKKEVT/
9095  istist=1
9096  IF(ibarf(j).EQ.500)istist=2
9097  CALL hkkfil(istist,mpdgha(nref(j)),mhkkhh(i),0,
9098  * pxf(j),pyf(j),pzf(j),hep(j),nhkkau,iormo(j),12)
9099  IF(idhkk(nhkk).EQ.99999) WRITE (6,5009)nhkk,nref(j),
9100  * idhkk(nhkk)
9101 C WRITE(6,*)' Second chain HADRZZ'
9102  IF (iphkk.GE.7) WRITE(6,5001) nhkk,
9103  * isthkk(nhkk),idhkk(nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk),
9104  & jdahkk(1,nhkk),jdahkk(2,nhkk),(phkk(khkk,nhkk),khkk=1,5),
9105  & (vhkk(khkk,nhkk),khkk=1,4)
9106  24 CONTINUE
9107 C JDAHKK(1,IMOHKK)=NHKKAU
9108 C JDAHKK(2,IMOHKK)=NHKK
9109  IF(nnnpj.GE.1)THEN
9110  nnnpso=nnnps
9111  nnnps=nnnps+1
9112  nnnpsu=nnnpso+nnnpj
9113  DO 187 j=nnnps,nnnpsu
9114  jj=j-nnnps+1
9115  IF(j.GT.40000.OR.jj.GT.1000)THEN
9116 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
9117  go to 187
9118  ENDIF
9119  pxs(j)=pxj(jj)
9120  pys(j)=pyj(jj)
9121  pzs(j)=pzj(jj)
9122  hes(j)=hej(jj)
9123  187 CONTINUE
9124  nnnps=nnnps+nnnpj-1
9125  ENDIF
9126  5111 CONTINUE
9127  ENDIF
9128  20 CONTINUE
9129 C----------------------------------------------------------------
9130 C
9131  RETURN
9132  5001 FORMAT (i6,i4,5i6,9e10.2)
9133  5003 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
9134  5009 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
9135  END
9136 C
9137 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
9138 
9139  SUBROUTINE qinnuc(X,Y)
9140 
9141 C Este programa genera una distribucion de partones de tipo gaussiana
9142 C centrada en el centro del hadron. Distribucion: F(b)=A*(-b**2/c).
9143 C La distribucion la generamos en coordenadas polares porque asi
9144 C tenemos primitiva.
9145 C
9146  IMPLICIT DOUBLE PRECISION(a-h,o-z)
9147  SAVE
9148 
9149  CHARACTER*80 title
9150  CHARACTER*8 projty,targty
9151 C COMMON/USER/TITLE,PROJTY,TARGTY,CMENER,ISTRUF
9152 C & ,ISINGD,IDUBLD,SDFRAC,PTLAR
9153  COMMON /user1/title,projty,targty
9154  COMMON /user2/cmener,sdfrac,ptlar,istruf,isingd,idubld
9155 
9156  c=4.*(0.15d-24+0.01d-24*log(cmener))
9157  10 p=rndm(v1)
9158  IF ((p). eq .(1.d0)) THEN
9159  go to 10
9160  END IF
9161  z=rndm(v2)
9162  t=2.*3.1416*z
9163  r=dsqrt(-c*dlog(1.d00-p))
9164  x=r*dcos(t)
9165  y=r*dsin(t)
9166 
9167  RETURN
9168  END
9169 
9170 C
9171 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
9172 C
9173  SUBROUTINE casavs
9174  IMPLICIT DOUBLE PRECISION (a-h,o-z)
9175  SAVE
9176 C
9177 C-------------------------
9178 C
9179 C Casado diquarks VS
9180 C
9181 C ADD GENERATED HADRONS TO /ALLPAR/
9182 C STARTING AT (NAUX + 1)
9183 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
9184 C
9185 C-------------------------
9186 *KEEP,INTMX.
9187  parameter(intmx=2488,intmd=252)
9188 *KEEP,DXQX.
9189 C INCLUDE (XQXQ)
9190 * NOTE: INTMX set via INCLUDE(INTMX)
9191  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
9192  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
9193  * ,xpsu(248),xtsu(248)
9194  * ,xpsut(248),xtsut(248)
9195  common/popcck/pdbck,pdbse,pdbseu,
9196  * ijpock,irejck,ick4,ihad4,ick6,ihad6
9197  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
9198  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
9199  *isea43,isea63,irejao
9200 *KEEP,INTNEW.
9201  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
9202  +ixpv,ixps,ixtv,ixts, intvv1(248),
9203  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
9204  +intss1(intmx),intss2(intmx),
9205  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
9206  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
9207 
9208 C /INTNEW/
9209 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
9210 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
9211 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
9212 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
9213 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
9214 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
9215 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
9216 C FROM PROJECTILE/TARGET NUCLEI
9217 C-------------------
9218 *KEEP,IFROTO.
9219  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
9220  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
9221  +jhkknt
9222  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
9223  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
9224  & mhkkhh(intmx),
9225  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
9226 *KEEP,LOZUO.
9227  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
9228  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
9229  +intlo(intmx),inloss(intmx)
9230 C /LOZUO/
9231 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
9232 C REJECTED IN KKEVT
9233 C------------------
9234 *KEEP,DIQI.
9235  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
9236  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
9237  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
9238  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
9239 *KEEP,HKKEVT.
9240 c INCLUDE (HKKEVT)
9241  parameter(nmxhkk= 89998)
9242 c PARAMETER (NMXHKK=25000)
9243  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
9244  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
9245  +(4,nmxhkk)
9246 C
9247 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
9248 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
9249 C THE POSITIONS OF THE PROJECTILE NUCLEONS
9250 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
9251 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
9252 C COMPLETELY CONSISTENT. THE TIMES IN THE
9253 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
9254 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
9255 C
9256 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
9257 C
9258 C NMXHKK: maximum numbers of entries (partons/particles) that can be
9259 C stored in the commonblock.
9260 C
9261 C NHKK: the actual number of entries stored in current event. These are
9262 C found in the first NHKK positions of the respective arrays below.
9263 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
9264 C entry.
9265 C
9266 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
9267 C = 0 : null entry.
9268 C = 1 : an existing entry, which has not decayed or fragmented.
9269 C This is the main class of entries which represents the
9270 C "final state" given by the generator.
9271 C = 2 : an entry which has decayed or fragmented and therefore
9272 C is not appearing in the final state, but is retained for
9273 C event history information.
9274 C = 3 : a documentation line, defined separately from the event
9275 C history. (incoming reacting
9276 C particles, etc.)
9277 C = 4 - 10 : undefined, but reserved for future standards.
9278 C = 11 - 20 : at the disposal of each model builder for constructs
9279 C specific to his program, but equivalent to a null line in the
9280 C context of any other program. One example is the cone defining
9281 C vector of HERWIG, another cluster or event axes of the JETSET
9282 C analysis routines.
9283 C = 21 - : at the disposal of users, in particular for event tracking
9284 C in the detector.
9285 C
9286 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
9287 C standard.
9288 C
9289 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
9290 C The value is 0 for initial entries.
9291 C
9292 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
9293 C one mother exist, in which case the value 0 is used. In cluster
9294 C fragmentation models, the two mothers would correspond to the q
9295 C and qbar which join to form a cluster. In string fragmentation,
9296 C the two mothers of a particle produced in the fragmentation would
9297 C be the two endpoints of the string (with the range in between
9298 C implied).
9299 C
9300 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
9301 C entry has not decayed, this is 0.
9302 C
9303 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
9304 C entry has not decayed, this is 0. It is assumed that the daughters
9305 C of a particle (or cluster or string) are stored sequentially, so
9306 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
9307 C daughters. Even in cases where only one daughter is defined (e.g.
9308 C K0 -> K0S) both values should be defined, to make for a uniform
9309 C approach in terms of loop constructions.
9310 C
9311 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
9312 C
9313 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
9314 C
9315 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
9316 C
9317 C PHKK(4,IHKK) : energy, in GeV.
9318 C
9319 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
9320 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
9321 C
9322 C VHKK(1,IHKK) : production vertex x position, in mm.
9323 C
9324 C VHKK(2,IHKK) : production vertex y position, in mm.
9325 C
9326 C VHKK(3,IHKK) : production vertex z position, in mm.
9327 C
9328 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
9329 C********************************************************************
9330 *KEEP,ABRVS.
9331  COMMON /abrvs/ amcvs1(248),amcvs2(248),gacvs1(248),gacvs2(248),
9332  +bgxvs1(248),bgyvs1(248),bgzvs1(248), bgxvs2(248),bgyvs2(248),
9333  +bgzvs2(248), nchvs1(248),nchvs2(248),ijcvs1(248),ijcvs2(248),
9334  +pqvsa1(248,4),pqvsa2(248,4), pqvsb1(248,4),pqvsb2(248,4)
9335 *KEEP,DFINPA.
9336  CHARACTER*8 anf
9337  parameter(nfimax=249)
9338  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
9339  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
9340  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
9341  * istath(nfimax)
9342 *KEEP,DPRIN.
9343  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
9344 *KEEP,PROJK.
9345  COMMON /projk/ iprojk
9346 *KEEP,NUCC.
9347  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
9348 *KEND.
9349 C modified DPMJET
9350  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
9351  * anndv,annvd,annds,annsd,
9352  * annhh,annzz,
9353  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
9354  * pthh,ptzz,
9355  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
9356  * eehh,eezz
9357  * ,anndi,ptdi,eedi
9358  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
9359  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
9360  * acouzz,acouhh,acouds,acousd,
9361  * acoudz,acouzd,acoudi,
9362  * acoudv,acouvd,acoucc
9363 C---------------------
9364  COMMON /zsea/zseaav,zseasu,anzsea
9365  COMMON /casadi/casaxx,icasad
9366 C---------------------
9367 C-----------------------------------------------------------------------
9368  DO 50 i=1,nvs
9369 C-----------------------drop recombined chain pairs
9370  IF(nchvs1(i).EQ.99.AND.nchvs2(i).EQ.99) go to 50
9371  is1=intvs1(i)
9372  is2=intvs2(i)
9373 C
9374  IF (ipco.GE.6) WRITE (6,1010) ipvq(is1),ippv1(is1),ippv2(is1),
9375  + itsq(is2),itsaq(is2), amcvs1(i),amcvs2(i),gacvs1(i),gacvs2(i),
9376  + bgxvs1(i),bgyvs1(i),bgzvs1(i), bgxvs2(i),bgyvs2(i),bgzvs2(i),
9377  + nchvs1(i),nchvs2(i),ijcvs1(i),ijcvs2(i), pqvsa1(i,4),pqvsa2
9378  + (i,4),pqvsb1(i,4),pqvsb2(i,4)
9379 C
9380 C
9381 C++++++++++++++++++++++++++++++ CHAIN 2: DIQUARK-QUARK +++++++++++
9382  ifb1=ippv1(is1)
9383  ifb2=ippv2(is1)
9384  ifb3=itsq(is2)
9385 C------------------------------------------------------------------
9386 C check bookkeeping
9387 C-----------------------------------------------------------------
9388 C I= number of valence chain
9389 C Projectile Nr ippp= IFROVP(INTVS1(I))
9390 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
9391  ippp = ifrovp(intvs1(i))
9392  jipp=jsshs(ippp)
9393 C------------------------------------------------------------------
9394 C check bookkeeping
9395 C-----------------------------------------------------------------
9396  IF(ipco.GE.1)THEN
9397  WRITE(6,*)' VS qq-q ,IFB1,IFB2,IFB3,',
9398  * 'INTVS1=IS1,INTVS2=IS2,JIPP,JITTX',
9399  * ifb1,ifb2,ifb3,intvs1(i),intvs2(i),jipp,jittx
9400  WRITE (6,*)' target sea quark IFB3=',ifb3,
9401  * ' from IS2=',intvs2(i)
9402  WRITE(6,*)' with ITSQ(IS2),XTSQ(IS2),IFROST(IS2)',
9403  * itsq(is2),xtsq(is2),ifrost(is2)
9404  ENDIF
9405  DO 797 ii=1,ixtv
9406  IF(ifrost(is2).EQ.ifrovt(ii))iii=ii
9407  797 CONTINUE
9408  IF(ipco.GE.1)THEN
9409  WRITE (6,*)' projectile III=',iii
9410  WRITE(6,*)' corresp. XTVQ(i),XTVD(i),ITVQ(I),ITTV1(I),ITTV2(I)',
9411  * xtvq(iii),xtvd(iii),itvq(iii),ittv1(iii),ittv2(iii)
9412  ENDIF
9413 C-------------------------------------------------------------------
9414 C Casado diquark option
9415 C+++++++++++++++++++++++++++++ VS CHAIN 2: DIQUARK-QUARK +++++++++
9416 C-------------------------------------------------------------------
9417  IF(icasad.EQ.1)THEN
9418  IF(rndm(vv).LE.casaxx)THEN
9419  IF(rndm(vvv).LE.0.5d0)THEN
9420  iscasa=itsq(is2)
9421  itvcas=ittv1(iii)
9422  itsq(is2)=itvcas
9423  ittv1(iii)=iscasa
9424  ifb3=itsq(is2)
9425  IF(ipco.GE.1)THEN
9426  WRITE(6,*)' Cas VS2 qq-q 1 ,IFB1,IFB2,IFB3,',
9427  * 'INTVS1=IS1,INTVS2=IS2,III',
9428  * ifb1,ifb2,ifb3,intvs1(i),intvs2(i),iii
9429  * ,'-----------------------------------------------------'
9430  ENDIF
9431  ELSE
9432  iscasa=itsq(is2)
9433  itvcas=ittv2(iii)
9434  itsq(is2)=itvcas
9435  ittv2(iii)=iscasa
9436  ifb3=itsq(is2)
9437  IF(ipco.GE.1)THEN
9438  WRITE(6,*)' Cas VS2 qq-q 2 ,IFB1,IFB2,IFB3,',
9439  * 'INTVS1=IS1,INTVS2=IS2,III',
9440  * ifb1,ifb2,ifb3,intvs1(i),intvs2(i),iii
9441  * ,'-----------------------------------------------------'
9442  ENDIF
9443  ENDIF
9444  ENDIF
9445  ENDIF
9446 C-------------------------------------------------------------------
9447 C Casado diquark option
9448 C-------------------------------------------------------------------
9449  50 CONTINUE
9450 C
9451  RETURN
9452  1010 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
9453  END
9454 C
9455 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
9456 C
9457  SUBROUTINE casasv
9458  IMPLICIT DOUBLE PRECISION (a-h,o-z)
9459  SAVE
9460 C-------------------------
9461 C
9462 C Casado diquarks SV
9463 C
9464 C ADD GENERATED HADRONS TO /ALLPAR/
9465 C STARTING AT (NAUX + 1)
9466 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
9467 C
9468 C---------------------------------------------------------
9469 *KEEP,INTMX.
9470  parameter(intmx=2488,intmd=252)
9471 *KEEP,DXQX.
9472 C INCLUDE (XQXQ)
9473 * NOTE: INTMX set via INCLUDE(INTMX)
9474  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
9475  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
9476  * ,xpsu(248),xtsu(248)
9477  * ,xpsut(248),xtsut(248)
9478  common/popcck/pdbck,pdbse,pdbseu,
9479  * ijpock,irejck,ick4,ihad4,ick6,ihad6
9480  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
9481  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
9482  *isea43,isea63,irejao
9483 *KEEP,INTNEW.
9484  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
9485  +ixpv,ixps,ixtv,ixts, intvv1(248),
9486  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
9487  +intss1(intmx),intss2(intmx),
9488  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
9489  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
9490 
9491 C /INTNEW/
9492 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
9493 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
9494 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
9495 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
9496 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
9497 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
9498 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
9499 C FROM PROJECTILE/TARGET NUCLEI
9500 C-------------------
9501 *KEEP,IFROTO.
9502  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
9503  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
9504  +jhkknt
9505  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
9506  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
9507  & mhkkhh(intmx),
9508  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
9509 *KEEP,LOZUO.
9510  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
9511  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
9512  +intlo(intmx),inloss(intmx)
9513 C /LOZUO/
9514 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
9515 C REJECTED IN KKEVT
9516 C------------------
9517 *KEEP,DIQI.
9518  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
9519  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
9520  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
9521  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
9522 *KEEP,HKKEVT.
9523 c INCLUDE (HKKEVT)
9524  parameter(nmxhkk= 89998)
9525 c PARAMETER (NMXHKK=25000)
9526  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
9527  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
9528  +(4,nmxhkk)
9529 C
9530 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
9531 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
9532 C THE POSITIONS OF THE PROJECTILE NUCLEONS
9533 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
9534 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
9535 C COMPLETELY CONSISTENT. THE TIMES IN THE
9536 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
9537 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
9538 C
9539 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
9540 C
9541 C NMXHKK: maximum numbers of entries (partons/particles) that can be
9542 C stored in the commonblock.
9543 C
9544 C NHKK: the actual number of entries stored in current event. These are
9545 C found in the first NHKK positions of the respective arrays below.
9546 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
9547 C entry.
9548 C
9549 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
9550 C = 0 : null entry.
9551 C = 1 : an existing entry, which has not decayed or fragmented.
9552 C This is the main class of entries which represents the
9553 C "final state" given by the generator.
9554 C = 2 : an entry which has decayed or fragmented and therefore
9555 C is not appearing in the final state, but is retained for
9556 C event history information.
9557 C = 3 : a documentation line, defined separately from the event
9558 C history. (incoming reacting
9559 C particles, etc.)
9560 C = 4 - 10 : undefined, but reserved for future standards.
9561 C = 11 - 20 : at the disposal of each model builder for constructs
9562 C specific to his program, but equivalent to a null line in the
9563 C context of any other program. One example is the cone defining
9564 C vector of HERWIG, another cluster or event axes of the JETSET
9565 C analysis routines.
9566 C = 21 - : at the disposal of users, in particular for event tracking
9567 C in the detector.
9568 C
9569 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
9570 C standard.
9571 C
9572 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
9573 C The value is 0 for initial entries.
9574 C
9575 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
9576 C one mother exist, in which case the value 0 is used. In cluster
9577 C fragmentation models, the two mothers would correspond to the q
9578 C and qbar which join to form a cluster. In string fragmentation,
9579 C the two mothers of a particle produced in the fragmentation would
9580 C be the two endpoints of the string (with the range in between
9581 C implied).
9582 C
9583 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
9584 C entry has not decayed, this is 0.
9585 C
9586 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
9587 C entry has not decayed, this is 0. It is assumed that the daughters
9588 C of a particle (or cluster or string) are stored sequentially, so
9589 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
9590 C daughters. Even in cases where only one daughter is defined (e.g.
9591 C K0 -> K0S) both values should be defined, to make for a uniform
9592 C approach in terms of loop constructions.
9593 C
9594 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
9595 C
9596 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
9597 C
9598 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
9599 C
9600 C PHKK(4,IHKK) : energy, in GeV.
9601 C
9602 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
9603 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
9604 C
9605 C VHKK(1,IHKK) : production vertex x position, in mm.
9606 C
9607 C VHKK(2,IHKK) : production vertex y position, in mm.
9608 C
9609 C VHKK(3,IHKK) : production vertex z position, in mm.
9610 C
9611 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
9612 C********************************************************************
9613 *KEEP,ABRSV.
9614  COMMON /abrsv/ amcsv1(248),amcsv2(248),gacsv1(248),gacsv2(248),
9615  +bgxsv1(248),bgysv1(248),bgzsv1(248), bgxsv2(248),bgysv2(248),
9616  +bgzsv2(248), nchsv1(248),nchsv2(248),ijcsv1(248),ijcsv2(248),
9617  +pqsva1(248,4),pqsva2(248,4), pqsvb1(248,4),pqsvb2(248,4)
9618 *KEEP,DFINPA.
9619  CHARACTER*8 anf
9620  parameter(nfimax=249)
9621  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
9622  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
9623  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
9624  * istath(nfimax)
9625 *KEEP,DPRIN.
9626  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
9627 *KEEP,PROJK.
9628  COMMON /projk/ iprojk
9629 *KEEP,NUCC.
9630  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
9631 *KEND.
9632 C modified DPMJET
9633  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
9634  * anndv,annvd,annds,annsd,
9635  * annhh,annzz,
9636  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
9637  * pthh,ptzz,
9638  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
9639  * eehh,eezz
9640  * ,anndi,ptdi,eedi
9641  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
9642  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
9643  * acouzz,acouhh,acouds,acousd,
9644  * acoudz,acouzd,acoudi,
9645  * acoudv,acouvd,acoucc
9646 C---------------------
9647  COMMON /zsea/zseaav,zseasu,anzsea
9648  COMMON /casadi/casaxx,icasad
9649 C---------------------
9650  DATA ncalsv /0/
9651 C-----------------------------------------------------------------------
9652  ncalsv=ncalsv+1
9653  DO 50 i=1,nsv
9654 C-----------------------drop recombined chain pairs
9655  IF(nchsv1(i).EQ.99.AND.nchsv2(i).EQ.99) go to 50
9656  is1=intsv1(i)
9657  is2=intsv2(i)
9658 C
9659  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itvq(is2),
9660  + ittv1(is2),ittv2(is2), amcsv1(i),amcsv2(i),gacsv1(i),gacsv2(i),
9661  + bgxsv1(i),bgysv1(i),bgzsv1(i), bgxsv2(i),bgysv2(i),bgzsv2(i),
9662  + nchsv1(i),nchsv2(i),ijcsv1(i),ijcsv2(i), pqsva1(i,4),pqsva2
9663  + (i,4),pqsvb1(i,4),pqsvb2(i,4)
9664  1000 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
9665 C
9666 C++++++++++++++++++++++++++++++ CHAIN 1: QUARK-DIQUARK +++++++++++
9667  ifb1=ipsq(is1)
9668  ifb2=ittv1(is2)
9669  ifb3=ittv2(is2)
9670 C------------------------------------------------------------------
9671 C------------------------------------------------------------------
9672 C check bookkeeping
9673 C-----------------------------------------------------------------
9674 C I= number of valence chain
9675 C Target Nr itt = IFROVT(INTSV2(I))
9676 C No of Glauber sea q at Target JITT=JTSHS(ITT)
9677  ittt = ifrovt(intsv2(i))
9678  jitt=jtshs(ittt)
9679 C------------------------------------------------------------------
9680 C check bookkeeping
9681 C-----------------------------------------------------------------
9682  IF(ipco.GE.1)THEN
9683  WRITE(6,*)' SV q-qq ,IFB1,IFB2,IFB3,',
9684  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITT',
9685  * ifb1,ifb2,ifb3,intsv1(i),intsv2(i),jippx,jitt
9686  WRITE (6,*)' projectile sea quark IFB1=',ifb1,
9687  * ' from IS1=',intsv1(i)
9688  WRITE(6,*)' with IPSQ(IS1),XPSQ(IS1),IFROSP(IS1)',
9689  * ipsq(is1),xpsq(is1),ifrosp(is1)
9690  ENDIF
9691  DO 798 ii=1,ixpv
9692  IF(ifrosp(is1).EQ.ifrovp(ii))iii=ii
9693  798 CONTINUE
9694  IF(ipco.GE.1)THEN
9695  WRITE (6,*)' projectile III=',iii
9696  WRITE(6,*)' corresp. XPVQ(i),XPVD(i),IPVQ(I),IPPV1(I),IPPV2(I)',
9697  * xpvq(iii),xpvd(iii),ipvq(iii),ippv1(iii),ippv2(iii)
9698  ENDIF
9699 C-------------------------------------------------------------------
9700 C Casado diquark option
9701 C++++++++++++++++++++++++++++ SV CHAIN 1: QUARK-DIQUARK +++++++++++
9702 C-------------------------------------------------------------------
9703  IF(icasad.EQ.1)THEN
9704  IF(rndm(vv).LE.casaxx)THEN
9705  IF(rndm(vvv).LE.0.5d0)THEN
9706  iscasa=ipsq(is1)
9707  ipvcas=ippv1(iii)
9708  ipsq(is1)=ipvcas
9709  ippv1(iii)=iscasa
9710  ifb1=ipsq(is1)
9711  IF(ipco.GE.1)THEN
9712  WRITE(6,*)' Cas SV1 q-qq 1 ,IFB1,IFB2,IFB3,',
9713  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITT,III',
9714  * ifb1,ifb2,ifb3,intsv1(i),intsv2(i),jippx,jitt,iii
9715  * ,'-----------------------------------------------------'
9716  ENDIF
9717  ELSE
9718  iscasa=ipsq(is1)
9719  ipvcas=ippv2(iii)
9720  ipsq(is1)=ipvcas
9721  ippv2(iii)=iscasa
9722  ifb1=ipsq(is1)
9723  IF(ipco.GE.1)THEN
9724  WRITE(6,*)' Cas SV1 q-qq 2 ,IFB1,IFB2,IFB3,',
9725  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITT,III',
9726  * ifb1,ifb2,ifb3,intsv1(i),intsv2(i),jippx,jitt,iii
9727  * ,'-----------------------------------------------------'
9728  ENDIF
9729  ENDIF
9730  ENDIF
9731  ENDIF
9732 C-------------------------------------------------------------------
9733 C Casado diquark option
9734 C-------------------------------------------------------------------
9735  50 CONTINUE
9736 C----------------------------------------------------------------
9737 C
9738  RETURN
9739  END
mpdgha
function mpdgha(MCIND)
Definition: dpm25nulib.f:386
calbam
subroutine calbam(NNCH, I1, I2, IFB11, IFB22, IFB33, IFB44, AMCH, NOBAM, IHAD)
Definition: dpm25nuc7.f:2138
intmx
const int intmx
Definition: G4DPMJET2_5Interface.hh:68
z
Double_t z
Definition: plot.C:279
yy
Double_t yy
Definition: macro.C:11
xksamp
subroutine xksamp(NN, ECM)
Definition: dpm25nuc3.f:1273
hadrds
subroutine hadrds
Definition: dpm25nuc5.f:3858
hadjse
subroutine hadjse(NHAD, AMCH, PPR, PTA, GAM, BGX, BGY, BGZ, IFB1, IFB2, IFB3, IFB4, I1, I2, NOBAM, NNCH, NORIG, IREJ, IISSQQ)
Definition: dpm25nuc4.f:1479
gm
#define gm
Definition: mymalloc.cc:2499
mcihad
function mcihad(MCIND)
Definition: dpm25nulib.f:364
flksaa
subroutine flksaa(NN, ECM)
Definition: dpm25nuc3.f:922
hadrkk
subroutine hadrkk(NHKKH1, PPN)
Definition: dpm25nuc3.f:3259
x2
Double_t x2[nxs]
Definition: Style.C:19
dtrans
subroutine dtrans(XO, YO, ZO, CDE, SDE, SFE, CFE, X, Y, Z)
Definition: dpm25nulib.f:510
d
Float_t d
Definition: plot.C:237
sltraf
subroutine sltraf(GA, BGA, EIN, PZIN, EOUT, PZOUT)
Definition: dpm25nuc3.f:72
saptre
subroutine saptre(AM1, G1, BGX1, BGY1, BGZ1, AM2, G2, BGX2, BGY2, BGZ2)
Definition: dpm25nuc3.f:1
rndm
DOUBLE PRECISION function rndm(RDUMMY)
Definition: dpm25nulib.f:1460
dtwopd
subroutine dtwopd(UMO, ECM1, ECM2, PCM1, PCM2, COD1, COF1, SIF1, COD2, COF2, SIF2, AM1, AM2)
Definition: dpm25nuc7.f:3326
hadrdz
subroutine hadrdz
Definition: dpm25nuc5.f:6432
nucmom
subroutine nucmom
Definition: dpm25nuc3.f:83
p
const char * p
Definition: xmltok.h:285
sampex
DOUBLE PRECISION function sampex(X1, X2)
Definition: dpm25nulib.f:1118
dtrafo
subroutine dtrafo(GAM, BGAM, CX, CY, CZ, COD, COF, SIF, P, ECM, PL, CXL, CYL, CZL, EL)
Definition: dpm25nuc3.f:7346
lortmo
subroutine lortmo(N, GAM, BGX, BGY, BGZ)
Definition: dpm25nuc3.f:7420
flksam
subroutine flksam
Definition: dpm25nuc3.f:653
xx
Double_t xx
Definition: macro.C:10
cormom
subroutine cormom(AMCH1, AMCH2, AMCH1N, AMCH2N, PQ1X, PQ1Y, PQ1Z, PQ1E, PA1X, PA1Y, PA1Z, PA1E, PQ2X, PQ2Y, PQ2Z, PQ2E, PA2X, PA2Y, PA2Z, PA2E, PXCH1, PYCH1, PZCH1, ECH1, PXCH2, PYCH2, PZCH2, ECH2, IREJ)
Definition: dpm25nuc3.f:6305
diqvs
subroutine diqvs(ECM, IPV, J, IREJ)
Definition: dpm25nuc5.f:1411
c1
TCanvas * c1
Definition: plotHisto.C:7
flahad
subroutine flahad(ITYP, IBAR, IF1, IF2, IF3)
Definition: dpm25nuc3.f:1194
pyp
function pyp(I, J)
Definition: pythia61.f:38097
a
G4double a
Definition: TRTMaterials.hh:39
dpoli
subroutine dpoli(CS, SI)
Definition: dpm25nulib.f:597
fer4mt
subroutine fer4mt(IT, PFERM, PXT, PYT, PZT, ET, KT)
Definition: dpm25nuc3.f:430
sampxb
DOUBLE PRECISION function sampxb(X1, X2, B)
Definition: dpm25nulib.f:1133
nmxhkk
const int nmxhkk
Definition: G4DPMJET2_5Interface.hh:78
dbetar
DOUBLE PRECISION function dbetar(GAM, ETA)
Definition: dpm25nulib.f:289
selpt
subroutine selpt(PTXSQ1, PTYSQ1, PLQ1, EQ1, PTXSA1, PTYSA1, PLAQ1, EAQ1, PTXSQ2, PTYSQ2, PLQ2, EQ2, PTXSA2, PTYSA2, PLAQ2, EAQ2, AMCH1, AMCH2, IREJ, IKVALA, PTTQ1, PTTA1, PTTQ2, PTTA2, NSELPT)
Definition: dpm25nuc3.f:6620
selpt4
subroutine selpt4(PTXSQ1, PTYSQ1, PLQ1, EQ1, PTXSA1, PTYSA1, PLAQ1, EAQ1, PTXSQ2, PTYSQ2, PLQ2, EQ2, PTXSA2, PTYSA2, PLAQ2, EAQ2, AMCH1, AMCH2, IREJ, IKVALA, PTTQ1, PTTA1, NSELPT)
Definition: dpm25nuc3.f:6435
c2_transformation::one
static float_type one(float_type)
utility function f(x)=1 useful in axis transforms
Definition: c2_function.hh:1201
qinnuc
subroutine qinnuc(X, Y)
Definition: dpm25nuc3.f:9129
parpt
subroutine parpt(IFL, PT1, PT2, IPT, NEVT)
Definition: dpm25nuc1.f:6468
y
Double_t y
Definition: plot.C:279
fer4m
subroutine fer4m(PFERM, PXT, PYT, PZT, ET, KT)
Definition: dpm25nuc3.f:320
sewew
subroutine sewew(IOP, NHKKH1)
Definition: dpm25nuc4.f:33
intmd
const int intmd
Definition: G4DPMJET2_5Interface.hh:66
hadrsv
subroutine hadrsv
Definition: dpm25nuc3.f:4279
sttran
subroutine sttran(XO, YO, ZO, CDE, SDE, SFE, CFE, X, Y, Z)
Definition: dpm25nuc3.f:7369
n
Char_t n[5]
Definition: comparison_ascii.C:55
hadrvs
subroutine hadrvs
Definition: dpm25nuc3.f:5230
testem0.App.init
def init
Definition: testem0.py:56
corval
subroutine corval(AMMM, IREJ, AMCH1, AMCH2, QTX1, QTY1, QZ1, QE1, QTX2, QTY2, QZ2, QE2, NORIG)
Definition: dpm25nuc3.f:8390
hadrsd
subroutine hadrsd
Definition: dpm25nuc5.f:5429
hadrvd
subroutine hadrvd
Definition: dpm25nuc5.f:2382
hadrhh
subroutine hadrhh
Definition: dpm25nuc3.f:8459
hadrss
subroutine hadrss
Definition: dpm25nuc3.f:4727
diqssd
subroutine diqssd(ECM, ITS, IPS, IREJ)
Definition: dpm25nuc5.f:4398
daltra
subroutine daltra(GA, BGX, BGY, BGZ, PCX, PCY, PCZ, EC, P, PX, PY, PZ, E)
Definition: dpm25nulib.f:542
hadjck
subroutine hadjck(NHAD, AMCH, PPR, PTA, GAM, BGX, BGY, BGZ, IFB1, IFB2, IFB3, IFB4, I1, I2, NOBAM, NNCH, NORIG, IREJ)
Definition: dpm25nuc4.f:958
diqdss
subroutine diqdss(ECM, ITS, IPS, IREJ)
Definition: dpm25nuc5.f:2829
x1
Double_t x1[nxs]
Definition: Style.C:18
diqsv
subroutine diqsv(ECM, ITV, J, IREJ)
Definition: dpm25nuc5.f:1
dechkk
subroutine dechkk(NHKKH1)
Definition: dpm25nuc3.f:6992
samppt
subroutine samppt(MODE, PT)
Definition: dpm25nuc1.f:4387
fer4mp
subroutine fer4mp(IP, PFERM, PXT, PYT, PZT, ET, KT)
Definition: dpm25nuc3.f:373
comcm2
subroutine comcm2(IQ1, IQ2, IAQ1, IAQ2, NNCH, IREJ, AMCH)
Definition: dpm25nuc3.f:6218
x
Double_t x
Definition: plot.C:279
sampey
DOUBLE PRECISION function sampey(X1, X2)
Definition: dpm25nulib.f:1107
zz
Double_t zz
Definition: macro.C:12
r
jump r
Definition: plot.C:36
dsfecf
subroutine dsfecf(SFE, CFE)
Definition: dpm25nuc7.f:3354
dfermi
subroutine dfermi(GPART)
Definition: dpm25nulib.f:609
title
subroutine title(NA, NB, NCA, NCB)
Definition: dpm25nuc7.f:1744
evtest
subroutine evtest(IREJ)
Definition: dpm25nuc3.f:7496
c2_factory::log
static c2_log_p< float_type > & log()
make a *new object
Definition: c2_factory.hh:138
CLHEP::HepLorentzVector::et
double et() const
cobcma
subroutine cobcma(IF1, IF2, IF3, IJNCH, NNCH, IREJ, AMCH, AMCHN, IKET)
Definition: dpm25nuc3.f:6049
casavs
subroutine casavs
Definition: dpm25nuc3.f:9163
hadrdv
subroutine hadrdv
Definition: dpm25nuc5.f:971
dfatpr
subroutine dfatpr(IP, PABS)
Definition: dpm25nuc3.f:571
casasv
subroutine casasv
Definition: dpm25nuc3.f:9447
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
hadrzz
subroutine hadrzz
Definition: dpm25nuc3.f:8798
hkkfil
subroutine hkkfil(IST, ID, M1, M2, PX, PY, PZ, E, NHKKAU, KORMO, ICALL)
Definition: dpm25nuc1.f:6509
parhkk
subroutine parhkk
Definition: dpm25nuc3.f:2859
comcma
subroutine comcma(IFQ, IFAQ, IJNCH, NNCH, IREJ, AMCH, AMCHN)
Definition: dpm25nuc3.f:6135
lortrp
subroutine lortrp(N, NAUX, GAM, BGX, BGY, BGZ)
Definition: dpm25nuc3.f:5983
hadrvv
subroutine hadrvv
Definition: dpm25nuc3.f:3726
print
void print(const std::vector< T > &data)
Definition: DicomRun.hh:111
dthrep
subroutine dthrep(UMO, ECM1, ECM2, ECM3, PCM1, PCM2, PCM3, COD1, COF1, SIF1, COD2, COF2, SIF2, COD3, COF3, SIF3, AM1, AM2, AM3)
Definition: dpm25nuc7.f:2748
dbeta
DOUBLE PRECISION function dbeta(X1, X2, BET)
Definition: dpm25nuc7.f:2672
hadrzd
subroutine hadrzd
Definition: dpm25nuc5.f:7422
betrej
DOUBLE PRECISION function betrej(GAM, ETA, XMIN, XMAX)
Definition: dpm25nulib.f:344
dbklas
subroutine dbklas(I, J, K, I8, I10)
Definition: dpm25nuc7.f:6096
dfatta
subroutine dfatta(IT, PABS)
Definition: dpm25nuc3.f:489
hadjet
subroutine hadjet(NHAD, AMCH, PPR, PTA, GAM, BGX, BGY, BGZ, IFB1, IFB2, IFB3, IFB4, I1, I2, NOBAM, NNCH, NORIG)
Definition: dpm25nuc3.f:5651
c2_factory::exp
static c2_exp_p< float_type > & exp()
make a *new object
Definition: c2_factory.hh:140
Generated on Sat Dec 14 2013 14:33:19 for Geant4_10 by   doxygen 1.8.5