Geant4_10
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
mpdgha
function mpdgha(MCIND)
Definition: dpm25nulib.f:386
kkevdv
subroutine kkevdv(IREJDV)
Definition: dpm25nuc5.f:208
intmx
const int intmx
Definition: G4DPMJET2_5Interface.hh:68
z
Double_t z
Definition: plot.C:279
hadrds
subroutine hadrds
Definition: dpm25nuc5.f:3858
hadjse
subroutine hadjse(NHAD, AMCH, PPR, PTA, GAM, BGX, BGY, BGZ, IFB1, IFB2, IFB3, IFB4, I1, I2, NOBAM, NNCH, NORIG, IREJ, IISSQQ)
Definition: dpm25nuc4.f:1479
kkevvd
subroutine kkevvd(IREJVD)
Definition: dpm25nuc5.f:1622
gm
#define gm
Definition: mymalloc.cc:2499
cromsc
subroutine cromsc(PX, PY, PZ, E, RX, RY, RZ, PXN, PYN, PZN, EN, IORIG)
Definition: dpm25nuc2.f:7037
x2
Double_t x2[nxs]
Definition: Style.C:19
saptre
subroutine saptre(AM1, G1, BGX1, BGY1, BGZ1, AM2, G2, BGX2, BGY2, BGZ2)
Definition: dpm25nuc3.f:1
rndm
DOUBLE PRECISION function rndm(RDUMMY)
Definition: dpm25nulib.f:1460
diqzzd
subroutine diqzzd(ECM, XPSQ1, XPSAQ1, XPSQ2, XPSAQ2, IPSQ1, IPSAQ1, IPSQ2, IPSAQ2, IREJSD)
Definition: dpm25nuc5.f:6951
hadrdz
subroutine hadrdz
Definition: dpm25nuc5.f:6432
cormom
subroutine cormom(AMCH1, AMCH2, AMCH1N, AMCH2N, PQ1X, PQ1Y, PQ1Z, PQ1E, PA1X, PA1Y, PA1Z, PA1E, PQ2X, PQ2Y, PQ2Z, PQ2E, PA2X, PA2Y, PA2Z, PA2E, PXCH1, PYCH1, PZCH1, ECH1, PXCH2, PYCH2, PZCH2, ECH2, IREJ)
Definition: dpm25nuc3.f:6305
diqvs
subroutine diqvs(ECM, IPV, J, IREJ)
Definition: dpm25nuc5.f:1411
a
G4double a
Definition: TRTMaterials.hh:39
zomcma
subroutine zomcma(IFQ, IFAQ, IJNCH, NNCH, IREJ, AMCH, AMCHN)
Definition: dpm25nuc5.f:8028
nmxhkk
const int nmxhkk
Definition: G4DPMJET2_5Interface.hh:78
zormom
subroutine zormom(AMMM, AMCH1, AMCH1N, AMCH2N, XP, XPP, XTVQ, XTVD, PQ1X, PQ1Y, PQ1Z, PQ1E, PA1X, PA1Y, PA1Z, PA1E, PQ2X, PQ2Y, PQ2Z, PQ2E, PA2X, PA2Y, PA2Z, PA2E, PXCH1, PYCH1, PZCH1, ECH1, PXCH2, PYCH2, PZCH2, ECH2, IREJ)
Definition: dpm25nuc5.f:8190
selpt
subroutine selpt(PTXSQ1, PTYSQ1, PLQ1, EQ1, PTXSA1, PTYSA1, PLAQ1, EAQ1, PTXSQ2, PTYSQ2, PLQ2, EQ2, PTXSA2, PTYSA2, PLAQ2, EAQ2, AMCH1, AMCH2, IREJ, IKVALA, PTTQ1, PTTA1, PTTQ2, PTTA2, NSELPT)
Definition: dpm25nuc3.f:6620
selpt4
subroutine selpt4(PTXSQ1, PTYSQ1, PLQ1, EQ1, PTXSA1, PTYSA1, PLAQ1, EAQ1, PTXSQ2, PTYSQ2, PLQ2, EQ2, PTXSA2, PTYSA2, PLAQ2, EAQ2, AMCH1, AMCH2, IREJ, IKVALA, PTTQ1, PTTA1, NSELPT)
Definition: dpm25nuc3.f:6435
qinnuc
subroutine qinnuc(X, Y)
Definition: dpm25nuc3.f:9129
kkevds
subroutine kkevds(IREJDS)
Definition: dpm25nuc5.f:3040
intmd
const int intmd
Definition: G4DPMJET2_5Interface.hh:66
n
Char_t n[5]
Definition: comparison_ascii.C:55
testem0.App.init
def init
Definition: testem0.py:56
corval
subroutine corval(AMMM, IREJ, AMCH1, AMCH2, QTX1, QTY1, QZ1, QE1, QTX2, QTY2, QZ2, QE2, NORIG)
Definition: dpm25nuc3.f:8390
hadrsd
subroutine hadrsd
Definition: dpm25nuc5.f:5429
hadrvd
subroutine hadrvd
Definition: dpm25nuc5.f:2382
diqssd
subroutine diqssd(ECM, ITS, IPS, IREJ)
Definition: dpm25nuc5.f:4398
daltra
subroutine daltra(GA, BGX, BGY, BGZ, PCX, PCY, PCZ, EC, P, PX, PY, PZ, E)
Definition: dpm25nulib.f:542
diqdss
subroutine diqdss(ECM, ITS, IPS, IREJ)
Definition: dpm25nuc5.f:2829
x1
Double_t x1[nxs]
Definition: Style.C:18
diqsv
subroutine diqsv(ECM, ITV, J, IREJ)
Definition: dpm25nuc5.f:1
zobcma
subroutine zobcma(IF1, IF2, IF3, IJNCH, NNCH, IREJ, AMCH, AMCHN, IKET)
Definition: dpm25nuc5.f:7947
x
Double_t x
Definition: plot.C:279
dsfecf
subroutine dsfecf(SFE, CFE)
Definition: dpm25nuc7.f:3354
cobcma
subroutine cobcma(IF1, IF2, IF3, IJNCH, NNCH, IREJ, AMCH, AMCHN, IKET)
Definition: dpm25nuc3.f:6049
zomcm2
subroutine zomcm2(IQ1, IQ2, IAQ1, IAQ2, NNCH, IREJ, AMCH)
Definition: dpm25nuc5.f:8099
hadrdv
subroutine hadrdv
Definition: dpm25nuc5.f:971
G4Abla::tau
G4double tau(G4double bet, G4double homega, G4double ef, G4double t)
Definition: G4Abla.cc:2586
c2_factory::sqrt
static c2_sqrt_p< float_type > & sqrt()
make a *new object
Definition: c2_factory.hh:142
drtran
subroutine drtran(XO, YO, ZO, CDE, SDE, SFE, CFE, X, Y, Z)
Definition: dpm25nuc7.f:3265
hkkfil
subroutine hkkfil(IST, ID, M1, M2, PX, PY, PZ, E, NHKKAU, KORMO, ICALL)
Definition: dpm25nuc1.f:6509
zorval
subroutine zorval(AMMM, IREJ, AMCH1, AMCH2, QTX1, QTY1, QZ1, QE1, QTX2, QTY2, QZ2, QE2, IORI)
Definition: dpm25nuc5.f:8304
kkevsd
subroutine kkevsd(IREJSD)
Definition: dpm25nuc5.f:4612
dbeta
DOUBLE PRECISION function dbeta(X1, X2, BET)
Definition: dpm25nuc7.f:2672
hadrzd
subroutine hadrzd
Definition: dpm25nuc5.f:7422
dbklas
subroutine dbklas(I, J, K, I8, I10)
Definition: dpm25nuc7.f:6096
diqdzz
subroutine diqdzz(ECM, XPSQ1, XPSAQ1, XPSQ2, XPSAQ2, IPSQ1, IPSAQ1, IPSQ2, IPSAQ2, IREJDS)
Definition: dpm25nuc5.f:5958
hadjase
subroutine hadjase(NHAD, AMCH, PPR, PTA, GAM, BGX, BGY, BGZ, IFB1, IFB2, IFB3, IFB4, I1, I2, NOBAM, NNCH, NORIG, IREJ, IISSQQ)
Definition: dpm25nuc4.f:2176
hadjet
subroutine hadjet(NHAD, AMCH, PPR, PTA, GAM, BGX, BGY, BGZ, IFB1, IFB2, IFB3, IFB4, I1, I2, NOBAM, NNCH, NORIG)
Definition: dpm25nuc3.f:5651
Generated on Sat Dec 14 2013 14:33:21 for Geant4_10 by   doxygen 1.8.5