Geant4  9.6.p02
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
dpm25nuc5.f
Go to the documentation of this file.
1  SUBROUTINE diqsv(ECM,ITV,J,IREJ)
2  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3  SAVE
4 * define d-v chains (sea diquark - valence chains)
5 * sq-q and saqsaq-qq chains instead of sq-qq and saq-q chains
6  COMMON /zsea/zseaav,zseasu,anzsea
7  common/popcck/pdbck,pdbse,pdbseu,
8  * ijpock,irejck,ick4,ihad4,ick6,ihad6
9  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
10  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
11  *isea43,isea63,irejao
12 *KEEP,INTMX.
13  parameter(intmx=2488,intmd=252)
14 *KEEP,IFROTO.
15  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
16  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
17  +jhkknt
18  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
19  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
20  & mhkkhh(intmx),
21  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
22 *KEEP,DIQI.
23  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
24  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
25  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
26  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
27 *KEEP,DXQX.
28 C INCLUDE (XQXQ)
29 * NOTE: INTMX set via INCLUDE(INTMX)
30  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
31  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
32  * ,xpsu(248),xtsu(248)
33  * ,xpsut(248),xtsut(248)
34 *KEEP,INTNEW.
35  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
36  +ixpv,ixps,ixtv,ixts, intvv1(248),
37  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
38  +intss1(intmx),intss2(intmx),
39  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
40  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
41 
42 C /INTNEW/
43 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
44 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
45 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
46 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
47 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
48 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
49 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
50 C FROM PROJECTILE/TARGET NUCLEI
51 C-------------------
52 *KEEP,ABRDV.
53  COMMON /abrdv/ amcdv1(248),amcdv2(248),gacdv1(248),gacdv2(248),
54  +bgxdv1(248),bgydv1(248),bgzdv1(248), bgxdv2(248),bgydv2(248),
55  +bgzdv2(248), nchdv1(248),nchdv2(248),ijcdv1(248),ijcdv2(248),
56  +pqdva1(248,4),pqdva2(248,4), pqdvb1(248,4),pqdvb2(248,4)
57 *KEND.
58  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
59  COMMON /seasu3/seasq
60  COMMON /xseadi/ xseacu,unon,unom,unosea, cvq,cdq,csea,ssmima,
61  +ssmimq,vvmthr
62  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
63  *idzre(3),izdre(3),idiqrz(7)
64  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
65  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
66  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
67  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
68  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
69  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
70 C------------------------------------------------------------------
71 C COMMON /PCHARM/PCCCC
72  parameter(ummm=0.3d0)
73  parameter(smmm=0.5d0)
74  parameter(cmmm=1.3d0)
75  DATA pc/0.0001d0/
76 *KEND.
77 C----------
78 C
79  DATA inicha/0/
80 C----------------------------------------------------------------------
81 C Initialize Charm selection at soft chain ends
82 C
83  IF(inicha.EQ.0)THEN
84  rx=8.d0
85  x1=rx
86  gm=2.140d0
87  x2=ummm
88  betoo=7.5d0
89  ENDIF
90  rx=8.d0
91  x1=rx
92  betcha=betoo+1.3d0-log10(ecm)
93  pu=dbeta(x1,x2,betcha)
94  x2=smmm
95  ps=dbeta(x1,x2,betcha)
96  x2=cmmm
97  pc=dbeta(x1,x2,betcha)
98 C PU1=PU/(2*PU+PS+PC)
99 C PS1=PS/(2*PU+PS+PC)
100  pc1=pc/(2*pu+ps+pc)
101 C changed j.r.7.12.94
102 C PC=PC1/2.9
103 C changed j.r.14.12.94
104 C PC=PC1/5.0
105 C PC=PC1/10.0
106  pc=pc1/7.0d0
107  pu1=pu/(2*pu+ps+pc)
108  ps1=ps/(2*pu+ps+pc)
109  IF(inicha.EQ.0)THEN
110  inicha=1
111  WRITE(6,4567)pc,betcha,pu1,ps1,seasq
112  4567 FORMAT(' Charm chain ends DIQSV: PC,BETCHA,PU,PS,SEASQ ',5f10.5)
113  ENDIF
114 C----------------------------------------------------------------------
115  irej=0
116 * kinematics: is the mass of the adiquark-diquark chain big enough
117 * to allow for fragmentation
118  IF(iphkk.GE.6)WRITE (6,'( A)') ' diqsv'
119  ipsq2(j)=1.d0+rndm(v1)*(2.d0+2.d0*seasq)
120  rr=rndm(v)
121  IF(rr.LT.pc)ipsq2(j)=4
122 C------------------------------------------------------------------
123  ipsaq2(j)=-ipsq2(j)
124 C---------------------------------------------------j.r.29.4.94
125 C x**1.5 distr for sea diquarks
126 C number of projectile nucleon
127  inucpr=ifrosp(j)
128 C number of projectile diquark
129  iitop=itovp(inucpr)
130 C diquark x
131  xpdiqu=xpvd(iitop)
132 C minimal value of diquark x
133  xdthr=cdq/ecm
134 C
135  xdfree=xpdiqu-xdthr
136  xall=xdfree+xpsq(j)+xpsaq(j)-2.*xdthr
137  xdalt=xpvd(iitop)
138  xsalt=xpsq(j)
139  xaalt=xpsaq(j)
140  IF(xall.GE.0.)THEN
141  rr1=rndm(v1)
142  rr2=rndm(v2)
143  rr3=rndm(v3)
144  sr123=rr1+rr2+rr3
145  dx1=rr1*xall/sr123
146  dx2=rr2*xall/sr123
147  dx3=rr3*xall/sr123
148  xpvd(iitop)=xdthr+dx1
149  xpsq(j)=xdthr+dx2
150  xpsaq(j)=xdthr+dx3
151  ENDIF
152 C--------------------------------------------------------------
153  amdvq1=xpsq(j)*xtvq(itv)*ecm**2
154  amdvq2=xpsaq(j)*xtvd(itv)*ecm**2
155  idiqre(1)=idiqre(1)+1
156  IF(ipsq(j).GE.3.AND.ipsq2(j).GE.3)THEN
157  idiqre(2)=idiqre(2)+1
158 C IF(AMDVQ2.LE.9.0.OR.AMDVQ1.LE.2.30) THEN
159  IF(amdvq2.LE.17.0d0.OR.amdvq1.LE.6.60d0) THEN
160  irej=1
161  idiqre(3)=idiqre(3)+1
162  idiqre(2)=idiqre(2)-1
163  idiqre(1)=idiqre(1)-1
164  xpvd(iitop)=xdalt
165  xpsq(j)=xsalt
166  xpsaq(j)=xaalt
167  RETURN
168  ENDIF
169  ELSEIF(ipsq(j).GE.3.OR.ipsq2(j).GE.3)THEN
170  idiqre(4)=idiqre(4)+1
171 C IF(AMDVQ2.LE.7.3.OR.AMDVQ1.LE.1.90) THEN
172  IF(amdvq2.LE.13.6d0.OR.amdvq1.LE.5.80d0) THEN
173  irej=1
174  idiqre(5)=idiqre(5)+1
175  idiqre(4)=idiqre(4)-1
176  idiqre(1)=idiqre(1)-1
177  xpvd(iitop)=xdalt
178  xpsq(j)=xsalt
179  xpsaq(j)=xaalt
180  RETURN
181  ENDIF
182  ELSE
183  idiqre(6)=idiqre(6)+1
184 C IF(AMDVQ2.LE.6.70.OR.AMDVQ1.LE.1.50) THEN
185  IF(amdvq2.LE.12.40d0.OR.amdvq1.LE.3.9d0) THEN
186  irej=1
187  idiqre(7)=idiqre(7)+1
188  idiqre(6)=idiqre(6)-1
189  idiqre(1)=idiqre(1)-1
190  xpvd(iitop)=xdalt
191  xpsq(j)=xsalt
192  xpsaq(j)=xaalt
193  RETURN
194  ENDIF
195  ENDIF
196  ndv=ndv+1
197  nchdv1(ndv)=0
198  nchdv2(ndv)=0
199  intdv1(ndv)=j
200  intdv2(ndv)=itv
201  RETURN
202  END
203 C
204 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
205 C
206 C DEBUG SUBCHK
207 C END DEBUG
208  SUBROUTINE kkevdv(IREJDV)
209  IMPLICIT DOUBLE PRECISION (a-h,o-z)
210  SAVE
211 C
212 C------------------ treatment of sea diquark - valence CHAIN SYSTEMS
213  COMMON /zsea/zseaav,zseasu,anzsea
214  common/popcck/pdbck,pdbse,pdbseu,
215  * ijpock,irejck,ick4,ihad4,ick6,ihad6
216  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
217  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
218  *isea43,isea63,irejao
219 C
220 *KEEP,INTMX.
221 
222  parameter(intmx=2488,intmd=252)
223 *KEEP,HKKEVT.
224 c INCLUDE (HKKEVT)
225  parameter(nmxhkk= 89998)
226 c PARAMETER (NMXHKK=25000)
227  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
228  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
229  +(4,nmxhkk)
230 C
231 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
232 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
233 C THE POSITIONS OF THE PROJECTILE NUCLEONS
234 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
235 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
236 C COMPLETELY CONSISTENT. THE TIMES IN THE
237 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
238 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
239 C
240 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
241 C
242 C NMXHKK: maximum numbers of entries (partons/particles) that can be
243 C stored in the commonblock.
244 C
245 C NHKK: the actual number of entries stored in current event. These are
246 C found in the first NHKK positions of the respective arrays below.
247 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
248 C entry.
249 C
250 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
251 C = 0 : null entry.
252 C = 1 : an existing entry, which has not decayed or fragmented.
253 C This is the main class of entries which represents the
254 C "final state" given by the generator.
255 C = 2 : an entry which has decayed or fragmented and therefore
256 C is not appearing in the final state, but is retained for
257 C event history information.
258 C = 3 : a documentation line, defined separately from the event
259 C history. (incoming reacting
260 C particles, etc.)
261 C = 4 - 10 : undefined, but reserved for future standards.
262 C = 11 - 20 : at the disposal of each model builder for constructs
263 C specific to his program, but equivalent to a null line in the
264 C context of any other program. One example is the cone defining
265 C vector of HERWIG, another cluster or event axes of the JETSET
266 C analysis routines.
267 C = 21 - : at the disposal of users, in particular for event tracking
268 C in the detector.
269 C
270 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
271 C standard.
272 C
273 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
274 C The value is 0 for initial entries.
275 C
276 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
277 C one mother exist, in which case the value 0 is used. In cluster
278 C fragmentation models, the two mothers would correspond to the q
279 C and qbar which join to form a cluster. In string fragmentation,
280 C the two mothers of a particle produced in the fragmentation would
281 C be the two endpoints of the string (with the range in between
282 C implied).
283 C
284 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
285 C entry has not decayed, this is 0.
286 C
287 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
288 C entry has not decayed, this is 0. It is assumed that the daughters
289 C of a particle (or cluster or string) are stored sequentially, so
290 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
291 C daughters. Even in cases where only one daughter is defined (e.g.
292 C K0 -> K0S) both values should be defined, to make for a uniform
293 C approach in terms of loop constructions.
294 C
295 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
296 C
297 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
298 C
299 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
300 C
301 C PHKK(4,IHKK) : energy, in GeV.
302 C
303 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
304 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
305 C
306 C VHKK(1,IHKK) : production vertex x position, in mm.
307 C
308 C VHKK(2,IHKK) : production vertex y position, in mm.
309 C
310 C VHKK(3,IHKK) : production vertex z position, in mm.
311 C
312 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
313 C********************************************************************
314 *KEEP,IFROTO.
315  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
316  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
317  +jhkknt
318  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
319  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
320  & mhkkhh(intmx),
321  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
322 *KEEP,DIQI.
323  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
324  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
325  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
326  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
327 *KEEP,INTNEW.
328  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
329  +ixpv,ixps,ixtv,ixts, intvv1(248),
330  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
331  +intss1(intmx),intss2(intmx),
332  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
333  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
334 
335 C /INTNEW/
336 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
337 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
338 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
339 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
340 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
341 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
342 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
343 C FROM PROJECTILE/TARGET NUCLEI
344 C-------------------
345 *KEEP,ABRDV.
346  COMMON /abrdv/ amcdv1(248),amcdv2(248),gacdv1(248),gacdv2(248),
347  +bgxdv1(248),bgydv1(248),bgzdv1(248), bgxdv2(248),bgydv2(248),
348  +bgzdv2(248), nchdv1(248),nchdv2(248),ijcdv1(248),ijcdv2(248),
349  +pqdva1(248,4),pqdva2(248,4), pqdvb1(248,4),pqdvb2(248,4)
350 *KEEP,DXQX.
351 C INCLUDE (XQXQ)
352 * NOTE: INTMX set via INCLUDE(INTMX)
353  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
354  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
355  * ,xpsu(248),xtsu(248)
356  * ,xpsut(248),xtsut(248)
357 *KEEP,LOZUO.
358  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
359  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
360  +intlo(intmx),inloss(intmx)
361  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
362  *idzre(3),izdre(3),idiqrz(7)
363 C /LOZUO/
364 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
365 C REJECTED IN KKEVT
366 C------------------
367 *KEEP,TRAFOP.
368  COMMON /trafop/ gamp,bgamp,betp
369 *KEEP,NUCIMP.
370  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
371  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
372  +prebin,taebin,fermod,etacou
373 *KEEP,FERMI.
374  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
375  +(4,248)
376 *KEEP,DPAR.
377 C /DPAR/ CONTAINS PARTICLE PROPERTIES
378 C ANAME = LITERAL NAME OF THE PARTICLE
379 C AAM = PARTICLE MASS IN GEV
380 C GA = DECAY WIDTH
381 C TAU = LIFE TIME OF INSTABLE PARTICLES
382 C IICH = ELECTRIC CHARGE OF THE PARTICLE
383 C IIBAR = BARYON NUMBER
384 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
385 C
386  CHARACTER*8 aname
387  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
388  +iibar(210),k1(210),k2(210)
389 C------------------
390 *KEEP,DPRIN.
391  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
392 *KEEP,REJEC.
393  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
394  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
395  +irvs14, irvv11,irvv12,irvv13,irvv14
396 *KEEP,PROJK.
397  COMMON /projk/ iprojk
398  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
399  common/rptshm/rproj,rtarg,bimpac
400  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
401  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
402  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
403  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
404  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
405  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
406 *KEND.
407 C-------------------
408  IF(iphkk.GE.6)WRITE (6,'( A)') ' kkevdv'
409  irejdv=0
410  DO 10 n=1,ndv
411 C---------------------------drop recombined chain pairs
412  IF(nchdv1(n).EQ.99.AND.nchdv2(n).EQ.99)go to 10
413 C
414 C*** 4-MOMENTA OF PROJECTILE SEA-QUARK PAIRS IN NN-CMS
415  ixspr=intdv1(n)
416  inucpr=ifrosp(ixspr)
417  jnucpr=itovp(inucpr)
418 C
419  psqpx=xpsq(ixspr)*prmom(1,inucpr)
420  psqpy=xpsq(ixspr)*prmom(2,inucpr)
421  psqpz=xpsq(ixspr)*prmom(3,inucpr)
422  psqe=xpsq(ixspr)*prmom(4,inucpr)
423  psaqpx=xpsaq(ixspr)*prmom(1,inucpr)
424  psaqpy=xpsaq(ixspr)*prmom(2,inucpr)
425  psaqpz=xpsaq(ixspr)*prmom(3,inucpr)
426  psaqe=xpsaq(ixspr)*prmom(4,inucpr)
427 C
428 C*** 4-MOMENTA OF TARGET QUARK-DIQUARK PAIRS IN NN-CMS
429  ixvta=intdv2(n)
430  inucta=ifrovt(ixvta)
431  jnucta=itovt(inucta)
432 C
433  tvqpx=xtvq(ixvta)*tamom(1,inucta)
434  tvqpy=xtvq(ixvta)*tamom(2,inucta)
435  tvqpz=xtvq(ixvta)*tamom(3,inucta)
436  tvqe=xtvq(ixvta)*tamom(4,inucta)
437  tvdqpx=xtvd(ixvta)*tamom(1,inucta)
438  tvdqpy=xtvd(ixvta)*tamom(2,inucta)
439  tvdqpz=xtvd(ixvta)*tamom(3,inucta)
440  tvdqe=xtvd(ixvta)*tamom(4,inucta)
441 C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
442 C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
443 C j.r.6.5.93
444 C
445 C multiple scattering of sea quark chain ends
446 C
447  IF(it.GT.1)THEN
448  itnu=ip+inucta
449  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
450  rtiy=vhkk(2,itnu)*1.e12
451  rtiz=vhkk(3,itnu)*1.e12
452  CALL cromsc(psqpx,psqpy,psqpz,psqe,rtix,rtiy,rtiz,
453  * psqnx,psqny,psqnz,psqne,51)
454  psqpx=psqnx
455  psqpy=psqny
456  psqpz=psqnz
457  psqe=psqne
458  CALL cromsc(psaqpx,psaqpy,psaqpz,psaqe,rtix,rtiy,rtiz,
459  * psaqnx,psaqny,psaqnz,psaqne,52)
460  psaqpx=psaqnx
461  psaqpy=psaqny
462  psaqpz=psaqnz
463  psaqe=psaqne
464 C ---------
465 C j.r.6.5.93
466 C
467 C multiple scattering of VALENCE quark chain ends
468 C
469  itnu=ip+inucta
470  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
471  rtiy=vhkk(2,itnu)*1.e12
472  rtiz=vhkk(3,itnu)*1.e12
473  CALL cromsc(tvqpx,tvqpy,tvqpz,tvqe,rtix,rtiy,rtiz,
474  * tvqnx,tvqny,tvqnz,tvqne,53)
475  tvqpx=tvqnx
476  tvqpy=tvqny
477  tvqpz=tvqnz
478  tvqe=tvqne
479  CALL cromsc(tvdqpx,tvdqpy,tvdqpz,tvdqe,rtix,rtiy,rtiz,
480  * tvdqnx,tvdqny,tvdqnz,tvdqne,54)
481  tvdqpx=tvdqnx
482  tvdqpy=tvdqny
483  tvdqpz=tvdqnz
484  tvdqe=tvdqne
485  ENDIF
486 C ---------
487 
488 C
489 C j.r.10.5.93
490  IF(ip.GE.0)go to 1779
491  psqpz2=psqe**2-psqpx**2-psqpy**2
492  IF(psqpz2.GE.0.)THEN
493  psqpz=sqrt(psqpz2)
494  ELSE
495  psqpx=0.
496  psqpy=0.
497  psqpz=psqe
498  ENDIF
499 C
500  psaqp2=psaqe**2-psaqpx**2-psaqpy**2
501  IF(psaqp2.GE.0.)THEN
502  psaqpz=sqrt(psaqp2)
503  ELSE
504  psaqpx=0.
505  psaqpy=0.
506  psaqpz=psaqe
507  ENDIF
508 C
509  tvqpz2=tvqe**2-tvqpx**2-tvqpy**2
510  IF(tvqpz2.GE.0.)THEN
511  tvqpz=-sqrt(tvqpz2)
512  ELSE
513  tvqpx=0.
514  tvqpy=0.
515  tvqpz=tvqe
516  ENDIF
517 C
518  tdqpz2=tvdqe**2-tvdqpx**2-tvdqpy**2
519  IF(tdqpz2.GE.0.)THEN
520  tvdqpz=-sqrt(tdqpz2)
521  ELSE
522  tvdqpx=0.
523  tvdqpy=0.
524  tvdqpz=tvdqe
525  ENDIF
526  1779 CONTINUE
527 C ----------------
528 
529 C ---------
530 C changej.r.6.5.93
531 C changej.r.6.5.93
532  ptxsq1=0.
533  ptxsa1=0.
534  ptxsq2=0.
535  ptxsa2=0.
536  ptysq1=0.
537  ptysa1=0.
538  ptysq2=0.
539  ptysa2=0.
540  ptxsq1=psqpx
541  ptxsa1=psaqpx
542  ptxsq2=tvqpx
543  ptxsa2=tvdqpx
544  ptysq1=psqpy
545  ptysa1=psaqpy
546  ptysq2=tvqpy
547  ptysa2=tvdqpy
548  plq1=psqpz
549  plaq1=psaqpz
550  plq2=tvqpz
551  plaq2=tvdqpz
552  eq1=psqe
553  eaq1=psaqe
554  eq2=tvqe
555  eaq2=tvdqe
556 C
557 C*** SAMPLE PARTON-PT VALUES / DETERMINE PARTON 4-MOMENTA AND CHAIN MAS
558 C*** IN THE REST FRAME DEFINED ABOVE
559 C
560 C change j.r.6.5.93
561 C _________________
562  ikvala=0
563  IF(ipev.GE.2) THEN
564  WRITE(6,'(A,I5)') ' KKEVDV - IRDV13=',irdv13
565  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
566  + ' DV: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
567  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
568  + amch1,amch2,irej,ikvala,pttq1,ptta1
569  ENDIF
570  ikvala=0
571  nselpt=1
572  nselpt=0
573  IF(ip.EQ.1)nselpt=1
574  IF(nselpt.EQ.1)CALL selpt( ptxsq1,ptysq1,plq1,
575  + eq1,ptxsa1,ptysa1,plaq1,eaq1,
576  + ptxsa2,ptysa2,plaq2,eaq2,
577  + ptxsq2,ptysq2,plq2,eq2,
578  + amch1,amch2,irej,ikvala,pttq1,ptta1,
579  * pttq2,ptta2,
580  * nselpt)
581  IF(nselpt.EQ.0)CALL selpt4( ptxsq1,ptysq1,plq1,
582  + eq1,ptxsa1,ptysa1,plaq1,eaq1,
583  + ptxsa2,ptysa2,plaq2,eaq2,
584  + ptxsq2,ptysq2,plq2,eq2,
585  + amch1,amch2,irej,ikvala,pttq1,ptta1,nselpt)
586  IF(ipev.GE.2) THEN
587  WRITE(6,'(A,I5)') ' KKEVDV - IRDV13=',irdv13
588  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
589  + ' DV: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
590  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
591  + amch1,amch2,irej,ikvala,pttq1,ptta1
592  ENDIF
593  IF (ipev.GE.7) WRITE(6,'(A,I10)')
594  + 'DV IREJ ', irej
595  IF (irej.EQ.1) THEN
596  irdv13=irdv13 + 1
597  IF(ipev.GE.1) THEN
598  WRITE(6,'(A,I5)') ' KKEVDV - IRDV13=',irdv13
599  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
600  + ' DV: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
601  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
602  + amch1,amch2,irej,ikvala,pttq1,ptta1
603  ENDIF
604  go to 20
605  ENDIF
606 C
607 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
608 C
609  ptxch1=ptxsq1 + ptxsq2
610  ptych1=ptysq1 + ptysq2
611  ptzch1=plq1 + plq2
612  ech1=eq1 + eq2
613  ptxch2=ptxsa2 + ptxsa1
614  ptych2=ptysa2 + ptysa1
615  ptzch2=plaq2 + plaq1
616  ech2=eaq2 + eaq1
617  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
618  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
619 C
620 C
621  IF (ipev.GE.6) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
622  + ' DV: IREJ ',irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
623  + amch1,ptxch1,ptych1,ptzch1,ech1,
624  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
625  + ptzch2,ech2
626 
627 C
628 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS OR OCTETT
629 C OR DECUPLETT BARYONS
630 C FIRST FOR CHAIN 1 (PROJ SEA-diquark - TAR QUARK)
631 C
632  CALL cobcma(ipsq(ixspr),ipsq2(ixspr),itvq(ixvta), ijnch1,nnch1,
633  + irej,amch1,amch1n,1)
634 C*** MASS BELOW OCTETT BARYON MASS
635  IF(irej.EQ.1) THEN
636  irdv11=irdv11 + 1
637  IF(ipev.GE.1) THEN
638  WRITE(6,'(A,I5)') ' KKEVDV - IRDV11=',irdv11
639  WRITE(6,'(A,6I5/6E12.4/2E12.4)') ' DV:', ipsq(ixspr),ittv1
640  + (ixvta),ittv2(ixvta),ijnch1,nnch1,irej, xpsq(ixspr),xpsaq
641  + (ixspr),xpsqcm,xpsacm, xtvq(ixvta),xtvd(ixvta),amch1,amch1n
642 
643  ENDIF
644  goto 20
645  ENDIF
646 C CORRECT KINEMATICS FOR CHAIN 1
647 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
648  IF(nnch1.NE.0)THEN
649  CALL cormom(amch1,amch2,amch1n,amch2n,
650  + ptxsq1,ptysq1,plq1,eq1,
651  + ptxsa1,ptysa1,plaq1,eaq1,
652  + ptxsa2,ptysa2,plaq2,eaq2,
653  + ptxsq2,ptysq2,plq2,eq2,
654  + ptxch1,ptych1,ptzch1,ech1, ptxch2,ptych2,ptzch2,ech2,
655  + irej)
656  amch2=amch2n
657  ENDIF
658 C
659  IF (ipev.GE.2) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
660  + ' DV(2): IREJ ',irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
661  + amch1,ptxch1,ptych1,ptzch1,ech1,
662  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
663  + ptzch2,ech2
664  IF(irej.EQ.1)THEN
665  IF(ipev.GE.1)WRITE(6,'(A)')' dv cormom rej.'
666  go to 20
667  ENDIF
668  IF (amch2 .LT.3.)THEN
669  IF(ipev.GE.1)WRITE(6,'(A,F10.2)')' dv amch2',amch2
670  go to 20
671  ENDIF
672 C
673 C
674 C no test for chain 2 / mass constraint from DIQVS
675  ijnch2=0
676  nnch2=0
677  qtxch1=ptxch1
678  qtych1=ptych1
679  qtzch1=ptzch1
680  qech1=ech1
681  qtxch2=ptxch2
682  qtych2=ptych2
683  qtzch2=ptzch2
684  qech2=ech2
685  pqdva1(n,1)=ptxsq1
686  pqdva1(n,2)=ptysq1
687  pqdva1(n,3)=plq1
688  pqdva1(n,4)=eq1
689  pqdva2(n,1)=ptxsq2
690  pqdva2(n,2)=ptysq2
691  pqdva2(n,3)=plq2
692  pqdva2(n,4)=eq2
693  pqdvb1(n,1)=ptxsa2
694  pqdvb1(n,2)=ptysa2
695  pqdvb1(n,3)=plaq2
696  pqdvb1(n,4)=eaq2
697  pqdvb2(n,1)=ptxsa1
698  pqdvb2(n,2)=ptysa1
699  pqdvb2(n,3)=plaq1
700  pqdvb2(n,4)=eaq1
701 C-------------------
702 
703 C
704 C PUT D-V CHAIN ENDS INTO /HKKEVT/
705 C MOMENTA IN NN-CMS
706 C POSITION OF ORIGINAL NUCLEONS
707 C
708 **** keep for the moment the old s-v notations
709 C FLAG FOR DV-CHAIN ENDS
710 C PROJECTILE: ISTHKK=131
711 C TARGET: ISTHKK=122
712 C FOR DV-CHAINS ISTHKK=4
713 C
714  ihkkpd=jhkkps(ixspr )
715  ihkkpo=jhkkps(ixspr )-1
716  ihkktd=jhkktv(ixvta )
717  ihkkto=jhkktv(ixvta )-1
718  IF (ipev.GT.3)WRITE(6,1000)ixspr,inucpr,jnucpr,ihkkpo,ihkkpd
719  1000 FORMAT (' IXSPR,INUCPR,JNUCPR,IHKKPO,IHKKPD ',5i5)
720  IF (ipev.GT.3)WRITE(6,1010)ixvta,inucta,jnucta,ihkkto,ihkktd
721  1010 FORMAT (' IXVTA,INUCTA,JNUCTA,IHKKTO,IHKKTD ',5i5)
722 C CHAIN 1 PROJECTILE SEA-diquark
723  nhkk=nhkk+1
724  IF (nhkk.EQ.nmxhkk)THEN
725  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
726  RETURN
727  ENDIF
728  ihkk=nhkk
729  isthkk(ihkk)=131
730  idhkk(ihkk)=idhkk(ihkkpo)
731  jmohkk(1,ihkk)=ihkkpo
732  jmohkk(2,ihkk)=jmohkk(1,ihkkpo)
733  jdahkk(1,ihkk)=ihkk+2
734  jdahkk(2,ihkk)=ihkk+2
735  phkk(1,ihkk)=pqdva1(n,1)
736  phkk(2,ihkk)=pqdva1(n,2)
737  phkk(3,ihkk)=pqdva1(n,3)
738  phkk(4,ihkk)=pqdva1(n,4)
739  phkk(5,ihkk)=0.
740 C Add position of parton in hadron
741  CALL qinnuc(xxpp,yypp)
742  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
743  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
744  vhkk(3,ihkk)=vhkk(3,ihkkpo)
745  vhkk(4,ihkk)=vhkk(4,ihkkpo)
746  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
747  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
748  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
749 
750  1020 FORMAT (i6,i4,5i6,9e10.2)
751 C CHAIN 1 TARGET QUARK
752  nhkk=nhkk+1
753  IF (nhkk.EQ.nmxhkk)THEN
754  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
755  RETURN
756  ENDIF
757  ihkk=nhkk
758  isthkk(ihkk)=122
759  idhkk(ihkk)=idhkk(ihkktd)
760  jmohkk(1,ihkk)=ihkktd
761  jmohkk(2,ihkk)=jmohkk(1,ihkktd)
762  jdahkk(1,ihkk)=ihkk+1
763  jdahkk(2,ihkk)=ihkk+1
764  phkk(1,ihkk)=pqdva2(n,1)
765  phkk(2,ihkk)=pqdva2(n,2)
766  phkk(3,ihkk)=pqdva2(n,3)
767  phkk(4,ihkk)=pqdva2(n,4)
768  phkk(5,ihkk)=0.
769 C Add position of parton in hadron
770  CALL qinnuc(xxpp,yypp)
771  vhkk(1,ihkk)=vhkk(1,ihkktd)+xxpp
772  vhkk(2,ihkk)=vhkk(2,ihkktd)+yypp
773  vhkk(3,ihkk)=vhkk(3,ihkktd)
774  vhkk(4,ihkk)=vhkk(4,ihkktd)
775  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
776  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
777  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
778 
779 C
780 C CHAIN 1 BEFORE FRAGMENTATION
781  nhkk=nhkk+1
782  IF (nhkk.EQ.nmxhkk)THEN
783  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
784  RETURN
785  ENDIF
786  ihkk=nhkk
787  isthkk(ihkk)=4
788  idhkk(ihkk)=88888+nnch1
789  jmohkk(1,ihkk)=ihkk-2
790  jmohkk(2,ihkk)=ihkk-1
791  phkk(1,ihkk)=qtxch1
792  phkk(2,ihkk)=qtych1
793  phkk(3,ihkk)=qtzch1
794  phkk(4,ihkk)=qech1
795  phkk(5,ihkk)=amch1
796 C POSITION OF CREATED CHAIN IN LAB
797 C =POSITION OF TARGET NUCLEON
798 C TIME OF CHAIN CREATION IN LAB
799 C =TIME OF PASSAGE OF PROJECTILE
800 C NUCLEUS AT POSITION OF TAR. NUCLEUS
801  vhkk(1,nhkk)= vhkk(1,nhkk-1)
802  vhkk(2,nhkk)= vhkk(2,nhkk-1)
803  vhkk(3,nhkk)= vhkk(3,nhkk-1)
804  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
805  mhkkdv(n)=ihkk
806  IF (iprojk.EQ.1)THEN
807  whkk(1,nhkk)= vhkk(1,nhkk-2)
808  whkk(2,nhkk)= vhkk(2,nhkk-2)
809  whkk(3,nhkk)= vhkk(3,nhkk-2)
810  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
811  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
812  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
813  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
814 
815  ENDIF
816  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
817  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
818  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
819 
820 C
821 C
822 C CHAIN 2 projectile sea antidiquark
823  nhkk=nhkk+1
824  IF (nhkk.EQ.nmxhkk)THEN
825  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
826  RETURN
827  ENDIF
828  ihkk=nhkk
829  isthkk(ihkk)=131
830  idhkk(ihkk)=idhkk(ihkkpd)
831  jmohkk(1,ihkk)=ihkkpd
832  jmohkk(2,ihkk)=jmohkk(1,ihkkpd)
833  jdahkk(1,ihkk)=ihkk+2
834  jdahkk(2,ihkk)=ihkk+2
835  phkk(1,ihkk)=pqdvb1(n,1)
836  phkk(2,ihkk)=pqdvb1(n,2)
837  phkk(3,ihkk)=pqdvb1(n,3)
838  phkk(4,ihkk)=pqdvb1(n,4)
839  phkk(5,ihkk)=0.
840 C Add position of parton in hadron
841  CALL qinnuc(xxpp,yypp)
842  vhkk(1,ihkk)=vhkk(1,ihkkpd)+xxpp
843  vhkk(2,ihkk)=vhkk(2,ihkkpd)+yypp
844  vhkk(3,ihkk)=vhkk(3,ihkkpd)
845  vhkk(4,ihkk)=vhkk(4,ihkkpd)
846  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
847  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
848  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
849 
850 C CHAIN 2 TARGET diquark
851  nhkk=nhkk+1
852  IF (nhkk.EQ.nmxhkk)THEN
853  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
854  RETURN
855  ENDIF
856  ihkk=nhkk
857  isthkk(ihkk)=122
858  idhkk(ihkk)=idhkk(ihkkto)
859  jmohkk(1,ihkk)=ihkkto
860  jmohkk(2,ihkk)=jmohkk(1,ihkkto)
861  jdahkk(1,ihkk)=ihkk+1
862  jdahkk(2,ihkk)=ihkk+1
863  phkk(1,ihkk)=pqdvb2(n,1)
864  phkk(2,ihkk)=pqdvb2(n,2)
865  phkk(3,ihkk)=pqdvb2(n,3)
866  phkk(4,ihkk)=pqdvb2(n,4)
867  phkk(5,ihkk)=0.
868 C Add position of parton in hadron
869  CALL qinnuc(xxpp,yypp)
870  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
871  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
872  vhkk(3,ihkk)=vhkk(3,ihkkto)
873  vhkk(4,ihkk)=vhkk(4,ihkkto)
874  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
875  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
876  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
877 
878 C
879 C CHAIN 2 BEFORE FRAGMENTATION
880  nhkk=nhkk+1
881  IF (nhkk.EQ.nmxhkk)THEN
882  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
883  RETURN
884  ENDIF
885  ihkk=nhkk
886  isthkk(ihkk)=4
887  idhkk(ihkk)=88888+nnch2
888  jmohkk(1,ihkk)=ihkk-2
889  jmohkk(2,ihkk)=ihkk-1
890  phkk(1,ihkk)=qtxch2
891  phkk(2,ihkk)=qtych2
892  phkk(3,ihkk)=qtzch2
893  phkk(4,ihkk)=qech2
894  phkk(5,ihkk)=amch2
895 C POSITION OF CREATED CHAIN IN LAB
896 C =POSITION OF TARGET NUCLEON
897 C TIME OF CHAIN CREATION IN LAB
898 C =TIME OF PASSAGE OF PROJECTILE
899 C NUCLEUS AT POSITION OF TAR. NUCLEUS
900  vhkk(1,nhkk)= vhkk(1,nhkk-1)
901  vhkk(2,nhkk)= vhkk(2,nhkk-1)
902  vhkk(3,nhkk)= vhkk(3,nhkk-1)
903  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
904  mhkkdv(n)=ihkk
905  IF (iprojk.EQ.1)THEN
906  whkk(1,nhkk)= vhkk(1,nhkk-2)
907  whkk(2,nhkk)= vhkk(2,nhkk-2)
908  whkk(3,nhkk)= vhkk(3,nhkk-2)
909  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
910  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
911  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
912  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
913 
914  ENDIF
915  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
916  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
917  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
918 
919 C
920 C
921 C NOW WE HAVE AN ACCEPTABLE SEA--VALENCE EVENT
922 * sea diquark pair!
923 C AND PUT IT INTO THE HISTOGRAM
924 C
925  amcdv1(n)=amch1
926  amcdv2(n)=amch2
927  gacdv1(n)=qech1/amch1
928  bgxdv1(n)=qtxch1/amch1
929  bgydv1(n)=qtych1/amch1
930  bgzdv1(n)=qtzch1/amch1
931  gacdv2(n)=qech2/amch2
932  bgxdv2(n)=qtxch2/amch2
933  bgydv2(n)=qtych2/amch2
934  bgzdv2(n)=qtzch2/amch2
935  nchdv1(n)=nnch1
936  nchdv2(n)=nnch2
937  ijcdv1(n)=ijnch1
938  ijcdv2(n)=ijnch2
939  IF (ipev.GE.6) WRITE(6,'(A/I10,4F12.7,5I5/10X,4F12.6/10X,6F12.6,
940  +4I5/8F15.5/ 8F15.5)') ' DV / FINAL PRINT',n
941 C +, XPSQ
942 C + (IXSPR),XPSAQ(IXSPR),XTVQ(IXVTA),XTVD(IXVTA), IPSQ(IXSPR),IPSAQ
943 C + (IXSPR), ITVQ(IXVTA),ITTV1(IXVTA),ITTV2(IXVTA), AMCDV1(N),AMCDV2
944 C + (N),GACDV1(N),GACDV2(N), BGXDV1(N),BGYDV1(N),BGZDV1(N), BGXDV2
945 C + (N),BGYDV2(N),BGZDV2(N), NCHDV1(N),NCHDV2(N),IJCDV1(N),IJCDV2
946 C + (N), (PQDVA1(N,JU),PQDVA2(N,JU),PQDVB1(N,JU), PQDVB2(N,JU),JU=1,
947 C + 4)
948  10 CONTINUE
949  RETURN
950 C
951  20 CONTINUE
952 C EVENT REJECTED
953 C START A NEW ONE
954  irejdv=1
955  issqq=ipsq(ixspr)
956  jssqq=ipsq2(ixspr)
957  IF(issqq.EQ.3.AND.jssqq.EQ.3)THEN
958  idvre(3)=idvre(3)+1
959  ELSEIF(issqq.EQ.3.OR.jssqq.EQ.3)THEN
960  idvre(2)=idvre(2)+1
961  ELSE
962  idvre(1)=idvre(1)+1
963  ENDIF
964  RETURN
965  END
966 C
967 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
968 C
969 C DEBUG SUBCHK
970 C END DEBUG
971  SUBROUTINE hadrdv
972  IMPLICIT DOUBLE PRECISION (a-h,o-z)
973  SAVE
974 C-------------------------
975 C
976 C hadronize sea diquark - valence CHAINS
977 C
978 C ADD GENERATED HADRONS TO /ALLPAR/
979 C STARTING AT (NAUX + 1)
980 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
981 C
982 C---------------------------------------------------------
983  COMMON /zsea/zseaav,zseasu,anzsea
984  common/popcck/pdbck,pdbse,pdbseu,
985  * ijpock,irejck,ick4,ihad4,ick6,ihad6
986  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
987  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
988  *isea43,isea63,irejao
989 *KEEP,INTMX.
990  parameter(intmx=2488,intmd=252)
991 *KEEP,IFROTO.
992  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
993  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
994  +jhkknt
995  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
996  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
997  & mhkkhh(intmx),
998  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
999 *KEEP,DIQI.
1000  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
1001  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
1002  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
1003  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
1004 *KEEP,DXQX.
1005 C INCLUDE (XQXQ)
1006 * NOTE: INTMX set via INCLUDE(INTMX)
1007  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
1008  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
1009  * ,xpsu(248),xtsu(248)
1010  * ,xpsut(248),xtsut(248)
1011 *KEEP,INTNEW.
1012  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
1013  +ixpv,ixps,ixtv,ixts, intvv1(248),
1014  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
1015  +intss1(intmx),intss2(intmx),
1016  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
1017  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
1018 
1019 C /INTNEW/
1020 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
1021 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
1022 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
1023 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
1024 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
1025 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
1026 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
1027 C FROM PROJECTILE/TARGET NUCLEI
1028 C-------------------
1029 *KEEP,ABRDV.
1030  COMMON /abrdv/ amcdv1(248),amcdv2(248),gacdv1(248),gacdv2(248),
1031  +bgxdv1(248),bgydv1(248),bgzdv1(248), bgxdv2(248),bgydv2(248),
1032  +bgzdv2(248), nchdv1(248),nchdv2(248),ijcdv1(248),ijcdv2(248),
1033  +pqdva1(248,4),pqdva2(248,4), pqdvb1(248,4),pqdvb2(248,4)
1034 *KEEP,LOZUO.
1035  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
1036  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
1037  +intlo(intmx),inloss(intmx)
1038 C /LOZUO/
1039 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
1040 C REJECTED IN KKEVT
1041 C------------------
1042 *KEEP,HKKEVT.
1043 c INCLUDE (HKKEVT)
1044  parameter(nmxhkk= 89998)
1045 c PARAMETER (NMXHKK=25000)
1046  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
1047  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
1048  +(4,nmxhkk)
1049 C
1050 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
1051 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
1052 C THE POSITIONS OF THE PROJECTILE NUCLEONS
1053 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
1054 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
1055 C COMPLETELY CONSISTENT. THE TIMES IN THE
1056 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
1057 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
1058 C
1059 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
1060 C
1061 C NMXHKK: maximum numbers of entries (partons/particles) that can be
1062 C stored in the commonblock.
1063 C
1064 C NHKK: the actual number of entries stored in current event. These are
1065 C found in the first NHKK positions of the respective arrays below.
1066 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
1067 C entry.
1068 C
1069 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
1070 C = 0 : null entry.
1071 C = 1 : an existing entry, which has not decayed or fragmented.
1072 C This is the main class of entries which represents the
1073 C "final state" given by the generator.
1074 C = 2 : an entry which has decayed or fragmented and therefore
1075 C is not appearing in the final state, but is retained for
1076 C event history information.
1077 C = 3 : a documentation line, defined separately from the event
1078 C history. (incoming reacting
1079 C particles, etc.)
1080 C = 4 - 10 : undefined, but reserved for future standards.
1081 C = 11 - 20 : at the disposal of each model builder for constructs
1082 C specific to his program, but equivalent to a null line in the
1083 C context of any other program. One example is the cone defining
1084 C vector of HERWIG, another cluster or event axes of the JETSET
1085 C analysis routines.
1086 C = 21 - : at the disposal of users, in particular for event tracking
1087 C in the detector.
1088 C
1089 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
1090 C standard.
1091 C
1092 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
1093 C The value is 0 for initial entries.
1094 C
1095 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
1096 C one mother exist, in which case the value 0 is used. In cluster
1097 C fragmentation models, the two mothers would correspond to the q
1098 C and qbar which join to form a cluster. In string fragmentation,
1099 C the two mothers of a particle produced in the fragmentation would
1100 C be the two endpoints of the string (with the range in between
1101 C implied).
1102 C
1103 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
1104 C entry has not decayed, this is 0.
1105 C
1106 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
1107 C entry has not decayed, this is 0. It is assumed that the daughters
1108 C of a particle (or cluster or string) are stored sequentially, so
1109 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
1110 C daughters. Even in cases where only one daughter is defined (e.g.
1111 C K0 -> K0S) both values should be defined, to make for a uniform
1112 C approach in terms of loop constructions.
1113 C
1114 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
1115 C
1116 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
1117 C
1118 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
1119 C
1120 C PHKK(4,IHKK) : energy, in GeV.
1121 C
1122 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
1123 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
1124 C
1125 C VHKK(1,IHKK) : production vertex x position, in mm.
1126 C
1127 C VHKK(2,IHKK) : production vertex y position, in mm.
1128 C
1129 C VHKK(3,IHKK) : production vertex z position, in mm.
1130 C
1131 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
1132 C********************************************************************
1133 *KEEP,DFINPA.
1134  CHARACTER*8 anf
1135  parameter(nfimax=249)
1136  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
1137  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
1138  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
1139  * istath(nfimax)
1140 *KEEP,DPRIN.
1141  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1142 *KEEP,PROJK.
1143  COMMON /projk/ iprojk
1144 *KEND.
1145  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1146 C modified DPMJET
1147  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
1148  * anndv,annvd,annds,annsd,
1149  * annhh,annzz,
1150  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
1151  * pthh,ptzz,
1152  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
1153  * eehh,eezz
1154  * ,anndi,ptdi,eedi
1155  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
1156  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
1157  * acouzz,acouhh,acouds,acousd,
1158  * acoudz,acouzd,acoudi,
1159  * acoudv,acouvd,acoucc
1160  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
1161  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
1162  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
1163  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
1164  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
1165  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
1166 C---------------------
1167  dimension poj(4),pat(4)
1168  DATA ncaldv /0/
1169  IF(iphkk.GE.6)WRITE (6,'( A)') ' hadrdv'
1170 C-----------------------------------------------------------------------
1171  ncaldv=ncaldv+1
1172  DO 50 i=1,ndv
1173 C-----------------------drop recombined chain pairs
1174  IF(nchdv1(i).EQ.99.AND.nchdv2(i).EQ.99) go to 50
1175  is1=intdv1(i)
1176  is2=intdv2(i)
1177  IF(ipco.GE.3)WRITE(6,*)' hadrdv I IS1,IS2 ',i,is1,is2
1178 C
1179  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itvq(is2),
1180  + ittv1(is2),ittv2(is2), amcdv1(i),amcdv2(i),gacdv1(i),gacdv2(i),
1181  + bgxdv1(i),bgydv1(i),bgzdv1(i), bgxdv2(i),bgydv2(i),bgzdv2(i),
1182  + nchdv1(i),nchdv2(i),ijcdv1(i),ijcdv2(i), pqdva1(i,4),pqdva2
1183  + (i,4),pqdvb1(i,4),pqdvb2(i,4)
1184  1000 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
1185 C
1186 C++++++++++++++++++++++++++++++ CHAIN 1: diquark-quark +++++++++++
1187  ifb1=ipsq(is1)
1188  ifb2=ipsq2(is1)
1189  ifb3=itvq(is2)
1190  DO 10 j=1,4
1191  poj(j)=pqdva1(i,j)
1192  pat(j)=pqdva2(i,j)
1193  10 CONTINUE
1194  IF((nchdv1(i).NE.0.OR.nchdv2(i).NE.0).AND.ip.NE.1)
1195  & CALL saptre(amcdv1(i),gacdv1(i),bgxdv1(i),bgydv1(i),bgzdv1(i),
1196  & amcdv2(i),gacdv2(i),bgxdv2(i),bgydv2(i),bgzdv2(i))
1197 C----------------------------------------------------------------
1198 C WRITE (6,1244) POJ,PAT
1199 C1244 FORMAT (' D-V QUARK-DIQUARK POJ,PAT ',8E12.3)
1200 C------------------------------------------------------------------
1201 C check bookkeeping
1202 C-----------------------------------------------------------------
1203 C I= number of valence chain
1204 C Projectile Nr ippp= IFROVP(INTVS1(I))
1205 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
1206  IF(ipco.GE.3)WRITE(6,*)' INTDV1(I) ',intdv1(i)
1207 C IPPP = IFROVP(INTVS1(I))
1208 C IPPP = IFROVP(INTDV1(I))
1209  IF(intdv1(i).GE.1)THEN
1210  ipppp = ifrosp(intdv1(i))
1211  ELSE
1212  ipppp=0
1213  ENDIF
1214  IF(ipco.GE.3)WRITE(6,*)' IPPP,IPPPP ',ippp,ipppp
1215  IF(ipppp.GE.1)THEN
1216  jipp=jsshs(ipppp)
1217  ELSE
1218  jipp=0
1219  ENDIF
1220 C JIPP=1
1221  IF(ipco.GE.3)WRITE(6,*)' JIPP ',jipp
1222 C IF(NCHVS2(I).EQ.0)THEN
1223  IF(ipco.GE.3)WRITE(6,'(A,3I5)')'HADRVS: I,IPPP,JIPP ',
1224  * i,ippp,jipp
1225 C ENDIF
1226 C------------------------------------------------------------------
1227 C check bookkeeping
1228 C-----------------------------------------------------------------
1229  IF(ifb1.LE.2.AND.ifb2.LE.2)THEN
1230  ndvuu=ndvuu+1
1231  ELSEIF((ifb1.EQ.3.AND.ifb2.LE.2).OR.
1232  * (ifb2.EQ.3.AND.ifb1.LE.2))THEN
1233  ndvus=ndvus+1
1234  ELSEIF(ifb1.EQ.3.AND.ifb2.EQ.3)THEN
1235  ndvss=ndvss+1
1236  ENDIF
1237  IF (nchdv1(i).NE.0)
1238  * CALL hadjet(nhad,amcdv1(i),poj,pat,gacdv1(i),
1239  * bgxdv1(i), bgydv1
1240  + (i),bgzdv1(i),ifb1,ifb2,ifb3,ifb4, ijcdv1(i),
1241  * ijcdv1(i),6,nchdv1
1242  + (i),11)
1243 C--------------------------------------------------------------------
1244  zseawu=rndm(bb)*2.d0*zseaav
1245  rseack=float(jipp)*pdbse +zseawu*pdbseu
1246  IF(ipco.GE.1)WRITE(6,*)'HADJSE JIPP,RSEACK,PDBSE 1 dpmnuc5',
1247  + jipp,rseack,pdbse
1248 C--------------------------------------------------------------------
1249  IF(nchdv1(i).EQ.0)THEN
1250 C---------------------------------------------------------------------
1251  irejss=5
1252  IF(rndm(v).LE.rseack)THEN
1253  irejss=2
1254  IF(amcdv1(i).GT.2.3d0)THEN
1255  irejss=0
1256  CALL hadjse(nhad,amcdv1(i),poj,pat,gacdv1(i),bgxdv1(i),
1257  * bgydv1
1258  + (i),bgzdv1(i),ifb1,ifb2,ifb3,ifb4, ijcdv1(i),ijcdv1(i),6,
1259  * nchdv1
1260  + (i),6,irejss,iissqq)
1261  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JIPP,',
1262  * 'RSEACK,IREJSS 1 dpmnuc5 ',
1263  + jipp,rseack,irejss
1264  ENDIF
1265  IF(irejss.GE.1)THEN
1266  IF(irejss.EQ.1)irejse=irejse+1
1267  IF(irejss.EQ.3)irejs3=irejs3+1
1268  IF(irejss.EQ.2)irejs0=irejs0+1
1269  CALL hadjet(nhad,amcdv1(i),poj,pat,gacdv1(i),
1270  * bgxdv1(i), bgydv1
1271  + (i),bgzdv1(i),ifb1,ifb2,ifb3,ifb4, ijcdv1(i),
1272  * ijcdv1(i),6,nchdv1
1273  + (i),11)
1274  ihad6=ihad6+1
1275  ENDIF
1276  IF(irejss.EQ.0)THEN
1277  IF(iissqq.EQ.3)THEN
1278  ise63=ise63+1
1279  ELSE
1280  ise6=ise6+1
1281  ENDIF
1282  ENDIF
1283  ELSE
1284  CALL hadjet(nhad,amcdv1(i),poj,pat,gacdv1(i),
1285  * bgxdv1(i), bgydv1
1286  + (i),bgzdv1(i),ifb1,ifb2,ifb3,ifb4, ijcdv1(i),
1287  * ijcdv1(i),6,nchdv1
1288  + (i),11)
1289  ihad6=ihad6+1
1290  ENDIF
1291  ENDIF
1292 C--------------------------------------------------------------------
1293  acoudv=acoudv+1
1294  nhkkau=nhkk+1
1295  DO 20 j=1,nhad
1296  IF (nhkk.EQ.nmxhkk) THEN
1297  WRITE (6,'(A,2I5/A)') .EQ.' HADRDV: NHKKNMXHKK ',nhkk,nmxhkk
1298  RETURN
1299  ENDIF
1300 C NHKK=NHKK+1
1301  IF (nhkk.EQ.nmxhkk)THEN
1302  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
1303  RETURN
1304  ENDIF
1305 C
1306  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
1307  IF (abs(ehecc-hef(j)).GT.0.001) THEN
1308 C WRITE(6,'(2A/3I5,3E15.6)')
1309 C & ' HADRDV / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
1310 C * ' NCALDV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
1311 C * NCALDV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
1312  hef(j)=ehecc
1313  ENDIF
1314  anndv=anndv+1
1315  eedv=eedv+hef(j)
1316  ptdv=ptdv+sqrt(pxf(j)**2+pyf(j)**2)
1317 C PUT NN-CMS HADRONS INTO /HKKEVT/
1318  istist=1
1319  IF(ibarf(j).EQ.500)istist=2
1320  CALL hkkfil(istist,mpdgha(nref(j)),mhkkdv(i)-3,0,
1321  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),13)
1322  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
1323  + (nhkk)
1324  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
1325  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
1326  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
1327 
1328  20 CONTINUE
1329 C IF(NHAD.GT.0) THEN
1330 C JDAHKK(1,IMOHKK)=NHKKAU
1331 C JDAHKK(2,IMOHKK)=NHKK
1332 C ENDIF
1333 C+++++++++++++++++++++++++++++ CHAIN 2: adiquark - diquark +++++++++
1334  ifb1=ipsaq(is1)
1335  ifb2=ipsaq2(is1)
1336  ifb3=ittv1(is2)
1337  ifb4=ittv2(is2)
1338  ifb1=iabs(ifb1)+6
1339  ifb2=iabs(ifb2)+6
1340  DO 30 j=1,4
1341  poj(j)=pqdvb2(i,j)
1342  pat(j)=pqdvb1(i,j)
1343  30 CONTINUE
1344 C
1345  IF(ifb1.LE.8.AND.ifb2.LE.8)THEN
1346  nadvuu=nadvuu+1
1347  ELSEIF((ifb1.EQ.9.AND.ifb2.LE.8).OR.
1348  * (ifb2.EQ.9.AND.ifb1.LE.8))THEN
1349  nadvus=nadvus+1
1350  ELSEIF(ifb1.EQ.9.AND.ifb2.EQ.9)THEN
1351  nadvss=nadvss+1
1352  ENDIF
1353  CALL hadjet(nhad,amcdv2(i),poj,pat,gacdv2(i),
1354  * bgxdv2(i), bgydv2
1355  + (i),bgzdv2(i),ifb1,ifb2,ifb3,ifb4, ijcdv2(i),
1356  * ijcdv2(i),5,nchdv2
1357  + (i),12)
1358 C ADD HADRONS/RESONANCES INTO
1359 C COMMON /ALLPAR/ STARTING AT NAUX
1360  nhkkau=nhkk+1
1361  DO 40 j=1,nhad
1362  IF (nhkk.EQ.nmxhkk) THEN
1363  WRITE (6,'(A,2I5/A)') .EQ.' HADRDV: NHKKNMXHKK ', nhkk,
1364  + nmxhkk
1365  RETURN
1366  ENDIF
1367 C NHKK=NHKK+1
1368  IF (nhkk.EQ.nmxhkk)THEN
1369  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
1370  RETURN
1371  ENDIF
1372 C
1373  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
1374  IF (abs(ehecc-hef(j)).GT.0.001) THEN
1375 C WRITE(6,'(2A/3I5,3E15.6)')
1376 C & ' HADRDV / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
1377 C * ' NCALDV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
1378 C * NCALDV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
1379  hef(j)=ehecc
1380  ENDIF
1381  anndv=anndv+1
1382  eedv=eedv+hef(j)
1383  ptdv=ptdv+sqrt(pxf(j)**2+pyf(j)**2)
1384 C PUT NN-CMS HADRONS INTO /HKKEVT/
1385  istist=1
1386  IF(ibarf(j).EQ.500)istist=2
1387  CALL hkkfil(istist,mpdgha(nref(j)),mhkkdv(i),0,
1388  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),14)
1389  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
1390  + (nhkk)
1391  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
1392  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
1393  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
1394 
1395  40 CONTINUE
1396 C IF(NHAD.GT.0) THEN
1397 C JDAHKK(1,IMOHKK)=NHKKAU
1398 C JDAHKK(2,IMOHKK)=NHKK
1399 C ENDIF
1400  50 CONTINUE
1401 C----------------------------------------------------------------
1402 C
1403  RETURN
1404  1010 FORMAT (i6,i4,5i6,9e10.2)
1405  1020 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
1406  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
1407  END
1408 C
1409 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1410 C
1411  SUBROUTINE diqvs(ECM,IPV,J,IREJ)
1412  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1413  SAVE
1414 * define v-d chains (valence - sea diquark chains)
1415 * q-sqsq and qq-saqsaq chains instead of qq-sq and q-saq chains
1416  COMMON /zsea/zseaav,zseasu,anzsea
1417  common/popcck/pdbck,pdbse,pdbseu,
1418  * ijpock,irejck,ick4,ihad4,ick6,ihad6
1419  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
1420  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
1421  *isea43,isea63,irejao
1422 *KEEP,INTMX.
1423  parameter(intmx=2488,intmd=252)
1424 *KEEP,IFROTO.
1425  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
1426  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
1427  +jhkknt
1428  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
1429  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
1430  & mhkkhh(intmx),
1431  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
1432 *KEEP,DIQI.
1433  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
1434  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
1435  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
1436  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
1437 *KEEP,DXQX.
1438 C INCLUDE (XQXQ)
1439 * NOTE: INTMX set via INCLUDE(INTMX)
1440  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
1441  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
1442  * ,xpsu(248),xtsu(248)
1443  * ,xpsut(248),xtsut(248)
1444 *KEEP,INTNEW.
1445  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
1446  +ixpv,ixps,ixtv,ixts, intvv1(248),
1447  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
1448  +intss1(intmx),intss2(intmx),
1449  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
1450  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
1451 
1452 C /INTNEW/
1453 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
1454 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
1455 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
1456 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
1457 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
1458 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
1459 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
1460 C FROM PROJECTILE/TARGET NUCLEI
1461 C-------------------
1462 *KEEP,ABRVD.
1463  COMMON /abrvd/ amcvd1(248),amcvd2(248),gacvd1(248),gacvd2(248),
1464  +bgxvd1(248),bgyvd1(248),bgzvd1(248), bgxvd2(248),bgyvd2(248),
1465  +bgzvd2(248), nchvd1(248),nchvd2(248),ijcvd1(248),ijcvd2(248),
1466  +pqvda1(248,4),pqvda2(248,4), pqvdb1(248,4),pqvdb2(248,4)
1467 *KEND.
1468  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1469  common/seasu3/seasq
1470  COMMON /xseadi/ xseacu,unon,unom,unosea, cvq,cdq,csea,ssmima,
1471  +ssmimq,vvmthr
1472  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
1473  *idzre(3),izdre(3),idiqrz(7)
1474  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
1475  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
1476  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
1477  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
1478  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
1479  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
1480 C-----------------------------------------------------------------------
1481 C COMMON /PCHARM/PCCCC
1482  parameter(ummm=0.3d0)
1483  parameter(smmm=0.5d0)
1484  parameter(cmmm=1.3d0)
1485  DATA pc/0.0001d0/
1486 *KEND.
1487 C----------
1488 C
1489  DATA inicha/0/
1490 C----------------------------------------------------------------------
1491 C Initialize Charm selection at soft chain ends
1492 C
1493  IF(inicha.EQ.0)THEN
1494  rx=8.d0
1495  x1=rx
1496  gm=2.140d0
1497  x2=ummm
1498  betoo=7.5d0
1499  ENDIF
1500  rx=8.d0
1501  x1=rx
1502  betcha=betoo+1.3d0-log10(ecm)
1503  pu=dbeta(x1,x2,betcha)
1504  x2=smmm
1505  ps=dbeta(x1,x2,betcha)
1506  x2=cmmm
1507  pc=dbeta(x1,x2,betcha)
1508 C PU1=PU/(2*PU+PS+PC)
1509 C PS1=PS/(2*PU+PS+PC)
1510  pc1=pc/(2*pu+ps+pc)
1511 C changed j.r.7.12.94
1512 C PC=PC1/2.9
1513 C changed j.r.14.12.94
1514 C PC=PC1/5.0
1515 C PC=PC1/10.0
1516  pc=pc1/7.0d0
1517  pu1=pu/(2*pu+ps+pc)
1518  ps1=ps/(2*pu+ps+pc)
1519  IF(inicha.EQ.0)THEN
1520  inicha=1
1521  WRITE(6,4567)pc,betcha,pu1,ps1,seasq
1522  4567 FORMAT(' Charm chain ends DIQVS: PC,BETCHA,PU,PS,SEASQ ',5f10.5)
1523  ENDIF
1524 C----------------------------------------------------------------------
1525  IF(iphkk.GE.6)WRITE (6,'( A,2I10)') ' diqvs IPV,J ',ipv,j
1526  irej=0
1527 * kinematics: is the mass of both chains big enough
1528 * to allow for fragmentation
1529  itsq2(j)=1.d0+rndm(v1)*(2.d0+2.d0*seasq)
1530  rr=rndm(v)
1531  IF(rr.LT.pc)itsq2(j)=4
1532 C-----------------------------------------------------------------------
1533  itsaq2(j)=-itsq2(j)
1534 C---------------------------------------------------j.r.29.4.94
1535 C x**1.5 distr for sea diquarks
1536 C number of target nucleon
1537  inucta=ifrost(j)
1538 C number of target diquark
1539  iitot=itovt(inucta)
1540 C diquark x
1541  xtdiqu=xtvd(iitot)
1542 C minimal value of diquark x
1543  xdthr=cdq/ecm
1544 C
1545  xdfree=xtdiqu-xdthr
1546  xall=xdfree+xtsq(j)+xtsaq(j)-2.*xdthr
1547  xdalt=xtvd(iitot)
1548  xsalt=xtsq(j)
1549  xaalt=xtsaq(j)
1550  IF(xall.GE.0.)THEN
1551  rr1=rndm(v1)
1552  rr2=rndm(v2)
1553  rr3=rndm(v3)
1554  sr123=rr1+rr2+rr3
1555  dx1=rr1*xall/sr123
1556  dx2=rr2*xall/sr123
1557  dx3=rr3*xall/sr123
1558  xtvd(iitot)=xdthr+dx1
1559  xtsq(j)=xdthr+dx2
1560  xtsaq(j)=xdthr+dx3
1561  ENDIF
1562 C--------------------------------------------------------------
1563 
1564  amvdq1=xtsq(j)*xpvq(ipv)*ecm**2
1565  amvdq2=xtsaq(j)*xpvd(ipv)*ecm**2
1566  idiqre(1)=idiqre(1)+1
1567  IF(itsq(j).GE.3.AND.itsq2(j).GE.3)THEN
1568  idiqre(2)=idiqre(2)+1
1569 C IF(AMVDQ2.LE.9.0.OR.AMVDQ1.LE.2.30) THEN
1570  IF(amvdq2.LE.17.0d0.OR.amvdq1.LE.6.60d0) THEN
1571  irej=1
1572  idiqre(3)=idiqre(3)+1
1573  idiqre(2)=idiqre(2)-1
1574  idiqre(1)=idiqre(1)-1
1575  xtvd(iitot)=xdalt
1576  xtsq(j)=xsalt
1577  xtsaq(j)=xaalt
1578  RETURN
1579  ENDIF
1580  ELSEIF(itsq(j).GE.3.OR.itsq2(j).GE.3)THEN
1581  idiqre(4)=idiqre(4)+1
1582 C IF(AMVDQ2.LE.7.3D0.OR.AMVDQ1.LE.1.90D0) THEN
1583  IF(amvdq2.LE.13.6.OR.amvdq1.LE.5.80) THEN
1584  irej=1
1585  idiqre(5)=idiqre(5)+1
1586  idiqre(4)=idiqre(4)-1
1587  idiqre(1)=idiqre(1)-1
1588  xtvd(iitot)=xdalt
1589  xtsq(j)=xsalt
1590  xtsaq(j)=xaalt
1591  RETURN
1592  ENDIF
1593  ELSE
1594  idiqre(6)=idiqre(6)+1
1595 C IF(AMVDQ2.LE.6.70.OR.AMVDQ1.LE.1.50) THEN
1596  IF(amvdq2.LE.12.40d0.OR.amvdq1.LE.3.9d0) THEN
1597  irej=1
1598  idiqre(7)=idiqre(7)+1
1599  idiqre(6)=idiqre(6)-1
1600  idiqre(1)=idiqre(1)-1
1601  xtvd(iitot)=xdalt
1602  xtsq(j)=xsalt
1603  xtsaq(j)=xaalt
1604  RETURN
1605  ENDIF
1606  ENDIF
1607  nvd=nvd+1
1608 c WRITE(6,'(A/5X,3F10.3,3I5/5X,3F10.3)')
1609 c + ' DIQVS: AMVDQ1, XTSQ, XPVQ, IPV,J, NVD/ AMVDQ2, XTSAQ, XPVD',
1610 c + AMVDQ1,XTSQ(J),XPVQ(IPV),IPV,J, NVD, AMVDQ2,XTSAQ(J),XPVD(IPV)
1611  nchvd1(nvd)=0
1612  nchvd2(nvd)=0
1613  intvd1(nvd)=ipv
1614  intvd2(nvd)=j
1615  RETURN
1616  END
1617 C
1618 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1619 C
1620 C DEBUG SUBCHK
1621 C END DEBUG
1622  SUBROUTINE kkevvd(IREJVD)
1623  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1624  SAVE
1625 C
1626 C------------------ treatment of valence - sea diquark CHAIN SYSTEMS
1627 C
1628  COMMON /zsea/zseaav,zseasu,anzsea
1629  common/popcck/pdbck,pdbse,pdbseu,
1630  * ijpock,irejck,ick4,ihad4,ick6,ihad6
1631  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
1632  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
1633  *isea43,isea63,irejao
1634 *KEEP,INTMX.
1635  parameter(intmx=2488,intmd=252)
1636 *KEEP,HKKEVT.
1637 c INCLUDE (HKKEVT)
1638  parameter(nmxhkk= 89998)
1639 c PARAMETER (NMXHKK=25000)
1640  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
1641  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
1642  +(4,nmxhkk)
1643 C
1644 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
1645 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
1646 C THE POSITIONS OF THE PROJECTILE NUCLEONS
1647 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
1648 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
1649 C COMPLETELY CONSISTENT. THE TIMES IN THE
1650 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
1651 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
1652 C
1653 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
1654 C
1655 C NMXHKK: maximum numbers of entries (partons/particles) that can be
1656 C stored in the commonblock.
1657 C
1658 C NHKK: the actual number of entries stored in current event. These are
1659 C found in the first NHKK positions of the respective arrays below.
1660 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
1661 C entry.
1662 C
1663 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
1664 C = 0 : null entry.
1665 C = 1 : an existing entry, which has not decayed or fragmented.
1666 C This is the main class of entries which represents the
1667 C "final state" given by the generator.
1668 C = 2 : an entry which has decayed or fragmented and therefore
1669 C is not appearing in the final state, but is retained for
1670 C event history information.
1671 C = 3 : a documentation line, defined separately from the event
1672 C history. (incoming reacting
1673 C particles, etc.)
1674 C = 4 - 10 : undefined, but reserved for future standards.
1675 C = 11 - 20 : at the disposal of each model builder for constructs
1676 C specific to his program, but equivalent to a null line in the
1677 C context of any other program. One example is the cone defining
1678 C vector of HERWIG, another cluster or event axes of the JETSET
1679 C analysis routines.
1680 C = 21 - : at the disposal of users, in particular for event tracking
1681 C in the detector.
1682 C
1683 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
1684 C standard.
1685 C
1686 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
1687 C The value is 0 for initial entries.
1688 C
1689 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
1690 C one mother exist, in which case the value 0 is used. In cluster
1691 C fragmentation models, the two mothers would correspond to the q
1692 C and qbar which join to form a cluster. In string fragmentation,
1693 C the two mothers of a particle produced in the fragmentation would
1694 C be the two endpoints of the string (with the range in between
1695 C implied).
1696 C
1697 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
1698 C entry has not decayed, this is 0.
1699 C
1700 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
1701 C entry has not decayed, this is 0. It is assumed that the daughters
1702 C of a particle (or cluster or string) are stored sequentially, so
1703 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
1704 C daughters. Even in cases where only one daughter is defined (e.g.
1705 C K0 -> K0S) both values should be defined, to make for a uniform
1706 C approach in terms of loop constructions.
1707 C
1708 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
1709 C
1710 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
1711 C
1712 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
1713 C
1714 C PHKK(4,IHKK) : energy, in GeV.
1715 C
1716 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
1717 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
1718 C
1719 C VHKK(1,IHKK) : production vertex x position, in mm.
1720 C
1721 C VHKK(2,IHKK) : production vertex y position, in mm.
1722 C
1723 C VHKK(3,IHKK) : production vertex z position, in mm.
1724 C
1725 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
1726 C********************************************************************
1727 *KEEP,IFROTO.
1728  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
1729  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
1730  +jhkknt
1731  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
1732  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
1733  & mhkkhh(intmx),
1734  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
1735 *KEEP,DIQI.
1736  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
1737  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
1738  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
1739  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
1740 *KEEP,INTNEW.
1741  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
1742  +ixpv,ixps,ixtv,ixts, intvv1(248),
1743  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
1744  +intss1(intmx),intss2(intmx),
1745  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
1746  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
1747 
1748 C /INTNEW/
1749 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
1750 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
1751 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
1752 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
1753 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
1754 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
1755 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
1756 C FROM PROJECTILE/TARGET NUCLEI
1757 C-------------------
1758 *KEEP,ABRVD.
1759  COMMON /abrvd/ amcvd1(248),amcvd2(248),gacvd1(248),gacvd2(248),
1760  +bgxvd1(248),bgyvd1(248),bgzvd1(248), bgxvd2(248),bgyvd2(248),
1761  +bgzvd2(248), nchvd1(248),nchvd2(248),ijcvd1(248),ijcvd2(248),
1762  +pqvda1(248,4),pqvda2(248,4), pqvdb1(248,4),pqvdb2(248,4)
1763 *KEEP,DXQX.
1764 C INCLUDE (XQXQ)
1765 * NOTE: INTMX set via INCLUDE(INTMX)
1766  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
1767  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
1768  * ,xpsu(248),xtsu(248)
1769  * ,xpsut(248),xtsut(248)
1770  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
1771  *idzre(3),izdre(3),idiqrz(7)
1772 *KEEP,LOZUO.
1773  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
1774  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
1775  +intlo(intmx),inloss(intmx)
1776 C /LOZUO/
1777 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
1778 C REJECTED IN KKEVT
1779 C------------------
1780 *KEEP,TRAFOP.
1781  COMMON /trafop/ gamp,bgamp,betp
1782 *KEEP,NUCIMP.
1783  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
1784  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
1785  +prebin,taebin,fermod,etacou
1786 *KEEP,FERMI.
1787  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
1788  +(4,248)
1789 *KEEP,DPAR.
1790 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1791 C ANAME = LITERAL NAME OF THE PARTICLE
1792 C AAM = PARTICLE MASS IN GEV
1793 C GA = DECAY WIDTH
1794 C TAU = LIFE TIME OF INSTABLE PARTICLES
1795 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1796 C IIBAR = BARYON NUMBER
1797 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1798 C
1799  CHARACTER*8 aname
1800  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1801  +iibar(210),k1(210),k2(210)
1802 C------------------
1803 *KEEP,DPRIN.
1804  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1805 *KEEP,REJEC.
1806  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
1807  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
1808  +irvs14, irvv11,irvv12,irvv13,irvv14
1809 *KEEP,PROJK.
1810  COMMON /projk/ iprojk
1811  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1812  common/rptshm/rproj,rtarg,bimpac
1813  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
1814  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
1815  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
1816  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
1817  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
1818  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
1819 *KEND.
1820 C-------------------
1821  IF(iphkk.GE.6)WRITE (6,'( A)') ' kkevvd'
1822  irejvd=0
1823  DO 10 n=1,nvd
1824 C---------------------------drop recombined chain pairs
1825  IF(nchvd1(n).EQ.99.AND.nchvd2(n).EQ.99)go to 10
1826 C
1827 C*** 4-MOMENTA OF projectile QUARK-DIQUARK PAIRS IN NN-CMS
1828  ixvpr=intvd1(n)
1829  inucpr=ifrovp(ixvpr)
1830  jnucpr=itovp(inucpr)
1831 C
1832  pvqpx=xpvq(ixvpr)*prmom(1,inucpr)
1833  pvqpy=xpvq(ixvpr)*prmom(2,inucpr)
1834  pvqpz=xpvq(ixvpr)*prmom(3,inucpr)
1835  pvqe=xpvq(ixvpr)*prmom(4,inucpr)
1836  pvdqpx=xpvd(ixvpr)*prmom(1,inucpr)
1837  pvdqpy=xpvd(ixvpr)*prmom(2,inucpr)
1838  pvdqpz=xpvd(ixvpr)*prmom(3,inucpr)
1839  pvdqe=xpvd(ixvpr)*prmom(4,inucpr)
1840 C
1841 C*** 4-MOMENTA OF TARGET QUARK-DIQUARK PAIRS IN NN-CMS
1842  ixsta=intvd2(n)
1843  inucta=ifrost(ixsta)
1844  jnucta=itovt(inucta)
1845 *
1846  tsqpx=xtsq(ixsta)*tamom(1,inucta)
1847  tsqpy=xtsq(ixsta)*tamom(2,inucta)
1848  tsqpz=xtsq(ixsta)*tamom(3,inucta)
1849  tsqe=xtsq(ixsta)*tamom(4,inucta)
1850  tsaqpx=xtsaq(ixsta)*tamom(1,inucta)
1851  tsaqpy=xtsaq(ixsta)*tamom(2,inucta)
1852  tsaqpz=xtsaq(ixsta)*tamom(3,inucta)
1853  tsaqe=xtsaq(ixsta)*tamom(4,inucta)
1854 C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
1855 C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
1856 C j.r.6.5.93
1857 C
1858 C multiple scattering of VALENCE quark chain ends
1859 C
1860  IF(it.GT.1)THEN
1861  itnu=ip+inucta
1862  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
1863  rtiy=vhkk(2,itnu)*1.e12
1864  rtiz=vhkk(3,itnu)*1.e12
1865  CALL cromsc(pvqpx,pvqpy,pvqpz,pvqe,rtix,rtiy,rtiz,
1866  * pvqnx,pvqny,pvqnz,pvqne,55)
1867  pvqpx=pvqnx
1868  pvqpy=pvqny
1869  pvqpz=pvqnz
1870  pvqe=pvqne
1871  CALL cromsc(pvdqpx,pvdqpy,pvdqpz,pvdqe,rtix,rtiy,rtiz,
1872  * pvdqnx,pvdqny,pvdqnz,pvdqne,56)
1873  pvdqpx=pvdqnx
1874  pvdqpy=pvdqny
1875  pvdqpz=pvdqnz
1876  pvdqe=pvdqne
1877 C ---------
1878 C j.r.6.5.93
1879 C
1880 C multiple scattering of sea quark chain ends
1881 C
1882  itnu=ip+inucta
1883  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
1884  rtiy=vhkk(2,itnu)*1.e12
1885  rtiz=vhkk(3,itnu)*1.e12
1886  CALL cromsc(tsqpx,tsqpy,tsqpz,tsqe,rtix,rtiy,rtiz,
1887  * tsqnx,tsqny,tsqnz,tsqne,57)
1888  tsqpx=tsqnx
1889  tsqpy=tsqny
1890  tsqpz=tsqnz
1891  tsqe=tsqne
1892  CALL cromsc(tsaqpx,tsaqpy,tsaqpz,tsaqe,rtix,rtiy,rtiz,
1893  * tsaqnx,tsaqny,tsaqnz,tsaqne,58)
1894  tsaqpx=tsaqnx
1895  tsaqpy=tsaqny
1896  tsaqpz=tsaqnz
1897  tsaqe=tsaqne
1898  ENDIF
1899 C ---------
1900 C ---------
1901 C j.r.10.5.93
1902  IF(ip.GE.0)go to 1779
1903  pvqpz2=pvqe**2-pvqpx**2-pvqpy**2
1904  IF(pvqpz2.GE.0.)THEN
1905  pvqpz=sqrt(pvqpz2)
1906  ELSE
1907  pvqpx=0.
1908  pvqpy=0.
1909  pvqpz=pvqe
1910  ENDIF
1911 C
1912  pdqpz2=pvdqe**2-pvdqpx**2-pvdqpy**2
1913  IF(pdqpz2.GE.0.)THEN
1914  pvdqpz=sqrt(pdqpz2)
1915  ELSE
1916  pvdqpx=0.
1917  pvdqpy=0.
1918  pvdqpz=pvdqe
1919  ENDIF
1920 C
1921  tsqpz2=tsqe**2-tsqpx**2-tsqpy**2
1922  IF(tsqpz2.GE.0.)THEN
1923  tsqpz=-sqrt(tsqpz2)
1924  ELSE
1925  tsqpx=0.
1926  tsqpy=0.
1927  tsqpz=tsqe
1928  ENDIF
1929 C
1930  taqpz2=tsaqe**2-tsaqpx**2-tsaqpy**2
1931  IF(taqpz2.GE.0.)THEN
1932  tsaqpz=-sqrt(taqpz2)
1933  ELSE
1934  tsaqpx=0.
1935  tsaqpy=0.
1936  tsaqpz=tsaqe
1937  ENDIF
1938  1779 CONTINUE
1939 C ----------------
1940 C changej.r.6.5.93
1941  ptxsq1=0.
1942  ptxsa1=0.
1943  ptxsq2=0.
1944  ptxsa2=0.
1945  ptysq1=0.
1946  ptysa1=0.
1947  ptysq2=0.
1948  ptysa2=0.
1949  ptxsq1=pvqpx
1950  ptxsa1=pvdqpx
1951  ptxsq2=tsqpx
1952  ptxsa2=tsaqpx
1953  ptysq1=pvqpy
1954  ptysa1=pvdqpy
1955  ptysq2=tsqpy
1956  ptysa2=tsaqpy
1957  plq1=pvqpz
1958  plaq1=pvdqpz
1959  plq2=tsqpz
1960  plaq2=tsaqpz
1961  eq1=pvqe
1962  eaq1=pvdqe
1963  eq2=tsqe
1964  eaq2=tsaqe
1965 C ---------------
1966 C
1967 C*** SAMPLE PARTON-PT VALUES / DETERMINE PARTON 4-MOMENTA AND CHAIN MAS
1968 C*** IN THE REST FRAME DEFINED ABOVE
1969 C
1970  ikvala=0
1971  IF(ipev.GE.2) THEN
1972  WRITE(6,'(A,I5)') ' KKEVVD - IRVD13=',irvd13
1973  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
1974  + ' VD: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
1975  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
1976  + amch1,amch2,irej,ikvala,pttq1,ptta1
1977  ENDIF
1978  ikvala=0
1979  nselpt=1
1980  nselpt=0
1981  IF(ip.EQ.1)nselpt=1
1982  IF(nselpt.EQ.1)CALL selpt(ptxsq1,ptysq1,plq1,
1983  + eq1,ptxsa1,ptysa1,plaq1,eaq1,
1984  + ptxsa2,ptysa2,plaq2,eaq2,
1985  + ptxsq2,ptysq2,plq2,eq2,
1986  + amch1,amch2,irej,ikvala,pttq1,ptta1,
1987  * pttq2,ptta2,
1988  * nselpt)
1989  IF(nselpt.EQ.0)CALL selpt4(ptxsq1,ptysq1,plq1,
1990  + eq1,ptxsa1,ptysa1,plaq1,eaq1,
1991  + ptxsa2,ptysa2,plaq2,eaq2,
1992  + ptxsq2,ptysq2,plq2,eq2,
1993  + amch1,amch2,irej,ikvala,pttq1,ptta1,nselpt)
1994  IF(ipev.GE.2) THEN
1995  WRITE(6,'(A,I5)') ' KKEVVD - IRVD13=',irvd13
1996  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
1997  + ' VD: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
1998  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
1999  + amch1,amch2,irej,ikvala,pttq1,ptta1
2000  WRITE(6,'(A,I5)') ' KKEVVD - IRVD13=',irvd13
2001  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
2002  + ' VD: amch1,amch2 ',
2003  + amch1,amch2
2004  ENDIF
2005 
2006  IF (ipev.GE.7) WRITE(6,'(A/5X,I10)')
2007  + 'VD IREJ ', irej
2008  IF (irej.EQ.1) THEN
2009  irvd13=irvd13 + 1
2010  IF(ipev.GE.1) THEN
2011  WRITE(6,'(A,I5)') ' KKEVVD - IRVD13=',irvd13
2012  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
2013  + ' VD: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
2014  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
2015  + amch1,amch2,irej,ikvala,pttq1,ptta1
2016 
2017  ENDIF
2018  go to 20
2019  ENDIF
2020 C
2021 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
2022 C
2023  ptxch1=ptxsq1 + ptxsq2
2024  ptych1=ptysq1 + ptysq2
2025  ptzch1=plq1 + plq2
2026  ech1=eq1 + eq2
2027  ptxch2=ptxsa2 + ptxsa1
2028  ptych2=ptysa2 + ptysa1
2029  ptzch2=plaq2 + plaq1
2030  ech2=eaq2 + eaq1
2031  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
2032  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
2033 C
2034  IF (ipev.GE.6) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
2035  + ' VD: IREJ ', irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
2036  + amch1,ptxch1,ptych1,ptzch1,ech1,
2037  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
2038  + ptzch2,ech2
2039 
2040 C
2041 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS OR OCTETT
2042 C OR DECUPLETT BARYONS
2043 C FIRST FOR CHAIN 1 (PROJ quark - tar sea-diquark)
2044 C
2045  CALL cobcma(itsq(ixsta),itsq2(ixsta),ipvq(ixvpr), ijnch1,nnch1,
2046  + irej,amch1,amch1n,1)
2047 C*** MASS BELOW OCTETT BARYON MASS
2048  IF(irej.EQ.1) THEN
2049  irvd11=irvd11 + 1
2050  IF(ipev.GE.1) THEN
2051  WRITE(6,'(A,I5)') ' KKEVVD - IRVD11=',irvd11
2052  WRITE(6,'(A,6I5/6E12.4/2E12.4)') ' VD:', ipvq(ixvpr),itsq
2053  + (ixsta),itsq2(ixsta),ijnch1,nnch1,irej, xpvq(ixvpr),xpvd
2054  + (ixvpr),xpvqcm,xpvdcm,
2055  + xtsq(ixsta),xtsaq(ixsta),amch1,amch1n
2056 
2057  ENDIF
2058  goto 20
2059  ENDIF
2060 C CORRECT KINEMATICS FOR CHAIN 1
2061 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
2062  IF(nnch1.NE.0)THEN
2063  CALL cormom(amch1,amch2,amch1n,amch2n,
2064  + ptxsq1,ptysq1,plq1,eq1,
2065  + ptxsa1,ptysa1,plaq1,eaq1,
2066  + ptxsa2,ptysa2,plaq2,eaq2,
2067  + ptxsq2,ptysq2,plq2,eq2,
2068  + ptxch1,ptych1,ptzch1,ech1, ptxch2,ptych2,ptzch2,ech2,
2069  + irej)
2070  amch2=amch2n
2071  ENDIF
2072  IF(irej.EQ.1)THEN
2073  IF(ipev.GE.1)WRITE(6,'(A)')' vd CORMOM rej.'
2074  go to 20
2075  ENDIF
2076 C
2077  IF (ipev.GE.6) WRITE(6,'(A,5F12.5,I10/A,5F12.5/A,5F12.5)')
2078  + ' VD(2): AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJ ', ammm,gammm,bgggx,
2079  + bgggy,bgggz,irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
2080  + amch1,ptxch1,ptych1,ptzch1,ech1,
2081  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
2082  + ptzch2,ech2
2083 C
2084 C no test for chain 2 / mass constraint from DIQVS
2085  ijnch2=0
2086  nnch2=0
2087  qtxch1=ptxch1
2088  qtych1=ptych1
2089  qtzch1=ptzch1
2090  qech1=ech1
2091  qtxch2=ptxch2
2092  qtych2=ptych2
2093  qtzch2=ptzch2
2094  qech2=ech2
2095  pqvda1(n,1)=ptxsq1
2096  pqvda1(n,2)=ptysq1
2097  pqvda1(n,3)=plq1
2098  pqvda1(n,4)=eq1
2099  pqvda2(n,1)=ptxsq2
2100  pqvda2(n,2)=ptysq2
2101  pqvda2(n,3)=plq2
2102  pqvda2(n,4)=eq2
2103  pqvdb1(n,1)=ptxsa2
2104  pqvdb1(n,2)=ptysa2
2105  pqvdb1(n,3)=plaq2
2106  pqvdb1(n,4)=eaq2
2107  pqvdb2(n,1)=ptxsa1
2108  pqvdb2(n,2)=ptysa1
2109  pqvdb2(n,3)=plaq1
2110  pqvdb2(n,4)=eaq1
2111 C
2112 C
2113 C
2114 C PUT D-V CHAIN ENDS INTO /HKKEVT/
2115 C MOMENTA IN NN-CMS
2116 C POSITION OF ORIGINAL NUCLEONS
2117 C
2118 **** keep for the moment the old v-s notations
2119 C FLAG FOR VD-CHAIN ENDS
2120 C PROJECTILE: ISTHKK=121
2121 C TARGET: ISTHKK=132
2122 C FOR VD-CHAINS ISTHKK=5
2123 C
2124  ihkkpd=jhkkpv(ixvpr )
2125  ihkkpo=jhkkpv(ixvpr )-1
2126  ihkktd=jhkkts(ixsta )
2127  ihkkto=jhkkts(ixsta )-1
2128  IF (ipev.GT.3)WRITE(6,1000)ixvpr,inucpr,jnucpr,ihkkpo,ihkkpd
2129  1000 FORMAT (' IXVPR,INUCPR,JNUCPR,IHKKPO,IHKKPD ',5i5)
2130  IF (ipev.GT.3)WRITE(6,1010)ixsta,inucta,jnucta,ihkkto,ihkktd
2131  1010 FORMAT (' IXSTA,INUCTA,JNUCTA,IHKKTO,IHKKTD ',5i5)
2132 C CHAIN 1 PROJECTILE SEA-diquark
2133  nhkk=nhkk+1
2134  IF (nhkk.EQ.nmxhkk)THEN
2135  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
2136  RETURN
2137  ENDIF
2138  ihkk=nhkk
2139  isthkk(ihkk)=121
2140  idhkk(ihkk)=idhkk(ihkkpo)
2141  jmohkk(1,ihkk)=ihkkpo
2142  jmohkk(2,ihkk)=jmohkk(1,ihkkpo)
2143  jdahkk(1,ihkk)=ihkk+2
2144  jdahkk(2,ihkk)=ihkk+2
2145  phkk(1,ihkk)=pqvda1(n,1)
2146  phkk(2,ihkk)=pqvda1(n,2)
2147  phkk(3,ihkk)=pqvda1(n,3)
2148  phkk(4,ihkk)=pqvda1(n,4)
2149  phkk(5,ihkk)=0.
2150 C Add position of parton in hadron
2151  CALL qinnuc(xxpp,yypp)
2152  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
2153  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
2154  vhkk(3,ihkk)=vhkk(3,ihkkpo)
2155  vhkk(4,ihkk)=vhkk(4,ihkkpo)
2156  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
2157  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2158  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2159 
2160  1020 FORMAT (i6,i4,5i6,9e10.2)
2161 C CHAIN 1 TARGET QUARK
2162  nhkk=nhkk+1
2163  IF (nhkk.EQ.nmxhkk)THEN
2164  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
2165  RETURN
2166  ENDIF
2167  ihkk=nhkk
2168  isthkk(ihkk)=132
2169  idhkk(ihkk)=idhkk(ihkktd)
2170  jmohkk(1,ihkk)=ihkktd
2171  jmohkk(2,ihkk)=jmohkk(1,ihkktd)
2172  jdahkk(1,ihkk)=ihkk+1
2173  jdahkk(2,ihkk)=ihkk+1
2174  phkk(1,ihkk)=pqvda2(n,1)
2175  phkk(2,ihkk)=pqvda2(n,2)
2176  phkk(3,ihkk)=pqvda2(n,3)
2177  phkk(4,ihkk)=pqvda2(n,4)
2178  phkk(5,ihkk)=0.
2179 C Add position of parton in hadron
2180  CALL qinnuc(xxpp,yypp)
2181  vhkk(1,ihkk)=vhkk(1,ihkktd)+xxpp
2182  vhkk(2,ihkk)=vhkk(2,ihkktd)+yypp
2183  vhkk(3,ihkk)=vhkk(3,ihkktd)
2184  vhkk(4,ihkk)=vhkk(4,ihkktd)
2185  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
2186  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2187  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2188 
2189 C
2190 C CHAIN 1 BEFORE FRAGMENTATION
2191  nhkk=nhkk+1
2192  IF (nhkk.EQ.nmxhkk)THEN
2193  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
2194  RETURN
2195  ENDIF
2196  ihkk=nhkk
2197  isthkk(ihkk)=5
2198  idhkk(ihkk)=88888+nnch1
2199  jmohkk(1,ihkk)=ihkk-2
2200  jmohkk(2,ihkk)=ihkk-1
2201  phkk(1,ihkk)=qtxch1
2202  phkk(2,ihkk)=qtych1
2203  phkk(3,ihkk)=qtzch1
2204  phkk(4,ihkk)=qech1
2205  phkk(5,ihkk)=amch1
2206 C POSITION OF CREATED CHAIN IN LAB
2207 C =POSITION OF TARGET NUCLEON
2208 C TIME OF CHAIN CREATION IN LAB
2209 C =TIME OF PASSAGE OF PROJECTILE
2210 C NUCLEUS AT POSITION OF TAR. NUCLEUS
2211  vhkk(1,nhkk)= vhkk(1,nhkk-1)
2212  vhkk(2,nhkk)= vhkk(2,nhkk-1)
2213  vhkk(3,nhkk)= vhkk(3,nhkk-1)
2214  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
2215  mhkkvd(n)=ihkk
2216  IF (iprojk.EQ.1)THEN
2217  whkk(1,nhkk)= vhkk(1,nhkk-2)
2218  whkk(2,nhkk)= vhkk(2,nhkk-2)
2219  whkk(3,nhkk)= vhkk(3,nhkk-2)
2220  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
2221  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
2222  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2223  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
2224 
2225  ENDIF
2226  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
2227  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2228  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2229 
2230 C
2231 C
2232 C CHAIN 2 projectile sea antidiquark
2233  nhkk=nhkk+1
2234  IF (nhkk.EQ.nmxhkk)THEN
2235  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
2236  RETURN
2237  ENDIF
2238  ihkk=nhkk
2239  isthkk(ihkk)=121
2240  idhkk(ihkk)=idhkk(ihkkpd)
2241  jmohkk(1,ihkk)=ihkkpd
2242  jmohkk(2,ihkk)=jmohkk(1,ihkkpd)
2243  jdahkk(1,ihkk)=ihkk+2
2244  jdahkk(2,ihkk)=ihkk+2
2245  phkk(1,ihkk)=pqvdb1(n,1)
2246  phkk(2,ihkk)=pqvdb1(n,2)
2247  phkk(3,ihkk)=pqvdb1(n,3)
2248  phkk(4,ihkk)=pqvdb1(n,4)
2249  phkk(5,ihkk)=0.
2250 C Add position of parton in hadron
2251  CALL qinnuc(xxpp,yypp)
2252  vhkk(1,ihkk)=vhkk(1,ihkkpd)+xxpp
2253  vhkk(2,ihkk)=vhkk(2,ihkkpd)+yypp
2254  vhkk(3,ihkk)=vhkk(3,ihkkpd)
2255  vhkk(4,ihkk)=vhkk(4,ihkkpd)
2256  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
2257  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2258  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2259 
2260 C CHAIN 2 TARGET diquark
2261  nhkk=nhkk+1
2262  IF (nhkk.EQ.nmxhkk)THEN
2263  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
2264  RETURN
2265  ENDIF
2266  ihkk=nhkk
2267  isthkk(ihkk)=132
2268  idhkk(ihkk)=idhkk(ihkkto)
2269  jmohkk(1,ihkk)=ihkkto
2270  jmohkk(2,ihkk)=jmohkk(1,ihkkto)
2271  jdahkk(1,ihkk)=ihkk+1
2272  jdahkk(2,ihkk)=ihkk+1
2273  phkk(1,ihkk)=pqvdb2(n,1)
2274  phkk(2,ihkk)=pqvdb2(n,2)
2275  phkk(3,ihkk)=pqvdb2(n,3)
2276  phkk(4,ihkk)=pqvdb2(n,4)
2277  phkk(5,ihkk)=0.
2278 C Add position of parton in hadron
2279  CALL qinnuc(xxpp,yypp)
2280  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
2281  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
2282  vhkk(3,ihkk)=vhkk(3,ihkkto)
2283  vhkk(4,ihkk)=vhkk(4,ihkkto)
2284  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
2285  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2286  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2287 
2288 C
2289 C CHAIN 2 BEFORE FRAGMENTATION
2290  nhkk=nhkk+1
2291  IF (nhkk.EQ.nmxhkk)THEN
2292  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
2293  RETURN
2294  ENDIF
2295  ihkk=nhkk
2296  isthkk(ihkk)=5
2297  idhkk(ihkk)=88888+nnch2
2298  jmohkk(1,ihkk)=ihkk-2
2299  jmohkk(2,ihkk)=ihkk-1
2300  phkk(1,ihkk)=qtxch2
2301  phkk(2,ihkk)=qtych2
2302  phkk(3,ihkk)=qtzch2
2303  phkk(4,ihkk)=qech2
2304  phkk(5,ihkk)=amch2
2305 C POSITION OF CREATED CHAIN IN LAB
2306 C =POSITION OF TARGET NUCLEON
2307 C TIME OF CHAIN CREATION IN LAB
2308 C =TIME OF PASSAGE OF PROJECTILE
2309 C NUCLEUS AT POSITION OF TAR. NUCLEUS
2310  vhkk(1,nhkk)= vhkk(1,nhkk-1)
2311  vhkk(2,nhkk)= vhkk(2,nhkk-1)
2312  vhkk(3,nhkk)= vhkk(3,nhkk-1)
2313  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
2314  mhkkvd(n)=ihkk
2315  IF (iprojk.EQ.1)THEN
2316  whkk(1,nhkk)= vhkk(1,nhkk-2)
2317  whkk(2,nhkk)= vhkk(2,nhkk-2)
2318  whkk(3,nhkk)= vhkk(3,nhkk-2)
2319  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
2320  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
2321  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2322  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
2323 
2324  ENDIF
2325  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
2326  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2327  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2328 
2329 C
2330 C
2331 C NOW WE HAVE AN ACCEPTABLE SEA--VALENCE EVENT
2332 * sea diquark pair!
2333 C AND PUT IT INTO THE HISTOGRAM
2334 C
2335  amcvd1(n)=amch1
2336  amcvd2(n)=amch2
2337  gacvd1(n)=qech1/amch1
2338  bgxvd1(n)=qtxch1/amch1
2339  bgyvd1(n)=qtych1/amch1
2340  bgzvd1(n)=qtzch1/amch1
2341  gacvd2(n)=qech2/amch2
2342  bgxvd2(n)=qtxch2/amch2
2343  bgyvd2(n)=qtych2/amch2
2344  bgzvd2(n)=qtzch2/amch2
2345  nchvd1(n)=nnch1
2346  nchvd2(n)=nnch2
2347  ijcvd1(n)=ijnch1
2348  ijcvd2(n)=ijnch2
2349  IF (ipev.GE.2) WRITE(6,'(A/I10,4F12.7,5I5/10X,4F12.6/10X,6F12.6,
2350  +4I5/8F15.5/8F15.5/2I5)') ' VD / FINAL PRINT',n
2351 C +, XPVQ
2352 C + (IXVPR),XPVD(IXVPR),XTSQ(IXSTA),XTSAQ(IXSTA), IPVQ(IXVPR),IPPV1
2353 C + (IXVPR),IPPV2(IXVPR),ITSQ(IXSTA),ITSAQ(IXSTA), AMCVD1(N),AMCVD2
2354 C + (N),GACVD1(N),GACVD2(N), BGXVD1(N),BGYVD1(N),BGZVD1(N), BGXVD2
2355 C + (N),BGYVD2(N),BGZVD2(N), NCHVD1(N),NCHVD2(N),IJCVD1(N),IJCVD2
2356 C + (N), (PQVDA1(N,JU),PQVDA2(N,JU),PQVDB1(N,JU), PQVDB2(N,JU),JU=1,
2357 C + 4),
2358 C + IXVPR,IXSTA
2359  10 CONTINUE
2360  RETURN
2361 C
2362  20 CONTINUE
2363 C EVENT REJECTED
2364 C START A NEW ONE
2365  irejvd=1
2366  issqq=itsq(ixsta)
2367  jssqq=itsq2(ixsta)
2368  IF(issqq.EQ.3.AND.jssqq.EQ.3)THEN
2369  ivdre(3)=ivdre(3)+1
2370  ELSEIF(issqq.EQ.3.OR.jssqq.EQ.3)THEN
2371  ivdre(2)=ivdre(2)+1
2372  ELSE
2373  ivdre(1)=ivdre(1)+1
2374  ENDIF
2375  RETURN
2376  END
2377 C
2378 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2379 C
2380 C DEBUG SUBCHK
2381 C END DEBUG
2382  SUBROUTINE hadrvd
2383  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2384  SAVE
2385 C-------------------------
2386 C
2387 C hadronize sea diquark - valence CHAINS
2388 C
2389 C ADD GENERATED HADRONS TO /ALLPAR/
2390 C STARTING AT (NAUX + 1)
2391 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
2392 C
2393 C---------------------------------------------------------
2394  COMMON /zsea/zseaav,zseasu,anzsea
2395  common/popcck/pdbck,pdbse,pdbseu,
2396  * ijpock,irejck,ick4,ihad4,ick6,ihad6
2397  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
2398  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
2399  *isea43,isea63,irejao
2400 *KEEP,INTMX.
2401  parameter(intmx=2488,intmd=252)
2402 *KEEP,IFROTO.
2403  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
2404  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
2405  +jhkknt
2406  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
2407  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
2408  & mhkkhh(intmx),
2409  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
2410 *KEEP,DIQI.
2411  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
2412  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
2413  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
2414  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
2415 *KEEP,DXQX.
2416 C INCLUDE (XQXQ)
2417 * NOTE: INTMX set via INCLUDE(INTMX)
2418  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
2419  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
2420  * ,xpsu(248),xtsu(248)
2421  * ,xpsut(248),xtsut(248)
2422 *KEEP,INTNEW.
2423  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
2424  +ixpv,ixps,ixtv,ixts, intvv1(248),
2425  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
2426  +intss1(intmx),intss2(intmx),
2427  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
2428  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
2429 
2430 C /INTNEW/
2431 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
2432 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
2433 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
2434 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
2435 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
2436 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
2437 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
2438 C FROM PROJECTILE/TARGET NUCLEI
2439 C-------------------
2440 *KEEP,ABRVD.
2441  COMMON /abrvd/ amcvd1(248),amcvd2(248),gacvd1(248),gacvd2(248),
2442  +bgxvd1(248),bgyvd1(248),bgzvd1(248), bgxvd2(248),bgyvd2(248),
2443  +bgzvd2(248), nchvd1(248),nchvd2(248),ijcvd1(248),ijcvd2(248),
2444  +pqvda1(248,4),pqvda2(248,4), pqvdb1(248,4),pqvdb2(248,4)
2445 *KEEP,LOZUO.
2446  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
2447  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
2448  +intlo(intmx),inloss(intmx)
2449 C /LOZUO/
2450 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
2451 C REJECTED IN KKEVT
2452 C------------------
2453 *KEEP,HKKEVT.
2454 c INCLUDE (HKKEVT)
2455  parameter(nmxhkk= 89998)
2456 c PARAMETER (NMXHKK=25000)
2457  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
2458  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
2459  +(4,nmxhkk)
2460 C
2461 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
2462 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
2463 C THE POSITIONS OF THE PROJECTILE NUCLEONS
2464 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
2465 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
2466 C COMPLETELY CONSISTENT. THE TIMES IN THE
2467 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
2468 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
2469 C
2470 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
2471 C
2472 C NMXHKK: maximum numbers of entries (partons/particles) that can be
2473 C stored in the commonblock.
2474 C
2475 C NHKK: the actual number of entries stored in current event. These are
2476 C found in the first NHKK positions of the respective arrays below.
2477 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
2478 C entry.
2479 C
2480 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
2481 C = 0 : null entry.
2482 C = 1 : an existing entry, which has not decayed or fragmented.
2483 C This is the main class of entries which represents the
2484 C "final state" given by the generator.
2485 C = 2 : an entry which has decayed or fragmented and therefore
2486 C is not appearing in the final state, but is retained for
2487 C event history information.
2488 C = 3 : a documentation line, defined separately from the event
2489 C history. (incoming reacting
2490 C particles, etc.)
2491 C = 4 - 10 : undefined, but reserved for future standards.
2492 C = 11 - 20 : at the disposal of each model builder for constructs
2493 C specific to his program, but equivalent to a null line in the
2494 C context of any other program. One example is the cone defining
2495 C vector of HERWIG, another cluster or event axes of the JETSET
2496 C analysis routines.
2497 C = 21 - : at the disposal of users, in particular for event tracking
2498 C in the detector.
2499 C
2500 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
2501 C standard.
2502 C
2503 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
2504 C The value is 0 for initial entries.
2505 C
2506 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
2507 C one mother exist, in which case the value 0 is used. In cluster
2508 C fragmentation models, the two mothers would correspond to the q
2509 C and qbar which join to form a cluster. In string fragmentation,
2510 C the two mothers of a particle produced in the fragmentation would
2511 C be the two endpoints of the string (with the range in between
2512 C implied).
2513 C
2514 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
2515 C entry has not decayed, this is 0.
2516 C
2517 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
2518 C entry has not decayed, this is 0. It is assumed that the daughters
2519 C of a particle (or cluster or string) are stored sequentially, so
2520 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
2521 C daughters. Even in cases where only one daughter is defined (e.g.
2522 C K0 -> K0S) both values should be defined, to make for a uniform
2523 C approach in terms of loop constructions.
2524 C
2525 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
2526 C
2527 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
2528 C
2529 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
2530 C
2531 C PHKK(4,IHKK) : energy, in GeV.
2532 C
2533 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
2534 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
2535 C
2536 C VHKK(1,IHKK) : production vertex x position, in mm.
2537 C
2538 C VHKK(2,IHKK) : production vertex y position, in mm.
2539 C
2540 C VHKK(3,IHKK) : production vertex z position, in mm.
2541 C
2542 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
2543 C********************************************************************
2544 *KEEP,DFINPA.
2545  CHARACTER*8 anf
2546  parameter(nfimax=249)
2547  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
2548  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
2549  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
2550  * istath(nfimax)
2551 *KEEP,DPRIN.
2552  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2553 *KEEP,PROJK.
2554  COMMON /projk/ iprojk
2555 *KEND.
2556  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
2557 C modified DPMJET
2558  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
2559  * anndv,annvd,annds,annsd,
2560  * annhh,annzz,
2561  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
2562  * pthh,ptzz,
2563  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
2564  * eehh,eezz
2565  * ,anndi,ptdi,eedi
2566  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
2567  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
2568  * acouzz,acouhh,acouds,acousd,
2569  * acoudz,acouzd,acoudi,
2570  * acoudv,acouvd,acoucc
2571  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
2572  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
2573  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
2574  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
2575  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
2576  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
2577 C---------------------
2578  dimension poj(4),pat(4)
2579  DATA ncalvd /0/
2580 C-----------------------------------------------------------------------
2581  IF(iphkk.GE.6)WRITE (6,'( A)') ' hadrvd'
2582  ncalvd=ncalvd+1
2583  DO 50 i=1,nvd
2584 C-----------------------drop recombined chain pairs
2585  IF(nchvd1(i).EQ.99.AND.nchvd2(i).EQ.99) go to 50
2586  is1=intvd1(i)
2587  is2=intvd2(i)
2588 C
2589  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itvq(is2),
2590  + ittv1(is2),ittv2(is2), amcvd1(i),amcvd2(i),gacvd1(i),gacvd2(i),
2591  + bgxvd1(i),bgyvd1(i),bgzvd1(i), bgxvd2(i),bgyvd2(i),bgzvd2(i),
2592  + nchvd1(i),nchvd2(i),ijcvd1(i),ijcvd2(i), pqvda1(i,4),pqvda2
2593  + (i,4),pqvdb1(i,4),pqvdb2(i,4)
2594  1000 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
2595 C
2596 C++++++++++++++++++++++++++++++ CHAIN 1: quark-diquark +++++++++++
2597  ifb1=ipvq(is1)
2598  ifb2=itsq(is2)
2599  ifb3=itsq2(is2)
2600  DO 10 j=1,4
2601  poj(j)=pqvda1(i,j)
2602  pat(j)=pqvda2(i,j)
2603  10 CONTINUE
2604  IF((nchvd1(i).NE.0.OR.nchvd2(i).NE.0).AND.ip.NE.1)
2605  & CALL saptre(amcvd1(i),gacvd1(i),bgxvd1(i),
2606  * bgyvd1(i),bgzvd1(i),
2607  & amcvd2(i),gacvd2(i),bgxvd2(i),
2608  * bgyvd2(i),bgzvd2(i))
2609 C----------------------------------------------------------------
2610 C----------------------------------------------------------------
2611 C WRITE (6,1244) POJ,PAT
2612 C1244 FORMAT (' V-D QUARK-DIQUARK POJ,PAT ',8E12.3)
2613 C------------------------------------------------------------------
2614 C check bookkeeping
2615 C-----------------------------------------------------------------
2616 C I= number of valence chain
2617 C Target Nr itt = IFROVT(INTSV2(I))
2618 C No of Glauber sea q at Target JITT=JTSHS(ITT)
2619 C ITTT = IFROVT(INTSV2(I))
2620 C IF(INTVD2(I).GE.1)THEN
2621 C ITTT = IFROVT(INTVD2(I))
2622 C ELSE
2623  ittt=0
2624 C ENDIF
2625 C IF(ITTT.GE.1)THEN
2626 C JITT=JTSHS(ITTT)
2627 C ELSE
2628  jitt=0
2629 C ENDIF
2630 C IF(NCHSV1(I).EQ.0)THEN
2631 C WRITE(6,'(A,3I5)')'HADRSV: I,ITTT,JITT ',
2632 C * I,ITTT,JITT
2633 C ENDIF
2634 C------------------------------------------------------------------
2635 C check bookkeeping
2636 C-----------------------------------------------------------------
2637  IF(ifb2.LE.2.AND.ifb3.LE.2)THEN
2638  nvduu=nvduu+1
2639  ELSEIF((ifb2.EQ.3.AND.ifb3.LE.2).OR.
2640  * (ifb3.EQ.3.AND.ifb2.LE.2))THEN
2641  nvdus=nvdus+1
2642  ELSEIF(ifb2.EQ.3.AND.ifb3.EQ.3)THEN
2643  nvdss=nvdss+1
2644  ENDIF
2645  IF((nchvd1(i).NE.0))THEN
2646  CALL hadjet(nhad,amcvd1(i),poj,pat,gacvd1(i),
2647  * bgxvd1(i), bgyvd1
2648  + (i),bgzvd1(i),ifb1,ifb2,ifb3,ifb4, ijcvd1(i),
2649  * ijcvd1(i),4,nchvd1
2650  + (i),13)
2651  ENDIF
2652 C-----------------------------------------------------------------
2653  aack=float(ick4)/float(ick4+ihad4+1)
2654  IF((nchvd1(i).EQ.0))THEN
2655  zseawu=rndm(bb)*2.d0*zseaav
2656  rseack=float(jitt)*pdbse +zseawu*pdbseu
2657  IF(ipco.GE.1)WRITE(6,'(2A,I5,2F10.3)')'HADJSE JITT,',
2658  * 'RSEACK,PDBSE 2 dpmnuc5 ',
2659  + jitt,rseack,pdbse
2660  irejss=5
2661  IF(rndm(v).LE.rseack)THEN
2662  irejss=2
2663  IF(amcvd1(i).GT.2.3d0)THEN
2664  irejss=0
2665  CALL hadjse(nhad,amcvd1(i),poj,pat,gacvd1(i),
2666  * bgxvd1(i),
2667  * bgyvd1
2668  + (i),bgzvd1(i),ifb1,ifb2,ifb3,ifb4, ijcvd1(i),
2669  * ijcvd1(i),4,
2670  * nchvd1
2671  + (i),3,irejss,iissqq)
2672  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JITT,',
2673  * 'RSEACK,IREJSS 2 dpmnuc5 ',
2674  + jitt,rseack,irejss
2675  ENDIF
2676  IF(irejss.GE.1)THEN
2677  IF(irejss.EQ.1)irejse=irejse+1
2678  IF(irejss.EQ.3)irejs3=irejs3+1
2679  IF(irejss.EQ.2)irejs0=irejs0+1
2680  CALL hadjet(nhad,amcvd1(i),poj,pat,gacvd1(i),
2681  * bgxvd1(i), bgyvd1
2682  + (i),bgzvd1(i),ifb1,ifb2,ifb3,ifb4,
2683  * ijcvd1(i),ijcvd1(i),4,nchvd1
2684  + (i),13)
2685  ihad4=ihad4+1
2686  ENDIF
2687  IF(irejss.EQ.0)THEN
2688  IF(iissqq.EQ.3)THEN
2689  ise43=ise43+1
2690  ELSE
2691  ise4=ise4+1
2692  ENDIF
2693  ENDIF
2694  ELSE
2695  CALL hadjet(nhad,amcvd1(i),poj,pat,gacvd1(i),
2696  * bgxvd1(i), bgyvd1
2697  + (i),bgzvd1(i),ifb1,ifb2,ifb3,ifb4,
2698  * ijcvd1(i),ijcvd1(i),4,nchvd1
2699  + (i),13)
2700  ihad4=ihad4+1
2701  ENDIF
2702  ENDIF
2703 
2704 C-----------------------------------------------------------------
2705  acouvd=acouvd+1
2706  nhkkau=nhkk+1
2707  DO 20 j=1,nhad
2708  IF (nhkk.EQ.nmxhkk) THEN
2709  WRITE (6,'(A,2I5/A)') .EQ.' HADRVD: NHKKNMXHKK ',nhkk,nmxhkk
2710  RETURN
2711  ENDIF
2712 C NHKK=NHKK+1
2713  IF (nhkk.EQ.nmxhkk)THEN
2714  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
2715  RETURN
2716  ENDIF
2717 C
2718  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
2719  IF (abs(ehecc-hef(j)).GT.0.001) THEN
2720 C WRITE(6,'(2A/3I5,3E15.6)')
2721 C & ' HADRVD / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
2722 C * ' NCALVD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
2723 C * NCALVD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
2724  hef(j)=ehecc
2725  ENDIF
2726  annvd=annvd+1
2727  eevd=eevd+hef(j)
2728  ptvd=ptvd+sqrt(pxf(j)**2+pyf(j)**2)
2729 C PUT NN-CMS HADRONS INTO /HKKEVT/
2730  istist=1
2731  IF(ibarf(j).EQ.500)istist=2
2732  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvd(i)-3,0,
2733  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),15)
2734  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
2735  + (nhkk)
2736  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
2737  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
2738  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
2739 
2740  20 CONTINUE
2741 C IF(NHAD.GT.0) THEN
2742 C JDAHKK(1,IMOHKK)=NHKKAU
2743 C JDAHKK(2,IMOHKK)=NHKK
2744 C ENDIF
2745 C+++++++++++++++++++++++++++++ CHAIN 2: diquark - adiquark +++++++++
2746  ifb1=ippv1(is1)
2747  ifb2=ippv2(is1)
2748  ifb3=itsaq(is2)
2749  ifb4=itsaq2(is2)
2750  ifb3=iabs(ifb3)+6
2751  ifb4=iabs(ifb4)+6
2752  DO 30 j=1,4
2753  poj(j)=pqvdb2(i,j)
2754  pat(j)=pqvdb1(i,j)
2755  30 CONTINUE
2756 C
2757  IF(amcvd2(i).LT.2.3)THEN
2758  WRITE(6,'(A,F10.2,I5)')' HADRVD AMCVD2(I), I ',
2759  * amcvd2(i),i
2760  RETURN
2761  ENDIF
2762  IF(ifb3.LE.8.AND.ifb4.LE.8)THEN
2763  navduu=navduu+1
2764  ELSEIF((ifb3.EQ.9.AND.ifb4.LE.8).OR.
2765  * (ifb4.EQ.9.AND.ifb3.LE.8))THEN
2766  navdus=navdus+1
2767  ELSEIF(ifb3.EQ.9.AND.ifb4.EQ.9)THEN
2768  navdss=navdss+1
2769  ENDIF
2770  CALL hadjet(nhad,amcvd2(i),poj,pat,gacvd2(i),
2771  * bgxvd2(i), bgyvd2
2772  + (i),bgzvd2(i),ifb1,ifb2,ifb3,ifb4, ijcvd2(i),
2773  * ijcvd2(i),5,nchvd2
2774  + (i),14)
2775 C ADD HADRONS/RESONANCES INTO
2776 C COMMON /ALLPAR/ STARTING AT NAUX
2777  nhkkau=nhkk+1
2778  DO 40 j=1,nhad
2779  IF (nhkk.EQ.nmxhkk) THEN
2780  WRITE (6,'(A,2I5/A)') .EQ.' HADRVD: NHKKNMXHKK ',
2781  * nhkk,
2782  + nmxhkk
2783  RETURN
2784  ENDIF
2785 C NHKK=NHKK+1
2786  IF (nhkk.EQ.nmxhkk)THEN
2787  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
2788  RETURN
2789  ENDIF
2790 C
2791  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
2792  IF (abs(ehecc-hef(j)).GT.0.001) THEN
2793 C WRITE(6,'(2A/3I5,3E15.6)')
2794 C & ' HADRVD / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
2795 C * ' NCALVD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
2796 C * NCALVD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
2797  hef(j)=ehecc
2798  ENDIF
2799  annvd=annvd+1
2800  eevd=eevd+hef(j)
2801  ptvd=ptvd+sqrt(pxf(j)**2+pyf(j)**2)
2802 C PUT NN-CMS HADRONS INTO /HKKEVT/
2803  istist=1
2804  IF(ibarf(j).EQ.500)istist=2
2805  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvd(i),0,
2806  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),16)
2807  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
2808  + (nhkk)
2809  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
2810  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
2811  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
2812 
2813  40 CONTINUE
2814 C IF(NHAD.GT.0) THEN
2815 C JDAHKK(1,IMOHKK)=NHKKAU
2816 C JDAHKK(2,IMOHKK)=NHKK
2817 C ENDIF
2818  50 CONTINUE
2819 C----------------------------------------------------------------
2820 C
2821  RETURN
2822  1010 FORMAT (i6,i4,5i6,9e10.2)
2823  1020 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
2824  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
2825  END
2826 C
2827 C ---------------------------------------------------------------
2828 C
2829  SUBROUTINE diqdss(ECM,ITS,IPS,IREJ)
2830  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2831  SAVE
2832 * define d-s chains (sea diquark - sea chains)
2833 * sqsq-sq and saqsaq-saq chains instead of q-aq and aq-q chains
2834  COMMON /zsea/zseaav,zseasu,anzsea
2835  common/popcck/pdbck,pdbse,pdbseu,
2836  * ijpock,irejck,ick4,ihad4,ick6,ihad6
2837  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
2838  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
2839  *isea43,isea63,irejao
2840 *KEEP,INTMX.
2841  parameter(intmx=2488,intmd=252)
2842 *KEEP,IFROTO.
2843  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
2844  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
2845  +jhkknt
2846  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
2847  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
2848  & mhkkhh(intmx),
2849  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
2850 *KEEP,DIQI.
2851  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
2852  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
2853  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
2854  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
2855 *KEEP,DXQX.
2856 C INCLUDE (XQXQ)
2857 * NOTE: INTMX set via INCLUDE(INTMX)
2858  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
2859  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
2860  * ,xpsu(248),xtsu(248)
2861  * ,xpsut(248),xtsut(248)
2862 *KEEP,INTNEW.
2863  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
2864  +ixpv,ixps,ixtv,ixts, intvv1(248),
2865  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
2866  +intss1(intmx),intss2(intmx),
2867  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
2868  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
2869 
2870 C /INTNEW/
2871 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
2872 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
2873 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
2874 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
2875 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
2876 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
2877 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
2878 C FROM PROJECTILE/TARGET NUCLEI
2879 C-------------------
2880 *KEEP,ABRDS.
2881  COMMON /abrds/ amcds1(248),amcds2(248),gacds1(248),gacds2(248),
2882  +bgxds1(248),bgyds1(248),bgzds1(248), bgxds2(248),bgyds2(248),
2883  +bgzds2(248), nchds1(248),nchds2(248),ijcds1(248),ijcds2(248),
2884  +pqdsa1(248,4),pqdsa2(248,4), pqdsb1(248,4),pqdsb2(248,4)
2885 *KEND.
2886  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2887  common/seasu3/seasq
2888  COMMON /xseadi/ xseacu,unon,unom,unosea, cvq,cdq,csea,ssmima,
2889  +ssmimq,vvmthr
2890  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
2891  *idzre(3),izdre(3),idiqrz(7)
2892  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
2893  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
2894  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
2895  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
2896  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
2897  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
2898 C-----------------------------------------------------------------
2899 C COMMON /PCHARM/PCCCC
2900  parameter(ummm=0.3d0)
2901  parameter(smmm=0.5d0)
2902  parameter(cmmm=1.3d0)
2903  DATA pc/0.0001d0/
2904 *KEND.
2905 C----------
2906 C
2907  DATA inicha/0/
2908 C----------------------------------------------------------------------
2909 C Initialize Charm selection at soft chain ends
2910 C
2911  IF(inicha.EQ.0)THEN
2912  rx=8.d0
2913  x1=rx
2914  gm=2.140d0
2915  x2=ummm
2916  betoo=7.5d0
2917  ENDIF
2918  rx=8.d0
2919  x1=rx
2920  betcha=betoo+1.3d0-log10(ecm)
2921  pu=dbeta(x1,x2,betcha)
2922  x2=smmm
2923  ps=dbeta(x1,x2,betcha)
2924  x2=cmmm
2925  pc=dbeta(x1,x2,betcha)
2926 C PU1=PU/(2*PU+PS+PC)
2927 C PS1=PS/(2*PU+PS+PC)
2928  pc1=pc/(2*pu+ps+pc)
2929 C changed j.r.7.12.94
2930 C PC=PC1/2.9
2931 C changed j.r.14.12.94
2932 C PC=PC1/5.0
2933 C PC=PC1/10.0
2934  pc=pc1/7.0d0
2935  pu1=pu/(2*pu+ps+pc)
2936  ps1=ps/(2*pu+ps+pc)
2937  IF(inicha.EQ.0)THEN
2938  inicha=1
2939  WRITE(6,4567)pc,betcha,pu1,ps1,seasq
2940  4567 FORMAT(' Charm chain ends DIQDSS: PC,BETCHA,PU,PS,SEASQ',5f10.5)
2941  ENDIF
2942 C----------------------------------------------------------------------
2943  IF(iphkk.GE.6)WRITE (6,'( A)') ' diqdss'
2944  irej=0
2945 * kinematics: is the mass of the adiquark-diquark chain big enough
2946 * to allow for fragmentation
2947  ipsq2(ips)=1.d0+rndm(v1)*(2.d0+2.d0*seasq)
2948  rr=rndm(v)
2949  IF(rr.LT.pc)ipsq2(ips)=4
2950 C-----------------------------------------------------------------
2951  ipsaq2(ips)=-ipsq2(ips)
2952 C---------------------------------------------------j.r.29.4.94
2953 C x**1.5 distr for sea diquarks
2954 C number of projectile nucleon
2955  inucpr=ifrosp(ips)
2956 C number of projectile diquark
2957  iitop=itovp(inucpr)
2958 C diquark x
2959  xpdiqu=xpvd(iitop)
2960 C minimal value of diquark x
2961  xdthr=cdq/ecm
2962 C
2963  xdfree=xpdiqu-xdthr
2964  xall=xdfree+xpsq(ips)+xpsaq(ips)-2.*xdthr
2965  xdalt=xpvd(iitop)
2966  xsalt=xpsq(ips)
2967  xaalt=xpsaq(ips)
2968  IF(xall.GE.0.)THEN
2969  rr1=rndm(v1)
2970  rr2=rndm(v2)
2971  rr3=rndm(v3)
2972  sr123=rr1+rr2+rr3
2973  dx1=rr1*xall/sr123
2974  dx2=rr2*xall/sr123
2975  dx3=rr3*xall/sr123
2976  xpvd(iitop)=xdthr+dx1
2977  xpsq(ips)=xdthr+dx2
2978  xpsaq(ips)=xdthr+dx3
2979  ENDIF
2980 C--------------------------------------------------------------
2981  amdsq1=xpsq(ips)*xtsq(its)*ecm**2
2982  amdsq2=xpsaq(ips)*xtsaq(its)*ecm**2
2983  idiqre(1)=idiqre(1)+1
2984  IF(ipsq(ips).GE.3.AND.ipsq2(ips).GE.3)THEN
2985  idiqre(2)=idiqre(2)+1
2986 C IF(AMDSQ2.LE.2.3.OR.AMDSQ1.LE.2.30) THEN
2987  IF(amdsq2.LE.6.6d0.OR.amdsq1.LE.6.60d0) THEN
2988  irej=1
2989  idiqre(3)=idiqre(3)+1
2990  idiqre(2)=idiqre(2)-1
2991  idiqre(1)=idiqre(1)-1
2992  xpvd(iitop)=xdalt
2993  xpsq(ips)=xsalt
2994  xpsaq(ips)=xaalt
2995  RETURN
2996  ENDIF
2997  ELSEIF(ipsq(ips).GE.3.OR.ipsq2(ips).GE.3)THEN
2998  idiqre(4)=idiqre(4)+1
2999 C IF(AMDSQ2.LE.1.9.OR.AMDSQ1.LE.1.90) THEN
3000  IF(amdsq2.LE.5.8d0.OR.amdsq1.LE.5.80d0) THEN
3001  irej=1
3002  idiqre(5)=idiqre(5)+1
3003  idiqre(4)=idiqre(4)-1
3004  idiqre(1)=idiqre(1)-1
3005  xpvd(iitop)=xdalt
3006  xpsq(ips)=xsalt
3007  xpsaq(ips)=xaalt
3008  RETURN
3009  ENDIF
3010  ELSE
3011  idiqre(6)=idiqre(6)+1
3012 C IF(AMDSQ2.LE.1.50.OR.AMDSQ1.LE.1.50) THEN
3013  IF(amdsq2.LE.3.9d0.OR.amdsq1.LE.3.9d0) THEN
3014  irej=1
3015  idiqre(7)=idiqre(7)+1
3016  idiqre(6)=idiqre(6)-1
3017  idiqre(1)=idiqre(1)-1
3018  xpvd(iitop)=xdalt
3019  xpsq(ips)=xsalt
3020  xpsaq(ips)=xaalt
3021  RETURN
3022  ENDIF
3023  ENDIF
3024  nds=nds+1
3025  nchds1(nds)=0
3026  nchds2(nds)=0
3027  intds1(nds)=ips
3028  intds2(nds)=its
3029 C WRITE(6,'(A/5X,3F10.3,3I5/5X,3F10.3)')
3030 C +' DIQDSS: AMDSQ1, XTSQ, XPSQ, ITS,IPS, NDS/ AMDSQ2, XTSAQ, XPSAQ',
3031 C + AMDSQ1,XTSQ(ITS),XPSQ(IPS),ITS,IPS, NDS, AMDSQ2,
3032 C +XTSAQ(ITS),XPSAQ(IPS)
3033  RETURN
3034  END
3035 C
3036 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3037 C
3038 C DEBUG SUBCHK
3039 C END DEBUG
3040  SUBROUTINE kkevds(IREJDS)
3041  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3042  SAVE
3043 C
3044 C------------------ treatment of sea diquark - sea CHAIN SYSTEMS
3045 C
3046  COMMON /zsea/zseaav,zseasu,anzsea
3047  common/popcck/pdbck,pdbse,pdbseu,
3048  * ijpock,irejck,ick4,ihad4,ick6,ihad6
3049  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
3050  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
3051  *isea43,isea63,irejao
3052 *KEEP,INTMX.
3053  parameter(intmx=2488,intmd=252)
3054 *KEEP,HKKEVT.
3055 c INCLUDE (HKKEVT)
3056  parameter(nmxhkk= 89998)
3057 c PARAMETER (NMXHKK=25000)
3058  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
3059  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
3060  +(4,nmxhkk)
3061 C
3062 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
3063 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
3064 C THE POSITIONS OF THE PROJECTILE NUCLEONS
3065 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
3066 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
3067 C COMPLETELY CONSISTENT. THE TIMES IN THE
3068 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
3069 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
3070 C
3071 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
3072 C
3073 C NMXHKK: maximum numbers of entries (partons/particles) that can be
3074 C stored in the commonblock.
3075 C
3076 C NHKK: the actual number of entries stored in current event. These are
3077 C found in the first NHKK positions of the respective arrays below.
3078 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
3079 C entry.
3080 C
3081 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
3082 C = 0 : null entry.
3083 C = 1 : an existing entry, which has not decayed or fragmented.
3084 C This is the main class of entries which represents the
3085 C "final state" given by the generator.
3086 C = 2 : an entry which has decayed or fragmented and therefore
3087 C is not appearing in the final state, but is retained for
3088 C event history information.
3089 C = 3 : a documentation line, defined separately from the event
3090 C history. (incoming reacting
3091 C particles, etc.)
3092 C = 4 - 10 : undefined, but reserved for future standards.
3093 C = 11 - 20 : at the disposal of each model builder for constructs
3094 C specific to his program, but equivalent to a null line in the
3095 C context of any other program. One example is the cone defining
3096 C vector of HERWIG, another cluster or event axes of the JETSET
3097 C analysis routines.
3098 C = 21 - : at the disposal of users, in particular for event tracking
3099 C in the detector.
3100 C
3101 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
3102 C standard.
3103 C
3104 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
3105 C The value is 0 for initial entries.
3106 C
3107 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
3108 C one mother exist, in which case the value 0 is used. In cluster
3109 C fragmentation models, the two mothers would correspond to the q
3110 C and qbar which join to form a cluster. In string fragmentation,
3111 C the two mothers of a particle produced in the fragmentation would
3112 C be the two endpoints of the string (with the range in between
3113 C implied).
3114 C
3115 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
3116 C entry has not decayed, this is 0.
3117 C
3118 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
3119 C entry has not decayed, this is 0. It is assumed that the daughters
3120 C of a particle (or cluster or string) are stored sequentially, so
3121 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
3122 C daughters. Even in cases where only one daughter is defined (e.g.
3123 C K0 -> K0S) both values should be defined, to make for a uniform
3124 C approach in terms of loop constructions.
3125 C
3126 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
3127 C
3128 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
3129 C
3130 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
3131 C
3132 C PHKK(4,IHKK) : energy, in GeV.
3133 C
3134 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
3135 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
3136 C
3137 C VHKK(1,IHKK) : production vertex x position, in mm.
3138 C
3139 C VHKK(2,IHKK) : production vertex y position, in mm.
3140 C
3141 C VHKK(3,IHKK) : production vertex z position, in mm.
3142 C
3143 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
3144 C********************************************************************
3145 *KEEP,IFROTO.
3146  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
3147  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
3148  +jhkknt
3149  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
3150  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
3151  & mhkkhh(intmx),
3152  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
3153 *KEEP,DIQI.
3154  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
3155  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
3156  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
3157  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
3158 *KEEP,INTNEW.
3159  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
3160  +ixpv,ixps,ixtv,ixts, intvv1(248),
3161  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
3162  +intss1(intmx),intss2(intmx),
3163  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
3164  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
3165 
3166 C /INTNEW/
3167 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
3168 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
3169 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
3170 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
3171 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
3172 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
3173 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
3174 C FROM PROJECTILE/TARGET NUCLEI
3175 C-------------------
3176 *KEEP,ABRDS.
3177  COMMON /abrds/ amcds1(248),amcds2(248),gacds1(248),gacds2(248),
3178  +bgxds1(248),bgyds1(248),bgzds1(248), bgxds2(248),bgyds2(248),
3179  +bgzds2(248), nchds1(248),nchds2(248),ijcds1(248),ijcds2(248),
3180  +pqdsa1(248,4),pqdsa2(248,4), pqdsb1(248,4),pqdsb2(248,4)
3181  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
3182  *idzre(3),izdre(3),idiqrz(7)
3183 *KEEP,DXQX.
3184 C INCLUDE (XQXQ)
3185 * NOTE: INTMX set via INCLUDE(INTMX)
3186  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
3187  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
3188  * ,xpsu(248),xtsu(248)
3189  * ,xpsut(248),xtsut(248)
3190 *KEEP,LOZUO.
3191  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
3192  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
3193  +intlo(intmx),inloss(intmx)
3194 C /LOZUO/
3195 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
3196 C REJECTED IN KKEVT
3197 C------------------
3198 *KEEP,TRAFOP.
3199  COMMON /trafop/ gamp,bgamp,betp
3200 *KEEP,NUCIMP.
3201  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
3202  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
3203  +prebin,taebin,fermod,etacou
3204 *KEEP,FERMI.
3205  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
3206  +(4,248)
3207 *KEEP,DPAR.
3208 C /DPAR/ CONTAINS PARTICLE PROPERTIES
3209 C ANAME = LITERAL NAME OF THE PARTICLE
3210 C AAM = PARTICLE MASS IN GEV
3211 C GA = DECAY WIDTH
3212 C TAU = LIFE TIME OF INSTABLE PARTICLES
3213 C IICH = ELECTRIC CHARGE OF THE PARTICLE
3214 C IIBAR = BARYON NUMBER
3215 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
3216 C
3217  CHARACTER*8 aname
3218  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
3219  +iibar(210),k1(210),k2(210)
3220 C------------------
3221 *KEEP,DPRIN.
3222  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3223 *KEEP,REJEC.
3224  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
3225  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
3226  +irvs14, irvv11,irvv12,irvv13,irvv14
3227 *KEEP,PROJK.
3228  COMMON /projk/ iprojk
3229  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
3230  common/rptshm/rproj,rtarg,bimpac
3231  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
3232  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
3233  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
3234  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
3235  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
3236  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
3237 *KEND.
3238 C-------------------
3239  IF(iphkk.GE.6)WRITE (6,'( A)') ' kkevds'
3240  irejds=0
3241  DO 10 n=1,nds
3242 C---------------------------drop recombined chain pairs
3243  IF(nchds1(n).EQ.99.AND.nchds2(n).EQ.99)go to 10
3244 C
3245 C*** 4-MOMENTA OF PROJECTILE SEA-QUARK PAIRS IN NN-CMS
3246  IF(iphkk.GE.7)WRITE(6,'(A,2I10)')' KKEVDS N,NDS',n,nds
3247  ixspr=intds1(n)
3248  IF(iphkk.GE.7)WRITE(6,'(A,2I10)')' KKEVDS N,IXSPR',n,ixspr
3249  inucpr=ifrosp(ixspr)
3250  jnucpr=itovp(inucpr)
3251  IF(iphkk.GE.7)WRITE(6,'(A,2I10)')' KKEVDS INUCPR,JNUCPR',
3252  + inucpr,jnucpr
3253 C
3254  psqpx=xpsq(ixspr)*prmom(1,inucpr)
3255  psqpy=xpsq(ixspr)*prmom(2,inucpr)
3256  psqpz=xpsq(ixspr)*prmom(3,inucpr)
3257  psqe=xpsq(ixspr)*prmom(4,inucpr)
3258  psaqpx=xpsaq(ixspr)*prmom(1,inucpr)
3259  psaqpy=xpsaq(ixspr)*prmom(2,inucpr)
3260  psaqpz=xpsaq(ixspr)*prmom(3,inucpr)
3261  psaqe=xpsaq(ixspr)*prmom(4,inucpr)
3262 C
3263 C*** 4-MOMENTA OF TARGET QUARK-AQUARK PAIRS IN NN-CMS
3264  ixsta=intds2(n)
3265  IF(iphkk.GE.7)WRITE(6,'(A,2I10)')' KKEVDS N,IXSTA',n,ixsta
3266  inucta=ifrost(ixsta)
3267  jnucta=itovt(inucta)
3268  IF(iphkk.GE.7)WRITE(6,'(A,2I10)')' KKEVDS INUCTA,JNUCTA',
3269  + inucta,jnucta
3270 C
3271  tsqpx=xtsq(ixsta)*tamom(1,inucta)
3272  tsqpy=xtsq(ixsta)*tamom(2,inucta)
3273  tsqpz=xtsq(ixsta)*tamom(3,inucta)
3274  tsqe=xtsq(ixsta)*tamom(4,inucta)
3275  tsdqpx=xtsaq(ixsta)*tamom(1,inucta)
3276  tsdqpy=xtsaq(ixsta)*tamom(2,inucta)
3277  tsdqpz=xtsaq(ixsta)*tamom(3,inucta)
3278  tsdqe=xtsaq(ixsta)*tamom(4,inucta)
3279 C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
3280 C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
3281 C j.r.6.5.93
3282 C
3283 C multiple scattering of sea quark chain ends
3284 C
3285  IF(it.GT.1)THEN
3286  itnu=ip+inucta
3287  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
3288  rtiy=vhkk(2,itnu)*1.e12
3289  rtiz=vhkk(3,itnu)*1.e12
3290  CALL cromsc(psqpx,psqpy,psqpz,psqe,rtix,rtiy,rtiz,
3291  * psqnx,psqny,psqnz,psqne,59)
3292  psqpx=psqnx
3293  psqpy=psqny
3294  psqpz=psqnz
3295  psqe=psqne
3296  CALL cromsc(psaqpx,psaqpy,psaqpz,psaqe,rtix,rtiy,rtiz,
3297  * psaqnx,psaqny,psaqnz,psaqne,60)
3298  psaqpx=psaqnx
3299  psaqpy=psaqny
3300  psaqpz=psaqnz
3301  psaqe=psaqne
3302 C ---------
3303 C j.r.6.5.93
3304 C
3305 C multiple scattering of sea quark chain ends
3306 C
3307  itnu=ip+inucta
3308  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
3309  rtiy=vhkk(2,itnu)*1.e12
3310  rtiz=vhkk(3,itnu)*1.e12
3311  CALL cromsc(tsqpx,tsqpy,tsqpz,tsqe,rtix,rtiy,rtiz,
3312  * tsqnx,tsqny,tsqnz,tsqne,61)
3313  tsqpx=tsqnx
3314  tsqpy=tsqny
3315  tsqpz=tsqnz
3316  tsqe=tsqne
3317  CALL cromsc(tsdqpx,tsdqpy,tsdqpz,tsdqe,rtix,rtiy,rtiz,
3318  * tsdqnx,tsdqny,tsdqnz,tsdqne,62)
3319  tsdqpx=tsdqnx
3320  tsdqpy=tsdqny
3321  tsdqpz=tsdqnz
3322  tsdqe=tsdqne
3323  ENDIF
3324 C ---------
3325 C j.r.10.5.93
3326  IF(ip.GE.0)go to 1779
3327  psqpz2=psqe**2-psqpx**2-psqpy**2
3328  IF(psqpz2.GE.0.)THEN
3329  psqpz=sqrt(psqpz2)
3330  ELSE
3331  psqpx=0.
3332  psqpy=0.
3333  psqpz=psqe
3334  ENDIF
3335 C
3336  paqpz2=psaqe**2-psaqpx**2-psaqpy**2
3337  IF(paqpz2.GE.0.)THEN
3338  psaqpz=sqrt(paqpz2)
3339  ELSE
3340  psaqpx=0.
3341  psaqpy=0.
3342  psaqpz=psaqe
3343  ENDIF
3344 C
3345  tsqpz2=tsqe**2-tsqpx**2-tsqpy**2
3346  IF(tsqpz2.GE.0.)THEN
3347  tsqpz=-sqrt(tsqpz2)
3348  ELSE
3349  tsqpx=0.
3350  tsqpy=0.
3351  tsqpz=tsqe
3352  ENDIF
3353 C
3354  tdqpz2=tsdqe**2-tsdqpx**2-tsdqpy**2
3355  IF(tdqpz2.GE.0.)THEN
3356  tsdqpz=-sqrt(tdqpz2)
3357  ELSE
3358  tsdqpx=0.
3359  tsdqpy=0.
3360  tsdqpz=tsdqe
3361  ENDIF
3362  1779 CONTINUE
3363 C ---------
3364 C changej.r.6.5.93
3365  ptxsq1=0.
3366  ptxsa1=0.
3367  ptxsq2=0.
3368  ptxsa2=0.
3369  ptysq1=0.
3370  ptysa1=0.
3371  ptysq2=0.
3372  ptysa2=0.
3373  ptxsq1=psqpx
3374  ptxsa1=psaqpx
3375  ptxsq2=tsqpx
3376  ptxsa2=tsdqpx
3377  ptysq1=psqpy
3378  ptysa1=psaqpy
3379  ptysq2=tsqpy
3380  ptysa2=tsdqpy
3381  plq1=psqpz
3382  plaq1=psaqpz
3383  plq2=tsqpz
3384  plaq2=tsdqpz
3385  eq1=psqe
3386  eaq1=psaqe
3387  eq2=tsqe
3388  eaq2=tsdqe
3389 C ---------------
3390 C
3391  ikvala=0
3392  IF(ipev.GE.2) THEN
3393  WRITE(6,'(A,I5)') ' KKEVDS - IRDS13=',irds13
3394  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
3395  + ' DS: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
3396  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
3397  + amch1,amch2,irej,ikvala,pttq1,ptta1
3398  ENDIF
3399  ikvala=0
3400  nselpt=1
3401  CALL selpt( ptxsq1,ptysq1,plq1,
3402  + eq1,ptxsa1,ptysa1,plaq1,eaq1,
3403  + ptxsa2,ptysa2,plaq2,eaq2,
3404  + ptxsq2,ptysq2,plq2,eq2,
3405  + amch1,amch2,irej,ikvala,pttq1,ptta1,
3406  * pttq2,ptta2,
3407  * nselpt)
3408  IF(ipev.GE.2) THEN
3409  WRITE(6,'(A,I5)') ' KKEVDS - IRDS13=',irds13
3410  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
3411  + ' DS: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
3412  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
3413  + amch1,amch2,irej,ikvala,pttq1,ptta1
3414  ENDIF
3415 
3416  IF (ipev.GE.7) WRITE(6,'(A/5X,I10)')
3417  + 'DS IREJ ', irej
3418  IF (irej.EQ.1) THEN
3419  irds13=irds13 + 1
3420  IF(ipev.GE.2) THEN
3421  WRITE(6,'(A,I5)') ' KKEVDS - IRDS13=',irds13
3422  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
3423  + ' DS: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
3424  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
3425  + amch1,amch2,irej,ikvala,pttq1,ptta1
3426  ENDIF
3427  go to 11
3428  ENDIF
3429 C
3430 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
3431 C
3432  ptxch1=ptxsq1 + ptxsq2
3433  ptych1=ptysq1 + ptysq2
3434  ptzch1=plq1 + plq2
3435  ech1=eq1 + eq2
3436  ptxch2=ptxsa2 + ptxsa1
3437  ptych2=ptysa2 + ptysa1
3438  ptzch2=plaq2 + plaq1
3439  ech2=eaq2 + eaq1
3440  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
3441  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
3442 C
3443 C
3444  IF (ipev.GE.6) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
3445  + ' DS: IREJ ',irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
3446  + amch1,ptxch1,ptych1,ptzch1,ech1,
3447  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
3448  + ptzch2,ech2
3449 C
3450 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS OR OCTETT
3451 C OR DECUPLETT BARYONS
3452 C FIRST FOR CHAIN 1 (PROJ SEA-diquark - TAR QUARK)
3453 C
3454  CALL cobcma(ipsq(ixspr),ipsq2(ixspr),itsq(ixsta), ijnch1,nnch1,
3455  + irej,amch1,amch1n,1)
3456 C*** MASS BELOW OCTETT BARYON MASS
3457  IF(irej.EQ.1) THEN
3458  irds11=irds11 + 1
3459  IF(ipev.GE.2) THEN
3460  WRITE(6,'(A,I5)') ' KKEVDS - IRDS11=',irds11
3461  WRITE(6,'(A,6I5/6E12.4/2E12.4)') ' DS:', ipsq(ixspr),ittv1
3462  + (ixsta),ittv2(ixsta),ijnch1,nnch1,irej, xpsq(ixspr),xpsaq
3463  + (ixspr),xpsqcm,xpsacm, xtvq(ixsta),xtvd(ixsta),amch1,amch1n
3464  ENDIF
3465  goto 11
3466  ENDIF
3467 C CORRECT KINEMATICS FOR CHAIN 1
3468 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
3469  IF(nnch1.NE.0)THEN
3470  CALL cormom(amch1,amch2,amch1n,amch2n,
3471  + ptxsq1,ptysq1,plq1,eq1,
3472  + ptxsa1,ptysa1,plaq1,eaq1,
3473  + ptxsa2,ptysa2,plaq2,eaq2,
3474  + ptxsq2,ptysq2,plq2,eq2,
3475  + ptxch1,ptych1,ptzch1,ech1, ptxch2,ptych2,ptzch2,ech2,
3476  + irej)
3477  amch2=amch2n
3478  ENDIF
3479  IF(irej.EQ.1)go to 11
3480 C
3481  IF (ipev.GE.6) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
3482  + ' DS(2): IREJ ',irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
3483  + amch1,ptxch1,ptych1,ptzch1,ech1,
3484  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
3485  + ptzch2,ech2
3486 C
3487 C REPLACE SMALL MASS CHAINS BY octet or decuplet baryons
3488 C SECOND FOR CHAIN 2 (proj sadiquark - tar saquark)
3489 C
3490  CALL cobcma(ipsaq(ixspr),ipsaq2(ixspr),itsaq(ixsta),
3491  + ijnch2,nnch2,irej,amch2,amch2n,2)
3492 c rejection of both s-s chains if mass of chain 2 too low
3493  IF(irej.EQ.1) THEN
3494  irds12=irds12 + 1
3495  IF(ipev.GE.2) THEN
3496  WRITE(6,1090) irds12
3497  WRITE(6,1100) ipsaq(ixspr),ipsaq2(ixspr),itsaq(ixsta),
3498  + ijnch2,nnch2,irej,
3499  + xpsq(ixspr),xpsaq(ixspr),xpsqcm,xpsacm, xtsq(ixsta),xtsaq
3500  + (ixsta),xtsqcm,xtsacm, amch2,amch2n
3501  1090 FORMAT(' KKEVDS - IRDS12=',i5)
3502  1100 FORMAT(' DS - 1100', 6i5/2(4e12.4/),2e12.4)
3503  ENDIF
3504  goto 11
3505  ENDIF
3506 C if AMCH2 changed in COBCMA/COMCMA
3507 C CORVAL corrects chain kinematics
3508 C according to 2-body kinem.
3509 C with fixed masses
3510  IF(nnch2.NE.0) THEN
3511  amch2=amch2n
3512  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
3513  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
3514  eee=ech1+ech2
3515  pxxx=ptxch1+ptxch2
3516  pyyy=ptych1+ptych2
3517  pzzz=ptzch1+ptzch2
3518  gammm=eee/(ammm+1.e-4)
3519  bgggx=pxxx/(ammm+1.e-4)
3520  bgggy=pyyy/(ammm+1.e-4)
3521  bgggz=pzzz/(ammm+1.e-4)
3522 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
3523 C
3524 C 4-MOMENTA OF CHAINS
3525  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
3526  + ptxch1,ptych1,ptzch1,ech1,
3527  + pppch1, qtxch1,qtych1,qtzch1,qech1)
3528 C
3529  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
3530  + ptxch2,ptych2,ptzch2,ech2,
3531  + pppch2, qtxch2,qtych2,qtzch2,qech2)
3532 C
3533  norig=51
3534  CALL corval(ammm,irej,amch1,amch2, qtxch1,qtych1,qtzch1,qech1,
3535  + qtxch2,qtych2,qtzch2,qech2,norig)
3536 C
3537 C 4-MOMENTA OF CHAINS
3538 
3539  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch1,qtych1,qtzch1,qech1,
3540  + pppch1, ptxch1,ptych1,ptzch1,ech1)
3541 C
3542  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch2,qtych2,qtzch2,qech2,
3543  + pppch2, ptxch2,ptych2,ptzch2,ech2)
3544 C
3545 
3546 C
3547  IF(ipev.GE.6) THEN
3548  WRITE(6,'(A/3(1PE15.4),3I5)')
3549  + ' DS - CALL CORVAL: AMMM, AMCH1, AMCH2, NNCH1, NNCH2, IREJ',
3550  + ammm, amch1, amch2, nnch1, nnch2, irej
3551  WRITE(6,1050) irej, amch1,
3552  + ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
3553  1050 FORMAT (' DS: IREJ || ',i10/
3554  + ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
3555  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
3556  ENDIF
3557  IF(irej.EQ.1) THEN
3558 * AMCH1N + AMCH2N > AMMM - 0.2
3559 * reject event
3560  irds14=irds14+1
3561  goto 11
3562  ENDIF
3563  ENDIF
3564 C
3565  qtxch1=ptxch1
3566  qtych1=ptych1
3567  qtzch1=ptzch1
3568  qech1=ech1
3569  qtxch2=ptxch2
3570  qtych2=ptych2
3571  qtzch2=ptzch2
3572  qech2=ech2
3573  pqdsa1(n,1)=ptxsq1
3574  pqdsa1(n,2)=ptysq1
3575  pqdsa1(n,3)=plq1
3576  pqdsa1(n,4)=eq1
3577  pqdsa2(n,1)=ptxsq2
3578  pqdsa2(n,2)=ptysq2
3579  pqdsa2(n,3)=plq2
3580  pqdsa2(n,4)=eq2
3581  pqdsb1(n,1)=ptxsa2
3582  pqdsb1(n,2)=ptysa2
3583  pqdsb1(n,3)=plaq2
3584  pqdsb1(n,4)=eaq2
3585  pqdsb2(n,1)=ptxsa1
3586  pqdsb2(n,2)=ptysa1
3587  pqdsb2(n,3)=plaq1
3588  pqdsb2(n,4)=eaq1
3589 C-------------------
3590 C
3591 C PUT D-S CHAIN ENDS INTO /HKKEVT/
3592 C MOMENTA IN NN-CMS
3593 C POSITION OF ORIGINAL NUCLEONS
3594 C
3595 **** keep for the moment the old s-v notations
3596 C FLAG FOR DS-CHAIN ENDS
3597 C PROJECTILE: ISTHKK=131
3598 C TARGET: ISTHKK=122
3599 C FOR DS-CHAINS ISTHKK=4
3600 C
3601  ihkkpd=jhkkps(ixspr )
3602  ihkkpo=jhkkps(ixspr )-1
3603  ihkktd=jhkkts(ixsta )
3604  ihkkto=jhkkts(ixsta )-1
3605  IF (ipev.GT.3)WRITE(6,1000)ixspr,inucpr,jnucpr,ihkkpo,ihkkpd
3606  1000 FORMAT (' IXSPR,INUCPR,JNUCPR,IHKKPO,IHKKPD ',5i5)
3607  IF (ipev.GT.3)WRITE(6,1010)ixsta,inucta,jnucta,ihkkto,ihkktd
3608  1010 FORMAT (' IXSTA,INUCTA,JNUCTA,IHKKTO,IHKKTD ',5i5)
3609 C CHAIN 1 PROJECTILE SEA-diquark
3610  nhkk=nhkk+1
3611  IF (nhkk.EQ.nmxhkk)THEN
3612  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
3613  RETURN
3614  ENDIF
3615  ihkk=nhkk
3616  isthkk(ihkk)=131
3617  idhkk(ihkk)=idhkk(ihkkpo)
3618  jmohkk(1,ihkk)=ihkkpo
3619  jmohkk(2,ihkk)=jmohkk(1,ihkkpo)
3620  jdahkk(1,ihkk)=ihkk+2
3621  jdahkk(2,ihkk)=ihkk+2
3622  phkk(1,ihkk)=pqdsa1(n,1)
3623  phkk(2,ihkk)=pqdsa1(n,2)
3624  phkk(3,ihkk)=pqdsa1(n,3)
3625  phkk(4,ihkk)=pqdsa1(n,4)
3626  phkk(5,ihkk)=0.
3627 C Add position of parton in hadron
3628  CALL qinnuc(xxpp,yypp)
3629  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
3630  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
3631  vhkk(3,ihkk)=vhkk(3,ihkkpo)
3632  vhkk(4,ihkk)=vhkk(4,ihkkpo)
3633  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
3634  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
3635  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
3636 
3637  1020 FORMAT (i6,i4,5i6,9e10.2)
3638 C CHAIN 1 TARGET QUARK
3639  nhkk=nhkk+1
3640  IF (nhkk.EQ.nmxhkk)THEN
3641  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
3642  RETURN
3643  ENDIF
3644  ihkk=nhkk
3645  isthkk(ihkk)=122
3646  idhkk(ihkk)=idhkk(ihkktd)
3647  jmohkk(1,ihkk)=ihkktd
3648  jmohkk(2,ihkk)=jmohkk(1,ihkktd)
3649  jdahkk(1,ihkk)=ihkk+1
3650  jdahkk(2,ihkk)=ihkk+1
3651  phkk(1,ihkk)=pqdsa2(n,1)
3652  phkk(2,ihkk)=pqdsa2(n,2)
3653  phkk(3,ihkk)=pqdsa2(n,3)
3654  phkk(4,ihkk)=pqdsa2(n,4)
3655  phkk(5,ihkk)=0.
3656 C Add position of parton in hadron
3657  CALL qinnuc(xxpp,yypp)
3658  vhkk(1,ihkk)=vhkk(1,ihkktd)+xxpp
3659  vhkk(2,ihkk)=vhkk(2,ihkktd)+yypp
3660  vhkk(3,ihkk)=vhkk(3,ihkktd)
3661  vhkk(4,ihkk)=vhkk(4,ihkktd)
3662  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
3663  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
3664  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
3665 
3666 C
3667 C CHAIN 1 BEFORE FRAGMENTATION
3668  nhkk=nhkk+1
3669  IF (nhkk.EQ.nmxhkk)THEN
3670  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
3671  RETURN
3672  ENDIF
3673  ihkk=nhkk
3674  isthkk(ihkk)=4
3675  idhkk(ihkk)=88888+nnch1
3676  jmohkk(1,ihkk)=ihkk-2
3677  jmohkk(2,ihkk)=ihkk-1
3678  phkk(1,ihkk)=qtxch1
3679  phkk(2,ihkk)=qtych1
3680  phkk(3,ihkk)=qtzch1
3681  phkk(4,ihkk)=qech1
3682  phkk(5,ihkk)=amch1
3683 C POSITION OF CREATED CHAIN IN LAB
3684 C =POSITION OF TARGET NUCLEON
3685 C TIME OF CHAIN CREATION IN LAB
3686 C =TIME OF PASSAGE OF PROJECTILE
3687 C NUCLEUS AT POSITION OF TAR. NUCLEUS
3688  vhkk(1,nhkk)= vhkk(1,nhkk-1)
3689  vhkk(2,nhkk)= vhkk(2,nhkk-1)
3690  vhkk(3,nhkk)= vhkk(3,nhkk-1)
3691  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
3692  mhkkds(n)=ihkk
3693  IF (iprojk.EQ.1)THEN
3694  whkk(1,nhkk)= vhkk(1,nhkk-2)
3695  whkk(2,nhkk)= vhkk(2,nhkk-2)
3696  whkk(3,nhkk)= vhkk(3,nhkk-2)
3697  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
3698  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
3699  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
3700  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
3701 
3702  ENDIF
3703  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
3704  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
3705  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
3706 
3707 C
3708 C
3709 C CHAIN 2 projectile sea antidiquark
3710  nhkk=nhkk+1
3711  IF (nhkk.EQ.nmxhkk)THEN
3712  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
3713  RETURN
3714  ENDIF
3715  ihkk=nhkk
3716  isthkk(ihkk)=131
3717  idhkk(ihkk)=idhkk(ihkkpd)
3718  jmohkk(1,ihkk)=ihkkpd
3719  jmohkk(2,ihkk)=jmohkk(1,ihkkpd)
3720  jdahkk(1,ihkk)=ihkk+2
3721  jdahkk(2,ihkk)=ihkk+2
3722  phkk(1,ihkk)=pqdsb1(n,1)
3723  phkk(2,ihkk)=pqdsb1(n,2)
3724  phkk(3,ihkk)=pqdsb1(n,3)
3725  phkk(4,ihkk)=pqdsb1(n,4)
3726  phkk(5,ihkk)=0.
3727 C Add position of parton in hadron
3728  CALL qinnuc(xxpp,yypp)
3729  vhkk(1,ihkk)=vhkk(1,ihkkpd)+xxpp
3730  vhkk(2,ihkk)=vhkk(2,ihkkpd)+yypp
3731  vhkk(3,ihkk)=vhkk(3,ihkkpd)
3732  vhkk(4,ihkk)=vhkk(4,ihkkpd)
3733  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
3734  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
3735  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
3736 
3737 C CHAIN 2 TARGET diquark
3738  nhkk=nhkk+1
3739  IF (nhkk.EQ.nmxhkk)THEN
3740  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
3741  RETURN
3742  ENDIF
3743  ihkk=nhkk
3744  isthkk(ihkk)=122
3745  idhkk(ihkk)=idhkk(ihkkto)
3746  jmohkk(1,ihkk)=ihkkto
3747  jmohkk(2,ihkk)=jmohkk(1,ihkkto)
3748  jdahkk(1,ihkk)=ihkk+1
3749  jdahkk(2,ihkk)=ihkk+1
3750  phkk(1,ihkk)=pqdsb2(n,1)
3751  phkk(2,ihkk)=pqdsb2(n,2)
3752  phkk(3,ihkk)=pqdsb2(n,3)
3753  phkk(4,ihkk)=pqdsb2(n,4)
3754  phkk(5,ihkk)=0.
3755 C Add position of parton in hadron
3756  CALL qinnuc(xxpp,yypp)
3757  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
3758  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
3759  vhkk(3,ihkk)=vhkk(3,ihkkto)
3760  vhkk(4,ihkk)=vhkk(4,ihkkto)
3761  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
3762  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
3763  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
3764 
3765 C
3766 C CHAIN 2 BEFORE FRAGMENTATION
3767  nhkk=nhkk+1
3768  IF (nhkk.EQ.nmxhkk)THEN
3769  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
3770  RETURN
3771  ENDIF
3772  ihkk=nhkk
3773  isthkk(ihkk)=4
3774  idhkk(ihkk)=88888+nnch2
3775  jmohkk(1,ihkk)=ihkk-2
3776  jmohkk(2,ihkk)=ihkk-1
3777  phkk(1,ihkk)=qtxch2
3778  phkk(2,ihkk)=qtych2
3779  phkk(3,ihkk)=qtzch2
3780  phkk(4,ihkk)=qech2
3781  phkk(5,ihkk)=amch2
3782 C POSITION OF CREATED CHAIN IN LAB
3783 C =POSITION OF TARGET NUCLEON
3784 C TIME OF CHAIN CREATION IN LAB
3785 C =TIME OF PASSAGE OF PROJECTILE
3786 C NUCLEUS AT POSITION OF TAR. NUCLEUS
3787  vhkk(1,nhkk)= vhkk(1,nhkk-1)
3788  vhkk(2,nhkk)= vhkk(2,nhkk-1)
3789  vhkk(3,nhkk)= vhkk(3,nhkk-1)
3790  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
3791  mhkkds(n)=ihkk
3792  IF (iprojk.EQ.1)THEN
3793  whkk(1,nhkk)= vhkk(1,nhkk-2)
3794  whkk(2,nhkk)= vhkk(2,nhkk-2)
3795  whkk(3,nhkk)= vhkk(3,nhkk-2)
3796  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
3797  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
3798  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
3799  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
3800 
3801  ENDIF
3802  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
3803  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
3804  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
3805 C
3806 C NOW WE HAVE AN ACCEPTABLE SEA--VALENCE EVENT
3807 * sea diquark pair!
3808 C AND PUT IT INTO THE HISTOGRAM
3809 C
3810  amcds1(n)=amch1
3811  amcds2(n)=amch2
3812  gacds1(n)=qech1/amch1
3813  bgxds1(n)=qtxch1/amch1
3814  bgyds1(n)=qtych1/amch1
3815  bgzds1(n)=qtzch1/amch1
3816  gacds2(n)=qech2/amch2
3817  bgxds2(n)=qtxch2/amch2
3818  bgyds2(n)=qtych2/amch2
3819  bgzds2(n)=qtzch2/amch2
3820  nchds1(n)=nnch1
3821  nchds2(n)=nnch2
3822  ijcds1(n)=ijnch1
3823  ijcds2(n)=ijnch2
3824  IF (ipev.GE.6) WRITE(6,'(A/I10,4F12.7,5I5/10X,4F12.6/10X,6F12.6,
3825  +4I5/8F15.5/ 8F15.5)') ' DS / FINAL PRINT',n
3826 C +, XPSQ
3827 C + (IXSPR),XPSAQ(IXSPR),XTSQ(IXSTA),XTSAQ(IXSTA), IPSQ(IXSPR),IPSAQ
3828 C + (IXSPR), ITSQ(IXSTA),ITTV1(IXSTA),ITTV2(IXSTA), AMCDS1(N),AMCDS2
3829 C + (N),GACDS1(N),GACDS2(N), BGXDS1(N),BGYDS1(N),BGZDS1(N), BGXDS2
3830 C + (N),BGYDS2(N),BGZDS2(N), NCHDS1(N),NCHDS2(N),IJCDS1(N),IJCDS2
3831 C + (N), (PQDSA1(N,JU),PQDSA2(N,JU),PQDSB1(N,JU), PQDSB2(N,JU),JU=1,
3832 C + 4)
3833  go to 20
3834 C*** TREATMENT OF REJECTED SEA-SEA INTERACTIONS
3835  11 CONTINUE
3836  nchds1(n)=99
3837  nchds2(n)=99
3838  xpvd(jnucpr)=xpvd(jnucpr) + xpsq(ixspr) + xpsaq(ixspr)
3839  xtvd(jnucta)=xtvd(jnucta) + xtsaq(ixsta) + xtsq(ixsta)
3840  issqq=abs(ipsaq(ixspr))
3841  jssqq=abs(ipsaq2(ixspr))
3842  IF(issqq.EQ.3.AND.jssqq.EQ.3)THEN
3843  idsre(3)=idsre(3)+1
3844  ELSEIF(issqq.EQ.3.OR.jssqq.EQ.3)THEN
3845  idsre(2)=idsre(2)+1
3846  ELSE
3847  idsre(1)=idsre(1)+1
3848  ENDIF
3849  20 CONTINUE
3850  10 CONTINUE
3851  RETURN
3852  END
3853 C
3854 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3855 C
3856 C DEBUG SUBCHK
3857 C END DEBUG
3858  SUBROUTINE hadrds
3859  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3860  SAVE
3861 C-------------------------
3862 C
3863 C hadronize sea diquark - valence CHAINS
3864 C
3865 C ADD GENERATED HADRONS TO /ALLPAR/
3866 C STARTING AT (NAUX + 1)
3867 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
3868 C
3869 C---------------------------------------------------------
3870  COMMON /zsea/zseaav,zseasu,anzsea
3871  common/popcck/pdbck,pdbse,pdbseu,
3872  * ijpock,irejck,ick4,ihad4,ick6,ihad6
3873  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
3874  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
3875  *isea43,isea63,irejao
3876 *KEEP,INTMX.
3877  parameter(intmx=2488,intmd=252)
3878 *KEEP,IFROTO.
3879  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
3880  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
3881  +jhkknt
3882  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
3883  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
3884  & mhkkhh(intmx),
3885  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
3886 *KEEP,DIQI.
3887  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
3888  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
3889  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
3890  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
3891 *KEEP,DXQX.
3892 C INCLUDE (XQXQ)
3893 * NOTE: INTMX set via INCLUDE(INTMX)
3894  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
3895  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
3896  * ,xpsu(248),xtsu(248)
3897  * ,xpsut(248),xtsut(248)
3898 *KEEP,INTNEW.
3899  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
3900  +ixpv,ixps,ixtv,ixts, intvv1(248),
3901  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
3902  +intss1(intmx),intss2(intmx),
3903  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
3904  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
3905 
3906 C /INTNEW/
3907 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
3908 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
3909 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
3910 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
3911 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
3912 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
3913 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
3914 C FROM PROJECTILE/TARGET NUCLEI
3915 C-------------------
3916 *KEEP,ABRDS.
3917  COMMON /abrds/ amcds1(248),amcds2(248),gacds1(248),gacds2(248),
3918  +bgxds1(248),bgyds1(248),bgzds1(248), bgxds2(248),bgyds2(248),
3919  +bgzds2(248), nchds1(248),nchds2(248),ijcds1(248),ijcds2(248),
3920  +pqdsa1(248,4),pqdsa2(248,4), pqdsb1(248,4),pqdsb2(248,4)
3921 *KEEP,LOZUO.
3922  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
3923  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
3924  +intlo(intmx),inloss(intmx)
3925 C /LOZUO/
3926 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
3927 C REJECTED IN KKEVT
3928 C------------------
3929 *KEEP,HKKEVT.
3930 c INCLUDE (HKKEVT)
3931  parameter(nmxhkk= 89998)
3932 c PARAMETER (NMXHKK=25000)
3933  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
3934  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
3935  +(4,nmxhkk)
3936 C
3937 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
3938 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
3939 C THE POSITIONS OF THE PROJECTILE NUCLEONS
3940 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
3941 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
3942 C COMPLETELY CONSISTENT. THE TIMES IN THE
3943 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
3944 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
3945 C
3946 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
3947 C
3948 C NMXHKK: maximum numbers of entries (partons/particles) that can be
3949 C stored in the commonblock.
3950 C
3951 C NHKK: the actual number of entries stored in current event. These are
3952 C found in the first NHKK positions of the respective arrays below.
3953 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
3954 C entry.
3955 C
3956 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
3957 C = 0 : null entry.
3958 C = 1 : an existing entry, which has not decayed or fragmented.
3959 C This is the main class of entries which represents the
3960 C "final state" given by the generator.
3961 C = 2 : an entry which has decayed or fragmented and therefore
3962 C is not appearing in the final state, but is retained for
3963 C event history information.
3964 C = 3 : a documentation line, defined separately from the event
3965 C history. (incoming reacting
3966 C particles, etc.)
3967 C = 4 - 10 : undefined, but reserved for future standards.
3968 C = 11 - 20 : at the disposal of each model builder for constructs
3969 C specific to his program, but equivalent to a null line in the
3970 C context of any other program. One example is the cone defining
3971 C vector of HERWIG, another cluster or event axes of the JETSET
3972 C analysis routines.
3973 C = 21 - : at the disposal of users, in particular for event tracking
3974 C in the detector.
3975 C
3976 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
3977 C standard.
3978 C
3979 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
3980 C The value is 0 for initial entries.
3981 C
3982 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
3983 C one mother exist, in which case the value 0 is used. In cluster
3984 C fragmentation models, the two mothers would correspond to the q
3985 C and qbar which join to form a cluster. In string fragmentation,
3986 C the two mothers of a particle produced in the fragmentation would
3987 C be the two endpoints of the string (with the range in between
3988 C implied).
3989 C
3990 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
3991 C entry has not decayed, this is 0.
3992 C
3993 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
3994 C entry has not decayed, this is 0. It is assumed that the daughters
3995 C of a particle (or cluster or string) are stored sequentially, so
3996 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
3997 C daughters. Even in cases where only one daughter is defined (e.g.
3998 C K0 -> K0S) both values should be defined, to make for a uniform
3999 C approach in terms of loop constructions.
4000 C
4001 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
4002 C
4003 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
4004 C
4005 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
4006 C
4007 C PHKK(4,IHKK) : energy, in GeV.
4008 C
4009 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
4010 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
4011 C
4012 C VHKK(1,IHKK) : production vertex x position, in mm.
4013 C
4014 C VHKK(2,IHKK) : production vertex y position, in mm.
4015 C
4016 C VHKK(3,IHKK) : production vertex z position, in mm.
4017 C
4018 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
4019 C********************************************************************
4020 *KEEP,DFINPA.
4021  CHARACTER*8 anf
4022  parameter(nfimax=249)
4023  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
4024  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
4025  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
4026  * istath(nfimax)
4027 *KEEP,DPRIN.
4028  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4029 *KEEP,PROJK.
4030  COMMON /projk/ iprojk
4031 *KEND.
4032  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
4033 C modified DPMJET
4034  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
4035  * anndv,annvd,annds,annsd,
4036  * annhh,annzz,
4037  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
4038  * pthh,ptzz,
4039  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
4040  * eehh,eezz
4041  * ,anndi,ptdi,eedi
4042  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
4043  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
4044  * acouzz,acouhh,acouds,acousd,
4045  * acoudz,acouzd,acoudi,
4046  * acoudv,acouvd,acoucc
4047  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
4048  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
4049  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
4050  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
4051  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
4052  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
4053 C---------------------
4054  dimension poj(4),pat(4)
4055  DATA ncalds /0/
4056 C-----------------------------------------------------------------------
4057  IF(iphkk.GE.6)WRITE (6,'( A)') ' hadrds'
4058  ncalds=ncalds+1
4059  DO 50 i=1,nds
4060 C-----------------------drop recombined chain pairs
4061  IF(nchds1(i).EQ.99.AND.nchds2(i).EQ.99) go to 50
4062  is1=intds1(i)
4063  is2=intds2(i)
4064 C
4065  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itsq(is2),
4066  + itsaq(is2),ittv2(is2), amcds1(i),amcds2(i),gacds1(i),gacds2(i),
4067  + bgxds1(i),bgyds1(i),bgzds1(i), bgxds2(i),bgyds2(i),bgzds2(i),
4068  + nchds1(i),nchds2(i),ijcds1(i),ijcds2(i), pqdsa1(i,4),pqdsa2
4069  + (i,4),pqdsb1(i,4),pqdsb2(i,4)
4070  1000 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
4071 C
4072 C++++++++++++++++++++++++++++++ CHAIN 1: diquark-quark +++++++++++
4073  ifb1=ipsq(is1)
4074  ifb2=ipsq2(is1)
4075  ifb3=itsq(is2)
4076  DO 10 j=1,4
4077  poj(j)=pqdsa1(i,j)
4078  pat(j)=pqdsa2(i,j)
4079  10 CONTINUE
4080  IF((nchds1(i).NE.0.OR.nchds2(i).NE.0).AND.ip.NE.1)
4081  & CALL saptre(amcds1(i),gacds1(i),bgxds1(i),bgyds1(i),bgzds1(i),
4082  & amcds2(i),gacds2(i),bgxds2(i),bgyds2(i),bgzds2(i))
4083 C----------------------------------------------------------------
4084 C----------------------------------------------------------------
4085  IF(ipco.GE.3)WRITE (6,1244) poj,pat
4086  1244 FORMAT (' D-S QUARK-DIQUARK POJ,PAT ',8e12.3)
4087 * IF(AMCDS1(I).LT.1.6)THEN
4088 * IF(NCHDS1(I).EQ.0)THEN
4089 * WRITE(6,'(A,F10.2,5I5)')' HADRDS AMCDS1(I),NCHDS1(I),I ',
4090 * + AMCDS1(I),NCHDS1(I),IJCDS1(I),I,IS1,IS2
4091 * RETURN
4092 * ENDIF
4093 * ENDIF
4094 C------------------------------------------------------------------
4095 C check bookkeeping
4096 C-----------------------------------------------------------------
4097 C I= number of valence chain
4098 C Projectile Nr ipp = IFROVP(INTVS1(I))
4099 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
4100 C IPPP = IFROVP(INTVS1(I))
4101 C WRITE(6,*)' INTVS1(I) INTDS1(I)',INTVS1(I),INTDS1(I)
4102 C IF(INTDS1(I).GE.1.AND.INTDS1(I).LE.INTMD)THEN
4103 C IPPP = IFROVP(INTDS1(I))
4104 C ELSE
4105 C WRITE(6,*)' HADRDS: INTDS1(I) ',INTDS1(I)
4106  ippp=0
4107 C ENDIF
4108 C WRITE(6,*)' IPPP ',IPPP
4109 C IF(IPPP.GT.0)THEN
4110 C JIPP=JSSHS(IPPP)
4111 C ELSEIF(IPPP.EQ.0)THEN
4112  jipp=1
4113 C ENDIF
4114 C WRITE(6,*)' JIPP ',JIPP
4115 C IF(NCHVS2(I).EQ.0)THEN
4116  IF(ipco.GE.3)WRITE(6,'(A,3I5)')'HADRDS: I,IPPP,JIPP ',
4117  * i,ippp,jipp
4118 C ENDIF
4119 C------------------------------------------------------------------
4120 C check bookkeeping
4121 C-----------------------------------------------------------------
4122  IF(ifb1.LE.2.AND.ifb2.LE.2)THEN
4123  ndsuu=ndsuu+1
4124  ELSEIF((ifb1.EQ.3.AND.ifb2.LE.2).OR.
4125  * (ifb2.EQ.3.AND.ifb1.LE.2))THEN
4126  ndsus=ndsus+1
4127  ELSEIF(ifb1.EQ.3.AND.ifb2.EQ.3)THEN
4128  ndsss=ndsss+1
4129  ENDIF
4130  IF((nchds1(i).NE.0))
4131  * CALL hadjet(nhad,amcds1(i),poj,pat,gacds1(i),
4132  * bgxds1(i), bgyds1
4133  + (i),bgzds1(i),ifb1,ifb2,ifb3,ifb4, ijcds1(i),
4134  * ijcds1(i),6,nchds1
4135  + (i),15)
4136 C---------------------------------------------------------------
4137  aack=float(ick6)/float(ick6+ihad6+1)
4138  IF((nchds1(i).EQ.0))THEN
4139  zseawu=rndm(bb)*2.d0*zseaav
4140  rseack=float(jitt)*pdbse +zseawu*pdbseu
4141  IF(ipco.GE.1)WRITE(6,'(2A,I5,2F10.3)')'HADJSE JIPP,',
4142  * 'RSEACK,PDBSE 3 dpmnuc5',
4143  + jipp,rseack,pdbse
4144  irejss=5
4145  IF(rndm(v).LE.rseack)THEN
4146  irejss=2
4147  IF(amcds1(i).GT.2.3d0)THEN
4148  irejss=0
4149  CALL hadjse(nhad,amcds1(i),poj,pat,gacds1(i),bgxds1(i),
4150  * bgyds1
4151  + (i),bgzds1(i),ifb1,ifb2,ifb3,ifb4, ijcds1(i),ijcds1(i),6,
4152  * nchds1
4153  + (i),6,irejss,iissqq)
4154  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JIPP,',
4155  * 'RSEACK,IREJSS 3 dpmnuc5 ',
4156  + jipp,rseack,irejss
4157  ENDIF
4158  IF(irejss.GE.1)THEN
4159  IF(irejss.EQ.1)irejse=irejse+1
4160  IF(irejss.EQ.3)irejs3=irejs3+1
4161  IF(irejss.EQ.2)irejs0=irejs0+1
4162  CALL hadjet(nhad,amcds1(i),poj,pat,gacds1(i),
4163  * bgxds1(i), bgyds1
4164  + (i),bgzds1(i),ifb1,ifb2,ifb3,ifb4, ijcds1(i),
4165  * ijcds1(i),6,nchds1
4166  + (i),15)
4167  ihad6=ihad6+1
4168  ENDIF
4169  IF(irejss.EQ.0)THEN
4170  IF(iissqq.EQ.3)THEN
4171  ise63=ise63+1
4172  ELSE
4173  ise6=ise6+1
4174  ENDIF
4175  ENDIF
4176  ELSE
4177  CALL hadjet(nhad,amcds1(i),poj,pat,gacds1(i),
4178  * bgxds1(i), bgyds1
4179  + (i),bgzds1(i),ifb1,ifb2,ifb3,ifb4, ijcds1(i),
4180  * ijcds1(i),6,nchds1
4181  + (i),15)
4182  ihad6=ihad6+1
4183  ENDIF
4184  ENDIF
4185 
4186 C---------------------------------------------------------------
4187  acouds=acouds+1
4188  nhkkau=nhkk+1
4189  DO 20 j=1,nhad
4190  IF (nhkk.EQ.nmxhkk) THEN
4191  WRITE (6,'(A,2I5/A)') .EQ.' HADRDS: NHKKNMXHKK ',nhkk,nmxhkk
4192  RETURN
4193  ENDIF
4194 C NHKK=NHKK+1
4195  IF (nhkk.EQ.nmxhkk)THEN
4196  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
4197  RETURN
4198  ENDIF
4199 C
4200  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4201  IF (abs(ehecc-hef(j)).GT.0.001) THEN
4202 C WRITE(6,'(2A/3I5,3E15.6)')
4203 C & ' HADRDS / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
4204 C * ' NCALDS, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4205 C * NCALDS, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
4206  hef(j)=ehecc
4207  ENDIF
4208  annds=annds+1
4209  eeds=eeds+hef(j)
4210  ptds=ptds+sqrt(pxf(j)**2+pyf(j)**2)
4211 C PUT NN-CMS HADRONS INTO /HKKEVT/
4212  istist=1
4213  IF(ibarf(j).EQ.500)istist=2
4214  IF(ipco.GE.3)WRITE(6,*)' HADRDS before HKKFIL'
4215  CALL hkkfil(istist,mpdgha(nref(j)),mhkkds(i)-3,0,
4216  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),17)
4217  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
4218  + (nhkk)
4219  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
4220  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4221  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4222 
4223  20 CONTINUE
4224 C IF(NHAD.GT.0) THEN
4225 C JDAHKK(1,IMOHKK)=NHKKAU
4226 C JDAHKK(2,IMOHKK)=NHKK
4227 C ENDIF
4228 C+++++++++++++++++++++++++++++ CHAIN 2: adiquark - aquark +++++++++
4229  ifb1=ipsaq(is1)
4230  ifb2=ipsaq2(is1)
4231  ifb3=itsaq(is2)
4232  ifb1=iabs(ifb1)+6
4233  ifb2=iabs(ifb2)+6
4234  ifb3=iabs(ifb3)+6
4235  DO 30 j=1,4
4236  poj(j)=pqdsb2(i,j)
4237  pat(j)=pqdsb1(i,j)
4238  30 CONTINUE
4239 * IF(AMCDS2(I).LT.1.6)THEN
4240 * IF(NCHDS2(I).EQ.0)THEN
4241 C WRITE(6,'(A,F10.2,5I5)')' HADRDS AMCDS2(I),NCHDS2(I),I ',
4242 C + AMCDS2(I),NCHDS2(I),IJCDS2(I),I,IS1,IS2
4243 * RETURN
4244 * ENDIF
4245 * ENDIF
4246 C
4247 C------------------------------------------------------------------
4248 C check bookkeeping
4249 C-----------------------------------------------------------------
4250 C I= number of valence chain
4251 C Projectile Nr ipp = IFROVP(INTVS1(I))
4252 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
4253 C WRITE(6,*)'HADRDS INTDS2(I) ',INTDS2(I)
4254 C IPPP = IFROVP(INTVS1(I))
4255 C IF(INTDS2(I).GE.1)THEN
4256 C ITTT = IFROVP(INTDS2(I))
4257 C ELSE
4258  ittt=0
4259 C ENDIF
4260 C WRITE(6,*)' HADRDS 2 IPPP', IPPP
4261 C IF(ITTT.GT.0)THEN
4262 C JITT=JSSHS(ITTT)
4263 C ELSE
4264  jitt=0
4265 C ENDIF
4266 C IF(NCHVS2(I).EQ.0)THEN
4267 C WRITE(6,'(A,3I5)')'HADRDS: I,IPPP,JIPP ',
4268 C * I,IPPP,JIPP
4269 C ENDIF
4270 C------------------------------------------------------------------
4271 C check bookkeeping
4272 C-----------------------------------------------------------------
4273  IF(ifb1.LE.8.AND.ifb2.LE.8)THEN
4274  nadsuu=nadsuu+1
4275  ELSEIF((ifb1.EQ.9.AND.ifb2.LE.8).OR.
4276  * (ifb2.EQ.9.AND.ifb1.LE.8))THEN
4277  nadsus=nadsus+1
4278  ELSEIF(ifb1.EQ.9.AND.ifb2.EQ.9)THEN
4279  nadsss=nadsss+1
4280  ENDIF
4281 C WRITE(6,*)'NCHDS2(I)',NCHDS2(I)
4282 C WRITE(6,*)' before HADJET:AMCDS2(I),GACDS2(I),BGXDS2(I),',
4283 C * AMCDS2(I),GACDS2(I),BGXDS2(I)
4284  IF((nchds2(i).NE.0))
4285  * CALL hadjet(nhad,amcds2(i),poj,pat,gacds2(i),
4286  * bgxds2(i), bgyds2
4287  + (i),bgzds2(i),ifb1,ifb2,ifb3,ifb4, ijcds2(i),
4288  * ijcds2(i),6,nchds2
4289  + (i),16)
4290 C WRITE(6,*)' after HADJET '
4291 C-----------------------------------------------------------------
4292  aack=float(ick6)/float(ick6+ihad6+1)
4293  IF((nchds2(i).EQ.0))THEN
4294  zseawu=rndm(bb)*2.d0*zseaav
4295  rseack=float(jitt)*pdbse +zseawu*pdbseu
4296  IF(ipco.GE.1)WRITE(6,'(2A,I5,2F10.3)')'HADJSE JIPP,',
4297  * 'RSEACK,PDBSE ',
4298  + jipp,rseack,pdbse
4299  irejss=5
4300  IF(rndm(v).LE.rseack)THEN
4301  irejss=2
4302  IF(amcds2(i).GT.2.3d0)THEN
4303  irejss=0
4304 C WRITE(6,*)' before HADJASE '
4305  CALL hadjase(nhad,amcds2(i),poj,pat,gacds2(i),bgxds2(i),
4306  * bgyds2
4307  + (i),bgzds2(i),ifb1,ifb2,ifb3,ifb4, ijcds2(i),ijcds2(i),6,
4308  * nchds2
4309  + (i),6,irejss,iissqq)
4310  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JIPP,',
4311  * 'RSEACK,IREJSS ',
4312  + jipp,rseack,irejss
4313  ENDIF
4314  IF(irejss.GE.1)THEN
4315  IF(irejss.EQ.1)irejsa=irejsa+1
4316  IF(irejss.EQ.3)ireja3=ireja3+1
4317  IF(irejss.EQ.2)ireja0=ireja0+1
4318 C WRITE(6,*)' before HADJET2 '
4319  CALL hadjet(nhad,amcds2(i),poj,pat,gacds2(i),
4320  * bgxds2(i), bgyds2
4321  + (i),bgzds2(i),ifb1,ifb2,ifb3,ifb4, ijcds2(i),
4322  * ijcds2(i),6,nchds2
4323  + (i),16)
4324  ihada6=ihada6+1
4325  ENDIF
4326  IF(irejss.EQ.0)THEN
4327  IF(iissqq.EQ.3)THEN
4328  isea63=isea63+1
4329  ELSE
4330  isea6=isea6+1
4331  ENDIF
4332  ENDIF
4333  ELSE
4334 C WRITE(6,*)' before HADJET3 '
4335  CALL hadjet(nhad,amcds2(i),poj,pat,gacds2(i),
4336  * bgxds2(i), bgyds2
4337  + (i),bgzds2(i),ifb1,ifb2,ifb3,ifb4, ijcds2(i),
4338  * ijcds2(i),6,nchds2
4339  + (i),16)
4340  ihada6=ihada6+1
4341  ENDIF
4342  ENDIF
4343 C--------------------------------------------------------------------
4344 C ADD HADRONS/RESONANCES INTO
4345 C COMMON /ALLPAR/ STARTING AT NAUX
4346  nhkkau=nhkk+1
4347  DO 40 j=1,nhad
4348  IF (nhkk.EQ.nmxhkk) THEN
4349  WRITE (6,'(A,2I5/A)') .EQ.' HADRDS: NHKKNMXHKK ', nhkk,
4350  + nmxhkk
4351  RETURN
4352  ENDIF
4353 C NHKK=NHKK+1
4354  IF (nhkk.EQ.nmxhkk)THEN
4355  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
4356  RETURN
4357  ENDIF
4358 C
4359  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4360  IF (abs(ehecc-hef(j)).GT.0.001) THEN
4361 C WRITE(6,'(2A/3I5,3E15.6)')
4362 C & ' HADRDS / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
4363 C * ' NCALDS, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4364 C * NCALDS, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
4365  hef(j)=ehecc
4366  ENDIF
4367  annds=annds+1
4368  eeds=eeds+hef(j)
4369  ptds=ptds+sqrt(pxf(j)**2+pyf(j)**2)
4370 C PUT NN-CMS HADRONS INTO /HKKEVT/
4371  istist=1
4372  IF(ibarf(j).EQ.500)istist=2
4373  IF(ipco.GE.3)WRITE(6,*)' HADRDS before 2 HKKFIL'
4374  CALL hkkfil(istist,mpdgha(nref(j)),mhkkds(i),0,
4375  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),18)
4376  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
4377  + (nhkk)
4378  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
4379  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4380  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4381 
4382  40 CONTINUE
4383 C IF(NHAD.GT.0) THEN
4384 C JDAHKK(1,IMOHKK)=NHKKAU
4385 C JDAHKK(2,IMOHKK)=NHKK
4386 C ENDIF
4387  50 CONTINUE
4388 C----------------------------------------------------------------
4389 C
4390  RETURN
4391  1010 FORMAT (i6,i4,5i6,9e10.2)
4392  1020 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
4393  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
4394  END
4395 C
4396 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4397 C
4398  SUBROUTINE diqssd(ECM,ITS,IPS,IREJ)
4399  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4400  SAVE
4401 * define s-d chains (sea - sea diquark chains)
4402 * sq-sqsq and saq-saqsaq chains instead of q-aq and aq-q chains
4403  COMMON /zsea/zseaav,zseasu,anzsea
4404  common/popcck/pdbck,pdbse,pdbseu,
4405  * ijpock,irejck,ick4,ihad4,ick6,ihad6
4406  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
4407  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
4408  *isea43,isea63,irejao
4409 *KEEP,INTMX.
4410  parameter(intmx=2488,intmd=252)
4411 *KEEP,IFROTO.
4412  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
4413  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
4414  +jhkknt
4415  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
4416  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
4417  & mhkkhh(intmx),
4418  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
4419 *KEEP,DIQI.
4420  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
4421  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
4422  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
4423  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
4424 *KEEP,DXQX.
4425 C INCLUDE (XQXQ)
4426 * NOTE: INTMX set via INCLUDE(INTMX)
4427  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
4428  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
4429  * ,xpsu(248),xtsu(248)
4430  * ,xpsut(248),xtsut(248)
4431 *KEEP,INTNEW.
4432  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
4433  +ixpv,ixps,ixtv,ixts, intvv1(248),
4434  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
4435  +intss1(intmx),intss2(intmx),
4436  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
4437  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
4438 
4439 C /INTNEW/
4440 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
4441 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
4442 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
4443 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
4444 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
4445 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
4446 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
4447 C FROM PROJECTILE/TARGET NUCLEI
4448 C-------------------
4449 *KEEP,ABRSD.
4450  COMMON /abrsd/ amcsd1(248),amcsd2(248),gacsd1(248),gacsd2(248),
4451  +bgxsd1(248),bgysd1(248),bgzsd1(248), bgxsd2(248),bgysd2(248),
4452  +bgzsd2(248), nchsd1(248),nchsd2(248),ijcsd1(248),ijcsd2(248),
4453  +pqsda1(248,4),pqsda2(248,4), pqsdb1(248,4),pqsdb2(248,4)
4454 *KEND.
4455  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4456  common/seasu3/seasq
4457  COMMON /xseadi/ xseacu,unon,unom,unosea, cvq,cdq,csea,ssmima,
4458  +ssmimq,vvmthr
4459  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
4460  *idzre(3),izdre(3),idiqrz(7)
4461  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
4462  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
4463  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
4464  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
4465  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
4466  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
4467 C----------------------------------------------------------------------
4468 C COMMON /PCHARM/PCCCC
4469  parameter(ummm=0.3d0)
4470  parameter(smmm=0.5d0)
4471  parameter(cmmm=1.3d0)
4472  DATA pc/0.0001d0/
4473 *KEND.
4474 C----------
4475 C
4476  DATA inicha/0/
4477 C----------------------------------------------------------------------
4478 C Initialize Charm selection at soft chain ends
4479 C
4480  IF(inicha.EQ.0)THEN
4481  rx=8.d0
4482  x1=rx
4483  gm=2.140d0
4484  x2=ummm
4485  betoo=7.5d0
4486  ENDIF
4487  rx=8.d0
4488  x1=rx
4489  betcha=betoo+1.3d0-log10(ecm)
4490  pu=dbeta(x1,x2,betcha)
4491  x2=smmm
4492  ps=dbeta(x1,x2,betcha)
4493  x2=cmmm
4494  pc=dbeta(x1,x2,betcha)
4495 C PU1=PU/(2*PU+PS+PC)
4496 C PS1=PS/(2*PU+PS+PC)
4497  pc1=pc/(2*pu+ps+pc)
4498 C changed j.r.7.12.94
4499 C PC=PC1/2.9
4500 C changed j.r.14.12.94
4501 C PC=PC1/5.0
4502 C PC=PC1/10.0
4503  pc=pc1/7.0d0
4504  pu1=pu/(2*pu+ps+pc)
4505  ps1=ps/(2*pu+ps+pc)
4506  IF(inicha.EQ.0)THEN
4507  inicha=1
4508  WRITE(6,4567)pc,betcha,pu1,ps1,seasq
4509  4567 FORMAT(' Charm chain ends DIQSSD: PC,BETCHA,PU,PS,SEASQ',4f10.5)
4510  ENDIF
4511 C----------------------------------------------------------------------
4512  rr=rndm(v)
4513  is=1.d0+rndm(v1)*(2.d0+2.d0*seasq)
4514  IF(rr.LT.pc)is=4
4515 C----------------------------------------------------------------------
4516  IF(iphkk.GE.6)WRITE (6,'( A)') ' diqssd'
4517  irej=0
4518 * kinematics: is the mass of both chains big enough
4519 * to allow for fragmentation
4520  itsq2(its)=1.d0+rndm(v1)*(2.d0+2.d0*seasq)
4521  rr=rndm(v)
4522  IF(rr.LT.pc)itsq2(its)=4
4523 C----------------------------------------------------------------------
4524  itsaq2(its)=-itsq2(its)
4525 C---------------------------------------------------j.r.29.4.94
4526 C x**1.5 distr for sea diquarks
4527 C number of target nucleon
4528  inucta=ifrost(its)
4529 C number of target diquark
4530  iitot=itovt(inucta)
4531 C diquark x
4532  xtdiqu=xtvd(iitot)
4533 C minimal value of diquark x
4534  xdthr=cdq/ecm
4535 C
4536  xdfree=xtdiqu-xdthr
4537  xall=xdfree+xtsq(its)+xtsaq(its)-2.*xdthr
4538  xdalt=xtvd(iitot)
4539  xsalt=xtsq(its)
4540  xaalt=xtsaq(its)
4541  IF(xall.GE.0.)THEN
4542  rr1=rndm(v1)
4543  rr2=rndm(v2)
4544  rr3=rndm(v3)
4545  sr123=rr1+rr2+rr3
4546  dx1=rr1*xall/sr123
4547  dx2=rr2*xall/sr123
4548  dx3=rr3*xall/sr123
4549  xtvd(iitot)=xdthr+dx1
4550  xtsq(its)=xdthr+dx2
4551  xtsaq(its)=xdthr+dx3
4552  ENDIF
4553 C--------------------------------------------------------------
4554  amsdq1=xtsq(its)*xpsq(ips)*ecm**2
4555  amsdq2=xtsaq(its)*xpsaq(ips)*ecm**2
4556  idiqre(1)=idiqre(1)+1
4557  IF(itsq(its).GE.3.AND.itsq2(its).GE.3)THEN
4558  idiqre(2)=idiqre(2)+1
4559 C IF(AMSDQ2.LE.2.30.OR.AMSDQ1.LE.2.30) THEN
4560  IF(amsdq2.LE.6.60d0.OR.amsdq1.LE.6.60d0) THEN
4561  irej=1
4562  idiqre(3)=idiqre(3)+1
4563  idiqre(2)=idiqre(2)-1
4564  idiqre(1)=idiqre(1)-1
4565  xtvd(iitot)=xdalt
4566  xtsq(its)=xsalt
4567  xtsaq(its)=xaalt
4568  RETURN
4569  ENDIF
4570  ELSEIF(itsq(its).GE.3.OR.itsq2(its).GE.3)THEN
4571  idiqre(4)=idiqre(4)+1
4572 C IF(AMSDQ2.LE.1.9.OR.AMSDQ1.LE.1.90) THEN
4573  IF(amsdq2.LE.5.8d0.OR.amsdq1.LE.5.80d0) THEN
4574  irej=1
4575  idiqre(5)=idiqre(5)+1
4576  idiqre(4)=idiqre(4)-1
4577  idiqre(1)=idiqre(1)-1
4578  xtvd(iitot)=xdalt
4579  xtsq(its)=xsalt
4580  xtsaq(its)=xaalt
4581  RETURN
4582  ENDIF
4583  ELSE
4584  idiqre(6)=idiqre(6)+1
4585 C IF(AMSDQ2.LE.1.50.OR.AMSDQ1.LE.1.50) THEN
4586  IF(amsdq2.LE.3.9d0.OR.amsdq1.LE.3.9d0) THEN
4587  irej=1
4588  idiqre(7)=idiqre(7)+1
4589  idiqre(6)=idiqre(6)-1
4590  idiqre(1)=idiqre(1)-1
4591  xtvd(iitot)=xdalt
4592  xtsq(its)=xsalt
4593  xtsaq(its)=xaalt
4594  RETURN
4595  ENDIF
4596  ENDIF
4597  nsd=nsd+1
4598 c WRITE(6,'(A/5X,3F10.3,3I5/5X,3F10.3)')
4599 c +' DIQVS: AMSDQ1, XTSQ, XPVQ, IPS,ITS, NSD/ AMSDQ2, XTSAQ, XPVD',
4600 c +AMSDQ1,XTSQ(ITS),XPVQ(IPS),IPS,ITS,NSD,AMSDQ2,XTSAQ(ITS),XPVD(IPS)
4601  nchsd1(nsd)=0
4602  nchsd2(nsd)=0
4603  intsd1(nsd)=ips
4604  intsd2(nsd)=its
4605  RETURN
4606  END
4607 C
4608 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4609 C
4610 C DEBUG SUBCHK
4611 C END DEBUG
4612  SUBROUTINE kkevsd(IREJSD)
4613  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4614  SAVE
4615 C
4616 C------------------ treatment of sea - sea diquark CHAIN SYSTEMS
4617 C
4618  COMMON /zsea/zseaav,zseasu,anzsea
4619  common/popcck/pdbck,pdbse,pdbseu,
4620  * ijpock,irejck,ick4,ihad4,ick6,ihad6
4621  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
4622  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
4623  *isea43,isea63,irejao
4624 *KEEP,INTMX.
4625  parameter(intmx=2488,intmd=252)
4626 *KEEP,HKKEVT.
4627 c INCLUDE (HKKEVT)
4628  parameter(nmxhkk= 89998)
4629 c PARAMETER (NMXHKK=25000)
4630  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
4631  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
4632  +(4,nmxhkk)
4633 C
4634 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
4635 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
4636 C THE POSITIONS OF THE PROJECTILE NUCLEONS
4637 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
4638 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
4639 C COMPLETELY CONSISTENT. THE TIMES IN THE
4640 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
4641 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
4642 C
4643 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
4644 C
4645 C NMXHKK: maximum numbers of entries (partons/particles) that can be
4646 C stored in the commonblock.
4647 C
4648 C NHKK: the actual number of entries stored in current event. These are
4649 C found in the first NHKK positions of the respective arrays below.
4650 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
4651 C entry.
4652 C
4653 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
4654 C = 0 : null entry.
4655 C = 1 : an existing entry, which has not decayed or fragmented.
4656 C This is the main class of entries which represents the
4657 C "final state" given by the generator.
4658 C = 2 : an entry which has decayed or fragmented and therefore
4659 C is not appearing in the final state, but is retained for
4660 C event history information.
4661 C = 3 : a documentation line, defined separately from the event
4662 C history. (incoming reacting
4663 C particles, etc.)
4664 C = 4 - 10 : undefined, but reserved for future standards.
4665 C = 11 - 20 : at the disposal of each model builder for constructs
4666 C specific to his program, but equivalent to a null line in the
4667 C context of any other program. One example is the cone defining
4668 C vector of HERWIG, another cluster or event axes of the JETSET
4669 C analysis routines.
4670 C = 21 - : at the disposal of users, in particular for event tracking
4671 C in the detector.
4672 C
4673 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
4674 C standard.
4675 C
4676 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
4677 C The value is 0 for initial entries.
4678 C
4679 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
4680 C one mother exist, in which case the value 0 is used. In cluster
4681 C fragmentation models, the two mothers would correspond to the q
4682 C and qbar which join to form a cluster. In string fragmentation,
4683 C the two mothers of a particle produced in the fragmentation would
4684 C be the two endpoints of the string (with the range in between
4685 C implied).
4686 C
4687 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
4688 C entry has not decayed, this is 0.
4689 C
4690 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
4691 C entry has not decayed, this is 0. It is assumed that the daughters
4692 C of a particle (or cluster or string) are stored sequentially, so
4693 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
4694 C daughters. Even in cases where only one daughter is defined (e.g.
4695 C K0 -> K0S) both values should be defined, to make for a uniform
4696 C approach in terms of loop constructions.
4697 C
4698 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
4699 C
4700 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
4701 C
4702 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
4703 C
4704 C PHKK(4,IHKK) : energy, in GeV.
4705 C
4706 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
4707 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
4708 C
4709 C VHKK(1,IHKK) : production vertex x position, in mm.
4710 C
4711 C VHKK(2,IHKK) : production vertex y position, in mm.
4712 C
4713 C VHKK(3,IHKK) : production vertex z position, in mm.
4714 C
4715 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
4716 C********************************************************************
4717 *KEEP,IFROTO.
4718  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
4719  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
4720  +jhkknt
4721  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
4722  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
4723  & mhkkhh(intmx),
4724  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
4725 *KEEP,DIQI.
4726  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
4727  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
4728  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
4729  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
4730 *KEEP,INTNEW.
4731  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
4732  +ixpv,ixps,ixtv,ixts, intvv1(248),
4733  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
4734  +intss1(intmx),intss2(intmx),
4735  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
4736  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
4737 
4738 C /INTNEW/
4739 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
4740 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
4741 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
4742 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
4743 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
4744 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
4745 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
4746 C FROM PROJECTILE/TARGET NUCLEI
4747 C-------------------
4748 *KEEP,ABRSD.
4749  COMMON /abrsd/ amcsd1(248),amcsd2(248),gacsd1(248),gacsd2(248),
4750  +bgxsd1(248),bgysd1(248),bgzsd1(248), bgxsd2(248),bgysd2(248),
4751  +bgzsd2(248), nchsd1(248),nchsd2(248),ijcsd1(248),ijcsd2(248),
4752  +pqsda1(248,4),pqsda2(248,4), pqsdb1(248,4),pqsdb2(248,4)
4753 *KEEP,DXQX.
4754 C INCLUDE (XQXQ)
4755 * NOTE: INTMX set via INCLUDE(INTMX)
4756  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
4757  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
4758  * ,xpsu(248),xtsu(248)
4759  * ,xpsut(248),xtsut(248)
4760  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
4761  *idzre(3),izdre(3),idiqrz(7)
4762 *KEEP,LOZUO.
4763  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
4764  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
4765  +intlo(intmx),inloss(intmx)
4766 C /LOZUO/
4767 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
4768 C REJECTED IN KKEVT
4769 C------------------
4770 *KEEP,TRAFOP.
4771  COMMON /trafop/ gamp,bgamp,betp
4772 *KEEP,NUCIMP.
4773  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
4774  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
4775  +prebin,taebin,fermod,etacou
4776 *KEEP,FERMI.
4777  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
4778  +(4,248)
4779 *KEEP,DPAR.
4780 C /DPAR/ CONTAINS PARTICLE PROPERTIES
4781 C ANAME = LITERAL NAME OF THE PARTICLE
4782 C AAM = PARTICLE MASS IN GEV
4783 C GA = DECAY WIDTH
4784 C TAU = LIFE TIME OF INSTABLE PARTICLES
4785 C IICH = ELECTRIC CHARGE OF THE PARTICLE
4786 C IIBAR = BARYON NUMBER
4787 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
4788 C
4789  CHARACTER*8 aname
4790  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
4791  +iibar(210),k1(210),k2(210)
4792 C------------------
4793 *KEEP,DPRIN.
4794  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4795 *KEEP,REJEC.
4796  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
4797  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
4798  +irvs14, irvv11,irvv12,irvv13,irvv14
4799 *KEEP,PROJK.
4800  COMMON /projk/ iprojk
4801  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
4802  common/rptshm/rproj,rtarg,bimpac
4803  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
4804  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
4805  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
4806  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
4807  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
4808  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
4809 *KEND.
4810 C-------------------
4811  IF(iphkk.GE.6)WRITE (6,'( A)') ' kkevsd'
4812  irejsd=0
4813  DO 10 n=1,nsd
4814 C---------------------------drop recombined chain pairs
4815  IF(nchsd1(n).EQ.99.AND.nchsd2(n).EQ.99)go to 10
4816 C
4817 C*** 4-MOMENTA OF projectile QUARK-DIQUARK PAIRS IN NN-CMS
4818  ixspr=intsd1(n)
4819  inucpr=ifrosp(ixspr)
4820  jnucpr=itovp(inucpr)
4821 C
4822  psqpx=xpsq(ixspr)*prmom(1,inucpr)
4823  psqpy=xpsq(ixspr)*prmom(2,inucpr)
4824  psqpz=xpsq(ixspr)*prmom(3,inucpr)
4825  psqe=xpsq(ixspr)*prmom(4,inucpr)
4826  psdqpx=xpsaq(ixspr)*prmom(1,inucpr)
4827  psdqpy=xpsaq(ixspr)*prmom(2,inucpr)
4828  psdqpz=xpsaq(ixspr)*prmom(3,inucpr)
4829  psdqe=xpsaq(ixspr)*prmom(4,inucpr)
4830 C
4831 C*** 4-MOMENTA OF TARGET QUARK-DIQUARK PAIRS IN NN-CMS
4832  ixsta=intsd2(n)
4833  inucta=ifrost(ixsta)
4834  jnucta=itovt(inucta)
4835 *
4836  tsqpx=xtsq(ixsta)*tamom(1,inucta)
4837  tsqpy=xtsq(ixsta)*tamom(2,inucta)
4838  tsqpz=xtsq(ixsta)*tamom(3,inucta)
4839  tsqe=xtsq(ixsta)*tamom(4,inucta)
4840  tsaqpx=xtsaq(ixsta)*tamom(1,inucta)
4841  tsaqpy=xtsaq(ixsta)*tamom(2,inucta)
4842  tsaqpz=xtsaq(ixsta)*tamom(3,inucta)
4843  tsaqe=xtsaq(ixsta)*tamom(4,inucta)
4844 C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
4845 C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
4846 C j.r.6.5.93
4847 C
4848 C multiple scattering of sea quark chain ends
4849 C
4850  IF(it.GT.1)THEN
4851  itnu=ip+inucta
4852  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
4853  rtiy=vhkk(2,itnu)*1.e12
4854  rtiz=vhkk(3,itnu)*1.e12
4855  CALL cromsc(psqpx,psqpy,psqpz,psqe,rtix,rtiy,rtiz,
4856  * psqnx,psqny,psqnz,psqne,63)
4857  psqpx=psqnx
4858  psqpy=psqny
4859  psqpz=psqnz
4860  psqe=psqne
4861  CALL cromsc(psdqpx,psdqpy,psdqpz,psdqe,rtix,rtiy,rtiz,
4862  * psdqnx,psdqny,psdqnz,psdqne,64)
4863  psdqpx=psdqnx
4864  psdqpy=psdqny
4865  psdqpz=psdqnz
4866  psdqe=psdqne
4867 C ---------
4868 
4869 C j.r.6.5.93
4870 C
4871 C multiple scattering of sea quark chain ends
4872 C
4873  itnu=ip+inucta
4874  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
4875  rtiy=vhkk(2,itnu)*1.e12
4876  rtiz=vhkk(3,itnu)*1.e12
4877  CALL cromsc(tsqpx,tsqpy,tsqpz,tsqe,rtix,rtiy,rtiz,
4878  * tsqnx,tsqny,tsqnz,tsqne,65)
4879  tsqpx=tsqnx
4880  tsqpy=tsqny
4881  tsqpz=tsqnz
4882  tsqe=tsqne
4883  CALL cromsc(tsaqpx,tsaqpy,tsaqpz,tsaqe,rtix,rtiy,rtiz,
4884  * tsaqnx,tsaqny,tsaqnz,tsaqne,66)
4885  tsaqpx=tsaqnx
4886  tsaqpy=tsaqny
4887  tsaqpz=tsaqnz
4888  tsaqe=tsaqne
4889  ENDIF
4890 C ---------
4891 C j.r.10.5.93
4892  IF(ip.GE.0)go to 1779
4893  psqpz2=psqe**2-psqpx**2-psqpy**2
4894  IF(psqpz2.GE.0.)THEN
4895  psqpz=sqrt(psqpz2)
4896  ELSE
4897  psqpx=0.
4898  psqpy=0.
4899  psqpz=psqe
4900  ENDIF
4901 C
4902  pdqpz2=psdqe**2-psdqpx**2-psdqpy**2
4903  IF(pdqpz2.GE.0.)THEN
4904  psdqpz=sqrt(pdqpz2)
4905  ELSE
4906  psdqpx=0.
4907  psdqpy=0.
4908  psdqpz=psdqe
4909  ENDIF
4910 C
4911  tsqpz2=tsqe**2-tsqpx**2-tsqpy**2
4912  IF(tsqpz2.GE.0.)THEN
4913  tsqpz=-sqrt(tsqpz2)
4914  ELSE
4915  tsqpx=0.
4916  tsqpy=0.
4917  tsqpz=tsqe
4918  ENDIF
4919 C
4920  taqpz2=tsaqe**2-tsaqpx**2-tsaqpy**2
4921  IF(taqpz2.GE.0.)THEN
4922  tsaqpz=-sqrt(taqpz2)
4923  ELSE
4924  tsaqpx=0.
4925  tsaqpy=0.
4926  tsaqpz=tsaqe
4927  ENDIF
4928  1779 CONTINUE
4929 C ---------
4930 C changej.r.6.5.93
4931  ptxsq1=0.
4932  ptxsa1=0.
4933  ptxsq2=0.
4934  ptxsa2=0.
4935  ptysq1=0.
4936  ptysa1=0.
4937  ptysq2=0.
4938  ptysa2=0.
4939  ptxsq1=psqpx
4940  ptxsa1=psdqpx
4941  ptxsq2=tsqpx
4942  ptxsa2=tsaqpx
4943  ptysq1=psqpy
4944  ptysa1=psdqpy
4945  ptysq2=tsqpy
4946  ptysa2=tsaqpy
4947  plq1=psqpz
4948  plaq1=psdqpz
4949  plq2=tsqpz
4950  plaq2=tsaqpz
4951  eq1=psqe
4952  eaq1=psdqe
4953  eq2=tsqe
4954  eaq2=tsaqe
4955 C ---------------
4956 C
4957 C _________________
4958  IF(ipev.GE.2) THEN
4959  WRITE(6,'(A,I5)') ' KKEVSD - IRSD13=',irsd13
4960  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
4961  + ' VD: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
4962  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
4963  + amch1,amch2,irej,ikvala,pttq1,ptta1
4964  ENDIF
4965  ikvala=0
4966  nselpt=1
4967  CALL selpt( ptxsq1,ptysq1,plq1,
4968  + eq1,ptxsa1,ptysa1,plaq1,eaq1,
4969  + ptxsa2,ptysa2,plaq2,eaq2,
4970  + ptxsq2,ptysq2,plq2,eq2,
4971  + amch1,amch2,irej,ikvala,pttq1,ptta1,
4972  * pttq2,ptta2,
4973  * nselpt)
4974  IF(ipev.GE.2) THEN
4975  WRITE(6,'(A,I5)') ' KKEVSD - IRSD13=',irsd13
4976  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
4977  + ' VD: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
4978  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
4979  + amch1,amch2,irej,ikvala,pttq1,ptta1
4980  ENDIF
4981  IF (ipev.GE.7) WRITE(6,'(A/5X,I10)')
4982  + 'SD IREJ ', irej
4983  IF (irej.EQ.1) THEN
4984  irsd13=irsd13 + 1
4985  IF(ipev.GE.2) THEN
4986  WRITE(6,'(A,I5)') ' KKEVSD - IRSD13=',irsd13
4987  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
4988  + ' VD: ...', ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
4989  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
4990  + amch1,amch2,irej,ikvala,pttq1,ptta1
4991 
4992  ENDIF
4993  go to 11
4994  ENDIF
4995 C
4996 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
4997 C
4998  ptxch1=ptxsq1 + ptxsq2
4999  ptych1=ptysq1 + ptysq2
5000  ptzch1=plq1 + plq2
5001  ech1=eq1 + eq2
5002  ptxch2=ptxsa2 + ptxsa1
5003  ptych2=ptysa2 + ptysa1
5004  ptzch2=plaq2 + plaq1
5005  ech2=eaq2 + eaq1
5006  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
5007  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
5008 C
5009 C
5010  IF (ipev.GE.6) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
5011  + ' SD: IREJ ',irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
5012  + amch1,ptxch1,ptych1,ptzch1,ech1,
5013  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
5014  + ptzch2,ech2
5015 
5016 C
5017 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS OR OCTETT
5018 C OR DECUPLETT BARYONS
5019 C FIRST FOR CHAIN 1 (PROJ quark - tar sea-diquark)
5020 C
5021  CALL cobcma(itsq(ixsta),itsq2(ixsta),ipsq(ixspr), ijnch1,nnch1,
5022  + irej,amch1,amch1n,1)
5023 C*** MASS BELOW OCTETT BARYON MASS
5024  IF(irej.EQ.1) THEN
5025  irsd11=irsd11 + 1
5026  IF(ipev.GE.2) THEN
5027  WRITE(6,'(A,I5)') ' KKEVSD - IRSD11=',irsd11
5028  WRITE(6,'(A,6I5/6E12.4/2E12.4)') ' SD:', ipvq(ixspr),itsq
5029  + (ixsta),itsq2(ixsta),ijnch1,nnch1,irej, xpvq(ixspr),xpvd
5030  + (ixspr),xpsqcm,xpsdcm, xtsq(ixsta),xtsaq(ixsta),amch1,amch1n
5031  ENDIF
5032  goto 11
5033  ENDIF
5034 C CORRECT KINEMATICS FOR CHAIN 1
5035 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
5036  IF(nnch1.NE.0)THEN
5037  CALL cormom(amch1,amch2,amch1n,amch2n,
5038  + ptxsq1,ptysq1,plq1,eq1,
5039  + ptxsa1,ptysa1,plaq1,eaq1,
5040  + ptxsa2,ptysa2,plaq2,eaq2,
5041  + ptxsq2,ptysq2,plq2,eq2,
5042  + ptxch1,ptych1,ptzch1,ech1, ptxch2,ptych2,ptzch2,ech2,
5043  + irej)
5044  amch2=amch2n
5045  ENDIF
5046  IF (irej.EQ.1)go to 11
5047 C
5048  IF (ipev.GE.6) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
5049  + ' SD(2): IREJ ',irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
5050  + amch1,ptxch1,ptych1,ptzch1,ech1,
5051  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
5052  + ptzch2,ech2
5053 C
5054 C REPLACE SMALL MASS CHAINS BY octet or decuplet baryons
5055 C SECOND FOR CHAIN 2 (proj saquark - tar sadiquark)
5056 C
5057  CALL cobcma(ipsaq(ixspr),itsaq(ixsta),itsaq2(ixsta),
5058  + ijnch2,nnch2,irej,amch2,amch2n,2)
5059 c rejection of both s-s chains if mass of chain 2 too low
5060  IF(irej.EQ.1) THEN
5061  irsd12=irsd12 + 1
5062  IF(ipev.GE.2) THEN
5063  WRITE(6,1090) irsd12
5064  WRITE(6,1100) ipsaq(ixspr),itsaq(ixsta),itsaq2(ixsta),
5065  + ijnch2,nnch2,irej,
5066  + xpsq(ixspr),xpsaq(ixspr),xpsqcm,xtsacm, xtsq(ixsta),xtsaq
5067  + (ixsta),xtsqcm,xtsacm, amch2,amch2n
5068  1090 FORMAT(' KKEVSD - IRSD12=',i5)
5069  1100 FORMAT(' SD - 1100', 6i5/2(4e12.4/),2e12.4)
5070  ENDIF
5071  goto 11
5072  ENDIF
5073 C if AMCH2 changed in COBCMA/COMCMA
5074 C CORVAL corrects chain kinematics
5075 C according to 2-body kinem.
5076 C with fixed masses
5077  IF(nnch2.NE.0) THEN
5078  amch2=amch2n
5079 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
5080  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
5081  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
5082  eee=ech1+ech2
5083  pxxx=ptxch1+ptxch2
5084  pyyy=ptych1+ptych2
5085  pzzz=ptzch1+ptzch2
5086  gammm=eee/(ammm+1.e-4)
5087  bgggx=pxxx/(ammm+1.e-4)
5088  bgggy=pyyy/(ammm+1.e-4)
5089  bgggz=pzzz/(ammm+1.e-4)
5090 C-------------------
5091 C 4-MOMENTA OF CHAINS
5092  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
5093  + ptxch1,ptych1,ptzch1,ech1,
5094  + pppch1, qtxch1,qtych1,qtzch1,qech1)
5095 C
5096  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
5097  + ptxch2,ptych2,ptzch2,ech2,
5098  + pppch2, qtxch2,qtych2,qtzch2,qech2)
5099 C
5100  norig=52
5101  CALL corval(ammm,irej,amch1,amch2, qtxch1,qtych1,qtzch1,qech1,
5102  + qtxch2,qtych2,qtzch2,qech2,norig)
5103 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
5104 C
5105 C 4-MOMENTA OF CHAINS
5106 
5107  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch1,qtych1,qtzch1,qech1,
5108  + pppch1, ptxch1,ptych1,ptzch1,ech1)
5109 C
5110  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch2,qtych2,qtzch2,qech2,
5111  + pppch2, ptxch2,ptych2,ptzch2,ech2)
5112 C
5113 
5114 C
5115  IF(ipev.GE.6) THEN
5116  WRITE(6,'(A/3(1PE15.4),3I5)')
5117  + ' SD - CALL CORVAL: AMMM, AMCH1, AMCH2, NNCH1, NNCH2, IREJ',
5118  + ammm, amch1, amch2, nnch1, nnch2, irej
5119  WRITE(6,1050) irej, amch1,
5120  + ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
5121  1050 FORMAT (' SD: IREJ || ',i10/
5122  + ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
5123  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
5124  ENDIF
5125  IF(irej.EQ.1) THEN
5126 * AMCH1N + AMCH2N > AMMM - 0.2
5127 * reject event
5128  irsd14=irsd14+1
5129  goto 11
5130  ENDIF
5131  ENDIF
5132 C
5133  qtxch1=ptxch1
5134  qtych1=ptych1
5135  qtzch1=ptzch1
5136  qech1=ech1
5137  qtxch2=ptxch2
5138  qtych2=ptych2
5139  qtzch2=ptzch2
5140  qech2=ech2
5141  pqsda1(n,1)=ptxsq1
5142  pqsda1(n,2)=ptysq1
5143  pqsda1(n,3)=plq1
5144  pqsda1(n,4)=eq1
5145  pqsda2(n,1)=ptxsa2
5146  pqsda2(n,2)=ptysa2
5147  pqsda2(n,3)=plaq2
5148  pqsda2(n,4)=eaq2
5149  pqsdb1(n,1)=ptxsq2
5150  pqsdb1(n,2)=ptysq2
5151  pqsdb1(n,3)=plq2
5152  pqsdb1(n,4)=eq2
5153  pqsdb2(n,1)=ptxsa1
5154  pqsdb2(n,2)=ptysa1
5155  pqsdb2(n,3)=plaq1
5156  pqsdb2(n,4)=eaq1
5157 C-------------------
5158 C
5159 C PUT D-S CHAIN ENDS INTO /HKKEVT/
5160 C MOMENTA IN NN-CMS
5161 C POSITION OF ORIGINAL NUCLEONS
5162 C
5163 **** keep for the moment the old v-s notations
5164 C FLAG FOR SD-CHAIN ENDS
5165 C PROJECTILE: ISTHKK=121
5166 C TARGET: ISTHKK=132
5167 C FOR SD-CHAINS ISTHKK=5
5168 C
5169  ihkkpd=jhkkps(ixspr )
5170  ihkkpo=jhkkps(ixspr )-1
5171  ihkktd=jhkkts(ixsta )
5172  ihkkto=jhkkts(ixsta )-1
5173  IF (ipev.GT.3)WRITE(6,1000)ixspr,inucpr,jnucpr,ihkkpo,ihkkpd
5174  1000 FORMAT (' IXSPR,INUCPR,JNUCPR,IHKKPO,IHKKPD ',5i5)
5175  IF (ipev.GT.3)WRITE(6,1010)ixsta,inucta,jnucta,ihkkto,ihkktd
5176  1010 FORMAT (' IXSTA,INUCTA,JNUCTA,IHKKTO,IHKKTD ',5i5)
5177 C CHAIN 1 PROJECTILE SEA-diquark
5178  nhkk=nhkk+1
5179  IF (nhkk.EQ.nmxhkk)THEN
5180  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
5181  RETURN
5182  ENDIF
5183  ihkk=nhkk
5184  isthkk(ihkk)=121
5185  idhkk(ihkk)=idhkk(ihkkpo)
5186  jmohkk(1,ihkk)=ihkkpo
5187  jmohkk(2,ihkk)=jmohkk(1,ihkkpo)
5188  jdahkk(1,ihkk)=ihkk+2
5189  jdahkk(2,ihkk)=ihkk+2
5190  phkk(1,ihkk)=pqsda1(n,1)
5191  phkk(2,ihkk)=pqsda1(n,2)
5192  phkk(3,ihkk)=pqsda1(n,3)
5193  phkk(4,ihkk)=pqsda1(n,4)
5194  phkk(5,ihkk)=0.
5195 C Add position of parton in hadron
5196  CALL qinnuc(xxpp,yypp)
5197  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
5198  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
5199  vhkk(3,ihkk)=vhkk(3,ihkkpo)
5200  vhkk(4,ihkk)=vhkk(4,ihkkpo)
5201  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
5202  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5203  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5204 
5205  1020 FORMAT (i6,i4,5i6,9e10.2)
5206 C CHAIN 1 TARGET QUARK
5207  nhkk=nhkk+1
5208  IF (nhkk.EQ.nmxhkk)THEN
5209  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
5210  RETURN
5211  ENDIF
5212  ihkk=nhkk
5213  isthkk(ihkk)=132
5214  idhkk(ihkk)=idhkk(ihkktd)
5215  jmohkk(1,ihkk)=ihkktd
5216  jmohkk(2,ihkk)=jmohkk(1,ihkktd)
5217  jdahkk(1,ihkk)=ihkk+1
5218  jdahkk(2,ihkk)=ihkk+1
5219  phkk(1,ihkk)=pqsda2(n,1)
5220  phkk(2,ihkk)=pqsda2(n,2)
5221  phkk(3,ihkk)=pqsda2(n,3)
5222  phkk(4,ihkk)=pqsda2(n,4)
5223  phkk(5,ihkk)=0.
5224 C Add position of parton in hadron
5225  CALL qinnuc(xxpp,yypp)
5226  vhkk(1,ihkk)=vhkk(1,ihkktd)+xxpp
5227  vhkk(2,ihkk)=vhkk(2,ihkktd)+yypp
5228  vhkk(3,ihkk)=vhkk(3,ihkktd)
5229  vhkk(4,ihkk)=vhkk(4,ihkktd)
5230  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
5231  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5232  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5233 
5234 C
5235 C CHAIN 1 BEFORE FRAGMENTATION
5236  nhkk=nhkk+1
5237  IF (nhkk.EQ.nmxhkk)THEN
5238  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
5239  RETURN
5240  ENDIF
5241  ihkk=nhkk
5242  isthkk(ihkk)=5
5243  idhkk(ihkk)=88888+nnch1
5244  jmohkk(1,ihkk)=ihkk-2
5245  jmohkk(2,ihkk)=ihkk-1
5246  phkk(1,ihkk)=qtxch1
5247  phkk(2,ihkk)=qtych1
5248  phkk(3,ihkk)=qtzch1
5249  phkk(4,ihkk)=qech1
5250  phkk(5,ihkk)=amch1
5251 C POSITION OF CREATED CHAIN IN LAB
5252 C =POSITION OF TARGET NUCLEON
5253 C TIME OF CHAIN CREATION IN LAB
5254 C =TIME OF PASSAGE OF PROJECTILE
5255 C NUCLEUS AT POSITION OF TAR. NUCLEUS
5256  vhkk(1,nhkk)= vhkk(1,nhkk-1)
5257  vhkk(2,nhkk)= vhkk(2,nhkk-1)
5258  vhkk(3,nhkk)= vhkk(3,nhkk-1)
5259  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
5260  mhkksd(n)=ihkk
5261  IF (iprojk.EQ.1)THEN
5262  whkk(1,nhkk)= vhkk(1,nhkk-2)
5263  whkk(2,nhkk)= vhkk(2,nhkk-2)
5264  whkk(3,nhkk)= vhkk(3,nhkk-2)
5265  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
5266  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
5267  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5268  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
5269 
5270  ENDIF
5271  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
5272  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5273  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5274 
5275 C
5276 C
5277 C CHAIN 2 projectile sea antidiquark
5278  nhkk=nhkk+1
5279  IF (nhkk.EQ.nmxhkk)THEN
5280  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
5281  RETURN
5282  ENDIF
5283  ihkk=nhkk
5284  isthkk(ihkk)=121
5285  idhkk(ihkk)=idhkk(ihkkpd)
5286  jmohkk(1,ihkk)=ihkkpd
5287  jmohkk(2,ihkk)=jmohkk(1,ihkkpd)
5288  jdahkk(1,ihkk)=ihkk+2
5289  jdahkk(2,ihkk)=ihkk+2
5290  phkk(1,ihkk)=pqsdb1(n,1)
5291  phkk(2,ihkk)=pqsdb1(n,2)
5292  phkk(3,ihkk)=pqsdb1(n,3)
5293  phkk(4,ihkk)=pqsdb1(n,4)
5294  phkk(5,ihkk)=0.
5295 C Add position of parton in hadron
5296  CALL qinnuc(xxpp,yypp)
5297  vhkk(1,ihkk)=vhkk(1,ihkkpd)+xxpp
5298  vhkk(2,ihkk)=vhkk(2,ihkkpd)+yypp
5299  vhkk(3,ihkk)=vhkk(3,ihkkpd)
5300  vhkk(4,ihkk)=vhkk(4,ihkkpd)
5301  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
5302  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5303  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5304 
5305 C CHAIN 2 TARGET diquark
5306  nhkk=nhkk+1
5307  IF (nhkk.EQ.nmxhkk)THEN
5308  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
5309  RETURN
5310  ENDIF
5311  ihkk=nhkk
5312  isthkk(ihkk)=132
5313  idhkk(ihkk)=idhkk(ihkkto)
5314  jmohkk(1,ihkk)=ihkkto
5315  jmohkk(2,ihkk)=jmohkk(1,ihkkto)
5316  jdahkk(1,ihkk)=ihkk+1
5317  jdahkk(2,ihkk)=ihkk+1
5318  phkk(1,ihkk)=pqsdb2(n,1)
5319  phkk(2,ihkk)=pqsdb2(n,2)
5320  phkk(3,ihkk)=pqsdb2(n,3)
5321  phkk(4,ihkk)=pqsdb2(n,4)
5322  phkk(5,ihkk)=0.
5323 C Add position of parton in hadron
5324  CALL qinnuc(xxpp,yypp)
5325  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
5326  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
5327  vhkk(3,ihkk)=vhkk(3,ihkkto)
5328  vhkk(4,ihkk)=vhkk(4,ihkkto)
5329  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
5330  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5331  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5332 
5333 C
5334 C CHAIN 2 BEFORE FRAGMENTATION
5335  nhkk=nhkk+1
5336  IF (nhkk.EQ.nmxhkk)THEN
5337  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
5338  RETURN
5339  ENDIF
5340  ihkk=nhkk
5341  isthkk(ihkk)=5
5342  idhkk(ihkk)=88888+nnch2
5343  jmohkk(1,ihkk)=ihkk-2
5344  jmohkk(2,ihkk)=ihkk-1
5345  phkk(1,ihkk)=qtxch2
5346  phkk(2,ihkk)=qtych2
5347  phkk(3,ihkk)=qtzch2
5348  phkk(4,ihkk)=qech2
5349  phkk(5,ihkk)=amch2
5350 C POSITION OF CREATED CHAIN IN LAB
5351 C =POSITION OF TARGET NUCLEON
5352 C TIME OF CHAIN CREATION IN LAB
5353 C =TIME OF PASSAGE OF PROJECTILE
5354 C NUCLEUS AT POSITION OF TAR. NUCLEUS
5355  vhkk(1,nhkk)= vhkk(1,nhkk-1)
5356  vhkk(2,nhkk)= vhkk(2,nhkk-1)
5357  vhkk(3,nhkk)= vhkk(3,nhkk-1)
5358  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
5359  mhkksd(n)=ihkk
5360  IF (iprojk.EQ.1)THEN
5361  whkk(1,nhkk)= vhkk(1,nhkk-2)
5362  whkk(2,nhkk)= vhkk(2,nhkk-2)
5363  whkk(3,nhkk)= vhkk(3,nhkk-2)
5364  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
5365  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
5366  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5367  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
5368 
5369  ENDIF
5370  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
5371  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5372  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5373 
5374 C
5375 C
5376 C NOW WE HAVE AN ACCEPTABLE SEA--VALENCE EVENT
5377 * sea diquark pair!
5378 C AND PUT IT INTO THE HISTOGRAM
5379 C
5380  amcsd1(n)=amch1
5381  amcsd2(n)=amch2
5382  gacsd1(n)=qech1/amch1
5383  bgxsd1(n)=qtxch1/amch1
5384  bgysd1(n)=qtych1/amch1
5385  bgzsd1(n)=qtzch1/amch1
5386  gacsd2(n)=qech2/amch2
5387  bgxsd2(n)=qtxch2/amch2
5388  bgysd2(n)=qtych2/amch2
5389  bgzsd2(n)=qtzch2/amch2
5390  nchsd1(n)=nnch1
5391  nchsd2(n)=nnch2
5392  ijcsd1(n)=ijnch1
5393  ijcsd2(n)=ijnch2
5394  IF (ipev.GE.2) WRITE(6,'(A/I10,4F12.7,5I5/10X,4F12.6/10X,6F12.6,
5395  +4I5/8F15.5/8F15.5/2I5)') ' SD / FINAL PRINT',n
5396 C +, XPSQ
5397 C + (IXSPR),XPSAQ(IXSPR),XTSQ(IXSTA),XTSAQ(IXSTA), IPSQ(IXSPR),IPPV1
5398 C + (IXSPR),IPPV2(IXSPR),ITSQ(IXSTA),ITSAQ(IXSTA), AMCSD1(N),AMCSD2
5399 C + (N),GACSD1(N),GACSD2(N), BGXSD1(N),BGYSD1(N),BGZSD1(N), BGXSD2
5400 C + (N),BGYSD2(N),BGZSD2(N), NCHSD1(N),NCHSD2(N),IJCSD1(N),IJCSD2
5401 C + (N), (PQSDA1(N,JU),PQSDA2(N,JU),PQSDB1(N,JU), PQSDB2(N,JU),JU=1,
5402 C + 4),
5403 C + IXSPR,IXSTA
5404  go to 20
5405 C*** TREATMENT OF REJECTED SEA-SEA INTERACTIONS
5406  11 CONTINUE
5407  nchsd1(n)=99
5408  nchsd2(n)=99
5409  xpvd(jnucpr)=xpvd(jnucpr) + xpsq(ixspr) + xpsaq(ixspr)
5410  xtvd(jnucta)=xtvd(jnucta) + xtsaq(ixsta) + xtsq(ixsta)
5411  issqq=abs(itsaq(ixsta))
5412  jssqq=abs(itsaq2(ixsta))
5413  IF(issqq.EQ.3.AND.jssqq.EQ.3)THEN
5414  isdre(3)=isdre(3)+1
5415  ELSEIF(issqq.EQ.3.OR.jssqq.EQ.3)THEN
5416  isdre(2)=isdre(2)+1
5417  ELSE
5418  isdre(1)=isdre(1)+1
5419  ENDIF
5420  20 CONTINUE
5421  10 CONTINUE
5422  RETURN
5423  END
5424 C
5425 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5426 C
5427 C DEBUG SUBCHK
5428 C END DEBUG
5429  SUBROUTINE hadrsd
5430  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5431  SAVE
5432 C-------------------------
5433 C
5434 C hadronize sea diquark - valence CHAINS
5435 C
5436 C ADD GENERATED HADRONS TO /ALLPAR/
5437 C STARTING AT (NAUX + 1)
5438 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
5439 C
5440 C---------------------------------------------------------
5441  COMMON /zsea/zseaav,zseasu,anzsea
5442  common/popcck/pdbck,pdbse,pdbseu,
5443  * ijpock,irejck,ick4,ihad4,ick6,ihad6
5444  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
5445  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
5446  *isea43,isea63,irejao
5447 *KEEP,INTMX.
5448  parameter(intmx=2488,intmd=252)
5449 *KEEP,IFROTO.
5450  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
5451  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
5452  +jhkknt
5453  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
5454  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
5455  & mhkkhh(intmx),
5456  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
5457 *KEEP,DIQI.
5458  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
5459  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
5460  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
5461  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
5462 *KEEP,DXQX.
5463 C INCLUDE (XQXQ)
5464 * NOTE: INTMX set via INCLUDE(INTMX)
5465  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
5466  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
5467  * ,xpsu(248),xtsu(248)
5468  * ,xpsut(248),xtsut(248)
5469 *KEEP,INTNEW.
5470  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
5471  +ixpv,ixps,ixtv,ixts, intvv1(248),
5472  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
5473  +intss1(intmx),intss2(intmx),
5474  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
5475  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
5476 
5477 C /INTNEW/
5478 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
5479 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
5480 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
5481 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
5482 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
5483 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
5484 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
5485 C FROM PROJECTILE/TARGET NUCLEI
5486 C-------------------
5487 *KEEP,ABRSD.
5488  COMMON /abrsd/ amcsd1(248),amcsd2(248),gacsd1(248),gacsd2(248),
5489  +bgxsd1(248),bgysd1(248),bgzsd1(248), bgxsd2(248),bgysd2(248),
5490  +bgzsd2(248), nchsd1(248),nchsd2(248),ijcsd1(248),ijcsd2(248),
5491  +pqsda1(248,4),pqsda2(248,4), pqsdb1(248,4),pqsdb2(248,4)
5492 *KEEP,LOZUO.
5493  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
5494  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
5495  +intlo(intmx),inloss(intmx)
5496 C /LOZUO/
5497 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
5498 C REJECTED IN KKEVT
5499 C------------------
5500 *KEEP,HKKEVT.
5501 c INCLUDE (HKKEVT)
5502  parameter(nmxhkk= 89998)
5503 c PARAMETER (NMXHKK=25000)
5504  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
5505  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
5506  +(4,nmxhkk)
5507 C
5508 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
5509 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
5510 C THE POSITIONS OF THE PROJECTILE NUCLEONS
5511 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
5512 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
5513 C COMPLETELY CONSISTENT. THE TIMES IN THE
5514 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
5515 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
5516 C
5517 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
5518 C
5519 C NMXHKK: maximum numbers of entries (partons/particles) that can be
5520 C stored in the commonblock.
5521 C
5522 C NHKK: the actual number of entries stored in current event. These are
5523 C found in the first NHKK positions of the respective arrays below.
5524 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
5525 C entry.
5526 C
5527 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
5528 C = 0 : null entry.
5529 C = 1 : an existing entry, which has not decayed or fragmented.
5530 C This is the main class of entries which represents the
5531 C "final state" given by the generator.
5532 C = 2 : an entry which has decayed or fragmented and therefore
5533 C is not appearing in the final state, but is retained for
5534 C event history information.
5535 C = 3 : a documentation line, defined separately from the event
5536 C history. (incoming reacting
5537 C particles, etc.)
5538 C = 4 - 10 : undefined, but reserved for future standards.
5539 C = 11 - 20 : at the disposal of each model builder for constructs
5540 C specific to his program, but equivalent to a null line in the
5541 C context of any other program. One example is the cone defining
5542 C vector of HERWIG, another cluster or event axes of the JETSET
5543 C analysis routines.
5544 C = 21 - : at the disposal of users, in particular for event tracking
5545 C in the detector.
5546 C
5547 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
5548 C standard.
5549 C
5550 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
5551 C The value is 0 for initial entries.
5552 C
5553 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
5554 C one mother exist, in which case the value 0 is used. In cluster
5555 C fragmentation models, the two mothers would correspond to the q
5556 C and qbar which join to form a cluster. In string fragmentation,
5557 C the two mothers of a particle produced in the fragmentation would
5558 C be the two endpoints of the string (with the range in between
5559 C implied).
5560 C
5561 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
5562 C entry has not decayed, this is 0.
5563 C
5564 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
5565 C entry has not decayed, this is 0. It is assumed that the daughters
5566 C of a particle (or cluster or string) are stored sequentially, so
5567 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
5568 C daughters. Even in cases where only one daughter is defined (e.g.
5569 C K0 -> K0S) both values should be defined, to make for a uniform
5570 C approach in terms of loop constructions.
5571 C
5572 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
5573 C
5574 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
5575 C
5576 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
5577 C
5578 C PHKK(4,IHKK) : energy, in GeV.
5579 C
5580 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
5581 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
5582 C
5583 C VHKK(1,IHKK) : production vertex x position, in mm.
5584 C
5585 C VHKK(2,IHKK) : production vertex y position, in mm.
5586 C
5587 C VHKK(3,IHKK) : production vertex z position, in mm.
5588 C
5589 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
5590 C********************************************************************
5591 *KEEP,DFINPA.
5592  CHARACTER*8 anf
5593  parameter(nfimax=249)
5594  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
5595  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
5596  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
5597  * istath(nfimax)
5598 *KEEP,DPRIN.
5599  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5600 *KEEP,PROJK.
5601  COMMON /projk/ iprojk
5602 *KEND.
5603  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
5604 C modified DPMJET
5605  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
5606  * anndv,annvd,annds,annsd,
5607  * annhh,annzz,
5608  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
5609  * pthh,ptzz,
5610  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
5611  * eehh,eezz
5612  * ,anndi,ptdi,eedi
5613  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
5614  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
5615  * acouzz,acouhh,acouds,acousd,
5616  * acoudz,acouzd,acoudi,
5617  * acoudv,acouvd,acoucc
5618  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
5619  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
5620  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
5621  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
5622  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
5623  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
5624 C---------------------
5625  dimension poj(4),pat(4)
5626  DATA ncalsd /0/
5627 C-----------------------------------------------------------------------
5628  IF(iphkk.GE.6)WRITE (6,'( A)') ' hadrsd'
5629  ncalsd=ncalsd+1
5630  DO 50 i=1,nsd
5631 C-----------------------drop recombined chain pairs
5632  IF(nchsd1(i).EQ.99.AND.nchsd2(i).EQ.99) go to 50
5633  is1=intsd1(i)
5634  is2=intsd2(i)
5635 C
5636  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itvq(is2),
5637  + ittv1(is2),ittv2(is2), amcsd1(i),amcsd2(i),gacsd1(i),gacsd2(i),
5638  + bgxsd1(i),bgysd1(i),bgzsd1(i), bgxsd2(i),bgysd2(i),bgzsd2(i),
5639  + nchsd1(i),nchsd2(i),ijcsd1(i),ijcsd2(i), pqsda1(i,4),pqsda2
5640  + (i,4),pqsdb1(i,4),pqsdb2(i,4)
5641  1000 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
5642 C
5643 C++++++++++++++++++++++++++++++ CHAIN 1: quark-diquark +++++++++++
5644  ifb1=ipsq(is1)
5645  ifb2=itsq(is2)
5646  ifb3=itsq2(is2)
5647  DO 10 j=1,4
5648  poj(j)=pqsda1(i,j)
5649  pat(j)=pqsda2(i,j)
5650  10 CONTINUE
5651  IF((nchsd1(i).NE.0.OR.nchsd2(i).NE.0).AND.ip.NE.1)
5652  & CALL saptre(amcsd1(i),gacsd1(i),bgxsd1(i),bgysd1(i),bgzsd1(i),
5653  & amcsd2(i),gacsd2(i),bgxsd2(i),bgysd2(i),bgzsd2(i))
5654 C----------------------------------------------------------------
5655 C----------------------------------------------------------------
5656 C WRITE (6,1244) POJ,PAT
5657 C1244 FORMAT (' V-D QUARK-DIQUARK POJ,PAT ',8E12.3)
5658 * IF(AMCSD1(I).LT.1.6)THEN
5659 * IF(NCHSD1(I).EQ.0)THEN
5660 * WRITE(6,'(A,F10.2,5I5)')' HADRSD AMCDS1(I),NCHSD1(I),I ',
5661 * + AMCSD1(I),NCHSD1(I),IJCSD1(I),I,IS1,IS2
5662 * RETURN
5663 * ENDIF
5664 * ENDIF
5665 C------------------------------------------------------------------
5666 C check bookkeeping
5667 C-----------------------------------------------------------------
5668 C I= number of valence chain
5669 C Target Nr itt = IFROVT(INTSV2(I))
5670 C No of Glauber sea q at Target JITT=JTSHS(ITT)
5671 C ITTT = IFROVT(INTSV2(I))
5672 C IF(INTSD2(I).GE.1)THEN
5673 C ITTT = IFROVT(INTSD2(I))
5674 C ELSE
5675  ittt=0
5676 C ENDIF
5677 C IF(ITTT.GE.1)THEN
5678 C JITT=JTSHS(ITTT)
5679 C ELSE
5680  jitt=0
5681 C ENDIF
5682 C IF(NCHSV1(I).EQ.0)THEN
5683 C WRITE(6,'(A,3I5)')'HADRSV: I,ITTT,JITT ',
5684 C * I,ITTT,JITT
5685 C ENDIF
5686 C------------------------------------------------------------------
5687 C check bookkeeping
5688 C-----------------------------------------------------------------
5689  IF(ifb2.LE.2.AND.ifb3.LE.2)THEN
5690  nsduu=nsduu+1
5691  ELSEIF((ifb2.EQ.3.AND.ifb3.LE.2).OR.
5692  * (ifb3.EQ.3.AND.ifb2.LE.2))THEN
5693  nsdus=nsdus+1
5694  ELSEIF(ifb2.EQ.3.AND.ifb3.EQ.3)THEN
5695  nsdss=nsdss+1
5696  ENDIF
5697  IF((nchsd1(i).NE.0))
5698  * CALL hadjet(nhad,amcsd1(i),poj,pat,gacsd1(i),
5699  * bgxsd1(i), bgysd1
5700  + (i),bgzsd1(i),ifb1,ifb2,ifb3,ifb4, ijcsd1(i),
5701  * ijcsd1(i),4,nchsd1
5702  + (i),17)
5703 C---------------------------------------------------------------
5704  aack=float(ick4)/float(ick4+ihad4+1)
5705  IF((nchsd1(i).EQ.0))THEN
5706  zseawu=rndm(bb)*2.d0*zseaav
5707  rseack=float(jitt)*pdbse +zseawu*pdbseu
5708  IF(ipco.GE.1)WRITE(6,'(2A,I5,2F10.3)')'HADJSE JITT,',
5709  * 'RSEACK,PDBSE 4 dpmnuc5 ',
5710  + jitt,rseack,pdbse
5711  irejss=5
5712  IF(rndm(v).LE.rseack)THEN
5713  irejss=2
5714  IF(amcsd1(i).GT.2.3d0)THEN
5715  irejss=0
5716  CALL hadjse(nhad,amcsd1(i),poj,pat,gacsd1(i),bgxsd1(i),
5717  * bgysd1
5718  + (i),bgzsd1(i),ifb1,ifb2,ifb3,ifb4, ijcsd1(i),ijcsd1(i),4,
5719  * nchsd1
5720  + (i),3,irejss,iissqq)
5721  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JITT,',
5722  * 'RSEACK,IREJSS 4 dpmnuc5 NHAD',
5723  + jitt,rseack,irejss,nhad
5724  ENDIF
5725  IF(irejss.GE.1)THEN
5726  IF(irejss.EQ.1)irejse=irejse+1
5727  IF(irejss.EQ.3)irejs3=irejs3+1
5728  IF(irejss.EQ.2)irejs0=irejs0+1
5729  CALL hadjet(nhad,amcsd1(i),poj,pat,gacsd1(i),
5730  * bgxsd1(i), bgysd1
5731  + (i),bgzsd1(i),ifb1,ifb2,ifb3,ifb4, ijcsd1(i),
5732  * ijcsd1(i),4,nchsd1
5733  + (i),17)
5734  ihad4=ihad4+1
5735  ENDIF
5736  IF(irejss.EQ.0)THEN
5737  IF(iissqq.EQ.3)THEN
5738  ise43=ise43+1
5739  ELSE
5740  ise4=ise4+1
5741  ENDIF
5742  ENDIF
5743  ELSE
5744  CALL hadjet(nhad,amcsd1(i),poj,pat,gacsd1(i),
5745  * bgxsd1(i), bgysd1
5746  + (i),bgzsd1(i),ifb1,ifb2,ifb3,ifb4, ijcsd1(i),
5747  * ijcsd1(i),4,nchsd1
5748  + (i),17)
5749  ihad4=ihad4+1
5750  ENDIF
5751  ENDIF
5752 C---------------------------------------------------------------
5753  acousd=acousd+1
5754  nhkkau=nhkk+1
5755  DO 20 j=1,nhad
5756  IF (nhkk.EQ.nmxhkk) THEN
5757  WRITE (6,'(A,2I5/A)') .EQ.' HADRSD: NHKKNMXHKK ',nhkk,nmxhkk
5758  RETURN
5759  ENDIF
5760 C NHKK=NHKK+1
5761  IF (nhkk.EQ.nmxhkk)THEN
5762  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
5763  RETURN
5764  ENDIF
5765 C
5766  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5767  IF (abs(ehecc-hef(j)).GT.0.001) THEN
5768 C WRITE(6,'(2A/3I5,3E15.6)')
5769 C & ' HADRSD / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
5770 C * ' NCALSD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
5771 C * NCALSD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
5772  hef(j)=ehecc
5773  ENDIF
5774  annsd=annsd+1
5775  eesd=eesd+hef(j)
5776  ptsd=ptsd+sqrt(pxf(j)**2+pyf(j)**2)
5777 C PUT NN-CMS HADRONS INTO /HKKEVT/
5778  istist=1
5779  IF(ibarf(j).EQ.500)istist=2
5780  IF(ipco.GE.3)WRITE(6,*)' HADRSD before HKKFIL J,NHAD',j,nhad
5781  CALL hkkfil(istist,mpdgha(nref(j)),mhkksd(i)-3,0,
5782  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),19)
5783  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
5784  + (nhkk)
5785  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
5786  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
5787  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
5788 
5789  20 CONTINUE
5790 C WRITE(6,*)' after 20 CONTINUE'
5791 C IF(NHAD.GT.0) THEN
5792 C JDAHKK(1,IMOHKK)=NHKKAU
5793 C JDAHKK(2,IMOHKK)=NHKK
5794 C ENDIF
5795 C+++++++++++++++++++++++++++++ CHAIN 2: aquark - adiquark +++++++++
5796  ifb1=ipsaq(is1)
5797  ifb2=itsaq(is2)
5798  ifb3=itsaq2(is2)
5799  ifb1=iabs(ifb1)+6
5800  ifb2=iabs(ifb2)+6
5801  ifb3=iabs(ifb3)+6
5802  DO 30 j=1,4
5803  poj(j)=pqsdb2(i,j)
5804  pat(j)=pqsdb1(i,j)
5805  30 CONTINUE
5806 C
5807 * IF(AMCSD2(I).LT.1.6)THEN
5808 * IF(NCHSD2(I).EQ.0)THEN
5809 * WRITE(6,'(A,F10.2,5I5)')' HADRSD AMCSD2(I),NCHSD2(I),I ',
5810 * + AMCSD2(I),NCHSD2(I),IJCSD2(I),I,IS1,IS2
5811 * RETURN
5812 * ENDIF
5813 * ENDIF
5814 C------------------------------------------------------------------
5815 C check bookkeeping
5816 C-----------------------------------------------------------------
5817 C I= number of valence chain
5818 C Target Nr itt = IFROVT(INTSV2(I))
5819 C No of Glauber sea q at Target JITT=JTSHS(ITT)
5820 C ITTT = IFROVT(INTSV2(I))
5821 C WRITE(6,*)' INTSD2(I),I',INTSD2(I),I
5822 C IF(INTSD2(I).GE.1)THEN
5823 C ITTT = IFROVT(INTSD2(I))
5824 C ELSE
5825  ittt=0
5826 C ENDIF
5827 C WRITE(6,*)' ITTT',ITTT
5828 C IF(ITTT.GE.1)THEN
5829 C JITT=JTSHS(ITTT)
5830 C ELSEIF(ITTT.EQ.0)THEN
5831  jitt=0
5832 C ENDIF
5833 C WRITE(6,*)' JITT',JITT
5834 C IF(NCHSV1(I).EQ.0)THEN
5835 C WRITE(6,'(A,3I5)')'HADRSD: I,ITTT,JITT ',
5836 C * I,ITTT,JITT
5837 C ENDIF
5838 C------------------------------------------------------------------
5839 C check bookkeeping
5840 C-----------------------------------------------------------------
5841  IF(ifb2.LE.8.AND.ifb3.LE.8)THEN
5842  nasduu=nasduu+1
5843  ELSEIF((ifb2.EQ.9.AND.ifb3.LE.8).OR.
5844  * (ifb3.EQ.9.AND.ifb2.LE.8))THEN
5845  nasdus=nasdus+1
5846  ELSEIF(ifb2.EQ.9.AND.ifb3.EQ.9)THEN
5847  nasdss=nasdss+1
5848  ENDIF
5849  IF((nchsd2(i).NE.0))
5850  * CALL hadjet(nhad,amcsd2(i),poj,pat,gacsd2(i),
5851  * bgxsd2(i), bgysd2
5852  + (i),bgzsd2(i),ifb1,ifb2,ifb3,ifb4, ijcsd2(i),
5853  * ijcsd2(i),4,nchsd2
5854  + (i),18)
5855 C----------------------------------------------------------------
5856  aack=float(ick4)/float(ick4+ihad4+1)
5857  IF((nchsd2(i).EQ.0))THEN
5858  zseawu=rndm(bb)*2.d0*zseaav
5859  rseack=float(jitt)*pdbse +zseawu*pdbseu
5860  IF(ipco.GE.1)WRITE(6,'(2A,I5,2F10.3)')'HADJASE JITT,',
5861  * 'RSEACK,PDBSE ',
5862  + jitt,rseack,pdbse
5863  irejss=5
5864  IF(rndm(v).LE.rseack)THEN
5865  irejss=2
5866  IF(amcsd2(i).GT.2.3d0)THEN
5867  irejss=0
5868  CALL hadjase(nhad,amcsd2(i),poj,pat,gacsd2(i),bgxsd2(i),
5869  * bgysd2
5870  + (i),bgzsd2(i),ifb1,ifb2,ifb3,ifb4, ijcsd2(i),ijcsd2(i),4,
5871  * nchsd2
5872  + (i),3,irejss,iissqq)
5873  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JITT,',
5874  * 'RSEACK,IREJSS ',
5875  + jitt,rseack,irejss
5876  ENDIF
5877  IF(irejss.GE.1)THEN
5878  IF(irejss.EQ.1)irejsa=irejsa+1
5879  IF(irejss.EQ.3)ireja3=ireja3+1
5880  IF(irejss.EQ.2)ireja0=ireja0+1
5881  CALL hadjet(nhad,amcsd2(i),poj,pat,gacsd2(i),
5882  * bgxsd2(i), bgysd2
5883  + (i),bgzsd2(i),ifb1,ifb2,ifb3,ifb4, ijcsd2(i),
5884  * ijcsd2(i),4,nchsd2
5885  + (i),18)
5886  ihada4=ihada4+1
5887  ENDIF
5888  IF(irejss.EQ.0)THEN
5889  IF(iissqq.EQ.3)THEN
5890  isea43=isea43+1
5891  ELSE
5892  isea4=isea4+1
5893  ENDIF
5894  ENDIF
5895  ELSE
5896  CALL hadjet(nhad,amcsd2(i),poj,pat,gacsd2(i),
5897  * bgxsd2(i), bgysd2
5898  + (i),bgzsd2(i),ifb1,ifb2,ifb3,ifb4, ijcsd2(i),
5899  * ijcsd2(i),4,nchsd2
5900  + (i),18)
5901  ihada4=ihada4+1
5902  ENDIF
5903  ENDIF
5904 C----------------------------------------------------------------
5905 C ADD HADRONS/RESONANCES INTO
5906 C COMMON /ALLPAR/ STARTING AT NAUX
5907  nhkkau=nhkk+1
5908  DO 40 j=1,nhad
5909  IF (nhkk.EQ.nmxhkk) THEN
5910  WRITE (6,'(A,2I5/A)') .EQ.' HADRSD: NHKKNMXHKK ', nhkk,
5911  + nmxhkk
5912  RETURN
5913  ENDIF
5914 C NHKK=NHKK+1
5915  IF (nhkk.EQ.nmxhkk)THEN
5916  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
5917  RETURN
5918  ENDIF
5919 C
5920  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5921  IF (abs(ehecc-hef(j)).GT.0.001) THEN
5922 C WRITE(6,'(2A/3I5,3E15.6)')
5923 C & ' HADRSD / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
5924 C * ' NCALSD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
5925 C * NCALSD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
5926  hef(j)=ehecc
5927  ENDIF
5928  annsd=annsd+1
5929  eesd=eesd+hef(j)
5930  ptsd=ptsd+sqrt(pxf(j)**2+pyf(j)**2)
5931 C PUT NN-CMS HADRONS INTO /HKKEVT/
5932  istist=1
5933  IF(ibarf(j).EQ.500)istist=2
5934  CALL hkkfil(istist,mpdgha(nref(j)),mhkksd(i),0,
5935  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),20)
5936  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
5937  + (nhkk)
5938  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
5939  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
5940  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
5941 
5942  40 CONTINUE
5943 C IF(NHAD.GT.0) THEN
5944 C JDAHKK(1,IMOHKK)=NHKKAU
5945 C JDAHKK(2,IMOHKK)=NHKK
5946 C ENDIF
5947  50 CONTINUE
5948 C----------------------------------------------------------------
5949 C
5950  RETURN
5951  1010 FORMAT (i6,i4,5i6,9e10.2)
5952  1020 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
5953  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
5954  END
5955 C----------------------------------------------------------------
5956 C formerly dpmdiqqq.f
5957 C----------------------------------------------------------------
5958  SUBROUTINE diqdzz(ECM,XPSQ1,XPSAQ1,XPSQ2,XPSAQ2,
5959  * ipsq1,ipsaq1,ipsq2,ipsaq2,irejds)
5960  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5961  SAVE
5962 * define d-s chains (sea diquark - sea chains)
5963 * sqsq-sq and saqsaq-saq chains instead of q-aq and aq-q chains
5964  COMMON /zsea/zseaav,zseasu,anzsea
5965  common/popcck/pdbck,pdbse,pdbseu,
5966  * ijpock,irejck,ick4,ihad4,ick6,ihad6
5967  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
5968  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
5969  *isea43,isea63,irejao
5970 *KEEP,INTNEW.
5971  parameter(intmd=252)
5972  COMMON /intnez/ndz,nzd
5973  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
5974 C-------------------
5975 *KEEP,ABRDS.
5976  COMMON /abrdz/ amcds1(intmd),amcds2(intmd),
5977  +gacds1(intmd),gacds2(intmd),
5978  +bgxds1(intmd),bgyds1(intmd),bgzds1(intmd),
5979  +bgxds2(intmd),bgyds2(intmd),
5980  +bgzds2(intmd), nchds1(intmd),nchds2(intmd),
5981  +ijcds1(intmd),ijcds2(intmd),
5982  +pqdsa1(intmd,4),pqdsa2(intmd,4),
5983  +pqdsb1(intmd,4),pqdsb2(intmd,4),
5984  +ipsq(intmd),ipsqq2(intmd),itsq(intmd),
5985  +ipsaq(intmd),isaqq2(intmd),itsaq(intmd)
5986  +,idzss(intmd)
5987 C-------------------
5988 *KEND.
5989  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5990 *KEEP,DPAR.
5991 C /DPAR/ CONTAINS PARTICLE PROPERTIES
5992 C ANAME = LITERAL NAME OF THE PARTICLE
5993 C AAM = PARTICLE MASS IN GEV
5994 C GA = DECAY WIDTH
5995 C TAU = LIFE TIME OF INSTABLE PARTICLES
5996 C IICH = ELECTRIC CHARGE OF THE PARTICLE
5997 C IIBAR = BARYON NUMBER
5998 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
5999 C
6000  CHARACTER*8 aname
6001  COMMON /dpar/ aname(210),am(210),ga(210),tau(210),ich(210),
6002  +ibar(210),k1(210),k2(210)
6003 C COMMON /PCHARM/PCCCC
6004  common/seasu3/seasq
6005  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
6006  *idzre(3),izdre(3),idiqrz(7)
6007  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
6008  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
6009  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
6010  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
6011  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
6012  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
6013  parameter(ummm=0.3d0)
6014  parameter(smmm=0.5d0)
6015  parameter(cmmm=1.3d0)
6016  DATA pc/0.0001d0/
6017 *KEND.
6018 C----------
6019 C
6020  DATA inicha/0/
6021 C----------------------------------------------------------------------
6022 C Initialize Charm selection at soft chain ends
6023 C
6024  IF(inicha.EQ.0)THEN
6025  rx=8.
6026  x1=rx
6027  gm=2.140
6028  x2=ummm
6029  betoo=7.5d0
6030  ENDIF
6031  rx=8.
6032  x1=rx
6033  betcha=betoo+1.3-log10(ecm)
6034  pu=dbeta(x1,x2,betcha)
6035  x2=smmm
6036  ps=dbeta(x1,x2,betcha)
6037  x2=cmmm
6038  pc=dbeta(x1,x2,betcha)
6039 C PU1=PU/(2*PU+PS+PC)
6040 C PS1=PS/(2*PU+PS+PC)
6041  pc1=pc/(2*pu+ps+pc)
6042 C changed j.r.7.12.94
6043  pc=pc1
6044  pu1=pu/(2*pu+ps+pc)
6045  ps1=ps/(2*pu+ps+pc)
6046  IF(inicha.EQ.0)THEN
6047  inicha=1
6048  WRITE(6,4567)pc,betcha,pu1,ps1,seasq
6049  4567 FORMAT(' Charm chain ends DIQDZZ: PC,BETCHA,PU,PS,SEASQ',5f10.5)
6050  ENDIF
6051 C----------------------------------------------------------------------
6052  IF(iphkk.GE.3)WRITE (6,'( A)') ' diqdss'
6053  irejds=0
6054 * kinematics: is the mass of the adiquark-diquark chain big enough
6055 * to allow for fragmentation
6056  ipsqq1=1.d0+rndm(v1)*(2.d0+2.d0*seasq)
6057  rr=rndm(v)
6058  IF(rr.LT.pc)ipsqq1=4
6059 C------------------
6060  isaqq1=-ipsqq1
6061  amdsq1=xpsq1*xpsq2*ecm**2
6062  amdsq2=xpsaq1*xpsaq2*ecm**2
6063  idiqrz(1)=idiqrz(1)+1
6064  IF(ipsq1.EQ.3.AND.ipsqq1.EQ.3)THEN
6065  idiqrz(2)=idiqrz(2)+1
6066 C IF(AMDSQ2.LE.2.3.OR.AMDSQ1.LE.2.30) THEN
6067  IF(amdsq2.LE.6.6d0.OR.amdsq1.LE.6.60d0) THEN
6068  idiqrz(3)=idiqrz(3)+1
6069  idiqrz(2)=idiqrz(2)-1
6070  idiqrz(1)=idiqrz(1)-1
6071  irejds=1
6072  RETURN
6073  ENDIF
6074  ELSEIF(ipsq1.EQ.3.OR.ipsqq1.EQ.3)THEN
6075  idiqrz(4)=idiqrz(4)+1
6076 C IF(AMDSQ2.LE.1.9.OR.AMDSQ1.LE.1.90) THEN
6077  IF(amdsq2.LE.5.8d0.OR.amdsq1.LE.5.80d0) THEN
6078  idiqrz(5)=idiqrz(5)+1
6079  idiqrz(4)=idiqrz(4)-1
6080  idiqrz(1)=idiqrz(1)-1
6081  irejds=1
6082  RETURN
6083  ENDIF
6084  ELSEIF(((ipsq1.EQ.4).OR.(ipsqq1.EQ.4)).AND.
6085  * ((ipsq1.EQ.3).OR.(ipsqq1.EQ.3)))THEN
6086 C IF(AMDSQ2.LE.1.9.OR.AMDSQ1.LE.1.90) THEN
6087  IF(amdsq2.LE.30.8d0.OR.amdsq1.LE.30.80d0) THEN
6088  irejds=1
6089  RETURN
6090  ENDIF
6091  ELSEIF(ipsq1.EQ.4.OR.ipsqq1.EQ.4)THEN
6092 C IF(AMDSQ2.LE.1.9.OR.AMDSQ1.LE.1.90) THEN
6093  IF(amdsq2.LE.25.8.OR.amdsq1.LE.25.80) THEN
6094  irejds=1
6095  RETURN
6096  ENDIF
6097  ELSE
6098  idiqrz(6)=idiqrz(6)+1
6099 C IF(AMDSQ2.LE.1.50.OR.AMDSQ1.LE.1.50) THEN
6100  IF(amdsq2.LE.3.9.OR.amdsq1.LE.3.9) THEN
6101  idiqrz(7)=idiqrz(7)+1
6102  idiqrz(6)=idiqrz(6)-1
6103  idiqrz(1)=idiqrz(1)-1
6104  irejds=1
6105  RETURN
6106  ENDIF
6107  ENDIF
6108  ndz=ndz+1
6109  IF(ndz.GE.intmd)THEN
6110  irejds=1
6111  ndz=ndz-1
6112  RETURN
6113  ENDIF
6114 C WRITE(6,*)' DIQDZZ:IDIQRZ(1-7),NDZ ',(IDIQRZ(II),II=1,7),NDZ
6115  nchds1(ndz)=0
6116  nchds2(ndz)=0
6117 C WRITE(6,*)' DIQDZZ:NDZ,NCHDS1(NDZ),NCHDS2(NDZ) ',
6118 C * NDZ,NCHDS1(NDZ),NCHDS2(NDZ)
6119  idzss(ndz)=0
6120 C-------------------
6121 C KKEVDZ part
6122 C-------------------
6123  IF(iphkk.GE.3)WRITE (6,'( A,I10)') ' kkevdz',ndz
6124  n=ndz
6125 C DO 10 N=1,NDZ
6126 C
6127 C*** 4-MOMENTA OF PROJECTILE SEA-QUARK PAIRS IN NN-CMS
6128  IF(iphkk.GE.7)WRITE(6,'(A,2I10)')' KKEVDZ N,NDZ',n,ndz
6129 C
6130  prmomz=sqrt(ecm**2/4.-am(1)**2)
6131  psqpx=0.
6132  psqpy=0.
6133  psqpz=xpsq1*prmomz
6134  psqe=xpsq1*ecm/2.
6135  psaqpx=0.
6136  psaqpy=0.
6137  psaqpz=xpsaq1*prmomz
6138  psaqe=xpsaq1*ecm/2.
6139 C
6140 C*** 4-MOMENTA OF TARGET QUARK-AQUARK PAIRS IN NN-CMS
6141 C
6142  tsqpx=0.
6143  tsqpy=0.
6144  tsqpz=-xpsq2*prmomz
6145  tsqe=xpsq2*ecm/2.
6146  tsdqpx=0.
6147  tsdqpy=0.
6148  tsdqpz=-xpsaq2*prmomz
6149  tsdqe=xpsaq2*ecm/2.
6150 C
6151 C*** LORENTZ PARAMETER FOR CMS OF BOTH (sqsq-q) and
6152 C (saqsaq-diq)-SYSTEM
6153 C FROM PROJECTILE AND TARGET, RESP.
6154 C
6155  pxxx=psqpx + psaqpx + tsqpx + tsdqpx
6156  pyyy=psqpy + psaqpy + tsqpy + tsdqpy
6157  pzzz=psqpz + psaqpz + tsqpz + tsdqpz
6158  eee =psqe + psaqe + tsqe + tsdqe
6159  pptoto=sqrt(pxxx**2+pyyy**2+pzzz**2)
6160  ammm=sqrt(abs((eee+pptoto)*(eee-pptoto)))
6161  gammm=eee/(ammm+1.e-4)
6162  bgggx=pxxx/(ammm+1.e-4)
6163  bgggy=pyyy/(ammm+1.e-4)
6164  bgggz=pzzz/(ammm+1.e-4)
6165 C
6166 C*** SAMPLE PARTON-PT VALUES / DETERMINE PARTON 4-MOMENTA AND CHAIN MAS
6167 C*** IN THE REST FRAME DEFINED ABOVE
6168 C
6169 C XPSQCM=XPSQ1/(XPSQ1+XPSAQ1)
6170 C XPSACM=1.0 - XPSQCM
6171 C XTSQCM=XPSQ2/(XPSQ2+XPSAQ2)
6172 C XTSACM=1.0 - XTSQCM
6173  xpsqcm=xpsq1
6174  xpsacm=xpsaq1
6175  xtsqcm=xpsq2
6176  xtsacm=xpsaq2
6177 C
6178 C*** SAMPLE PARTON-PT VALUES / DETERMINE PARTON 4-MOMENTA AND CHAIN MAS
6179 C*** IN THE REST FRAME DEFINED ABOVE
6180 C
6181  ptxsq1=0
6182  ptysq1=0
6183  ptxsa1=0
6184  ptysa1=0
6185  ptxsq2=0
6186  ptysq2=0
6187  ptxsa2=0
6188  ptysa2=0
6189  plq1 = xpsq1 *ecm/2.
6190  eq1 = xpsq1 *ecm/2.
6191  plaq1= xpsaq1*ecm/2.
6192  eaq1 = xpsaq1*ecm/2.
6193  plq2 =-xpsq2 *ecm/2.
6194  eq2 = xpsq2 *ecm/2.
6195  plaq2=-xpsaq2*ecm/2.
6196  eaq2 = xpsaq2*ecm/2.
6197  ikvala=0
6198  nselpt=1
6199  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVDZ call selpt'
6200  CALL selpt(
6201  + ptxsq1,ptysq1,plq1,eq1,
6202  + ptxsa1,ptysa1,plaq1,eaq1,
6203  + ptxsa2,ptysa2,plaq2,eaq2,
6204  + ptxsq2,ptysq2,plq2,eq2,
6205  + amch1,amch2,irejds,ikvala,pttq1,ptta1,
6206  + pttq2,ptta2,nselpt)
6207 C
6208  IF (ipev.GE.7) WRITE(6,'(A/5X,5F12.5,I10)')
6209  + 'DS AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJ ', ammm,gammm,bgggx,
6210  + bgggy,bgggz,irej
6211  IF (irejds.EQ.1) THEN
6212 C NDZ=NDZ-1
6213  irds13=irds13 + 1
6214  IF(ipev.GE.2) THEN
6215  WRITE(6,'(A,I5)') ' KKEVDZ - IRDS13=',irds13
6216  WRITE(6,'(A/5E12.4/4(4E12.4/),2E12.4/2I5/4E12.4)')
6217  + ' DS: XPSQCM,XPSACM,XTSQCM,XTSACM,AMMM ...', xpsqcm,xpsacm,
6218  + xtsqcm,xtsacm,ammm, ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
6219  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
6220  + amch1,amch2,irejds,ikvala,pttq1,ptta1
6221  ENDIF
6222  go to 11
6223  ENDIF
6224 C
6225 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
6226 C
6227  ptxch1=ptxsq1 + ptxsq2
6228  ptych1=ptysq1 + ptysq2
6229  ptzch1=plq1 + plq2
6230  ech1=eq1 + eq2
6231  ptxch2=ptxsa2 + ptxsa1
6232  ptych2=ptysa2 + ptysa1
6233  ptzch2=plaq2 + plaq1
6234  ech2=eaq2 + eaq1
6235 C WRITE(6,667)ECH1,ECH2,PTZCH1,PTZCH2
6236 C 667 FORMAT(' DS ECH1,ECH2,PTZCH1,PTZCH2: ',4F10.3)
6237 C
6238  IF (ipev.GE.6) WRITE(6,'(A,5F12.5,I10/A,5F12.5/A,5F12.5)')
6239  + ' DS: AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJDS ', ammm,gammm,bgggx,
6240  + bgggy,bgggz,irejds, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
6241  + amch1,ptxch1,ptych1,ptzch1,ech1,
6242  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
6243  + ptzch2,ech2
6244 
6245 C
6246 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS OR OCTETT
6247 C OR DECUPLETT BARYONS
6248 C FIRST FOR CHAIN 1 (PROJ SEA-diquark - TAR QUARK)
6249 C
6250  CALL zobcma(ipsq1,ipsqq1,ipsq2, ijnch1,nnch1,
6251  + irejds,amch1,amch1n,1)
6252 C*** MASS BELOW OCTETT BARYON MASS
6253  IF(irejds.EQ.1) THEN
6254 C NDZ=NDZ-1
6255  irds11=irds11 + 1
6256  goto 11
6257  ENDIF
6258 C CORRECT KINEMATICS FOR CHAIN 1
6259 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
6260  IF(nnch1.NE.0)
6261  + CALL zormom(ammm,amch1,amch1n,amch2,
6262  + xpsq1,xpsaq1,xpsaq2,xpsq2,
6263  + ptxsq1,ptysq1,plq1,eq1,
6264  + ptxsa1,ptysa1,plaq1,eaq1,
6265  + ptxsa2,ptysa2,plaq2,eaq2,
6266  + ptxsq2,ptysq2,plq2,eq2,
6267  + ptxch1,ptych1,ptzch1,ech1, ptxch2,ptych2,ptzch2,ech2,
6268  + irejds)
6269  IF(irejds.EQ.1)THEN
6270  go to 11
6271  ENDIF
6272 C
6273  IF (ipev.GE.6) WRITE(6,'(A,5F12.5,I10/A,5F12.5/A,5F12.5)')
6274  + ' DS(2): AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJDS',ammm,gammm,bgggx,
6275  + bgggy,bgggz,irejds, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
6276  + amch1,ptxch1,ptych1,ptzch1,ech1,
6277  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
6278  + ptzch2,ech2
6279 C
6280 C REPLACE SMALL MASS CHAINS BY octet or decuplet baryons
6281 C SECOND FOR CHAIN 2 (proj sadiquark - tar saquark)
6282 C
6283  CALL zobcma(ipsaq1,isaqq1,ipsaq2,
6284  + ijnch2,nnch2,irejds,amch2,amch2n,2)
6285 c rejection of both s-s chains if mass of chain 2 too low
6286  IF(irejds.EQ.1) THEN
6287  irds12=irds12 + 1
6288 C NDZ=NDZ-1
6289  IF(ipev.GE.2) THEN
6290  WRITE(6,1090) irds12
6291  1090 FORMAT(' KKEVDZ - IRDS12=',i5)
6292  1100 FORMAT(' DS - 1100', 6i5/2(4e12.4/),2e12.4)
6293  ENDIF
6294  goto 11
6295  ENDIF
6296 C if AMCH2 changed in COBCMA/COMCMA
6297 C ZORVAL corrects chain kinematics
6298 C according to 2-body kinem.
6299 C with fixed masses
6300  IF(nnch2.NE.0) THEN
6301  amch2=amch2n
6302  iori=2
6303  CALL zorval(ammm,irejds,amch1,amch2, ptxch1,ptych1,ptzch1,ech1,
6304  + ptxch2,ptych2,ptzch2,ech2,iori)
6305  IF(irejds.EQ.1) THEN
6306 * AMCH1N + AMCH2N > AMMM - 0.2
6307 * reject event
6308 C NDZ=NDZ-1
6309  irds14=irds14+1
6310  goto 11
6311  ENDIF
6312 C
6313  IF(ipev.GE.6) THEN
6314  WRITE(6,'(A/3(1PE15.4),3I5)')
6315  + ' DS - CALL ZORVAL: AMMM,AMCH1,AMCH2,NNCH1,NNCH2,IREJDS',
6316  + ammm, amch1, amch2, nnch1, nnch2, irejds
6317  WRITE(6,1050) ammm,gammm,bgggx,bgggy,bgggz,irejds, amch1,
6318  + ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
6319  1050 FORMAT (' DS: AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJDS ',5f12.5,i10/
6320  + ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
6321  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
6322  ENDIF
6323  IF(irejds.EQ.1) THEN
6324 * AMCH1N + AMCH2N > AMMM - 0.2
6325 * reject event
6326 C NDZ=NDZ-1
6327  irds14=irds14+1
6328  goto 11
6329  ENDIF
6330  ENDIF
6331 C
6332 C TRANSFORM BOTH CHAINS BACK INTO NN CMS
6333 C
6334 C 4-MOMENTA OF CHAINS
6335  qtxch1=ptxch1
6336  qtych1=ptych1
6337  qtzch1=ptzch1
6338  qech1=ech1
6339  qtxch2=ptxch2
6340  qtych2=ptych2
6341  qtzch2=ptzch2
6342  qech2=ech2
6343 C WRITE(6,887)QECH1,QECH2,QTZCH1,QTZCH2,AMCH1,AMCH2
6344  887 FORMAT( ' DS: QECH1,QECH2,QTZCH1,QTZCH2,AMCH1,AMCH2 ',6f10.2)
6345 
6346 C PARTONS AT ENDS OF CHAIN 1
6347 C CALL DALTRA(GAMMM,BGGGX,BGGGY,BGGGZ, PTXSQ1,PTYSQ1,PLQ1,EQ1,
6348 C + PPPQ1, PQDSA1(N,1),PQDSA1(N,2),PQDSA1(N,3),PQDSA1(N,4) )
6349  pqdsa1(n,1)=ptxsq1
6350  pqdsa1(n,2)=ptysq1
6351  pqdsa1(n,3)=plq1
6352  pqdsa1(n,4)=eq1
6353  pqdsa2(n,1)=ptxsq2
6354  pqdsa2(n,2)=ptysq2
6355  pqdsa2(n,3)=plq2
6356  pqdsa2(n,4)=eq2
6357 
6358 C PARTONS AT ENDS OF CHAIN 2
6359  pqdsb2(n,1)=ptxsa2
6360  pqdsb2(n,2)=ptysa2
6361  pqdsb2(n,3)=plaq2
6362  pqdsb2(n,4)=eaq2
6363 
6364  pqdsb1(n,1)=ptxsa1
6365  pqdsb1(n,2)=ptysa1
6366  pqdsb1(n,3)=plaq1
6367  pqdsb1(n,4)=eaq1
6368 
6369 C
6370 C
6371 C
6372 C NOW WE HAVE AN ACCEPTABLE SEA--VALENCE EVENT
6373 * sea diquark pair!
6374 C AND PUT IT INTO THE HISTOGRAM
6375 C
6376  ipsq(n)=ipsq1
6377  ipsqq2(n)=ipsqq1
6378  itsq(n)=ipsq2
6379  ipsaq(n)=ipsaq1
6380  isaqq2(n)=isaqq1
6381  itsaq(n)=ipsaq2
6382  amcds1(n)=amch1
6383  amcds2(n)=amch2
6384  gacds1(n)=qech1/amch1
6385  bgxds1(n)=qtxch1/amch1
6386  bgyds1(n)=qtych1/amch1
6387  bgzds1(n)=qtzch1/amch1
6388  gacds2(n)=qech2/amch2
6389  bgxds2(n)=qtxch2/amch2
6390  bgyds2(n)=qtych2/amch2
6391  bgzds2(n)=qtzch2/amch2
6392  nchds1(n)=nnch1
6393  nchds2(n)=nnch2
6394  ijcds1(n)=ijnch1
6395  ijcds2(n)=ijnch2
6396  IF (ipev.GE.3) WRITE(6,'(A/I10,4F12.7,5I5/10X,4F12.6/10X,6F12.6,
6397  +4I5/8F15.5/ 8F15.5)') ' DS / FINAL PRINT',n
6398  go to 20
6399 C*** TREATMENT OF REJECTED SEA-SEA INTERACTIONS
6400  11 CONTINUE
6401  nchds1(n)=99
6402  nchds2(n)=99
6403 C 28.10.96
6404  ndz=ndz-1
6405  IF(ndz.LT.0)THEN
6406  ndz=ndz+1
6407  ENDIF
6408  issqq=ipsq1
6409  jssqq=ipsqq1
6410  IF(issqq.EQ.3.AND.jssqq.EQ.3)THEN
6411  idzre(3)=idzre(3)+1
6412  ELSEIF(issqq.EQ.3.OR.jssqq.EQ.3)THEN
6413  idzre(2)=idzre(2)+1
6414  ELSE
6415  idzre(1)=idzre(1)+1
6416  ENDIF
6417  20 CONTINUE
6418  10 CONTINUE
6419 C WRITE(6,*)' DIQDZZ: IDZRE(1-3),NDZ ',(IDZRE(II),II=1,3),NDZ
6420 C WRITE(6,*)' DIQDZZ:NDZ,NCHDS1(NDZ),NCHDS2(NDZ) ',
6421 C * NDZ,NCHDS1(NDZ),NCHDS2(NDZ)
6422  RETURN
6423  END
6424 C
6425 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6426 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6427 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6428 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6429 
6430 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6431 C
6432  SUBROUTINE hadrdz
6433  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6434  SAVE
6435 C-------------------------
6436 C
6437 C hadronize sea diquark - valence CHAINS
6438 C
6439 C ADD GENERATED HADRONS TO /ALLPAR/
6440 C STARTING AT (NAUX + 1)
6441 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
6442 C
6443 C---------------------------------------------------------
6444  COMMON /zsea/zseaav,zseasu,anzsea
6445  common/popcck/pdbck,pdbse,pdbseu,
6446  * ijpock,irejck,ick4,ihad4,ick6,ihad6
6447  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
6448  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
6449  *isea43,isea63,irejao
6450 *KEEP,INTNEW.
6451  parameter(intmd=252)
6452  COMMON /intnez/ ndz,nzd
6453 C-------------------
6454 *KEEP,ABRDS.
6455  COMMON /abrdz/ amcds1(intmd),amcds2(intmd),
6456  +gacds1(intmd),gacds2(intmd),
6457  +bgxds1(intmd),bgyds1(intmd),bgzds1(intmd),
6458  +bgxds2(intmd),bgyds2(intmd),
6459  +bgzds2(intmd), nchds1(intmd),nchds2(intmd),
6460  +ijcds1(intmd),ijcds2(intmd),
6461  +pqdsa1(intmd,4),pqdsa2(intmd,4),
6462  +pqdsb1(intmd,4),pqdsb2(intmd,4),
6463  +ipsq(intmd),ipsqq2(intmd),itsq(intmd),
6464  +ipsaq(intmd),isaqq2(intmd),itsaq(intmd)
6465  +,idzss(intmd)
6466 *KEEP,INTMX.
6467  parameter(intmx=2488)
6468 *KEEP,IFROTO.
6469  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
6470  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
6471  +jhkknt
6472  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
6473  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
6474  & mhkkhh(intmx),
6475  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
6476 *KEEP,DIQI.
6477 C COMMON /DIQI/ IPVQ(248),IPPV1(248),IPPV2(248), ITVQ(248),ITTV1
6478 C +(248),ITTV2(248), IPSQ(INTMX),IPSQ2(INTMX),
6479 C +IPSAQ(INTMX),IPSAQ2(INTMX),ITSQ(INTMX),ITSQ2(INTMX),
6480 C +ITSAQ(INTMX),ITSAQ2(INTMX),KKPROJ(248),KKTARG(248)
6481 *KEEP,DXQX.
6482 C INCLUDE (XQXQ)
6483 * NOTE: INTMX set via INCLUDE(INTMX)
6484  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
6485  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
6486  * ,xpsu(248),xtsu(248)
6487  * ,xpsut(248),xtsut(248)
6488 
6489 C-------------------
6490 *KEEP,LOZUO.
6491  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
6492  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
6493  +intlo(intmx),inloss(intmx)
6494 C /LOZUO/
6495 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
6496 C REJECTED IN KKEVT
6497 C------------------
6498 *KEEP,HKKEVT.
6499  parameter(nmxhkk= 89998)
6500 c PARAMETER (NMXHKK=25000)
6501  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
6502  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
6503  +(4,nmxhkk)
6504 C
6505 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
6506 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
6507 C THE POSITIONS OF THE PROJECTILE NUCLEONS
6508 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
6509 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
6510 C COMPLETELY CONSISTENT. THE TIMES IN THE
6511 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
6512 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
6513 C
6514 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
6515 C
6516 C NMXHKK: maximum numbers of entries (partons/particles) that can be
6517 C stored in the commonblock.
6518 C
6519 C NHKK: the actual number of entries stored in current event. These are
6520 C found in the first NHKK positions of the respective arrays below.
6521 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
6522 C entry.
6523 C
6524 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
6525 C = 0 : null entry.
6526 C = 1 : an existing entry, which has not decayed or fragmented.
6527 C This is the main class of entries which represents the
6528 C "final state" given by the generator.
6529 C = 2 : an entry which has decayed or fragmented and therefore
6530 C is not appearing in the final state, but is retained for
6531 C event history information.
6532 C = 3 : a documentation line, defined separately from the event
6533 C history. (incoming reacting
6534 C particles, etc.)
6535 C = 4 - 10 : undefined, but reserved for future standards.
6536 C = 11 - 20 : at the disposal of each model builder for constructs
6537 C specific to his program, but equivalent to a null line in the
6538 C context of any other program. One example is the cone defining
6539 C vector of HERWIG, another cluster or event axes of the JETSET
6540 C analysis routines.
6541 C = 21 - : at the disposal of users, in particular for event tracking
6542 C in the detector.
6543 C
6544 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
6545 C standard.
6546 C
6547 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
6548 C The value is 0 for initial entries.
6549 C
6550 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
6551 C one mother exist, in which case the value 0 is used. In cluster
6552 C fragmentation models, the two mothers would correspond to the q
6553 C and qbar which join to form a cluster. In string fragmentation,
6554 C the two mothers of a particle produced in the fragmentation would
6555 C be the two endpoints of the string (with the range in between
6556 C implied).
6557 C
6558 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
6559 C entry has not decayed, this is 0.
6560 C
6561 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
6562 C entry has not decayed, this is 0. It is assumed that the daughters
6563 C of a particle (or cluster or string) are stored sequentially, so
6564 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
6565 C daughters. Even in cases where only one daughter is defined (e.g.
6566 C K0 -> K0S) both values should be defined, to make for a uniform
6567 C approach in terms of loop constructions.
6568 C
6569 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
6570 C
6571 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
6572 C
6573 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
6574 C
6575 C PHKK(4,IHKK) : energy, in GeV.
6576 C
6577 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
6578 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
6579 C
6580 C VHKK(1,IHKK) : production vertex x position, in mm.
6581 C
6582 C VHKK(2,IHKK) : production vertex y position, in mm.
6583 C
6584 C VHKK(3,IHKK) : production vertex z position, in mm.
6585 C
6586 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
6587 C********************************************************************
6588 *KEEP,DFINPA.
6589  CHARACTER*8 anf
6590  parameter(nfimax=249)
6591  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
6592  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
6593  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
6594  * istath(nfimax)
6595 *KEEP,DPRIN.
6596  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6597 *KEEP,PROJK.
6598  COMMON /projk/ iprojk
6599 *KEND.
6600  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
6601 C modified DPMJET
6602  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
6603  * anndv,annvd,annds,annsd,
6604  * annhh,annzz,
6605  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
6606  * pthh,ptzz,
6607  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
6608  * eehh,eezz
6609  * ,anndi,ptdi,eedi
6610  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
6611  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
6612  * acouzz,acouhh,acouds,acousd,
6613  * acoudz,acouzd,acoudi,
6614  * acoudv,acouvd,acoucc
6615  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
6616  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
6617  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
6618  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
6619  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
6620  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
6621 *KEEP,INTNEW.
6622  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
6623  +ixpv,ixps,ixtv,ixts, intvv1(248),
6624  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
6625  +intss1(intmx),intss2(intmx),
6626  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
6627  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
6628 C---------------------
6629  dimension poj(4),pat(4)
6630  DATA ncalds /0/
6631 C IPHKK=3
6632 C-----------------------------------------------------------------------
6633  IF(iphkk.GE.3)WRITE (6,'( A,4I10)') ' hadrdz',ndz,nzd,
6634  * nchds1(1),nchds2(1)
6635  ncalds=ncalds+1
6636  DO 50 i=1,ndz
6637 C-----------------------drop recombined chain pairs
6638  IF(nchds1(i).EQ.99.AND.nchds2(i).EQ.99) go to 50
6639  is1=i
6640  is2=i
6641 C
6642  IF (ipco.GE.6) WRITE (6,*)'IPSQ(IS1),IPSAQ(IS1),ITSQ(IS2)',
6643  + 'ITSAQ(IS2), AMCDS1(I),AMCDS2(I),GACDS1(I),GACDS2(I)',
6644  + 'BGXDS1(I),BGYDS1(I),BGZDS1(I), BGXDS2(I),BGYDS2(I),BGZDS2(I)',
6645  + 'NCHDS1(I),NCHDS2(I),IJCDS1(I),IJCDS2(I), PQDSA1(I,4),PQDSA2',
6646  + '(I,4),PQDSB1(I,4),PQDSB2(I,4)',
6647  * ipsq(is1),ipsaq(is1),itsq(is2),
6648  + itsaq(is2), amcds1(i),amcds2(i),gacds1(i),gacds2(i),
6649  + bgxds1(i),bgyds1(i),bgzds1(i), bgxds2(i),bgyds2(i),bgzds2(i),
6650  + nchds1(i),nchds2(i),ijcds1(i),ijcds2(i), pqdsa1(i,4),pqdsa2
6651  + (i,4),pqdsb1(i,4),pqdsb2(i,4)
6652  1000 FORMAT(10x,4i5,10f9.2/10x,4i5,4f12.4)
6653 C
6654 C
6655 C++++++++++++++++++++++++++++++ CHAIN 1: diquark-quark +++++++++++
6656  ifb1=ipsq(is1)
6657  ifb2=ipsqq2(is1)
6658  ifb3=itsq(is2)
6659  DO 10 j=1,4
6660  poj(j)=pqdsa1(i,j)
6661  pat(j)=pqdsa2(i,j)
6662  10 CONTINUE
6663  IF((nchds1(i).NE.0.OR.nchds2(i).NE.0).AND.ip.NE.1)
6664  & CALL saptre(amcds1(i),gacds1(i),bgxds1(i),bgyds1(i),bgzds1(i),
6665  & amcds2(i),gacds2(i),bgxds2(i),bgyds2(i),bgzds2(i))
6666 C----------------------------------------------------------------
6667 C----------------------------------------------------------------
6668  IF (ipco.GE.6)WRITE (6,1244) poj,pat
6669  1244 FORMAT (' D-V QUARK-DIQUARK POJ,PAT ',8e12.3)
6670 * IF(AMCDS1(I).LT.1.6)THEN
6671 * IF(NCHDS1(I).EQ.0)THEN
6672 * WRITE(6,'(A,F10.2,5I5)')' HADRDZ AMCDS1(I),NCHDS1(I),I ',
6673 * + AMCDS1(I),NCHDS1(I),IJCDS1(I),I,IS1,IS2
6674 * RETURN
6675 * ENDIF
6676 * ENDIF
6677 C------------------------------------------------------------------
6678 C check bookkeeping
6679 C-----------------------------------------------------------------
6680 C I= number of valence chain
6681 C Projectile Nr ipp = IFROVP(INTVS1(I))
6682 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
6683  IF(ipco.GE.4)WRITE(6,*)' IPPP,INTVS1(I)',ippp,intvs1(i)
6684  IF(intvs1(i).GT.0)THEN
6685  ippp = ifrovp(intvs1(i))
6686  IF(ipco.GE.4)WRITE(6,*)' IPPP,INTVS1(I)',ippp,intvs1(i)
6687  jipp=jsshs(ippp)
6688  ELSEIF(intvs1(i).EQ.0)THEN
6689  jipp=0
6690  ENDIF
6691  IF(ipco.GE.4)WRITE(6,*)' JIPP,INTVS1(I)',jipp,intvs1(i)
6692 C IF(NCHVS2(I).EQ.0)THEN
6693 C WRITE(6,'(A,3I5)')'HADRVS: I,IPPP,JIPP ',
6694 C * I,IPPP,JIPP
6695 C ENDIF
6696 C------------------------------------------------------------------
6697 C check bookkeeping
6698 C-----------------------------------------------------------------
6699  IF(ifb1.LE.2.AND.ifb2.LE.2)THEN
6700  ndzuu=ndzuu+1
6701  ELSEIF((ifb1.EQ.3.AND.ifb2.LE.2).OR.
6702  * (ifb2.EQ.3.AND.ifb1.LE.2))THEN
6703  ndzus=ndzus+1
6704  ELSEIF(ifb1.EQ.3.AND.ifb2.EQ.3)THEN
6705  ndzss=ndzss+1
6706  ENDIF
6707  IF((nchds1(i).NE.0))
6708  * CALL hadjet(nhad,amcds1(i),poj,pat,gacds1(i),bgxds1(i), bgyds1
6709  + (i),bgzds1(i),ifb1,ifb2,ifb3,ifb4, ijcds1(i),ijcds1(i),6,nchds1
6710  + (i),15)
6711 C---------------------------------------------------------------------
6712  aack=float(ick6)/float(ick6+ihad6+1)
6713  IF((nchds1(i).EQ.0))THEN
6714  zseawu=rndm(bb)*2.d0*zseaav
6715  rseack=float(jitt)*pdbse +zseawu*pdbseu
6716  IF(ipco.GE.1)WRITE(6,'(2A,I5,2F10.3)')'HADJSE JIPP,',
6717  * 'RSEACK,PDBSE 1 dpmdiqqq',
6718  + jipp,rseack,pdbse
6719  irejss=5
6720  IF(rndm(v).LE.rseack)THEN
6721  irejss=2
6722  IF(amcds1(i).GT.2.3d0)THEN
6723  irejss=0
6724  CALL hadjse(nhad,amcds1(i),poj,pat,gacds1(i),bgxds1(i),
6725  * bgyds1
6726  + (i),bgzds1(i),ifb1,ifb2,ifb3,ifb4, ijcds1(i),ijcds1(i),6,
6727  * nchds1
6728  + (i),6,irejss,iissqq)
6729  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JIPP,',
6730  * 'RSEACK,IREJSS 1 dpmdiqqq ',
6731  + jipp,rseack,irejss
6732  ENDIF
6733  IF(irejss.GE.1)THEN
6734  IF(irejss.EQ.1)irejse=irejse+1
6735  IF(irejss.EQ.3)irejs3=irejs3+1
6736  IF(irejss.EQ.2)irejs0=irejs0+1
6737  CALL hadjet(nhad,amcds1(i),poj,pat,gacds1(i),bgxds1(i), bgyds1
6738  + (i),bgzds1(i),ifb1,ifb2,ifb3,ifb4, ijcds1(i),ijcds1(i),6,nchds1
6739  + (i),15)
6740  ihad6=ihad6+1
6741  ENDIF
6742  IF(irejss.EQ.0)THEN
6743  IF(iissqq.EQ.3)THEN
6744  ise63=ise63+1
6745  ELSE
6746  ise6=ise6+1
6747  ENDIF
6748  ENDIF
6749  ELSE
6750  CALL hadjet(nhad,amcds1(i),poj,pat,gacds1(i),bgxds1(i), bgyds1
6751  + (i),bgzds1(i),ifb1,ifb2,ifb3,ifb4, ijcds1(i),ijcds1(i),6,nchds1
6752  + (i),15)
6753  ihad6=ihad6+1
6754  ENDIF
6755  ENDIF
6756 C---------------------------------------------------------------------
6757  acoudz=acoudz+1
6758  nhkkau=nhkk+1
6759  DO 20 j=1,nhad
6760  IF (nhkk.EQ.nmxhkk) THEN
6761  WRITE (6,'(A,2I5/A)') .EQ.' HADRDZ: NHKKNMXHKK ',nhkk,nmxhkk
6762  RETURN
6763  ENDIF
6764 C NHKK=NHKK+1
6765  IF (nhkk.EQ.nmxhkk)THEN
6766  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
6767  RETURN
6768  ENDIF
6769 C
6770  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
6771  IF (abs(ehecc-hef(j)).GT.0.001) THEN
6772 C WRITE(6,'(2A/3I5,3E15.6)')
6773 C & ' HADRDZ / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
6774 C * ' NCALDS, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
6775 C * NCALDS, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
6776  hef(j)=ehecc
6777  ENDIF
6778  anndz=anndz+1
6779  eedz=eedz+hef(j)
6780  ptdz=ptdz+sqrt(pxf(j)**2+pyf(j)**2)
6781 C PUT NN-CMS HADRONS INTO /HKKEVT/
6782  istist=1
6783  IF(ibarf(j).EQ.500)istist=2
6784  CALL hkkfil(istist,mpdgha(nref(j)),1,0,
6785  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),21)
6786  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
6787  + (nhkk)
6788 C JMOHKK(1,NHKK)=MHKKSS(I)-3
6789  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
6790  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
6791  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
6792 
6793  20 CONTINUE
6794 C IF(NHAD.GT.0) THEN
6795 C JDAHKK(1,IMOHKK)=NHKKAU
6796 C JDAHKK(2,IMOHKK)=NHKK
6797 C ENDIF
6798 C+++++++++++++++++++++++++++++ CHAIN 2: adiquark - aquark +++++++++
6799  ifb1=ipsaq(is1)
6800  ifb2=isaqq2(is1)
6801  ifb3=itsaq(is2)
6802  ifb1=iabs(ifb1)+6
6803  ifb2=iabs(ifb2)+6
6804  ifb3=iabs(ifb3)+6
6805  DO 30 j=1,4
6806  poj(j)=pqdsb2(i,j)
6807  pat(j)=pqdsb1(i,j)
6808  30 CONTINUE
6809 * IF(AMCDS2(I).LT.1.6)THEN
6810 * IF(NCHDS2(I).EQ.0)THEN
6811 * WRITE(6,'(A,F10.2,5I5)')' HADRDZ AMCDS2(I),NCHDS2(I),I ',
6812 * + AMCDS2(I),NCHDS2(I),IJCDS2(I),I,IS1,IS2
6813 * RETURN
6814 * ENDIF
6815 * ENDIF
6816 C
6817 C------------------------------------------------------------------
6818 C check bookkeeping
6819 C-----------------------------------------------------------------
6820 C I= number of valence chain
6821 C Projectile Nr ipp = IFROVP(INTVS1(I))
6822 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
6823  IF(intvs1(i).GT.0)THEN
6824  ippp = ifrovp(intvs1(i))
6825  jitt=jsshs(ippp)
6826  ELSEIF(intvs1(i).EQ.0)THEN
6827  jitt=0
6828  ENDIF
6829 C IF(NCHVS2(I).EQ.0)THEN
6830 C WRITE(6,'(A,3I5)')'HADRVS: I,IPPP,JIPP ',
6831 C * I,IPPP,JIPP
6832 C ENDIF
6833 C------------------------------------------------------------------
6834 C check bookkeeping
6835 C-----------------------------------------------------------------
6836  IF(ifb1.LE.8.AND.ifb2.LE.8)THEN
6837  nadzuu=nadzuu+1
6838  ELSEIF((ifb1.EQ.9.AND.ifb2.LE.8).OR.
6839  * (ifb2.EQ.9.AND.ifb1.LE.8))THEN
6840  nadzus=nadzus+1
6841  ELSEIF(ifb1.EQ.9.AND.ifb2.EQ.9)THEN
6842  nadzss=nadzss+1
6843  ENDIF
6844  IF((nchds2(i).NE.0))
6845  * CALL hadjet(nhad,amcds2(i),poj,pat,gacds2(i),bgxds2(i), bgyds2
6846  + (i),bgzds2(i),ifb1,ifb2,ifb3,ifb4, ijcds2(i),ijcds2(i),6,nchds2
6847  + (i),16)
6848 C-----------------------------------------------------------------------
6849  IF((nchds2(i).EQ.0))THEN
6850  zseawu=rndm(bb)*2.d0*zseaav
6851  rseack=float(jitt)*pdbse +zseawu*pdbseu
6852  IF(ipco.GE.1)WRITE(6,'(2A,I5,2F10.3)')'HADJSE JIPP,',
6853  * 'RSEACK,PDBSE ',
6854  + jipp,rseack,pdbse
6855  irejss=5
6856  IF(rndm(v).LE.rseack)THEN
6857  irejss=2
6858  IF(amcds2(i).GT.2.3d0)THEN
6859  irejss=0
6860  CALL hadjase(nhad,amcds2(i),poj,pat,gacds2(i),bgxds2(i),
6861  * bgyds2
6862  + (i),bgzds2(i),ifb1,ifb2,ifb3,ifb4, ijcds2(i),ijcds2(i),6,
6863  * nchds2
6864  + (i),6,irejss,iissqq)
6865  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JIPP,',
6866  * 'RSEACK,IREJSS ',
6867  + jipp,rseack,irejss
6868  ENDIF
6869  IF(irejss.GE.1)THEN
6870  IF(irejss.EQ.1)irejsa=irejsa+1
6871  IF(irejss.EQ.3)ireja3=ireja3+1
6872  IF(irejss.EQ.2)ireja0=ireja0+1
6873  CALL hadjet(nhad,amcds2(i),poj,pat,gacds2(i),bgxds2(i), bgyds2
6874  + (i),bgzds2(i),ifb1,ifb2,ifb3,ifb4, ijcds2(i),ijcds2(i),6,nchds2
6875  + (i),16)
6876  ihada6=ihada6+1
6877  ENDIF
6878  IF(irejss.EQ.0)THEN
6879  IF(iissqq.EQ.3)THEN
6880  isea63=isea63+1
6881  ELSE
6882  isea6=isea6+1
6883  ENDIF
6884  ENDIF
6885  ELSE
6886  CALL hadjet(nhad,amcds2(i),poj,pat,gacds2(i),bgxds2(i), bgyds2
6887  + (i),bgzds2(i),ifb1,ifb2,ifb3,ifb4, ijcds2(i),ijcds2(i),6,nchds2
6888  + (i),16)
6889  ihada6=ihada6+1
6890  ENDIF
6891  ENDIF
6892 C-----------------------------------------------------------------------
6893 C ADD HADRONS/RESONANCES INTO
6894 C COMMON /ALLPAR/ STARTING AT NAUX
6895  nhkkau=nhkk+1
6896  DO 40 j=1,nhad
6897  IF (nhkk.EQ.nmxhkk) THEN
6898  WRITE (6,'(A,2I5/A)') .EQ.' HADRDZ: NHKKNMXHKK ', nhkk,
6899  + nmxhkk
6900  RETURN
6901  ENDIF
6902 C NHKK=NHKK+1
6903  IF (nhkk.EQ.nmxhkk)THEN
6904  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
6905  RETURN
6906  ENDIF
6907 C
6908  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
6909  IF (abs(ehecc-hef(j)).GT.0.001) THEN
6910 C WRITE(6,'(2A/3I5,3E15.6)')
6911 C & ' HADRDZ / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
6912 C * ' NCALDS, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
6913 C * NCALDS, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
6914  hef(j)=ehecc
6915  ENDIF
6916 C
6917  anndz=anndz+1
6918  eedz=eedz+hef(j)
6919  ptdz=ptdz+sqrt(pxf(j)**2+pyf(j)**2)
6920 C PUT NN-CMS HADRONS INTO /HKKEVT/
6921  istist=1
6922  IF(ibarf(j).EQ.500)istist=2
6923  CALL hkkfil(istist,mpdgha(nref(j)),1,0,
6924  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),22)
6925  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
6926  + (nhkk)
6927 C JMOHKK(1,NHKK)=MHKKSS(I)
6928  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
6929  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
6930  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
6931 
6932  40 CONTINUE
6933 C IF(NHAD.GT.0) THEN
6934 C JDAHKK(1,IMOHKK)=NHKKAU
6935 C JDAHKK(2,IMOHKK)=NHKK
6936 C ENDIF
6937  50 CONTINUE
6938 C----------------------------------------------------------------
6939 C
6940 C IPHKK=0
6941  RETURN
6942  1010 FORMAT (i6,i4,5i6,9e10.2)
6943  1020 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
6944  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
6945  END
6946 C
6947 C*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6948 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6949 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6950 C
6951  SUBROUTINE diqzzd(ECM,XPSQ1,XPSAQ1,XPSQ2,XPSAQ2,
6952  * ipsq1,ipsaq1,ipsq2,ipsaq2,irejsd)
6953  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6954  SAVE
6955 * define s-d chains (sea - sea diquark chains)
6956 * sq-sqsq and saq-saqsaq chains instead of q-aq and aq-q chains
6957  COMMON /zsea/zseaav,zseasu,anzsea
6958  common/popcck/pdbck,pdbse,pdbseu,
6959  * ijpock,irejck,ick4,ihad4,ick6,ihad6
6960  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
6961  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
6962  *isea43,isea63,irejao
6963 *KEEP,INTNEW.
6964  parameter(intmd=252)
6965  COMMON /intnez/ ndz,nzd
6966  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
6967 C-------------------
6968 *KEEP,DPAR.
6969 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6970 C ANAME = LITERAL NAME OF THE PARTICLE
6971 C AAM = PARTICLE MASS IN GEV
6972 C GA = DECAY WIDTH
6973 C TAU = LIFE TIME OF INSTABLE PARTICLES
6974 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6975 C IIBAR = BARYON NUMBER
6976 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6977 C
6978  CHARACTER*8 aname
6979  COMMON /dpar/ aname(210),am(210),ga(210),tau(210),ich(210),
6980  +ibar(210),k1(210),k2(210)
6981 C------------------
6982 *KEEP,ABRSD.
6983  COMMON /abrzd/ amcsd1(intmd),amcsd2(intmd),
6984  +gacsd1(intmd),gacsd2(intmd),
6985  +bgxsd1(intmd),bgysd1(intmd),bgzsd1(intmd),
6986  +bgxsd2(intmd),bgysd2(intmd),
6987  +bgzsd2(intmd), nchsd1(intmd),nchsd2(intmd),
6988  +ijcsd1(intmd),ijcsd2(intmd),
6989  +pqsda1(intmd,4),pqsda2(intmd,4),
6990  +pqsdb1(intmd,4),pqsdb2(intmd,4),
6991  +ipsq(intmd),itsq(intmd),itsq2(intmd),
6992  +ipsaq(intmd),itsaq(intmd),itsaq2(intmd)
6993  +,izdss(intmd)
6994 *KEND.
6995  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6996  common/seasu3/seasq
6997  COMMON /diqrej/idiqre(7),idvre(3),ivdre(3),idsre(3),isdre(3),
6998  *idzre(3),izdre(3),idiqrz(7)
6999  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
7000  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
7001  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
7002  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
7003  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
7004  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
7005 C COMMON /PCHARM/PCCCC
7006  parameter(ummm=0.3d0)
7007  parameter(smmm=0.5d0)
7008  parameter(cmmm=1.3d0)
7009  DATA pc/0.0001d0/
7010 *KEND.
7011 C----------
7012 C
7013  DATA inicha/0/
7014 C----------------------------------------------------------------------
7015 C Initialize Charm selection at soft chain ends
7016 C
7017  IF(inicha.EQ.0)THEN
7018  rx=8.
7019  x1=rx
7020  gm=2.140
7021  x2=ummm
7022  betoo=7.5d0
7023  ENDIF
7024  rx=8.
7025  x1=rx
7026  betcha=betoo+1.3-log10(ecm)
7027  pu=dbeta(x1,x2,betcha)
7028  x2=smmm
7029  ps=dbeta(x1,x2,betcha)
7030  x2=cmmm
7031  pc=dbeta(x1,x2,betcha)
7032 C PU1=PU/(2*PU+PS+PC)
7033 C PS1=PS/(2*PU+PS+PC)
7034  pc1=pc/(2*pu+ps+pc)
7035 C changed j.r.7.12.94
7036  pc=pc1
7037  pu1=pu/(2*pu+ps+pc)
7038  ps1=ps/(2*pu+ps+pc)
7039  IF(inicha.EQ.0)THEN
7040  inicha=1
7041  WRITE(6,4567)pc,betcha,pu1,ps1,seasq
7042  4567 FORMAT(' Charm chain ends DIQZZD: PC,BETCHA,PU,PS,SEASQ',5f10.5)
7043  ENDIF
7044 C----------------------------------------------------------------------
7045  IF(iphkk.GE.3)WRITE (6,'( A)') ' diqssd'
7046  irejsd=0
7047 * kinematics: is the mass of both chains big enough
7048 * to allow for fragmentation
7049 C IPSQQ2=1
7050 C RND=RNDM(V)
7051 C IF(RND.GT.0.62) IPSQQ2=2
7052 C IF(RND.LT.0.24) IPSQQ2=3
7053  ipsqq2=1.d0+rndm(v1)*(2.d0+2.d0*seasq)
7054  rr=rndm(v)
7055  IF(rr.LT.pc)ipsqq2=4
7056  isaqq2=-ipsqq2
7057  amsdq1=xpsq2*xpsq1*ecm**2
7058  amsdq2=xpsaq2*xpsaq1*ecm**2
7059  idiqrz(1)=idiqrz(1)+1
7060 C
7061  IF(ipsq2.EQ.3.AND.ipsqq2.EQ.3)THEN
7062  idiqrz(2)=idiqrz(2)+1
7063 C IF(AMSDQ2.LE.2.30.OR.AMSDQ1.LE.2.30) THEN
7064  IF(amsdq2.LE.6.6d0.OR.amsdq1.LE.6.6d0) THEN
7065  idiqrz(3)=idiqrz(3)+1
7066  idiqrz(2)=idiqrz(2)-1
7067  idiqrz(1)=idiqrz(1)-1
7068  irejsd=1
7069  RETURN
7070  ENDIF
7071  ELSEIF(ipsq2.EQ.3.OR.ipsqq2.EQ.3)THEN
7072  idiqrz(4)=idiqrz(4)+1
7073 C IF(AMSDQ2.LE.1.9.OR.AMSDQ1.LE.1.90) THEN
7074  IF(amsdq2.LE.5.8d0.OR.amsdq1.LE.5.80d0) THEN
7075  idiqrz(5)=idiqrz(5)+1
7076  idiqrz(4)=idiqrz(4)-1
7077  idiqrz(1)=idiqrz(1)-1
7078  irejsd=1
7079  RETURN
7080  ENDIF
7081  ELSEIF(((ipsq2.EQ.4).OR.(ipsqq2.EQ.4)).AND.
7082  * ((ipsq2.EQ.3).OR.(ipsqq2.EQ.3)))THEN
7083 C IF(AMDSQ2.LE.1.9.OR.AMDSQ1.LE.1.90) THEN
7084  IF(amsdq2.LE.30.8d0.OR.amsdq1.LE.30.80d0) THEN
7085  irejsd=1
7086  RETURN
7087  ENDIF
7088  ELSEIF(ipsq2.EQ.4.OR.ipsqq2.EQ.4)THEN
7089 C IF(AMSDQ2.LE.1.9.OR.AMSDQ1.LE.1.90) THEN
7090  IF(amsdq2.LE.25.8d0.OR.amsdq1.LE.25.80d0) THEN
7091  irejsd=1
7092  RETURN
7093  ENDIF
7094  ELSE
7095  idiqrz(6)=idiqrz(6)+1
7096 C IF(AMSDQ2.LE.1.50.OR.AMSDQ1.LE.1.50) THEN
7097  IF(amsdq2.LE.3.9d0.OR.amsdq1.LE.3.9d0) THEN
7098  idiqrz(7)=idiqrz(7)+1
7099  idiqrz(6)=idiqrz(6)-1
7100  idiqrz(1)=idiqrz(1)-1
7101  irejsd=1
7102  RETURN
7103  ENDIF
7104  ENDIF
7105  nzd=nzd+1
7106  IF(nzd.GE.intmd)THEN
7107  irejsd=1
7108  nzd=nzd-1
7109  RETURN
7110  ENDIF
7111 C WRITE(6,*)' DIQZZD:IDIQRZ(1-7),NZD ',(IDIQRZ(II),II=1,7),NZD
7112  nchsd1(nzd)=0
7113  nchsd2(nzd)=0
7114  izdss(nzd)=0
7115 C-------------------
7116 C kkevzd part
7117 C-------------------
7118  IF(iphkk.GE.3)WRITE (6,'( A,3I10)') ' kkevzd',nzd,
7119  * nchsd1(1),nchsd2(1)
7120  n=nzd
7121 C DO 10 N=1,NZD
7122 C---------------------------drop recombined chain pairs
7123  IF(nchsd1(n).EQ.99.AND.nchsd2(n).EQ.99)go to 10
7124 C
7125 C*** 4-MOMENTA OF projectile QUARK-DIQUARK PAIRS IN NN-CMS
7126 C
7127  prmomz=sqrt(ecm**2/4.-am(1)**2)
7128  psqpx=0.
7129  psqpy=0.
7130  psqpz=xpsq1*prmomz
7131  psqe=xpsq1*ecm/2.
7132  psdqpx=0.
7133  psdqpy=0.
7134  psdqpz=xpsaq1*prmomz
7135  psdqe=xpsaq1*ecm/2.
7136 C
7137 C*** 4-MOMENTA OF TARGET QUARK-DIQUARK PAIRS IN NN-CMS
7138 *
7139  tsqpx=0.
7140  tsqpy=0.
7141  tsqpz=-xpsq2*prmomz
7142  tsqe=xpsq2*ecm/2.
7143  tsaqpx=0.
7144  tsaqpy=0.
7145  tsaqpz=-xpsaq2*prmomz
7146  tsaqe=xpsaq2*ecm/2.
7147 C
7148 C*** LORENTZ PARAMETER FOR CMS OF BOTH (q-sqsq) and
7149 C (diq-saqsaq)-SYSTEM
7150 C FROM PROJECTILE AND TARGET, RESP.
7151 C
7152  pxxx=tsqpx + tsaqpx + psqpx + psdqpx
7153  pyyy=tsqpy + tsaqpy + psqpy + psdqpy
7154  pzzz=tsqpz + tsaqpz + psqpz + psdqpz
7155  eee =tsqe + tsaqe + psqe + psdqe
7156  pptoto=sqrt(pxxx**2+pyyy**2+pzzz**2)
7157  ammm=sqrt(abs((eee+pptoto)*(eee-pptoto)))
7158  gammm=eee/(ammm+1.e-4)
7159  bgggx=pxxx/(ammm+1.e-4)
7160  bgggy=pyyy/(ammm+1.e-4)
7161  bgggz=pzzz/(ammm+1.e-4)
7162 C
7163 C*** SAMPLE PARTON-PT VALUES / DETERMINE PARTON 4-MOMENTA AND CHAIN MAS
7164 C*** IN THE REST FRAME DEFINED ABOVE
7165 C
7166  xtsqcm=xpsq2
7167  xtsacm=xpsaq2
7168  xpsqcm=xpsq1
7169  xpsacm=xpsaq1
7170 C
7171 C*** SAMPLE PARTON-PT VALUES / DETERMINE PARTON 4-MOMENTA AND CHAIN MAS
7172 C*** IN THE REST FRAME DEFINED ABOVE
7173 C
7174  ptxsq1=0
7175  ptysq1=0
7176  ptxsa1=0
7177  ptysa1=0
7178  ptxsq2=0
7179  ptysq2=0
7180  ptxsa2=0
7181  ptysa2=0
7182  plq1 = xpsq1 *ecm/2.
7183  eq1 = xpsq1 *ecm/2.
7184  plaq1= xpsaq1*ecm/2.
7185  eaq1 = xpsaq1*ecm/2.
7186  plq2 =-xpsq2 *ecm/2.
7187  eq2 = xpsq2 *ecm/2.
7188  plaq2=-xpsaq2*ecm/2.
7189  eaq2 = xpsaq2*ecm/2.
7190  nselpt=1
7191  ikvala=0
7192  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVZD call selpt'
7193  CALL selpt( ptxsq1,ptysq1,plq1,
7194  + eq1,ptxsa1,ptysa1,plaq1,eaq1,
7195  + ptxsa2,ptysa2,plaq2,eaq2,
7196  + ptxsq2,ptysq2,plq2,eq2,
7197  + amch1,amch2,irejsd,ikvala,pttq1,ptta1,
7198  + pttq2,ptta2,nselpt)
7199 c WRITE(6,'(A,I5)') ' KKEVZD - IRSD13=',IRSD13
7200 c WRITE(6,'(A/5E12.4/4(4E12.4/),2E12.4/2I5/4E12.4)')
7201 c + ' SD: XPSQCM,XPSDCM,XTSQCM,XTSACM,AMMM,amch1,amch2 ',
7202 c + XPVQCM,XPVDCM,
7203 c + XTSQCM,XTSACM,AMMM, AMCH1,AMCH2
7204  IF (ipev.GE.6) WRITE(6,'(A/5X,5F12.5,I10)')
7205  + 'SD AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJSD ', ammm,gammm,bgggx,
7206  + bgggy,bgggz,irejsd
7207  IF (irejsd.EQ.1) THEN
7208  irsd13=irsd13 + 1
7209  IF(ipev.GE.2) THEN
7210  WRITE(6,'(A,I5)') ' KKEVZD - IRSD13=',irsd13
7211  WRITE(6,'(A/5E12.4/4(4E12.4/),2E12.4/2I5/4E12.4)')
7212  + ' VD: XPVQCM,XPVDCM,XTSQCM,XTSACM,AMMM ...', xpsqcm,xpsdcm,
7213  + xtsqcm,xtsacm,ammm, ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
7214  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
7215  + amch1,amch2,irejsd,ikvala,pttq1,ptta1
7216 
7217  ENDIF
7218  go to 11
7219  ENDIF
7220 C
7221 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
7222 C
7223  ptxch1=ptxsq1 + ptxsq2
7224  ptych1=ptysq1 + ptysq2
7225  ptzch1=plq1 + plq2
7226  ech1=eq1 + eq2
7227  ptxch2=ptxsa2 + ptxsa1
7228  ptych2=ptysa2 + ptysa1
7229  ptzch2=plaq2 + plaq1
7230  ech2=eaq2 + eaq1
7231 C WRITE(6,667)ECH1,ECH2,PTZCH1,PTZCH2
7232 C 667 FORMAT(' SD ECH1,ECH2,PTZCH1,PTZCH2: ',4F10.3)
7233 C
7234  IF (ipev.GE.6) WRITE(6,'(A,5F12.5,I10/A,5F12.5/A,5F12.5)')
7235  + ' SD: AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJSD ', ammm,gammm,bgggx,
7236  + bgggy,bgggz,irejsd, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
7237  + amch1,ptxch1,ptych1,ptzch1,ech1,
7238  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
7239  + ptzch2,ech2
7240 
7241 C
7242 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS OR OCTETT
7243 C OR DECUPLETT BARYONS
7244 C FIRST FOR CHAIN 1 (PROJ quark - tar sea-diquark)
7245 C
7246  CALL zobcma(ipsq2,ipsqq2,ipsq1, ijnch1,nnch1,
7247  + irejsd,amch1,amch1n,1)
7248 C*** MASS BELOW OCTETT BARYON MASS
7249  IF(irejsd.EQ.1) THEN
7250  irsd11=irsd11 + 1
7251  goto 11
7252  ENDIF
7253 C CORRECT KINEMATICS FOR CHAIN 1
7254 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
7255  IF(nnch1.NE.0)
7256  + CALL zormom(ammm,amch1,amch1n,amch2,
7257  + xpsq1,xpsaq1,xpsaq2,xpsq2,
7258  + ptxsq1,ptysq1,plq1,eq1,
7259  + ptxsa1,ptysa1,plaq1,eaq1,
7260  + ptxsa2,ptysa2,plaq2,eaq2,
7261  + ptxsq2,ptysq2,plq2,eq2,
7262  + ptxch1,ptych1,ptzch1,ech1, ptxch2,ptych2,ptzch2,ech2,
7263  + irejsd)
7264  IF(irejsd.EQ.1)THEN
7265  go to 11
7266  ENDIF
7267 C
7268  IF (ipev.GE.6) WRITE(6,'(A,5F12.5,I10/A,5F12.5/A,5F12.5)')
7269  + ' SD(2): AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJSD',ammm,gammm,bgggx,
7270  + bgggy,bgggz,irejsd, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
7271  + amch1,ptxch1,ptych1,ptzch1,ech1,
7272  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
7273  + ptzch2,ech2
7274 C
7275 C REPLACE SMALL MASS CHAINS BY octet or decuplet baryons
7276 C SECOND FOR CHAIN 2 (proj saquark - tar sadiquark)
7277 C
7278  CALL zobcma(ipsaq1,ipsaq2,isaqq2,
7279  + ijnch2,nnch2,irejsd,amch2,amch2n,2)
7280 c rejection of both s-s chains if mass of chain 2 too low
7281  IF(irejsd.EQ.1) THEN
7282  irsd12=irsd12 + 1
7283  IF(ipev.GE.2) THEN
7284  WRITE(6,1090) irsd12
7285  WRITE(6,1100) ipsaq1,ipsaq2,isaqq2,
7286  + ijnch2,nnch2,irejsd,
7287  + xpsq1,xpsaq1,xpsqcm,xtsacm, xpsq2,xpsaq2
7288  + ,xtsqcm,xtsacm, amch2,amch2n
7289  1090 FORMAT(' KKEVZD - IRSD12=',i5)
7290  1100 FORMAT(' SD - 1100', 6i5/2(4e12.4/),2e12.4)
7291  ENDIF
7292  goto 11
7293  ENDIF
7294 C if AMCH2 changed in COBCMA/COMCMA
7295 C ZORVAL corrects chain kinematics
7296 C according to 2-body kinem.
7297 C with fixed masses
7298  IF(nnch2.NE.0) THEN
7299  amch2=amch2n
7300  iori=1
7301  CALL zorval(ammm,irejsd,amch1,amch2, ptxch1,ptych1,ptzch1,ech1,
7302  + ptxch2,ptych2,ptzch2,ech2,iori)
7303 C
7304  IF(ipev.GE.6) THEN
7305  WRITE(6,'(A/3(1PE15.4),3I5)')
7306  + ' SD - CALL ZORVAL: AMMM,AMCH1,AMCH2,NNCH1,NNCH2,IREJSD',
7307  + ammm, amch1, amch2, nnch1, nnch2, irejsd
7308  WRITE(6,1050) ammm,gammm,bgggx,bgggy,bgggz,irejsd, amch1,
7309  + ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
7310  1050 FORMAT (' SD: AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJSD ',5f12.5,i10/
7311  + ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
7312  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
7313  ENDIF
7314  IF(irejsd.EQ.1) THEN
7315 * AMCH1N + AMCH2N > AMMM - 0.2
7316 * reject event
7317  irsd14=irsd14+1
7318  goto 11
7319  ENDIF
7320  ENDIF
7321 C
7322 C TRANSFORM BOTH CHAINS BACK INTO NN CMS
7323 C
7324 C 4-MOMENTA OF CHAINS
7325  qtxch1=ptxch1
7326  qtych1=ptych1
7327  qtzch1=ptzch1
7328  qech1=ech1
7329 
7330  qtxch2=ptxch2
7331  qtych2=ptych2
7332  qtzch2=ptzch2
7333  qech2=ech2
7334 C WRITE(6,887)QECH1,QECH2,QTZCH1,QTZCH2,AMCH1,AMCH2
7335 C 887 FORMAT( ' SD: QECH1,QECH2,QTZCH1,QTZCH2,AMCH1,AMCH2 ',6F10.2)
7336 
7337 C PARTONS AT ENDS OF CHAIN 1
7338  pqsda1(n,1)=ptxsq1
7339  pqsda1(n,2)=ptysq1
7340  pqsda1(n,3)=plq1
7341  pqsda1(n,4)=eq1
7342 
7343  pqsda2(n,1)=ptxsq2
7344  pqsda2(n,2)=ptysq2
7345  pqsda2(n,3)=plq2
7346  pqsda2(n,4)=eq2
7347 
7348 C PARTONS AT ENDS OF CHAIN 2
7349  pqsdb2(n,1)=ptxsa2
7350  pqsdb2(n,2)=ptysa2
7351  pqsdb2(n,3)=plaq2
7352  pqsdb2(n,4)=eaq2
7353 
7354  pqsdb1(n,1)=ptxsa1
7355  pqsdb1(n,2)=ptysa1
7356  pqsdb1(n,3)=plaq1
7357  pqsdb1(n,4)=eaq1
7358 
7359 C
7360 
7361 C
7362 C
7363 C NOW WE HAVE AN ACCEPTABLE SEA--VALENCE EVENT
7364 * sea diquark pair!
7365 C AND PUT IT INTO THE HISTOGRAM
7366 C
7367  ipsq(n)=ipsq1
7368  itsq(n)=ipsq2
7369  itsq2(n)=ipsqq2
7370  ipsaq(n)=ipsaq1
7371  itsaq(n)=ipsaq2
7372  itsaq2(n)=isaqq2
7373  amcsd1(n)=amch1
7374  amcsd2(n)=amch2
7375  gacsd1(n)=qech1/amch1
7376  bgxsd1(n)=qtxch1/amch1
7377  bgysd1(n)=qtych1/amch1
7378  bgzsd1(n)=qtzch1/amch1
7379  gacsd2(n)=qech2/amch2
7380  bgxsd2(n)=qtxch2/amch2
7381  bgysd2(n)=qtych2/amch2
7382  bgzsd2(n)=qtzch2/amch2
7383  nchsd1(n)=nnch1
7384  nchsd2(n)=nnch2
7385  ijcsd1(n)=ijnch1
7386  ijcsd2(n)=ijnch2
7387  IF (ipev.GE.2) WRITE(6,'(A/I10,4F12.7,5I5/10X,4F12.6/10X,6F12.6,
7388  +4I5/8F15.5/8F15.5/2I5)') ' SD / FINAL PRINT',n
7389  go to 20
7390 C*** TREATMENT OF REJECTED SEA-SEA INTERACTIONS
7391  11 CONTINUE
7392  nchsd1(n)=99
7393  nchsd2(n)=99
7394 C 28.10.96
7395  nzd=nzd-1
7396  IF(nzd.LT.0)THEN
7397  nzd=nzd+1
7398  ENDIF
7399  issqq=ipsq2
7400  jssqq=ipsqq2
7401  IF(issqq.EQ.3.AND.jssqq.EQ.3)THEN
7402  izdre(3)=izdre(3)+1
7403  ELSEIF(issqq.EQ.3.OR.jssqq.EQ.3)THEN
7404  izdre(2)=izdre(2)+1
7405  ELSE
7406  izdre(1)=izdre(1)+1
7407  ENDIF
7408  20 CONTINUE
7409  10 CONTINUE
7410 C WRITE(6,*)' DIQZZD: IZDRE(1-3),NZD ',(IZDRE(II),II=1,3),NZD
7411  RETURN
7412  END
7413 C
7414 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7415 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7416 C ---------------------------------------------------------------
7417 C ---------------------------------------------------------------
7418 C ---------------------------------------------------------------
7419 
7420 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7421 C
7422  SUBROUTINE hadrzd
7423  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7424  SAVE
7425 C-------------------------
7426 C
7427 C hadronize sea diquark - valence CHAINS
7428 C
7429 C ADD GENERATED HADRONS TO /ALLPAR/
7430 C STARTING AT (NAUX + 1)
7431 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
7432 C
7433 C---------------------------------------------------------
7434  COMMON /zsea/zseaav,zseasu,anzsea
7435  common/popcck/pdbck,pdbse,pdbseu,
7436  * ijpock,irejck,ick4,ihad4,ick6,ihad6
7437  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
7438  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
7439  *isea43,isea63,irejao
7440  parameter(intmd=252)
7441  COMMON /intnez/ ndz,nzd
7442 C-------------------
7443 *KEEP,ABRSD.
7444  COMMON /abrzd/ amcsd1(intmd),amcsd2(intmd),
7445  +gacsd1(intmd),gacsd2(intmd),
7446  +bgxsd1(intmd),bgysd1(intmd),bgzsd1(intmd),
7447  +bgxsd2(intmd),bgysd2(intmd),
7448  +bgzsd2(intmd), nchsd1(intmd),nchsd2(intmd),
7449  +ijcsd1(intmd),ijcsd2(intmd),
7450  +pqsda1(intmd,4),pqsda2(intmd,4),
7451  +pqsdb1(intmd,4),pqsdb2(intmd,4),
7452  +ipsq(intmd),itsq(intmd),itsq2(intmd),
7453  +ipsaq(intmd),itsaq(intmd),itsaq2(intmd)
7454  +,izdss(intmd)
7455 *KEEP,INTMX.
7456  parameter(intmx=2488)
7457 *KEEP,IFROTO.
7458  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
7459  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
7460  +jhkknt
7461  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
7462  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
7463  & mhkkhh(intmx),
7464  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
7465 *KEEP,DIQI.
7466 C COMMON /DIQI/ IPVQ(248),IPPV1(248),IPPV2(248), ITVQ(248),ITTV1
7467 C +(248),ITTV2(248), IPSQ(INTMX),IPSQ2(INTMX),
7468 C +IPSAQ(INTMX),IPSAQ2(INTMX),ITSQ(INTMX),ITSQ2(INTMX),
7469 C +ITSAQ(INTMX),ITSAQ2(INTMX),KKPROJ(248),KKTARG(248)
7470 *KEEP,DXQX.
7471 C INCLUDE (XQXQ)
7472 * NOTE: INTMX set via INCLUDE(INTMX)
7473  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
7474  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
7475  * ,xpsu(248),xtsu(248)
7476  * ,xpsut(248),xtsut(248)
7477 *KEEP,INTNEW.
7478 C COMMON /INTNEW/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
7479 C +IXPV,IXPS,IXTV,IXTS, INTVV1(248),
7480 C +INTVV2(248),INTSV1(248),INTSV2(248), INTVS1(248),INTVS2(248),
7481 C +INTSS1(INTMX),INTSS2(INTMX),
7482 C +INTDV1(248),INTDV2(248),INTVD1(248),INTVD2(248),
7483 C +INTDS1(INTMD),INTDS2(INTMD),INTSD1(INTMD),INTSD2(INTMD)
7484 
7485 C /INTNEW/
7486 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
7487 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
7488 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
7489 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
7490 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
7491 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
7492 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
7493 C FROM PROJECTILE/TARGET NUCLEI
7494 C-------------------
7495 *KEEP,LOZUO.
7496  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
7497  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
7498  +intlo(intmx),inloss(intmx)
7499 C /LOZUO/
7500 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
7501 C REJECTED IN KKEVT
7502 C------------------
7503 *KEEP,HKKEVT.
7504 c INCLUDE (HKKEVT)
7505  parameter(nmxhkk= 89998)
7506 c PARAMETER (NMXHKK=25000)
7507  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
7508  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
7509  +(4,nmxhkk)
7510 C
7511 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
7512 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
7513 C THE POSITIONS OF THE PROJECTILE NUCLEONS
7514 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
7515 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
7516 C COMPLETELY CONSISTENT. THE TIMES IN THE
7517 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
7518 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
7519 C
7520 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
7521 C
7522 C NMXHKK: maximum numbers of entries (partons/particles) that can be
7523 C stored in the commonblock.
7524 C
7525 C NHKK: the actual number of entries stored in current event. These are
7526 C found in the first NHKK positions of the respective arrays below.
7527 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
7528 C entry.
7529 C
7530 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
7531 C = 0 : null entry.
7532 C = 1 : an existing entry, which has not decayed or fragmented.
7533 C This is the main class of entries which represents the
7534 C "final state" given by the generator.
7535 C = 2 : an entry which has decayed or fragmented and therefore
7536 C is not appearing in the final state, but is retained for
7537 C event history information.
7538 C = 3 : a documentation line, defined separately from the event
7539 C history. (incoming reacting
7540 C particles, etc.)
7541 C = 4 - 10 : undefined, but reserved for future standards.
7542 C = 11 - 20 : at the disposal of each model builder for constructs
7543 C specific to his program, but equivalent to a null line in the
7544 C context of any other program. One example is the cone defining
7545 C vector of HERWIG, another cluster or event axes of the JETSET
7546 C analysis routines.
7547 C = 21 - : at the disposal of users, in particular for event tracking
7548 C in the detector.
7549 C
7550 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
7551 C standard.
7552 C
7553 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
7554 C The value is 0 for initial entries.
7555 C
7556 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
7557 C one mother exist, in which case the value 0 is used. In cluster
7558 C fragmentation models, the two mothers would correspond to the q
7559 C and qbar which join to form a cluster. In string fragmentation,
7560 C the two mothers of a particle produced in the fragmentation would
7561 C be the two endpoints of the string (with the range in between
7562 C implied).
7563 C
7564 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
7565 C entry has not decayed, this is 0.
7566 C
7567 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
7568 C entry has not decayed, this is 0. It is assumed that the daughters
7569 C of a particle (or cluster or string) are stored sequentially, so
7570 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
7571 C daughters. Even in cases where only one daughter is defined (e.g.
7572 C K0 -> K0S) both values should be defined, to make for a uniform
7573 C approach in terms of loop constructions.
7574 C
7575 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
7576 C
7577 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
7578 C
7579 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
7580 C
7581 C PHKK(4,IHKK) : energy, in GeV.
7582 C
7583 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
7584 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
7585 C
7586 C VHKK(1,IHKK) : production vertex x position, in mm.
7587 C
7588 C VHKK(2,IHKK) : production vertex y position, in mm.
7589 C
7590 C VHKK(3,IHKK) : production vertex z position, in mm.
7591 C
7592 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
7593 C********************************************************************
7594 *KEEP,DFINPA.
7595  CHARACTER*8 anf
7596  parameter(nfimax=249)
7597  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
7598  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
7599  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
7600  * istath(nfimax)
7601 *KEEP,DPRIN.
7602  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7603 *KEEP,PROJK.
7604  COMMON /projk/ iprojk
7605 *KEND.
7606  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
7607 C modified DPMJET
7608  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
7609  * anndv,annvd,annds,annsd,
7610  * annhh,annzz,
7611  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
7612  * pthh,ptzz,
7613  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
7614  * eehh,eezz
7615  * ,anndi,ptdi,eedi
7616  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
7617  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
7618  * acouzz,acouhh,acouds,acousd,
7619  * acoudz,acouzd,acoudi,
7620  * acoudv,acouvd,acoucc
7621  COMMON /diqsum/ndvuu,ndvus,ndvss,nvduu,nvdus,nvdss,
7622  * ndsuu,ndsus,ndsss,nsduu,nsdus,nsdss,
7623  * ndzuu,ndzus,ndzss,nzduu,nzdus,nzdss
7624  * ,nadvuu,nadvus,nadvss,navduu,navdus,navdss,
7625  * nadsuu,nadsus,nadsss,nasduu,nasdus,nasdss,
7626  * nadzuu,nadzus,nadzss,nazduu,nazdus,nazdss
7627 C---------------------
7628 *KEEP,INTNEW.
7629  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
7630  +ixpv,ixps,ixtv,ixts, intvv1(248),
7631  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
7632  +intss1(intmx),intss2(intmx),
7633  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
7634  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
7635 
7636  dimension poj(4),pat(4)
7637  DATA ncalsd /0/
7638 C IPHKK=3
7639 C-----------------------------------------------------------------------
7640  IF(iphkk.GE.3)WRITE (6,'( A,4I10)') ' hadrzd',ndz,nzd,
7641  * nchsd1(1),nchsd2(1)
7642  ncalsd=ncalsd+1
7643  DO 50 i=1,nzd
7644 C-----------------------drop recombined chain pairs
7645  IF(nchsd1(i).EQ.99.AND.nchsd2(i).EQ.99) go to 50
7646  is1=i
7647  is2=i
7648 C
7649 C IF (IPCO.GE.6) WRITE (6,1000) IPSQ(IS1),IPSAQ(IS1),ITVQ(IS2),
7650 C + ITTV1(IS2),ITTV2(IS2), AMCSD1(I),AMCSD2(I),GACSD1(I),GACSD2(I),
7651 C + BGXSD1(I),BGYSD1(I),BGZSD1(I), BGXSD2(I),BGYSD2(I),BGZSD2(I),
7652 C + NCHSD1(I),NCHSD2(I),IJCSD1(I),IJCSD2(I), PQSDA1(I,4),PQSDA2
7653 C + (I,4),PQSDB1(I,4),PQSDB2(I,4)
7654  1000 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
7655 C
7656 C++++++++++++++++++++++++++++++ CHAIN 1: quark-diquark +++++++++++
7657  ifb1=ipsq(is1)
7658  ifb2=itsq(is2)
7659  ifb3=itsq2(is2)
7660  DO 10 j=1,4
7661  poj(j)=pqsda1(i,j)
7662  pat(j)=pqsda2(i,j)
7663  10 CONTINUE
7664  IF((nchsd1(i).NE.0.OR.nchsd2(i).NE.0).AND.ip.NE.1)
7665  & CALL saptre(amcsd1(i),gacsd1(i),bgxsd1(i),bgysd1(i),bgzsd1(i),
7666  & amcsd2(i),gacsd2(i),bgxsd2(i),bgysd2(i),bgzsd2(i))
7667 C----------------------------------------------------------------
7668 C----------------------------------------------------------------
7669 C WRITE (6,1244) POJ,PAT
7670 C1244 FORMAT (' V-D QUARK-DIQUARK POJ,PAT ',8E12.3)
7671 * IF(AMCSD1(I).LT.1.6)THEN
7672 * IF(NCHSD1(I).EQ.0)THEN
7673 * WRITE(6,'(A,F10.2,5I5)')' HADRZD AMCDS1(I),NCHSD1(I),I ',
7674 * + AMCSD1(I),NCHSD1(I),IJCSD1(I),I,IS1,IS2
7675 * RETURN
7676 * ENDIF
7677 * ENDIF
7678 C------------------------------------------------------------------
7679 C check bookkeeping
7680 C-----------------------------------------------------------------
7681 C I= number of valence chain
7682 C Target Nr itt = IFROVT(INTSV2(I))
7683 C No of Glauber sea q at Target JITT=JTSHS(ITT)
7684  IF(intsv2(i).GT.0)THEN
7685  ittt = ifrovt(intsv2(i))
7686  jitt=jtshs(ittt)
7687  ELSEIF(intsv2(i).EQ.0)THEN
7688  jitt=0
7689  ENDIF
7690 C IF(NCHSV1(I).EQ.0)THEN
7691 C WRITE(6,'(A,3I5)')'HADRSV: I,ITTT,JITT ',
7692 C * I,ITTT,JITT
7693 C ENDIF
7694 C------------------------------------------------------------------
7695 C check bookkeeping
7696 C-----------------------------------------------------------------
7697  IF(ifb2.LE.2.AND.ifb3.LE.2)THEN
7698  nzduu=nzduu+1
7699  ELSEIF((ifb2.EQ.3.AND.ifb3.LE.2).OR.
7700  * (ifb3.EQ.3.AND.ifb2.LE.2))THEN
7701  nzdus=nzdus+1
7702  ELSEIF(ifb2.EQ.3.AND.ifb3.EQ.3)THEN
7703  nzdss=nzdss+1
7704  ENDIF
7705  IF((nchsd1(i).NE.0))
7706  * CALL hadjet(nhad,amcsd1(i),poj,pat,gacsd1(i),bgxsd1(i), bgysd1
7707  + (i),bgzsd1(i),ifb1,ifb2,ifb3,ifb4, ijcsd1(i),ijcsd1(i),4,nchsd1
7708  + (i),17)
7709 C-------------------------------------------------------------------
7710  aack=float(ick4)/float(ick4+ihad4+1)
7711  IF((nchsd1(i).EQ.0))THEN
7712  zseawu=rndm(bb)*2.d0*zseaav
7713  rseack=float(jitt)*pdbse +zseawu*pdbseu
7714  IF(ipco.GE.1)WRITE(6,'(2A,I5,2F10.3)')'HADJSE JITT,',
7715  * 'RSEACK,PDBSE 2 dpmdiqqq ',
7716  + jitt,rseack,pdbse
7717  irejss=5
7718  IF(rndm(v).LE.rseack)THEN
7719  irejss=2
7720  IF(amcsd1(i).GT.2.3d0)THEN
7721  irejss=0
7722  CALL hadjse(nhad,amcsd1(i),poj,pat,gacsd1(i),bgxsd1(i),
7723  * bgysd1
7724  + (i),bgzsd1(i),ifb1,ifb2,ifb3,ifb4, ijcsd1(i),ijcsd1(i),4,
7725  * nchsd1
7726  + (i),3,irejss,iissqq)
7727  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JITT,',
7728  * 'RSEACK,IREJSS 2 dpmdiqqq ',
7729  + jitt,rseack,irejss
7730  ENDIF
7731  IF(irejss.GE.1)THEN
7732  IF(irejss.EQ.1)irejse=irejse+1
7733  IF(irejss.EQ.3)irejs3=irejs3+1
7734  IF(irejss.EQ.2)irejs0=irejs0+1
7735  CALL hadjet(nhad,amcsd1(i),poj,pat,gacsd1(i),bgxsd1(i), bgysd1
7736  + (i),bgzsd1(i),ifb1,ifb2,ifb3,ifb4, ijcsd1(i),ijcsd1(i),4,nchsd1
7737  + (i),17)
7738  ihad4=ihad4+1
7739  ENDIF
7740  IF(irejss.EQ.0)THEN
7741  IF(iissqq.EQ.3)THEN
7742  ise43=ise43+1
7743  ELSE
7744  ise4=ise4+1
7745  ENDIF
7746  ENDIF
7747  ELSE
7748  CALL hadjet(nhad,amcsd1(i),poj,pat,gacsd1(i),bgxsd1(i), bgysd1
7749  + (i),bgzsd1(i),ifb1,ifb2,ifb3,ifb4, ijcsd1(i),ijcsd1(i),4,nchsd1
7750  + (i),17)
7751  ihad4=ihad4+1
7752  ENDIF
7753  ENDIF
7754 C-------------------------------------------------------------------
7755  acouzd=acouzd+1
7756  nhkkau=nhkk+1
7757  DO 20 j=1,nhad
7758  IF (nhkk.EQ.nmxhkk) THEN
7759  WRITE (6,'(A,2I5/A)') .EQ.' HADRZD: NHKKNMXHKK ',nhkk,nmxhkk
7760  RETURN
7761  ENDIF
7762 C NHKK=NHKK+1
7763  IF (nhkk.EQ.nmxhkk)THEN
7764  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
7765  RETURN
7766  ENDIF
7767 C
7768  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
7769  IF (abs(ehecc-hef(j)).GT.0.001) THEN
7770 C WRITE(6,'(2A/3I5,3E15.6)')
7771 C & ' HADRZD / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
7772 C * ' NCALSD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
7773 C * NCALSD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
7774  hef(j)=ehecc
7775  ENDIF
7776  annzd=annzd+1
7777  eezd=eezd+hef(j)
7778  ptzd=ptzd+sqrt(pxf(j)**2+pyf(j)**2)
7779 C PUT NN-CMS HADRONS INTO /HKKEVT/
7780  istist=1
7781  IF(ibarf(j).EQ.500)istist=2
7782  CALL hkkfil(istist,mpdgha(nref(j)),1,0,
7783  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),23)
7784  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
7785  + (nhkk)
7786 C JMOHKK(1,NHKK)=MHKKSS(I)-3
7787  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
7788  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
7789  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
7790 
7791  20 CONTINUE
7792 C IF(NHAD.GT.0) THEN
7793 C JDAHKK(1,IMOHKK)=NHKKAU
7794 C JDAHKK(2,IMOHKK)=NHKK
7795 C ENDIF
7796 C+++++++++++++++++++++++++++++ CHAIN 2: aquark - adiquark +++++++++
7797  ifb1=ipsaq(is1)
7798  ifb2=itsaq(is2)
7799  ifb3=itsaq2(is2)
7800  ifb1=iabs(ifb1)+6
7801  ifb2=iabs(ifb2)+6
7802  ifb3=iabs(ifb3)+6
7803  DO 30 j=1,4
7804  poj(j)=pqsdb2(i,j)
7805  pat(j)=pqsdb1(i,j)
7806  30 CONTINUE
7807 C
7808 * IF(AMCSD2(I).LT.1.6)THEN
7809 * IF(NCHSD2(I).EQ.0)THEN
7810 * WRITE(6,'(A,F10.2,5I5)')' HADRZD AMCSD2(I),NCHSD2(I),I ',
7811 * + AMCSD2(I),NCHSD2(I),IJCSD2(I),I,IS1,IS2
7812 * RETURN
7813 * ENDIF
7814 * ENDIF
7815 C------------------------------------------------------------------
7816 C check bookkeeping
7817 C-----------------------------------------------------------------
7818 C I= number of valence chain
7819 C Target Nr itt = IFROVT(INTSV2(I))
7820 C No of Glauber sea q at Target JITT=JTSHS(ITT)
7821  IF(intsv2(i).GT.0)THEN
7822  ittt = ifrovt(intsv2(i))
7823  jitt=jtshs(ittt)
7824  ELSEIF(intsv2(i).EQ.0)THEN
7825  jitt=0
7826  ENDIF
7827 C IF(NCHSV1(I).EQ.0)THEN
7828 C WRITE(6,'(A,3I5)')'HADRSV: I,ITTT,JITT ',
7829 C * I,ITTT,JITT
7830 C ENDIF
7831 C------------------------------------------------------------------
7832 C check bookkeeping
7833 C-----------------------------------------------------------------
7834  IF(ifb2.LE.8.AND.ifb3.LE.8)THEN
7835  nazduu=nazduu+1
7836  ELSEIF((ifb2.EQ.9.AND.ifb3.LE.8).OR.
7837  * (ifb3.EQ.9.AND.ifb2.LE.8))THEN
7838  nazdus=nazdus+1
7839  ELSEIF(ifb2.EQ.9.AND.ifb3.EQ.9)THEN
7840  nazdss=nazdss+1
7841  ENDIF
7842  IF((nchsd2(i).NE.0))
7843  * CALL hadjet(nhad,amcsd2(i),poj,pat,gacsd2(i),bgxsd2(i), bgysd2
7844  + (i),bgzsd2(i),ifb1,ifb2,ifb3,ifb4, ijcsd2(i),ijcsd2(i),4,nchsd2
7845  + (i),18)
7846 C----------------------------------------------------------------------
7847  IF((nchsd1(i).EQ.0))THEN
7848  zseawu=rndm(bb)*2.d0*zseaav
7849  rseack=float(jitt)*pdbse +zseawu*pdbseu
7850  IF(ipco.GE.1)WRITE(6,'(2A,I5,2F10.3)')'HADJSE JITT,',
7851  * 'RSEACK,PDBSE ',
7852  + jitt,rseack,pdbse
7853  irejss=5
7854  IF(rndm(v).LE.rseack)THEN
7855  irejss=2
7856  IF(amcsd2(i).GT.2.3d0)THEN
7857  irejss=0
7858  CALL hadjase(nhad,amcsd2(i),poj,pat,gacsd2(i),bgxsd2(i),
7859  * bgysd2
7860  + (i),bgzsd2(i),ifb1,ifb2,ifb3,ifb4, ijcsd2(i),ijcsd2(i),4,
7861  * nchsd2
7862  + (i),3,irejss,iissqq)
7863  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JITT,',
7864  * 'RSEACK,IREJSS ',
7865  + jitt,rseack,irejss
7866  ENDIF
7867  IF(irejss.GE.1)THEN
7868  IF(irejss.EQ.1)irejsa=irejsa+1
7869  IF(irejss.EQ.3)ireja3=ireja3+1
7870  IF(irejss.EQ.2)ireja0=ireja0+1
7871  CALL hadjet(nhad,amcsd2(i),poj,pat,gacsd2(i),bgxsd2(i), bgysd2
7872  + (i),bgzsd2(i),ifb1,ifb2,ifb3,ifb4, ijcsd2(i),ijcsd2(i),4,nchsd2
7873  + (i),18)
7874  ihada4=ihada4+1
7875  ENDIF
7876  IF(irejss.EQ.0)THEN
7877  IF(iissqq.EQ.3)THEN
7878  isea43=isea43+1
7879  ELSE
7880  isea4=isea4+1
7881  ENDIF
7882  ENDIF
7883  ELSE
7884  CALL hadjet(nhad,amcsd2(i),poj,pat,gacsd2(i),bgxsd2(i), bgysd2
7885  + (i),bgzsd2(i),ifb1,ifb2,ifb3,ifb4, ijcsd2(i),ijcsd2(i),4,nchsd2
7886  + (i),18)
7887  ihada4=ihada4+1
7888  ENDIF
7889  ENDIF
7890 C----------------------------------------------------------------------
7891 C ADD HADRONS/RESONANCES INTO
7892 C COMMON /ALLPAR/ STARTING AT NAUX
7893  nhkkau=nhkk+1
7894  DO 40 j=1,nhad
7895  IF (nhkk.EQ.nmxhkk) THEN
7896  WRITE (6,'(A,2I5/A)') .EQ.' HADRZD: NHKKNMXHKK ', nhkk,
7897  + nmxhkk
7898  RETURN
7899  ENDIF
7900 C NHKK=NHKK+1
7901  IF (nhkk.EQ.nmxhkk)THEN
7902  WRITE (6,'(A,2I5)').EQ.' XKSAMP:NHKKNMXHKK ',nhkk,nmxhkk
7903  RETURN
7904  ENDIF
7905 C
7906  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
7907  IF (abs(ehecc-hef(j)).GT.0.001) THEN
7908 C WRITE(6,'(2A/3I5,3E15.6)')
7909 C & ' HADRZD / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
7910 C * ' NCALSD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
7911 C * NCALSD, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
7912  hef(j)=ehecc
7913  ENDIF
7914  annzd=annzd+1
7915  eezd=eezd+hef(j)
7916  ptzd=ptzd+sqrt(pxf(j)**2+pyf(j)**2)
7917 C PUT NN-CMS HADRONS INTO /HKKEVT/
7918  istist=1
7919  IF(ibarf(j).EQ.500)istist=2
7920  CALL hkkfil(istist,mpdgha(nref(j)),1,0,
7921  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),24)
7922  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
7923  + (nhkk)
7924 C JMOHKK(1,NHKK)=MHKKSS(I)
7925  IF (iphkk.GE.2) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
7926  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
7927  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
7928 
7929  40 CONTINUE
7930 C IF(NHAD.GT.0) THEN
7931 C JDAHKK(1,IMOHKK)=NHKKAU
7932 C JDAHKK(2,IMOHKK)=NHKK
7933 C ENDIF
7934  50 CONTINUE
7935 C----------------------------------------------------------------
7936 C
7937 C IPHKK=0
7938  RETURN
7939  1010 FORMAT (i6,i4,5i6,9e10.2)
7940  1020 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
7941  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
7942  END
7943 C ---------------------------------------------------------------
7944 C ---------------------------------------------------------------
7945 C ---------------------------------------------------------------
7946 C
7947  SUBROUTINE zobcma(IF1,IF2,IF3,IJNCH,NNCH,IREJ,AMCH,AMCHN,IKET)
7948  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7949  SAVE
7950 C
7951 C REPLACE SMALL MASS BARYON CHAINS (AMCH)
7952 C BY OCTETT OR DECUPLETT BARYONS
7953 C
7954 C MASS CORRECTED FOR NNCH.NE.0
7955 C
7956 C IREJ=1: CHAIN GENERATION NOT ALLOWED BECAUSE OF TOO SMALL MASS
7957 C START FROM THE BEGINNING IN HAEVT
7958 C
7959 *KEEP,DPAR.
7960 C /DPAR/ CONTAINS PARTICLE PROPERTIES
7961 C ANAME = LITERAL NAME OF THE PARTICLE
7962 C AAM = PARTICLE MASS IN GEV
7963 C GA = DECAY WIDTH
7964 C TAU = LIFE TIME OF INSTABLE PARTICLES
7965 C IICH = ELECTRIC CHARGE OF THE PARTICLE
7966 C IIBAR = BARYON NUMBER
7967 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
7968 C
7969  CHARACTER*8 aname
7970  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
7971  +iibar(210),k1(210),k2(210)
7972 C------------------
7973  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
7974 C------------------
7975 *KEEP,DPRIN.
7976  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7977 *KEEP,KETMAS.
7978  COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
7979 *KEND.
7980 C----------------
7981  CALL dbklas(if1,if2,if3,ib8,ibb10)
7982 C
7983  IF (ipev.GE.6)WRITE(6,1000)if1,if2,if3,ib8,ibb10
7984  1000 FORMAT (' COBCMA: IPQ,ITTQ1,ITTQ2,IB8,IBB10 ',5i5)
7985 C
7986  am81=aam(ib8)
7987  am101=aam(ibb10)
7988  am8(iket)=am81
7989  am10(iket)=am101
7990  ib88(iket)=ib8
7991  ib1010(iket)=ibb10
7992  nnch=0
7993  ijnch=0
7994  irej=0
7995  amff1=am101+0.3
7996 C
7997  IF(amch.LT.am81) THEN
7998  irej=1
7999  ELSEIF (amch.LT.am101)THEN
8000 C PRODUCE OKTETT BARYON
8001 C CORRECT KINEMATICS
8002  ijnch=ib8
8003  nnch=-1
8004  amchn=am81
8005  ELSEIF(amch.LT.amff1) THEN
8006 C PRODUCE DECUPLETT BARYON
8007 C CORRECT KINEMATICS
8008  amchn=am101
8009  ijnch=ibb10
8010  nnch=1
8011  ELSE
8012  amchn=amch
8013  ENDIF
8014 C NO CORRECTIONS BUT DO CHAIN 2
8015  IF(ipev.GE.6) THEN
8016  WRITE(6,1010) amch,amchn,am81,am101
8017  WRITE(6,1020) if1,if2,if3,ib8,ibb10,ijnch,nnch,irej
8018  1010 FORMAT(' COBCMA: AMCH,AMCHN,AM81,AM101', 4f13.4)
8019  1020 FORMAT(' COBCMA: IF1,IF2,IF3,IB8,IBB10,IJNCH,NNCH,IREJ',8i4)
8020  ENDIF
8021  RETURN
8022  END
8023 *CMZ : 1.00/00 27/11/91 17.09.37 by H.-J. M¶hring
8024 *-- Author :
8025 C
8026 C++++++++++++++++++++++++++++++++++++++
8027 C
8028  SUBROUTINE zomcma(IFQ,IFAQ,IJNCH,NNCH,IREJ,AMCH,AMCHN)
8029  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8030  SAVE
8031 C
8032 C REPLACE SMALL MASS MESON CHAINS BY PSEUDOSCALAR OR VECTOR MESONS
8033 C
8034 C
8035 *KEEP,DPAR.
8036 C /DPAR/ CONTAINS PARTICLE PROPERTIES
8037 C ANAME = LITERAL NAME OF THE PARTICLE
8038 C AAM = PARTICLE MASS IN GEV
8039 C GA = DECAY WIDTH
8040 C TAU = LIFE TIME OF INSTABLE PARTICLES
8041 C IICH = ELECTRIC CHARGE OF THE PARTICLE
8042 C IIBAR = BARYON NUMBER
8043 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
8044 C
8045  CHARACTER*8 aname
8046  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
8047  +iibar(210),k1(210),k2(210)
8048 C------------------
8049 C------------------
8050 *KEEP,INPDAT.
8051  COMMON /inpdat/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
8052  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
8053 *KEEP,DPRIN.
8054  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8055 *KEND.
8056  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
8057 C------------------------
8058  iifaq=iabs(ifaq)
8059  ifps=imps(iifaq,ifq)
8060  ifv=imve(iifaq,ifq)
8061  IF (ipev.GE.6)WRITE (6,1000)iifaq,ifq,ifps,ifv
8062  1000 FORMAT (' COMCMA',5x,' IIPPAQ,ITQ,IFPS,IFV ',4i5)
8063  amps=aam(ifps)
8064  amv=aam(ifv)
8065  nnch=0
8066  ijnch=0
8067  irej=0
8068  amff=amv+0.3
8069  IF(ipev.GE.6) WRITE(6,1010) amch,amps,amv,ifps,ifv
8070  1010 FORMAT(' AMCH,AMPS,AMV,IFPS,IFV ',3f12.4,2i10)
8071 C
8072  IF(amch.LT.amps) THEN
8073  irej=1
8074  RETURN
8075  ENDIF
8076 C
8077  IF (amch.LT.amv) THEN
8078 C PRODUCE PSEUDO SCALAR
8079  ijnch=ifps
8080  nnch=-1
8081  amchn=amps
8082  ELSEIF(amch.LT.amff) THEN
8083 C PRODUCE VECTOR MESON
8084  ijnch=ifv
8085  nnch=1
8086  amchn=amv
8087  ELSE
8088  amchn=amch
8089  ENDIF
8090 C
8091  RETURN
8092  END
8093 *CMZ : 1.00/00 27/11/91 17.09.38 by H.-J. M¶hring
8094 *-- Author :
8095 C
8096 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8097 C
8098 C 17/10/89 910191458 MEMBER NAME MCOMCM2 (KK89.S) F77
8099  SUBROUTINE zomcm2(IQ1,IQ2,IAQ1,IAQ2,NNCH,IREJ,AMCH)
8100  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8101  SAVE
8102 
8103 C--------------------------------------------------------------------
8104 C (QQ)-(AQ AQ) CHAIN:
8105 C CHECK QUANTUM NUMBERS AND
8106 C CORRECT MASS IF NECESSARY
8107 C REJECT IF THERE IS NO CORRESPONDING PARTICLE
8108 C OR TOO LOW MASS
8109 C--------------------------------------------------------------------
8110 C
8111 *KEEP,DPAR.
8112 C /DPAR/ CONTAINS PARTICLE PROPERTIES
8113 C ANAME = LITERAL NAME OF THE PARTICLE
8114 C AAM = PARTICLE MASS IN GEV
8115 C GA = DECAY WIDTH
8116 C TAU = LIFE TIME OF INSTABLE PARTICLES
8117 C IICH = ELECTRIC CHARGE OF THE PARTICLE
8118 C IIBAR = BARYON NUMBER
8119 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
8120 C
8121  CHARACTER*8 aname
8122  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
8123  +iibar(210),k1(210),k2(210)
8124 C------------------
8125 C------------------
8126 *KEEP,DPRIN.
8127  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8128 *KEEP,INPDAT.
8129  COMMON /inpdat/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
8130  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
8131 *KEND.
8132  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
8133 C--------------------------
8134  irej=0
8135  iiaq1=-iaq1
8136  iiaq2=-iaq2
8137  IF (iiaq1.EQ.iq1) go to 10
8138  IF (iiaq1.EQ.iq2) go to 20
8139  IF (iiaq2.EQ.iq1) go to 30
8140  IF (iiaq2.EQ.iq2) go to 40
8141 C REJECTION: NO CANCELLATION OF
8142 C ANY (Q-AQ) PAIR
8143  irej=1
8144  IF(ipev.GE.3) THEN
8145  WRITE(6,'(A/5X,4I5,1PE13.5)')
8146  + ' KKEVVV/COMCM2 (QU. NUMBERS): IQ1, IQ2, IAQ1, IAQ2, AMCH', iq1,
8147  + iq2, iaq1, iaq2, amch
8148  ENDIF
8149  RETURN
8150 C
8151  10 CONTINUE
8152 C IFPS=IMPS(IIAQ2,IQ2)
8153 C IFV =IMVE(IIAQ2,IQ2)
8154  go to 50
8155  20 CONTINUE
8156 C IFPS=IMPS(IIAQ2,IQ1)
8157 C IFV =IMVE(IIAQ2,IQ1)
8158  go to 50
8159  30 CONTINUE
8160 C IFPS=IMPS(IIAQ1,IQ2)
8161 C IFV =IMVE(IIAQ1,IQ2)
8162  go to 50
8163  40 CONTINUE
8164 C IFPS=IMPS(IIAQ1,IQ1)
8165 C IFV =IMVE(IIAQ1,IQ1)
8166 C
8167  50 CONTINUE
8168 C AMFPS=AAM(IFPS)
8169 C AMFV =AAM(IFV)
8170 C AMFF=AMFV+0.3
8171 C EMPIRICAL DEFINITION OF AMFF
8172 C TO ALLOW FOR (B-ANTIB) PAIR PRODUCTION
8173  amff=2.5
8174  nnch=0
8175  IF (amch.LT.amff) THEN
8176  irej=1
8177  IF(ipev.GE.3) THEN
8178  WRITE(6,'(A/5X,4I5,1PE13.5)')
8179  + ' KKEVVV/COMCM2 (MASS!): IQ1, IQ2, IAQ1, IAQ2, AMCH', iq1,
8180  + iq2, iaq1, iaq2, amch
8181  ENDIF
8182  ENDIF
8183  RETURN
8184  END
8185 *CMZ : 1.00/00 27/11/91 17.09.38 by H.-J. M¶hring
8186 *-- Author :
8187 C
8188 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8189 C
8190  SUBROUTINE zormom(AMMM,AMCH1,AMCH1N,AMCH2N, XP,XPP,XTVQ,XTVD,
8191  +pq1x,pq1y,pq1z,pq1e,pa1x,pa1y,pa1z,pa1e, pq2x,pq2y,pq2z,pq2e,pa2x,
8192  +pa2y,pa2z,pa2e, pxch1,pych1,pzch1,ech1, pxch2,pych2,pzch2,ech2,
8193  + irej)
8194  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8195  SAVE
8196 C
8197 C CORRECT KINEMATICS IF MASS OF THE FIRST CHAIN HAS BEEN CHANGED
8198 C FROM AMCH1 TO AMCH1N
8199 C CHAIN 1: (XP,XTVD)
8200 C AMMM : TOTAL MASS OF TWO CHAIN SYSTEM
8201 C AMCH2N : RESULTING NEW MASS FOR CHAIN 2 (OUTPUT ONLY)
8202 C
8203 C--- RESCALING OF X-VALUES
8204 C ACCORDING TO THE MODIFIED MASS OF CHAIN 1
8205 *KEEP,DPRIN.
8206  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8207 *KEND.
8208  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
8209 C------------------------------------
8210  irej=0
8211  fak=amch1n/amch1
8212  amch1=amch1n
8213  xpsqol=xp
8214  xp=xp*fak
8215  xpp=xpp + xpsqol - xp
8216  xtvdol=xtvd
8217  xtvd=xtvd*fak
8218  xtvq=xtvq + xtvdol - xtvd
8219  xppcm=xpp/(xp+xpp)
8220  xtvqcm=xtvq/(xtvq+xtvd)
8221 C
8222 C--- RESCALING OF MOMENTA FOR PARTONS OF CHAIN 1
8223  pq1x=pq1x*fak
8224  pq1y=pq1y*fak
8225  pq1z=pq1z*fak
8226  pq1e=pq1e*fak
8227  pa2x=pa2x*fak
8228  pa2y=pa2y*fak
8229  pa2z=pa2z*fak
8230  pa2e=pa2e*fak
8231 C--- NEW MOMENTUM OF CHAIN 1
8232 C TO BE COMPENSATED BY CHAIN 2
8233  pxch1=pq1x+pa2x
8234  pych1=pq1y+pa2y
8235  pzch1=pq1z+pa2z
8236  ech1 =pq1e+pa2e
8237  IF(ech1.LE.amch1)THEN
8238  irej=1
8239 C WRITE(6,'(A)') ' ZORMOM: INCONSISTENT KINEMATICS'
8240  RETURN
8241  ENDIF
8242  pch1 =sqrt(abs((ech1-amch1)*(ech1+amch1)))+0.000001
8243  cxch1=pxch1/pch1
8244  cych1=pych1/pch1
8245  czch1=pzch1/pch1
8246 C--- NEW 4-MOMENTUM OF CHAIN 2
8247  pxch2=-pxch1
8248  pych2=-pych1
8249  pzch2=-pzch1
8250  ech2 =ammm - ech1
8251  IF(ech2.LE.pch1)THEN
8252  irej=1
8253 C WRITE(6,'(A)') ' ZORMOM: INCONSISTENT KINEMATICS'
8254  RETURN
8255  ENDIF
8256  amch2n=sqrt(abs((ech2-pch1)*(ech2+pch1)))
8257 C--- ENERGIES OF PARTONS FROM CHAIN 2
8258  pa1e=xppcm*ammm/2.
8259  pq2e=xtvqcm*ammm/2.
8260  IF(pch1.GT.(pa1e+pq2e)) THEN
8261  irej=1
8262 C WRITE(6,'(A)') ' ZORMOM: INCONSISTENT KINEMATICS'
8263  RETURN
8264  ENDIF
8265 C--- MOMENTUM COMPONENTS OF PARTONS FROM CHAIN 2
8266 C WITH RESPECT TO THE MOMENTUM OF CHAIN 1 (Z)
8267  ct1=-(pch1**2 + (pa1e-pq2e)*(pa1e+pq2e))/(2.0*pch1*pa1e)
8268  if(abs(ct1).gt.1.0) then
8269 C write(6,'(5x,A/5x,4(1PE15.7))')
8270 C & ' ZORMOM: PCH1,PA1E,PQ2E, CT1', PCH1,PA1E,PQ2E, CT1
8271  ct1=sign(0.999999999,ct1)
8272 C WRITE(6,'(A)') ' ZORMOM: INCONSISTENT KINEMATICS'
8273  irej=1
8274  RETURN
8275  endif
8276  st1=sqrt(abs((1.0+ct1)*(1.0-ct1)))
8277  CALL dsfecf(sfe,cfe)
8278  CALL drtran(cxch1,cych1,czch1,ct1,st1,sfe,cfe,cxa1,cya1,cza1)
8279  pa1x=cxa1*pa1e
8280  pa1y=cya1*pa1e
8281  pa1z=cza1*pa1e
8282  pq2x=pxch2 - pa1x
8283  pq2y=pych2 - pa1y
8284  pq2z=pzch2 - pa1z
8285 C---
8286  IF(ipri.GT.1) THEN
8287  pxsum=pq1x+pa1x+pq2x+pa2x
8288  pysum=pq1y+pa1y+pq2y+pa2y
8289  pzsum=pq1z+pa1z+pq2z+pa2z
8290  pesum=pq1e+pa1e+pq2e+pa2e
8291  WRITE(6,'(A)') ' ZORMOM: KINEMATIC TEST FOR PARTONS'
8292  WRITE(6,'(A,1PE12.5)') ' AMMM',ammm
8293  WRITE(6,'(A,4(1PE12.5))') ' PXSUM,PYSUM,PZSUM,PESUM', pxsum,
8294  + pysum,pzsum,pesum
8295  ENDIF
8296  RETURN
8297  END
8298 *CMZ : 1.00/00 27/11/91 17.09.38 by H.-J. M¶hring
8299 *-- Author :
8300 C
8301 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8302 C DEBUG SUBCHK
8303 C END DEBUG
8304  SUBROUTINE zorval(AMMM,IREJ,AMCH1,AMCH2, QTX1,QTY1,QZ1,QE1,QTX2,
8305  +qty2,qz2,qe2,iori)
8306  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8307  SAVE
8308 C
8309 C KINEMATICAL CORRECTION OF TWO-VALENCE CHAIN SYSTEM
8310 C ACCORDING TO 2-PARTICLE KINEMATICS WITH FIXED MASSES
8311 C
8312 C**** WIR BRAUCHEN AUCH NOCH DIE NEUEN 4-IMPULSE DER KETTENENDEN
8313 C
8314 *KEEP,DPRIN.
8315  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8316 *KEND.
8317 C-----------------------------------------
8318  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
8319  irej=0
8320  IF(ammm.LE.amch1+amch2+0.4) THEN
8321  irej=1
8322  RETURN
8323  ENDIF
8324 C
8325  ek1=(ammm**2-amch2**2 + amch1**2)/(2.*ammm)
8326  ek2=ammm - ek1
8327  pzk1=sqrt(ek1**2 - amch1**2)
8328  pzk1=sign(pzk1,qz1)
8329  pzk2=sqrt(ek2**2 - amch2**2)
8330  pzk2=sign(pzk2,qz2)
8331  pxk1=0.
8332  pyk1=0.
8333  pxk2=0.
8334  pyk2=0.
8335 C ROTATE NEW CHAIN MOMENTA
8336 C INTO DIRECTION OF CHAINS BEFORE CORRECTION
8337  gam=(qe1+qe2)/ammm
8338  bgx=(qtx1+qtx2)/ammm
8339  bgy=(qty1+qty2)/ammm
8340  bgz=(qz1+qz2)/ammm
8341 C
8342  IF(abs(gam-1.).GT.1e-3) THEN
8343 C WRITE(6,'(A/5(1PE15.5)/15X,4(1PE15.4),I5)')
8344 C + ' ZORVAL: INCONSISTENT KINEMATICS OF CHAINS
8345 C + AMMM, QE1, QTX1, QTY1, QZ1, QE2, QTX2, QTY2, QZ2', AMMM, QE1,
8346 C + QTX1, QTY1, QZ1, QE2, QTX2, QTY2, QZ2,IORI
8347  irej=1
8348  RETURN
8349  ENDIF
8350 C
8351  CALL daltra(gam,-bgx,-bgy,-bgz,pxk1,pyk1,pzk1,ek1,pppch1, qtx1,
8352  +qty1,qz1,qe1)
8353  CALL daltra(gam,-bgx,-bgy,-bgz,pxk2,pyk2,pzk2,ek2,pppch2, qtx2,
8354  +qty2,qz2,qe2)
8355  IF(ipri.GT.1) THEN
8356  WRITE(6,'(2A)') ' ZORVAL - CORRECTION OF CHAIN MOMENTA',
8357  + ' IF MASS OF CHAIN 2 HAD TO BE CHANGED'
8358  ENDIF
8359  RETURN
8360  END
Generated on Sat May 25 2013 14:32:34 for Geant4 by   doxygen 1.8.4