Geant4.10
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
dpm25nuc3.f
Go to the documentation of this file.
1  SUBROUTINE saptre(AM1,G1,BGX1,BGY1,BGZ1,
2  & am2,g2,bgx2,bgy2,bgz2)
3  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4  SAVE
5 C SELECT PT FOR CHAIN PAIRS, WHICH ARE RESONANCES
6  b3=4.
7  e1=g1*am1
8  px1=bgx1*am1
9  py1=bgy1*am1
10  pz1=bgz1*am1
11  e2=g2*am2
12  px2=bgx2*am2
13  py2=bgy2*am2
14  pz2=bgz2*am2
15 C SAMPLE TRANSVERSE MOMENTUM LIKE IN BAMJET
16 C ES DEFINED AS ES=SQRT(PT**2+AM**2)-AM
17  esmax1=e1-am1
18  esmax2=e2-am2
19  esmax=min(esmax1,esmax2)
20  IF(esmax.LE.0.05d0) RETURN
21  hma=am1
22  IF (b3*esmax.GT.60.d0)THEN
23  exeb=0.
24  ELSE
25  exeb=exp(-b3*esmax)
26  ENDIF
27  bexp=hma*(1.-exeb)/b3
28  axexp=(1.d0-(b3*esmax-1.d0)*exeb)/b3**2
29  wa=axexp/(bexp+axexp)
30  xab=rndm(wu)
31  10 CONTINUE
32  IF (xab.LT.wa)THEN
33  x=rndm(v)
34  y=rndm(v)
35  es=-2./(b3**2)*log(x*y+1.e-7)
36  ELSE
37  x=rndm(v)
38  es=abs(-log(x+1.e-7)/b3)
39  END IF
40  IF(es.GT.esmax) goto10
41  es=es+hma
42  hps=sqrt((es-hma)*(es+hma))
43  20 CONTINUE
44  CALL dsfecf(sfe,cfe)
45  sip=sfe
46  cop=cfe
47  hpx=hps*cop
48  hpy=hps*sip
49  pz1nsq=pz1**2-hps**2-2.*px1*hpx-2.*py1*hpy
50  pz2nsq=pz2**2-hps**2+2.*px2*hpx+2.*py2*hpy
51  IF(pz1nsq.LT.0.001d0.OR.pz2nsq.LT.0.001d0) RETURN
52  pz1=sign(sqrt(pz1nsq),pz1)
53  pz2=sign(sqrt(pz2nsq),pz2)
54  px1=px1+hpx
55  py1=py1+hpy
56  px2=px2-hpx
57  py2=py2-hpy
58  bgx1=px1/am1
59  bgy1=py1/am1
60  bgz1=pz1/am1
61  bgx2=px2/am2
62  bgy2=py2/am2
63  bgz2=pz2/am2
64 C WRITE(6,1001) HPX,HPY
65 C1001 FORMAT(' HPX,HPY ',2F10.3)
66  RETURN
67  END
68 *-- Author :
69 C
70 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
71 C
72  SUBROUTINE sltraf(GA,BGA,EIN,PZIN,EOUT,PZOUT)
73  IMPLICIT DOUBLE PRECISION (a-h,o-z)
74  SAVE
75  pzout=ga*pzin - bga*ein
76  eout=ga*ein - bga*pzin
77  RETURN
78  END
79 *-- Author :
80 C
81 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
82 C
83  SUBROUTINE nucmom
84  IMPLICIT DOUBLE PRECISION (a-h,o-z)
85  SAVE
86 C***
87 C FERMI-MOMENTA FOR ALL NUCLEONS
88 C TRANSFORMED INTO NN-CMS
89 C FOR INCIDENT HADRONS USE CMS MOMENTUM
90 C***
91 *KEEP,INTMX.
92  parameter(intmx=2488,intmd=252)
93 *KEEP,DXQX.
94 C INCLUDE (XQXQ)
95 * NOTE: INTMX set via INCLUDE(INTMX)
96  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
97  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
98  * ,xpsu(248),xtsu(248)
99  * ,xpsut(248),xtsut(248)
100 *KEEP,INTNEW.
101  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
102  +ixpv,ixps,ixtv,ixts, intvv1(248),
103  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
104  +intss1(intmx),intss2(intmx),
105  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
106  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
107 
108 C /INTNEW/
109 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
110 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
111 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
112 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
113 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
114 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
115 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
116 C FROM PROJECTILE/TARGET NUCLEI
117 C-------------------
118 *KEEP,IFROTO.
119  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
120  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
121  +jhkknt
122  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
123  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
124  & mhkkhh(intmx),
125  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
126 *KEEP,LOZUO.
127  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
128  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
129  +intlo(intmx),inloss(intmx)
130 C /LOZUO/
131 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
132 C REJECTED IN KKEVT
133 C------------------
134 *KEEP,DIQI.
135  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
136  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
137  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
138  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
139 *KEEP,HKKEVT.
140 c INCLUDE (HKKEVT)
141  parameter(nmxhkk= 89998)
142 c PARAMETER (NMXHKK=25000)
143  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
144  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
145  +(4,nmxhkk)
146 C
147 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
148 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
149 C THE POSITIONS OF THE PROJECTILE NUCLEONS
150 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
151 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
152 C COMPLETELY CONSISTENT. THE TIMES IN THE
153 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
154 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
155 C
156 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
157 C
158 C NMXHKK: maximum numbers of entries (partons/particles) that can be
159 C stored in the commonblock.
160 C
161 C NHKK: the actual number of entries stored in current event. These are
162 C found in the first NHKK positions of the respective arrays below.
163 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
164 C entry.
165 C
166 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
167 C = 0 : null entry.
168 C = 1 : an existing entry, which has not decayed or fragmented.
169 C This is the main class of entries which represents the
170 C "final state" given by the generator.
171 C = 2 : an entry which has decayed or fragmented and therefore
172 C is not appearing in the final state, but is retained for
173 C event history information.
174 C = 3 : a documentation line, defined separately from the event
175 C history. (incoming reacting
176 C particles, etc.)
177 C = 4 - 10 : undefined, but reserved for future standards.
178 C = 11 - 20 : at the disposal of each model builder for constructs
179 C specific to his program, but equivalent to a null line in the
180 C context of any other program. One example is the cone defining
181 C vector of HERWIG, another cluster or event axes of the JETSET
182 C analysis routines.
183 C = 21 - : at the disposal of users, in particular for event tracking
184 C in the detector.
185 C
186 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
187 C standard.
188 C
189 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
190 C The value is 0 for initial entries.
191 C
192 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
193 C one mother exist, in which case the value 0 is used. In cluster
194 C fragmentation models, the two mothers would correspond to the q
195 C and qbar which join to form a cluster. In string fragmentation,
196 C the two mothers of a particle produced in the fragmentation would
197 C be the two endpoints of the string (with the range in between
198 C implied).
199 C
200 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
201 C entry has not decayed, this is 0.
202 C
203 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
204 C entry has not decayed, this is 0. It is assumed that the daughters
205 C of a particle (or cluster or string) are stored sequentially, so
206 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
207 C daughters. Even in cases where only one daughter is defined (e.g.
208 C K0 -> K0S) both values should be defined, to make for a uniform
209 C approach in terms of loop constructions.
210 C
211 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
212 C
213 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
214 C
215 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
216 C
217 C PHKK(4,IHKK) : energy, in GeV.
218 C
219 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
220 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
221 C
222 C VHKK(1,IHKK) : production vertex x position, in mm.
223 C
224 C VHKK(2,IHKK) : production vertex y position, in mm.
225 C
226 C VHKK(3,IHKK) : production vertex z position, in mm.
227 C
228 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
229 C********************************************************************
230 *KEEP,DPRIN.
231  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
232 *KEEP,NNCMS.
233  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
234 *KEEP,NUCC.
235  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
236 *KEEP,DPAR.
237 C /DPAR/ CONTAINS PARTICLE PROPERTIES
238 C ANAME = LITERAL NAME OF THE PARTICLE
239 C AAM = PARTICLE MASS IN GEV
240 C GA = DECAY WIDTH
241 C TAU = LIFE TIME OF INSTABLE PARTICLES
242 C IICH = ELECTRIC CHARGE OF THE PARTICLE
243 C IIBAR = BARYON NUMBER
244 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
245 C
246  CHARACTER*8 aname
247  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
248  +iibar(210),k1(210),k2(210)
249 C------------------
250 *KEEP,NUCIMP.
251  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
252  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
253  +prebin,taebin,fermod,etacou
254 *KEEP,PROJK.
255  COMMON /projk/ iprojk
256 *KEND.
257  IF(ijproj.EQ.5)RETURN
258 C
259 C****************************** PROJECTILE
260 C - INTERACTING PROJECTILES ISTHKK=11
261  DO 10 j=1,ip
262 C IF(ISTHKK(J).EQ.11) THEN
263  kk=kkproj(j)
264  prmom(1,j)=phkk(1,j)
265  prmom(2,j)=phkk(2,j)
266  gaproj=eproj/aam(kk)
267  bgproj=pproj/aam(kk)
268  CALL sltraf(gaproj,-bgproj, phkk(4,j),phkk(3,j),prmom4,prmom3)
269 
270  CALL sltraf(gamcm,+bgcm, prmom4,prmom3,prmom(4,j),prmom(3,j))
271 
272  prmom(5,j)=sqrt( abs((prmom(4,j)-aam(kk)) *(prmom(4,j)+aam(kk)
273  + )))
274 C ENDIF
275  10 CONTINUE
276 C
277 C------------------------------ TARGET
278 C INTERACTING TARGET NUCLEONS ISTHKK=12
279  ihkk=ip
280  DO 20 j=1,it
281  ihkk=ihkk + 1
282 C IF(ISTHKK(IHKK).EQ.12) THEN
283  kk=kktarg(j)
284  tamom(1,j)=phkk(1,ihkk)
285  tamom(2,j)=phkk(2,ihkk)
286  CALL sltraf(gamcm,bgcm, phkk(4,ihkk),phkk(3,ihkk),tamom(4,j),
287  + tamom(3,j))
288  tamom(5,j)=sqrt(abs( (tamom(4,j)-aam(kk))
289  + *(tamom(4,j)+aam(kk))))
290 
291 C ENDIF
292  20 CONTINUE
293 C
294  IF(ipev.GE.6) THEN
295  WRITE(6,'(/A,I5/5X,A)') ' NUCMOM: IP=',ip,
296  + ' J,IPVQ(J),IPPV1(J),IPPV2(J),ISTHKK,KKPROJ,PRMOM'
297  DO 30 j=1,ip
298  WRITE(6,'(I4,5I3,5(1PE11.3))') j,isthkk(j),kkproj(j), ipvq(j),
299  + ippv1(j),ippv2(j), (prmom(jj,j),jj=1,5)
300 
301  30 CONTINUE
302 C
303  WRITE(6,'(/A,I5/5X,A)') ' NUCMOM: IT=',it,
304  + ' J,ITVQ(J),ITTV1(J),ITTV2(J),ISTHKK,KKTARG,TAMOM'
305  ihkk=ip
306  DO 40 j=1,it
307  ihkk=ihkk + 1
308  WRITE(6,'(I4,5I3,5(1PE11.3))') j,isthkk(ihkk),kktarg(j), itvq
309  + (j),ittv1(j),ittv2(j), (tamom(jj,j),jj=1,5)
310 
311  40 CONTINUE
312  ENDIF
313 C
314  RETURN
315  END
316 *-- Author :
317 C
318 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
319 C
320  SUBROUTINE fer4m(PFERM,PXT,PYT,PZT,ET,KT)
321  IMPLICIT DOUBLE PRECISION (a-h,o-z)
322  SAVE
323 C
324 C SAMPLE FERMI MOMENTUM FROM DISTRIBUTION WITH T=0
325 C-----------
326 *KEEP,DPAR.
327 C /DPAR/ CONTAINS PARTICLE PROPERTIES
328 C ANAME = LITERAL NAME OF THE PARTICLE
329 C AAM = PARTICLE MASS IN GEV
330 C GA = DECAY WIDTH
331 C TAU = LIFE TIME OF INSTABLE PARTICLES
332 C IICH = ELECTRIC CHARGE OF THE PARTICLE
333 C IIBAR = BARYON NUMBER
334 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
335 C
336  CHARACTER*8 aname
337  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
338  +iibar(210),k1(210),k2(210)
339 C------------------
340 *KEEP,DROPPT.
341  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
342  +ishmal,lpauli
343  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
344  +ipadis,ishmal,lpauli
345 *KEND.
346 C-----------
347  IF (fermp) THEN
348  CALL dfermi(pabs)
349  pabs=pferm*pabs
350 C SAMPLE ANGLES
351  CALL dpoli(polc,pols)
352  CALL dsfecf(sfe,cfe)
353 C
354  cxta=pols*cfe
355  cyta=pols*sfe
356  czta=polc
357  et=sqrt(pabs*pabs+aam(kt)**2)
358  pxt=cxta*pabs
359  pyt=cyta*pabs
360  pzt=czta*pabs
361 C
362  ELSE
363  et=aam(kt)
364  pxt=0.
365  pyt=0.
366  pzt=0.
367  ENDIF
368 C
369  RETURN
370  END
371 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
372 C
373  SUBROUTINE fer4mp(IP,PFERM,PXT,PYT,PZT,ET,KT)
374  IMPLICIT DOUBLE PRECISION (a-h,o-z)
375  SAVE
376  COMMON /ferfor/iferfo
377 C
378 C SAMPLE FERMI MOMENTUM FROM DISTRIBUTION WITH T=0
379 C-----------
380 *KEEP,DPAR.
381 C /DPAR/ CONTAINS PARTICLE PROPERTIES
382 C ANAME = LITERAL NAME OF THE PARTICLE
383 C AAM = PARTICLE MASS IN GEV
384 C GA = DECAY WIDTH
385 C TAU = LIFE TIME OF INSTABLE PARTICLES
386 C IICH = ELECTRIC CHARGE OF THE PARTICLE
387 C IIBAR = BARYON NUMBER
388 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
389 C
390  CHARACTER*8 aname
391  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
392  +iibar(210),k1(210),k2(210)
393 C------------------
394 *KEEP,DROPPT.
395  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
396  +ishmal,lpauli
397  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
398  +ipadis,ishmal,lpauli
399 *KEND.
400 C-----------
401  IF (fermp) THEN
402  IF(iferfo.EQ.1)THEN
403  CALL dfermi(pabs)
404  pabs=pferm*pabs
405  ENDIF
406  IF(iferfo.EQ.2)CALL dfatpr(ip,pabs)
407 C SAMPLE ANGLES
408  CALL dpoli(polc,pols)
409  CALL dsfecf(sfe,cfe)
410 C
411  cxta=pols*cfe
412  cyta=pols*sfe
413  czta=polc
414  et=sqrt(pabs*pabs+aam(kt)**2)
415  pxt=cxta*pabs
416  pyt=cyta*pabs
417  pzt=czta*pabs
418 C
419  ELSE
420  et=aam(kt)
421  pxt=0.
422  pyt=0.
423  pzt=0.
424  ENDIF
425 C
426  RETURN
427  END
428 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
429 C
430  SUBROUTINE fer4mt(IT,PFERM,PXT,PYT,PZT,ET,KT)
431  IMPLICIT DOUBLE PRECISION (a-h,o-z)
432  SAVE
433  COMMON /ferfor/iferfo
434 C
435 C SAMPLE FERMI MOMENTUM FROM DISTRIBUTION WITH T=0
436 C-----------
437 *KEEP,DPAR.
438 C /DPAR/ CONTAINS PARTICLE PROPERTIES
439 C ANAME = LITERAL NAME OF THE PARTICLE
440 C AAM = PARTICLE MASS IN GEV
441 C GA = DECAY WIDTH
442 C TAU = LIFE TIME OF INSTABLE PARTICLES
443 C IICH = ELECTRIC CHARGE OF THE PARTICLE
444 C IIBAR = BARYON NUMBER
445 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
446 C
447  CHARACTER*8 aname
448  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
449  +iibar(210),k1(210),k2(210)
450 C------------------
451 *KEEP,DROPPT.
452  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
453  +ishmal,lpauli
454  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
455  +ipadis,ishmal,lpauli
456 *KEND.
457 C-----------
458 C WRITE(6,*)' FERMP',FERMP
459  IF (fermp) THEN
460  IF(iferfo.EQ.1)THEN
461  CALL dfermi(pabs)
462 CWRITE(6,*)' PABS',PABS
463  pabs=pferm*pabs
464 CWRITE(6,*)' PABS',PABS
465  ENDIF
466  IF(iferfo.EQ.2)CALL dfatta(it,pabs)
467 C SAMPLE ANGLES
468 CWRITE(6,*)' PABS',PABS
469  CALL dpoli(polc,pols)
470  CALL dsfecf(sfe,cfe)
471 C
472  cxta=pols*cfe
473  cyta=pols*sfe
474  czta=polc
475  et=sqrt(pabs*pabs+aam(kt)**2)
476  pxt=cxta*pabs
477  pyt=cyta*pabs
478  pzt=czta*pabs
479 C
480  ELSE
481  et=aam(kt)
482  pxt=0.
483  pyt=0.
484  pzt=0.
485  ENDIF
486 C
487  RETURN
488  END
489  SUBROUTINE dfatta(IT,PABS)
490  IMPLICIT DOUBLE PRECISION (a-h,o-z)
491  SAVE
492 C FERMI MOMENTUM A LA C. CIOFI DEGLI ATTI ET AL PRC53(96)1689
493  dimension par10(6),par20(6),par30(6),par40(6),par50(6),
494  * par60(6),par11(6),par21(6),par31(6),par41(6),
495  * aia(6),att(101),catt(101),aka(101)
496  common/fattad/daka(101),fatt(101)
497  DATA par10/1.61d0,2.74d0,3.24d0,3.57d0,1.80d0,0.d0/
498  DATA par20/2.66d0,3.33d0,3.72d0,4.97d0,4.77d0,0.d0/
499  DATA par30/3.54d0,6.66d0,0.d0,0.d0,0.d0,0.d0/
500  DATA par40/0.d0,0.d0,11.1d0,19.8d0,25.5d0,0.d0/
501  DATA par50/0.d0,0.d0,0.d0,15.d0,0.d0,0.d0/
502  DATA par60/0.d0,0.d0,0.d0,0.d0,40.3d0,0.d0/
503  DATA par11/.426d0,.326d0,.419d0,.230d0,.275d0,0.d0/
504  DATA par21/1.6d0,1.4d0,1.77d0,1.2d0,1.01d0,0.d0/
505  DATA par31/.0237d0,.0263d0,.0282d0,.0286d0,.0304d0,0.d0/
506  DATA par41/.22d0,.22d0,.22d0,.22d0,.22d0,0.d0/
507  DATA aia/12.d0,16.d0,40.d0,56.d0,208.d0,209.d0/
508  DATA init/0/
509  ait=it
510  IF(init.EQ.0)THEN
511 C INITIALIZATION
512 C INTERPOLATE PARAMETERS
513  DO 1 i=1,4
514  IF(ait.GE.aia(i).AND.ait.LT.aia(i+1))THEN
515  dait=(ait-aia(i))/(aia(i+1)-aia(i))
516  dbit=1.d0-dait
517  iii=i
518  ENDIF
519  1 CONTINUE
520  IF(ait.LT.aia(1))THEN
521  dbit=1.d0
522  dait=0.d0
523  iii=1
524  ENDIF
525  IF(ait.GE.aia(5))THEN
526  dbit=1.d0
527  dait=0.d0
528  iii=5
529  ENDIF
530  a0=dbit*par10(iii)+dait*par10(iii+1)
531  b0=dbit*par20(iii)+dait*par20(iii+1)
532  c0=dbit*par30(iii)+dait*par30(iii+1)
533  d0=dbit*par40(iii)+dait*par40(iii+1)
534  e0=dbit*par50(iii)+dait*par50(iii+1)
535  f0=dbit*par60(iii)+dait*par60(iii+1)
536  a1=dbit*par11(iii)+dait*par11(iii+1)
537  b1=dbit*par21(iii)+dait*par21(iii+1)
538  c1=dbit*par31(iii)+dait*par31(iii+1)
539  d1=dbit*par41(iii)+dait*par41(iii+1)
540  init=1
541  dk=0.04d0
542  catt(1)=0.d0
543  DO 2 i=1,101
544  ai=i
545  ak=(ai-1.d0)*dk
546  aka(i)=ak
547  daka(i)=aka(i)
548  att(i)=ak**2*(a0*exp(-b0*ak**2)*(1.d0+c0*ak**2+
549  * d0*ak**4+e0*ak**6+f0*ak**8)+
550  * a1*exp(-b1*ak**2)+c1*exp(-d1*ak**2))
551  IF(i.GT.1)catt(i)=catt(i-1)+att(i)
552  2 CONTINUE
553  DO 3 i=1,101
554  catt(i)=catt(i)/catt(101)
555  fatt(i)=0.d0
556  3 CONTINUE
557  ENDIF
558 C END INITIALIZATION
559  rndfa=rndm(v)
560  DO 10 i=1,101
561  IF(rndfa.LT.catt(i))THEN
562  iatt=i
563  go to 11
564  ENDIF
565  10 CONTINUE
566  11 CONTINUE
567  pabs=aka(iatt)*0.197d0
568  fatt(iatt)=fatt(iatt)+1.d0/pabs**2
569  RETURN
570  END
571  SUBROUTINE dfatpr(IP,PABS)
572  IMPLICIT DOUBLE PRECISION (a-h,o-z)
573  SAVE
574 C FERMI MOMENTUM A LA C. CIOFI DEGLI ATTI ET AL PRC53(96)1689
575  dimension par10(6),par20(6),par30(6),par40(6),par50(6),
576  * par60(6),par11(6),par21(6),par31(6),par41(6),
577  * aia(6),att(101),catt(101),aka(101)
578  DATA par10/1.61d0,2.74d0,3.24d0,3.57d0,1.80d0,0.d0/
579  DATA par20/2.66d0,3.33d0,3.72d0,4.97d0,4.77d0,0.d0/
580  DATA par30/3.54d0,6.66d0,0.d0,0.d0,0.d0,0.d0/
581  DATA par40/0.d0,0.d0,11.1d0,19.8d0,25.5d0,0.d0/
582  DATA par50/0.d0,0.d0,0.d0,15.d0,0.d0,0.d0/
583  DATA par60/0.d0,0.d0,0.d0,0.d0,40.3d0,0.d0/
584  DATA par11/.426d0,.326d0,.419d0,.230d0,.275d0,0.d0/
585  DATA par21/1.6d0,1.4d0,1.77d0,1.2d0,1.01d0,0.d0/
586  DATA par31/.0237d0,.0263d0,.0282d0,.0286d0,.0304d0,0.d0/
587  DATA par41/.22d0,.22d0,.22d0,.22d0,.22d0,0.d0/
588  DATA aia/12.d0,16.d0,40.d0,56.d0,208.d0,209.d0/
589  DATA init/0/
590  ait=ip
591  IF(init.EQ.0)THEN
592 C INITIALIZATION
593 C INTERPOLATE PARAMETERS
594  DO 1 i=1,4
595  IF(ait.GE.aia(i).AND.ait.LT.aia(i+1))THEN
596  dait=(ait-aia(i))/(aia(i+1)-aia(i))
597  dbit=1.d0-dait
598  iii=i
599  ENDIF
600  1 CONTINUE
601  IF(ait.LT.aia(1))THEN
602  dbit=1.d0
603  dait=0.d0
604  iii=1
605  ENDIF
606  IF(ait.GE.aia(5))THEN
607  dbit=1.d0
608  dait=0.d0
609  iii=5
610  ENDIF
611  a0=dbit*par10(iii)+dait*par10(iii+1)
612  b0=dbit*par20(iii)+dait*par20(iii+1)
613  c0=dbit*par30(iii)+dait*par30(iii+1)
614  d0=dbit*par40(iii)+dait*par40(iii+1)
615  e0=dbit*par50(iii)+dait*par50(iii+1)
616  f0=dbit*par60(iii)+dait*par60(iii+1)
617  a1=dbit*par11(iii)+dait*par11(iii+1)
618  b1=dbit*par21(iii)+dait*par21(iii+1)
619  c1=dbit*par31(iii)+dait*par31(iii+1)
620  d1=dbit*par41(iii)+dait*par41(iii+1)
621  init=1
622  dk=0.04d0
623  catt(1)=0.d0
624  DO 2 i=1,101
625  ai=i
626  ak=(ai-1.d0)*dk
627  aka(i)=ak
628  att(i)=ak**2*(a0*exp(-b0*ak**2)*(1.d0+c0*ak**2+
629  * d0*ak**4+e0*ak**6+f0*ak**8)+
630  * a1*exp(-b1*ak**2)+c1*exp(-d1*ak**2))
631  IF(i.GT.1)catt(i)=catt(i-1)+att(i)
632  2 CONTINUE
633  DO 3 i=1,101
634  catt(i)=catt(i)/catt(101)
635  3 CONTINUE
636  ENDIF
637 C END INITIALIZATION
638  rndfa=rndm(v)
639  DO 10 i=1,101
640  IF(rndfa.LT.catt(i))THEN
641  iatt=i
642  go to 11
643  ENDIF
644  10 CONTINUE
645  11 CONTINUE
646  pabs=aka(iatt)*0.197d0
647  RETURN
648  END
649 *-- Author :
650 C
651 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
652 C
653  SUBROUTINE flksam
654  IMPLICIT DOUBLE PRECISION (a-h,o-z)
655  SAVE
656 C QUARK CONTENT
657 C OF PROJECTILE AND TARGET
658 C (HADRONS / ALL NUCLEONS)
659 C---------------------------------------------------------------------
660 *KEEP,INTMX.
661  parameter(intmx=2488,intmd=252)
662 *KEEP,DXQX.
663 C INCLUDE (XQXQ)
664 * NOTE: INTMX set via INCLUDE(INTMX)
665  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
666  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
667  * ,xpsu(248),xtsu(248)
668  * ,xpsut(248),xtsut(248)
669 *KEEP,INTNEW.
670  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
671  +ixpv,ixps,ixtv,ixts, intvv1(248),
672  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
673  +intss1(intmx),intss2(intmx),
674  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
675  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
676 
677 C /INTNEW/
678 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
679 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
680 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
681 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
682 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
683 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
684 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
685 C FROM PROJECTILE/TARGET NUCLEI
686 C-------------------
687 *KEEP,IFROTO.
688  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
689  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
690  +jhkknt
691  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
692  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
693  & mhkkhh(intmx),
694  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
695 *KEEP,LOZUO.
696  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
697  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
698  +intlo(intmx),inloss(intmx)
699 C /LOZUO/
700 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
701 C REJECTED IN KKEVT
702 C------------------
703 *KEEP,DIQI.
704  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
705  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
706  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
707  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
708 *KEEP,HKKEVT.
709 c INCLUDE (HKKEVT)
710  parameter(nmxhkk= 89998)
711 c PARAMETER (NMXHKK=25000)
712  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
713  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
714  +(4,nmxhkk)
715 C
716 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
717 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
718 C THE POSITIONS OF THE PROJECTILE NUCLEONS
719 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
720 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
721 C COMPLETELY CONSISTENT. THE TIMES IN THE
722 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
723 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
724 C
725 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
726 C
727 C NMXHKK: maximum numbers of entries (partons/particles) that can be
728 C stored in the commonblock.
729 C
730 C NHKK: the actual number of entries stored in current event. These are
731 C found in the first NHKK positions of the respective arrays below.
732 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
733 C entry.
734 C
735 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
736 C = 0 : null entry.
737 C = 1 : an existing entry, which has not decayed or fragmented.
738 C This is the main class of entries which represents the
739 C "final state" given by the generator.
740 C = 2 : an entry which has decayed or fragmented and therefore
741 C is not appearing in the final state, but is retained for
742 C event history information.
743 C = 3 : a documentation line, defined separately from the event
744 C history. (incoming reacting
745 C particles, etc.)
746 C = 4 - 10 : undefined, but reserved for future standards.
747 C = 11 - 20 : at the disposal of each model builder for constructs
748 C specific to his program, but equivalent to a null line in the
749 C context of any other program. One example is the cone defining
750 C vector of HERWIG, another cluster or event axes of the JETSET
751 C analysis routines.
752 C = 21 - : at the disposal of users, in particular for event tracking
753 C in the detector.
754 C
755 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
756 C standard.
757 C
758 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
759 C The value is 0 for initial entries.
760 C
761 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
762 C one mother exist, in which case the value 0 is used. In cluster
763 C fragmentation models, the two mothers would correspond to the q
764 C and qbar which join to form a cluster. In string fragmentation,
765 C the two mothers of a particle produced in the fragmentation would
766 C be the two endpoints of the string (with the range in between
767 C implied).
768 C
769 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
770 C entry has not decayed, this is 0.
771 C
772 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
773 C entry has not decayed, this is 0. It is assumed that the daughters
774 C of a particle (or cluster or string) are stored sequentially, so
775 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
776 C daughters. Even in cases where only one daughter is defined (e.g.
777 C K0 -> K0S) both values should be defined, to make for a uniform
778 C approach in terms of loop constructions.
779 C
780 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
781 C
782 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
783 C
784 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
785 C
786 C PHKK(4,IHKK) : energy, in GeV.
787 C
788 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
789 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
790 C
791 C VHKK(1,IHKK) : production vertex x position, in mm.
792 C
793 C VHKK(2,IHKK) : production vertex y position, in mm.
794 C
795 C VHKK(3,IHKK) : production vertex z position, in mm.
796 C
797 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
798 C********************************************************************
799 *KEEP,NUCC.
800  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
801 *KEEP,DPAR.
802 C /DPAR/ CONTAINS PARTICLE PROPERTIES
803 C ANAME = LITERAL NAME OF THE PARTICLE
804 C AAM = PARTICLE MASS IN GEV
805 C GA = DECAY WIDTH
806 C TAU = LIFE TIME OF INSTABLE PARTICLES
807 C IICH = ELECTRIC CHARGE OF THE PARTICLE
808 C IIBAR = BARYON NUMBER
809 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
810 C
811  CHARACTER*8 aname
812  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
813  +iibar(210),k1(210),k2(210)
814 C------------------
815 *KEEP,DPRIN.
816  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
817 *KEEP,PROJK.
818  COMMON /projk/ iprojk
819 *KEND.
820 C----------
821  dimension ihkkq(-6:6),ihkkqq(-3:3,-3:3)
822  DATA ihkkq/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
823  DATA ihkkqq/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
824  +-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
825  +0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
826 C----------------------------------------------------------------------
827 C
828 C FLAVORS OF VALENCE QUARKS FROM PROJECTILE HADRON/NUCLEONS
829 C
830 C-----
831 C
832  IF(ipev.GE.3) WRITE(6,'(A,6I4)')
833  +' FLKSAM-ENTRY: IT,ITZ, IP,IPZ, IJPROJ,IBPROJ', it,itz,ip,ipz,
834  +ijproj,ibproj
835 C
836  ixpss=ixps
837  ixtss=ixts
838  ixpvv=ixpv
839  ixtvv=ixtv
840  DO 10 jp=1,ixpvv
841  ifr=ifrovp(jp)
842  kproj=kkproj(ifr)
843  CALL flahad(kproj,ibproj,ipvq(jp),ippv1(jp),ippv2(jp))
844 C
845  IF (ipev.GE.6) WRITE (6,1000)ipvq(jp),ippv1(jp),ippv2(jp)
846  1000 FORMAT (' FLKSAM: IPVQ,IPPV1,IPPV2 ',3i4)
847 C
848  jhkk=jhkkpv(jp)
849  jhkkq=jhkk - 1
850  idhkk(jhkkq)=ihkkq(ipvq(jp))
851  IF(ibproj.EQ.0) THEN
852  idhkk(jhkk)=ihkkq(ippv1(jp))
853  ELSE
854  idhkk(jhkk)=ihkkqq(ippv1(jp),ippv2(jp))
855  ENDIF
856 C
857  10 CONTINUE
858 C
859 C*********************************************************************
860 C
861 C-------------------------------SAMPLING PROJECTILE SEA FLAVORS-------
862 C
863 C*********************************************************************
864 C
865  DO 20 n=1,ixpss
866 C
867  jhkkaq=jhkkps(n)
868  jhkkq=jhkkaq - 1
869  idhkk(jhkkq)=ihkkq(ipsq(n))
870  idhkk(jhkkaq)=ihkkq(ipsaq(n))
871 C
872  20 CONTINUE
873 C--------------------------------------------------------------------
874 C
875 C FLAVORS OF VALENCE QUARKS FROM TARGET HADRON / ALL NUCLEONS
876 C
877 C-----
878 C
879  DO 30 jt=1,ixtvv
880  ifr=ifrovt(jt)
881  ktarg=kktarg(ifr)
882  ibtarg=iibar(ktarg)
883  CALL flahad(ktarg,ibtarg,itvq(jt),ittv1(jt),ittv2(jt))
884 C
885  jhkk=jhkktv(jt)
886  jhkkq=jhkk - 1
887  idhkk(jhkkq)=ihkkq(itvq(jt))
888  IF(ibtarg.EQ.0) THEN
889  idhkk(jhkk)=ihkkq(ittv1(jt))
890  ELSE
891  idhkk(jhkk)=ihkkqq(ittv1(jt),ittv2(jt))
892  ENDIF
893  IF (ipev.GE.8) WRITE (6,'(A,8I4)')
894  + ' FLKSAM: KTARG,ITVQ(JT),ITTV1(JT),ITTV2(JT)', ktarg,itvq(jt),
895  + ittv1(jt),ittv2(jt), idhkk(jhkkq),jhkkq,idhkk(jhkk),jhkk
896 
897 C
898 C
899  30 CONTINUE
900 C
901 C*********************************************************************
902 C
903 C-------------------------------SAMPLING TARGET SEA FLAVORS-------
904 C
905 C*********************************************************************
906 C
907  DO 40 n=1,ixtss
908 C
909  jhkkaq=jhkkts(n)
910  jhkkq=jhkkaq - 1
911  idhkk(jhkkq)=ihkkq(itsq(n))
912  idhkk(jhkkaq)=ihkkq(itsaq(n))
913 C
914  40 CONTINUE
915 C
916  RETURN
917  END
918 *-- Author :
919 C
920 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
921 C
922  SUBROUTINE flksaa(NN,ECM)
923  IMPLICIT DOUBLE PRECISION (a-h,o-z)
924  SAVE
925 C QUARK CONTENT
926 C OF PROJECTILE AND TARGET
927 C (HADRONS / ALL NUCLEONS)
928 C first run sea quark flavors
929 C---------------------------------------------------------------------
930 *KEEP,INTMX.
931  parameter(intmx=2488,intmd=252)
932 *KEEP,DXQX.
933 C INCLUDE (XQXQ)
934 * NOTE: INTMX set via INCLUDE(INTMX)
935  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
936  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
937  * ,xpsu(248),xtsu(248)
938  * ,xpsut(248),xtsut(248)
939 *KEEP,INTNEW.
940  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
941  +ixpv,ixps,ixtv,ixts, intvv1(248),
942  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
943  +intss1(intmx),intss2(intmx),
944  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
945  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
946 
947 C /INTNEW/
948 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
949 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
950 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
951 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
952 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
953 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
954 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
955 C FROM PROJECTILE/TARGET NUCLEI
956 C-------------------
957 *KEEP,IFROTO.
958  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
959  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
960  +jhkknt
961  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
962  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
963  & mhkkhh(intmx),
964  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
965 *KEEP,LOZUO.
966  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
967  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
968  +intlo(intmx),inloss(intmx)
969 C /LOZUO/
970 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
971 C REJECTED IN KKEVT
972 C------------------
973 *KEEP,DIQI.
974  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
975  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
976  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
977  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
978 *KEEP,HKKEVT.
979 c INCLUDE (HKKEVT)
980  parameter(nmxhkk= 89998)
981 c PARAMETER (NMXHKK=25000)
982  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
983  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
984  +(4,nmxhkk)
985 C
986 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
987 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
988 C THE POSITIONS OF THE PROJECTILE NUCLEONS
989 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
990 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
991 C COMPLETELY CONSISTENT. THE TIMES IN THE
992 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
993 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
994 C
995 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
996 C
997 C NMXHKK: maximum numbers of entries (partons/particles) that can be
998 C stored in the commonblock.
999 C
1000 C NHKK: the actual number of entries stored in current event. These are
1001 C found in the first NHKK positions of the respective arrays below.
1002 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
1003 C entry.
1004 C
1005 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
1006 C = 0 : null entry.
1007 C = 1 : an existing entry, which has not decayed or fragmented.
1008 C This is the main class of entries which represents the
1009 C "final state" given by the generator.
1010 C = 2 : an entry which has decayed or fragmented and therefore
1011 C is not appearing in the final state, but is retained for
1012 C event history information.
1013 C = 3 : a documentation line, defined separately from the event
1014 C history. (incoming reacting
1015 C particles, etc.)
1016 C = 4 - 10 : undefined, but reserved for future standards.
1017 C = 11 - 20 : at the disposal of each model builder for constructs
1018 C specific to his program, but equivalent to a null line in the
1019 C context of any other program. One example is the cone defining
1020 C vector of HERWIG, another cluster or event axes of the JETSET
1021 C analysis routines.
1022 C = 21 - : at the disposal of users, in particular for event tracking
1023 C in the detector.
1024 C
1025 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
1026 C standard.
1027 C
1028 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
1029 C The value is 0 for initial entries.
1030 C
1031 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
1032 C one mother exist, in which case the value 0 is used. In cluster
1033 C fragmentation models, the two mothers would correspond to the q
1034 C and qbar which join to form a cluster. In string fragmentation,
1035 C the two mothers of a particle produced in the fragmentation would
1036 C be the two endpoints of the string (with the range in between
1037 C implied).
1038 C
1039 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
1040 C entry has not decayed, this is 0.
1041 C
1042 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
1043 C entry has not decayed, this is 0. It is assumed that the daughters
1044 C of a particle (or cluster or string) are stored sequentially, so
1045 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
1046 C daughters. Even in cases where only one daughter is defined (e.g.
1047 C K0 -> K0S) both values should be defined, to make for a uniform
1048 C approach in terms of loop constructions.
1049 C
1050 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
1051 C
1052 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
1053 C
1054 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
1055 C
1056 C PHKK(4,IHKK) : energy, in GeV.
1057 C
1058 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
1059 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
1060 C
1061 C VHKK(1,IHKK) : production vertex x position, in mm.
1062 C
1063 C VHKK(2,IHKK) : production vertex y position, in mm.
1064 C
1065 C VHKK(3,IHKK) : production vertex z position, in mm.
1066 C
1067 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
1068 C********************************************************************
1069 *KEEP,NUCC.
1070  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1071 *KEEP,DPAR.
1072 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1073 C ANAME = LITERAL NAME OF THE PARTICLE
1074 C AAM = PARTICLE MASS IN GEV
1075 C GA = DECAY WIDTH
1076 C TAU = LIFE TIME OF INSTABLE PARTICLES
1077 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1078 C IIBAR = BARYON NUMBER
1079 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1080 C
1081  CHARACTER*8 aname
1082  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1083  +iibar(210),k1(210),k2(210)
1084 C------------------
1085 *KEEP,DPRIN.
1086  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1087 *KEEP,PROJK.
1088  COMMON /projk/ iprojk
1089  COMMON /seasu3/seasq
1090 C COMMON /PCHARM/PCCCC
1091  parameter(ummm=0.3d0)
1092  parameter(smmm=0.5d0)
1093  parameter(cmmm=1.3d0)
1094  DATA pc/0.0001d0/
1095 *KEND.
1096 C----------
1097 C DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
1098 C DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
1099 C DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
1100 C +-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
1101 C +0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
1102 C----------------------------------------------------------------------
1103 C
1104 C FLAVORS OF VALENCE QUARKS FROM PROJECTILE HADRON/NUCLEONS
1105 C
1106 C-----
1107 C
1108  DATA inicha/0/
1109 C----------------------------------------------------------------------
1110 C Initialize Charm selection at soft chain ends
1111 C
1112  IF(inicha.EQ.0)THEN
1113  rx=8.
1114  x1=rx
1115  gm=2.140
1116  x2=ummm
1117  betoo=7.5d0
1118  ENDIF
1119  rx=8.
1120  x1=rx
1121  betcha=betoo+1.3-log10(ecm)
1122  pu=dbeta(x1,x2,betcha)
1123  x2=smmm
1124  ps=dbeta(x1,x2,betcha)
1125  x2=cmmm
1126  pc=dbeta(x1,x2,betcha)
1127 C PU1=PU/(2*PU+PS+PC)
1128 C PS1=PS/(2*PU+PS+PC)
1129  pc1=pc/(2*pu+ps+pc)
1130 C changed j.r.7.12.94
1131 C PC=PC1/2.9
1132 C changed j.r.14.12.94
1133 C PC=PC1/5.0
1134 C PC=PC1/10.0
1135  pc=pc1/7.0
1136  pu1=pu/(2*pu+ps+pc)
1137  ps1=ps/(2*pu+ps+pc)
1138  IF(inicha.EQ.0)THEN
1139  inicha=1
1140  WRITE(6,4567)pc,betcha,pu1,ps1
1141  4567 FORMAT(' Charm at chain ends FLKSAA: PC,BETCHA,PU,PS ',4f10.5)
1142  ENDIF
1143 C----------------------------------------------------------------------
1144 C
1145  IF(ipev.GE.3) WRITE(6,'(A,6I4)')
1146  +' FLKSAA-ENTRY: IT,ITZ, IP,IPZ, IJPROJ,IBPROJ', it,itz,ip,ipz,
1147  +ijproj,ibproj
1148 C
1149  ixpss=nn
1150  ixtss=nn
1151 C
1152 C*********************************************************************
1153 C
1154 C-------------------------------SAMPLING PROJECTILE SEA FLAVORS-------
1155 C
1156 C*********************************************************************
1157 C
1158  DO 20 n=1,ixpss
1159  is=1
1160  rr=rndm(v)
1161  is=1.d0+rndm(v1)*(2.d0+seasq)
1162  IF(rr.LT.pc)is=4
1163  ipsq(n)=is
1164  ipsaq(n)=-is
1165  IF (ipev.GE.8) WRITE (6,1010) n,ipsq(n),ipsaq(n)
1166  1010 FORMAT (' FLKSAA: N,IPSQ(N),IPSAQ(N) ',3i4)
1167 C
1168  20 CONTINUE
1169 C
1170 C*********************************************************************
1171 C
1172 C-------------------------------SAMPLING TARGET SEA FLAVORS-------
1173 C
1174 C*********************************************************************
1175 C
1176  DO 40 n=1,ixtss
1177  is=1
1178  rr=rndm(v)
1179  is=1.d0+rndm(v1)*(2.d0+seasq)
1180  IF(rr.LT.pc)is=4
1181  itsq(n)=is
1182  itsaq(n)=-is
1183  IF (ipev.GE.8) WRITE (6,1020) n,itsq(n),itsaq(n)
1184  1020 FORMAT (' FLKSAA: N,ITSQ(N),ITSAQ(N) ',3i4)
1185 C
1186  40 CONTINUE
1187 C
1188  RETURN
1189  END
1190 *-- Author :
1191 C
1192 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1193 C
1194  SUBROUTINE flahad(ITYP,IBAR,IF1,IF2,IF3)
1195  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1196  SAVE
1197 C
1198 C QUARK FLAVOR COMPOSITION FOR HADRONS
1199 C ITYP : NUMBERING AS FOR BAMJET ...
1200 C LE.30 !!!!!!!!!!
1201 C
1202 C----------------------------------------------------------------------
1203 C
1204 *KEEP,DPRIN.
1205  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1206 *KEND.
1207  dimension mquark(3,30)
1208  DATA mquark/ 2,1,1, -2,-1,-1, 0,0,0, 0,0,0, 0,0,0, 0,0,0, 0,0,0,
1209  +2,2,1, -2,-2,-1, 0,0,0, 0,0,0, 0,0,0, 1,-2,0, 2,-1,0, 1,-3,0, 3,
1210  +-1,0, 1,2,3, -1,-2,-3, 0,0,0, 2,2,3, 1,1,3, 1,2,3, 1,-1,0, 2,-3,0,
1211  +3,-2,0, 2,-2,0, 3,-3,0, 0,0,0, 0,0,0, 0,0,0/
1212 C----------------------------------------------------------------------
1213  IF(ibar.NE.0) THEN
1214  ipq1 = mquark(1,ityp)
1215  ipq2 = mquark(2,ityp)
1216  ipq3 = mquark(3,ityp)
1217 C
1218  IF(ipev.GE.3) print 1000, ityp,ibar
1219  1000 FORMAT(' FLAHAD: ITYP,IBAR',2i5)
1220 C
1221  isam5=1. + 6.*rndm(v)
1222  go to(10,20,30,40,50,60),isam5
1223  10 CONTINUE
1224  if1=ipq1
1225  if2=ipq2
1226  if3=ipq3
1227  go to 70
1228  20 CONTINUE
1229  if1=ipq2
1230  if2=ipq3
1231  if3=ipq1
1232  go to 70
1233  30 CONTINUE
1234  if1=ipq3
1235  if2=ipq1
1236  if3=ipq2
1237  go to 70
1238  40 CONTINUE
1239  if1=ipq1
1240  if2=ipq3
1241  if3=ipq2
1242  go to 70
1243  50 CONTINUE
1244  if1=ipq2
1245  if2=ipq1
1246  if3=ipq3
1247  go to 70
1248  60 CONTINUE
1249  if1=ipq3
1250  if2=ipq2
1251  if3=ipq1
1252  70 CONTINUE
1253  IF (ipev.GE.3) WRITE (6,1010) if1,if2,if3
1254  1010 FORMAT (' FLAHAD: IF1,IF2,IF3 ',3i4)
1255  ELSE
1256 C VALENCE QUARK FLAVORS FOR MESONS
1257  if1=mquark(1,ityp)
1258  if2=mquark(2,ityp)
1259  if3=0
1260  IF(ipev.GE.3) THEN
1261  WRITE(6,'(A,6I4)') ' FLAHAD (MESON): IF1,IF2,IF3', if1,if2,if3
1262 
1263 
1264  ENDIF
1265  ENDIF
1266 C
1267  RETURN
1268  END
1269 *-- Author :
1270 C
1271 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1272 C
1273  SUBROUTINE xksamp(NN,ECM)
1274  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1275  SAVE
1276 *-----------------------------------------------------------
1277 * SAMPLING MOMENTUM FRACTIONS OF QUARKS AND DIQUARKS
1278 *-----------------------------------------------------------
1279 *KEEP,DINPDA.
1280  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
1281  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
1282 *KEEP,INTMX.
1283  parameter(intmx=2488,intmd=252)
1284  parameter(amis=0.8d0,amas=2.6d0,amiu=0.5d0,amau=2.6d0)
1285 *KEEP,DXQX.
1286 C INCLUDE (XQXQ)
1287 * NOTE: INTMX set via INCLUDE(INTMX)
1288  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
1289  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
1290  * ,xpsu(248),xtsu(248)
1291  * ,xpsut(248),xtsut(248)
1292 *KEEP,INTNEW.
1293  COMMON /intnez/ndz,nzd
1294  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
1295  +ixpv,ixps,ixtv,ixts, intvv1(248),
1296  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
1297  +intss1(intmx),intss2(intmx),
1298  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
1299  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
1300 
1301 C /INTNEW/
1302 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
1303 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
1304 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
1305 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
1306 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
1307 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
1308 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
1309 C FROM PROJECTILE/TARGET NUCLEI
1310 C-------------------
1311 *KEEP,IFROTO.
1312  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
1313  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
1314  +jhkknt
1315  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
1316  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
1317  & mhkkhh(intmx),
1318  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
1319 *KEEP,LOZUO.
1320  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
1321  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
1322  +intlo(intmx),inloss(intmx)
1323 C /LOZUO/
1324 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
1325 C REJECTED IN KKEVT
1326 C------------------
1327 *KEEP,DIQI.
1328  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
1329  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
1330  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
1331  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
1332 *KEEP,HKKEVT.
1333 c INCLUDE (HKKEVT)
1334  parameter(nmxhkk= 89998)
1335 c PARAMETER (NMXHKK=25000)
1336  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
1337  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
1338  +(4,nmxhkk)
1339 C
1340 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
1341 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
1342 C THE POSITIONS OF THE PROJECTILE NUCLEONS
1343 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
1344 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
1345 C COMPLETELY CONSISTENT. THE TIMES IN THE
1346 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
1347 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
1348 C
1349 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
1350 C
1351 C NMXHKK: maximum numbers of entries (partons/particles) that can be
1352 C stored in the commonblock.
1353 C
1354 C NHKK: the actual number of entries stored in current event. These are
1355 C found in the first NHKK positions of the respective arrays below.
1356 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
1357 C entry.
1358 C
1359 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
1360 C = 0 : null entry.
1361 C = 1 : an existing entry, which has not decayed or fragmented.
1362 C This is the main class of entries which represents the
1363 C "final state" given by the generator.
1364 C = 2 : an entry which has decayed or fragmented and therefore
1365 C is not appearing in the final state, but is retained for
1366 C event history information.
1367 C = 3 : a documentation line, defined separately from the event
1368 C history. (incoming reacting
1369 C particles, etc.)
1370 C = 4 - 10 : undefined, but reserved for future standards.
1371 C = 11 - 20 : at the disposal of each model builder for constructs
1372 C specific to his program, but equivalent to a null line in the
1373 C context of any other program. One example is the cone defining
1374 C vector of HERWIG, another cluster or event axes of the JETSET
1375 C analysis routines.
1376 C = 21 - : at the disposal of users, in particular for event tracking
1377 C in the detector.
1378 C
1379 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
1380 C standard.
1381 C
1382 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
1383 C The value is 0 for initial entries.
1384 C
1385 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
1386 C one mother exist, in which case the value 0 is used. In cluster
1387 C fragmentation models, the two mothers would correspond to the q
1388 C and qbar which join to form a cluster. In string fragmentation,
1389 C the two mothers of a particle produced in the fragmentation would
1390 C be the two endpoints of the string (with the range in between
1391 C implied).
1392 C
1393 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
1394 C entry has not decayed, this is 0.
1395 C
1396 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
1397 C entry has not decayed, this is 0. It is assumed that the daughters
1398 C of a particle (or cluster or string) are stored sequentially, so
1399 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
1400 C daughters. Even in cases where only one daughter is defined (e.g.
1401 C K0 -> K0S) both values should be defined, to make for a uniform
1402 C approach in terms of loop constructions.
1403 C
1404 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
1405 C
1406 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
1407 C
1408 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
1409 C
1410 C PHKK(4,IHKK) : energy, in GeV.
1411 C
1412 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
1413 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
1414 C
1415 C VHKK(1,IHKK) : production vertex x position, in mm.
1416 C
1417 C VHKK(2,IHKK) : production vertex y position, in mm.
1418 C
1419 C VHKK(3,IHKK) : production vertex z position, in mm.
1420 C
1421 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
1422 C********************************************************************
1423 *KEEP,SHMAKL.
1424 C INCLUDE (SHMAKL)
1425 * NOTE: INTMX set via INCLUDE(INTMX)
1426  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
1427 *KEEP,NUCC.
1428  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1429 *KEEP,DPAR.
1430 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1431 C ANAME = LITERAL NAME OF THE PARTICLE
1432 C AAM = PARTICLE MASS IN GEV
1433 C GA = DECAY WIDTH
1434 C TAU = LIFE TIME OF INSTABLE PARTICLES
1435 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1436 C IIBAR = BARYON NUMBER
1437 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1438 C
1439  CHARACTER*8 aname
1440  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1441  +iibar(210),k1(210),k2(210)
1442 C------------------
1443 *KEEP,DPRIN.
1444  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1445 *KEEP,NUCKOO.
1446  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
1447  +tpoo(3,intmx)
1448 *KEEP,PROJK.
1449  COMMON /projk/ iprojk
1450 *KEEP,XSEADI.
1451  COMMON /xseadi/ xseacu,unon,unom,unosea, cvq,cdq,csea,ssmima,
1452  +ssmimq,vvmthr
1453 *
1454 *KEEP,ABRVV.
1455  COMMON /abrvv/ amcvv1(248),amcvv2(248),gacvv1(248),gacvv2(248),
1456  +bgxvv1(248),bgyvv1(248),bgzvv1(248), bgxvv2(248),bgyvv2(248),
1457  +bgzvv2(248), nchvv1(248),nchvv2(248),ijcvv1(248),ijcvv2(248),
1458  +pqvva1(248,4),pqvva2(248,4), pqvvb1(248,4),pqvvb2(248,4)
1459 *KEEP,ABRSS.
1460 C INCLUDE (ABRSS)
1461  COMMON /abrss/ amcss1(intmx),amcss2(intmx), gacss1(intmx),gacss2
1462  +(intmx), bgxss1(intmx),bgyss1(intmx),bgzss1(intmx), bgxss2(intmx),
1463  +bgyss2(intmx),bgzss2(intmx), nchss1(intmx),nchss2(intmx), ijcss1
1464  +(intmx),ijcss2(intmx), pqssa1(intmx,4),pqssa2(intmx,4), pqssb1
1465  +(intmx,4),pqssb2(intmx,4)
1466 *KEEP,ABRVS.
1467  COMMON /abrvs/ amcvs1(248),amcvs2(248),gacvs1(248),gacvs2(248),
1468  +bgxvs1(248),bgyvs1(248),bgzvs1(248), bgxvs2(248),bgyvs2(248),
1469  +bgzvs2(248), nchvs1(248),nchvs2(248),ijcvs1(248),ijcvs2(248),
1470  +pqvsa1(248,4),pqvsa2(248,4), pqvsb1(248,4),pqvsb2(248,4)
1471 *KEEP,ABRSV.
1472  COMMON /abrsv/ amcsv1(248),amcsv2(248),gacsv1(248),gacsv2(248),
1473  +bgxsv1(248),bgysv1(248),bgzsv1(248), bgxsv2(248),bgysv2(248),
1474  +bgzsv2(248), nchsv1(248),nchsv2(248),ijcsv1(248),ijcsv2(248),
1475  +pqsva1(248,4),pqsva2(248,4), pqsvb1(248,4),pqsvb2(248,4)
1476 *KEND.
1477  LOGICAL lseadi
1478  COMMON /seadiq/lseadi
1479  common/recom/irecom
1480  common/diquax/amedd,idiqua,idiquu
1481  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
1482  COMMON /seaqxx/ seaqx,seaqxn
1483  dimension isxpvq(248),isxpvd(248),isxtvq(248),isxtvd(248)
1484  parameter(sqma=0.7d0)
1485 C*******************************************************************"
1486 C*** ACTUAL STANDARD VALUES FROM BLOCK DATA:
1487 C
1488 C CSEA=1.0, CVQ=1., CDQ=2.
1489 C UNON=2., UNOM=1.5, UNOSEA=2.0
1490 C----------------------------------
1491  parameter(nsea=3,nval=10)
1492  DATA icoun /0/
1493  DATA jcoun /0/
1494 * NSEA: maximum number of trials to generate x's for the required number
1495 * of sea quark pairs for a given hadron
1496 * changed from 10 to 3 22/04/92
1497 C---------------------------------------------------------------------
1498  jcoun=jcoun+1
1499  DO 10 i=1,ip
1500  jsshs(i)=0
1501  10 CONTINUE
1502  DO 20 i=1,it
1503  jtshs(i)=0
1504  20 CONTINUE
1505  DO 30 i=1,intmx
1506  zuosp(i)=.false.
1507  zuost(i)=.false.
1508  IF (i.GT.248) go to 30
1509  zuovp(i)=.false.
1510  zuovt(i)=.false.
1511  30 CONTINUE
1512  IF(ecm.LE.1.d-3)THEN
1513  WRITE(6,*)' xksamp: ECM=0.D0 '
1514  ecm=ecm+1.d-3
1515  ENDIF
1516  xsthr=csea/ecm
1517  IF(xsthr.LE.1.d-12)THEN
1518  WRITE(6,*)' xksamp 30 : XSTHR=0.D0 ',csea,ecm,xsthr
1519  xsthr=xsthr+1.d-12
1520  ENDIF
1521 C-----------------------------------------------------------------
1522 C
1523 C J.R.21.2.94
1524 C
1525 C----------------------------------------------------------------
1526 C j.r.12.3.97
1527 C j.r.11.4.97 part restored
1528  IF(ip.EQ.1) xsthr=4./ecm**2
1529 C test 28.4.97
1530 C IF(IP.EQ.1) XSTHR=4./ECM**2
1531  IF(xsthr.LE.1.d-12)THEN
1532  xsthr=xsthr+1.d-12
1533  ENDIF
1534 C----------------------------------------------------------------
1535 C-----------------------------------------------------------------
1536 C
1537 C J.R.16.3.95
1538 C
1539 C----------------------------------------------------------------
1540  IF(ip.GE.150.AND.it.GE.150) xsthr=2.5/(ecm*sqrt(ecm))
1541 C----------------------------------------------------------------
1542  bsqma=sqma/ecm
1543 C before 28.8.97
1544 C IF (ECM.LT.10.D0) XSTHR=((12.-ECM)/5.+1.)*CSEA/ECM
1545 C 28.4.97 test
1546  IF (ecm.LT.10.d0.AND.ip.GT.1)xsthr=((12.-ecm)/5.+1.)*csea/ecm
1547  xvthr=cvq/ecm
1548  xdthr=cdq/ecm
1549  IF (xvthr+xdthr.GT.0.90d0)THEN
1550  xvthr=0.95-xdthr
1551  IF(xvthr.LE.0.05d0)THEN
1552  WRITE (6,1000)ecm
1553  ENDIF
1554  ENDIF
1555  IF(ecm.LE.1.d-3)THEN
1556  WRITE(6,*)' xksamp: ECM=0.D0 '
1557  ecm=ecm+1.d-3
1558  ENDIF
1559  xssthr=ssmima/ecm
1560 C------------------------- 20.12.91.j.r.
1561  IF(jcoun.EQ.1)WRITE(6,'(A,4E15.5)')
1562  *' XKSAMP: XSTHR,XVTHR,XDTHR,XSSTHR ',
1563  * xsthr,xvthr,xdthr,xssthr
1564  IF(ipev.GE.1)WRITE(6,'(A,4E15.5)')
1565  *' XKSAMP: XSTHR,XVTHR,XDTHR,XSSTHR ',
1566  * xsthr,xvthr,xdthr,xssthr
1567 C-------------------------
1568 C TEST KINEMATICAL LIMITS
1569  IF (xvthr+xdthr.GT.0.95d0)THEN
1570  WRITE (6,1000)ecm
1571  1000 FORMAT (' PROGRAMM STOPPED IN XSAMP1 ECM = ',f6.2,' TOO SMALL')
1572  stop
1573  ENDIF
1574 C MAXIMUM NUMBER OF SEA-PAIRS ALLOWED KINEMATICALLY
1575 C XXSEAM=1.0 - XVTHR*(1.D0+RNDM(V1)) - XDTHR*(1.D0+RNDM(V2))
1576 C * -0.01*(1.D0+5.D0*RNDM(V3))
1577 C 28.4.97 test
1578  xxseam=1.0 - xvthr*(1.d0+0.3d0*rndm(v1))
1579  * - xdthr*(1.d0+0.3d0*rndm(v2))
1580  * -0.01*(1.d0+1.5d0*rndm(v3))
1581 C..............................................................
1582 C 1/x seaquarks
1583  IF(seaqxn.GE.0.75d0)THEN
1584  xsthr=8.*csea/ecm
1585 C 23.5.95
1586  xsthr=4.*csea/ecm
1587  xxseam=1.d0-xvthr-xdthr
1588 C MAXIMUM NUMBER OF SEA-PAIRS ALLOWED KINEMATICALLY
1589  xxseam=1.0 - xvthr*(1.d0+rndm(v1)) - xdthr*(1.d0+rndm(v2))
1590  * -0.01*(1.d0+5.d0*rndm(v3))
1591  ENDIF
1592 C..............................................................
1593  IF(xsthr.LE.1.d-9)THEN
1594  icoun=icoun+1
1595  IF(icoun.LE.50)THEN
1596  WRITE(6,*)' xksamp: XSTHR=0.D0 '
1597  WRITE(6,'(A,2E20.5,I10)')
1598  * ' XXSEAM,XSTHR,NSMAX',xxseam,xsthr,nsmax
1599  ENDIF
1600  xsthr=xsthr+1.d-9
1601  ENDIF
1602  nsmax=0.50*xxseam / xsthr
1603  IF(ipev.GE.1)WRITE(6,'(A,E15.5,I10)')
1604  * ' XXSEAM,NSMAX',xxseam,nsmax
1605 *--------------------------------------------------------------------
1606 *-------------------------------------------------------------------
1607 C Change XVTHR and XDTHR at low energies
1608 C TEST j.r. 9.2.95
1609  IF (xdthr.GT.0.14d0)xdthr=0.14d0
1610  IF (xvthr.GT.0.14d0)xvthr=0.14d0
1611 *--------------------------------------------------------------------
1612 C PARTON X-VALUES OF INTERACTING
1613 C PROJECTILE HADRON / NUCLEONS
1614  ixpv=0
1615  ixps=0
1616  unoprv=unon
1617  IF(ijproj.NE.0.AND.ibproj.EQ.0) unoprv=unom
1618  IF(jcoun.EQ.1)WRITE(6,'(A,4E15.5)')
1619  *' XKSAMP: XSTHR,XVTHR,XDTHR,XSSTHR ',
1620  * xsthr,xvthr,xdthr,xssthr
1621 * loop over projectile nucleons
1622  DO 100 ipp=1,ip
1623  IF (jssh(ipp).NE.0) THEN
1624 C--------------------------------------------------------------
1625 C prepare diquark rejection
1626 C--------------------------------------------------------------
1627  iixpss=ixps
1628  iixpvv=ixpv
1629  99 CONTINUE
1630  ixps=iixpss
1631  ixpv=iixpvv
1632 C--------------------------------------------------------------
1633  jipp=jssh(ipp)-1
1634  jipp=min(jipp,nsmax)
1635  41 CONTINUE
1636  xxsea=0.0
1637  IF(jipp.GT.0) THEN
1638 C j.r.11.12.97
1639  xsmax=xxseam - 1.5*jipp*xsthr
1640 C XSMAX=XXSEAM - 2.*JIPP*XSTHR
1641  IF(xsthr.GE.xsmax) THEN
1642  jipp=jipp-1
1643  goto 41
1644  ENDIF
1645 * x-values of sea-quark pairs
1646  nscoun=0
1647  40 CONTINUE
1648  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-40'
1649  xxsea=0.0
1650  nscoun=nscoun+1
1651  IF (nscoun.GT.nsea) THEN
1652  jipp=jipp-1
1653  nscoun=0
1654  ENDIF
1655  DO 70 isq=1,jipp
1656 C j.r.29.4.93---
1657  IF(ipsq(ixps+1).LE.2)THEN
1658 C..............................................................
1659 C 1/sqrt(x) seaquarks
1660  IF(seaqxn.LE.0.75d0)THEN
1661  xpsqi=sampex(xsthr,xsmax)
1662 C 1/x seaquarks
1663  ELSEIF(seaqxn.GT.0.75d0)THEN
1664  xpsqi=sampey(xsthr,xsmax)
1665  ENDIF
1666 C..............................................................
1667  IF(ipev.GE.1)WRITE(6,'(A,3E15.5)')
1668  * 'XPSQI 1:XPSQI,XSTHR,XSMAX',
1669  * xpsqi,xsthr,xsmax
1670  ELSE
1671  IF(xsmax.GT.xsthr+bsqma)THEN
1672  xpsqi=sampxb(xsthr+bsqma,xsmax,bsqma)
1673  IF(ipev.GE.1)WRITE(6,'(A,4E15.5)')
1674  * 'XPSQI 2:XPSQI,XSTHR,XSMAX,BSQMA',
1675  * xpsqi,xsthr,xsmax,bsqma
1676  ELSE
1677 C..............................................................
1678 C 1/sqrt(x) seaquarks
1679  IF(seaqxn.LE.0.75d0)THEN
1680  xpsqi=sampex(xsthr,xsmax)
1681 C 1/x seaquarks
1682  ELSEIF(seaqxn.GT.0.75d0)THEN
1683  xpsqi=sampey(xsthr,xsmax)
1684  ENDIF
1685 C..............................................................
1686  IF(ipev.GE.1)WRITE(6,'(A,3E15.5)')
1687  * 'XPSQI 3:XPSQI,XSTHR,XSMAX',
1688  * xpsqi,xsthr,xsmax
1689  ENDIF
1690  ENDIF
1691 C
1692  IF(ipsaq(ixps+1).GE.-2)THEN
1693 C..............................................................
1694 C 1/sqrt(x) seaquarks
1695  IF(seaqxn.LE.0.75d0)THEN
1696  xpsaqi=sampex(xsthr,xsmax)
1697 C 1/x seaquarks
1698  ELSEIF(seaqxn.GT.0.75d0)THEN
1699  xpsaqi=sampey(xsthr,xsmax)
1700  ENDIF
1701 C..............................................................
1702  IF(ipev.GE.1)WRITE(6,'(A,3E15.5)')
1703  * 'XPSAQI 1:XPSAQI,XSTHR,XSMAX',
1704  * xpsaqi,xsthr,xsmax
1705  ELSE
1706  IF(xsmax.GT.xsthr+bsqma)THEN
1707  xpsaqi=sampxb(xsthr+bsqma,xsmax,bsqma)
1708  IF(ipev.GE.1)WRITE(6,'(A,4E15.5)')
1709  * 'XPSAQI 2:XPSAQI,XSTHR,XSMAX,BSQMA',
1710  * xpsaqi,xsthr,xsmax,bsqma
1711  ELSE
1712 C..............................................................
1713 C 1/sqrt(x) seaquarks
1714  IF(seaqxn.LE.0.75d0)THEN
1715  xpsaqi=sampex(xsthr,xsmax)
1716 C 1/x seaquarks
1717  ELSEIF(seaqxn.GT.0.75d0)THEN
1718  xpsaqi=sampey(xsthr,xsmax)
1719  ENDIF
1720 C..............................................................
1721  IF(ipev.GE.1)WRITE(6,'(A,3E15.5)')
1722  * 'XPSAQI 3:XPSAQI,XSTHR,XSMAX',
1723  * xpsaqi,xsthr,xsmax
1724  ENDIF
1725  ENDIF
1726 C ---
1727  50 CONTINUE
1728  IF(ipev.GE.1)
1729  * WRITE(6,'(A,3E15.4)') ' XKSAMP-50: XPSQI,XSTHR,XSMAX',
1730  & xpsqi,xsthr,xsmax
1731  60 CONTINUE
1732  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-60'
1733  IF(ipev.GE.1)
1734  * WRITE(6,'(A,3E15.4)') ' XKSAMP-60: XPSAQI,XSTHR,XSMAX',
1735  & xpsaqi,xsthr,xsmax
1736  xxsea=xxsea + xpsqi + xpsaqi
1737  IF(xxsea.GE.xxseam) THEN
1738  ixps=ixps - isq + 1
1739  goto 40
1740  ENDIF
1741  ixps=ixps+1
1742  IF(ipev.GE.1)WRITE(6,'(A,I10)') ' XKSAMP-60: IXPS',ixps
1743  xpsq(ixps)=xpsqi
1744  xpsaq(ixps)=xpsaqi
1745 C Test 14.4.99
1746  xpsq(ixps)=xpsaqi
1747  xpsaq(ixps)=xpsqi
1748  ifrosp(ixps)=ipp
1749  zuosp(ixps)=.true.
1750  70 CONTINUE
1751  ENDIF
1752  jsshs(ipp)=jipp
1753 * projectile valence quarks
1754  80 CONTINUE
1755  IF(xvthr.GT.0.05d0)THEN
1756  IF(xvthr.GT.1.d0-xxsea-xdthr)THEN
1757  WRITE(6,*)' xvthr,xxsea,xdthr ', xvthr,xxsea,xdthr
1758  ENDIF
1759 C TEST 15.4.99
1760 C XPVQI=BETREJ(0.5D0,UNOPRV,XVTHR,1.D0-XXSEA-XDTHR)
1761  xpvqi=betrej(0.1d0,unoprv,xvthr,1.d0-xxsea-xdthr)
1762  81 CONTINUE
1763  ELSE
1764  90 CONTINUE
1765  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-90'
1766 C TEST 15.4.99
1767 C XPVQI=DBETAR(0.5D0,UNOPRV)
1768  xpvqi=dbetar(0.1d0,unoprv)
1769  IF ((xpvqi.LT.xvthr).OR.(1.d0-xpvqi-xxsea.LT.xdthr))
1770  * goto 90
1771  ENDIF
1772  xpvdi=1. - xpvqi - xxsea
1773 C CONSISTENCY TEST
1774 C TO BE FULFILLED AUTOMATICALLY
1775  IF(xpvdi.LT.xdthr) THEN
1776  WRITE(6,'(A/A/E12.3,4I4,3E11.3)')
1777  + ' INCONSISTENT X-SAMPLING / XKSAMP / PROJECTILE',
1778  + ' ECM, IP, IPP, JSSH(IPP), JIPP, XPVQI, XPVDI, XXSEA', ecm,
1779  + ip, ipp, jssh(ipp), jipp, xpvqi, xpvdi, xxsea
1780  stop
1781  ENDIF
1782 C
1783 C--------------------------------------------------------------
1784 C diquark rejection
1785 C Here we have a projectile diquark
1786 C Reject it according to xd**1.5 rule
1787 C--------------------------------------------------------------
1788  xtest=xpvdi**1.5
1789  vv=ipp
1790 C--------------------------------------------------------------
1791  ixpv=ixpv+1
1792  xpvq(ixpv)=xpvqi
1793  xpvd(ixpv)=xpvdi
1794  isxpvq(ixpv)=0
1795  isxpvd(ixpv)=0
1796  ifrovp(ixpv)=ipp
1797  itovp(ipp)=ixpv
1798  zuovp(ixpv)=.true.
1799  ENDIF
1800  100 CONTINUE
1801 C******************************
1802 C PARTON X-VALUES OF INTERACTING TARGET NUCLEONS
1803  ixtv=0
1804  ixts=0
1805  DO 170 itt=1,it
1806  IF (jtsh(itt).NE.0) THEN
1807 C--------------------------------------------------------------
1808 C prepare diquark rejection
1809 C--------------------------------------------------------------
1810  iixtss=ixts
1811  iixtvv=ixtv
1812  169 CONTINUE
1813  ixts=iixtss
1814  ixtv=iixtvv
1815 C--------------------------------------------------------------
1816  jitt=jtsh(itt)-1
1817  jitt=min(jitt,nsmax)
1818  111 CONTINUE
1819  xxsea=0.0
1820  IF(jitt.GT.0) THEN
1821 C j.r.11.12.97
1822  xsmax=xxseam -1.5*jitt*xsthr
1823 C XSMAX=XXSEAM - 2.*JITT*XSTHR
1824  IF(xsthr.GE.xsmax) THEN
1825  jitt=jitt-1
1826  goto 111
1827  ENDIF
1828  nscoun=0
1829  110 CONTINUE
1830  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-110'
1831  xxsea=0.0
1832  nscoun=nscoun+1
1833  IF (nscoun.GT.nsea)THEN
1834  jitt=jitt-1
1835  nscoun=0
1836  ENDIF
1837  DO 140 isq=1,jitt
1838 C CHANGE 23.5.90 / 13.9.90
1839 C IF(XSTHR.GT.0.05D0)THEN
1840 C J.R.29.4.93---
1841  IF(itsq(ixts+1).LE.2)THEN
1842 C..............................................................
1843 C 1/sqrt(x) seaquarks
1844  IF(seaqxn.LE.0.75d0)THEN
1845  xtsqi=sampex(xsthr,xsmax)
1846 C 1/x seaquarks
1847  ELSEIF(seaqxn.GT.0.75d0)THEN
1848  xtsqi=sampey(xsthr,xsmax)
1849  ENDIF
1850 C..............................................................
1851  ELSE
1852  IF(xsmax.GT.xsthr+bsqma)THEN
1853  xtsqi=sampxb(xsthr+bsqma,xsmax,bsqma)
1854  ELSE
1855 C..............................................................
1856 C 1/sqrt(x) seaquarks
1857  IF(seaqxn.LE.0.75d0)THEN
1858  xtsqi=sampex(xsthr,xsmax)
1859 C 1/x seaquarks
1860  ELSEIF(seaqxn.GT.0.75d0)THEN
1861  xtsqi=sampey(xsthr,xsmax)
1862  ENDIF
1863 C..............................................................
1864  ENDIF
1865  ENDIF
1866 C
1867  IF(itsaq(ixts+1).GE.-2)THEN
1868 C..............................................................
1869 C 1/sqrt(x) seaquarks
1870  IF(seaqxn.LE.0.75d0)THEN
1871  xtsaqi=sampex(xsthr,xsmax)
1872 C 1/x seaquarks
1873  ELSEIF(seaqxn.GT.0.75d0)THEN
1874  xtsaqi=sampey(xsthr,xsmax)
1875  ENDIF
1876 C..............................................................
1877  ELSE
1878  IF(xsmax.GT.xsthr+bsqma)THEN
1879  xtsaqi=sampxb(xsthr+bsqma,xsmax,bsqma)
1880  ELSE
1881 C..............................................................
1882 C 1/sqrt(x) seaquarks
1883  IF(seaqxn.LE.0.75d0)THEN
1884  xtsaqi=sampex(xsthr,xsmax)
1885 C 1/x seaquarks
1886  ELSEIF(seaqxn.GT.0.75d0)THEN
1887  xtsaqi=sampey(xsthr,xsmax)
1888  ENDIF
1889 C..............................................................
1890  ENDIF
1891  ENDIF
1892 C ---
1893 C XTSQI=SAMPEX(XSTHR,XSMAX)
1894 C
1895 C XTSAQI=SAMPEX(XSTHR,XSMAX)
1896 C ELSE
1897  120 CONTINUE
1898  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-120'
1899 C XTSQI=SAMPEX(XSTHR,XSMAX)
1900 C IF (XTSQI.LT.XSTHR.OR.XTSQI.GE.XSMAX) GOTO 120
1901  130 CONTINUE
1902  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-130'
1903 C XTSAQI=SAMPEX(XSTHR,XSMAX)
1904 C IF (XTSAQI.LT.XSTHR.OR.XTSAQI.GE.XSMAX) GOTO 130
1905 C ENDIF
1906  xxsea=xxsea + xtsqi + xtsaqi
1907  IF(xxsea.GE.xxseam) THEN
1908  ixts=ixts - isq + 1
1909  goto 110
1910  ENDIF
1911  ixts=ixts+1
1912  IF(ipev.GE.1)WRITE(6,'(A,I10)')' XKSAMP-130: IXTS',ixts
1913  xtsq(ixts)=xtsqi
1914  xtsaq(ixts)=xtsaqi
1915  ifrost(ixts)=itt
1916  zuost(ixts)=.true.
1917  140 CONTINUE
1918  ENDIF
1919  jtshs(itt)=jitt
1920 C
1921 C*** TARGET VALENCE QUARKS
1922  150 CONTINUE
1923  IF(xvthr.GT.0.05d0)THEN
1924  IF(xvthr.GT.1.d0-xxsea-xdthr)THEN
1925  WRITE(6,*)' xvthr,xxsea,xdthr ', xvthr,xxsea,xdthr
1926  ENDIF
1927 C TEST 15.4.99
1928 C XTVQI=BETREJ(0.5D0,UNON,XVTHR,1.-XXSEA-XDTHR)
1929  xtvqi=betrej(0.1d0,unon,xvthr,1.-xxsea-xdthr)
1930  151 CONTINUE
1931  ELSE
1932  160 CONTINUE
1933  IF(ipev.GE.1)WRITE(6,'(A)') ' XKSAMP-160'
1934 C TEST 15.4.99
1935 C XTVQI=DBETAR(0.5D0,UNON)
1936  xtvqi=dbetar(0.1d0,unon)
1937  xmist=1.-xtvqi-xxsea
1938  IF(ipev.GE.1)WRITE(6,'(A,5E15.5)')
1939  * ' XTVQI,XVTHR,XXSEA,XMIST,XDTHR',
1940  * xtvqi,xvthr,xxsea,xmist,xdthr
1941  IF((xtvqi.LT.xvthr).OR.(1.d0-xtvqi-xxsea.LT.xdthr+0.0001d0))
1942  * goto 160
1943  ENDIF
1944  xtvdi=1. - xtvqi - xxsea
1945 C CONSISTENCY TEST
1946 C TO BE FULFILLED AUTOMATICALLY
1947  IF(xtvdi.LT.xdthr) THEN
1948  WRITE(6,'(A/A/E12.3,4I4,3E11.3)')
1949  + ' INCONSISTENT X-SAMPLING / XKSAMP / TARGET',
1950  + ' ECM, IT, ITT, JTSH(ITT), JITT, XTVQI, XTVDI, XXSEA', ecm,
1951  + it, itt, jtsh(itt), jitt, xtvqi, xtvdi, xxsea
1952  stop
1953  ENDIF
1954 C
1955 C--------------------------------------------------------------
1956 C diquark rejection
1957 C Here we have a target diquark
1958 C Reject it according to xd**1.5 rule
1959 C--------------------------------------------------------------
1960  xtest=xtvdi**1.5
1961  vv=itt
1962 C IF(RNDM(VV).GT.XTEST)GO TO 169
1963 C--------------------------------------------------------------
1964  ixtv=ixtv+1
1965  xtvq(ixtv)=xtvqi
1966  xtvd(ixtv)=xtvdi
1967  isxtvq(ixtv)=0
1968  isxtvd(ixtv)=0
1969  ifrovt(ixtv)=itt
1970  itovt(itt)=ixtv
1971  zuovt(ixtv)=.true.
1972  ENDIF
1973  170 CONTINUE
1974 C
1975  IF (ipev.GE.6) THEN
1976  WRITE(6,1010)
1977  1010 FORMAT(' XKSAMP:',
1978  +' I,XPVQ(I),XPVD(I),IFROVP(I),ITOVP(I),ZUOVP(I),KKPROJ(I)')
1979  DO 180 i=1,ixpv
1980  WRITE(6,1020) i,xpvq(i),xpvd(i),ifrovp(i),itovp(i),zuovp(i),
1981  + kkproj(i)
1982  1020 FORMAT(i5,2e15.5,2i5,l5,i5)
1983  180 CONTINUE
1984  WRITE(6,1030)
1985  1030 FORMAT(' XKSAMP : I,XPSQ(I),XPSAQ(I),IFROSP(I),ZUOSP(I)')
1986  DO 190 i=1,ixps
1987  WRITE(6,1040) i,xpsq(i),xpsaq(i),ifrosp(i),zuosp(i)
1988  1040 FORMAT(i5,2e15.5,i5,l5)
1989  190 CONTINUE
1990 C
1991  WRITE(6,1050)
1992  1050 FORMAT(' XKSAMP:',
1993  +' I,XTVQ(I),XTVD(I),IFROVT(I),ITOVT(I),ZUOVT(I),KKTARG(I)')
1994  DO 200 i=1,ixtv
1995  WRITE(6,1020) i,xtvq(i),xtvd(i),ifrovt(i),itovt(i),zuovt(i),
1996  + kktarg(i)
1997  200 CONTINUE
1998  WRITE(6,1060)
1999  1060 FORMAT(' XKSAMP : I,XTSQ(I),XTSAQ(I),IFROST(I),ZUOST(I)')
2000  DO 210 i=1,ixts
2001  WRITE(6,1040) i,xtsq(i),xtsaq(i),ifrost(i),zuost(i)
2002  210 CONTINUE
2003  ENDIF
2004  IF(ipev.GE.6) THEN
2005  WRITE(6,'(A)')
2006  + ' XKSAMP : I,ITOVP(I),ITOVT(I),JSSHS(I),JTSHS(I)'
2007  ima=max(ip,it)
2008  DO 220 i=1,ima
2009  WRITE(6,1070) i,itovp(i),itovt(i),jsshs(i),jtshs(i)
2010  1070 FORMAT(5i5)
2011  220 CONTINUE
2012  DO 181 i=1,ixpv
2013  WRITE(6,*)' I,IPVQ(I),IPPV1(I),IPPV2(I) ',
2014  * i,ipvq(i),ippv1(i),ippv2(i)
2015  181 CONTINUE
2016  DO 182 i=1,ixtv
2017  WRITE(6,*)' I,ITVQ(I),ITTV1(I),ITTV2(I) ',
2018  * i,itvq(i),ittv1(i),ittv2(i)
2019  182 CONTINUE
2020  DO 183 i=1,ixps
2021  WRITE(6,*)' I,IPSQ(I),IPSAQ(I) ',
2022  * i,ipsq(i),ipsaq(i)
2023  183 CONTINUE
2024  DO 184 i=1,ixts
2025  WRITE(6,*)' I,ITSQ(I),ITSAQ(I) ',
2026  * i,itsq(i),itsaq(i)
2027  184 CONTINUE
2028  ENDIF
2029 C
2030 C----------------------------------------------------------------------
2031 C COLLECTION OF VALENCE-VALENCE PAIRS
2032  nvv=0
2033  IF(ipev.GE.4)WRITE(6,*)' collect v-v pairs NVV',nvv
2034  DO 230 i=1,nn
2035  intlo(i)=.true.
2036  230 CONTINUE
2037  DO 240 i=1,nn
2038  iipp=inter1(i)
2039  iitt=inter2(i)
2040  iippv=itovp(iipp)
2041  iittv=itovt(iitt)
2042  IF(zuovp(iippv).AND.zuovt(iittv)) THEN
2043  intlo(i)=.false.
2044  IF(ipev.GE.6)WRITE(6,'(A,5I5)')
2045  * ' XKSAMP v-v loop IIPP,IITT,IIPPV,IITTV,NVV',iipp,iitt,iippv,iittv,nvv
2046  zuovp(iippv)=.false.
2047  zuovt(iittv)=.false.
2048  nvv=nvv + 1
2049  IF(ipev.GE.4)WRITE(6,*)' collect v-v pairs NVV',nvv
2050  nchvv1(nvv)=0
2051  nchvv2(nvv)=0
2052  intvv1(nvv)=iippv
2053  intvv2(nvv)=iittv
2054 C -----------------------------------------------------J.R. 6.1.92
2055 C AMVVP2=XTVQ(IITTV)*XPVD(IIPPV)*ECM*ECM
2056 C IF(AMVVP2.GT.6.D0)THEN
2057 C RESAMPLE XTVQ
2058 C XTVQTH=6./(XPVD(IIPPV)*ECM*ECM)
2059 C XTVQXX=BETREJ(0.5D0,UNOPRV,XTVQTH,XTVQ(IITTV))
2060 C DXTVQ=XTVQ(IITTV)-XTVQXX
2061 C XTVQ(IITTV)=XTVQ(IITTV)-DXTVQ
2062 C XTVD(IITTV)=XTVD(IITTV)+DXTVQ
2063 C ENDIF
2064 C AMVVT2=XTVD(IITTV)*XPVQ(IIPPV)*ECM*ECM
2065 C IF(AMVVT2.GT.6.D0)THEN
2066 C RESAMPLE XPVQ
2067 C XPVQTH=6./(XTVD(IITTV)*ECM*ECM)
2068 C XPVQXX=BETREJ(0.5D0,UNOPRV,XPVQTH,XPVQ(IIPPV))
2069 C DXPVQ=XPVQ(IIPPV)-XPVQXX
2070 C XPVQ(IIPPV)=XPVQ(IIPPV)-DXPVQ
2071 C XPVD(IIPPV)=XPVD(IIPPV)+DXPVQ
2072 C ENDIF
2073 C--------------------------------------------------------------
2074  ENDIF
2075  240 CONTINUE
2076 C
2077 C COLLECTION OF THE SEA-VALENCE PAIRS
2078  ndv=0
2079  nsv=0
2080  DO 270 i=1,nn
2081  IF(intlo(i)) THEN
2082  iipp=inter1(i)
2083  iitt=inter2(i)
2084  iittv=itovt(iitt)
2085  DO 250 j=1,ixps
2086  IF(zuosp(j).AND.(ifrosp(j).EQ.iipp).AND.zuovt(iittv)) THEN
2087  zuosp(j)=.false.
2088  IF(ipev.GE.6)WRITE(6,'(A,6I5)')
2089  *' XKSAMP s-v loop I(NN),J(IXPS),iitt,iittv,NSV,NDV',
2090  + i,j, iitt,iittv,nsv,ndv
2091  zuovt(iittv)=.false.
2092  intlo(i)=.false.
2093 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2094  IF(rndm(v).GT.amedd.AND.idiqua.EQ.1)THEN
2095 C DEFINE D-V CHAINS (SEA-DIQUARK-VALENCE)
2096  CALL diqsv(ecm,iittv,j,irej)
2097  IF(irej.EQ.0)go to 260
2098  ENDIF
2099  nsv=nsv + 1
2100  nchsv1(nsv)=0
2101  nchsv2(nsv)=0
2102  intsv1(nsv)=j
2103  intsv2(nsv)=iittv
2104 C----------------correct sv chains to get minimum mass ------
2105 C IF(IP.GE.2)GO TO 5270
2106  amsvq1=xpsq(j)*xtvd(iittv)*ecm**2
2107  amsvq2=xpsaq(j)*xtvq(iittv)*ecm**2
2108  jxpv=itovp(iipp)
2109  IF(ipsq(j).EQ.3)THEN
2110  IF(amsvq1.GT.amas)THEN
2111  xpsqxx=(xtvd(iittv)*ecm**2)
2112  IF(xpsqxx.LE.1.d-1)xpsqxx=1.d-1
2113  xpsqth=amas/xpsqxx
2114  xpsqxx=sampex(xpsqth,xpsq(j))
2115  dxpsq=xpsq(j)-xpsqxx
2116  xpsq(j)=xpsq(j)-dxpsq
2117  xpvd(jxpv)=xpvd(jxpv)+dxpsq
2118  ELSEIF(amsvq1.LT.amas)THEN
2119  IF(xtvd(iittv)*ecm**2.LE.1.d-12)THEN
2120  WRITE(6,*)' xksamp: XTVD(IITTV)=0 ',iittv
2121  xtvd(iittv)=0.1d0
2122  ENDIF
2123  xpsqw=amas/(xtvd(iittv)*ecm**2)
2124  dxpsq=xpsqw-xpsq(j)
2125  isxtvd(iittv)=1
2126  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2127  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2128  xpsq(j)=xpsqw
2129  ENDIF
2130  ENDIF
2131  IF(amsvq2.GT.amis)THEN
2132  ELSEIF(amsvq2.LT.amis)THEN
2133  IF(xtvq(iittv)*ecm**2.LE.1.d-12)THEN
2134  WRITE(6,*)' xksamp: XTVQ(IITTV)=0 ',iittv
2135  xtvq(iittv)=0.1d0
2136  ENDIF
2137  xpsqw=amis/(xtvq(iittv)*ecm**2)
2138  dxpsq=xpsqw-xpsaq(j)
2139  isxtvq(iittv)=1
2140  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2141  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2142  xpsaq(j)=xpsqw
2143  ENDIF
2144  ENDIF
2145  ELSE
2146  IF(amsvq1.GT.amau)THEN
2147  IF(xtvd(iittv)*ecm**2.LE.1.d-12)THEN
2148  WRITE(6,*)' xksamp: XTVD(IITTV)=0 ',iittv
2149  xtvd(iittv)=0.1d0
2150  ENDIF
2151  xpsqth=amau/(xtvd(iittv)*ecm**2)
2152  xpsqxx=sampex(xpsqth,xpsq(j))
2153  dxpsq=xpsq(j)-xpsqxx
2154  xpsq(j)=xpsq(j)-dxpsq
2155  xpvd(jxpv)=xpvd(jxpv)+dxpsq
2156  ELSEIF(amsvq1.LT.amau)THEN
2157  IF(xtvd(iittv)*ecm**2.LE.1.d-12)THEN
2158  WRITE(6,*)' xksamp: XTVD(IITTV)=0 ',iittv
2159  xtvd(iittv)=0.1d0
2160  ENDIF
2161  xpsqw=amau/(xtvd(iittv)*ecm**2)
2162  dxpsq=xpsqw-xpsq(j)
2163  isxtvd(iittv)=1
2164  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2165  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2166  xpsq(j)=xpsqw
2167  ENDIF
2168  ENDIF
2169  IF(amsvq2.GT.amiu)THEN
2170  ELSEIF(amsvq2.LT.amiu)THEN
2171  IF(xtvq(iittv)*ecm**2.LE.1.d-12)THEN
2172  WRITE(6,*)' xksamp: XTVQ(IITTV)=0 ',iittv
2173  xtvq(iittv)=0.1d0
2174  ENDIF
2175  xpsqw=amiu/(xtvq(iittv)*ecm**2)
2176  dxpsq=xpsqw-xpsaq(j)
2177  isxtvq(iittv)=1
2178  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2179  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2180  xpsaq(j)=xpsqw
2181  ENDIF
2182  ENDIF
2183  ENDIF
2184 C5270 CONTINUE
2185 C-----------------------------------------------------------------
2186  goto 260
2187  ENDIF
2188  IF(ipev.GE.6)WRITE(6,'(A,6I5)')
2189  *' XKSAMP s-v loop I(NN),J(IXPS),iitt,iittv,NSV,NDV',
2190  + i,j, iitt,iittv,nsv,ndv
2191  250 CONTINUE
2192  ENDIF
2193  260 CONTINUE
2194  270 CONTINUE
2195 C
2196 C COLLECTION OF THE VALENCE-SEA PAIRS
2197  nvs=0
2198  nvd=0
2199  DO 300 i=1,nn
2200  IF(intlo(i)) THEN
2201  iipp=inter1(i)
2202  iitt=inter2(i)
2203  iippv=itovp(iipp)
2204  DO 280 j=1,ixts
2205  IF(zuovp(iippv).AND.zuost(j).AND.(ifrost(j).EQ.iitt)) THEN
2206  zuost(j)=.false.
2207  IF(ipev.GE.6)WRITE(6,*)
2208  * ' XKSAMP v-s loop IIPP,IITT,IIPPV,NVS,NVD,I,J,IXTS',
2209  * iipp,iitt,iippv,nvs,nvd,i,j,ixts
2210  zuovp(iippv)=.false.
2211  intlo(i)=.false.
2212 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2213  IF(rndm(v).GT.amedd.AND.idiqua.EQ.1)THEN
2214 C DEFINE V-D CHAINS (valence - sea diquark)
2215  CALL diqvs(ecm,iippv,j,irej)
2216  IF(ipev.GE.6)WRITE(6,*)
2217  * ' XKSAMP v-s loop IIPP,IITT,IIPPV,NVS,NVD,I,J,IXTS,JXTV'
2218  * ,iipp,iitt,iippv,nvs,nvd,i,j,ixts,jxtv
2219  IF(irej.EQ.0)go to 290
2220  ENDIF
2221  nvs=nvs + 1
2222  nchvs1(nvs)=0
2223  nchvs2(nvs)=0
2224  intvs1(nvs)=iippv
2225  intvs2(nvs)=j
2226 C----------------correct vs chains to get minimum mass ------
2227  amvsq1=xpvq(iippv)*xtsaq(j)*ecm**2
2228  amvsq2=xpvd(iippv)*xtsq(j)*ecm**2
2229  jxtv=itovt(iitt)
2230  IF(itsq(j).EQ.3)THEN
2231 C IF(AMVSQ1.GT.AMIS)THEN
2232  IF(amvsq1.LT.amis)THEN
2233  IF(xpvq(iippv)*ecm**2.LE.1.d-12)THEN
2234  WRITE(6,*)' xksamp: XPVQ(IIPPV)=0 ',iippv
2235  xpvq(iippv)=0.1d0
2236  ENDIF
2237  xtsqw=amis/(xpvq(iippv)*ecm**2)
2238  dxtsq=xtsqw-xtsaq(j)
2239  isxpvq(iippv)=1
2240  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2241  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2242  xtsaq(j)=xtsqw
2243  ENDIF
2244  ENDIF
2245  IF(amvsq2.GT.amas)THEN
2246  IF(xpvd(iippv)*ecm**2.LE.1.d-12)THEN
2247  WRITE(6,*)' xksamp: XPVD(IIPPV)=0 ',iippv
2248  xpvd(iippv)=0.1d0
2249  ENDIF
2250  xtsqth=amas/(xpvd(iippv)*ecm**2)
2251  xtsqxx=sampex(xtsqth,xtsq(j))
2252  dxtsq=xtsq(j)-xtsqxx
2253  xtsq(j)=xtsq(j)-dxtsq
2254  xtvd(jxtv)=xtvd(jxtv)+dxtsq
2255  ELSEIF(amvsq2.LT.amas)THEN
2256  IF(xpvd(iippv)*ecm**2.LE.1.d-12)THEN
2257  WRITE(6,*)' xksamp: XPVD(IIPPV)=0 ',iippv
2258  xpvd(iippv)=0.1d0
2259  ENDIF
2260  xtsqw=amas/(xpvd(iippv)*ecm**2)
2261  dxtsq=xtsqw-xtsq(j)
2262  isxpvd(iippv)=1
2263  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2264  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2265  xtsq(j)=xtsqw
2266  ENDIF
2267  ENDIF
2268  ELSE
2269 C IF(AMVSQ1.GT.AMIU)THEN
2270  IF(amvsq1.LT.amiu)THEN
2271  IF(xpvq(iippv)*ecm**2.LE.1.d-12)THEN
2272  WRITE(6,*)' xksamp: XPVQ(IIPPV)=0 ',iippv
2273  xpvq(iippv)=0.1d0
2274  ENDIF
2275  xtsqw=amiu/(xpvq(iippv)*ecm**2)
2276  dxtsq=xtsqw-xtsaq(j)
2277  isxpvq(iippv)=1
2278  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2279  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2280  xtsaq(j)=xtsqw
2281  ENDIF
2282  ENDIF
2283  IF(amvsq2.GT.amau)THEN
2284  IF(xpvd(iippv)*ecm**2.LE.1.d-12)THEN
2285  WRITE(6,*)' xksamp: XPVD(IIPPV)=0 ',iippv
2286  xpvd(iippv)=0.1d0
2287  ENDIF
2288  xtsqth=amau/(xpvd(iippv)*ecm**2)
2289  xtsqxx=sampex(xtsqth,xtsq(j))
2290  dxtsq=xtsq(j)-xtsqxx
2291  xtsq(j)=xtsq(j)-dxtsq
2292  xtvd(jxtv)=xtvd(jxtv)+dxtsq
2293  ELSEIF(amvsq2.LT.amau)THEN
2294  IF(xpvd(iippv)*ecm**2.LE.1.d-12)THEN
2295  WRITE(6,*)' xksamp: XPVD(IIPPV)=0 ',iippv
2296  xpvd(iippv)=0.1d0
2297  ENDIF
2298  xtsqw=amau/(xpvd(iippv)*ecm**2)
2299  dxtsq=xtsqw-xtsq(j)
2300  isxpvd(iippv)=1
2301  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2302  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2303  xtsq(j)=xtsqw
2304  ENDIF
2305  ENDIF
2306  ENDIF
2307 C-----------------------------------------------------------------
2308  goto 290
2309  ENDIF
2310  280 CONTINUE
2311  ENDIF
2312  290 CONTINUE
2313  300 CONTINUE
2314 C End loop: COLLECTION OF THE VALENCE-SEA PAIRS
2315 C
2316 C COLLECTION OF THE SEA-SEA PAIRS
2317 *--------------------- new version 8/03/1991 hjm
2318  nss=0
2319  nds=0
2320  nsd=0
2321  ndz=0
2322  nzd=0
2323  DO 420 i=1,nn
2324  IF(intlo(i)) THEN
2325  iipp=inter1(i)
2326  iitt=inter2(i)
2327  DO 400 j=1,ixts
2328  IF(zuost(j).AND.(ifrost(j).EQ.iitt)) THEN
2329  DO 390 jj=1,ixps
2330  IF(zuosp(jj).AND.(ifrosp(jj).EQ.iipp)) THEN
2331  nss=nss+1
2332  IF(ipev.GE.6)WRITE(6,'(A,5I5)')
2333  * ' XKSAMP s-s loop IIPP,IITT,NSS',iipp,iitt,nss
2334  nchss1(nss)=0
2335  nchss2(nss)=0
2336  IF(ipev.GE.6)WRITE(6,*)
2337  * ' XKSAMP s-s loop ,NCHSS1(NSS),NCHSS2(NSS),NSS ',
2338  * nchss1(nss),nchss2(nss),nss
2339  intss1(nss)=jj
2340  intss2(nss)=j
2341  intlo(i)=.false.
2342  zuost(j)=.false.
2343  zuosp(jj)=.false.
2344 C-------------------------------------------Mass check j.r.12/94-------
2345  ssma1q=xpsq(jj)*xtsaq(j)*ecm**2
2346  ssma2q=xpsaq(jj)*xtsq(j)*ecm**2
2347  IF(ssma1q.LT.1.2d0.OR.ssma2q.LT.1.2d0) THEN
2348  zuost(j)=.true.
2349  zuosp(jj)=.true.
2350  nss=nss-1
2351  go to 410
2352  ENDIF
2353 C-------------------------------------------Mass check j.r.12/94-------
2354 C**********************************************************************
2355 C**********************************************************************
2356 C
2357 C Chain recombination option
2358 C
2359  allket=(nvv+ixps+ixts)
2360  IF(allket.LE.1.d-5)THEN
2361  WRITE(6,*)' xksamp ALLKET=0' , allket
2362  allket=1.
2363  ENDIf
2364 C VALFRA=NVV/ALLKET
2365 C j.r.31.3.95
2366  anvvo=min(ixpv,ixtv)
2367  ansvo=ixtv-anvvo
2368  anvso=ixpv-anvvo
2369  ansso=(ixpv+ixps)-anvvo-ansvo-anvso
2370  IF(anvvo+ansso.LE.1.d-5)THEN
2371  WRITE(6,*)' xksamp (...)=0' ,anvvo,ansso
2372  ansso=1.
2373  ENDIf
2374 C VALFRA=1.D0
2375  IF(anvvo+ansso.GT.1.d-5)valfra=anvvo/(anvvo+ansso)
2376 C IF(IRECOM.EQ.1.AND.RNDM(VALFRA).GT.VALFRA)THEN
2377  IF(irecom.EQ.1)THEN
2378 C--- sea-sea pair found, is there a v-v pair suitable for recombination
2379 C 1. is there a v-v chain pair belonging to same projectile
2380 C 2. is there a v-v chain pair belonging to same target
2381  DO 4201 ivv=1,nvv
2382  IF (nchvv1(ivv).NE.99.AND.nchvv2(ivv).NE.99)THEN
2383  ixvpr=intvv1(ivv)
2384  inucpr=ifrovp(ixvpr)
2385  ixvta=intvv2(ivv)
2386  inucta=ifrovt(ixvta)
2387  IF(iipp.EQ.inucpr.OR.iitt.EQ.inucta)THEN
2388 C suitable v-v chain pair found, calculate masses of recombined ch's
2389 C old chains:
2390 C SSMA1Q=XPSQ(JJ)*XTSAQ(J)*ECM**2
2391 C SSMA2Q=XPSAQ(JJ)*XTSQ(J)*ECM**2
2392 C VVMA1Q=XPVQ(IXVPR)*XTVD(IXVTA)*ECM**2
2393 C VVMA2Q=XPVD(IXVPR)*XTVQ(IXVTA)*ECM**2
2394 C new chains:
2395 C SVMA1Q=XPSQ(JJ)*XTVD(IXVTA)*ECM**2
2396 C SVMA2Q=XPSAQ(JJ)*XTVQ(IXVTA)*ECM**2
2397 C VSMA1Q=XPVQ(IXVPR)*XTSAQ(J)*ECM**2
2398 C VSMA2Q=XPVD(IXVPR)*XTSQ(J)*ECM**2
2399 C
2400 C drop old v-v and s-s chains
2401 C
2402  nchss1(nss)=99
2403  nchss2(nss)=99
2404  nchvv1(ivv)=99
2405  nchvv2(ivv)=99
2406  IF(ipev.GE.6)WRITE(6,*)
2407  * ' XKSAMP before DIQSV ,NCHSS1(NSS),',
2408  * 'NCHSS2(NSS),NSS ',
2409  * nchss1(nss),nchss2(nss),nss
2410 C
2411 C assign new s-v and v-s chains
2412 C
2413 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2414  IF(rndm(v).GT.amedd.AND.idiqua.EQ.1)THEN
2415 C DEFINE D-V CHAINS (SEA-DIQUARK-VALENCE)
2416  CALL diqsv(ecm,ixvta,jj,irej)
2417  IF(irej.EQ.0)go to 4202
2418  ENDIF
2419  IF(ipev.GE.6)WRITE(6,*)
2420  * ' XKSAMP: NSS,NSV,NVS ',nss,nsv,nvs
2421  nsv=nsv+1
2422  intsv1(nsv)=jj
2423  intsv2(nsv)=ixvta
2424  IF(ipev.GE.6)WRITE(6,*)
2425  * ' XKSAMP: NSS,NSV,NVS ',nss,nsv,nvs
2426 C----------------correct sv chains to get minimum mass ------
2427  amsvq1=xpsq(jj)*xtvd(ixvta)*ecm**2
2428  amsvq2=xpsaq(jj)*xtvq(ixvta)*ecm**2
2429  jxpv=itovp(iipp)
2430  IF(ipev.GE.6)WRITE(6,'(A,5I5)')
2431  *' XKSAMP s-s loop rec sv,vs IXVTA,JXPV,JJ',ixvta,jxpv,jj
2432  IF(ipsq(jj).EQ.3)THEN
2433  IF(amsvq1.GT.amas)THEN
2434  IF(xtvd(ixvta)*ecm**2.LE.1.d-12)THEN
2435  WRITE(6,*)
2436  * ' xksamp: XTVD(IXVTA)=0 ',ixvta
2437  xtvd(ixvta)=0.1d0
2438  ENDIF
2439  xpsqth=amas/(xtvd(ixvta)*ecm**2)
2440  xpsqxx=sampex(xpsqth,xpsq(jj))
2441  dxpsq=xpsq(jj)-xpsqxx
2442  xpsq(jj)=xpsq(jj)-dxpsq
2443  xpvd(jxpv)=xpvd(jxpv)+dxpsq
2444  ELSEIF(amsvq1.LT.amas)THEN
2445  IF(xtvd(ixvta)*ecm**2.LE.1.d-12)THEN
2446  WRITE(6,*)
2447  * 'xksamp: XTVD(IXVTA)=0 ',ixvta
2448  xtvd(ixvta)=0.1d0
2449  ENDIF
2450  xpsqw=amas/(xtvd(ixvta)*ecm**2)
2451  dxpsq=xpsqw-xpsq(jj)
2452  isxtvd(ixvta)=1
2453  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2454  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2455  xpsq(jj)=xpsqw
2456  ENDIF
2457  ENDIF
2458 C IF(AMSVQ2.GT.AMIS)THEN
2459  IF(amsvq2.LT.amis)THEN
2460  IF(xtvq(ixvta)*ecm**2.LE.1.d-12)THEN
2461  WRITE(6,*)
2462  * ' xksamp: XTVQ(IXVTA)=0 ',ixvta
2463  xtvq(ixvta)=0.1d0
2464  ENDIF
2465  xpsqw=amis/(xtvq(ixvta)*ecm**2)
2466  dxpsq=xpsqw-xpsaq(jj)
2467  isxtvq(ixvta)=1
2468  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2469  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2470 C s.r.xpsaq statt xpsq! 1294
2471  xpsaq(jj)=xpsqw
2472  ENDIF
2473  ENDIF
2474  ELSE
2475  IF(amsvq1.GT.amau)THEN
2476  IF(xtvd(ixvta)*ecm**2.LE.1.d-12)THEN
2477  WRITE(6,*)
2478  * ' xksamp: XTVD(IXVTA)=0 ',ixvta
2479  xtvd(ixvta)=0.1d0
2480  ENDIF
2481  xpsqth=amau/(xtvd(ixvta)*ecm**2)
2482  xpsqxx=sampex(xpsqth,xpsq(jj))
2483  dxpsq=xpsq(jj)-xpsqxx
2484  xpsq(jj)=xpsq(jj)-dxpsq
2485  xpvd(jxpv)=xpvd(jxpv)+dxpsq
2486  ELSEIF(amsvq1.LT.amau)THEN
2487  IF(xtvd(ixvta)*ecm**2.LE.1.d-12)THEN
2488  WRITE(6,*)
2489  * ' xksamp: XTVD(IXVTA)=0 ',ixvta
2490  xtvd(ixvta)=0.1d0
2491  ENDIF
2492  xpsqw=amau/(xtvd(ixvta)*ecm**2)
2493  dxpsq=xpsqw-xpsq(jj)
2494  isxtvd(ixvta)=1
2495  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2496  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2497  xpsq(jj)=xpsqw
2498  ENDIF
2499  ENDIF
2500 C IF(AMSVQ2.GT.AMIU)THEN
2501  IF(amsvq2.LT.amiu)THEN
2502  IF(xtvq(ixvta)*ecm**2.LE.1.d-12)THEN
2503  WRITE(6,*)
2504  * ' xksamp: XTVQ(IXVTA)=0 ',ixvta
2505  xtvq(ixvta)=0.1d0
2506  ENDIF
2507  xpsqw=amiu/(xtvq(ixvta)*ecm**2)
2508  dxpsq=xpsqw-xpsaq(jj)
2509  isxtvq(ixvta)=1
2510  IF(xpvd(jxpv).GE.xdthr+dxpsq)THEN
2511  xpvd(jxpv)=xpvd(jxpv)-dxpsq
2512 C s.r.xpsaq statt xpsq! 1294
2513  xpsaq(jj)=xpsqw
2514  ENDIF
2515  ENDIF
2516  ENDIF
2517  4202 CONTINUE
2518 C-----------------------------------------------------------------
2519 C
2520 C assign new s-v and v-s chains
2521 C
2522 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2523  IF(rndm(v).GT.amedd.AND.idiqua.EQ.1)THEN
2524 C DEFINE V-D CHAINS (valence - sea diquark)
2525  CALL diqvs(ecm,ixvpr,j,irej)
2526  IF(irej.EQ.0)go to 4203
2527  ENDIF
2528  IF(ipev.GE.6)WRITE(6,*)
2529  * ' XKSAMP: NSS,NSV,NVS ',nss,nsv,nvs
2530  nvs=nvs+1
2531  intvs1(nvs)=ixvpr
2532  intvs2(nvs)=j
2533  IF(ipev.GE.6)WRITE(6,*)
2534  * ' XKSAMP: NSS,NSV,NVS ',nss,nsv,nvs
2535 C------###-------correct vs chains to get minimum mass ------
2536  amvsq1=xpvq(ixvpr)*xtsaq(j)*ecm**2
2537  amvsq2=xpvd(ixvpr)*xtsq(j)*ecm**2
2538  jxtv=itovt(iitt)
2539  IF(ipev.GE.6)WRITE(6,'(A,5I5)')
2540  *' XKSAMP s-s loop rec vs IXVTA,JXPV,JJ',ixvta,jxpv,jj
2541  IF(itsq(j).EQ.3)THEN
2542 C IF(AMVSQ1.GT.AMIS)THEN
2543  IF(amvsq1.LT.amis)THEN
2544  IF(xpvq(ixvpr)*ecm**2.LE.1.d-12)THEN
2545  WRITE(6,*)
2546  * ' xksamp: XPVQ(IXVPR)=0 ',ixvpr
2547  xpvq(ixvpr)=0.1d0
2548  ENDIF
2549  xtsqw=amis/(xpvq(ixvpr)*ecm**2)
2550  dxtsq=xtsqw-xtsaq(j)
2551  isxpvq(ixvpr)=1
2552  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2553  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2554  xtsaq(j)=xtsqw
2555  ENDIF
2556  ENDIF
2557  IF(amvsq2.GT.amas)THEN
2558  IF(xpvd(ixvpr)*ecm**2.LE.1.d-12)THEN
2559  WRITE(6,*)
2560  * ' xksamp: XPVD(IXVPR)=0 ',ixvpr
2561  xpvd(ixvpr)=0.1d0
2562  ENDIF
2563  xtsqth=amas/(xpvd(ixvpr)*ecm**2)
2564  xtsqxx=sampex(xtsqth,xtsq(j))
2565  dxtsq=xtsq(j)-xtsqxx
2566  xtsq(j)=xtsq(j)-dxtsq
2567  xtvd(jxtv)=xtvd(jxtv)+dxtsq
2568  ELSEIF(amvsq2.LT.amas)THEN
2569  IF(xpvd(ixvpr)*ecm**2.LE.1.d-12)THEN
2570  WRITE(6,*)
2571  * ' xksamp: XPVD(IXVPR)=0 ',ixvpr
2572  xpvd(ixvpr)=0.1d0
2573  ENDIF
2574  xtsqw=amas/(xpvd(ixvpr)*ecm**2)
2575  isxpvd(ixvpr)=1
2576  dxtsq=xtsqw-xtsq(j)
2577  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2578  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2579  xtsq(j)=xtsqw
2580  ENDIF
2581  ENDIF
2582  ELSE
2583 C IF(AMVSQ1.GT.AMIU)THEN
2584  IF(amvsq1.LT.amiu)THEN
2585  IF(xpvq(ixvpr)*ecm**2.LE.1.d-12)THEN
2586  WRITE(6,*)
2587  * ' xksamp: XPVQ(IXVPR)=0 ',ixvpr
2588  xpvq(ixvpr)=0.1d0
2589  ENDIF
2590  xtsqw=amiu/(xpvq(ixvpr)*ecm**2)
2591  dxtsq=xtsqw-xtsaq(j)
2592  isxpvq(ixvpr)=1
2593  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2594  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2595  xtsaq(j)=xtsqw
2596  ENDIF
2597  ENDIF
2598  IF(amvsq2.GT.amau)THEN
2599  IF(xpvd(ixvpr)*ecm**2.LE.1.d-12)THEN
2600  WRITE(6,*)
2601  * ' xksamp: XPVD(IXVPR)=0 ',ixvpr
2602  xpvd(ixvpr)=0.1d0
2603  ENDIF
2604  xtsqth=amau/(xpvd(ixvpr)*ecm**2)
2605  xtsqxx=sampex(xtsqth,xtsq(j))
2606  dxtsq=xtsq(j)-xtsqxx
2607  xtsq(j)=xtsq(j)-dxtsq
2608  xtvd(jxtv)=xtvd(jxtv)+dxtsq
2609  ELSEIF(amvsq2.LT.amau)THEN
2610  IF(xpvd(ixvpr)*ecm**2.LE.1.d-12)THEN
2611  WRITE(6,*)
2612  * ' xksamp: XPVD(IXVPR)=0 ',ixvpr
2613  xpvd(ixvpr)=0.1d0
2614  ENDIF
2615  xtsqw=amau/(xpvd(ixvpr)*ecm**2)
2616  dxtsq=xtsqw-xtsq(j)
2617  isxpvd(ixvpr)=1
2618  IF(xtvd(jxtv).GE.xdthr+dxtsq)THEN
2619  xtvd(jxtv)=xtvd(jxtv)-dxtsq
2620  xtsq(j)=xtsqw
2621  ENDIF
2622  ENDIF
2623  ENDIF
2624  4203 CONTINUE
2625 C-----------------------------------------------------------------
2626 C
2627 C jump out of s-s chain loop
2628 C
2629  go to 420
2630  ENDIF
2631  ENDIF
2632  4201 CONTINUE
2633  ENDIF
2634 C of loop recombination IF(IRECOM.EQ.1)THEN
2635 C**********************************************************************
2636 C we continue in s-s loop
2637 C**********************************************************************
2638 C
2639 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2640  IF(rndm(v).GT.2.d0*amedd-1.d0.AND.idiqua.EQ.1)THEN
2641 C DEFINE D-S CHAINS (SEA-DIQUARK---SEA)
2642  CALL diqdss(ecm,j,jj,irej)
2643  IF(irej.EQ.0) THEN
2644  nchss1(nss)=99
2645  nchss2(nss)=99
2646  IF(ipev.GE.6)WRITE(6,*)
2647  * ' XKSAMP AFTER DIQDSS IREJ=0',
2648  * ',NCHSS1(NSS),NCHSS2(NSS),NSS ',
2649  * nchss1(nss),nchss2(nss),nss
2650  go to 410
2651  ENDIF
2652  ENDIF
2653 C IF(LSEADI.AND.RNDM(V).GT.AMEDD.AND.IDIQUA.EQ.1)THEN
2654  IF(rndm(v).GT.2.d0*amedd-1.d0.AND.idiqua.EQ.1)THEN
2655 C DEFINE S-D CHAINS (SEA---SEA-DIQUARK)
2656  CALL diqssd(ecm,j,jj,irej)
2657  IF(irej.EQ.0) THEN
2658  nchss1(nss)=99
2659  nchss2(nss)=99
2660  IF(ipev.GE.6)WRITE(6,*)
2661  * ' XKSAMP AFTER DIQSSD IREJ=0',
2662  * ',NCHSS1(NSS),NCHSS2(NSS),NSS ',
2663  * nchss1(nss),nchss2(nss),nss
2664  go to 410
2665  ENDIF
2666  ENDIF
2667  ssma1q=xpsq(jj)*xtsaq(j)*ecm**2
2668  ssma2q=xpsaq(jj)*xtsq(j)*ecm**2
2669  IF(ssma1q.LT.ssmimq.OR.ssma2q.LT.ssmimq) THEN
2670  jxpv=itovp(iipp)
2671  jxtv=itovt(iitt)
2672  IF((xtvd(jxtv).GT.xdthr+3.5d0*xssthr)
2673  * .AND.(xpvd(jxpv)
2674  + .GT.xdthr+3.5d0*xssthr)) THEN
2675 * maximum allowed x values for sea quarks
2676  xspmax=1.0 - xpvq(jxpv) - xdthr - 1.2*xssthr
2677  xstmax=1.0 - xtvq(jxtv) - xdthr - 1.2*xssthr
2678 * resampling of x values not possible / discard s-s interaction
2679  IF((xspmax.LE.xssthr+0.05d0) .OR.(xstmax.LE.xssthr
2680  + +0.05d0)) goto 380
2681 * resampling for projectile sea quark pair
2682  icous=0
2683  310 CONTINUE
2684  icous=icous + 1
2685  IF(xssthr.GT.0.05d0) THEN
2686  xpsqi=betrej(xseacu,unosea,xssthr,xspmax)
2687  xpsaqi=betrej(xseacu,unosea,xssthr,xspmax)
2688  ELSE
2689  320 CONTINUE
2690  xpsqi=dbetar(xseacu,unosea)
2691  IF(xpsqi.LT.xssthr.OR.xpsqi.GT.xspmax) goto 320
2692  330 CONTINUE
2693  xpsaqi=dbetar(xseacu,unosea)
2694  IF(xpsaqi.LT.xssthr.OR.xpsaqi.GT.xspmax)
2695  + goto 330
2696  ENDIF
2697 * final test of remaining x for projectile diquark
2698  xpvdco=xpvd(jxpv) - xpsqi - xpsaqi + xpsq(jj) +
2699  + xpsaq(jj)
2700  IF(xpvdco.GT.xdthr) THEN
2701 * projectile x sampling ok / continue with target sea
2702  goto 340
2703  ELSEIF(icous.LT.5) THEN
2704  goto 310
2705  ELSE
2706 * too many unsuccessful attempts / discard s-s interaction
2707  goto 380
2708  ENDIF
2709 * resampling for target sea quark pair
2710  340 CONTINUE
2711  icous=0
2712  350 CONTINUE
2713  icous=icous + 1
2714  IF(xssthr.GT.0.05d0)THEN
2715  xtsqi=betrej(xseacu,unosea,xssthr,xstmax)
2716  xtsaqi=betrej(xseacu,unosea,xssthr,xstmax)
2717  ELSE
2718  360 CONTINUE
2719  xtsqi=dbetar(xseacu,unosea)
2720  IF(xtsqi.LT.xssthr.OR.xtsqi.GT.xstmax) goto 360
2721  370 CONTINUE
2722  xtsaqi=dbetar(xseacu,unosea)
2723  IF(xtsaqi.LT.xssthr.OR.xtsaqi.GT.xstmax)
2724  + goto 370
2725  ENDIF
2726 * final test of remaining x for target diquark
2727  xtvdco=xtvd(jxtv) - xtsqi - xtsaqi + xtsq(j) +
2728  + xtsaq(j)
2729  IF(xtvdco.LT.xdthr) THEN
2730 * repeat x sampling for target sea quarks
2731  IF(icous.LT.5) goto 350
2732 * discard s-s interaction / too many unsuccessful trials
2733  goto 380
2734  ENDIF
2735 * modification of x values acceptable
2736  xpvd(jxpv)=xpvdco
2737  xtvd(jxtv)=xtvdco
2738  xpsq(jj)=xpsqi
2739  xpsaq(jj)=xpsaqi
2740  xtsq(j)=xtsqi
2741  xtsaq(j)=xtsaqi
2742  goto 410
2743 * consider next s-s interaction
2744  ENDIF
2745 * discard s-s interaction
2746 * resampling of x values not allowed or unsuccessful
2747  380 CONTINUE
2748  intlo(i)=.false.
2749  zuost(j)=.true.
2750  zuosp(jj)=.true.
2751  nss=nss - 1
2752  ENDIF
2753 * consider next s-s interaction
2754  goto 410
2755  ENDIF
2756  390 CONTINUE
2757  ENDIF
2758  400 CONTINUE
2759  ENDIF
2760  410 CONTINUE
2761  420 CONTINUE
2762 C
2763 C CORRECT X-VALUES OF VALENCE QUARKS
2764 C FOR NON-MATCHING SEA QUARKS
2765  DO 430 i=1,ixps
2766  IF(zuosp(i)) THEN
2767  iifrop=ifrosp(i)
2768  iitop=itovp(iifrop)
2769  xpvq(iitop)=xpvq(iitop) + xpsq(i) + xpsaq(i)
2770  zuosp(i)=.false.
2771  ENDIF
2772  430 CONTINUE
2773  DO 440 i=1,ixts
2774  IF(zuost(i)) THEN
2775  iifrot=ifrost(i)
2776  iitot=itovt(iifrot)
2777  xtvq(iitot)=xtvq(iitot) + xtsq(i) + xtsaq(i)
2778  zuost(i)=.false.
2779  ENDIF
2780  440 CONTINUE
2781 C
2782  DO 450 i=1,ixpv
2783  IF(zuovp(i)) THEN
2784  ipip=ifrovp(i)
2785  isthkk(ipip)=13
2786  ENDIF
2787  450 CONTINUE
2788  DO 460 i=1,ixtv
2789  IF(zuovt(i)) THEN
2790  itit=ifrovt(i)
2791  isthkk(itit+ip)=14
2792  ENDIF
2793  460 CONTINUE
2794 C
2795  IF(ipev.GE.6) THEN
2796  WRITE(6,'(A)') ' XKSAMP: I,INTVV1,INTVV2,IFROVP,IFROVT'
2797  DO 470 i=1,nvv
2798  inup=intvv1(i)
2799  inut=intvv2(i)
2800  WRITE(6,'(5I5)') i,inup,inut,ifrovp(inup),ifrovt(inut)
2801  470 CONTINUE
2802  WRITE(6,'(A)')'XKSAMP:I(NSV),INTSV1,INTSV2,IFROSP,IFROVT'
2803  DO 480 i=1,nsv
2804  inup=intsv1(i)
2805  inut=intsv2(i)
2806  WRITE(6,'(5I5)') i,inup,inut,ifrosp(inup),ifrovt(inut)
2807  480 CONTINUE
2808  WRITE(6,'(A)') ' XKSAMP: I,INTVS1,INTVS2,IFROVP,IFROST'
2809  DO 490 i=1,nvs
2810  inup=intvs1(i)
2811  inut=intvs2(i)
2812  WRITE(6,'(5I5)') i,inup,inut,ifrovp(inup),ifrost(inut)
2813  490 CONTINUE
2814  WRITE(6,'(A)') ' XKSAMP: I,INTSS1,INTSS2,IFROSP,IFROST'
2815  DO 500 i=1,nss
2816  inup=intss1(i)
2817  inut=intss2(i)
2818  WRITE(6,'(5I5)') i,inup,inut,ifrosp(inup),ifrost(inut)
2819  500 CONTINUE
2820 C
2821  WRITE(6,'(A)')
2822  + ' XKSAMP : FINAL X-VALUES AFTER POTENTIAL CORRECTION'
2823  WRITE(6,1010)
2824  DO 510 i=1,ixpv
2825  WRITE(6,1020) i,xpvq(i),xpvd(i),ifrovp(i),itovp(i),zuovp(i)
2826  WRITE(6,*)' I(1-IXPV),IPVQ(I),IPPV1(I),IPPV2(I) ',
2827  * i,ipvq(i),ippv1(i),ippv2(i)
2828  510 CONTINUE
2829  WRITE(6,1030)
2830  DO 520 i=1,ixps
2831  WRITE(6,1040) i,xpsq(i),xpsaq(i),ifrosp(i),zuosp(i)
2832  WRITE(6,*)' I(1-IXPS),IPSQ(I),IPSAQ(I) ',
2833  * i,ipsq(i),ipsaq(i)
2834  520 CONTINUE
2835  WRITE(6,1050)
2836  DO 530 i=1,ixtv
2837  WRITE(6,1020) i,xtvq(i),xtvd(i),ifrovt(i),itovt(i),zuovt(i)
2838  WRITE(6,*)' I(1-IXTV),ITVQ(I),ITTV1(I),ITTV2(I) ',
2839  * i,itvq(i),ittv1(i),ittv2(i)
2840  530 CONTINUE
2841  WRITE(6,1060)
2842  DO 540 i=1,ixts
2843  WRITE(6,1040) i,xtsq(i),xtsaq(i),ifrost(i),zuost(i)
2844  WRITE(6,*)' I(1-IXTS),ITSQ(I),ITSAQ(I) ',
2845  * i,itsq(i),itsaq(i)
2846  540 CONTINUE
2847  ENDIF
2848  IF(ipev.GE.6)WRITE(6,'(A,6I5)')
2849  *' XKSAMP NSV,NDV,NVS,NVD',
2850  + nsv,ndv,nvs,nvd
2851 * store properties of interacting partons into /HKKEVT/
2852  CALL parhkk
2853  RETURN
2854  END
2855 *-- Author :
2856 *
2857 *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2858 *
2859  SUBROUTINE parhkk
2860  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2861  SAVE
2862 C
2863 C STORE INTERACTING PARTONS IN /HKKEVT/
2864 C X-VALUES STORED IN PHKK(3,...) AND PHKK(4,...)
2865 C POSITIONS OF NUCLEONS STORED IN VHKK
2866 C FLAG FOR PROJECTILE VALENCE: ISTHKK=21
2867 C PROJECTILE SEA : ISTHKK=31
2868 C FLAG FOR TARGET VALENCE : ISTHKK=22
2869 C TARGET SEA : ISTHKK=32
2870 *KEEP,INTMX.
2871  parameter(intmx=2488,intmd=252)
2872 *KEEP,DXQX.
2873 C INCLUDE (XQXQ)
2874 * NOTE: INTMX set via INCLUDE(INTMX)
2875  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
2876  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
2877  * ,xpsu(248),xtsu(248)
2878  * ,xpsut(248),xtsut(248)
2879 *KEEP,INTNEW.
2880  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
2881  +ixpv,ixps,ixtv,ixts, intvv1(248),
2882  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
2883  +intss1(intmx),intss2(intmx),
2884  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
2885  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
2886 
2887 C /INTNEW/
2888 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
2889 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
2890 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
2891 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
2892 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
2893 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
2894 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
2895 C FROM PROJECTILE/TARGET NUCLEI
2896 C-------------------
2897 *KEEP,IFROTO.
2898  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
2899  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
2900  +jhkknt
2901  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
2902  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
2903  & mhkkhh(intmx),
2904  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
2905 *KEEP,LOZUO.
2906  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
2907  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
2908  +intlo(intmx),inloss(intmx)
2909 C /LOZUO/
2910 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
2911 C REJECTED IN KKEVT
2912 C------------------
2913 *KEEP,DIQI.
2914  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
2915  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
2916  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
2917  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
2918 *KEEP,HKKEVT.
2919 c INCLUDE (HKKEVT)
2920  parameter(nmxhkk= 89998)
2921 c PARAMETER (NMXHKK=25000)
2922  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
2923  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
2924  +(4,nmxhkk)
2925 C
2926 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
2927 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
2928 C THE POSITIONS OF THE PROJECTILE NUCLEONS
2929 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
2930 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
2931 C COMPLETELY CONSISTENT. THE TIMES IN THE
2932 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
2933 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
2934 C
2935 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
2936 C
2937 C NMXHKK: maximum numbers of entries (partons/particles) that can be
2938 C stored in the commonblock.
2939 C
2940 C NHKK: the actual number of entries stored in current event. These are
2941 C found in the first NHKK positions of the respective arrays below.
2942 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
2943 C entry.
2944 C
2945 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
2946 C = 0 : null entry.
2947 C = 1 : an existing entry, which has not decayed or fragmented.
2948 C This is the main class of entries which represents the
2949 C "final state" given by the generator.
2950 C = 2 : an entry which has decayed or fragmented and therefore
2951 C is not appearing in the final state, but is retained for
2952 C event history information.
2953 C = 3 : a documentation line, defined separately from the event
2954 C history. (incoming reacting
2955 C particles, etc.)
2956 C = 4 - 10 : undefined, but reserved for future standards.
2957 C = 11 - 20 : at the disposal of each model builder for constructs
2958 C specific to his program, but equivalent to a null line in the
2959 C context of any other program. One example is the cone defining
2960 C vector of HERWIG, another cluster or event axes of the JETSET
2961 C analysis routines.
2962 C = 21 - : at the disposal of users, in particular for event tracking
2963 C in the detector.
2964 C
2965 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
2966 C standard.
2967 C
2968 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
2969 C The value is 0 for initial entries.
2970 C
2971 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
2972 C one mother exist, in which case the value 0 is used. In cluster
2973 C fragmentation models, the two mothers would correspond to the q
2974 C and qbar which join to form a cluster. In string fragmentation,
2975 C the two mothers of a particle produced in the fragmentation would
2976 C be the two endpoints of the string (with the range in between
2977 C implied).
2978 C
2979 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
2980 C entry has not decayed, this is 0.
2981 C
2982 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
2983 C entry has not decayed, this is 0. It is assumed that the daughters
2984 C of a particle (or cluster or string) are stored sequentially, so
2985 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
2986 C daughters. Even in cases where only one daughter is defined (e.g.
2987 C K0 -> K0S) both values should be defined, to make for a uniform
2988 C approach in terms of loop constructions.
2989 C
2990 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
2991 C
2992 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
2993 C
2994 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
2995 C
2996 C PHKK(4,IHKK) : energy, in GeV.
2997 C
2998 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
2999 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
3000 C
3001 C VHKK(1,IHKK) : production vertex x position, in mm.
3002 C
3003 C VHKK(2,IHKK) : production vertex y position, in mm.
3004 C
3005 C VHKK(3,IHKK) : production vertex z position, in mm.
3006 C
3007 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
3008 C********************************************************************
3009 *KEEP,SHMAKL.
3010 C INCLUDE (SHMAKL)
3011 * NOTE: INTMX set via INCLUDE(INTMX)
3012  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
3013 *KEEP,DPRIN.
3014  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3015 *KEND.
3016 C----------------------------------
3017  DO 10 i=1,ixpv
3018  nhkk=nhkk+1
3019  IF (nhkk.EQ.nmxhkk)THEN
3020  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3021  RETURN
3022  ENDIF
3023  isthkk(nhkk)=21
3024  kkkhkk=ifrovp(i)
3025  kkk=jhkknp(kkkhkk)
3026  jmohkk(1,nhkk)=kkk
3027  jmohkk(2,nhkk)=0
3028  jdahkk(1,nhkk)=0
3029  jdahkk(2,nhkk)=0
3030  phkk(1,nhkk)=0.
3031  phkk(2,nhkk)=0.
3032  phkk(3,nhkk)=xpvq(i)
3033  phkk(4,nhkk)=xpvq(i)
3034  phkk(5,nhkk)=0.
3035 C Add here position of parton in hadron
3036  vhkk(1,nhkk)=vhkk(1,kkk)
3037  vhkk(2,nhkk)=vhkk(2,kkk)
3038  vhkk(3,nhkk)=vhkk(3,kkk)
3039  vhkk(4,nhkk)=0.
3040 C
3041  IF (iphkk.GE.3) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3042  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3043  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3044 
3045 C
3046  nhkk=nhkk+1
3047  IF (nhkk.EQ.nmxhkk)THEN
3048  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3049  RETURN
3050  ENDIF
3051  isthkk(nhkk)=21
3052 C KKKHKK=IFROVP(I)
3053  kkk=jhkknp(kkkhkk)
3054  jmohkk(1,nhkk)=kkk
3055  jmohkk(2,nhkk)=0
3056  jdahkk(1,nhkk)=0
3057  jdahkk(2,nhkk)=0
3058  phkk(1,nhkk)=0.
3059  phkk(2,nhkk)=0.
3060  phkk(3,nhkk)=xpvd(i)
3061  phkk(4,nhkk)=xpvd(i)
3062  phkk(5,nhkk)=0.
3063 C Add here position of parton in hadron
3064  vhkk(1,nhkk)=vhkk(1,kkk)
3065  vhkk(2,nhkk)=vhkk(2,kkk)
3066  vhkk(3,nhkk)=vhkk(3,kkk)
3067  vhkk(4,nhkk)=0.
3068  jhkkpv(i)=nhkk
3069 C
3070  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3071  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3072  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3073 
3074  1000 FORMAT (i6,i4,5i6,9e10.2)
3075  10 CONTINUE
3076 C **** PROJECTILE SEA
3077  DO 20 i=1,ixps
3078  nhkk=nhkk+1
3079  IF (nhkk.EQ.nmxhkk)THEN
3080  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3081  RETURN
3082  ENDIF
3083  isthkk(nhkk)=31
3084  kkkhkk=ifrosp(i)
3085  kkk=jhkknp(kkkhkk)
3086  jmohkk(1,nhkk)=kkk
3087  jmohkk(2,nhkk)=0
3088  jdahkk(1,nhkk)=0
3089  jdahkk(2,nhkk)=0
3090  phkk(1,nhkk)=0.
3091  phkk(2,nhkk)=0.
3092  phkk(3,nhkk)=xpsq(i)
3093  phkk(4,nhkk)=xpsq(i)
3094  phkk(5,nhkk)=0.
3095 C Add here position of parton in hadron
3096  vhkk(1,nhkk)=vhkk(1,kkk)
3097  vhkk(2,nhkk)=vhkk(2,kkk)
3098  vhkk(3,nhkk)=vhkk(3,kkk)
3099  vhkk(4,nhkk)=0.
3100 C
3101  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3102  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3103  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3104 
3105 C
3106  nhkk=nhkk+1
3107  IF (nhkk.EQ.nmxhkk)THEN
3108  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3109  RETURN
3110  ENDIF
3111  isthkk(nhkk)=31
3112  kkkhkk=ifrosp(i)
3113  kkk=jhkknp(kkkhkk)
3114  jmohkk(1,nhkk)=kkk
3115  jmohkk(2,nhkk)=0
3116  jdahkk(1,nhkk)=0
3117  jdahkk(2,nhkk)=0
3118  phkk(1,nhkk)=0.
3119  phkk(2,nhkk)=0.
3120  phkk(3,nhkk)=xpsaq(i)
3121  phkk(4,nhkk)=xpsaq(i)
3122  phkk(5,nhkk)=0.
3123 C Add here position of parton in hadron
3124  vhkk(1,nhkk)=vhkk(1,kkk)
3125  vhkk(2,nhkk)=vhkk(2,kkk)
3126  vhkk(3,nhkk)=vhkk(3,kkk)
3127  vhkk(4,nhkk)=0.
3128  jhkkps(i)=nhkk
3129 C
3130  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3131  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3132  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3133 
3134  20 CONTINUE
3135 C ***** TARGET VALENCE
3136  DO 30 i=1,ixtv
3137  nhkk=nhkk+1
3138  IF (nhkk.EQ.nmxhkk)THEN
3139  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3140  RETURN
3141  ENDIF
3142  isthkk(nhkk)=22
3143  kkkhkk=ifrovt(i)
3144  kkk=jhkknt(kkkhkk)
3145  jmohkk(1,nhkk)=kkk
3146  jmohkk(2,nhkk)=0
3147  jdahkk(1,nhkk)=0
3148  jdahkk(2,nhkk)=0
3149  phkk(1,nhkk)=0.
3150  phkk(2,nhkk)=0.
3151  phkk(3,nhkk)=xtvq(i)
3152  phkk(4,nhkk)=xtvq(i)
3153  phkk(5,nhkk)=0.
3154 C Add here position of parton in hadron
3155  vhkk(1,nhkk)=vhkk(1,kkk)
3156  vhkk(2,nhkk)=vhkk(2,kkk)
3157  vhkk(3,nhkk)=vhkk(3,kkk)
3158  vhkk(4,nhkk)=0.
3159 C
3160  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3161  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3162  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3163 
3164 C
3165  nhkk=nhkk+1
3166  IF (nhkk.EQ.nmxhkk)THEN
3167  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3168  RETURN
3169  ENDIF
3170  isthkk(nhkk)=22
3171  kkkhkk=ifrovt(i)
3172  kkk=jhkknt(kkkhkk)
3173  jmohkk(1,nhkk)=kkk
3174  jmohkk(2,nhkk)=0
3175  jdahkk(1,nhkk)=0
3176  jdahkk(2,nhkk)=0
3177  phkk(1,nhkk)=0.
3178  phkk(2,nhkk)=0.
3179  phkk(3,nhkk)=xtvd(i)
3180  phkk(4,nhkk)=xtvd(i)
3181  phkk(5,nhkk)=0.
3182 C Add here position of parton in hadron
3183  vhkk(1,nhkk)=vhkk(1,kkk)
3184  vhkk(2,nhkk)=vhkk(2,kkk)
3185  vhkk(3,nhkk)=vhkk(3,kkk)
3186  vhkk(4,nhkk)=0.
3187  jhkktv(i)=nhkk
3188 C
3189  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3190  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3191  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3192 
3193  30 CONTINUE
3194 C ***** TARGET SEA
3195  DO 40 i=1,ixts
3196  nhkk=nhkk+1
3197  IF (nhkk.EQ.nmxhkk)THEN
3198  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3199  RETURN
3200  ENDIF
3201  isthkk(nhkk)=32
3202  kkkhkk=ifrost(i)
3203  kkk=jhkknt(kkkhkk)
3204  jmohkk(1,nhkk)=kkk
3205  jmohkk(2,nhkk)=0
3206  jdahkk(1,nhkk)=0
3207  jdahkk(2,nhkk)=0
3208  phkk(1,nhkk)=0.
3209  phkk(2,nhkk)=0.
3210  phkk(3,nhkk)=xtsq(i)
3211  phkk(4,nhkk)=xtsq(i)
3212  phkk(5,nhkk)=0.
3213 C Add here position of parton in hadron
3214  vhkk(1,nhkk)=vhkk(1,kkk)
3215  vhkk(2,nhkk)=vhkk(2,kkk)
3216  vhkk(3,nhkk)=vhkk(3,kkk)
3217  vhkk(4,nhkk)=0.
3218 C
3219  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3220  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3221  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3222 
3223 C
3224  nhkk=nhkk+1
3225  IF (nhkk.EQ.nmxhkk)THEN
3226  WRITE (6,'(A,2I5)') .EQ.' XKSAMP: NHKKNMXHKK ',nhkk,nmxhkk
3227  RETURN
3228  ENDIF
3229  isthkk(nhkk)=32
3230  kkkhkk=ifrost(i)
3231  kkk=jhkknt(kkkhkk)
3232  jmohkk(1,nhkk)=kkk
3233  jmohkk(2,nhkk)=0
3234  jdahkk(1,nhkk)=0
3235  jdahkk(2,nhkk)=0
3236  phkk(1,nhkk)=0.
3237  phkk(2,nhkk)=0.
3238  phkk(3,nhkk)=xtsaq(i)
3239  phkk(4,nhkk)=xtsaq(i)
3240  phkk(5,nhkk)=0.
3241 C Add here position of parton in hadron
3242  vhkk(1,nhkk)=vhkk(1,kkk)
3243  vhkk(2,nhkk)=vhkk(2,kkk)
3244  vhkk(3,nhkk)=vhkk(3,kkk)
3245  vhkk(4,nhkk)=0.
3246  jhkkts(i)=nhkk
3247 C
3248  IF (iphkk.GE.7) WRITE(6,1000) nhkk,isthkk(nhkk),idhkk(nhkk),
3249  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3250  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3251 
3252  40 CONTINUE
3253  RETURN
3254  END
3255 *-- Author :
3256 C
3257 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3258 C
3259  SUBROUTINE hadrkk(NHKKH1,PPN)
3260  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3261  SAVE
3262 C
3263 C HADRKK CONSTRUCTS ONE HADRONIZED EVENT FOR KK-COLLISIONS
3264 C ALL TYPES OF CHAINS ARE CONSIDERED
3265 C OPTONALLY GIVEN TYPES ARE SELECTED ACCORDING TO /DROPPT/
3266 C
3267 C--------------------------------------------------------------------
3268 *KEEP,INTMX.
3269  parameter(intmx=2488,intmd=252)
3270 *KEEP,DXQX.
3271 C INCLUDE (XQXQ)
3272 * NOTE: INTMX set via INCLUDE(INTMX)
3273  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
3274  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
3275  * ,xpsu(248),xtsu(248)
3276  * ,xpsut(248),xtsut(248)
3277 *KEEP,INTNEW.
3278  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
3279  +ixpv,ixps,ixtv,ixts, intvv1(248),
3280  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
3281  +intss1(intmx),intss2(intmx),
3282  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
3283  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
3284 
3285 C /INTNEW/
3286 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
3287 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
3288 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
3289 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
3290 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
3291 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
3292 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
3293 C FROM PROJECTILE/TARGET NUCLEI
3294 C-------------------
3295 *KEEP,IFROTO.
3296  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
3297  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
3298  +jhkknt
3299  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
3300  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
3301  & mhkkhh(intmx),
3302  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
3303 *KEEP,LOZUO.
3304  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
3305  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
3306  +intlo(intmx),inloss(intmx)
3307 C /LOZUO/
3308 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
3309 C REJECTED IN KKEVT
3310 C------------------
3311 *KEEP,DIQI.
3312  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
3313  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
3314  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
3315  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
3316 *KEEP,HKKEVT.
3317 c INCLUDE (HKKEVT)
3318  parameter(nmxhkk= 89998)
3319 c PARAMETER (NMXHKK=25000)
3320  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
3321  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
3322  +(4,nmxhkk)
3323 C
3324 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
3325 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
3326 C THE POSITIONS OF THE PROJECTILE NUCLEONS
3327 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
3328 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
3329 C COMPLETELY CONSISTENT. THE TIMES IN THE
3330 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
3331 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
3332 C
3333 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
3334 C
3335 C NMXHKK: maximum numbers of entries (partons/particles) that can be
3336 C stored in the commonblock.
3337 C
3338 C NHKK: the actual number of entries stored in current event. These are
3339 C found in the first NHKK positions of the respective arrays below.
3340 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
3341 C entry.
3342 C
3343 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
3344 C = 0 : null entry.
3345 C = 1 : an existing entry, which has not decayed or fragmented.
3346 C This is the main class of entries which represents the
3347 C "final state" given by the generator.
3348 C = 2 : an entry which has decayed or fragmented and therefore
3349 C is not appearing in the final state, but is retained for
3350 C event history information.
3351 C = 3 : a documentation line, defined separately from the event
3352 C history. (incoming reacting
3353 C particles, etc.)
3354 C = 4 - 10 : undefined, but reserved for future standards.
3355 C = 11 - 20 : at the disposal of each model builder for constructs
3356 C specific to his program, but equivalent to a null line in the
3357 C context of any other program. One example is the cone defining
3358 C vector of HERWIG, another cluster or event axes of the JETSET
3359 C analysis routines.
3360 C = 21 - : at the disposal of users, in particular for event tracking
3361 C in the detector.
3362 C
3363 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
3364 C standard.
3365 C
3366 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
3367 C The value is 0 for initial entries.
3368 C
3369 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
3370 C one mother exist, in which case the value 0 is used. In cluster
3371 C fragmentation models, the two mothers would correspond to the q
3372 C and qbar which join to form a cluster. In string fragmentation,
3373 C the two mothers of a particle produced in the fragmentation would
3374 C be the two endpoints of the string (with the range in between
3375 C implied).
3376 C
3377 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
3378 C entry has not decayed, this is 0.
3379 C
3380 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
3381 C entry has not decayed, this is 0. It is assumed that the daughters
3382 C of a particle (or cluster or string) are stored sequentially, so
3383 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
3384 C daughters. Even in cases where only one daughter is defined (e.g.
3385 C K0 -> K0S) both values should be defined, to make for a uniform
3386 C approach in terms of loop constructions.
3387 C
3388 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
3389 C
3390 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
3391 C
3392 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
3393 C
3394 C PHKK(4,IHKK) : energy, in GeV.
3395 C
3396 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
3397 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
3398 C
3399 C VHKK(1,IHKK) : production vertex x position, in mm.
3400 C
3401 C VHKK(2,IHKK) : production vertex y position, in mm.
3402 C
3403 C VHKK(3,IHKK) : production vertex z position, in mm.
3404 C
3405 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
3406 C********************************************************************
3407 *KEEP,SHMAKL.
3408 C INCLUDE (SHMAKL)
3409 * NOTE: INTMX set via INCLUDE(INTMX)
3410  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
3411 *KEEP,NNCMS.
3412  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
3413 *KEEP,DROPPT.
3414  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
3415  +ishmal,lpauli
3416  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
3417  +ipadis,ishmal,lpauli
3418 *KEEP,CMHICO.
3419  COMMON /cmhico/ cmhis
3420 *KEEP,DPRIN.
3421  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3422 *KEEP,DPAR.
3423 C /DPAR/ CONTAINS PARTICLE PROPERTIES
3424 C ANAME = LITERAL NAME OF THE PARTICLE
3425 C AAM = PARTICLE MASS IN GEV
3426 C GA = DECAY WIDTH
3427 C TAU = LIFE TIME OF INSTABLE PARTICLES
3428 C IICH = ELECTRIC CHARGE OF THE PARTICLE
3429 C IIBAR = BARYON NUMBER
3430 C K1,K1 = BEGIN AND END OF DECAY CHANNELS OF PARTICLE
3431 C
3432  CHARACTER*8 aname
3433  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
3434  +iibar(210),k1(210),k2(210)
3435 C------------------
3436 *KEND.
3437 C modified DPMJET
3438  COMMON /bufues/ bnnvv,bnnss,bnnsv,bnnvs,bnncc,
3439  * bnndv,bnnvd,bnnds,bnnsd,
3440  * bnnhh,bnnzz,
3441  * bptvv,bptss,bptsv,bptvs,bptcc,bptdv,
3442  * bptvd,bptds,bptsd,
3443  * bpthh,bptzz,
3444  * beevv,beess,beesv,beevs,beecc,beedv,
3445  * beevd,beeds,beesd,
3446  * beehh,beezz
3447  * ,bnndi,bptdi,beedi
3448  * ,bnnzd,bnndz,bptzd,bptdz,beezd,beedz
3449  COMMON /ncoucs/ bcouvv,bcouss,bcousv,bcouvs,
3450  * bcouzz,bcouhh,bcouds,bcousd,
3451  * bcoudz,bcouzd,bcoudi,
3452  * bcoudv,bcouvd,bcoucc
3453  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
3454  * anndv,annvd,annds,annsd,
3455  * annhh,annzz,
3456  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
3457  * pthh,ptzz,
3458  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
3459  * eehh,eezz
3460  * ,anndi,ptdi,eedi
3461  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
3462  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
3463  * acouzz,acouhh,acouds,acousd,
3464  * acoudz,acouzd,acoudi,
3465  * acoudv,acouvd,acoucc
3466 C---------------------
3467  COMMON /jspa/pxs(40000),pys(40000),pzs(40000),hes(40000),nnnps
3468 C---------------------
3469  COMMON /bamco/ nvdd
3470  LOGICAL lseadi
3471  COMMON /seadiq/ lseadi
3472  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
3473  common/diquax/amedd,idiqua,idiquu
3474  COMMON /secint/isecin
3475  DATA ievcou/0/
3476 C-------------
3477  nnnps=0
3478  ievcou=ievcou+1
3479  nhkkh1=nhkk
3480  IF (ipco.GE.1) WRITE(6,1000) nvv,nvs,nsv,nss
3481  1000 FORMAT (' ENTERING HADRKK NVV,NVS,NSV,NSS '/5i5)
3482 C----------------------------------------------------------------------
3483 C++++++++++++++ HADRONIZE SOFT SEA-SEA CHAINS ++++++++++++++++++++++
3484 C---
3485 C INITIALIZE COUNTERS
3486  annvv=0.001
3487  annss=0.001
3488  annsv=0.001
3489  annvs=0.001
3490  anncc=0.001
3491  anndv=0.001
3492  annvd=0.001
3493  annds=0.001
3494  annsd=0.001
3495  annhh=0.001
3496  annzz=0.001
3497  anndi=0.001
3498  annzd=0.001
3499  anndz=0.001
3500  ptvv=0.
3501  ptss=0.
3502  ptsv=0.
3503  ptvs=0.
3504  ptcc=0.
3505  ptdv=0.
3506  ptvd=0.
3507  ptds=0.
3508  ptsd=0.
3509  pthh=0.
3510  ptzz=0.
3511  ptdi=0.
3512  ptzd=0.
3513  ptdz=0.
3514  eevv=0.
3515  eess=0.
3516  eesv=0.
3517  eevs=0.
3518  eecc=0.
3519  eedv=0.
3520  eevd=0.
3521  eeds=0.
3522  eesd=0.
3523  eehh=0.
3524  eezz=0.
3525  eedi=0.
3526  eezd=0.
3527  eedz=0.
3528 C COMMON /NCOUCH/ ACOUVV,ACOUSS,ACOUSV,ACOUVS,
3529 C * ACOUZZ,ACOUHH,ACOUDS,ACOUSD,
3530 C * ACOUDZ,ACOUZD,ACOUDI
3531  acouvv=0.
3532  acouss=0.
3533  acousv=0.
3534  acouvs=0.
3535  acouzz=0.
3536  acouhh=0.
3537  acouds=0.
3538  acousd=0.
3539  acoudz=0.
3540  acouzd=0.
3541  acoudi=0.
3542  acoudv=0.
3543  acouvd=0.
3544  acoucc=0.
3545 *
3546  IF(ihada.OR.ihadss) THEN
3547  nvdd=0
3548  CALL hadrss
3549  ENDIF
3550  IF(ihada.OR.ihadsv) THEN
3551  CALL casasv
3552  ENDIF
3553  IF(ihada.OR.ihadvs) THEN
3554  CALL casavs
3555  ENDIF
3556  IF (iminij.EQ.1) CALL hadrhh
3557  CALL hadrzz
3558  IF(idiquu.EQ.1) CALL hadrdz
3559  IF(idiquu.EQ.1) CALL hadrzd
3560 C
3561 C
3562 C---------------------------------------------------------------
3563 C+++++++++++++++++++ HADRONIZE sea diquark - sea CHAINS +++++++
3564 C
3565 C IF(IHADA.OR.LSEADI) THEN
3566  IF(ihada) THEN
3567  nvdd=0
3568  IF(idiqua.EQ.1) CALL hadrds
3569  ENDIF
3570 C
3571 C+++++++++++++++++++ HADRONIZE sea - sea diquark CHAINS +++++++
3572 C
3573 C IF(IHADA.OR.LSEADI) THEN
3574  IF(ihada) THEN
3575  nvdd=0
3576  IF(idiqua.EQ.1) CALL hadrsd
3577  ENDIF
3578 C
3579 C
3580 C---------------------------------------------------------------
3581 C+++++++++++++++++++ HADRONIZE SEA-VALENCE CHAINS +++++++++++++++++
3582 C
3583  IF(ihada.OR.ihadsv) THEN
3584  nvdd=0
3585  CALL hadrsv
3586  ENDIF
3587 C
3588 C---------------------------------------------------------------
3589 C+++++++++++++++++++ HADRONIZE sea diquark - VALENCE CHAINS +++++++
3590 C
3591 C IF(IHADA.OR.LSEADI) THEN
3592  IF(ihada) THEN
3593  nvdd=0
3594  IF(idiqua.EQ.1) CALL hadrdv
3595  ENDIF
3596 C
3597 C----------------------------------------------------------------------
3598 C+++++++++++++++++++ HADRONIZE VALENCE-SEA CHAINS +++++++++++++++++
3599 C
3600  IF(ihada.OR.ihadvs) THEN
3601  nvdd=0
3602  CALL hadrvs
3603  ENDIF
3604 C
3605 C+++++++++++++++++++ HADRONIZE valence - sea diquark CHAINS +++++++
3606 C
3607 C IF(IHADA.OR.LSEADI) THEN
3608  IF(ihada) THEN
3609  nvdd=0
3610  IF(idiqua.EQ.1) CALL hadrvd
3611  ENDIF
3612 C
3613 C----------------------------------------------------------------------
3614 C HADRONIZE VALENCE-VALENCE CHAINS
3615 C---
3616  IF(ihada.OR.ihadvv) THEN
3617  nvdd=0
3618  CALL hadrvv
3619  ENDIF
3620 C
3621 C----------------------------------------------------------------------
3622 C HADRONIZE combined (qq)-(aqaq) chains
3623 C---
3624 C IF(IHADA.AND.LCOMBI) THEN
3625 C NVDD=15
3626 C CALL HADRCC
3627 C ENDIF
3628 C
3629 C---------------------------------------------------------------
3630 C OPTIONAL TEST OF
3631 C ENERGY-MOMENTUM CONSERVATION
3632 C IN NUCLEON-NUCLEON CMS
3633  IF (ipco.GE.1)THEN
3634  pxsu=0.
3635  pysu=0.
3636  pzsu=0.
3637  esum=0.
3638  ichsu=0
3639  ibasu=0
3640  WRITE(6,'(A)') ' HADRONS FROM HADRKK / NUCLEON-NUCLEON CMS'
3641  DO 10 i=nhkkh1+1,nhkk
3642  IF(isthkk(i).EQ.1)THEN
3643  pxsu=pxsu + phkk(1,i)
3644  pysu=pysu + phkk(2,i)
3645  pzsu=pzsu + phkk(3,i)
3646  esum=esum + phkk(4,i)
3647  nref=mcihad(idhkk(i))
3648  ichsu=ichsu + iich(nref)
3649  ibasu=ibasu + iibar(nref)
3650  IF (ipco.GE.7)
3651  * WRITE(6,1010)i,(phkk(j,i),j=1,5), iich(nref),iibar(nref),nref,
3652  + aname(nref)
3653  1010 FORMAT(5x,i4,5(1pe11.3),2i2,i5,a10)
3654  ENDIF
3655  10 CONTINUE
3656  WRITE(6,1020) pxsu,pysu,pzsu,esum,ichsu,ibasu
3657  1020 FORMAT(' PXSU,PYSU,PZSU,ESUM,ICHSU,IBASU'/4f10.3,2i5)
3658  ENDIF
3659 C
3660  CALL dechkk(nhkkh1)
3661 C
3662 C----------------------------------------------------------------------
3663 C LT FROM NUCLEON-NUCLEON CMS INTO LAB
3664 C PUT LAB SYSTEM PARTICLES INTO /HKKEVT/
3665  cmhiss=1.d0
3666  DO 20 i=nhkkh1+1,nhkk
3667  pznn=phkk(3,i)
3668  enn =phkk(4,i)
3669  IF (cmhiss.EQ.0.d0)THEN
3670 C PHKK(3,I) = GAMCM*PZNN + BGCM*ENN
3671 C PHKK(4,I) = GAMCM*ENN + BGCM*PZNN
3672  phkk(3,i) = gamcm*pznn + bgcm*enn
3673  phkk(4,i) = gamcm*enn + bgcm*pznn
3674  ENDIF
3675  ehecc=sqrt(phkk(1,i)** 2+ phkk(2,i)** 2+ phkk(3,i)** 2+ phkk
3676  + (5,i)**2)
3677  IF (abs(ehecc-phkk(4,i)).GT.0.001d0) THEN
3678 C WRITE(6,'(2A/3I5,3E16.6)')
3679 C & ' HADRKK: CORRECT INCONSISTENT ENERGY ',
3680 C * ' IEVCOU, I,IDHKK(I), PHKK(4,I),EHECC, PHKK(5,I)',
3681 C * IEVCOU, I,IDHKK(I), PHKK(4,I),EHECC, PHKK(5,I)
3682  phkk(4,i)=ehecc
3683  ENDIF
3684  20 CONTINUE
3685 C Secondary Interactions
3686  IF(isecin.EQ.1)CALL sewew(1,nhkkh1)
3687  ktauac=99
3688 C IF (CMHIS.EQ.0.D0) CALL DISTR(2,NHKKH1,PPN,KTAUAC)
3689 C
3690 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3691 C OPTIONAL TEST OF
3692 C ENERGY-MOMENTUM CONSERVATION IN LAB SYSTEM
3693  IF (ipco.GE.2)THEN
3694  pxsu=0.
3695  pysu=0.
3696  pzsu=0.
3697  esum=0.
3698  ichsu=0
3699  ibasu=0
3700  WRITE(6,'(A)') ' HADRONS FROM HADRKK / CMS SYSTEM'
3701  DO 30 i=nhkkh1+1,nhkk
3702  IF(isthkk(i).EQ.1)THEN
3703  pxsu=pxsu + phkk(1,i)
3704  pysu=pysu + phkk(2,i)
3705  pzsu=pzsu + phkk(3,i)
3706  esum=esum + phkk(4,i)
3707  nref=mcihad(idhkk(i))
3708  ichsu=ichsu + iich(nref)
3709  ibasu=ibasu + iibar(nref)
3710  IF (ipco.GE.7)
3711  * WRITE(6,1010) i, (phkk(j,i),j=1,5), iich(nref),iibar(nref),
3712  + nref,aname(nref)
3713  ENDIF
3714  30 CONTINUE
3715  WRITE(6,1020) pxsu,pysu,pzsu,esum,ichsu,ibasu
3716  ENDIF
3717 C
3718 C------------------------------------------------------------------
3719 C
3720  RETURN
3721  END
3722 *-- Author :
3723 C
3724 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3725 C
3726  SUBROUTINE hadrvv
3727  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3728  SAVE
3729 C
3730 C-------------------------
3731 C
3732 C HADRONIZE VALENCE-VALENCE CHAINS
3733 C
3734 C ADD GENERATED HADRONS TO /ALLPAR/
3735 C STARTING AT (NAUX + 1)
3736 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
3737 C
3738 C-------------------------
3739 *KEEP,INTMX.
3740  parameter(intmx=2488,intmd=252)
3741 *KEEP,DXQX.
3742 C INCLUDE (XQXQ)
3743 * NOTE: INTMX set via INCLUDE(INTMX)
3744  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
3745  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
3746  * ,xpsu(248),xtsu(248)
3747  * ,xpsut(248),xtsut(248)
3748 *KEEP,INTNEW.
3749  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
3750  +ixpv,ixps,ixtv,ixts, intvv1(248),
3751  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
3752  +intss1(intmx),intss2(intmx),
3753  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
3754  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
3755 
3756 C /INTNEW/
3757 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
3758 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
3759 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
3760 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
3761 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
3762 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
3763 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
3764 C FROM PROJECTILE/TARGET NUCLEI
3765 C-------------------
3766 *KEEP,IFROTO.
3767  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
3768  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
3769  +jhkknt
3770  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
3771  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
3772  & mhkkhh(intmx),
3773  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
3774 *KEEP,LOZUO.
3775  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
3776  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
3777  +intlo(intmx),inloss(intmx)
3778 C /LOZUO/
3779 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
3780 C REJECTED IN KKEVT
3781 C------------------
3782 *KEEP,DIQI.
3783  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
3784  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
3785  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
3786  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
3787 *KEEP,HKKEVT.
3788 c INCLUDE (HKKEVT)
3789  parameter(nmxhkk= 89998)
3790 c PARAMETER (NMXHKK=25000)
3791  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
3792  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
3793  +(4,nmxhkk)
3794 C
3795 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
3796 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
3797 C THE POSITIONS OF THE PROJECTILE NUCLEONS
3798 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
3799 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
3800 C COMPLETELY CONSISTENT. THE TIMES IN THE
3801 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
3802 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
3803 C
3804 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
3805 C
3806 C NMXHKK: maximum numbers of entries (partons/particles) that can be
3807 C stored in the commonblock.
3808 C
3809 C NHKK: the actual number of entries stored in current event. These are
3810 C found in the first NHKK positions of the respective arrays below.
3811 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
3812 C entry.
3813 C
3814 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
3815 C = 0 : null entry.
3816 C = 1 : an existing entry, which has not decayed or fragmented.
3817 C This is the main class of entries which represents the
3818 C "final state" given by the generator.
3819 C = 2 : an entry which has decayed or fragmented and therefore
3820 C is not appearing in the final state, but is retained for
3821 C event history information.
3822 C = 3 : a documentation line, defined separately from the event
3823 C history. (incoming reacting
3824 C particles, etc.)
3825 C = 4 - 10 : undefined, but reserved for future standards.
3826 C = 11 - 20 : at the disposal of each model builder for constructs
3827 C specific to his program, but equivalent to a null line in the
3828 C context of any other program. One example is the cone defining
3829 C vector of HERWIG, another cluster or event axes of the JETSET
3830 C analysis routines.
3831 C = 21 - : at the disposal of users, in particular for event tracking
3832 C in the detector.
3833 C
3834 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
3835 C standard.
3836 C
3837 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
3838 C The value is 0 for initial entries.
3839 C
3840 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
3841 C one mother exist, in which case the value 0 is used. In cluster
3842 C fragmentation models, the two mothers would correspond to the q
3843 C and qbar which join to form a cluster. In string fragmentation,
3844 C the two mothers of a particle produced in the fragmentation would
3845 C be the two endpoints of the string (with the range in between
3846 C implied).
3847 C
3848 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
3849 C entry has not decayed, this is 0.
3850 C
3851 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
3852 C entry has not decayed, this is 0. It is assumed that the daughters
3853 C of a particle (or cluster or string) are stored sequentially, so
3854 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
3855 C daughters. Even in cases where only one daughter is defined (e.g.
3856 C K0 -> K0S) both values should be defined, to make for a uniform
3857 C approach in terms of loop constructions.
3858 C
3859 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
3860 C
3861 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
3862 C
3863 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
3864 C
3865 C PHKK(4,IHKK) : energy, in GeV.
3866 C
3867 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
3868 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
3869 C
3870 C VHKK(1,IHKK) : production vertex x position, in mm.
3871 C
3872 C VHKK(2,IHKK) : production vertex y position, in mm.
3873 C
3874 C VHKK(3,IHKK) : production vertex z position, in mm.
3875 C
3876 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
3877 C********************************************************************
3878 *KEEP,NUCC.
3879  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
3880 *KEEP,ABRVV.
3881  COMMON /abrvv/ amcvv1(248),amcvv2(248),gacvv1(248),gacvv2(248),
3882  +bgxvv1(248),bgyvv1(248),bgzvv1(248), bgxvv2(248),bgyvv2(248),
3883  +bgzvv2(248), nchvv1(248),nchvv2(248),ijcvv1(248),ijcvv2(248),
3884  +pqvva1(248,4),pqvva2(248,4), pqvvb1(248,4),pqvvb2(248,4)
3885 *KEEP,DPRIN.
3886  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3887 *KEEP,DFINPA.
3888  CHARACTER*8 anf
3889  parameter(nfimax=249)
3890  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
3891  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
3892  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
3893  * istath(nfimax)
3894 *KEEP,PROJK.
3895  COMMON /projk/ iprojk
3896 *KEND.
3897 C modified DPMJET
3898  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
3899  * anndv,annvd,annds,annsd,
3900  * annhh,annzz,
3901  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
3902  * pthh,ptzz,
3903  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
3904  * eehh,eezz
3905  * ,anndi,ptdi,eedi
3906  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
3907  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
3908  * acouzz,acouhh,acouds,acousd,
3909  * acoudz,acouzd,acoudi,
3910  * acoudv,acouvd,acoucc
3911  common/popcck/pdbck,pdbse,pdbseu,
3912  * ijpock,irejck,ick4,ihad4,ick6,ihad6
3913  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
3914  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
3915  *isea43,isea63,irejao
3916 C---------------------
3917  COMMON /zsea/zseaav,zseasu,anzsea
3918 C---------------------
3919  dimension poj(4),pat(4)
3920  DATA ncalvv /0/
3921  IF(iphkk.GE.6)WRITE (6,'( A)') ' hadrVV'
3922 C-----------------------------------------------------------------
3923  ncalvv=ncalvv+1
3924  DO 50 i=1,nvv
3925 C-----------------------drop recombined chain pairs
3926  IF(nchvv1(i).EQ.99.AND.nchvv2(i).EQ.99) go to 50
3927  is1=intvv1(i)
3928  is2=intvv2(i)
3929 C
3930  IF (ipco.GE.1) WRITE (6,1000) ipvq(is1),ippv1(is1),ippv2(is1),
3931  + itvq(is2),ittv1(is2),ittv2(is2), amcvv1(i),amcvv2(i),gacvv1(i),
3932  + gacvv2(i), bgxvv1(i),bgyvv1(i),bgzvv1(i), bgxvv2(i),bgyvv2(i),
3933  + bgzvv2(i), nchvv1(i),nchvv2(i),ijcvv1(i),ijcvv2(i), pqvva1(i,4),
3934  + pqvva2(i,4),pqvvb1(i,4),pqvvb2(i,4)
3935 
3936 
3937 
3938  1000 FORMAT(6i5,10f9.2/10x,4i5,4f12.4)
3939 C
3940 C------------------------------ CHAIN 1:
3941 C INCIDENT BARYONS/MESONS: QUARK-DIQUARK
3942 C INCIDENT ANTIBARYONS : AQUARK-QUARK
3943  IF(ibproj.GE.0) THEN
3944  ifb1=ipvq(is1)
3945  ifb2=ittv1(is2)
3946  ifb3=ittv2(is2)
3947  nobam=4
3948  ELSE
3949  ifb1=ipvq(is1)
3950  ifb2=itvq(is2)
3951  ifb1=iabs(ifb1) + 6
3952  nobam=3
3953  ENDIF
3954 C
3955  DO 10 j=1,4
3956  poj(j)=pqvva1(i,j)
3957  pat(j)=pqvva2(i,j)
3958  10 CONTINUE
3959  pt1=sqrt(poj(1)**2+poj(2)**2)
3960  pt2=sqrt(pat(1)**2+pat(2)**2)
3961  CALL parpt(2,pt1,pt2,1,nevt)
3962 C------------------------------------------------------------------
3963 C------------------------------------------------------------------
3964 C------------------------------------------------------------------
3965 C check bookkeeping
3966 C-----------------------------------------------------------------
3967 C I= number of valence chain
3968 C Projectile Nr ipp = IFROVP(INTVV1(I))
3969 C Target Nr itt = IFROVT(INTVV2(I))
3970 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
3971 C No of Glauber sea q at Target JITT=JTSHS(ITT)
3972  ippp = ifrovp(intvv1(i))
3973  ittt = ifrovt(intvv2(i))
3974  jipp=jsshs(ippp)
3975  jitt=jtshs(ittt)
3976 C IF(NCHVV1(I).EQ.0)THEN
3977 C WRITE(6,'(A,5I5)')'HADRVV: I,IPPP,ITTT,JIPP,JITT ',
3978 C * I,IPPP,ITTT,JIPP,JITT
3979 C ENDIF
3980 C------------------------------------------------------------------
3981 C check bookkeeping
3982 C-----------------------------------------------------------------
3983  IF(ipco.GE.1)THEN
3984  WRITE(6,*)' VV q-qq ,IFB1,IFB2,IFB3,',
3985  * 'INTVV1=IS1,INTVV2=IS2,JIPP,JITT',
3986  * ifb1,ifb2,ifb3,intvv1(i),intvv2(i),jipp,jitt
3987  ENDIF
3988  IF(nobam.EQ.3.OR.nchvv1(i).NE.0)THEN
3989 C CALL HADJET(NHAD,AMCVV1(I),PAT,POJ,GACVV1(I),BGXVV1(I), BGYVV1
3990  CALL hadjet(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
3991  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
3992  + nchvv1(i),7)
3993  ENDIF
3994  aack=float(ick4)/float(ick4+ihad4+1)
3995  IF((nchvv1(i).EQ.0).AND.
3996  * (nobam.EQ.4))THEN
3997  zseawu=rndm(bb)*2.d0*zseaav
3998  rseack=float(jitt)*pdbse+ zseawu*pdbseu
3999  IF(ipco.GE.1)WRITE(6,*)'HADJSE JITT,RSEACK,PDBSE 1 dpmnuc3',
4000  + jitt,rseack,pdbse
4001  irejss=5
4002  IF(rndm(v).LE.rseack)THEN
4003  irejss=2
4004  IF(amcvv1(i).GT.2.3d0)THEN
4005  irejss=0
4006  CALL hadjse(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4007  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4008  + nchvv1(i),7,irejss,iissqq)
4009  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JITT,',
4010  * 'RSEACK,IREJSS 1 dpmnuc3 ',
4011  + jitt,rseack,irejss
4012  ENDIF
4013  IF(irejss.GE.1)THEN
4014  IF(irejss.EQ.1)irejse=irejse+1
4015  IF(irejss.EQ.3)irejs3=irejs3+1
4016  IF(irejss.EQ.2)irejs0=irejs0+1
4017  CALL hadjet(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4018  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4019  + nchvv1(i),7)
4020  ihad4=ihad4+1
4021  ENDIF
4022  IF(irejss.EQ.0)THEN
4023  IF(iissqq.EQ.3)THEN
4024  ise43=ise43+1
4025  ELSE
4026  ise4=ise4+1
4027  ENDIF
4028  ENDIF
4029  ELSEIF((ijpock.EQ.1).AND.
4030  * (aack.LE.pdbck))THEN
4031  irej=0
4032  CALL hadjck(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4033  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4034  + nchvv1(i),7,irej)
4035  IF(irej.EQ.1)THEN
4036  irejck=irejck+1
4037  CALL hadjet(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4038  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4039  + nchvv1(i),7)
4040  ihad4=ihad4+1
4041  ENDIF
4042  IF(irej.EQ.0)ick4=ick4+1
4043  ELSE
4044  CALL hadjet(nhad,amcvv1(i),poj,pat,gacvv1(i),bgxvv1(i), bgyvv1
4045  + (i),bgzvv1(i),ifb1,ifb2,ifb3,ifb4, ijcvv1(i),ijcvv1(i),nobam,
4046  + nchvv1(i),7)
4047  ihad4=ihad4+1
4048  ENDIF
4049  ENDIF
4050 C------------------------------------------------------------------
4051 C------------------------------------------------------------------
4052  acouvv=acouvv+1
4053 C*** REMOVED *** 31/07/90 *** ADD HADRONS/RESONANCES INTO
4054 C*** COMMON /ALLPAR/ STARTING AT NAUX
4055  nhkkau=nhkk+1
4056  DO 20 j=1,nhad
4057 C
4058 C NHKK=NHKK+1
4059  IF (nhkk.EQ.nmxhkk) THEN
4060  WRITE (6,'(A,2I5/A)') .EQ.' HADRVV: NHKKNMXHKK ',nhkk,nmxhkk
4061  RETURN
4062  ENDIF
4063 C
4064  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4065  IF (abs(ehecc-hef(j)).GT.0.001d0) THEN
4066 C WRITE(6,'(2A/3I5,3E15.6)')
4067 C & ' HADRVV / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
4068 C * ' NCALVV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4069 C * NCALVV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
4070  hef(j)=ehecc
4071  ENDIF
4072  annvv=annvv+1
4073  eevv=eevv+hef(j)
4074  ptvv=ptvv+sqrt(pxf(j)**2+pyf(j)**2)
4075 C PUT NN-CMS HADRONS INTO /HKKEVT/
4076  istist=1
4077  IF(ibarf(j).EQ.500)istist=2
4078  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvv(i)-3,0,
4079  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),1)
4080 C WRITE(6,*)' HKKFIL: NHKKAU,IORMO(J) ',ISTIST, NHKKAU,IORMO(J)
4081  IF(idhkk(nhkk).EQ.99999) WRITE (6,1010) nhkk,nref(j),idhkk
4082  + (nhkk)
4083  1010 FORMAT (' NHKK,NREF(J), ',3i10)
4084  imohkk=jmohkk(1,nhkk)
4085  IF(imohkk.LE.0.OR.imohkk.GT.nmxhkk)THEN
4086  WRITE(6,'(A,I10)')' HADRVV out of range IMOHKK= ',i10
4087  go to 2020
4088  ENDIF
4089  IF(irejss.LT.0)THEN
4090  WRITE(6,*)' From HADRVV 1 first chain after HKKFIL'
4091  IF (iphkk.GE.0) WRITE(6,1020) nhkk, isthkk(nhkk),idhkk(nhkk),
4092  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4093  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4094  ENDIF
4095  1020 FORMAT (i6,i4,5i6,9e10.2)
4096  20 CONTINUE
4097 C IF(NHAD.GT.0) THEN
4098 C JDAHKK(1,IMOHKK)=NHKKAU
4099 C JDAHKK(2,IMOHKK)=NHKK
4100 C ENDIF
4101  2020 CONTINUE
4102 C
4103 C------------------------------ CHAIN 2
4104 C INCIDENT BARYONS : DIQUARK-QUARK
4105 C INCIDENT MESONS : AQUARK-QUARKC
4106 C INCIDENT ANTIBARYONS: ADIQUARK-DIQUARK
4107 C
4108  IF(ibproj.GT.0) THEN
4109  ifb1=ippv1(is1)
4110  ifb2=ippv2(is1)
4111  ifb3=itvq(is2)
4112  nobam=6
4113  ELSEIF(ibproj.EQ.0) THEN
4114  ifb1=ippv1(is1)
4115  ifb2=itvq(is2)
4116  ifb1=iabs(ifb1) + 6
4117  nobam=3
4118  ELSE
4119  ifb1=ippv1(is1)
4120  ifb2=ippv2(is1)
4121  ifb1=iabs(ifb1) + 6
4122  ifb2=iabs(ifb2) + 6
4123  ifb3=ittv1(is2)
4124  ifb4=ittv2(is2)
4125  nobam=5
4126  ENDIF
4127 C
4128  DO 30 j=1,4
4129  poj(j)=pqvvb2(i,j)
4130  pat(j)=pqvvb1(i,j)
4131  30 CONTINUE
4132  pt1=sqrt(poj(1)**2+poj(2)**2)
4133  pt2=sqrt(pat(1)**2+pat(2)**2)
4134  CALL parpt(2,pt1,pt2,1,nevt)
4135 C*** POJ,PAT EXCHANGED J.R.15.2.90
4136 C*** RECHANGED 19/09/90 HJM
4137 C------------------------------------------------------------------
4138 C check bookkeeping
4139 C-----------------------------------------------------------------
4140 C I= number of valence chain
4141 C Projectile Nr ipp = IFROVP(INTVV1(I))
4142 C Target Nr itt = IFROVT(INTVV2(I))
4143 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
4144 C No of Glauber sea q at Target JITT=JTSHS(ITT)
4145  ippp = ifrovp(intvv1(i))
4146  ittt = ifrovt(intvv2(i))
4147  jipp=jsshs(ippp)
4148  jitt=jtshs(ittt)
4149 C IF(NCHVV2(I).EQ.0)THEN
4150 C WRITE(6,'(A,5I5)')'HadrVV: I,IPPP,ITTT,JIPP,JITT ',
4151 C * I,IPPP,ITTT,JIPP,JITT
4152 C ENDIF
4153 C------------------------------------------------------------------
4154 C check bookkeeping
4155 C-----------------------------------------------------------------
4156  IF(ipco.GE.1)THEN
4157  WRITE(6,*)' VV qq-q ,IFB1,IFB2,IFB3,',
4158  * 'INTVV1=IS1,INTVV2=IS2,JIPP,JITT',
4159  * ifb1,ifb2,ifb3,intvv1(i),intvv2(i),jipp,jitt
4160  ENDIF
4161  IF(nobam.EQ.5.OR.nobam.EQ.3.OR.nchvv2(i).NE.0)THEN
4162 C CALL HADJET(NHAD,AMCVV2(I),PAT,POJ,GACVV2(I),BGXVV2(I), BGYVV2
4163  CALL hadjet(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4164  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4165  + nchvv2(i),8)
4166  ENDIF
4167  aack=float(ick6)/float(ick6+ihad6+1)
4168  IF((nchvv2(i).EQ.0).AND.
4169  * (nobam.EQ.6))THEN
4170  zseawu=rndm(bb)*2.d0*zseaav
4171  rseack=float(jipp)*pdbse+ zseawu*pdbseu
4172  IF(ipco.GE.1)WRITE(6,*)'HADJSE JIPP,RSEACK,PDBSE 2 dpmnuc3',
4173  + jipp,rseack,pdbse
4174  irejss=5
4175  IF(rndm(v).LE.rseack)THEN
4176  irejss=2
4177  IF(amcvv2(i).GT.2.3d0)THEN
4178  irejss=0
4179  CALL hadjse(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4180  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4181  + nchvv2(i),8,irejss,iissqq)
4182  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JIPP,',
4183  * 'RSEACK,IREJSS 2 dpmnux3 ',
4184  + jipp,rseack,irejss
4185  ENDIF
4186  IF(irejss.GE.1)THEN
4187  IF(irejss.EQ.1)irejse=irejse+1
4188  IF(irejss.EQ.3)irejs3=irejs3+1
4189  IF(irejss.EQ.2)irejs0=irejs0+1
4190  CALL hadjet(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4191  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4192  + nchvv2(i),8)
4193  ihad6=ihad6+1
4194  ENDIF
4195  IF(irejss.EQ.0)THEN
4196  IF(iissqq.EQ.3)THEN
4197  ise63=ise63+1
4198  ELSE
4199  ise6=ise6+1
4200  ENDIF
4201  ENDIF
4202  ELSEIF((ijpock.EQ.1).AND.
4203  * (aack.LE.pdbck))THEN
4204  irej=0
4205  CALL hadjck(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4206  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4207  + nchvv2(i),8,irej)
4208  IF(irej.EQ.1)THEN
4209  irejck=irejck+1
4210  CALL hadjet(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4211  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4212  + nchvv2(i),8)
4213  ihad6=ihad6+1
4214  ENDIF
4215  IF(irej.EQ.0)ick6=ick6+1
4216  ELSE
4217  CALL hadjet(nhad,amcvv2(i),poj,pat,gacvv2(i),bgxvv2(i), bgyvv2
4218  + (i),bgzvv2(i),ifb1,ifb2,ifb3,ifb4, ijcvv2(i),ijcvv2(i),nobam,
4219  + nchvv2(i),8)
4220  ihad6=ihad6+1
4221  ENDIF
4222  ENDIF
4223 C ADD HADRONS/RESONANCES INTO
4224 C COMMON /ALLPAR/ STARTING AT NAUX
4225  nhkkau=nhkk+1
4226  DO 40 j=1,nhad
4227 C NHKK=NHKK+1
4228  IF (nhkk.EQ.nmxhkk) THEN
4229  WRITE (6,'(A,2I5/A)') .EQ.' HADRVV: NHKKNMXHKK ',nhkk,nmxhkk
4230  RETURN
4231  ENDIF
4232 C
4233  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4234  IF (abs(ehecc-hef(j)).GT.0.001d0) THEN
4235 C WRITE(6,'(2A/3I5,3E15.6)')
4236 C & ' HADRVV / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
4237 C * ' NCALVV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4238 C * NCALVV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)
4239  hef(j)=ehecc
4240  ENDIF
4241 C PUT NN-CMS HADRONS INTO /HKKEVT/
4242  annvv=annvv+1
4243  eevv=eevv+hef(j)
4244  ptvv=ptvv+sqrt(pxf(j)**2+pyf(j)**2)
4245  istist=1
4246  IF(ibarf(j).EQ.500)istist=2
4247  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvv(i),0,
4248  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),2)
4249 C WRITE(6,*)' HKKFIL: NHKKAU,IORMO(J) ',ISTIST, NHKKAU,IORMO(J)
4250  IF(idhkk(nhkk).EQ.99999) WRITE (6,1010)nhkk,nref(j), idhkk
4251  + (nhkk)
4252  imohkk=jmohkk(1,nhkk)
4253  IF(imohkk.LE.0.OR.imohkk.GT.nmxhkk)THEN
4254  WRITE(6,'(A,I10)')' HADRVV out of range IMOHKK= ',i10
4255  go to 4040
4256  ENDIF
4257  IF(irejss.LT.0)THEN
4258  WRITE(6,*)' From HADRVV second chain after HKKFIL'
4259  IF (iphkk.GE.0) WRITE(6,1020) nhkk, isthkk(nhkk),idhkk(nhkk),
4260  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4261  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4262  ENDIF
4263  40 CONTINUE
4264 C IF(NHAD.GT.0) THEN
4265 C JDAHKK(1,IMOHKK)=NHKKAU
4266 C JDAHKK(2,IMOHKK)=NHKK
4267 C ENDIF
4268  4040 CONTINUE
4269  50 CONTINUE
4270 C
4271 C------------------------------------------------------------------
4272 C
4273  RETURN
4274  END
4275 *-- Author :
4276 C
4277 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4278 C
4279  SUBROUTINE hadrsv
4280  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4281  SAVE
4282 C-------------------------
4283 C
4284 C HADRONIZE SEA-VALENCE CHAINS
4285 C
4286 C ADD GENERATED HADRONS TO /ALLPAR/
4287 C STARTING AT (NAUX + 1)
4288 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
4289 C
4290 C---------------------------------------------------------
4291 *KEEP,INTMX.
4292  parameter(intmx=2488,intmd=252)
4293 *KEEP,DXQX.
4294 C INCLUDE (XQXQ)
4295 * NOTE: INTMX set via INCLUDE(INTMX)
4296  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
4297  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
4298  * ,xpsu(248),xtsu(248)
4299  * ,xpsut(248),xtsut(248)
4300  common/popcck/pdbck,pdbse,pdbseu,
4301  * ijpock,irejck,ick4,ihad4,ick6,ihad6
4302  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
4303  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
4304  *isea43,isea63,irejao
4305 *KEEP,INTNEW.
4306  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
4307  +ixpv,ixps,ixtv,ixts, intvv1(248),
4308  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
4309  +intss1(intmx),intss2(intmx),
4310  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
4311  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
4312 
4313 C /INTNEW/
4314 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
4315 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
4316 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
4317 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
4318 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
4319 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
4320 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
4321 C FROM PROJECTILE/TARGET NUCLEI
4322 C-------------------
4323 *KEEP,IFROTO.
4324  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
4325  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
4326  +jhkknt
4327  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
4328  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
4329  & mhkkhh(intmx),
4330  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
4331 *KEEP,LOZUO.
4332  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
4333  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
4334  +intlo(intmx),inloss(intmx)
4335 C /LOZUO/
4336 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
4337 C REJECTED IN KKEVT
4338 C------------------
4339 *KEEP,DIQI.
4340  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
4341  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
4342  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
4343  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
4344 *KEEP,HKKEVT.
4345 c INCLUDE (HKKEVT)
4346  parameter(nmxhkk= 89998)
4347 c PARAMETER (NMXHKK=25000)
4348  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
4349  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
4350  +(4,nmxhkk)
4351 C
4352 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
4353 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
4354 C THE POSITIONS OF THE PROJECTILE NUCLEONS
4355 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
4356 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
4357 C COMPLETELY CONSISTENT. THE TIMES IN THE
4358 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
4359 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
4360 C
4361 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
4362 C
4363 C NMXHKK: maximum numbers of entries (partons/particles) that can be
4364 C stored in the commonblock.
4365 C
4366 C NHKK: the actual number of entries stored in current event. These are
4367 C found in the first NHKK positions of the respective arrays below.
4368 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
4369 C entry.
4370 C
4371 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
4372 C = 0 : null entry.
4373 C = 1 : an existing entry, which has not decayed or fragmented.
4374 C This is the main class of entries which represents the
4375 C "final state" given by the generator.
4376 C = 2 : an entry which has decayed or fragmented and therefore
4377 C is not appearing in the final state, but is retained for
4378 C event history information.
4379 C = 3 : a documentation line, defined separately from the event
4380 C history. (incoming reacting
4381 C particles, etc.)
4382 C = 4 - 10 : undefined, but reserved for future standards.
4383 C = 11 - 20 : at the disposal of each model builder for constructs
4384 C specific to his program, but equivalent to a null line in the
4385 C context of any other program. One example is the cone defining
4386 C vector of HERWIG, another cluster or event axes of the JETSET
4387 C analysis routines.
4388 C = 21 - : at the disposal of users, in particular for event tracking
4389 C in the detector.
4390 C
4391 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
4392 C standard.
4393 C
4394 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
4395 C The value is 0 for initial entries.
4396 C
4397 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
4398 C one mother exist, in which case the value 0 is used. In cluster
4399 C fragmentation models, the two mothers would correspond to the q
4400 C and qbar which join to form a cluster. In string fragmentation,
4401 C the two mothers of a particle produced in the fragmentation would
4402 C be the two endpoints of the string (with the range in between
4403 C implied).
4404 C
4405 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
4406 C entry has not decayed, this is 0.
4407 C
4408 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
4409 C entry has not decayed, this is 0. It is assumed that the daughters
4410 C of a particle (or cluster or string) are stored sequentially, so
4411 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
4412 C daughters. Even in cases where only one daughter is defined (e.g.
4413 C K0 -> K0S) both values should be defined, to make for a uniform
4414 C approach in terms of loop constructions.
4415 C
4416 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
4417 C
4418 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
4419 C
4420 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
4421 C
4422 C PHKK(4,IHKK) : energy, in GeV.
4423 C
4424 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
4425 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
4426 C
4427 C VHKK(1,IHKK) : production vertex x position, in mm.
4428 C
4429 C VHKK(2,IHKK) : production vertex y position, in mm.
4430 C
4431 C VHKK(3,IHKK) : production vertex z position, in mm.
4432 C
4433 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
4434 C********************************************************************
4435 *KEEP,ABRSV.
4436  COMMON /abrsv/ amcsv1(248),amcsv2(248),gacsv1(248),gacsv2(248),
4437  +bgxsv1(248),bgysv1(248),bgzsv1(248), bgxsv2(248),bgysv2(248),
4438  +bgzsv2(248), nchsv1(248),nchsv2(248),ijcsv1(248),ijcsv2(248),
4439  +pqsva1(248,4),pqsva2(248,4), pqsvb1(248,4),pqsvb2(248,4)
4440 *KEEP,DFINPA.
4441  CHARACTER*8 anf
4442  parameter(nfimax=249)
4443  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
4444  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
4445  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
4446  * istath(nfimax)
4447 *KEEP,DPRIN.
4448  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4449 *KEEP,PROJK.
4450  COMMON /projk/ iprojk
4451 *KEEP,NUCC.
4452  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
4453 *KEND.
4454 C modified DPMJET
4455  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
4456  * anndv,annvd,annds,annsd,
4457  * annhh,annzz,
4458  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
4459  * pthh,ptzz,
4460  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
4461  * eehh,eezz
4462  * ,anndi,ptdi,eedi
4463  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
4464  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
4465  * acouzz,acouhh,acouds,acousd,
4466  * acoudz,acouzd,acoudi,
4467  * acoudv,acouvd,acoucc
4468 C---------------------
4469  COMMON /zsea/zseaav,zseasu,anzsea
4470  COMMON /casadi/casaxx,icasad
4471 C---------------------
4472  dimension poj(4),pat(4)
4473  DATA ncalsv /0/
4474 C-----------------------------------------------------------------------
4475  ncalsv=ncalsv+1
4476  DO 50 i=1,nsv
4477 C-----------------------drop recombined chain pairs
4478  IF(nchsv1(i).EQ.99.AND.nchsv2(i).EQ.99) go to 50
4479  is1=intsv1(i)
4480  is2=intsv2(i)
4481 C
4482  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itvq(is2),
4483  + ittv1(is2),ittv2(is2), amcsv1(i),amcsv2(i),gacsv1(i),gacsv2(i),
4484  + bgxsv1(i),bgysv1(i),bgzsv1(i), bgxsv2(i),bgysv2(i),bgzsv2(i),
4485  + nchsv1(i),nchsv2(i),ijcsv1(i),ijcsv2(i), pqsva1(i,4),pqsva2
4486  + (i,4),pqsvb1(i,4),pqsvb2(i,4)
4487  1000 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
4488 C
4489 C++++++++++++++++++++++++++++++ CHAIN 1: QUARK-DIQUARK +++++++++++
4490  ifb1=ipsq(is1)
4491  ifb2=ittv1(is2)
4492  ifb3=ittv2(is2)
4493  DO 10 j=1,4
4494  poj(j)=pqsva1(i,j)
4495  pat(j)=pqsva2(i,j)
4496  10 CONTINUE
4497  pt1=sqrt(poj(1)**2+poj(2)**2)
4498  pt2=sqrt(pat(1)**2+pat(2)**2)
4499  CALL parpt(2,pt1,pt2,3,nevt)
4500 C IF((NCHSV1(I).NE.0.OR.NCHSV2(I).NE.0).AND.IP.NE.1)
4501 C & CALL SAPTRE(AMCSV1(I),GACSV1(I),BGXSV1(I),BGYSV1(I),BGZSV1(I),
4502 C & AMCSV2(I),GACSV2(I),BGXSV2(I),BGYSV2(I),BGZSV2(I))
4503 C----------------------------------------------------------------
4504  IF (ipco.GE.6)WRITE (6,1244) poj,pat
4505  1244 FORMAT (' S-V QUARK-DIQUARK POJ,PAT ',8e12.3)
4506 C------------------------------------------------------------------
4507 C------------------------------------------------------------------
4508 C------------------------------------------------------------------
4509 C check bookkeeping
4510 C-----------------------------------------------------------------
4511 C I= number of valence chain
4512 C Target Nr itt = IFROVT(INTSV2(I))
4513 C No of Glauber sea q at Target JITT=JTSHS(ITT)
4514  ittt = ifrovt(intsv2(i))
4515  jitt=jtshs(ittt)
4516 C IF(NCHSV1(I).EQ.0)THEN
4517 C WRITE(6,'(A,3I5)')'HADRSV: I,ITTT,JITT ',
4518 C * I,ITTT,JITT
4519 C ENDIF
4520 C------------------------------------------------------------------
4521 C check bookkeeping
4522 C-----------------------------------------------------------------
4523  IF(ipco.GE.1)THEN
4524  WRITE(6,*)' SV q-qq ,IFB1,IFB2,IFB3,',
4525  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITT',
4526  * ifb1,ifb2,ifb3,intsv1(i),intsv2(i),jippx,jitt
4527  ENDIF
4528 C-------------------------------------------------------------------
4529 C-------------------------------------------------------------------
4530  IF((nchsv1(i).NE.0))THEN
4531  CALL hadjet(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4532  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4533  + (i),3)
4534  ENDIF
4535  aack=float(ick4)/float(ick4+ihad4+1)
4536  IF((nchsv1(i).EQ.0))THEN
4537  zseawu=rndm(bb)*2.d0*zseaav
4538  rseack=float(jitt)*pdbse+ zseawu*pdbseu
4539  IF(ipco.GE.1)WRITE(6,*)'HADJSE JITT,RSEACK,PDBSE 3 dpmnuc3',
4540  + jitt,rseack,pdbse
4541  irejss=5
4542  IF(rndm(v).LE.rseack)THEN
4543  irejss=2
4544  IF(amcsv1(i).GT.2.3d0)THEN
4545  irejss=0
4546  CALL hadjse(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i),
4547  * bgysv1
4548  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,
4549  * nchsv1
4550  + (i),3,irejss,iissqq)
4551  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JITT,',
4552  * 'RSEACK,IREJSS 3 dpmnuc3 ',
4553  + jitt,rseack,irejss
4554  ENDIF
4555  IF(irejss.GE.1)THEN
4556  IF(irejss.EQ.1)irejse=irejse+1
4557  IF(irejss.EQ.3)irejs3=irejs3+1
4558  IF(irejss.EQ.2)irejs0=irejs0+1
4559  CALL hadjet(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4560  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4561  + (i),3)
4562  ihad4=ihad4+1
4563  ENDIF
4564  IF(irejss.EQ.0)THEN
4565  IF(iissqq.EQ.3)THEN
4566  ise43=ise43+1
4567  ELSE
4568  ise4=ise4+1
4569  ENDIF
4570  ENDIF
4571  ELSEIF((ijpock.EQ.1).AND.
4572  * (aack.LE.pdbck))THEN
4573  irej=0
4574  CALL hadjck(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4575  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4576  + (i),3,irej)
4577  IF(irej.EQ.1)THEN
4578  irejck=irejck+1
4579  CALL hadjet(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4580  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4581  + (i),3)
4582  ihad4=ihad4+1
4583  ENDIF
4584  IF(irej.EQ.0)ick4=ick4+1
4585  ELSE
4586  CALL hadjet(nhad,amcsv1(i),poj,pat,gacsv1(i),bgxsv1(i), bgysv1
4587  + (i),bgzsv1(i),ifb1,ifb2,ifb3,ifb4, ijcsv1(i),ijcsv1(i),4,nchsv1
4588  + (i),3)
4589  ihad4=ihad4+1
4590  ENDIF
4591  ENDIF
4592 C------------------------------------------------------------------
4593 C------------------------------------------------------------------
4594  acousv=acousv+1
4595 C*** REMOVED 31/07/90 HJM *** ADD HADRONS/RESONANCES INTO
4596 C COMMON /ALLPAR/ STARTING AT NAUX
4597  nhkkau=nhkk+1
4598  pixu=0.
4599  piyu=0.
4600  pizu=0.
4601  pieu=0.
4602  DO 20 j=1,nhad
4603 C NHKK=NHKK+1
4604  IF (nhkk.EQ.nmxhkk) THEN
4605  WRITE (6,'(A,2I5/A)') .EQ.' HADRSV: NHKKNMXHKK ',nhkk,nmxhkk
4606  RETURN
4607  ENDIF
4608 C
4609  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4610  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
4611  WRITE(6,'(2A/3I5,3E15.6)')
4612  & ' HADRSV / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
4613  * ' NCALSV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4614  * ncalsv, nhkk,nref(j), hef(j),ehecc, amf(j)
4615  hef(j)=ehecc
4616  ENDIF
4617  annsv=annsv+1
4618  eesv=eesv+hef(j)
4619  ptsv=ptsv+sqrt(pxf(j)**2+pyf(j)**2)
4620 C PUT NN-CMS HADRONS INTO /HKKEVT/
4621  istist=1
4622  IF(ibarf(j).EQ.500)istist=2
4623  CALL hkkfil(istist,mpdgha(nref(j)),mhkksv(i)-3,0,
4624  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),3)
4625 C WRITE(6,*)' HKKFIL: NHKKAU,IORMO(J) ',ISTIST, NHKKAU,IORMO(J)
4626  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
4627  + (nhkk)
4628  pixu=pixu+pxf(j)
4629  piyu=piyu+pyf(j)
4630  pizu=pizu+pzf(j)
4631  pieu=pieu+hef(j)
4632  IF(irejss.LT.0)THEN
4633  WRITE(6,*)' HADRSV / CHAIN 1'
4634  IF (iphkk.GE.0) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
4635  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4636  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4637  ENDIF
4638  20 CONTINUE
4639  IF(ipco.GE.6)WRITE(6,1644)pixu,piyu,pizu,pieu
4640  1644 FORMAT(' HADRSV,ch1 PIXU,PIYU,PIZU,PIEU ',4f12.5)
4641 C IF(NHAD.GT.0) THEN
4642 C JDAHKK(1,IMOHKK)=NHKKAU
4643 C JDAHKK(2,IMOHKK)=NHKK
4644 C ENDIF
4645 C+++++++++++++++++++++++++++++ CHAIN 2: AQUARK-QUARK ++++++++++++++
4646  ifb1=ipsaq(is1)
4647  ifb2=itvq(is2)
4648  ifb1=iabs(ifb1)+6
4649  DO 30 j=1,4
4650  poj(j)=pqsvb2(i,j)
4651  pat(j)=pqsvb1(i,j)
4652  30 CONTINUE
4653  pt1=sqrt(poj(1)**2+poj(2)**2)
4654  pt2=sqrt(pat(1)**2+pat(2)**2)
4655  CALL parpt(2,pt1,pt2,3,nevt)
4656 C
4657  IF(ipco.GE.1)THEN
4658  WRITE(6,*)' SV aq-q ,IFB1,IFB2,',
4659  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITTX',
4660  * ifb1,ifb2,intsv1(i),intsv2(i),jippx,jittx
4661  ENDIF
4662 C-------------------------------------------------------------------
4663 C-------------------------------------------------------------------
4664  IF (ipco.GE.6)WRITE (6,1244) poj,pat
4665  CALL hadjet(nhad,amcsv2(i),poj,pat,gacsv2(i),bgxsv2(i), bgysv2
4666  + (i),bgzsv2(i),ifb1,ifb2,ifb3,ifb4, ijcsv2(i),ijcsv2(i),3,nchsv2
4667  + (i),4)
4668 C ADD HADRONS/RESONANCES INTO
4669 C COMMON /ALLPAR/ STARTING AT NAUX
4670  nhkkau=nhkk+1
4671  pixu=0.
4672  piyu=0.
4673  pizu=0.
4674  pieu=0.
4675  DO 40 j=1,nhad
4676  IF (nhkk.EQ.nmxhkk) THEN
4677  WRITE (6,'(A,2I5/A)') .EQ.' HADRSV: NHKKNMXHKK ', nhkk,
4678  + nmxhkk
4679  RETURN
4680  ENDIF
4681 C NHKK=NHKK+1
4682 C
4683  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
4684  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
4685  WRITE(6,'(2A/3I5,3E15.6)')
4686  & ' HADRSV / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
4687  * ' NCALSV, NHKK,NREF(J), HEF(J),EHECC, AMF(J)',
4688  * ncalsv, nhkk,nref(j), hef(j),ehecc, amf(j)
4689  hef(j)=ehecc
4690  ENDIF
4691  annsv=annsv+1
4692  eesv=eesv+hef(j)
4693  ptsv=ptsv+sqrt(pxf(j)**2+pyf(j)**2)
4694 C PUT NN-CMS HADRONS INTO /HKKEVT/
4695  istist=1
4696  IF(ibarf(j).EQ.500)istist=2
4697  CALL hkkfil(istist,mpdgha(nref(j)),mhkksv(i),0,
4698  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),4)
4699  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
4700  + (nhkk)
4701  pixu=pixu+pxf(j)
4702  piyu=piyu+pyf(j)
4703  pizu=pizu+pzf(j)
4704  pieu=pieu+hef(j)
4705  IF (iphkk.GE.7) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk(nhkk),
4706  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
4707  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
4708 
4709  40 CONTINUE
4710  IF(ipco.GE.6)WRITE(6,1644)pixu,piyu,pizu,pieu
4711 C IF(NHAD.GT.0) THEN
4712 C JDAHKK(1,IMOHKK)=NHKKAU
4713 C JDAHKK(2,IMOHKK)=NHKK
4714 C ENDIF
4715  50 CONTINUE
4716 C----------------------------------------------------------------
4717 C
4718  RETURN
4719  1010 FORMAT (i6,i4,5i6,9e10.2)
4720  1020 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
4721  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
4722  END
4723 *-- Author :
4724 C
4725 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4726 C
4727  SUBROUTINE hadrss
4728  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4729  SAVE
4730 *KEEP,INTMX.
4731  parameter(intmx=2488,intmd=252)
4732 *KEEP,DXQX.
4733 C INCLUDE (XQXQ)
4734 * NOTE: INTMX set via INCLUDE(INTMX)
4735  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
4736  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
4737  * ,xpsu(248),xtsu(248)
4738  * ,xpsut(248),xtsut(248)
4739 *KEEP,INTNEW.
4740  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
4741  +ixpv,ixps,ixtv,ixts, intvv1(248),
4742  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
4743  +intss1(intmx),intss2(intmx),
4744  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
4745  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
4746 
4747 C /INTNEW/
4748 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
4749 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
4750 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
4751 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
4752 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
4753 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
4754 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
4755 C FROM PROJECTILE/TARGET NUCLEI
4756 C-------------------
4757 *KEEP,IFROTO.
4758  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
4759  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
4760  +jhkknt
4761  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
4762  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
4763  & mhkkhh(intmx),
4764  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
4765 *KEEP,LOZUO.
4766  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
4767  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
4768  +intlo(intmx),inloss(intmx)
4769 C /LOZUO/
4770 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
4771 C REJECTED IN KKEVT
4772 C------------------
4773 *KEEP,DIQI.
4774  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
4775  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
4776  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
4777  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
4778 *KEEP,HKKEVT.
4779 c INCLUDE (HKKEVT)
4780  parameter(nmxhkk= 89998)
4781 c PARAMETER (NMXHKK=25000)
4782  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
4783  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
4784  +(4,nmxhkk)
4785 C
4786 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
4787 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
4788 C THE POSITIONS OF THE PROJECTILE NUCLEONS
4789 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
4790 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
4791 C COMPLETELY CONSISTENT. THE TIMES IN THE
4792 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
4793 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
4794 C
4795 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
4796 C
4797 C NMXHKK: maximum numbers of entries (partons/particles) that can be
4798 C stored in the commonblock.
4799 C
4800 C NHKK: the actual number of entries stored in current event. These are
4801 C found in the first NHKK positions of the respective arrays below.
4802 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
4803 C entry.
4804 C
4805 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
4806 C = 0 : null entry.
4807 C = 1 : an existing entry, which has not decayed or fragmented.
4808 C This is the main class of entries which represents the
4809 C "final state" given by the generator.
4810 C = 2 : an entry which has decayed or fragmented and therefore
4811 C is not appearing in the final state, but is retained for
4812 C event history information.
4813 C = 3 : a documentation line, defined separately from the event
4814 C history. (incoming reacting
4815 C particles, etc.)
4816 C = 4 - 10 : undefined, but reserved for future standards.
4817 C = 11 - 20 : at the disposal of each model builder for constructs
4818 C specific to his program, but equivalent to a null line in the
4819 C context of any other program. One example is the cone defining
4820 C vector of HERWIG, another cluster or event axes of the JETSET
4821 C analysis routines.
4822 C = 21 - : at the disposal of users, in particular for event tracking
4823 C in the detector.
4824 C
4825 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
4826 C standard.
4827 C
4828 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
4829 C The value is 0 for initial entries.
4830 C
4831 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
4832 C one mother exist, in which case the value 0 is used. In cluster
4833 C fragmentation models, the two mothers would correspond to the q
4834 C and qbar which join to form a cluster. In string fragmentation,
4835 C the two mothers of a particle produced in the fragmentation would
4836 C be the two endpoints of the string (with the range in between
4837 C implied).
4838 C
4839 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
4840 C entry has not decayed, this is 0.
4841 C
4842 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
4843 C entry has not decayed, this is 0. It is assumed that the daughters
4844 C of a particle (or cluster or string) are stored sequentially, so
4845 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
4846 C daughters. Even in cases where only one daughter is defined (e.g.
4847 C K0 -> K0S) both values should be defined, to make for a uniform
4848 C approach in terms of loop constructions.
4849 C
4850 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
4851 C
4852 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
4853 C
4854 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
4855 C
4856 C PHKK(4,IHKK) : energy, in GeV.
4857 C
4858 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
4859 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
4860 C
4861 C VHKK(1,IHKK) : production vertex x position, in mm.
4862 C
4863 C VHKK(2,IHKK) : production vertex y position, in mm.
4864 C
4865 C VHKK(3,IHKK) : production vertex z position, in mm.
4866 C
4867 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
4868 C********************************************************************
4869 *KEEP,ABRSS.
4870 C INCLUDE (ABRSS)
4871  COMMON /abrss/ amcss1(intmx),amcss2(intmx), gacss1(intmx),gacss2
4872  +(intmx), bgxss1(intmx),bgyss1(intmx),bgzss1(intmx), bgxss2(intmx),
4873  +bgyss2(intmx),bgzss2(intmx), nchss1(intmx),nchss2(intmx), ijcss1
4874  +(intmx),ijcss2(intmx), pqssa1(intmx,4),pqssa2(intmx,4), pqssb1
4875  +(intmx,4),pqssb2(intmx,4)
4876 *KEEP,NUCC.
4877  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
4878 *KEEP,DFINPA.
4879  CHARACTER*8 anf
4880  parameter(nfimax=249)
4881  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
4882  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
4883  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
4884  * istath(nfimax)
4885 *KEEP,DPRIN.
4886  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4887 *KEEP,PROJK.
4888  COMMON /projk/ iprojk
4889 *KEND.
4890  dimension poj(4),pat(4)
4891 C modified DPMJET
4892  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
4893  * anndv,annvd,annds,annsd,
4894  * annhh,annzz,
4895  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
4896  * pthh,ptzz,
4897  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
4898  * eehh,eezz
4899  * ,anndi,ptdi,eedi
4900  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
4901  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
4902  * acouzz,acouhh,acouds,acousd,
4903  * acoudz,acouzd,acoudi,
4904  * acoudv,acouvd,acoucc
4905 C---------------------
4906  COMMON /pshow/ ipshow
4907 C COMMON /HARLUN/ IHARLU,QLUN
4908  COMMON /harlun/ qlun,iharlu
4909  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
4910  COMMON /jspa/pxs(40000),pys(40000),pzs(40000),hes(40000),nnnps
4911  COMMON /nomije/ ptmije(10),nnmije(10)
4912  COMMON /casadi/casaxx,icasad
4913 C-----------------------------------------------------------------------
4914  DO 60 i=1,nss
4915 C-----------------------drop recombined chain pairs
4916  IF(nchss1(i).EQ.99.AND.nchss2(i).EQ.99) go to 60
4917  IF (inloss(i)) THEN
4918  is1=intss1(i)
4919  is2=intss2(i)
4920 C
4921  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itsq(is2),
4922  + itsaq(is2), amcss1(i),amcss2(i),gacss1(i),gacss2(i), bgxss1
4923  + (i),bgyss1(i),bgzss1(i), bgxss2(i),bgyss2(i),bgzss2(i), nchss1
4924  + (i),nchss2(i),ijcss1(i),ijcss2(i), pqssa1(i,4),pqssa2(i,4),
4925  + pqssb1(i,4),pqssb2(i,4)
4926  1000 FORMAT(10x,4i5,10f9.2/10x,4i5,4f12.4)
4927 C
4928 C+++++++++++++++++++++++++++++ CHAIN 1: QUARK-AQUARK ++++++++++
4929  ifb1=ipsq(is1)
4930  ifb2=itsaq(is2)
4931  ifb2=iabs(ifb2)+6
4932  DO 10 j=1,4
4933  poj(j)=pqssa1(i,j)
4934  pat(j)=pqssa2(i,j)
4935  10 CONTINUE
4936  pt1=sqrt(poj(1)**2+poj(2)**2)
4937  pt2=sqrt(pat(1)**2+pat(2)**2)
4938  CALL parpt(2,pt1,pt2,4,nevt)
4939 C--------------------------------------------------------------
4940  iharlu=0
4941  qlun=0.
4942  IF(ipshow.EQ.1)THEN
4943  pojpt=sqrt(poj(2)**2+poj(1)**2)
4944  patpt=sqrt(pat(1)**2+pat(2)**2)
4945  DO iiii=1,10
4946  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
4947  * nnmije(iiii)+1
4948  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
4949  * nnmije(iiii)+1
4950  ENDDO
4951  qlun=min(pojpt,patpt)
4952  IF((qlun.LT.2.5d0).OR.(amcss1(i).LT.5.d0))THEN
4953  qlun=0.
4954  iharlu=0
4955  ELSE
4956  iharlu=1
4957  ENDIF
4958  ENDIF
4959  IF(ipco.GE.1)THEN
4960  WRITE(6,*)' SS q-aq ,IFB1,IFB2,',
4961  * 'INTSS1=IS1,INTSS2=IS2',
4962  * ifb1,ifb2,intss1(i),intss2(i)
4963  WRITE (6,*)' projectile sea quark IFB1=',ifb1,
4964  * ' from IS1=',intss1(i)
4965  WRITE(6,*)' with IPSQ(IS1),XPSQ(IS1),IFROSP(IS1)',
4966  * ipsq(is1),xpsq(is1),ifrosp(is1)
4967  ENDIF
4968  DO 798 ii=1,ixpv
4969  IF(ifrosp(is1).EQ.ifrovp(ii))iii=ii
4970  798 CONTINUE
4971  IF(ipco.GE.1)THEN
4972  WRITE (6,*)' projectile III=',iii
4973  WRITE(6,*)' corresp. XPVQ(i),XPVD(i),IPVQ(I),IPPV1(I),IPPV2(I)',
4974  * xpvq(iii),xpvd(iii),ipvq(iii),ippv1(iii),ippv2(iii)
4975  ENDIF
4976 C-------------------------------------------------------------------
4977 C Casado diquark option
4978 C+++++++++++++++++++++++++++ SS CHAIN 1: QUARK-AQUARK ++++++++++
4979 C-------------------------------------------------------------------
4980  IF(icasad.EQ.1)THEN
4981  IF(rndm(vv).LE.casaxx)THEN
4982  IF(rndm(vvv).LE.0.5d0)THEN
4983  iscasa=ipsq(is1)
4984  ipvcas=ippv1(iii)
4985  ipsq(is1)=ipvcas
4986  ippv1(iii)=iscasa
4987  ifb1=ipsq(is1)
4988  IF(ipco.GE.1)THEN
4989  WRITE(6,*)' Cas SS1 q-aq 1 ,IFB1,IFB2,',
4990  * 'INTSS1=IS1,INTSS2=IS2,III',
4991  * ifb1,ifb2,intss1(i),intss2(i),iii
4992  * ,'-----------------------------------------------------'
4993  ENDIF
4994  ELSE
4995  iscasa=ipsq(is1)
4996  ipvcas=ippv2(iii)
4997  ipsq(is1)=ipvcas
4998  ippv2(iii)=iscasa
4999  ifb1=ipsq(is1)
5000  IF(ipco.GE.1)THEN
5001  WRITE(6,*)' Cas SS1 q-aq 2 ,IFB1,IFB2,',
5002  * 'INTSS1=IS1,INTSS2=IS2,III',
5003  * ifb1,ifb2,intss1(i),intss2(i),iii
5004  * ,'-----------------------------------------------------'
5005  ENDIF
5006  ENDIF
5007  ENDIF
5008  ENDIF
5009 C-------------------------------------------------------------------
5010 C Casado diquark option
5011 C-------------------------------------------------------------------
5012  CALL hadjet(nhad,amcss1(i),poj,pat,gacss1(i),bgxss1(i), bgyss1
5013  + (i),bgzss1(i),ifb1,ifb2,ifb3,ifb4, ijcss1(i),ijcss1(i),3,
5014  + nchss1(i),1)
5015  acouss=acouss+1
5016  iharlu=0
5017  qlun=0.
5018 C ADD HADRONS/RESONANCES INTO
5019 C COMMON /ALLPAR/ STARTING AT NAUX
5020  nhkkau=nhkk+1
5021  DO 20 j=1,nhad
5022  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5023  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
5024  WRITE(6,'(A,2I5,2E16.6)')
5025  + ' HADRSS: CORRECT INCONSISTENT PARTICLE ENERGY ', nhkk,
5026  + nref(j), hef(j),ehecc
5027  hef(j)=ehecc
5028  ENDIF
5029  annss=annss+1
5030  eess=eess+hef(j)
5031  ptss=ptss+sqrt(pxf(j)**2+pyf(j)**2)
5032 C PUT NN-CMS HADRONS INTO /HKKEVT/
5033 C NHKK=NHKK+1
5034  IF (nhkk.EQ.nmxhkk) THEN
5035  WRITE (6,'(A,2I5)') ' HADRSS: NHKK.EQ NMXHKK',nhkk,nmxhkk
5036  RETURN
5037  ENDIF
5038  istist=1
5039  IF(ibarf(j).EQ.500)istist=2
5040  CALL hkkfil(istist,mpdgha(nref(j)),mhkkss(i)-3,0,
5041  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),5)
5042  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030) nhkk,nref(j), idhkk
5043  + (nhkk)
5044 C WRITE(6,*)' First chain HADRSS'
5045  IF (iphkk.GE.7) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk
5046  + (nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk
5047  + (2,nhkk),(phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk
5048  + =1,4)
5049  20 CONTINUE
5050  30 CONTINUE
5051 C IF(NHAD.GT.0) THEN
5052 C JDAHKK(1,IMOHKK)=NHKKAU
5053 C JDAHKK(2,IMOHKK)=NHKK
5054 C ENDIF
5055  IF(nnnpj.GE.1)THEN
5056  nnnpso=nnnps
5057  nnnps=nnnps+1
5058  nnnpsu=nnnpso+nnnpj
5059  DO 137 j=nnnps,nnnpsu
5060  jj=j-nnnps+1
5061  IF(j.GT.40000.OR.jj.GT.1000)THEN
5062 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
5063  go to 137
5064  ENDIF
5065  pxs(j)=pxj(jj)
5066  pys(j)=pyj(jj)
5067  pzs(j)=pzj(jj)
5068  hes(j)=hej(jj)
5069  137 CONTINUE
5070  nnnps=nnnps+nnnpj-1
5071  ENDIF
5072 C
5073 C++++++++++++++++++++++++++++++++ CHAIN 2: AQUARK-QUARK +++++++++
5074  ifb1=ipsaq(is1)
5075  ifb2=itsq(is2)
5076  ifb1=iabs(ifb1)+6
5077  DO 40 j=1,4
5078  poj(j)=pqssb2(i,j)
5079  pat(j)=pqssb1(i,j)
5080  40 CONTINUE
5081  pt1=sqrt(poj(1)**2+poj(2)**2)
5082  pt2=sqrt(pat(1)**2+pat(2)**2)
5083  CALL parpt(2,pt1,pt2,4,nevt)
5084  iharlu=0
5085  qlun=0.
5086  IF(ipshow.EQ.1)THEN
5087  pojpt=sqrt(poj(2)**2+poj(1)**2)
5088  patpt=sqrt(pat(1)**2+pat(2)**2)
5089  DO iiii=1,10
5090  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
5091  * nnmije(iiii)+1
5092  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
5093  * nnmije(iiii)+1
5094  ENDDO
5095  qlun=min(pojpt,patpt)
5096  IF((qlun.LT.2.5d0).OR.(amcss2(i).LT.5.d0))THEN
5097  qlun=0.
5098  iharlu=0
5099  ELSE
5100  iharlu=1
5101  ENDIF
5102  ENDIF
5103 C,,
5104  IF(ipco.GE.1)THEN
5105  WRITE(6,*)' SS aq-q ,IFB1,IFB2,',
5106  * 'INTSS1=IS1,INTSS2=IS2',
5107  * ifb1,ifb2,intss1(i),intss2(i)
5108  WRITE (6,*)' target sea quark IFB2=',ifb2,
5109  * ' from IS2=',intss2(i)
5110  WRITE(6,*)' with ITSQ(IS2),XTSQ(IS2),IFROST(IS2)',
5111  * itsq(is2),xtsq(is2),ifrost(is2)
5112  ENDIF
5113  DO 797 ii=1,ixtv
5114  IF(ifrost(is2).EQ.ifrovt(ii))iii=ii
5115  797 CONTINUE
5116  IF(ipco.GE.1)THEN
5117  WRITE (6,*)' projectile III=',iii
5118  WRITE(6,*)' corresp. XTVQ(i),XTVD(i),ITVQ(I),ITTV1(I),ITTV2(I)',
5119  * xtvq(iii),xtvd(iii),itvq(iii),ittv1(iii),ittv2(iii)
5120  ENDIF
5121 C-------------------------------------------------------------------
5122 C Casado diquark option
5123 C+++++++++++++++++++++++++++++ SS CHAIN 2: AQUARK-QUARK +++++++++
5124 C-------------------------------------------------------------------
5125  IF(icasad.EQ.1)THEN
5126  IF(rndm(vv).LE.casaxx)THEN
5127  IF(rndm(vvv).LE.0.5d0)THEN
5128  iscasa=itsq(is2)
5129  itvcas=ittv1(iii)
5130  itsq(is2)=itvcas
5131  ittv1(iii)=iscasa
5132  ifb2=itsq(is2)
5133  IF(ipco.GE.1)THEN
5134  WRITE(6,*)' Cas SS2 aq-q 1 ,IFB1,IFB2,',
5135  * 'INTSS1=IS1,INTSS2=IS2,III',
5136  * ifb1,ifb2,intss1(i),intss2(i),iii
5137  * ,'-----------------------------------------------------'
5138  ENDIF
5139  ELSE
5140  iscasa=itsq(is2)
5141  itvcas=ittv2(iii)
5142  itsq(is2)=itvcas
5143  ittv2(iii)=iscasa
5144  ifb2=itsq(is2)
5145  IF(ipco.GE.1)THEN
5146  WRITE(6,*)' Cas SS2 aq-q 2 ,IFB1,IFB2,',
5147  * 'INTSS1=IS1,INTSS2=IS2,III',
5148  * ifb1,ifb2,intss1(i),intss2(i),iii
5149  * ,'-----------------------------------------------------'
5150  ENDIF
5151  ENDIF
5152  ENDIF
5153  ENDIF
5154 C-------------------------------------------------------------------
5155 C Casado diquark option
5156 C-------------------------------------------------------------------
5157  CALL hadjet(nhad,amcss2(i),poj,pat,gacss2(i),bgxss2(i), bgyss2
5158  + (i),bgzss2(i),ifb1,ifb2,ifb3,ifb4, ijcss2(i),ijcss2(i),3,
5159  + nchss2(i),2)
5160  iharlu=0
5161  qlun=0.
5162 C ADD HADRONS/RESONANCES INTO
5163 C COMMON /ALLPAR/ STARTING AT NAUX
5164  nhkkau=nhkk+1
5165  DO 50 j=1,nhad
5166  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5167  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
5168  WRITE(6,'(A,2I5,2E16.6)')
5169  + ' HADRSS: CORRECT INCONSISTENT PARTICLE ENERGY ', nhkk,
5170  + nref(j), hef(j),ehecc
5171  hef(j)=ehecc
5172  ENDIF
5173  annss=annss+1
5174  eess=eess+hef(j)
5175  ptss=ptss+sqrt(pxf(j)**2+pyf(j)**2)
5176 C PUT NN-CMS HADRONS INTO /HKKEVT/
5177 C NHKK=NHKK+1
5178  IF (nhkk.EQ.nmxhkk) THEN
5179  WRITE (6,'(A,2I5)') ' HADRSS: NHKK.EQ NMXHKK',nhkk,nmxhkk
5180  RETURN
5181  ENDIF
5182  istist=1
5183  IF(ibarf(j).EQ.500)istist=2
5184  CALL hkkfil(istist,mpdgha(nref(j)),mhkkss(i),0,
5185  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),6)
5186  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030) nhkk,nref(j), idhkk
5187  + (nhkk)
5188 C WRITE(6,*)' Second chain HADRSS'
5189  IF (iphkk.GE.7) WRITE(6,1010) nhkk, isthkk(nhkk),idhkk
5190  + (nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk
5191  + (2,nhkk),(phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk
5192  + =1,4)
5193  50 CONTINUE
5194 C IF(NHAD.GT.0) THEN
5195 C JDAHKK(1,IMOHKK)=NHKKAU
5196 C JDAHKK(2,IMOHKK)=NHKK
5197 C ENDIF
5198  IF(nnnpj.GE.1)THEN
5199  nnnpso=nnnps
5200  nnnps=nnnps+1
5201  nnnpsu=nnnpso+nnnpj
5202  DO 187 j=nnnps,nnnpsu
5203  jj=j-nnnps+1
5204  IF(j.GT.40000.OR.jj.GT.1000)THEN
5205 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
5206  go to 187
5207  ENDIF
5208  pxs(j)=pxj(jj)
5209  pys(j)=pyj(jj)
5210  pzs(j)=pzj(jj)
5211  hes(j)=hej(jj)
5212  187 CONTINUE
5213  nnnps=nnnps+nnnpj-1
5214  ENDIF
5215  ENDIF
5216  60 CONTINUE
5217 C
5218 C--------------------------------------------------------------
5219 C
5220  RETURN
5221  1010 FORMAT (i6,i4,5i6,9e10.2)
5222  1020 FORMAT (.GT.' HADRVS JNAUMAX SKIP NEXT PARTICLES ',3i10)
5223  1030 FORMAT (' NHKK,NREF(J),IDHKK(NHKK) ',3i10)
5224  1040 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
5225  END
5226 *-- Author :
5227 C
5228 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5229 C
5230  SUBROUTINE hadrvs
5231  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5232  SAVE
5233 C
5234 C-------------------------
5235 C
5236 C HADRONIZE VALENCE-SEA CHAINS
5237 C
5238 C ADD GENERATED HADRONS TO /ALLPAR/
5239 C STARTING AT (NAUX + 1)
5240 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
5241 C
5242 C-------------------------
5243 *KEEP,INTMX.
5244  parameter(intmx=2488,intmd=252)
5245 *KEEP,DXQX.
5246 C INCLUDE (XQXQ)
5247 * NOTE: INTMX set via INCLUDE(INTMX)
5248  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
5249  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
5250  * ,xpsu(248),xtsu(248)
5251  * ,xpsut(248),xtsut(248)
5252  common/popcck/pdbck,pdbse,pdbseu,
5253  * ijpock,irejck,ick4,ihad4,ick6,ihad6
5254  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
5255  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
5256  *isea43,isea63,irejao
5257 *KEEP,INTNEW.
5258  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
5259  +ixpv,ixps,ixtv,ixts, intvv1(248),
5260  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
5261  +intss1(intmx),intss2(intmx),
5262  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
5263  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
5264 
5265 C /INTNEW/
5266 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
5267 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
5268 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
5269 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
5270 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
5271 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
5272 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
5273 C FROM PROJECTILE/TARGET NUCLEI
5274 C-------------------
5275 *KEEP,IFROTO.
5276  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
5277  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
5278  +jhkknt
5279  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
5280  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
5281  & mhkkhh(intmx),
5282  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
5283 *KEEP,LOZUO.
5284  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
5285  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
5286  +intlo(intmx),inloss(intmx)
5287 C /LOZUO/
5288 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
5289 C REJECTED IN KKEVT
5290 C------------------
5291 *KEEP,DIQI.
5292  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
5293  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
5294  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
5295  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
5296 *KEEP,HKKEVT.
5297 c INCLUDE (HKKEVT)
5298  parameter(nmxhkk= 89998)
5299 c PARAMETER (NMXHKK=25000)
5300  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
5301  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
5302  +(4,nmxhkk)
5303 C
5304 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
5305 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
5306 C THE POSITIONS OF THE PROJECTILE NUCLEONS
5307 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
5308 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
5309 C COMPLETELY CONSISTENT. THE TIMES IN THE
5310 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
5311 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
5312 C
5313 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
5314 C
5315 C NMXHKK: maximum numbers of entries (partons/particles) that can be
5316 C stored in the commonblock.
5317 C
5318 C NHKK: the actual number of entries stored in current event. These are
5319 C found in the first NHKK positions of the respective arrays below.
5320 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
5321 C entry.
5322 C
5323 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
5324 C = 0 : null entry.
5325 C = 1 : an existing entry, which has not decayed or fragmented.
5326 C This is the main class of entries which represents the
5327 C "final state" given by the generator.
5328 C = 2 : an entry which has decayed or fragmented and therefore
5329 C is not appearing in the final state, but is retained for
5330 C event history information.
5331 C = 3 : a documentation line, defined separately from the event
5332 C history. (incoming reacting
5333 C particles, etc.)
5334 C = 4 - 10 : undefined, but reserved for future standards.
5335 C = 11 - 20 : at the disposal of each model builder for constructs
5336 C specific to his program, but equivalent to a null line in the
5337 C context of any other program. One example is the cone defining
5338 C vector of HERWIG, another cluster or event axes of the JETSET
5339 C analysis routines.
5340 C = 21 - : at the disposal of users, in particular for event tracking
5341 C in the detector.
5342 C
5343 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
5344 C standard.
5345 C
5346 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
5347 C The value is 0 for initial entries.
5348 C
5349 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
5350 C one mother exist, in which case the value 0 is used. In cluster
5351 C fragmentation models, the two mothers would correspond to the q
5352 C and qbar which join to form a cluster. In string fragmentation,
5353 C the two mothers of a particle produced in the fragmentation would
5354 C be the two endpoints of the string (with the range in between
5355 C implied).
5356 C
5357 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
5358 C entry has not decayed, this is 0.
5359 C
5360 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
5361 C entry has not decayed, this is 0. It is assumed that the daughters
5362 C of a particle (or cluster or string) are stored sequentially, so
5363 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
5364 C daughters. Even in cases where only one daughter is defined (e.g.
5365 C K0 -> K0S) both values should be defined, to make for a uniform
5366 C approach in terms of loop constructions.
5367 C
5368 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
5369 C
5370 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
5371 C
5372 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
5373 C
5374 C PHKK(4,IHKK) : energy, in GeV.
5375 C
5376 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
5377 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
5378 C
5379 C VHKK(1,IHKK) : production vertex x position, in mm.
5380 C
5381 C VHKK(2,IHKK) : production vertex y position, in mm.
5382 C
5383 C VHKK(3,IHKK) : production vertex z position, in mm.
5384 C
5385 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
5386 C********************************************************************
5387 *KEEP,ABRVS.
5388  COMMON /abrvs/ amcvs1(248),amcvs2(248),gacvs1(248),gacvs2(248),
5389  +bgxvs1(248),bgyvs1(248),bgzvs1(248), bgxvs2(248),bgyvs2(248),
5390  +bgzvs2(248), nchvs1(248),nchvs2(248),ijcvs1(248),ijcvs2(248),
5391  +pqvsa1(248,4),pqvsa2(248,4), pqvsb1(248,4),pqvsb2(248,4)
5392 *KEEP,DFINPA.
5393  CHARACTER*8 anf
5394  parameter(nfimax=249)
5395  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
5396  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
5397  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
5398  * istath(nfimax)
5399 *KEEP,DPRIN.
5400  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5401 *KEEP,PROJK.
5402  COMMON /projk/ iprojk
5403 *KEEP,NUCC.
5404  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
5405 *KEND.
5406 C modified DPMJET
5407  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
5408  * anndv,annvd,annds,annsd,
5409  * annhh,annzz,
5410  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
5411  * pthh,ptzz,
5412  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
5413  * eehh,eezz
5414  * ,anndi,ptdi,eedi
5415  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
5416  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
5417  * acouzz,acouhh,acouds,acousd,
5418  * acoudz,acouzd,acoudi,
5419  * acoudv,acouvd,acoucc
5420 C---------------------
5421  COMMON /zsea/zseaav,zseasu,anzsea
5422  COMMON /casadi/casaxx,icasad
5423 C---------------------
5424  dimension poj(4),pat(4)
5425 C-----------------------------------------------------------------------
5426  DO 50 i=1,nvs
5427 C-----------------------drop recombined chain pairs
5428  IF(nchvs1(i).EQ.99.AND.nchvs2(i).EQ.99) go to 50
5429  is1=intvs1(i)
5430  is2=intvs2(i)
5431 C
5432  IF (ipco.GE.6) WRITE (6,1010) ipvq(is1),ippv1(is1),ippv2(is1),
5433  + itsq(is2),itsaq(is2), amcvs1(i),amcvs2(i),gacvs1(i),gacvs2(i),
5434  + bgxvs1(i),bgyvs1(i),bgzvs1(i), bgxvs2(i),bgyvs2(i),bgzvs2(i),
5435  + nchvs1(i),nchvs2(i),ijcvs1(i),ijcvs2(i), pqvsa1(i,4),pqvsa2
5436  + (i,4),pqvsb1(i,4),pqvsb2(i,4)
5437 C
5438 C+++++++++++++++++++++++++++++ CHAIN 1: QUARK-AQUARK ++++++++++
5439  ifb1=ipvq(is1)
5440  ifb2=itsaq(is2)
5441  ifb2=iabs(ifb2)+6
5442  DO 10 j=1,4
5443  poj(j)=pqvsa1(i,j)
5444  pat(j)=pqvsa2(i,j)
5445  10 CONTINUE
5446  pt1=sqrt(poj(1)**2+poj(2)**2)
5447  pt2=sqrt(pat(1)**2+pat(2)**2)
5448  CALL parpt(2,pt1,pt2,2,nevt)
5449 C IF((NCHVS1(I).NE.0.OR.NCHVS2(I).NE.0).AND.IP.NE.1)
5450 C & CALL SAPTRE(AMCVS2(I),GACVS2(I),BGXVS2(I),BGYVS2(I),BGZVS2(I),
5451 C & AMCVS1(I),GACVS1(I),BGXVS1(I),BGYVS1(I),BGZVS1(I))
5452 C-----------------------------------------------------------------
5453 C POJ,PAT EXCHANGED J.R.15.2.90
5454 C RECHANGED HJM 13/2/91
5455  IF(ipco.GE.1)THEN
5456  WRITE(6,*)' VS q-aq ,IFB1,IFB2,',
5457  * 'INTVS1=IS1,INTVS2=IS2,JIPPX,JITTX',
5458  * ifb1,ifb2,intvs1(i),intvs2(i),jippx,jittx
5459  ENDIF
5460  CALL hadjet(nhad,amcvs1(i),poj,pat,gacvs1(i),bgxvs1(i), bgyvs1
5461  + (i),bgzvs1(i),ifb1,ifb2,ifb3,ifb4, ijcvs1(i),ijcvs1(i),3,nchvs1
5462  + (i),5)
5463  acouvs=acouvs+1
5464 C ADD HADRONS/RESONANCES INTO
5465 C COMMON /ALLPAR/ STARTING AT NAUX
5466  nhkkau=nhkk+1
5467  DO 20 j=1,nhad
5468  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5469  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500)THEN
5470  WRITE(6,'(A,2I5,2E16.6)')
5471  + ' HADRVS: CORRECT INCONSISTENT PARTICLE ENERGY ', nhkk,nref
5472  + (j), hef(j),ehecc
5473  hef(j)=ehecc
5474  ENDIF
5475  annvs=annvs+1
5476  eevs=eevs+hef(j)
5477  ptvs=ptvs+sqrt(pxf(j)**2+pyf(j)**2)
5478 C PUT NN-CMS HADRONS INTO /HKKEVT/
5479 C NHKK=NHKK+1
5480  IF (nhkk.EQ.nmxhkk) THEN
5481  WRITE (6,'(A,2I5)') .EQ.' HADRVS: NHKKNMXHKK',nhkk,nmxhkk
5482  RETURN
5483  ENDIF
5484  istist=1
5485  IF(ibarf(j).EQ.500)istist=2
5486  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvs(i)-3,0,
5487  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),7)
5488  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030) nhkk, idhkk(nhkk)
5489 C WRITE(6,*)' Firt chain HADRVS'
5490  IF (iphkk.GE.7) WRITE(6,1000)nhkk, isthkk(nhkk),idhkk(nhkk),
5491  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
5492  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
5493 
5494  20 CONTINUE
5495 C IF(NHAD.GT.0) THEN
5496 C JDAHKK(1,IMOHKK)=NHKKAU
5497 C JDAHKK(2,IMOHKK)=NHKK
5498 C ENDIF
5499 C
5500 C++++++++++++++++++++++++++++++ CHAIN 2: DIQUARK-QUARK +++++++++++
5501  ifb1=ippv1(is1)
5502  ifb2=ippv2(is1)
5503  ifb3=itsq(is2)
5504  DO 30 j=1,4
5505  poj(j)=pqvsb2(i,j)
5506  pat(j)=pqvsb1(i,j)
5507  30 CONTINUE
5508  pt1=sqrt(poj(1)**2+poj(2)**2)
5509  pt2=sqrt(pat(1)**2+pat(2)**2)
5510  CALL parpt(2,pt1,pt2,2,nevt)
5511 C POJ,PAT EXCHANGED J.R.15.2.90
5512 C RECHANGED HJM 21/2/91
5513 C------------------------------------------------------------------
5514 C check bookkeeping
5515 C-----------------------------------------------------------------
5516 C I= number of valence chain
5517 C Projectile Nr ippp= IFROVP(INTVS1(I))
5518 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
5519  ippp = ifrovp(intvs1(i))
5520  jipp=jsshs(ippp)
5521 C IF(NCHVS2(I).EQ.0)THEN
5522 C WRITE(6,'(A,3I5)')'HADRVS: I,IPPP,JIPP ',
5523 C * I,IPPP,JIPP
5524 C ENDIF
5525 C------------------------------------------------------------------
5526 C check bookkeeping
5527 C-----------------------------------------------------------------
5528  IF(ipco.GE.1)THEN
5529  WRITE(6,*)' VS qq-q ,IFB1,IFB2,IFB3,',
5530  * 'INTVS1=IS1,INTVS2=IS2,JIPP,JITTX',
5531  * ifb1,ifb2,ifb3,intvs1(i),intvs2(i),jipp,jittx
5532  ENDIF
5533 C-------------------------------------------------------------------
5534 C-------------------------------------------------------------------
5535  IF((nchvs2(i).NE.0))THEN
5536  CALL hadjet(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i), bgyvs2
5537  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,nchvs2
5538  + (i),6)
5539  ENDIF
5540  aack=float(ick6)/float(ick6+ihad6+1)
5541  IF((nchvs2(i).EQ.0))THEN
5542  zseawu=rndm(bb)*2.d0*zseaav
5543  rseack=float(jipp)*pdbse+ zseawu*pdbseu
5544  IF(ipco.GE.1)WRITE(6,*)'HADJSE JIPP,RSEACK,PDBSE 4 dpmnuc3',
5545  + jipp,rseack,pdbse
5546  irejss=5
5547  IF(rndm(v).LE.rseack)THEN
5548  irejss=2
5549  IF(amcvs2(i).GT.2.3d0)THEN
5550  irejss=0
5551  CALL hadjse(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i),
5552  * bgyvs2
5553  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,
5554  * nchvs2
5555  + (i),6,irejss,iissqq)
5556  IF(ipco.GE.1)WRITE(6,'(2A,I5,F10.3,I5)')'HADJSE JIPP,',
5557  * 'RSEACK,IREJSS 4 dpmnuc3',
5558  + jipp,rseack,irejss
5559  ENDIF
5560  IF(irejss.GE.1)THEN
5561  IF(irejss.EQ.1)irejse=irejse+1
5562  IF(irejss.EQ.3)irejs3=irejs3+1
5563  IF(irejss.EQ.2)irejs0=irejs0+1
5564  CALL hadjet(nhad,amcvs2(i),poj,pat,gacvs2(i),
5565  * bgxvs2(i), bgyvs2
5566  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),
5567  * ijcvs2(i),6,nchvs2
5568  + (i),6)
5569  ihad6=ihad6+1
5570  ENDIF
5571  IF(irejss.EQ.0)THEN
5572  IF(iissqq.EQ.3)THEN
5573  ise63=ise63+1
5574  ELSE
5575  ise6=ise6+1
5576  ENDIF
5577  ENDIF
5578  ELSEIF((ijpock.EQ.1).AND.
5579  * (aack.LE.pdbck))THEN
5580  irej=0
5581  CALL hadjck(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i), bgyvs2
5582  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,nchvs2
5583  + (i),6,irej)
5584  IF(irej.EQ.1)THEN
5585  irejck=irejck+1
5586  CALL hadjet(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i), bgyvs2
5587  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,nchvs2
5588  + (i),6)
5589  ihad6=ihad6+1
5590  ENDIF
5591  IF(irej.EQ.0)ick6=ick6+1
5592  ELSE
5593  CALL hadjet(nhad,amcvs2(i),poj,pat,gacvs2(i),bgxvs2(i), bgyvs2
5594  + (i),bgzvs2(i),ifb1,ifb2,ifb3,ifb4, ijcvs2(i),ijcvs2(i),6,nchvs2
5595  + (i),6)
5596  ihad6=ihad6+1
5597  ENDIF
5598  ENDIF
5599 C------------------------------------------------------------------
5600 C------------------------------------------------------------------
5601 C ADD HADRONS/RESONANCES INTO
5602 C COMMON /ALLPAR/ STARTING AT NAUX
5603  nhkkau=nhkk+1
5604  DO 40 j=1,nhad
5605  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
5606  IF (abs(ehecc-hef(j)).GT.0.001d0.AND.ibarf(j).NE.500) THEN
5607  WRITE(6,'(A,2I5,2E16.6)')
5608  + ' HADRVS: CORRECT INCONSISTENT PARTICLE ENERGY ', nhkk,nref
5609  + (j), hef(j),ehecc
5610  hef(j)=ehecc
5611  ENDIF
5612  annvs=annvs+1
5613  eevs=eevs+hef(j)
5614  ptvs=ptvs+sqrt(pxf(j)**2+pyf(j)**2)
5615 C PUT NN-CMS HADRONS INTO /HKKEVT/
5616 C NHKK=NHKK+1
5617  IF (nhkk.EQ.nmxhkk) THEN
5618  WRITE (6,'(A,2I5)') .EQ.' HADRVS: NHKKNMXHKK ',nhkk,nmxhkk
5619  RETURN
5620  ENDIF
5621  istist=1
5622  IF(ibarf(j).EQ.500)istist=2
5623  CALL hkkfil(istist,mpdgha(nref(j)),mhkkvs(i),0,
5624  * pxf(j),pyf(j),pzf(j),hef(j),nhkkau,iormo(j),8)
5625 C WRITE(6,*)' HKKFIL: NHKKAU,IORMO(J) ',ISTIST, NHKKAU,IORMO(J)
5626  IF(idhkk(nhkk).EQ.99999) WRITE (6,1030)nhkk,nref(j), idhkk
5627  + (nhkk)
5628  IF(irejss.LT.0)THEN
5629  WRITE(6,*)' Second chain HADRVS'
5630  IF (iphkk.GE.0) WRITE(6,1000) nhkk, isthkk(nhkk),idhkk(nhkk),
5631  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
5632  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
5633  ENDIF
5634  40 CONTINUE
5635 C IF(NHAD.GT.0) THEN
5636 C JDAHKK(1,IMOHKK)=NHKKAU
5637 C JDAHKK(2,IMOHKK)=NHKK
5638 C ENDIF
5639  50 CONTINUE
5640 C
5641  RETURN
5642  1000 FORMAT (i6,i4,5i6,9e10.2)
5643  1010 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
5644  1020 FORMAT (.GT.' HADRVS JNAUMAX SKIP NEXT PARTICLES ',3i10)
5645  1030 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
5646  END
5647 *-- Author :
5648 C
5649 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5650 C
5651  SUBROUTINE hadjet(NHAD,AMCH,PPR,PTA,GAM,BGX,BGY,BGZ, IFB1,IFB2,
5652  +ifb3,ifb4,i1,i2,nobam,nnch,norig)
5653  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5654  SAVE
5655 C
5656 C HADJET DOES ALL THE NECESSARY ROTATIONS AND LORENTZ TRANSFORMS AND
5657 C CALL CALBAM (BAMJET)
5658 C
5659 C NHAD = NUMBER OF HADRONS CREATED (OUTPUT) = IHAD (CALBAM)
5660 C******** PRODUCED PARTICLES IN COMMON /CMSRES/
5661 C NOTE: NOW IN /FINPAR/ HJM 21/06/90
5662 C AMCH = INVARIANT MASS OF JET (INPUT)
5663 C PPR = 4-MOMENTUM OF FORWARD GOING PARTON (PROJECTILE)(INPUT)
5664 C PTA = 4-MOMENTUM OF BACKWARD GOING PARTON (TARGET)(INPUT)
5665 C GAM,BGX,BGY,BGZ = LORENTZ PARAMETERS OF JET CMS RELATIVE TO
5666 C COLLISION CMS (INPUT)
5667 C
5668 C--------------------------------------------------------------------
5669 C CALBAM(NNCH,I1,I2,IFB1,IFB2,IFB3,IFB4,AMCH,NOBAM,IHAD)
5670 C SAMPLING OF Q-AQ, Q-QQ, QQ-AQQ CHAINS
5671 C USING BAMJET(IHAD,IFB1,IFB2,IFB3,IFB4,AMCH,NOBAM)-----FOR NNCH=0
5672 C OR PARJET(IHAD,ICH1=I1 OR I2)------FOR NNCH=-1 OR +1
5673 C-------------------------------------------------------------------
5674 C IHAD : NUMBER OF PRODUCED PARTICLES
5675 C NNCH : CALL BAMJET FOR NNCH=0
5676 C CALL PARJET FOR NNCH=+1 ICH1=I1
5677 C FOR NNCH=-1 ICH1=I2
5678 C jet not existing for NNCH=+/-99, i.e. IHAD=0
5679 C PRODUCED PARTICLES IN CHAIN REST FRAME ARE IN COMMON /FINPAR/
5680 C AMCH : INVARIANT MASS OF CHAIN (BAMJET)
5681 C
5682 C NOBAM : = 3 QUARK-ANTIQUARK JET QUARK FLAVORS : IFB1,IFB2
5683 C OR ANTIQUARK-QUARK JET IN ANY ORDER
5684 C
5685 C = 4 QUARK-DIQUARK JET, FLAVORS : QU : IFB1, DIQU :IFB2,IFB
5686 C OR ANTIQUARK-ANTIDIQUARK JET
5687 C
5688 C
5689 C = 5 DIQUARK-ANTIDIQUARK JET
5690 C OR ANTIDIQUARK-DIQUARK JET
5691 C FLAVORS : DIQU : IFB1,IFB2, ANTIDIQU : IFB3,IFB4
5692 C IN ANY ORDER
5693 C
5694 C = 6 DIQUARK-QUARK JET, FLAVORS : DIQU : IFB1,IFB2 QU: IFB
5695 C OR ANTIDIQUARK-ANTIQUARK JET
5696 C
5697 C IFBI : FLAVORS : 1,2,3,4 = U,D,S,C 7,8,9,10 = AU,AD,AS,AC
5698 C
5699 C I1,I2 : NUMBER LABEL OF A HADRON CREATED BY PARJET
5700 C
5701 C NORMALLY IN BAMJET THE QUARKS MOVE FORWARD (POSITIVE Z-DIRECTION)
5702 C THE QUARK FLAVORS ARE FIRST GIVEN
5703 C CALBAM ALLOWS EITHER THE QUARK OR ANTIQUARK (DIQU) TO MOVE FORWARD
5704 C THE FORWARD GOING FLAVORS ARE GIVEN FIRST
5705 C
5706 C =====================================================================
5707 *KEEP,DFINPA.
5708  CHARACTER*8 anf
5709  parameter(nfimax=249)
5710  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
5711  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
5712  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
5713  * istath(nfimax)
5714 *KEEP,DPRIN.
5715  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5716 *KEND.
5717 *--------------------------------------------------------------------
5718 *-------------------------------------------------------------------
5719  COMMON /jspart/pxp(1000),pyp(1000),pzp(1000),hepp(1000),nnnp
5720  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
5721 ************************************************************************
5722 ************************************************************************
5723  common/ifragm/ifrag
5724  dimension ppr(4),pta(4),pprj(4),ptaj(4)
5725  LOGICAL ltesha
5726  parameter(tiny=1.d-10)
5727  DATA icheco/0/
5728  DATA icheca/0/
5729 C IPCO=6
5730 C----------------------------------------------------------------------
5731 C
5732 C CHECK HADJET ENERGY CONSERVATION PPR(4)+PTA(4) EQ EHAD
5733 C TRANSFORM PROJECTILE INTO JET REST FRAME
5734 C IF(NOBAM.EQ.4.OR.NOBAM.EQ.6) IPCO=6
5735  IF(ipco.GE.6) THEN
5736  WRITE(6,1010) gam,bgx,bgy,bgz,ppr,pprj
5737  WRITE(6,1000) nhad,amch,pta, ifb1,ifb2,ifb3,ifb4,i1,i2,nobam,
5738  + nnch,norig
5739  1000 FORMAT(10x,i10,5f10.3/10x,9i10)
5740  ENDIF
5741  IF(abs(nnch).EQ.99) THEN
5742  nhad=0
5743 C IPCO=0
5744  RETURN
5745  ENDIF
5746 C
5747  CALL daltra(gam,-bgx,-bgy,-bgz,ppr(1),ppr(2),ppr(3),ppr(4),pprtot,
5748  +pprj(1),pprj(2),pprj(3),pprj(4))
5749  CALL daltra(gam,-bgx,-bgy,-bgz,pta(1),pta(2),pta(3),pta(4),ptatot,
5750  +ptaj(1),ptaj(2),ptaj(3),ptaj(4))
5751 C
5752  IF(ipco.GE.3) WRITE(6,1010)gam,bgx,bgy,bgz,ppr,pprj,pta,ptaj
5753  1010 FORMAT(' HADJET: GAM,BGX,BGY,BGZ,PPR(4),PPRJ(4) ',4f15.5/8f15.5/ 8
5754  +f15.5)
5755 C WORK OUT COD,SID,COF,SIF OF PROJECTILE
5756 C IN JET FRAME
5757  IF(pprtot.LT.tiny)pprtot=tiny
5758  cod= pprj(3)/pprtot
5759  IF(cod.GE.1.d0)cod=0.999999999999
5760  IF(cod.LE.-1.d0)cod=-0.999999999999
5761  sid=sqrt(abs((1.d0-cod)*(1.d0+cod)))
5762  cof=1.
5763  sif=0.
5764  IF((abs(pprj(1)).GT.0.d0).OR.(abs(pprj(2)).GT.0.d0))THEN
5765  IF(pprtot*sid.GT.1.d-9) THEN
5766  cof=pprj(1)/(sid*pprtot)
5767  sif=pprj(2)/(sid*pprtot)
5768  anorf=sqrt(abs(cof*cof+sif*sif))
5769  cof=cof/anorf
5770  sif=sif/anorf
5771  ENDIF
5772  ENDIF
5773  IF (ipco.GE.6) WRITE(6,1020)cod,sid,cof,sif
5774  1020 FORMAT(' COD,SID,COF,SIF ',4f15.8)
5775 C SAMPLE JET IN JET CMS
5776  CALL calbam(nnch,i1,i2,ifb1,ifb2,ifb3,ifb4,amch,nobam,ihad)
5777 C IF(IHAD.EQ.1)THEN
5778 C IPRI=1
5779 C IPCO=3
5780 C ELSE
5781 C IPRI=0
5782 C IPCO=-1
5783 C ENDIF
5784 C NOW WE HAVE IHAD PARTICLES/RESONANCES
5785 C IN COMMON /FINPAR/
5786 C CHECK CALBAM ENERGY CONSERVATION / jet cms
5787  ecal=0.
5788  pxcal=0.
5789  pycal=0.
5790  pzcal=0.
5791  ltesha=.false.
5792  DO 10 i=1,ihad
5793  IF(ibarf(i).EQ.500)go to 1011
5794  pxcal=pxcal + pxf(i)
5795  pycal=pycal + pyf(i)
5796  pzcal=pzcal + pzf(i)
5797  IF(ifrag.EQ.0)THEN
5798  ehecc=sqrt(abs(pxf(i)**2+pyf(i)**2+pzf(i)**2+amf(i)**2))
5799  IF (abs(ehecc-hef(i)).GT.0.0001d0) THEN
5800  IF(ipri.GE.1) WRITE(6,'(2A/A/3I5,3E16.6)')
5801  + ' HADJET / AFTER CALBAM:',
5802  + ' CORRECT INCONSISTENT ENERGY IN JET CMS',
5803  + ' I, IHAD,NREF(I), HEF(I),EHECC, AMF(I)',
5804  * i,ihad,nref(i), hef(i),ehecc, amf(i)
5805  hef(i)=ehecc
5806  ltesha=.true.
5807  ENDIF
5808  ENDIF
5809  ecal=ecal + hef(i)
5810  1011 CONTINUE
5811  10 CONTINUE
5812  IF (abs(ecal-amch).GT.0.005d0) ltesha=.true.
5813  IF (ltesha) THEN
5814  icheca=icheca+1
5815  IF (abs(ecal-amch).GT.0.005d0) THEN
5816  IF(icheca.LE.10)WRITE(6,'(A/10I4)')
5817  + ' HADJET/1:ICHECA,IFB1,IFB2,IFB3,IFB4,I1,I2,NOBAM,NNCH,NORIG',
5818  + icheca,ifb1,
5819  + ifb2,ifb3,ifb4,i1,i2,nobam,nnch,norig
5820  IF(icheca.LE.10)WRITE(6,1030) amch,ecal,pxcal,pycal,pzcal
5821  1030 FORMAT(' CALBAM E. CHECK (5 MeV) AMCH,ECAL,PXCAL,PYCAL,PZCAL=',
5822  + /5e20.8)
5823  ltesha=.false.
5824  ENDIF
5825  ENDIF
5826  IF (ipco.GE.3)THEN
5827  DO 20 i=1,ihad
5828  WRITE(6,1040)i,pxf(i),pyf(i),pzf(i),hef(i),amf(i), ichf(i),
5829  + ibarf(i),nref(i),anf(i)
5830  1040 FORMAT(' JET SYSTEM ',i5,5f12.4,3i5,a10)
5831  20 CONTINUE
5832  ENDIF
5833 C CALL DECAY(IHAD,2)
5834 C NHAD=IHAD
5835 C CHECK CALBAM+DECAY ENERGY CONSERVATION
5836 C ECAL=0.
5837 C PXCAL=0.
5838 C PYCAL=0.
5839 C PZCAL=0.
5840 C DO 1204 I=1,IHAD
5841 C ECAL=ECAL+HEF(I)
5842 C PXCAL=PXCAL+PXF(I)
5843 C PYCAL=PYCAL+PYF(I)
5844 C PZCAL=PZCAL+PZF(I)
5845 C1204 CONTINUE
5846 C IOUCHA=3
5847 C IF (ABS(ECAL-AMCH)/AMCH.GT.0.00001D0)IOUCHA=1
5848 C IF (IPCO.GE.IOUCHA)WRITE(6,1203)AMCH,ECAL,PXCAL,PYCAL,PZCAL
5849 C1203 FORMAT(' CALBAM+DECAY ENERGY CHECK AMCH,ECAL,PXCAL,PYCAL,PZCAL '
5850 C * /5E20.8)
5851 C IF (IPCO.GE.3)THEN
5852 C DO 143 I=1,IHAD
5853 C WRITE(6,144)I,PXF(I),PYF(I),PZF(I),HEF(I),AMF(I),
5854 C * ICHF(I),IBARF(I),NREF(I),ANF(I)
5855 C 144 FORMAT(' JET SYSTEM DECAY ',I5,5F12.4,3I5,A10)
5856 C 143 CONTINUE
5857 C ENDIF
5858 C ROTATE JET BY COD,SID,COF,SIF
5859  pxcal=0.
5860  pycal=0.
5861  pzcal=0.
5862  ltesha=.false.
5863  DO 30 i=1,ihad
5864  phec2=pxf(i)**2+pyf(i)**2+pzf(i)**2
5865  CALL dtrans(pxf(i),pyf(i),pzf(i),cod,sid,cof,sif,xx,yy,zz)
5866  prota2=xx**2 + yy**2 + zz**2
5867  pxf(i)=xx
5868  pyf(i)=yy
5869  pzf(i)=zz
5870  pxcal=pxcal + pxf(i)
5871  pycal=pycal + pyf(i)
5872  pzcal=pzcal + pzf(i)
5873 C EHECC=SQRT(ABS(PXF(I)**2+PYF(I)**2+PZF(I)**2+AMF(I)**2))
5874  IF(abs(phec2-prota2).GT.0.0001d0) THEN
5875  WRITE(6,'(2A/3I5,3E16.6)')
5876  & ' HADJET: INCONSISTENT MOMENTUM AFTER TRANS',
5877  * ' I, IHAD,NREF(I), PHEC2,PROTA2, AMF(I)',
5878  * i,ihad,nref(i), phec2,prota2, amf(i)
5879 C HEF(I)=EHECC
5880  ltesha=.true.
5881  ENDIF
5882  30 CONTINUE
5883  IF (ltesha) THEN
5884  WRITE(6,'(A/9I4)')
5885  + ' HADJET/2: IFB1,IFB2,IFB3,IFB4,I1,I2,NOBAM,NNCH,NORIG', ifb1,
5886  + ifb2,ifb3,ifb4,i1,i2,nobam,nnch,norig
5887  WRITE(6,1031) pxcal,pycal,pzcal
5888  1031 FORMAT(' CALBAM ENERGY CHECK/2: PXCAL,PYCAL,PZCAL='/3e20.8)
5889  ltesha=.false.
5890  ENDIF
5891  IF (ipco.GE.3)THEN
5892  DO 40 i=1,ihad
5893  WRITE(6,1050)i,pxf(i),pyf(i),pzf(i),hef(i),amf(i), ichf(i),
5894  + ibarf(i),nref(i),anf(i)
5895  1050 FORMAT(' ROTATET JET SYSTEM ',i5,5f12.4,3i5,a10)
5896  40 CONTINUE
5897  ENDIF
5898 ************************************************************************
5899 ************************************************************************
5900 C Rotate partons
5901  nnnnp=nnnp
5902  IF(nnnp.GT.1000)nnnnp=1000
5903  DO 1105 i=1,nnnnp
5904  CALL dtrans(pxp(i),pyp(i),pzp(i),cod,sid,cof,sif,xx,yy,zz)
5905  pxp(i)=xx
5906  pyp(i)=yy
5907  pzp(i)=zz
5908  1105 CONTINUE
5909 ************************************************************************
5910 ************************************************************************
5911 C TRANSFORM THIS JET BACK INTO CMS
5912 C************************ IN COMMON BLOCK/CMSRES/
5913 C LORTMO USES /FINPAR/ ONLY !!!!!
5914 C CALL LORTRA(IHAD,1,GAM,BGX,BGY,BGZ)
5915  CALL lortmo(ihad,gam,bgx,bgy,bgz)
5916  nhad=ihad
5917 C
5918  IF (ipco.GE.3)THEN
5919  DO 50 i=1,ihad
5920  WRITE(6,1060) i,pxf(i),pyf(i),pzf(i),hef(i),amf(i), ichf(i),
5921  + ibarf(i),nref(i),anf(i)
5922  1060 FORMAT(' CMS SYSTEM ',i5,5f12.4,3i5,a10)
5923  50 CONTINUE
5924  ENDIF
5925 C HADJET ENERGY CONSERVATION TEST
5926 C AND CONSISTENCY TEST OF PARTICLE 4-MOMENTUM
5927  ltesha=.false.
5928  ehad=0.
5929  DO 60 i=1,ihad
5930  IF(ibarf(i).EQ.500)go to 6060
5931  ehad=ehad+hef(i)
5932  ehecc=sqrt(abs(pxf(i)**2+pyf(i)**2+pzf(i)**2+amf(i)**2))
5933  IF (abs(ehecc-hef(i)).GT.0.001d0) THEN
5934  IF(abs(ehecc-hef(i)).GT.0.1d0)WRITE(6,'(2A/4I5,3E16.6)')
5935  & ' HADJET: CORRECT INCONSISTENT ENERGY AFTER LORTRA',
5936  * ' NORIG, I, IHAD,NREF(I), HEF(I),EHECC, AMF(I)',
5937  * norig, i,ihad,nref(i), hef(i),ehecc, amf(i)
5938  hef(i)=ehecc
5939 C LTESHA=.TRUE.
5940  ENDIF
5941  6060 CONTINUE
5942  60 CONTINUE
5943 ************************************************************************
5944 ************************************************************************
5945 C Transform partons
5946  nnnnp=nnnp
5947  IF(nnnp.GT.1000)nnnnp=1000
5948  nnnpj=nnnnp
5949  CALL lortrp(nnnnp,1,gam,bgx,bgy,bgz)
5950 ************************************************************************
5951 ************************************************************************
5952 C IOUCHA=3
5953 c EEIN=PPR(4)+PTA(4)
5954 c PXIN=PPR(1)+PTA(1)
5955 c PYIN=PPR(2)+PTA(2)
5956 c PZIN=PPR(3)+PTA(3)
5957 C PXIN=BGX*AMCH
5958 C PYIN=BGY*AMCH
5959 C PZIN=BGZ*AMCH
5960  eein=gam*amch
5961  IF (abs(eein-ehad).GT.0.005d0) THEN
5962  icheco=icheco+1
5963  IF (abs(eein-ehad).GT.0.005d0) THEN
5964  IF(icheco.LT.10)THEN
5965  WRITE(6,'(A/10I5)')
5966  + ' HADJET/3:ICHECO,IFB1,IFB2,IFB3,IFB4,I1,I2,NOBAM,NNCH,NORIG',
5967  + icheco,ifb1,
5968  + ifb2,ifb3,ifb4,i1,i2,nobam,nnch,norig
5969  WRITE (6,1070) eein,ehad,amch,gam,bgx,bgy,bgz
5970  1070 FORMAT(' HADJET ENERGY CHECK (5 MeV) EEIN,EHAD,AMCH',3e20.8/
5971  + 20x,' GAM,BGX,BGY,BGZ ',4e20.8)
5972 c WRITE(6,1010)GAM,BGX,BGY,BGZ,PPR,PPRJ
5973  ENDIF
5974  ENDIF
5975  ENDIF
5976 C IPCO=0
5977  RETURN
5978  END
5979 
5980 ************************************************************************
5981 ************************************************************************
5982 *
5983  SUBROUTINE lortrp(N,NAUX,GAM,BGX,BGY,BGZ)
5984 *
5985 * LORENTZ TRANSFORMATION OF N PARTICLES IN JSPART TO BE
5986 * STORED IN JSPAR STARTING AT NAUX
5987 *
5988 *********************************************************************
5989 *
5990  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5991  SAVE
5992 C impl. mxnupa after KNO cut solved 3.92
5993  parameter(mxnupa=2500)
5994  COMMON /jspart/pxp(1000),pyp(1000),pzp(1000),hepp(1000),nnnp
5995  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
5996 * CHANGED JUNE 1,1987
5997  parameter(one=1.d0)
5998  DATA ifirst/0/
5999  DATA num/0/
6000  ifirst=ifirst+1
6001  num=num+1
6002  pxsm=0.0
6003  pysm=0.0
6004  pzsm=0.0
6005  esum=0.
6006  pxsc=0.0
6007  pysc=0.0
6008  pzsc=0.0
6009  esmc=0.0
6010 * END OF CHANGE
6011  DO 1 i=1,n
6012  j = naux + i - 1
6013  pxsm=pxsm+pxp(i)
6014  pysm=pysm+pyp(i)
6015  pzsm=pzsm+pzp(i)
6016  esum=esum+hepp(i)
6017  CALL daltra(gam,bgx,bgy,bgz,pxp(i),pyp(i),pzp(i),hepp(i),
6018  *ppa,pxj(j),pyj(j),pzj(j),hej(j))
6019  pxsc=pxsc+pxj(j)
6020  pysc=pysc+pyj(j)
6021  pzsc=pzsc+pzj(j)
6022  esmc=esmc+hej(j)
6023 1 CONTINUE
6024 * PXSM,ETC,ARE SUMS FOR BAMJET FRAGMENTS IN JET CMS
6025  CALL daltra(gam,bgx,bgy,bgz,pxsm,pysm,pzsm,esum,
6026  *ppa,pxsm,pysm,pzsm,esum)
6027 * PXSC,ETC,ARE SUMS FOR BAMJET FRAGMENTS IN PROJ,TARGET CMS
6028 
6029  pxdif=pxsm-pxsc
6030  pydif=pysm-pysc
6031  pzdif=pzsm-pzsc
6032  edif=esum-esmc
6033  diffl=pxdif+pydif+pzdif+edif
6034  IF(diffl.GE.1.d-2*one)
6035  1WRITE(6,2)num,pxdif,pydif,pzdif,edif,pxsm,pxsc,
6036 C WRITE(6,2)NUM,PXDIF,PYDIF,PZDIF,EDIF,PXSM,PXSC,
6037  1pysm,pysc,pzsm,pzsc,esum,esmc
6038  2 FORMAT(' ',2x,'LORTRA:NUM=',i5,2x,'PXDIF=',1pe15.6,2x,'PYDIF=',
6039  21pe15.6,2x,'PZDIF=',1pe15.6,2x,'EDIF=',1pe15.6/2x,'PXSM=',1pe15.6,
6040  32x,'PXSC=',1pe15.6,2x,'PYSM=',1pe15.6,2x,'PYSC=',1pe15.6/2x,'PZSM'
6041  4,1pe15.6,2x,'PZSC=',1pe15.6,2x,'ESUM=',1pe15.6,2x,'ESMC=',1pe15.6/
6042  52x,'LORTRA DIFFERENCES DUE TO ALTRA'/)
6043  RETURN
6044  END
6045 *
6046 ************************************************************************
6047 ************************************************************************
6048 *-- Author :
6049  SUBROUTINE cobcma(IF1,IF2,IF3,IJNCH,NNCH,IREJ,AMCH,AMCHN,IKET)
6050  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6051  SAVE
6052 C
6053 C REPLACE SMALL MASS BARYON CHAINS (AMCH)
6054 C BY OCTETT OR DECUPLETT BARYONS
6055 C
6056 C HERE ONLY THE CHAIN MASS IS CHANGED
6057 C (AMCHN) BUT NO CORRECTION OF KINEMATICS!
6058 C
6059 C MASS CORRECTED FOR NNCH.NE.0
6060 C
6061 C IREJ=1: CHAIN GENERATION NOT ALLOWED BECAUSE OF TOO SMALL MASS
6062 C START FROM THE BEGINNING IN HAEVT
6063 *KEEP,DPAR.
6064 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6065 C ANAME = LITERAL NAME OF THE PARTICLE
6066 C AAM = PARTICLE MASS IN GEV
6067 C GA = DECAY WIDTH
6068 C TAU = LIFE TIME OF INSTABLE PARTICLES
6069 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6070 C IIBAR = BARYON NUMBER
6071 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6072 C
6073  CHARACTER*8 aname
6074  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
6075  +iibar(210),k1(210),k2(210)
6076 C------------------
6077 *KEEP,DPRIN.
6078  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6079 *KEEP,KETMAS.
6080  COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
6081 *KEND.
6082 C----------------
6083  CALL dbklas(if1,if2,if3,ib8,ibb10)
6084 C
6085  IF (ipev.GE.2)WRITE(6,1000)if1,if2,if3,ib8,ibb10
6086  1000 FORMAT (' COBCMA: IPQ,ITTQ1,ITTQ2,IB8,IBB10 ',5i5)
6087 C
6088  am81=aam(ib8)
6089  am101=aam(ibb10)
6090  am8(iket)=am81
6091  am10(iket)=am101
6092  ib88(iket)=ib8
6093  ib1010(iket)=ibb10
6094  nnch=0
6095  ijnch=0
6096  irej=0
6097  amff1=am101+0.3
6098 C
6099 C j.r.10.5.93
6100 C IF(AMCH.LT.AMFF1) THEN
6101 C IREJ=1
6102 C RETURN
6103 C ENDIF
6104 C -------------
6105  IF(amch.LT.am81) THEN
6106  irej=1
6107  ELSEIF (amch.LT.am101)THEN
6108 C PRODUCE OKTETT BARYON
6109 C CORRECT KINEMATICS
6110  ijnch=ib8
6111  nnch=-1
6112  amchn=am81
6113  ELSEIF(amch.LT.amff1) THEN
6114 C PRODUCE DECUPLETT BARYON
6115 C CORRECT KINEMATICS
6116  amchn=am101
6117  ijnch=ibb10
6118  nnch=1
6119  ELSE
6120  amchn=amch
6121  ENDIF
6122 C NO CORRECTIONS BUT DO CHAIN 2
6123  IF(ipev.GE.2) THEN
6124  WRITE(6,1010) amch,amchn,am81,am101
6125  WRITE(6,1020) if1,if2,if3,ib8,ibb10,ijnch,nnch,irej
6126  1010 FORMAT(' COBCMA: AMCH,AMCHN,AM81,AM101', 4f13.4)
6127  1020 FORMAT(' COBCMA: IF1,IF2,IF3,IB8,IBB10,IJNCH,NNCH,IREJ',8i4)
6128  ENDIF
6129  RETURN
6130  END
6131 *-- Author :
6132 C
6133 C++++++++++++++++++++++++++++++++++++++
6134 C
6135  SUBROUTINE comcma(IFQ,IFAQ,IJNCH,NNCH,IREJ,AMCH,AMCHN)
6136  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6137  SAVE
6138 C
6139 C REPLACE SMALL MASS MESON CHAINS BY PSEUDOSCALAR OR VECTOR MESONS
6140 C
6141 C HERE ONLY THE CHAIN MASS IS CHANGED
6142 C (AMCHN) BUT NO CORRECTION OF KINEMATICS!
6143 C
6144 C
6145 *KEEP,DPAR.
6146 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6147 C ANAME = LITERAL NAME OF THE PARTICLE
6148 C AAM = PARTICLE MASS IN GEV
6149 C GA = DECAY WIDTH
6150 C TAU = LIFE TIME OF INSTABLE PARTICLES
6151 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6152 C IIBAR = BARYON NUMBER
6153 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6154 C
6155  CHARACTER*8 aname
6156  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
6157  +iibar(210),k1(210),k2(210)
6158 C------------------
6159 *KEEP,DINPDA.
6160  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
6161  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
6162 *KEEP,DPRIN.
6163  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6164 *KEND.
6165 C------------------------
6166  iifaq=iabs(ifaq)
6167  ifps=imps(iifaq,ifq)
6168  ifv=imve(iifaq,ifq)
6169  IF (ipev.GE.2)WRITE (6,1000)iifaq,ifq,ifps,ifv
6170  1000 FORMAT (' COMCMA',5x,' IIPPAQ,ITQ,IFPS,IFV ',4i5)
6171  amps=aam(ifps)
6172  amv=aam(ifv)
6173  nnch=0
6174  ijnch=0
6175  irej=0
6176  amff=amv+0.3
6177  IF(ipev.GE.2) WRITE(6,1010) amch,amps,amv,ifps,ifv
6178  1010 FORMAT(' AMCH,AMPS,AMV,IFPS,IFV ',3f12.4,2i10)
6179 C j.r.10.5.93
6180 C IF(AMCH.LT.AMFF) THEN
6181 C IREJ=1
6182 C RETURN
6183 C ENDIF
6184 C ------------
6185 C
6186  IF(amch.LT.amps) THEN
6187  irej=1
6188  RETURN
6189  ENDIF
6190 C
6191  IF (amch.LT.amv) THEN
6192 C PRODUCE PSEUDO SCALAR
6193  ijnch=ifps
6194  nnch=-1
6195  amchn=amps
6196  ELSEIF(amch.LT.amff) THEN
6197 C PRODUCE VECTOR MESON
6198  ijnch=ifv
6199  nnch=1
6200  amchn=amv
6201  ELSE
6202  amchn=amch
6203  ENDIF
6204  IF(ipev.GE.2) THEN
6205  WRITE(6,1030) amch,amchn,amps,amv
6206  WRITE(6,1020) ifq,ifaq,ifps,ifv,ijnch,nnch,irej
6207  1030 FORMAT(' COMCMA: AMCH,AMCHN,AMPS,AMV', 4f13.4)
6208  1020 FORMAT(' COMCMA: IFQ,IFAQ,IFPS,IFV,IJNCH,NNCH,IREJ',8i4)
6209  ENDIF
6210 C
6211  RETURN
6212  END
6213 *-- Author :
6214 C
6215 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6216 C
6217 C 17/10/89 910191458 MEMBER NAME MCOMCM2 (KK89.S) F77
6218  SUBROUTINE comcm2(IQ1,IQ2,IAQ1,IAQ2,NNCH,IREJ,AMCH)
6219  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6220  SAVE
6221 
6222 C--------------------------------------------------------------------
6223 C (QQ)-(AQ AQ) CHAIN:
6224 C CHECK QUANTUM NUMBERS AND
6225 C CORRECT MASS IF NECESSARY
6226 C REJECT IF THERE IS NO CORRESPONDING PARTICLE
6227 C OR TOO LOW MASS
6228 C--------------------------------------------------------------------
6229 *KEEP,DPAR.
6230 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6231 C ANAME = LITERAL NAME OF THE PARTICLE
6232 C AAM = PARTICLE MASS IN GEV
6233 C GA = DECAY WIDTH
6234 C TAU = LIFE TIME OF INSTABLE PARTICLES
6235 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6236 C IIBAR = BARYON NUMBER
6237 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6238 C
6239  CHARACTER*8 aname
6240  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
6241  +iibar(210),k1(210),k2(210)
6242 C------------------
6243 *KEEP,DPRIN.
6244  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6245 *KEEP,DINPDA.
6246  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
6247  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
6248 *KEND.
6249 C--------------------------
6250  irej=0
6251  iiaq1=-iaq1
6252  iiaq2=-iaq2
6253  IF (iiaq1.EQ.iq1) go to 10
6254  IF (iiaq1.EQ.iq2) go to 20
6255  IF (iiaq2.EQ.iq1) go to 30
6256  IF (iiaq2.EQ.iq2) go to 40
6257 C REJECTION: NO CANCELLATION OF
6258 C ANY (Q-AQ) PAIR
6259  irej=1
6260  IF(ipev.GE.3) THEN
6261  WRITE(6,'(A/5X,4I5,1PE13.5)')
6262  + ' KKEVVV/COMCM2 (QU. NUMBERS): IQ1, IQ2, IAQ1, IAQ2, AMCH', iq1,
6263  + iq2, iaq1, iaq2, amch
6264  ENDIF
6265  RETURN
6266 C
6267  10 CONTINUE
6268 C IFPS=IMPS(IIAQ2,IQ2)
6269 C IFV =IMVE(IIAQ2,IQ2)
6270  go to 50
6271  20 CONTINUE
6272 C IFPS=IMPS(IIAQ2,IQ1)
6273 C IFV =IMVE(IIAQ2,IQ1)
6274  go to 50
6275  30 CONTINUE
6276 C IFPS=IMPS(IIAQ1,IQ2)
6277 C IFV =IMVE(IIAQ1,IQ2)
6278  go to 50
6279  40 CONTINUE
6280 C IFPS=IMPS(IIAQ1,IQ1)
6281 C IFV =IMVE(IIAQ1,IQ1)
6282 C
6283  50 CONTINUE
6284 C AMFPS=AAM(IFPS)
6285 C AMFV =AAM(IFV)
6286 C AMFF=AMFV+0.3
6287 C EMPIRICAL DEFINITION OF AMFF
6288 C TO ALLOW FOR (B-ANTIB) PAIR PRODUCTION
6289  amff=2.5
6290  nnch=0
6291  IF (amch.LT.amff) THEN
6292  irej=1
6293  IF(ipev.GE.3) THEN
6294  WRITE(6,'(A/5X,4I5,1PE13.5)')
6295  + ' KKEVVV/COMCM2 (MASS!): IQ1, IQ2, IAQ1, IAQ2, AMCH', iq1,
6296  + iq2, iaq1, iaq2, amch
6297  ENDIF
6298  ENDIF
6299  RETURN
6300  END
6301 *-- Author :
6302 C
6303 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6304 C
6305  SUBROUTINE cormom(AMCH1,AMCH2,AMCH1N,AMCH2N,
6306  +pq1x,pq1y,pq1z,pq1e,pa1x,pa1y,pa1z,pa1e, pq2x,pq2y,pq2z,pq2e,pa2x,
6307  +pa2y,pa2z,pa2e, pxch1,pych1,pzch1,ech1, pxch2,pych2,pzch2,ech2,
6308  +irej)
6309  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6310  SAVE
6311 C
6312 C CORRECT KINEMATICS IF MASS OF THE FIRST CHAIN HAS BEEN CHANGED
6313 C FROM AMCH1 TO AMCH1N
6314 C CHAIN 1: (XP,XTVD)
6315 C AMMM : TOTAL MASS OF TWO CHAIN SYSTEM
6316 C AMCH2N : RESULTING NEW MASS FOR CHAIN 2 (OUTPUT ONLY)
6317 C
6318 C--- RESCALING OF X-VALUES
6319 C ACCORDING TO THE MODIFIED MASS OF CHAIN 1
6320 *KEEP,DPRIN.
6321  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6322 *KEND.
6323 C------------------------------------
6324 C WRITE(6,'(A,4(7E15.5/))')' CORMOM IN',AMCH1,AMCH2,AMCH1N,AMCH2N,
6325 C +PQ1X,PQ1Y,PQ1Z,PQ1E,PA1X,PA1Y,PA1Z,PA1E, PQ2X,PQ2Y,PQ2Z,PQ2E,PA2X,
6326 C +PA2Y,PA2Z,PA2E, PXCH1,PYCH1,PZCH1,ECH1, PXCH2,PYCH2,PZCH2,ECH2
6327 C
6328  IF(amch1.EQ.0.d0)THEN
6329  irej=1
6330  WRITE(6,*) 'Error in CORMOM : AMCH1=0. Event rejected'
6331  RETURN
6332  ENDIF
6333  fak=amch1n/amch1
6334 C WRITE(6,'(A,F10.5)')' FAK ',FAK
6335  amch1=amch1n
6336 C
6337  pq1xol=pq1x
6338  pq1yol=pq1y
6339  pq1zol=pq1z
6340  pq1eol=pq1e
6341  pa1xol=pa1x
6342  pa1yol=pa1y
6343  pa1zol=pa1z
6344  pa1eol=pa1e
6345  pq2xol=pq2x
6346  pq2yol=pq2y
6347  pq2zol=pq2z
6348  pq2eol=pq2e
6349  pa2xol=pa2x
6350  pa2yol=pa2y
6351  pa2zol=pa2z
6352  pa2eol=pa2e
6353 C
6354  pxch1o=pxch1
6355  pych1o=pych1
6356  pzch1o=pzch1
6357  ech10=ech1
6358  pxch2o=pxch2
6359  pych2o=pych2
6360  pzch2o=pzch2
6361  ech20=ech2
6362 C
6363 C
6364 C--- RESCALING OF MOMENTA FOR PARTONS OF CHAIN 1
6365  pq1x=pq1x*fak
6366  pq1y=pq1y*fak
6367  pq1z=pq1z*fak
6368  pq1e=pq1e*fak
6369  pa2x=pa2x*fak
6370  pa2y=pa2y*fak
6371  pa2z=pa2z*fak
6372  pa2e=pa2e*fak
6373 C NEW MOMENTA OF PARTONS OF CHAIN 2
6374 C FROM MOMENTUM CONSERVATION
6375  pa1x=pa1xol+pq1xol-pq1x
6376  pa1y=pa1yol+pq1yol-pq1y
6377  pa1z=pa1zol+pq1zol-pq1z
6378  pa1e=pa1eol+pq1eol-pq1e
6379  pq2x=pq2xol+pa2xol-pa2x
6380  pq2y=pq2yol+pa2yol-pa2y
6381  pq2z=pq2zol+pa2zol-pa2z
6382  pq2e=pq2eol+pa2eol-pa2e
6383 C--- NEW MOMENTUM OF CHAIN 1
6384  pxch1=pq1x+pa2x
6385  pych1=pq1y+pa2y
6386  pzch1=pq1z+pa2z
6387  ech1 =pq1e+pa2e
6388 C
6389 C WRITE(6,'(A,4(7E15.5/))')' CORMOM MOD',AMCH1,AMCH2,AMCH1N,AMCH2N,
6390 C +PQ1X,PQ1Y,PQ1Z,PQ1E,PA1X,PA1Y,PA1Z,PA1E, PQ2X,PQ2Y,PQ2Z,PQ2E,PA2X,
6391 C +PA2Y,PA2Z,PA2E, PXCH1,PYCH1,PZCH1,ECH1, PXCH2,PYCH2,PZCH2,ECH2
6392 C
6393  root =(ech1-amch1)*(ech1+amch1)
6394  IF(root.LT.0.d0)THEN
6395  irej=1
6396  WRITE(6,*)'Error in CORMOM : ROOT<0. Event rejected'
6397  WRITE(6,*)'ECH1=',ech1,' AMCH1=',amch1,' ROOT=',root
6398  RETURN
6399  ENDIF
6400  pch1 = sqrt(root) + 0.000001
6401 C
6402 C--- NEW 4-MOMENTUM OF CHAIN 2
6403  pxch2=pa1x+pq2x
6404  pych2=pa1y+pq2y
6405  pzch2=pa1z+pq2z
6406  ech2 =pa1e+pq2e
6407  pch2 =sqrt(pxch2**2+pych2**2+pzch2**2)
6408  amch22=ech2**2-pxch2**2-pych2**2-pzch2**2
6409 C
6410  IF(amch22.LT.0.d0)THEN
6411  irej=1
6412  WRITE(6,*)'Error in CORMOM : AMCH22<0. Event rejected'
6413 C WRITE(6,*)'ECH2=',ECH2,' PXCH2=',PXCH2,' PYCH2=',PYCH2,
6414 C * ' PZCH2=',PZCH2
6415  RETURN
6416  ENDIF
6417  amch2n=sqrt(amch22)
6418 C---
6419  IF(ipri.GT.1) THEN
6420  pxsum=pq1x+pa1x+pq2x+pa2x
6421  pysum=pq1y+pa1y+pq2y+pa2y
6422  pzsum=pq1z+pa1z+pq2z+pa2z
6423  pesum=pq1e+pa1e+pq2e+pa2e
6424  WRITE(6,'(A)') ' CORMOM: KINEMATIC TEST FOR PARTONS'
6425  WRITE(6,'(A,4(1PE12.5))') ' PXSUM,PYSUM,PZSUM,PESUM', pxsum,
6426  + pysum,pzsum,pesum
6427  ENDIF
6428  RETURN
6429  END
6430 *-- Author :
6431 C
6432 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6433 
6434 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6435  SUBROUTINE selpt4( PTXSQ1,PTYSQ1,
6436  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6437  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,nselpt)
6438  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6439  SAVE
6440 C SELECT PT VALUES FOR A TWO CHAIN SYSTEM
6441 C SELECT SEA QUARK AND ANTIQUARK PT-VALUES
6442 *KEEP,DPRIN.
6443  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6444 *KEEP,DROPPT.
6445  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
6446  +ishmal,lpauli
6447  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
6448  +ipadis,ishmal,lpauli
6449 *KEND.
6450  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
6451 C--------------------------------
6452 C change j.r.6.5.93
6453  qtxsq1=ptxsq1
6454  qtxsa1=ptxsa1
6455  qtxsq2=ptxsq2
6456  qtxsa2=ptxsa2
6457  qtysq1=ptysq1
6458  qtysa1=ptysa1
6459  qtysq2=ptysq2
6460  qtysa2=ptysa2
6461  qlq1=plq1
6462  qlaq1=plaq1
6463  qlq2=plq2
6464  qlaq2=plaq2
6465  qeq1=eq1
6466  qeaq1=eaq1
6467  qeq2=eq2
6468  qeaq2=eaq2
6469 C ----------------
6470  ianfa=0
6471  itagpt=0
6472 C changed from 3. j.r.21.8.93
6473  b33=16.00
6474  IF (ikvala.EQ.1)b33=16.0
6475  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6476  hps=sqrt(es*es+2.*es*0.94)
6477 C............................................................
6478  IF (.NOT.intpt) hps=0.0000001
6479  icount=0
6480  irej=0
6481  10 CONTINUE
6482  icount=icount+1
6483  IF (icount.EQ.48)THEN
6484  hps=0.d0
6485  ENDIF
6486  IF (icount.EQ.50)THEN
6487 C REJECT EVENT
6488  irej=1
6489  RETURN
6490  ENDIF
6491  IF (icount.GE.1)THEN
6492  hps=hps*0.8
6493  CALL dsfecf(sfe,cfe)
6494  ptxsq1=qtxsq1+hps*cfe
6495  ptysq1=qtysq1+hps*sfe
6496  ptxsa1=qtxsa1-hps*cfe
6497  ptysa1=qtysa1-hps*sfe
6498  go to 111
6499  ENDIF
6500  b33=2.*b33
6501  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6502  hps=sqrt(es*es+2.*es*0.94)
6503 C............................................................
6504  110 CONTINUE
6505  IF (.NOT.intpt) hps=0.0000001
6506 C.............................................................
6507  CALL dsfecf(sfe,cfe)
6508 C change j.r.6.5.93
6509  ptxsq1=qtxsq1+hps*cfe
6510  ptysq1=qtysq1+hps*sfe
6511  ptxsa1=qtxsa1-hps*cfe
6512  ptysa1=qtysa1-hps*sfe
6513  111 CONTINUE
6514 C -----------------
6515  IF (ipev.GE.7)WRITE(6,1000)ptxsq1,ptysq1,ptxsa1,ptysa1 ,ptxsq2,
6516  +ptysq2,ptxsa2,ptysa2
6517  1000 FORMAT (' PT S ',8f12.6)
6518 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
6519  pttq1=ptxsq1**2+ptysq1**2
6520  ptta1=ptxsa1**2+ptysa1**2
6521  IF((eq1**2.LE.pttq1).OR. (eaq1**2.LE.ptta1)) go to 10
6522 C
6523  ianfa2=0
6524  itagp2=0
6525  b33=16.00
6526  IF (ikvala.EQ.1)b33=16.0
6527  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6528  hps=sqrt(es*es+2.*es*0.94)
6529 C............................................................
6530  IF (.NOT.intpt) hps=0.0000001
6531  icoun2=0
6532  irej=0
6533  12 CONTINUE
6534  icoun2=icoun2+1
6535  IF (icoun2.EQ.48)THEN
6536  hps=0.d0
6537  ENDIF
6538  IF (icoun2.EQ.50)THEN
6539  irej=1
6540 C REJECT EVENT
6541  RETURN
6542  ENDIF
6543  IF(icoun2.GE.1)THEN
6544  hps=hps*0.8
6545  CALL dsfecf(sfe,cfe)
6546  ptxsq2=qtxsq2+hps*cfe
6547  ptysq2=qtysq2+hps*sfe
6548  ptxsa2=qtxsa2-hps*cfe
6549  ptysa2=qtysa2-hps*sfe
6550  go to 113
6551  ENDIF
6552  b33=2.*b33
6553 C
6554  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6555  hps=sqrt(es*es+2.*es*0.94d0)
6556 C............................................................
6557  112 CONTINUE
6558  IF (.NOT.intpt) hps=0.0000001
6559 C.............................................................
6560  CALL dsfecf(sfe,cfe)
6561 C change j.r.6.5.93
6562  ptxsq2=qtxsq2+hps*cfe
6563  ptysq2=qtysq2+hps*sfe
6564  ptxsa2=qtxsa2-hps*cfe
6565  ptysa2=qtysa2-hps*sfe
6566  113 CONTINUE
6567 C -----------------
6568 C
6569  IF (ipev.GE.7)WRITE(6,1000)ptxsq1,ptysq1,ptxsa1,ptysa1 ,ptxsq2,
6570  +ptysq2,ptxsa2,ptysa2
6571 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
6572  pttq2=ptxsq2**2+ptysq2**2
6573  ptta2=ptxsa2**2+ptysa2**2
6574  IF((eq2**2.LE.pttq2).OR. (eaq2**2.LE.ptta2)) go to 12
6575 C
6576 C IF(IP.GE.1)GO TO 1779
6577  plq1=sqrt(eq1**2-pttq1)
6578  plaq1=sqrt(eaq1**2-ptta1)
6579  plq2=-sqrt(eq2**2-pttq2)
6580  plaq2=-sqrt(eaq2**2-ptta2)
6581  1779 CONTINUE
6582 C-----------
6583 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
6584  amch1q=(eq1+eaq2)**2-(ptxsq1+ptxsa2)** 2-(ptysq1+ptysa2)**2-(plq1
6585  ++plaq2)**2
6586  IF (amch1q.LE.0.d0)THEN
6587  WRITE(6,301)amch1q
6588  301 FORMAT(' inconsistent Kinematics in SELPT AMCH1Q=',e12.3)
6589  WRITE(6,305) qtxsq1,qtysq1,
6590  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
6591  +qtxsa2,
6592  +qtysa2,qlaq2,qeaq2, amch1,amch2
6593  305 FORMAT( 'PTXSQ1,PTYSQ1,
6594  +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,PTYSQ2,PLQ2,EQ2,PTXSA2,
6595  +PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2',5(4e15.5/))
6596  irej=1
6597  RETURN
6598  ENDIF
6599  amch1=sqrt(amch1q)
6600 C
6601 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
6602  amch2q=(eq2+eaq1)**2-(ptxsq2+ptxsa1)** 2-(ptysq2+ptysa1)**2-(plq2
6603  ++plaq1)**2
6604  IF (amch2q.LE.0.d0)THEN
6605  WRITE(6,302)amch2q
6606  302 FORMAT(' inconsistent Kinematics in SELPT AMCH2Q=',e12.3)
6607  WRITE(6,305) qtxsq1,qtysq1,
6608  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
6609  +qtxsa2,
6610  +qtysa2,qlaq2,qeaq2, amch1,amch2
6611 C IF(ITAGPT.EQ.0)GO TO !33
6612  irej=1
6613  RETURN
6614  ENDIF
6615  amch2=sqrt(amch2q)
6616  RETURN
6617  END
6618 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6619 
6620  SUBROUTINE selpt( PTXSQ1,PTYSQ1,
6621  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6622  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6623  * pttq2,ptta2, nselpt)
6624  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6625  SAVE
6626 C SELECT PT VALUES FOR A TWO CHAIN SYSTEM DPMJET (combined
6627 C DTUNUC/TUJET method)
6628 C SELECT SEA QUARK AND ANTIQUARK PT-VALUES
6629 *KEEP,DPRIN.
6630  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6631 *KEEP,DROPPT.
6632  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
6633  +ishmal,lpauli
6634  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
6635  +ipadis,ishmal,lpauli
6636 *KEND.
6637  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
6638  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
6639  data nusept /0/
6640  data musept /0/
6641  IF(ipev.GE.4)WRITE(6,6633) ptxsq1,ptysq1,
6642  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6643  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6644  * nselpt
6645  6633 FORMAT(' selpt input: ',
6646  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6647  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6648  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,2i5,2e12.4,i5)
6649 C--------------------------------
6650 C change j.r.6.5.93
6651  qtxsq1=ptxsq1
6652  qtxsa1=ptxsa1
6653  qtxsq2=ptxsq2
6654  qtxsa2=ptxsa2
6655  qtysq1=ptysq1
6656  qtysa1=ptysa1
6657  qtysq2=ptysq2
6658  qtysa2=ptysa2
6659  qlq1=plq1
6660  qlaq1=plaq1
6661  qlq2=plq2
6662  qlaq2=plaq2
6663  qeq1=eq1
6664  qeaq1=eaq1
6665  qeq2=eq2
6666  qeaq2=eaq2
6667 C ----------------
6668  ianfa=0
6669  itagpt=0
6670  ianfa2=0
6671  itagp2=0
6672  irej=0
6673  icount=0
6674  icoun2=0
6675  1 CONTINUE
6676  IF ( nselpt.EQ.0 .OR.umo.LE.20.d0) THEN
6677 C changed from 3. j.r.21.8.93
6678  b33=16.0
6679 C IF (IKVALA.EQ.1)B33=3.7
6680 C Test 12.2.96
6681 C IF (IKVALA.EQ.1)B33=(3.0+6.0/LOG10(UMO+10.))/2.
6682  IF (ikvala.EQ.1)b33=3.0+6.0/log10(umo+10.)
6683  IF (ikvala.EQ.2)b33=4.0+3.0/log10(umo+10.)
6684  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6685  hps=sqrt(es*es+2.*es*0.94)
6686 C............................................................
6687  110 CONTINUE
6688  IF (.NOT.intpt) hps=0.0000001
6689 C.............................................................
6690  10 CONTINUE
6691  icount=icount+1
6692  IF (icount.EQ.48)THEN
6693  hps=0.d0
6694  ENDIF
6695  IF (icount.EQ.50)THEN
6696 C REJECT EVENT
6697  irej=1
6698  RETURN
6699  ENDIF
6700  IF (icount.GE.2)THEN
6701  hps=hps*0.8
6702  ptxsq1=ptxsq1*0.8
6703  ptysq1=ptysq1*0.8
6704  ptxsa1=ptxsa1*0.8
6705  ptysa1=ptysa1*0.8
6706  CALL dsfecf(sfe,cfe)
6707 C PTXSQ1=QTXSQ1+HPS*CFE
6708 C PTYSQ1=QTYSQ1+HPS*SFE
6709 C PTXSA1=QTXSA1-HPS*CFE
6710 C PTYSA1=QTYSA1-HPS*SFE
6711  go to 111
6712  ENDIF
6713  b33=2.*b33
6714  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6715  hps=sqrt(es*es+2.*es*0.94)
6716 C............................................................
6717  IF (.NOT.intpt) hps=0.0000001
6718 C
6719  ELSEIF(nselpt.EQ.1)THEN
6720  CALL samppt(1,hps)
6721  IF(ipev.GE.4)WRITE(6,6638)hps
6722  ELSEIF(nselpt.EQ.2)THEN
6723  IF (nusept.EQ.0)THEN
6724  CALL samppt(1,hps)
6725  IF(ipev.GE.4)WRITE(6,6638)hps
6726  nusept=1
6727  usept=hps
6728  ELSEIF(nusept.EQ.1)THEN
6729  hps=usept
6730  ENDIF
6731  ENDIF
6732  CALL dsfecf(sfe,cfe)
6733 C change j.r.6.5.93
6734  ptxsq1=qtxsq1+hps*cfe
6735  ptysq1=qtysq1+hps*sfe
6736  ptxsa1=qtxsa1-hps*cfe
6737  ptysa1=qtysa1-hps*sfe
6738  qtxsq1=qtxsq1*0.8
6739  qtysq1=qtysq1*0.8
6740  qtxsa1=qtxsa1*0.8
6741  qtysa1=qtysa1*0.8
6742  111 CONTINUE
6743 C -----------------
6744 C
6745  IF (ipev.GE.7)WRITE(6,1000)ptxsq1,ptysq1,ptxsa1,ptysa1 ,ptxsq2,
6746  +ptysq2,ptxsa2,ptysa2
6747  1000 FORMAT (' PT S ',8f12.6)
6748 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
6749  pttq1=ptxsq1**2+ptysq1**2
6750  ptta1=ptxsa1**2+ptysa1**2
6751 C
6752  IF ( nselpt.EQ.0.OR.umo.LE.20.d0 ) THEN
6753  b33=16.0
6754 C IF (IKVALA.EQ.1)B33=3.7
6755  IF (ikvala.EQ.1)b33=3.0+6.0/log10(umo+10.)
6756  IF (ikvala.EQ.2)b33=4.0+3.0/log10(umo+10.)
6757  irej=0
6758  12 CONTINUE
6759  icoun2=icoun2+1
6760  IF (icoun2.EQ.48)THEN
6761  hps=0.d0
6762  ENDIF
6763  IF (icoun2.EQ.50)THEN
6764 C REJECT EVENT
6765  irej=1
6766  RETURN
6767  ENDIF
6768  IF(icoun2.GE.2)THEN
6769  hps=hps*0.8
6770  ptxsq2=ptxsq2*0.8
6771  ptysq2=ptysq2*0.8
6772  ptxsa2=ptxsa2*0.8
6773  ptysa2=ptysa2*0.8
6774  CALL dsfecf(sfe,cfe)
6775 C PTXSQ2=QTXSQ2+HPS*CFE
6776 C PTYSQ2=QTYSQ2+HPS*SFE
6777 C PTXSA2=QTXSA2-HPS*CFE
6778 C PTYSA2=QTYSA2-HPS*SFE
6779  go to 113
6780  ENDIF
6781  b33=2.*b33
6782 C
6783  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
6784  hps=sqrt(es*es+2.*es*0.94)
6785 C............................................................
6786  112 CONTINUE
6787  IF (.NOT.intpt) hps=0.0000001
6788 C.............................................................
6789  ELSEIF(nselpt.EQ.1)THEN
6790  IF (musept.EQ.0)THEN
6791  CALL samppt(1,hps)
6792  IF(ipev.GE.4)WRITE(6,6638)hps
6793  6638 FORMAT (' SELPT:SAMPPT: HPS= ',e12.4)
6794  musept=1
6795  useptm=hps
6796  ELSEIF(musept.EQ.1)THEN
6797  hps=useptm
6798  ENDIF
6799  ENDIF
6800  CALL dsfecf(sfe,cfe)
6801 C change j.r.6.5.93
6802  ptxsq2=qtxsq2+hps*cfe
6803  ptysq2=qtysq2+hps*sfe
6804  ptxsa2=qtxsa2-hps*cfe
6805  ptysa2=qtysa2-hps*sfe
6806  qtxsq2=qtxsq2*0.8
6807  qtysq2=qtysq2*0.8
6808  qtxsa2=qtxsa2*0.8
6809  qtysa2=qtysa2*0.8
6810  113 CONTINUE
6811 C -----------------
6812 C
6813  IF (ipev.GE.7)WRITE(6,1000)ptxsq1,ptysq1,ptxsa1,ptysa1 ,ptxsq2,
6814  +ptysq2,ptxsa2,ptysa2
6815 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
6816  pttq1=ptxsq1**2+ptysq1**2
6817  ptta1=ptxsa1**2+ptysa1**2
6818  pttq2=ptxsq2**2+ptysq2**2
6819  ptta2=ptxsa2**2+ptysa2**2
6820  ptwq1=sqrt(pttq1)
6821  ptwa1=sqrt(ptta1)
6822  ptwq2=sqrt(pttq2)
6823  ptwa2=sqrt(ptta2)
6824  IF(plq1.GT.ptwq1.AND.abs(plaq2).GT.ptwq1)THEN
6825  plq1=qlq1-ptwq1
6826  plaq2=qlaq2+ptwq1
6827  ELSEIF(plq1.GT.ptwa2.AND.abs(plaq2).GT.ptwa2)THEN
6828  plq1=qlq1-ptwa2
6829  plaq2=qlaq2+ptwa2
6830  ENDIF
6831  IF(plaq1.GT.ptwa1.AND.abs(plq2).GT.ptwa1)THEN
6832  plaq1=qlaq1-ptwa1
6833  plq2=qlq2+ptwa1
6834  ELSEIF(plaq1.GT.ptwq2.AND.abs(plq2).GT.ptwq2)THEN
6835  plaq1=qlaq1-ptwq2
6836  plq2=qlq2+ptwq2
6837  ENDIF
6838  qlq1=plq1
6839  qlaq1=plaq1
6840  qlq2=plq2
6841  qlaq2=plaq2
6842  pttq1=pttq1+plq1**2
6843  ptta1=ptta1+plaq1**2
6844  pttq2=pttq2+plq2**2
6845  ptta2=ptta2+plaq2**2
6846  IF (intpt) THEN
6847  amte1=0.2
6848  IF(amte1.GE.eq1**2)amte1=eq1**2/2.
6849  amte2=0.2
6850  IF(amte2.GE.eq2**2)amte2=eq2**2/2.
6851  amte3=0.2
6852  IF(amte1.GE.eaq1**2)amte1=eaq1**2/2.
6853  amte4=0.2
6854  IF(amte2.GE.eaq2**2)amte2=eaq2**2/2.
6855  IF((eq1**2-amte1.LE.pttq1).OR.
6856  * (eq2**2-amte1.LE.pttq2)
6857  * .OR.(eaq1**2-amte3.LE.ptta1).OR.
6858  * (eaq2**2-amte4.LE.ptta2))THEN
6859  IF ( nselpt.EQ.0.OR.umo.LE.20.d0 ) THEN
6860  go to 1
6861  ELSE
6862  usept = usept * 0.7
6863  useptm = useptm * 0.7
6864  IF( usept.GT.0.01d0 .OR. useptm.GT.0.01d0 ) THEN
6865  IF (ipev.GE.6)THEN
6866  WRITE(6,*)' SELPT: JUMP AFTER REDUCTION OF USEPT'
6867  WRITE(6,*)' SELPT: USEPT,USEPTM,HPS',usept,useptm,hps
6868  ENDIF
6869  go to 1
6870  ELSE
6871  irej = 1
6872  IF(ipev.GE.4)WRITE(6,6634) ptxsq1,ptysq1,
6873  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6874  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6875  * nselpt
6876  6634 FORMAT(' selpt rejec: ',
6877  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6878  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6879  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,3i5)
6880  RETURN
6881  ENDIF
6882  ENDIF
6883  ENDIF
6884  ENDIF
6885  nusept=0
6886  musept=0
6887 C
6888  IF(ip.GE.1)go to 1779
6889  qqq1=qtxsq1**2+qtysq1**2+qlq1**2-pttq1
6890  IF(qqq1.GT.0.d0)THEN
6891  plq1=sqrt(qqq1)
6892  ELSE
6893  plq1=sqrt(eq1**2-pttq1)
6894  ENDIF
6895  qqa1=qtxsa1**2+qtysa1**2+qlaq1**2-ptta1
6896  IF(qqa1.GT.0.d0)THEN
6897  plaq1=sqrt(qqa1)
6898  ELSE
6899  plaq1=sqrt(eaq1**2-ptta1)
6900  ENDIF
6901  qqq2=qtxsq2**2+qtysq2**2+qlq2**2-pttq2
6902  IF(qqq2.GT.0.d0)THEN
6903  plq2=-sqrt(qqq2)
6904  ELSE
6905  plq2=-sqrt(eq2**2-pttq2)
6906  ENDIF
6907  qqa2=qtxsa2**2+qtysa2**2+qlaq2**2-ptta2
6908  IF(qqa2.GT.0.d0)THEN
6909  plaq2=-sqrt(qqa2)
6910  ELSE
6911  plaq2=-sqrt(eaq2**2-ptta2)
6912  ENDIF
6913  1779 CONTINUE
6914 C-----------
6915 C-----------
6916 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
6917  amch1q=(eq1+eaq2)**2-(ptxsq1+ptxsa2)** 2-(ptysq1+ptysa2)**2-(plq1
6918  ++plaq2)**2
6919  IF (amch1q.LE.0.d0)THEN
6920 C IF(IANFA.EQ.0)THEN
6921 C IANFA=1
6922 C ITAGPT=1
6923 C GO TO 110
6924 C ENDIF
6925 C GO TO 10
6926  WRITE(6,301)amch1q
6927  301 FORMAT(' inconsistent Kinematics in SELPT AMCH1Q=',e12.3)
6928  WRITE(6,305) qtxsq1,qtysq1,
6929  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
6930  +qtxsa2,
6931  +qtysa2,qlaq2,qeaq2, amch1,amch2
6932  305 FORMAT( 'PTXSQ1,PTYSQ1,
6933  +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,PTYSQ2,PLQ2,EQ2,PTXSA2,
6934  +PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2',5(4e15.5/))
6935 C IF(ITAGPT.EQ.0)GO TO !33
6936  irej=1
6937  IF(ipev.GE.4)WRITE(6,6635) ptxsq1,ptysq1,
6938  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6939  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6940  * nselpt
6941  6635 FORMAT(' selpt rejec: ',
6942  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6943  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6944  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,3i5)
6945  RETURN
6946  ENDIF
6947  amch1=sqrt(amch1q)
6948 C
6949 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
6950  amch2q=(eq2+eaq1)**2-(ptxsq2+ptxsa1)** 2-(ptysq2+ptysa1)**2-(plq2
6951  ++plaq1)**2
6952  IF (amch2q.LE.0.d0)THEN
6953 C IF(IANFA.EQ.0)THEN
6954 C IANFA=1
6955 C ITAGPT=1
6956 C GO TO 110
6957 C ENDIF
6958 C GO TO 10
6959  WRITE(6,302)amch2q
6960  302 FORMAT(' inconsistent Kinematics in SELPT AMCH2Q=',e12.3)
6961  WRITE(6,305) qtxsq1,qtysq1,
6962  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
6963  +qtxsa2,
6964  +qtysa2,qlaq2,qeaq2, amch1,amch2
6965 C IF(ITAGPT.EQ.0)GO TO !33
6966  irej=1
6967  IF(ipev.GE.4)WRITE(6,6636) ptxsq1,ptysq1,
6968  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6969  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6970  * nselpt
6971  6636 FORMAT(' selpt rejec: ',
6972  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6973  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6974  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,3i5)
6975  RETURN
6976  ENDIF
6977  amch2=sqrt(amch2q)
6978  IF(ipev.GE.4)WRITE(6,6637) ptxsq1,ptysq1,
6979  +plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6980  +ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6981  * nselpt
6982  6637 FORMAT(' selpt exit : ',
6983  + ' PTXSQ1,PTYSQ1, +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,
6984  + PTYSQ2,PLQ2,EQ2,PTXSA2, PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2,IREJ,
6985  +IKVALA, NSELPT ', 2(8e12.4/),2e12.4,2i5,2e12.4,i5)
6986  RETURN
6987  END
6988 *-- Author :
6989 C
6990 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6991 C
6992  SUBROUTINE dechkk(NHKKH1)
6993  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6994  SAVE
6995 *KEEP,HKKEVT.
6996 c INCLUDE (HKKEVT)
6997  parameter(nmxhkk= 89998)
6998 c PARAMETER (NMXHKK=25000)
6999  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
7000  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
7001  +(4,nmxhkk)
7002  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
7003  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
7004 C
7005 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
7006 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
7007 C THE POSITIONS OF THE PROJECTILE NUCLEONS
7008 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
7009 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
7010 C COMPLETELY CONSISTENT. THE TIMES IN THE
7011 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
7012 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
7013 C
7014 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
7015 C
7016 C NMXHKK: maximum numbers of entries (partons/particles) that can be
7017 C stored in the commonblock.
7018 C
7019 C NHKK: the actual number of entries stored in current event. These are
7020 C found in the first NHKK positions of the respective arrays below.
7021 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
7022 C entry.
7023 C
7024 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
7025 C = 0 : null entry.
7026 C = 1 : an existing entry, which has not decayed or fragmented.
7027 C This is the main class of entries which represents the
7028 C "final state" given by the generator.
7029 C = 2 : an entry which has decayed or fragmented and therefore
7030 C is not appearing in the final state, but is retained for
7031 C event history information.
7032 C = 3 : a documentation line, defined separately from the event
7033 C history. (incoming reacting
7034 C particles, etc.)
7035 C = 4 - 10 : undefined, but reserved for future standards.
7036 C = 11 - 20 : at the disposal of each model builder for constructs
7037 C specific to his program, but equivalent to a null line in the
7038 C context of any other program. One example is the cone defining
7039 C vector of HERWIG, another cluster or event axes of the JETSET
7040 C analysis routines.
7041 C = 21 - : at the disposal of users, in particular for event tracking
7042 C in the detector.
7043 C
7044 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
7045 C standard.
7046 C
7047 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
7048 C The value is 0 for initial entries.
7049 C
7050 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
7051 C one mother exist, in which case the value 0 is used. In cluster
7052 C fragmentation models, the two mothers would correspond to the q
7053 C and qbar which join to form a cluster. In string fragmentation,
7054 C the two mothers of a particle produced in the fragmentation would
7055 C be the two endpoints of the string (with the range in between
7056 C implied).
7057 C
7058 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
7059 C entry has not decayed, this is 0.
7060 C
7061 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
7062 C entry has not decayed, this is 0. It is assumed that the daughters
7063 C of a particle (or cluster or string) are stored sequentially, so
7064 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
7065 C daughters. Even in cases where only one daughter is defined (e.g.
7066 C K0 -> K0S) both values should be defined, to make for a uniform
7067 C approach in terms of loop constructions.
7068 C
7069 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
7070 C
7071 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
7072 C
7073 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
7074 C
7075 C PHKK(4,IHKK) : energy, in GeV.
7076 C
7077 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
7078 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
7079 C
7080 C VHKK(1,IHKK) : production vertex x position, in mm.
7081 C
7082 C VHKK(2,IHKK) : production vertex y position, in mm.
7083 C
7084 C VHKK(3,IHKK) : production vertex z position, in mm.
7085 C
7086 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
7087 C********************************************************************
7088 *KEEP,DDECAC.
7089  parameter(idmax9=602)
7090  CHARACTER*8 zkname
7091  COMMON /ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
7092 *KEEP,DPRIN.
7093  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7094 *KEEP,DPAR.
7095 C /DPAR/ CONTAINS PARTICLE PROPERTIES
7096 C ANAME = LITERAL NAME OF THE PARTICLE
7097 C AAM = PARTICLE MASS IN GEV
7098 C GA = DECAY WIDTH
7099 C TAU = LIFE TIME OF INSTABLE PARTICLES
7100 C IICH = ELECTRIC CHARGE OF THE PARTICLE
7101 C IIBAR = BARYON NUMBER
7102 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
7103 C
7104  CHARACTER*8 aname
7105  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
7106  +iibar(210),k1(210),k2(210)
7107 C------------------
7108 *KEND.
7109  dimension ecmf(3),pcmf(3),codf(3),coff(3),siff(3),itf(3)
7110  dimension ecmff(3),pcmff(3)
7111  dimension cxf(3),cyf(3),czf(3)
7112  DATA istab /2/
7113 C-----------------------------------------------------
7114  ihkk=nhkkh1
7115 C IPHKK=2
7116  IF (iphkk.GE.2) WRITE(6,1000) ihkk,nhkk
7117  1000 FORMAT(' DECHKK IHKK,NHKK= ',2i5)
7118 C
7119 C*** LOOP OVER ALL PARTICLES FROM THE STACK
7120  10 CONTINUE
7121  ihkk=ihkk+1
7122  IF (ihkk.GT.nhkk)THEN
7123 C IPHKK=0
7124  RETURN
7125  ENDIF
7126 C
7127  IF(abs(isthkk(ihkk)).NE.1) goto 10
7128  iqqqq=isthkk(ihkk)
7129 C
7130  it=mcihad(idhkk(ihkk))
7131 C
7132  IF (it.LT.1.OR.it.GT.210) THEN
7133  WRITE (6,1003)it
7134  1003 FORMAT (' DECHKK IT ',i10)
7135  ENDIF
7136 C
7137 C*****TEST STABLE OR UNSTABLE
7138 C ISTAB=2
7139 C ISTAB=1/2/3 MEANS STRONG + WEAK DECAYS / ONLY STRONG DECAYS /
7140 C STRONG DECAYS + WEAK DECAYS FOR CHARMED PARTICLES AND TAU LEPTONS
7141 C
7142 C GOTO 51 : THERE WAS NO DECAY RETURN TO STACK
7143 C
7144  IF(istab.EQ.1) THEN
7145  IF(it.EQ.135.OR.it.EQ.136) goto 10
7146  IF(it.GE.1.AND.it.LE.7) goto 10
7147  ELSEIF(istab.EQ.2) THEN
7148  IF(it.GE. 1.AND.it.LE. 30) goto 10
7149  IF(it.GE. 97.AND.it.LE.103) goto 10
7150  IF(it.GE.115.AND.it.LE.122) goto 10
7151  IF(it.GE.131.AND.it.LE.136) goto 10
7152  IF(it.EQ.109) goto 10
7153  IF(it.GE.137.AND.it.LE.160) goto 10
7154  ELSEIF(istab.EQ.3) THEN
7155  IF(it.GE.1.AND.it.LE.23) goto 10
7156  IF(it.GE. 97.AND.it.LE.103) goto 10
7157  IF(it.EQ.109.AND.it.EQ.115) goto 10
7158  IF(it.GE.133.AND.it.LE.136) goto 10
7159  ENDIF
7160 C*** DECAY TO BE HANDLED
7161 C
7162  pls=sqrt(abs(phkk(1,ihkk)**2+phkk(2,ihkk)**2+phkk(3,ihkk)**2))
7163 C
7164 C Consistency check of decaying hadron
7165 C
7166  amtest=sqrt(abs(phkk(4,ihkk)**2-pls**2))
7167  IF(abs(amtest-phkk(5,ihkk)).GE.1.d-3)THEN
7168 C WRITE(6,'(A,2E15.5,I10)')' DECHKK inconsistent resonance',
7169 C * AMTEST,PHKK(5,IHKK),IHKK
7170  plss=(phkk(4,ihkk)**2-phkk(5,ihkk))
7171  IF(plss.LE.0.d0)THEN
7172  WRITE(6,'(A)')' negative momentum square!'
7173  plss=0.d0
7174  ENDIF
7175  plsn=sqrt(plss)
7176  amodp=plsn/pls
7177  phkk(1,ihkk)=phkk(1,ihkk)*amodp
7178  phkk(2,ihkk)=phkk(2,ihkk)*amodp
7179  phkk(3,ihkk)=phkk(3,ihkk)*amodp
7180  pls=pls*amodp
7181  ENDIF
7182 C
7183  IF(pls.NE.0.d0) THEN
7184  cxs=phkk(1,ihkk)/pls
7185  cys=phkk(2,ihkk)/pls
7186  czs=phkk(3,ihkk)/pls
7187  ENDIF
7188  els=phkk(4,ihkk)
7189  eco=aam(it)
7190  gam=els/eco
7191  bgam=pls/eco
7192 C
7193  kz1=k1(it)
7194  vv=rndm(v) - 1.e-17
7195  iik=kz1-1
7196  20 iik=iik+1
7197  IF (vv.GT.wt(iik)) go to 20
7198 C
7199 C IIK IS THE DECAY CHANNEL
7200  itf(1)=nzk(iik,1)
7201  itf(2)=nzk(iik,2)
7202 C****************************** ?????????????????????
7203 C?? IF (ITF(2)-1.LT.0) GO TO 110
7204 C?? IF (IT2-1.LT.0) GO TO 305
7205  IF (itf(2).LT.1) go to 10
7206 C****************************** ????????????????????
7207  itf(3)=nzk(iik,3)
7208 C
7209  IF(iphkk.GE.1) WRITE(6,1010)it,iik,itf(1),itf(2),itf(3)
7210  1010 FORMAT(' DECHKK IT,IIK,IT1,IT2,IT3 ',5i5)
7211 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
7212 C
7213  IF(itf(3).EQ.0) THEN
7214  ndecpr=2
7215  CALL dtwopd(eco,ecmf(1),ecmf(2),pcmf(1),pcmf(2), codf(1),coff
7216  + (1),siff(1),codf(2),coff(2),siff(2), aam(itf(1)),aam(itf(2)))
7217  sid1=sqrt(abs((1.-codf(1))*(1.+codf(1))))
7218  sid2=sqrt(abs((1.-codf(2))*(1.+codf(2))))
7219  pix1=pcmf(1)*sid1*coff(1)
7220  piy1=pcmf(1)*sid1*siff(1)
7221  piz1=pcmf(1)*codf(1)
7222  pix2=pcmf(2)*sid2*coff(2)
7223  piy2=pcmf(2)*sid2*siff(2)
7224  piz2=pcmf(2)*codf(2)
7225  pix12=pix1+pix2
7226  piy12=piy1+piy2
7227  piz12=piz1+piz2
7228  ecm12=ecmf(1)+ecmf(2)-eco
7229  IF((abs(pix12).GT.0.000001d0).OR.
7230  + (abs(piy12).GT.0.000001d0).OR.
7231  + (abs(piz12).GT.0.000001d0).OR.
7232  + (abs(ecm12).GT.0.000001d0))THEN
7233  WRITE(6,778)pix12,piy12,piz12,ecm12
7234  778 FORMAT(' DWOPD px,py,pz,e',4f10.6)
7235  ENDIF
7236 
7237  ELSE
7238  ndecpr=3
7239  CALL dthrep(eco,ecmf(1),ecmf(2),ecmf(3),pcmf(1),pcmf(2),pcmf(3),
7240  + codf(1),coff(1),siff(1),codf(2),coff(2),siff(2), codf(3),coff
7241  + (3),siff(3), aam(itf(1)),aam(itf(2)),aam(itf(3)))
7242  sid1=sqrt((1.-codf(1))*(1.+codf(1)))
7243  sid2=sqrt((1.-codf(2))*(1.+codf(2)))
7244  sid3=sqrt((1.-codf(3))*(1.+codf(3)))
7245  pix1=pcmf(1)*sid1*coff(1)
7246  piy1=pcmf(1)*sid1*siff(1)
7247  piz1=pcmf(1)*codf(1)
7248  pix2=pcmf(2)*sid2*coff(2)
7249  piy2=pcmf(2)*sid2*siff(2)
7250  piz2=pcmf(2)*codf(2)
7251  pix3=pcmf(3)*sid3*coff(3)
7252  piy3=pcmf(3)*sid3*siff(3)
7253  piz3=pcmf(3)*codf(3)
7254  pix12=pix1+pix2+pix3
7255  piy12=piy1+piy2+piy3
7256  piz12=piz1+piz2+piz3
7257  ecm12=ecmf(1)+ecmf(2)+ecmf(3)-eco
7258  IF((abs(pix12).GT.0.000001d0).OR.
7259  + (abs(piy12).GT.0.000001d0).OR.
7260  + (abs(piz12).GT.0.000001d0).OR.
7261  + (abs(ecm12).GT.0.000001d0))THEN
7262  WRITE(6,779)pix12,piy12,piz12,ecm12
7263  779 FORMAT(' DTHEPD px,py,pz,e',4f10.6)
7264  ENDIF
7265 
7266  ENDIF
7267 C
7268  jdahkk(1,ihkk)=nhkk + 1
7269  jdahkk(2,ihkk)=nhkk + ndecpr
7270  DO 30 id=1,ndecpr
7271  ehecc=sqrt(abs(pcmf(id)** 2+ aam(itf(id))**2))
7272  IF (abs(ehecc-ecmf(id)).GT.0.0001d0) THEN
7273  WRITE(6,'(2A/3I5,3E15.6)')
7274  & ' DECHKK: CORRECT INCONSISTENT ENERGY ',
7275  * ' IHKK,NHKK,ITF(ID), ECMF(ID),EHECC, AAM(ITF(ID))',
7276  * ihkk,nhkk,itf(id), ecmf(id),ehecc, aam(itf(id))
7277  ENDIF
7278 C CALL DTRAFO(GAM,BGAM,CXS,CYS,CZS, CODF(ID),COFF(ID),
7279 C *SIFF(ID),PCMF
7280  CALL dtrafo(gam,bgam,cxs,cys,czs, codf(id),coff(id),
7281  * siff(id),pcmf(id),ecmf(id), pcmff(id),cxf(id),
7282  *cyf(id),czf(id),ecmff(id))
7283  IF (iphkk.GE.2) WRITE(6,'(A,7E15.5/8E15.5)')' DTRAFO ',
7284  * gam,bgam,cxs,cys,czs, codf(id),coff(id),
7285  * siff(id),pcmf(id),ecmf(id), pcmff(id),cxf(id),
7286  *cyf(id),czf(id),ecmff(id)
7287 
7288 C*******************
7289 C THERE WAS A DECAY, DROP MOTHER IHKK
7290 C AND PUT PARTICLE INTO HKK STACK
7291  isthkk(ihkk)=2
7292  IF (nhkk.EQ.nmxhkk)THEN
7293  WRITE (6,1020)nhkk,nmxhkk
7294  1020 FORMAT (.GT.' NHKKNMXHKK IN DECHKK RETURN ',2i10)
7295 C IPHKK=0
7296  RETURN
7297  ENDIF
7298 C
7299  nhkk=nhkk+1
7300  IF (nhkk.EQ.nmxhkk) THEN
7301  WRITE (6,'(A,2I5)') .EQ.' DECHKK: NHKKNMXHKK ',nhkk,nmxhkk
7302 C IPHKK=0
7303  RETURN
7304  ENDIF
7305  idbam(nhkk)=itf(id)
7306  isthkk(nhkk)=iqqqq
7307  idhkk(nhkk)=mpdgha(itf(id))
7308  jmohkk(1,nhkk)=ihkk
7309  jmohkk(2,nhkk)=0
7310  jdahkk(1,nhkk)=0
7311  jdahkk(2,nhkk)=0
7312  phkk(1,nhkk)=cxf(id)*pcmff(id)
7313  phkk(2,nhkk)=cyf(id)*pcmff(id)
7314  phkk(3,nhkk)=czf(id)*pcmff(id)
7315  ehecc=sqrt(abs(pcmff(id)** 2+ aam(itf(id))**2))
7316  IF (abs(ehecc-ecmff(id)).GT.0.003d0) THEN
7317  WRITE(6,'(2A/3I5,3E15.6)')
7318  & ' DECHKK: CORRECT INCONSISTENT ENERGY ',
7319  * ' IHKK,NHKK,ITF(ID), ECMF(ID),EHECC, AAM(ITF(ID))',
7320  * ihkk,nhkk,itf(id), ecmff(id),ehecc, aam(itf(id))
7321  ecmff(id)=ehecc
7322  ENDIF
7323  phkk(4,nhkk)=ecmff(id)
7324  phkk(5,nhkk)=aam(itf(id))
7325  vhkk(1,nhkk)=vhkk(1,ihkk)
7326  vhkk(2,nhkk)=vhkk(2,ihkk)
7327  vhkk(3,nhkk)=vhkk(3,ihkk)
7328  vhkk(4,nhkk)=vhkk(4,ihkk)
7329 C
7330  IF (iphkk.GE.7) WRITE(6,1030)nhkk, isthkk(nhkk),idhkk(nhkk),
7331  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
7332  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
7333 
7334  1030 FORMAT (i6,i4,5i6,9e10.2)
7335 C
7336  30 CONTINUE
7337 C
7338  goto 10
7339 C
7340 C RETURN
7341  END
7342 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7343 
7344 *=== trafo ============================================================*
7345 *
7346  SUBROUTINE dtrafo(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
7347  1pl,cxl,cyl,czl,el)
7348  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7349  SAVE
7350 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
7351  sid=sqrt(1.d0-cod*cod)
7352  plx=p*sid*cof
7353  ply=p*sid*sif
7354  pppt=sqrt(plx**2+ply**2)
7355  pcmz=p*cod
7356  plz=gam*pcmz+bgam*ecm
7357  pl=sqrt(plx*plx+ply*ply+plz*plz)
7358  el=gam*ecm+bgam*pcmz
7359 C ROTATION INTO THE ORIGINAL DIRECTION
7360  coz=plz/pl
7361 C SIZ=SQRT((1.D0-COZ)*(1.D0+COZ))
7362  siz=pppt/pl
7363 C WRITE(6,'(A,2E25.16)')' COZ,SIZ ',COZ,SIZ
7364  CALL sttran(cx,cy,cz,coz,siz,sif,cof,cxl,cyl,czl)
7365  RETURN
7366  END
7367 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7368 
7369  SUBROUTINE sttran(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
7370  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7371  SAVE
7372  DATA anglsq/1.d-14/
7373 C********************************************************************
7374 C VERSION BY J. RANFT
7375 C LEIPZIG
7376 C
7377 C THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES
7378 C
7379 C INPUT VARIABLES:
7380 C XO,YO,ZO = ORIGINAL DIRECTION COSINES
7381 C CDE,SDE = COSINE AND SINE OF THE POLAR (THETA)
7382 C ANGLE OF "SCATTERING"
7383 C SDE = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"
7384 C SFE,CFE = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE
7385 C OF "SCATTERING"
7386 C
7387 C OUTPUT VARIABLES:
7388 C X,Y,Z = NEW DIRECTION COSINES
7389 C
7390 C ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )
7391 C********************************************************************
7392 C
7393 *
7394 * Changed by A. Ferrari
7395 *
7396 * IF (ABS(XO)-0.0001D0) 1,1,2
7397 * 1 IF (ABS(YO)-0.0001D0) 3,3,2
7398 * 3 CONTINUE
7399  a = xo**2 + yo**2
7400  IF ( a .LT. anglsq ) THEN
7401  x=sde*cfe
7402  y=sde*sfe
7403 C Z=CDE CORRECTED AUGUST 88 PA
7404  z=cde*zo
7405  ELSE
7406  xi=sde*cfe
7407  yi=sde*sfe
7408  zi=cde
7409  a=sqrt(a)
7410  x=-yo*xi/a-zo*xo*yi/a+xo*zi
7411  y=xo*xi/a-zo*yo*yi/a+yo*zi
7412  z=a*yi+zo*zi
7413  END IF
7414  RETURN
7415  END
7416 *-- Author :
7417 C
7418 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7419 C
7420  SUBROUTINE lortmo(N,GAM,BGX,BGY,BGZ)
7421  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7422  SAVE
7423 C
7424 C*** LORENTZ TRANSFORMATION OF THE N PARTICLES IN FINPAR
7425 C
7426 *KEEP,DFINPA.
7427  CHARACTER*8 anf
7428  parameter(nfimax=249)
7429  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
7430  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
7431  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
7432  * istath(nfimax)
7433 *KEND.
7434 C-------------------
7435  parameter(tiny=1.d-10)
7436  DATA ifirst/0/
7437  DATA num/0/
7438 C
7439  ifirst=ifirst+1
7440  num=num+1
7441  pxsm=0.0
7442  pysm=0.0
7443  pzsm=0.0
7444  esum=0.
7445  pxsc=0.0
7446  pysc=0.0
7447  pzsc=0.0
7448  esmc=0.0
7449 C END OF CHANGE
7450  DO 10 i=1,n
7451  pxi=pxf(i)
7452  pyi=pyf(i)
7453  pzi=pzf(i)
7454  eei=hef(i)
7455  pxsm=pxsm + pxi
7456  pysm=pysm + pyi
7457  pzsm=pzsm + pzi
7458  esum=esum + eei
7459  CALL daltra(gam,bgx,bgy,bgz,pxi,pyi,pzi,eei, ppa,pxf(i),pyf(i),
7460  + pzf(i),hef(i))
7461  pxsc=pxsc + pxf(i)
7462  pysc=pysc + pyf(i)
7463  pzsc=pzsc + pzf(i)
7464  esmc=esmc + hef(i)
7465  10 CONTINUE
7466 C
7467 C PXSM,ETC,ARE SUMS FOR BAMJET FRAGMENTS IN JET CMS
7468  CALL daltra(gam,bgx,bgy,bgz,pxsm,pysm,pzsm,esum, ppa,pxsm,pysm,
7469  +pzsm,esum)
7470 C
7471 C PXSC,ETC,ARE SUMS FOR BAMJET FRAGMENTS IN PROJ,TARGET CMS
7472 
7473  pxdif=pxsm-pxsc
7474  pydif=pysm-pysc
7475  pzdif=pzsm-pzsc
7476  edif=esum-esmc
7477  diffl=pxdif+pydif+pzdif+edif
7478  IF(esum.LT.tiny)esum=tiny
7479  diffl=diffl/esum
7480  IF(diffl.GE.1.d-4)WRITE(6,1000)num,pxdif,pydif,pzdif,edif,pxsm,
7481  +pxsc, pysm,pysc,pzsm,pzsc,esum,esmc
7482  1000 FORMAT(' ',2x,'LORTRA:NUM=',i5,2x,'PXDIF=',1pe15.6,2x,'PYDIF=', 1
7483  +pe15.6,2x,'PZDIF=',1pe15.6,2x,'EDIF=',1pe15.6/2x,'PXSM=',1pe15.6,2
7484  +x,'PXSC=',1pe15.6,2x,'PYSM=',1pe15.6,2x,'PYSC=',1pe15.6/2x,'PZSM',
7485  +1pe15.6,2x,'PZSC=',1pe15.6,2x,'ESUM=',1pe15.6,2x,'ESMC=',1pe15.6/2
7486  +x,'LORTRA DIFFERENCES DUE TO ALTRA'/)
7487  RETURN
7488  END
7489 *-- Author :
7490 C-------------------------------------------------------------------
7491 C
7492 C FILE DMNUC3.FOR
7493 C
7494 C-------------------------------------------------------------------
7495 C
7496  SUBROUTINE evtest(IREJ)
7497  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7498  SAVE
7499 C
7500 C TEST OF ENERGY MOMENTUM CONSERVATION ON NIVEAU OF CHAINS
7501 C AND ON NIVEAU OF CHAIN ENDS
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  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
7511  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
7512 C
7513 *KEEP,NUCIMP.
7514  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
7515  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
7516  +prebin,taebin,fermod,etacou
7517 *KEEP,DPAR.
7518 C /DPAR/ CONTAINS PARTICLE PROPERTIES
7519 C ANAME = LITERAL NAME OF THE PARTICLE
7520 C AAM = PARTICLE MASS IN GEV
7521 C GA = DECAY WIDTH
7522 C TAU = LIFE TIME OF INSTABLE PARTICLES
7523 C IICH = ELECTRIC CHARGE OF THE PARTICLE
7524 C IIBAR = BARYON NUMBER
7525 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
7526 C
7527  CHARACTER*8 aname
7528  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
7529  +iibar(210),k1(210),k2(210)
7530 *KEEP,INTMX.
7531  parameter(intmx=2488,intmd=252)
7532 *KEEP,DXQX.
7533 C INCLUDE (XQXQ)
7534 * NOTE: INTMX set via INCLUDE(INTMX)
7535  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
7536  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
7537  * ,xpsu(248),xtsu(248)
7538  * ,xpsut(248),xtsut(248)
7539  COMMON /intnez/ ndz,nzd
7540 *KEEP,INTNEW.
7541  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
7542  +ixpv,ixps,ixtv,ixts, intvv1(248),
7543  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
7544  +intss1(intmx),intss2(intmx),
7545  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
7546  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
7547 
7548 C /INTNEW/
7549 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
7550 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
7551 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
7552 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
7553 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
7554 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
7555 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
7556 C FROM PROJECTILE/TARGET NUCLEI
7557 C-------------------
7558 *KEEP,IFROTO.
7559  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
7560  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
7561  +jhkknt
7562  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
7563  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
7564  & mhkkhh(intmx),
7565  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
7566 *KEEP,LOZUO.
7567  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
7568  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
7569  +intlo(intmx),inloss(intmx)
7570 C /LOZUO/
7571 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
7572 C REJECTED IN KKEVT
7573 C------------------
7574 *KEEP,DIQI.
7575  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
7576  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
7577  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
7578  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
7579 *KEEP,ABRSS.
7580 C INCLUDE (ABRSS)
7581  COMMON /abrss/ amcss1(intmx),amcss2(intmx), gacss1(intmx),gacss2
7582  +(intmx), bgxss1(intmx),bgyss1(intmx),bgzss1(intmx), bgxss2(intmx),
7583  +bgyss2(intmx),bgzss2(intmx), nchss1(intmx),nchss2(intmx), ijcss1
7584  +(intmx),ijcss2(intmx), pqssa1(intmx,4),pqssa2(intmx,4), pqssb1
7585  +(intmx,4),pqssb2(intmx,4)
7586 *KEEP,NNCMS.
7587  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
7588 *KEEP,ABRSV.
7589  COMMON /abrsv/ amcsv1(248),amcsv2(248),gacsv1(248),gacsv2(248),
7590  +bgxsv1(248),bgysv1(248),bgzsv1(248), bgxsv2(248),bgysv2(248),
7591  +bgzsv2(248), nchsv1(248),nchsv2(248),ijcsv1(248),ijcsv2(248),
7592  +pqsva1(248,4),pqsva2(248,4), pqsvb1(248,4),pqsvb2(248,4)
7593 *KEEP,ABRVS.
7594  COMMON /abrvs/ amcvs1(248),amcvs2(248),gacvs1(248),gacvs2(248),
7595  +bgxvs1(248),bgyvs1(248),bgzvs1(248), bgxvs2(248),bgyvs2(248),
7596  +bgzvs2(248), nchvs1(248),nchvs2(248),ijcvs1(248),ijcvs2(248),
7597  +pqvsa1(248,4),pqvsa2(248,4), pqvsb1(248,4),pqvsb2(248,4)
7598 *KEEP,ABRVV.
7599  COMMON /abrvv/ amcvv1(248),amcvv2(248),gacvv1(248),gacvv2(248),
7600  +bgxvv1(248),bgyvv1(248),bgzvv1(248), bgxvv2(248),bgyvv2(248),
7601  +bgzvv2(248), nchvv1(248),nchvv2(248),ijcvv1(248),ijcvv2(248),
7602  +pqvva1(248,4),pqvva2(248,4), pqvvb1(248,4),pqvvb2(248,4)
7603 *KEEP,ABRDV.
7604  COMMON /abrdv/ amcdv1(248),amcdv2(248),gacdv1(248),gacdv2(248),
7605  +bgxdv1(248),bgydv1(248),bgzdv1(248), bgxdv2(248),bgydv2(248),
7606  +bgzdv2(248), nchdv1(248),nchdv2(248),ijcdv1(248),ijcdv2(248),
7607  +pqdva1(248,4),pqdva2(248,4), pqdvb1(248,4),pqdvb2(248,4)
7608 C-------------------
7609 *KEEP,ABRVD.
7610  COMMON /abrvd/ amcvd1(248),amcvd2(248),gacvd1(248),gacvd2(248),
7611  +bgxvd1(248),bgyvd1(248),bgzvd1(248), bgxvd2(248),bgyvd2(248),
7612  +bgzvd2(248), nchvd1(248),nchvd2(248),ijcvd1(248),ijcvd2(248),
7613  +pqvda1(248,4),pqvda2(248,4), pqvdb1(248,4),pqvdb2(248,4)
7614 *KEEP,ABRDS.
7615  COMMON /abrds/ amcds1(248),amcds2(248),gacds1(248),gacds2(248),
7616  +bgxds1(248),bgyds1(248),bgzds1(248), bgxds2(248),bgyds2(248),
7617  +bgzds2(248), nchds1(248),nchds2(248),ijcds1(248),ijcds2(248),
7618  +pqdsa1(248,4),pqdsa2(248,4), pqdsb1(248,4),pqdsb2(248,4)
7619 C-------------------
7620 *KEEP,ABRDS.
7621  COMMON /abrdz/ amcdz1(intmd),amcdz2(intmd),
7622  +gacdz1(intmd),gacdz2(intmd),
7623  +bgxdz1(intmd),bgydz1(intmd),bgzdz1(intmd),
7624  +bgxdz2(intmd),bgydz2(intmd),
7625  +bgzdz2(intmd), nchdz1(intmd),nchdz2(intmd),
7626  +ijcdz1(intmd),ijcdz2(intmd),
7627  +pqdza1(intmd,4),pqdza2(intmd,4),
7628  +pqdzb1(intmd,4),pqdzb2(intmd,4),
7629  +ipzq(intmd),ipzqq2(intmd),itzq(intmd),
7630  +ipzaq(intmd),izaqq2(intmd),itzaq(intmd)
7631  +,idzzz(intmd)
7632 C-------------------
7633 *KEEP,ABRSD.
7634  COMMON /abrsd/ amcsd1(248),amcsd2(248),gacsd1(248),gacsd2(248),
7635  +bgxsd1(248),bgysd1(248),bgzsd1(248), bgxsd2(248),bgysd2(248),
7636  +bgzsd2(248), nchsd1(248),nchsd2(248),ijcsd1(248),ijcsd2(248),
7637  +pqsda1(248,4),pqsda2(248,4), pqsdb1(248,4),pqsdb2(248,4)
7638 C-------------------
7639 *KEEP,ABRSD.
7640  COMMON /abrzd/ amczd1(intmd),amczd2(intmd),
7641  +gaczd1(intmd),gaczd2(intmd),
7642  +bgxzd1(intmd),bgyzd1(intmd),bgzzd1(intmd),
7643  +bgxzd2(intmd),bgyzd2(intmd),
7644  +bgzzd2(intmd), nchzd1(intmd),nchzd2(intmd),
7645  +ijczd1(intmd),ijczd2(intmd),
7646  +pqzda1(intmd,4),pqzda2(intmd,4),
7647  +pqzdb1(intmd,4),pqzdb2(intmd,4),
7648  +ipyq(intmd),ityq(intmd),ityq2(intmd),
7649  +ipyaq(intmd),ityaq(intmd),ityaq2(intmd)
7650  +,izdyy(intmd)
7651 C-------------------
7652 *KEEP,DROPPT.
7653  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
7654  +ishmal,lpauli
7655  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
7656  +ipadis,ishmal,lpauli
7657 *KEEP,DPRIN.
7658  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7659 *KEND.
7660  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
7661  COMMON /abrzz/ amczz1(intmx),amczz2(intmx),
7662  * gaczz1(intmx),gaczz2(intmx),
7663  * bgxzz1(intmx),bgyzz1(intmx),bgzzz1(intmx),
7664  * bgxzz2(intmx),bgyzz2(intmx),bgzzz2(intmx),
7665  * nchzz1(intmx),nchzz2(intmx),
7666  * ijczz1(intmx),ijczz2(intmx),
7667  * pqzza1(intmx,4),pqzza2(intmx,4),
7668  * pqzzb1(intmx,4),pqzzb2(intmx,4)
7669  COMMON /abrhh/ amchh1(intmx),amchh2(intmx),
7670  * gachh1(intmx),gachh2(intmx),
7671  * bgxhh1(intmx),bgyhh1(intmx),bgzhh1(intmx),
7672  * bgxhh2(intmx),bgyhh2(intmx),bgzhh2(intmx),
7673  * nchhh1(intmx),nchhh2(intmx),
7674  * ijchh1(intmx),ijchh2(intmx),
7675  * pqhha1(intmx,4),pqhha2(intmx,4),
7676  * pqhhb1(intmx,4),pqhhb2(intmx,4)
7677  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
7678  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
7679  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
7680  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
7681  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
7682  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
7683  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
7684  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
7685  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
7686  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
7687  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
7688  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
7689  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
7690  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
7691  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
7692  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
7693  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
7694  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
7695 C------------------------
7696 C WRITE(6,1298)NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,NOCC,NONUST,
7697 C * NONUJT
7698 C1298 FORMAT(' NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,NOCC,NONUST,NONUJT'
7699 C */11I8)
7700  irej=0
7701  pxbal=0.
7702  pybal=0.
7703  pzbal=0.
7704  pebal=0.
7705  pxss=0.
7706  pyss=0.
7707  pzss=0.
7708  pess=0.
7709  pxsv=0.
7710  pysv=0.
7711  pzsv=0.
7712  pesv=0.
7713  pxvs=0.
7714  pyvs=0.
7715  pzvs=0.
7716  pevs=0.
7717  pxvv=0.
7718  pyvv=0.
7719  pzvv=0.
7720  pevv=0.
7721  pxds=0.
7722  pyds=0.
7723  pzds=0.
7724  peds=0.
7725  pxsd=0.
7726  pysd=0.
7727  pzsd=0.
7728  pesd=0.
7729  pxdz=0.
7730  pydz=0.
7731  pzdz=0.
7732  pedz=0.
7733  pxzd=0.
7734  pyzd=0.
7735  pzzd=0.
7736  pezd=0.
7737  pxdv=0.
7738  pydv=0.
7739  pzdv=0.
7740  pedv=0.
7741  pxvd=0.
7742  pyvd=0.
7743  pzvd=0.
7744  pevd=0.
7745  pxcc=0.
7746  pycc=0.
7747  pzcc=0.
7748  pecc=0.
7749  pxzz=0.
7750  pyzz=0.
7751  pzzz=0.
7752  pezz=0.
7753  pxhh=0.
7754  pyhh=0.
7755  pzhh=0.
7756  pehh=0.
7757 C IF(IP.EQ.1)GAMCM=GAMCM+(NSV+NDV)*AAM(IJPROJ)/UMO
7758 C
7759 C IF(IHADA.OR.IHADSS) THEN
7760  DO 10 n=1,nss
7761  IF (inloss(n))THEN
7762  IF(abs(nchss1(n)).NE.99) THEN
7763  pxss=pxss + pqssa1(n,1) + pqssa2(n,1)
7764  pyss=pyss + pqssa1(n,2) + pqssa2(n,2)
7765  pzss=pzss + pqssa1(n,3) + pqssa2(n,3)
7766  pess=pess + pqssa1(n,4) + pqssa2(n,4)
7767  ENDIF
7768  IF(abs(nchss2(n)).NE.99) THEN
7769  pxss=pxss + pqssb1(n,1) + pqssb2(n,1)
7770  pyss=pyss + pqssb1(n,2) + pqssb2(n,2)
7771  pzss=pzss + pqssb1(n,3) + pqssb2(n,3)
7772  pess=pess + pqssb1(n,4) + pqssb2(n,4)
7773  ENDIF
7774  ENDIF
7775  10 CONTINUE
7776  pzbss=gamcm*pzss + bgcm*pess
7777  pebss=gamcm*pess + bgcm*pzss
7778  pxbal=pxss
7779  pybal=pyss
7780  pzbal=pzbss
7781  pebal=pebss
7782 C ENDIF
7783 C IF(IHADA.OR.IHADSV) THEN
7784  DO 20 n=1,nsv
7785  IF(abs(nchsv1(n)).NE.99) THEN
7786  pxsv=pxsv +pqsva1(n,1)+pqsva2(n,1)
7787  pysv=pysv +pqsva1(n,2)+pqsva2(n,2)
7788  pzsv=pzsv +pqsva1(n,3)+pqsva2(n,3)
7789  pesv=pesv +pqsva1(n,4)+pqsva2(n,4)
7790  IF (ipev.GE.1)THEN
7791  WRITE(6,2001)
7792  + pxsv,pysv,pzsv,pesv
7793  ENDIF
7794  2001 FORMAT (
7795  +' SV ',4e15.5)
7796 C
7797  ENDIF
7798  IF(abs(nchsv2(n)).NE.99) THEN
7799  pxsv=pxsv + pqsvb1(n,1)+pqsvb2(n,1)
7800  pysv=pysv + pqsvb1(n,2)+pqsvb2(n,2)
7801  pzsv=pzsv + pqsvb1(n,3)+pqsvb2(n,3)
7802  pesv=pesv + pqsvb1(n,4)+pqsvb2(n,4)
7803  IF (ipev.GE.1)THEN
7804  WRITE(6,2001)
7805  + pxsv,pysv,pzsv,pesv
7806  ENDIF
7807  ENDIF
7808  20 CONTINUE
7809  pzbsv=gamcm*pzsv + bgcm*pesv
7810  pebsv=gamcm*pesv + bgcm*pzsv
7811  IF (ipev.GE.1)THEN
7812  WRITE(6,2001)
7813  + pxsv,pysv,pzbsv,pebsv
7814  ENDIF
7815  pxbal=pxbal + pxsv
7816  pybal=pybal + pysv
7817  pzbal=pzbal + pzbsv
7818  pebal=pebal + pebsv
7819 C ENDIF
7820 C IF(IHADA.OR.IHADVS) THEN
7821  DO 30 n=1,nvs
7822  IF(abs(nchvs1(n)).NE.99) THEN
7823  pxvs=pxvs + pqvsa1(n,1) + pqvsa2(n,1)
7824  pyvs=pyvs + pqvsa1(n,2) + pqvsa2(n,2)
7825  pzvs=pzvs + pqvsa1(n,3) + pqvsa2(n,3)
7826  pevs=pevs + pqvsa1(n,4) + pqvsa2(n,4)
7827  ENDIF
7828  IF(abs(nchvs2(n)).NE.99) THEN
7829  pxvs=pxvs + pqvsb1(n,1) + pqvsb2(n,1)
7830  pyvs=pyvs + pqvsb1(n,2) + pqvsb2(n,2)
7831  pzvs=pzvs + pqvsb1(n,3) + pqvsb2(n,3)
7832  pevs=pevs + pqvsb1(n,4) + pqvsb2(n,4)
7833  ENDIF
7834  30 CONTINUE
7835  pzbvs=gamcm*pzvs + bgcm*pevs
7836  pebvs=gamcm*pevs + bgcm*pzvs
7837  pxbal=pxbal + pxvs
7838  pybal=pybal + pyvs
7839  pzbal=pzbal + pzbvs
7840  pebal=pebal + pebvs
7841  DO 31 n=1,nds
7842  IF(abs(nchds1(n)).NE.99) THEN
7843  pxds=pxds + pqdsa1(n,1) + pqdsa2(n,1)
7844  pyds=pyds + pqdsa1(n,2) + pqdsa2(n,2)
7845  pzds=pzds + pqdsa1(n,3) + pqdsa2(n,3)
7846  peds=peds + pqdsa1(n,4) + pqdsa2(n,4)
7847  ENDIF
7848  IF(abs(nchds2(n)).NE.99) THEN
7849  pxds=pxds + pqdsb1(n,1) + pqdsb2(n,1)
7850  pyds=pyds + pqdsb1(n,2) + pqdsb2(n,2)
7851  pzds=pzds + pqdsb1(n,3) + pqdsb2(n,3)
7852  peds=peds + pqdsb1(n,4) + pqdsb2(n,4)
7853  ENDIF
7854  31 CONTINUE
7855  pzbds=gamcm*pzds + bgcm*peds
7856  pebds=gamcm*peds + bgcm*pzds
7857  pxbal=pxbal + pxds
7858  pybal=pybal + pyds
7859  pzbal=pzbal + pzbds
7860  pebal=pebal + pebds
7861  DO 371 n=1,ndz
7862  IF(abs(nchdz1(n)).NE.99) THEN
7863  pxdz=pxdz + pqdza1(n,1) + pqdza2(n,1)
7864  pydz=pydz + pqdza1(n,2) + pqdza2(n,2)
7865  pzdz=pzdz + pqdza1(n,3) + pqdza2(n,3)
7866  pedz=pedz + pqdza1(n,4) + pqdza2(n,4)
7867  ENDIF
7868  IF(abs(nchdz2(n)).NE.99) THEN
7869  pxdz=pxdz + pqdzb1(n,1) + pqdzb2(n,1)
7870  pydz=pydz + pqdzb1(n,2) + pqdzb2(n,2)
7871  pzdz=pzdz + pqdzb1(n,3) + pqdzb2(n,3)
7872  pedz=pedz + pqdzb1(n,4) + pqdzb2(n,4)
7873  ENDIF
7874  371 CONTINUE
7875  pzbdz=gamcm*pzdz + bgcm*pedz
7876  pebdz=gamcm*pedz + bgcm*pzdz
7877  pxbal=pxbal + pxdz
7878  pybal=pybal + pydz
7879  pzbal=pzbal + pzbdz
7880  pebal=pebal + pebdz
7881  DO 32 n=1,nsd
7882  IF(abs(nchsd1(n)).NE.99) THEN
7883  pxsd=pxsd + pqsda1(n,1) + pqsda2(n,1)
7884  pysd=pysd + pqsda1(n,2) + pqsda2(n,2)
7885  pzsd=pzsd + pqsda1(n,3) + pqsda2(n,3)
7886  pesd=pesd + pqsda1(n,4) + pqsda2(n,4)
7887  ENDIF
7888  IF(abs(nchsd2(n)).NE.99) THEN
7889  pxsd=pxsd + pqsdb1(n,1) + pqsdb2(n,1)
7890  pysd=pysd + pqsdb1(n,2) + pqsdb2(n,2)
7891  pzsd=pzsd + pqsdb1(n,3) + pqsdb2(n,3)
7892  pesd=pesd + pqsdb1(n,4) + pqsdb2(n,4)
7893  ENDIF
7894  32 CONTINUE
7895  pzbsd=gamcm*pzsd + bgcm*pesd
7896  pebsd=gamcm*pesd + bgcm*pzsd
7897  pxbal=pxbal + pxsd
7898  pybal=pybal + pysd
7899  pzbal=pzbal + pzbsd
7900  pebal=pebal + pebsd
7901  DO 372 n=1,nzd
7902  IF(abs(nchzd1(n)).NE.99) THEN
7903  pxzd=pxzd + pqzda1(n,1) + pqzda2(n,1)
7904  pyzd=pyzd + pqzda1(n,2) + pqzda2(n,2)
7905  pzzd=pzzd + pqzda1(n,3) + pqzda2(n,3)
7906  pezd=pezd + pqzda1(n,4) + pqzda2(n,4)
7907  ENDIF
7908  IF(abs(nchzd2(n)).NE.99) THEN
7909  pxzd=pxzd + pqzdb1(n,1) + pqzdb2(n,1)
7910  pyzd=pyzd + pqzdb1(n,2) + pqzdb2(n,2)
7911  pzzd=pzzd + pqzdb1(n,3) + pqzdb2(n,3)
7912  pezd=pezd + pqzdb1(n,4) + pqzdb2(n,4)
7913  ENDIF
7914  372 CONTINUE
7915  pzbzd=gamcm*pzzd + bgcm*pezd
7916  pebzd=gamcm*pezd + bgcm*pzzd
7917  pxbal=pxbal + pxzd
7918  pybal=pybal + pyzd
7919  pzbal=pzbal + pzbzd
7920  pebal=pebal + pebzd
7921  DO 33 n=1,ndv
7922  IF(abs(nchdv1(n)).NE.99) THEN
7923  pxdv=pxdv + pqdva1(n,1) + pqdva2(n,1)
7924  pydv=pydv + pqdva1(n,2) + pqdva2(n,2)
7925  pzdv=pzdv + pqdva1(n,3) + pqdva2(n,3)
7926  pedv=pedv + pqdva1(n,4) + pqdva2(n,4)
7927  ENDIF
7928  IF(abs(nchdv2(n)).NE.99) THEN
7929  pxdv=pxdv + pqdvb1(n,1) + pqdvb2(n,1)
7930  pydv=pydv + pqdvb1(n,2) + pqdvb2(n,2)
7931  pzdv=pzdv + pqdvb1(n,3) + pqdvb2(n,3)
7932  pedv=pedv + pqdvb1(n,4) + pqdvb2(n,4)
7933  ENDIF
7934  33 CONTINUE
7935  pzbdv=gamcm*pzdv + bgcm*pedv
7936  pebdv=gamcm*pedv + bgcm*pzdv
7937  pxbal=pxbal + pxdv
7938  pybal=pybal + pydv
7939  pzbal=pzbal + pzbdv
7940  pebal=pebal + pebdv
7941  DO 34 n=1,nvd
7942  IF(abs(nchvd1(n)).NE.99) THEN
7943  pxvd=pxvd + pqvda1(n,1) + pqvda2(n,1)
7944  pyvd=pyvd + pqvda1(n,2) + pqvda2(n,2)
7945  pzvd=pzvd + pqvda1(n,3) + pqvda2(n,3)
7946  pevd=pevd + pqvda1(n,4) + pqvda2(n,4)
7947  ENDIF
7948  IF(abs(nchvd2(n)).NE.99) THEN
7949  pxvd=pxvd + pqvdb1(n,1) + pqvdb2(n,1)
7950  pyvd=pyvd + pqvdb1(n,2) + pqvdb2(n,2)
7951  pzvd=pzvd + pqvdb1(n,3) + pqvdb2(n,3)
7952  pevd=pevd + pqvdb1(n,4) + pqvdb2(n,4)
7953  ENDIF
7954  34 CONTINUE
7955  pzbvd=gamcm*pzvd + bgcm*pevd
7956  pebvd=gamcm*pevd + bgcm*pzvd
7957  pxbal=pxbal + pxvd
7958  pybal=pybal + pyvd
7959  pzbal=pzbal + pzbvd
7960  pebal=pebal + pebvd
7961 C ENDIF
7962 C IF(IHADA.OR.IHADVV) THEN
7963  DO 40 n=1,nvv
7964  IF((nchvv1(n).NE.99).AND.(nchvv2(n).NE.99)) THEN
7965  pxvv=pxvv+pqvva1(n,1)+pqvva2(n,1)+pqvvb1(n,1)+pqvvb2(n,1)
7966  pyvv=pyvv+pqvva1(n,2)+pqvva2(n,2)+pqvvb1(n,2)+pqvvb2(n,2)
7967  pzvv=pzvv+pqvva1(n,3)+pqvva2(n,3)+pqvvb1(n,3)+pqvvb2(n,3)
7968  pevv=pevv+pqvva1(n,4)+pqvva2(n,4)+pqvvb1(n,4)+pqvvb2(n,4)
7969  ENDIF
7970  40 CONTINUE
7971  pzbvv=gamcm*pzvv + bgcm*pevv
7972  pebvv=gamcm*pevv + bgcm*pzvv
7973  pxbal=pxbal + pxvv
7974  pybal=pybal + pyvv
7975  pzbal=pzbal + pzbvv
7976  pebal=pebal + pebvv
7977 C ENDIF
7978 C IF(IHADA.OR.IHADSS) THEN
7979 C WRITE(6,*)' evtest nocc ',NOCC
7980 C DO 120 N=1,NOCC
7981 C PXCC=PXCC + POJCC(1,N) + PATCC(1,N)
7982 C PYCC=PYCC + POJCC(2,N) + PATCC(2,N)
7983 C PZCC=PZCC + POJCC(3,N) + PATCC(3,N)
7984 C PECC=PECC + POJCC(4,N) + PATCC(4,N)
7985 C120 CONTINUE
7986 C PZBCC=GAMCM*PZCC + BGCM*PECC
7987 C PEBCC=GAMCM*PECC + BGCM*PZCC
7988 C PXBAL=PXBAL + PXCC
7989 C PYBAL=PYBAL + PYCC
7990 C PZBAL=PZBAL + PZBCC
7991 C PEBAL=PEBAL + PEBCC
7992 C ENDIF
7993 C WRITE(6,*)' evtest nonust ',NONUST
7994  DO 210 n=1,nonust
7995  IF(abs(nchzz1(n)).NE.99.AND.jhkksx(n).EQ.1) THEN
7996  IF(abs(nchzz1(n)).NE.88) THEN
7997  pxzz=pxzz + pqzza1(n,1) + pqzza2(n,1)
7998  pyzz=pyzz + pqzza1(n,2) + pqzza2(n,2)
7999  pzzz=pzzz + pqzza1(n,3) + pqzza2(n,3)
8000  pezz=pezz + pqzza1(n,4) + pqzza2(n,4)
8001  ENDIF
8002  ENDIF
8003  IF(abs(nchzz2(n)).NE.99.AND.jhkksx(n).EQ.1) THEN
8004  IF(abs(nchzz2(n)).NE.88) THEN
8005  pxzz=pxzz + pqzzb1(n,1) + pqzzb2(n,1)
8006  pyzz=pyzz + pqzzb1(n,2) + pqzzb2(n,2)
8007  pzzz=pzzz + pqzzb1(n,3) + pqzzb2(n,3)
8008  pezz=pezz + pqzzb1(n,4) + pqzzb2(n,4)
8009  ENDIF
8010  ENDIF
8011  210 CONTINUE
8012  pzbzz=gamcm*pzzz + bgcm*pezz
8013  pebzz=gamcm*pezz + bgcm*pzzz
8014  pxbal=pxbal + pxzz
8015  pybal=pybal + pyzz
8016  pzbal=pzbal + pzbzz
8017  pebal=pebal + pebzz
8018 C WRITE(6,*)' evtest nonujt ',NONUJT
8019  DO 220 n=1,nonujt
8020  IF(abs(nchhh1(n)).NE.99.AND.jhkkex(n).EQ.1) THEN
8021  pxhh=pxhh + pqhha1(n,1) + pqhha2(n,1)
8022  pyhh=pyhh + pqhha1(n,2) + pqhha2(n,2)
8023  pzhh=pzhh + pqhha1(n,3) + pqhha2(n,3)
8024  pehh=pehh + pqhha1(n,4) + pqhha2(n,4)
8025  ENDIF
8026  IF(abs(nchhh2(n)).NE.99.AND.jhkkex(n).EQ.1) THEN
8027  pxhh=pxhh + pqhhb1(n,1) + pqhhb2(n,1)
8028  pyhh=pyhh + pqhhb1(n,2) + pqhhb2(n,2)
8029  pzhh=pzhh + pqhhb1(n,3) + pqhhb2(n,3)
8030  pehh=pehh + pqhhb1(n,4) + pqhhb2(n,4)
8031  ENDIF
8032  220 CONTINUE
8033  pzbhh=gamcm*pzhh + bgcm*pehh
8034  pebhh=gamcm*pehh + bgcm*pzhh
8035  pxbal=pxbal + pxhh
8036  pybal=pybal + pyhh
8037  pzbal=pzbal + pzbhh
8038  pebal=pebal + pebhh
8039 C
8040  e0000=0.d0
8041  p0000=0.d0
8042 C WRITE(6,*)' evtest ip ',IP
8043  DO 7767 i=1,ip
8044  IF(isthkk(i).EQ.11)e0000=e0000+prmom(4,i)
8045  IF(isthkk(i).EQ.11)p0000=p0000+prmom(3,i)
8046  7767 CONTINUE
8047 C WRITE(6,*)' evtest it ',IT
8048  DO 7768 ii=1,it
8049  i=ii+ip
8050  IF(isthkk(i).EQ.12)e0000=e0000+tamom(4,ii)
8051  IF(isthkk(i).EQ.12)p0000=p0000+tamom(3,ii)
8052  7768 CONTINUE
8053  p000=gamcm*p0000+bgcm*e0000
8054  e000=gamcm*e0000+bgcm*p0000
8055  iprojo=(pzbal*1.001)/pproj
8056  residu=abs(e000-pebal)/(e000)
8057  IF (ipev.GE.1)THEN
8058  WRITE(6,'(A,2E15.5)')' E000,PEBAL', e000,pebal
8059  WRITE(6,1000)pxbal,pybal,pzbal,pebal, pxss,pyss,pzbss,pebss,
8060  + pxsv,pysv,pzbsv,pebsv, pxvs,pyvs,pzbvs,pebvs, pxvv,pyvv,pzbvv,
8061  + pebvv,pxcc,pycc,pzbcc,pebcc,
8062  + pxzz,pyzz,pzbzz,pebzz,
8063  + pxhh,pyhh,pzbhh,pebhh,
8064  + pxds,pyds,pzbds,pebds,
8065  + pxsd,pysd,pzbsd,pebsd,
8066  + pxdz,pydz,pzbdz,pebdz,
8067  + pxzd,pyzd,pzbzd,pebzd,
8068  + pxdv,pydv,pzbdv,pebdv,
8069  + pxvd,pyvd,pzbvd,pebvd
8070  ENDIF
8071  IF (residu.GT.0.02d0)THEN
8072  irej=1
8073  ENDIF
8074  IF (residu.GT.0.02d0.AND.iphkk.GE.2)THEN
8075  irej=1
8076  WRITE(6,'(A,2E15.5)')' E000,PEBAL', e000,pebal
8077  WRITE(6,1000)pxbal,pybal,pzbal,pebal, pxss,pyss,pzbss,pebss,
8078  + pxsv,pysv,pzbsv,pebsv, pxvs,pyvs,pzbvs,pebvs, pxvv,pyvv,pzbvv,
8079  + pebvv,pxcc,pycc,pzbcc,pebcc,
8080  + pxzz,pyzz,pzbzz,pebzz,
8081  + pxhh,pyhh,pzbhh,pebhh,
8082  + pxds,pyds,pzbds,pebds,
8083  + pxsd,pysd,pzbsd,pebsd,
8084  + pxdz,pydz,pzbdz,pebdz,
8085  + pxzd,pyzd,pzbzd,pebzd,
8086  + pxdv,pydv,pzbdv,pebdv,
8087  + pxvd,pyvd,pzbvd,pebvd
8088  ENDIF
8089  1000 FORMAT (' 4 MOMENTUM CONS.IN EVENT LEVEL OF PARTONS',/ ' ALL',4e15
8090  +.5/,' SS ',4e15.5/,' SV ',4e15.5/ ' VS ',4e15.5/,' VV ',4e15.5/,
8091  + ' CC ',4e15.5/
8092  + ' ZZ ',4e15.5/
8093  + ' HH ',4e15.5/
8094  + ' DS ',4e15.5/
8095  + ' SD ',4e15.5/
8096  + ' DZ ',4e15.5/
8097  + ' ZD ',4e15.5/
8098  + ' DV ',4e15.5/
8099  + ' VD ',4e15.5)
8100 C
8101  pxbal=0.
8102  pybal=0.
8103  pzbal=0.
8104  pebal=0.
8105  pxss=0.
8106  pyss=0.
8107  pzss=0.
8108  pess=0.
8109  pxsv=0.
8110  pysv=0.
8111  pzsv=0.
8112  pesv=0.
8113  pxvs=0.
8114  pyvs=0.
8115  pzvs=0.
8116  pevs=0.
8117  pxvv=0.
8118  pyvv=0.
8119  pzvv=0.
8120  pevv=0.
8121  pxcc=0.
8122  pycc=0.
8123  pzcc=0.
8124  pecc=0.
8125  pxds=0.
8126  pyds=0.
8127  pzds=0.
8128  peds=0.
8129  pxsd=0.
8130  pysd=0.
8131  pzsd=0.
8132  pesd=0.
8133  pxdv=0.
8134  pydv=0.
8135  pzdv=0.
8136  pedv=0.
8137  pxvd=0.
8138  pyvd=0.
8139  pzvd=0.
8140  pevd=0.
8141  pxzz=0.
8142  pyzz=0.
8143  pzzz=0.
8144  pezz=0.
8145  pxhh=0.
8146  pyhh=0.
8147  pzhh=0.
8148  pehh=0.
8149 C
8150 C IF(IHADA.OR.IHADSS) THEN
8151  DO 50 n=1,nss
8152  IF (inloss(n))THEN
8153  IF(abs(nchss1(n)).NE.99) THEN
8154  pxss=pxss+bgxss1(n)*amcss1(n)
8155  pyss=pyss+bgyss1(n)*amcss1(n)
8156  pzss=pzss+bgzss1(n)*amcss1(n)
8157  pess=pess+gacss1(n)*amcss1(n)
8158  ENDIF
8159  IF(abs(nchss2(n)).NE.99) THEN
8160  pxss=pxss+bgxss2(n)*amcss2(n)
8161  pyss=pyss+bgyss2(n)*amcss2(n)
8162  pzss=pzss+bgzss2(n)*amcss2(n)
8163  pess=pess+gacss2(n)*amcss2(n)
8164  ENDIF
8165  ENDIF
8166  50 CONTINUE
8167  pzbss=gamcm*pzss + bgcm*pess
8168  pebss=gamcm*pess + bgcm*pzss
8169 C DO 130 N=1,NOCC
8170 C PXCC=PXCC + BGXCC(N)*AMCC(N)
8171 C PYCC=PYCC + BGYCC(N)*AMCC(N)
8172 C PZCC=PZCC + BGZCC(N)*AMCC(N)
8173 C PECC=PECC + GACC(N)*AMCC(N)
8174 C130 CONTINUE
8175  pxbal=pxss
8176  pybal=pyss
8177  pzbal=pzbss
8178  pebal=pebss
8179 C PZBCC=GAMCM*PZCC + BGCM*PECC
8180 C PEBCC=GAMCM*PECC + BGCM*PZCC
8181 C PXBAL=PXBAL + PXCC
8182 C PYBAL=PYBAL + PYCC
8183 C PZBAL=PZBAL + PZBCC
8184 C PEBAL=PEBAL + PEBCC
8185 C ENDIF
8186 C IF(IHADA.OR.IHADSV) THEN
8187  DO 60 n=1,nsv
8188  IF(abs(nchsv1(n)).NE.99) THEN
8189  pxsv=pxsv+bgxsv1(n)*amcsv1(n)
8190  pysv=pysv+bgysv1(n)*amcsv1(n)
8191  pzsv=pzsv+bgzsv1(n)*amcsv1(n)
8192  pesv=pesv+gacsv1(n)*amcsv1(n)
8193  ENDIF
8194  IF(abs(nchsv2(n)).NE.99) THEN
8195  pxsv=pxsv+bgxsv2(n)*amcsv2(n)
8196  pysv=pysv+bgysv2(n)*amcsv2(n)
8197  pzsv=pzsv+bgzsv2(n)*amcsv2(n)
8198  pesv=pesv+gacsv2(n)*amcsv2(n)
8199  ENDIF
8200  60 CONTINUE
8201  pzbsv=gamcm*pzsv + bgcm*pesv
8202  pebsv=gamcm*pesv + bgcm*pzsv
8203  pxbal=pxbal + pxsv
8204  pybal=pybal + pysv
8205  pzbal=pzbal + pzbsv
8206  pebal=pebal + pebsv
8207  DO 61 n=1,nds
8208  IF(abs(nchds1(n)).NE.99) THEN
8209  pxds=pxds+bgxds1(n)*amcds1(n)
8210  pyds=pyds+bgyds1(n)*amcds1(n)
8211  pzds=pzds+bgzds1(n)*amcds1(n)
8212  peds=peds+gacds1(n)*amcds1(n)
8213  ENDIF
8214  IF(abs(nchds2(n)).NE.99) THEN
8215  pxds=pxds+bgxds2(n)*amcds2(n)
8216  pyds=pyds+bgyds2(n)*amcds2(n)
8217  pzds=pzds+bgzds2(n)*amcds2(n)
8218  peds=peds+gacds2(n)*amcds2(n)
8219  ENDIF
8220  61 CONTINUE
8221  pzbds=gamcm*pzds + bgcm*peds
8222  pebds=gamcm*peds + bgcm*pzds
8223  pxbal=pxbal + pxds
8224  pybal=pybal + pyds
8225  pzbal=pzbal + pzbds
8226  pebal=pebal + pebds
8227  DO 62 n=1,nsd
8228  IF(abs(nchsd1(n)).NE.99) THEN
8229  pxsd=pxsd+bgxsd1(n)*amcsd1(n)
8230  pysd=pysd+bgysd1(n)*amcsd1(n)
8231  pzsd=pzsd+bgzsd1(n)*amcsd1(n)
8232  pesd=pesd+gacsd1(n)*amcsd1(n)
8233  ENDIF
8234  IF(abs(nchsd2(n)).NE.99) THEN
8235  pxsd=pxsd+bgxsd2(n)*amcsd2(n)
8236  pysd=pysd+bgysd2(n)*amcsd2(n)
8237  pzsd=pzsd+bgzsd2(n)*amcsd2(n)
8238  pesd=pesd+gacsd2(n)*amcsd2(n)
8239  ENDIF
8240  62 CONTINUE
8241  pzbsd=gamcm*pzsd + bgcm*pesd
8242  pebsd=gamcm*pesd + bgcm*pzsd
8243  pxbal=pxbal + pxsd
8244  pybal=pybal + pysd
8245  pzbal=pzbal + pzbsd
8246  pebal=pebal + pebsd
8247  DO 63 n=1,ndv
8248  IF(abs(nchdv1(n)).NE.99) THEN
8249  pxdv=pxdv+bgxdv1(n)*amcdv1(n)
8250  pydv=pydv+bgydv1(n)*amcdv1(n)
8251  pzdv=pzdv+bgzdv1(n)*amcdv1(n)
8252  pedv=pedv+gacdv1(n)*amcdv1(n)
8253  ENDIF
8254  IF(abs(nchdv2(n)).NE.99) THEN
8255  pxdv=pxdv+bgxdv2(n)*amcdv2(n)
8256  pydv=pydv+bgydv2(n)*amcdv2(n)
8257  pzdv=pzdv+bgzdv2(n)*amcdv2(n)
8258  pedv=pedv+gacdv2(n)*amcdv2(n)
8259  ENDIF
8260  63 CONTINUE
8261  pzbdv=gamcm*pzdv + bgcm*pedv
8262  pebdv=gamcm*pedv + bgcm*pzdv
8263  pxbal=pxbal + pxdv
8264  pybal=pybal + pydv
8265  pzbal=pzbal + pzbdv
8266  pebal=pebal + pebdv
8267  DO 64 n=1,nvd
8268  IF(abs(nchvd1(n)).NE.99) THEN
8269  pxvd=pxvd+bgxvd1(n)*amcvd1(n)
8270  pyvd=pyvd+bgyvd1(n)*amcvd1(n)
8271  pzvd=pzvd+bgzvd1(n)*amcvd1(n)
8272  pevd=pevd+gacvd1(n)*amcvd1(n)
8273  ENDIF
8274  IF(abs(nchvd2(n)).NE.99) THEN
8275  pxvd=pxvd+bgxvd2(n)*amcvd2(n)
8276  pyvd=pyvd+bgyvd2(n)*amcvd2(n)
8277  pzvd=pzvd+bgzvd2(n)*amcvd2(n)
8278  pevd=pevd+gacvd2(n)*amcvd2(n)
8279  ENDIF
8280  64 CONTINUE
8281  pzbvd=gamcm*pzvd + bgcm*pevd
8282  pebvd=gamcm*pevd + bgcm*pzvd
8283  pxbal=pxbal + pxvd
8284  pybal=pybal + pyvd
8285  pzbal=pzbal + pzbvd
8286  pebal=pebal + pebvd
8287 C ENDIF
8288 C IF(IHADA.OR.IHADVS) THEN
8289  DO 70 n=1,nvs
8290  IF(abs(nchvs1(n)).NE.99) THEN
8291  pxvs=pxvs+bgxvs1(n)*amcvs1(n)
8292  pyvs=pyvs+bgyvs1(n)*amcvs1(n)
8293  pzvs=pzvs+bgzvs1(n)*amcvs1(n)
8294  pevs=pevs+gacvs1(n)*amcvs1(n)
8295  ENDIF
8296  IF(abs(nchvs2(n)).NE.99) THEN
8297  pxvs=pxvs+bgxvs2(n)*amcvs2(n)
8298  pyvs=pyvs+bgyvs2(n)*amcvs2(n)
8299  pzvs=pzvs+bgzvs2(n)*amcvs2(n)
8300  pevs=pevs+gacvs2(n)*amcvs2(n)
8301  ENDIF
8302  70 CONTINUE
8303  pzbvs=gamcm*pzvs + bgcm*pevs
8304  pebvs=gamcm*pevs + bgcm*pzvs
8305  pxbal=pxbal + pxvs
8306  pybal=pybal + pyvs
8307  pzbal=pzbal + pzbvs
8308  pebal=pebal + pebvs
8309 C ENDIF
8310  DO 250 n=1,nonust
8311  IF(abs(nchzz1(n)).NE.99.AND.jhkksx(n).EQ.1) THEN
8312  pxzz=pxzz+bgxzz1(n)*amczz1(n)
8313  pyzz=pyzz+bgyzz1(n)*amczz1(n)
8314  pzzz=pzzz+bgzzz1(n)*amczz1(n)
8315  pezz=pezz+gaczz1(n)*amczz1(n)
8316  ENDIF
8317  IF(abs(nchzz2(n)).NE.99.AND.jhkksx(n).EQ.1) THEN
8318  pxzz=pxzz+bgxzz2(n)*amczz2(n)
8319  pyzz=pyzz+bgyzz2(n)*amczz2(n)
8320  pzzz=pzzz+bgzzz2(n)*amczz2(n)
8321  pezz=pezz+gaczz2(n)*amczz2(n)
8322  ENDIF
8323  250 CONTINUE
8324  pzbzz=gamcm*pzzz + bgcm*pezz
8325  pebzz=gamcm*pezz + bgcm*pzzz
8326  pxbal=pxbal + pxzz
8327  pybal=pybal + pyzz
8328  pzbal=pzbal + pzbzz
8329  pebal=pebal + pebzz
8330  DO 260 n=1,nonujt
8331  IF(abs(nchhh1(n)).NE.99.AND.jhkkex(n).EQ.1) THEN
8332  pxhh=pxhh+bgxhh1(n)*amchh1(n)
8333  pyhh=pyhh+bgyhh1(n)*amchh1(n)
8334  pzhh=pzhh+bgzhh1(n)*amchh1(n)
8335  pehh=pehh+gachh1(n)*amchh1(n)
8336  ENDIF
8337  IF(abs(nchhh2(n)).NE.99.AND.jhkkex(n).EQ.1) THEN
8338  pxhh=pxhh+bgxhh2(n)*amchh2(n)
8339  pyhh=pyhh+bgyhh2(n)*amchh2(n)
8340  pzhh=pzhh+bgzhh2(n)*amchh2(n)
8341  pehh=pehh+gachh2(n)*amchh2(n)
8342  ENDIF
8343  260 CONTINUE
8344  pzbhh=gamcm*pzhh + bgcm*pehh
8345  pebhh=gamcm*pehh + bgcm*pzhh
8346  pxbal=pxbal + pxhh
8347  pybal=pybal + pyhh
8348  pzbal=pzbal + pzbhh
8349  pebal=pebal + pebhh
8350 C IF(IHADA.OR.IHADVV) THEN
8351  DO 80 n=1,nvv
8352  IF((nchvv1(n).NE.99).AND.(nchvv2(n).NE.99)) THEN
8353  pxvv=pxvv+bgxvv1(n)*amcvv1(n)+bgxvv2(n)*amcvv2(n)
8354  pyvv=pyvv+bgyvv1(n)*amcvv1(n)+bgyvv2(n)*amcvv2(n)
8355  pzvv=pzvv+bgzvv1(n)*amcvv1(n)+bgzvv2(n)*amcvv2(n)
8356  pevv=pevv+gacvv1(n)*amcvv1(n)+gacvv2(n)*amcvv2(n)
8357  ENDIF
8358  80 CONTINUE
8359  pzbvv=gamcm*pzvv + bgcm*pevv
8360  pebvv=gamcm*pevv + bgcm*pzvv
8361  pxbal=pxbal + pxvv
8362  pybal=pybal + pyvv
8363  pzbal=pzbal + pzbvv
8364  pebal=pebal + pebvv
8365 C ENDIF
8366 C
8367  IF (ipev.GE.1) WRITE(6,1010)pxbal,pybal,pzbal,
8368  +pebal, pxss,pyss,pzbss,pebss, pxsv,pysv,pzbsv,pebsv, pxvs,pyvs,
8369  +pzbvs,pebvs, pxvv,pyvv,pzbvv,pebvv, pxcc,pycc,pzbcc,pebcc,
8370  + pxds,pyds,pzbds,pebds,
8371  + pxzz,pyzz,pzbzz,pebzz,
8372  + pxhh,pyhh,pzbhh,pebhh,
8373  + pxsd,pysd,pzbsd,pebsd,
8374  + pxdv,pydv,pzbdv,pebdv,
8375  + pxvd,pyvd,pzbvd,pebvd
8376  1010 FORMAT (' 4 MOMENTUM CONS.IN EVENT LEVEL OF CHAINS',/ ' ALL',4e15.
8377  +5/,' SS ',4e15.5/,' SV ',4e15.5/ ' VS ',4e15.5/,' VV ',4e15.5/,
8378  + ' CC ',4e15.5/
8379  + ' DS ',4e15.5/
8380  + ' ZZ ',4e15.5/
8381  + ' HH ',4e15.5/
8382  + ' SD ',4e15.5/
8383  + ' DV ',4e15.5/
8384  + ' VD ',4e15.5)
8385 C
8386  RETURN
8387  END
8388 *-- Author :
8389 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8390  SUBROUTINE corval(AMMM,IREJ,AMCH1,AMCH2, QTX1,QTY1,QZ1,QE1,QTX2,
8391  +qty2,qz2,qe2,norig)
8392  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8393  SAVE
8394 C
8395 C KINEMATICAL CORRECTION OF TWO-VALENCE CHAIN SYSTEM
8396 C ACCORDING TO 2-PARTICLE KINEMATICS WITH FIXED MASSES
8397 C
8398 C**** WIR BRAUCHEN AUCH NOCH DIE NEUEN 4-IMPULSE DER KETTENENDEN
8399 C
8400 *KEEP,DPRIN.
8401  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8402 *KEND.
8403 C-----------------------------------------
8404  irej=0
8405  IF(ammm.LE.amch1+amch2+0.4d0) THEN
8406  irej=1
8407  RETURN
8408  ENDIF
8409 C
8410  ek1=(ammm**2-amch2**2 + amch1**2)/(2.*ammm)
8411  ek2=ammm - ek1
8412  pzk1=sqrt(ek1**2 - amch1**2)
8413  pzk1=sign(pzk1,qz1)
8414  pzk2=sqrt(ek2**2 - amch2**2)
8415  pzk2=sign(pzk2,qz2)
8416  pxk1=0.
8417  pyk1=0.
8418  pxk2=0.
8419  pyk2=0.
8420  qtx2=pxk2
8421  qty2=pyk2
8422  qz2=pzk2
8423  qe2=ek2
8424  qtx1=pxk1
8425  qty1=pyk1
8426  qz1=pzk1
8427  qe1=ek1
8428 C ROTATE NEW CHAIN MOMENTA
8429 C INTO DIRECTION OF CHAINS BEFORE CORRECTION
8430 C GAM=(QE1+QE2)/AMMM
8431 C BGX=(QTX1+QTX2)/AMMM
8432 C BGY=(QTY1+QTY2)/AMMM
8433 C BGZ=(QZ1+QZ2)/AMMM
8434 C
8435 C IF(ABS(GAM-1.D0).GT.1D-4) THEN
8436 C WRITE(6,'(A,I10,A/6(1PE15.5)/15X,5(1PE15.4))')
8437 C + ' CORVAL: INCONSISTENT KINEMATICS OF CHAINS NORIG= ',NORIG,
8438 C + ' AMMM,AMCH1,QE1,QTX1,QTY1, QZ1,AMCH2,QE2,QTX2,QTY2,QZ2',
8439 C + AMMM,
8440 C + AMCH1, QE1,
8441 C + QTX1, QTY1, QZ1, AMCH2,QE2, QTX2, QTY2, QZ2
8442 C IREJ=1
8443 C ENDIF
8444 C
8445 C CALL DALTRA(GAM,-BGX,-BGY,-BGZ,PXK1,PYK1,PZK1,EK1,PPPCH1, QTX1,
8446 C +QTY1,QZ1,QE1)
8447 C CALL DALTRA(GAM,-BGX,-BGY,-BGZ,PXK2,PYK2,PZK2,EK2,PPPCH2, QTX2,
8448 C +QTY2,QZ2,QE2)
8449 C IF(IPRI.GT.1) THEN
8450 CC WRITE(6,'(2A)') ' CORVAL - CORRECTION OF CHAIN MOMENTA',
8451 C + ' IF MASS OF CHAIN 2 HAD TO BE CHANGED'
8452 C ENDIF
8453  RETURN
8454  END
8455 
8456 C
8457 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8458 C
8459  SUBROUTINE hadrhh
8460  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8461  SAVE
8462 C-------------------------
8463 C
8464 C HADRONIZE HARD CHAINS
8465 C
8466 C ADD GENERATED HADRONS TO /ALLPAR/
8467 C STARTING AT (NAUX + 1)
8468 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
8469 C
8470 C---------------------------------------------------------
8471  parameter(intmx=2488,intmd=252)
8472  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
8473  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
8474  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
8475  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
8476  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
8477  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
8478  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
8479  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
8480 *KEEP,INTNEW.
8481  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
8482  +ixpv,ixps,ixtv,ixts, intvv1(248),
8483  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
8484  +intss1(intmx),intss2(intmx),
8485  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
8486  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
8487 
8488 C /INTNEW/
8489 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
8490 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
8491 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
8492 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
8493 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
8494 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
8495 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
8496 C FROM PROJECTILE/TARGET NUCLEI
8497 C-------------------
8498  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx),
8499  * ifrovt(248),itovt(248),ifrost(intmx),
8500  * jsshs(intmx),jtshs(intmx),jhkknp(248),jhkknt(248),
8501  * jhkkpv(intmx),jhkkps(intmx),
8502  * jhkktv(intmx),jhkkts(intmx),
8503  * mhkkvv(intmx),mhkkss(intmx),
8504  & mhkkvs(intmx),mhkksv(intmx),
8505  & mhkkhh(intmx),
8506  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
8507 C-------------------
8508 *KEEP,DIQI.
8509  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
8510  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
8511  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
8512  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
8513 C.....................................................................
8514  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
8515  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),
8516  *zuost(intmx),
8517  * intlo(intmx),inloss(intmx)
8518 C /LOZUO/
8519 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
8520 C REJECTED IN KKEVT
8521 C
8522  COMMON /abrhh/ amchh1(intmx),amchh2(intmx),
8523  * gachh1(intmx),gachh2(intmx),
8524  * bgxhh1(intmx),bgyhh1(intmx),bgzhh1(intmx),
8525  * bgxhh2(intmx),bgyhh2(intmx),bgzhh2(intmx),
8526  * nchhh1(intmx),nchhh2(intmx),
8527  * ijchh1(intmx),ijchh2(intmx),
8528  * pqhha1(intmx,4),pqhha2(intmx,4),
8529  * pqhhb1(intmx,4),pqhhb2(intmx,4)
8530  COMMON /hardha/nhard1,nhkkha
8531 C
8532 C modified DPMJET
8533  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
8534  * anndv,annvd,annds,annsd,
8535  * annhh,annzz,
8536  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
8537  * pthh,ptzz,
8538  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
8539  * eehh,eezz
8540  * ,anndi,ptdi,eedi
8541  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
8542  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
8543  * acouzz,acouhh,acouds,acousd,
8544  * acoudz,acouzd,acoudi,
8545  * acoudv,acouvd,acoucc
8546 C---------------------
8547  COMMON /pshow/ ipshow
8548 C COMMON /HARLUN/ IHARLU,QLUN
8549  COMMON /harlun/ qlun,iharlu
8550  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
8551  COMMON /jspa/pxs(40000),pys(40000),pzs(40000),hes(40000),nnnps
8552 C--------------------
8553 *KEEP,DFINPA.
8554  CHARACTER*8 anf
8555  parameter(nfimax=249)
8556  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
8557  +hep(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
8558  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
8559  * istath(nfimax)
8560 C-------------------
8561  parameter(nmxhkk= 89998)
8562  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
8563  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),phkk(5,nmxhkk),
8564  & vhkk(4,nmxhkk),whkk(4,nmxhkk)
8565 C
8566  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8567  COMMON /projk/ iprojk
8568  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
8569  COMMON /gluspl/nugluu,nsgluu
8570  COMMON /nomije/ ptmije(10),nnmije(10)
8571 C
8572  dimension poj(4),pat(4)
8573  DATA ncalhh /0/
8574 C-----------------------------------------------------------------------
8575  nhard1=nhkk+1
8576  DO 20 i=1,nonujt
8577  ncalhh=ncalhh+1
8578 C
8579  IF (iphkk.GE.2)WRITE(6,7789)nonujt,ncalhh
8580  7789 FORMAT (' HADRHH NONUJT,NCALHH ',2i10)
8581  IF (jhkkex(i).EQ.1)THEN
8582  IF (i.GT.intmx)THEN
8583  WRITE (6,7744)i,intmx
8584  7744 FORMAT (.GT.' HADRHH IINTMX ',2i10)
8585  RETURN
8586  ENDIF
8587 C
8588 C++++++++++++++++++++++++++++++ CHAIN 1: QUARK-ANTIQUARK +++++++
8589  ifb1=ijjq1(i)
8590  ifb2=ijjaq1(i)
8591  ifb2=iabs(ifb2)+6
8592  DO 21 j=1,4
8593  poj(j)=pjeta1(i,j)
8594  pat(j)=pjeta2(i,j)
8595  21 CONTINUE
8596  pt1=sqrt(poj(1)**2+poj(2)**2)
8597  pt2=sqrt(pat(1)**2+pat(2)**2)
8598  CALL parpt(2,pt1,pt2,6,nevt)
8599  iharlu=0
8600  qlun=0.
8601  IF(ipshow.EQ.1)THEN
8602  pojpt=sqrt(poj(2)**2+poj(1)**2)
8603  patpt=sqrt(pat(1)**2+pat(2)**2)
8604  DO iiii=1,10
8605  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
8606  * nnmije(iiii)+1
8607  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
8608  * nnmije(iiii)+1
8609  ENDDO
8610  qlun=min(pojpt,patpt)
8611  IF((qlun.LT.2.5d0).OR.(amjch1(i).LT.5.d0))THEN
8612  qlun=0.
8613  iharlu=0
8614  ELSE
8615  iharlu=1
8616  ENDIF
8617  ENDIF
8618 C----------------------------------------------------------------
8619  IF (gamjh1(i).LT.0.001d0.OR.amjch1(i).LT.2.d0)THEN
8620  WRITE (6,7788)
8621  * i,nhad,amjch1(i),poj,pat,gamjh1(i),bgxjh1(i),
8622  * bgyjh1(i),bgzjh1(i),ifb1,ifb2,ifb3,ifb4,jhkkex(i)
8623  7788 FORMAT (' HADRHH ',2i5,8e12.2/5e12.2,5i5)
8624  go to 9977
8625  ENDIF
8626  CALL hadjet(nhad,amjch1(i),poj,pat,gamjh1(i),bgxjh1(i),
8627  * bgyjh1(i),bgzjh1(i),ifb1,ifb2,ifb3,ifb4,
8628  * 13,13,3,0,13)
8629  acouhh=acouhh+1
8630  iharlu=0
8631  qlun=0.
8632  nhkkau=nhkk+1
8633  IF(iphkk.GE.3)WRITE(6,*)' HADRHH:NHKK,NHKKAU ',nhkk,nhkkau
8634  IF (nhad.GT.nfimax) THEN
8635  WRITE (6,7755)nhad,nfimax
8636  7755 FORMAT (.GT.' NHADNFIMAX ',2i10)
8637  RETURN
8638  ENDIF
8639  DO 22 j=1,nhad
8640 C NHKK=NHKK+1
8641  IF (nhkk.EQ.nmxhkk) THEN
8642  WRITE (*,'(A,2I5/A)') .EQ.' HADRHH: NHKKNMXHKK ',
8643  * nhkk,nmxhkk
8644  RETURN
8645  ENDIF
8646 C
8647  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
8648  IF (abs(ehecc-hep(j)).GT.0.001d0) THEN
8649 C WRITE(*,'(2A/3I5,3E15.6)')
8650 C & ' HADRSV / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
8651 C * ' NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)',
8652 C * NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)
8653  hep(j)=ehecc
8654  ENDIF
8655  annhh=annhh+1.
8656  eehh=eehh+hep(j)
8657  pthh=sqrt(pxf(j)**2+pyf(j)**2)+pthh
8658 C PUT NN-CMS HADRONS INTO /HKKEVT/
8659  istist=1
8660  IF(ibarf(j).EQ.500)istist=2
8661  CALL hkkfil(istist,mpdgha(nref(j)),mhkkhh(i)-3,0,
8662  * pxf(j),pyf(j),pzf(j),hep(j),nhkkau,iormo(j),9)
8663  IF(idhkk(nhkk).EQ.99999) WRITE (6,5009)nhkk,nref(j),
8664  * idhkk(nhkk)
8665  IF(iphkk.GE.3) WRITE(6,*)' First chain HADRHH'
8666  IF (iphkk.GE.3) WRITE(6,5001) nhkk,
8667  * isthkk(nhkk),idhkk(nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk),
8668  & jdahkk(1,nhkk),jdahkk(2,nhkk),(phkk(khkk,nhkk),khkk=1,5),
8669  & (vhkk(khkk,nhkk),khkk=1,4)
8670  22 CONTINUE
8671 C JDAHKK(1,IMOHKK)=NHKKAU
8672 C JDAHKK(2,IMOHKK)=NHKK
8673  IF(nnnpj.GE.1)THEN
8674  nnnpso=nnnps
8675  nnnps=nnnps+1
8676  nnnpsu=nnnpso+nnnpj
8677  DO 137 j=nnnps,nnnpsu
8678  jj=j-nnnps+1
8679  IF(j.GT.40000.OR.jj.GT.1000)THEN
8680 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
8681  go to 137
8682  ENDIF
8683  pxs(j)=pxj(jj)
8684  pys(j)=pyj(jj)
8685  pzs(j)=pzj(jj)
8686  hes(j)=hej(jj)
8687  137 CONTINUE
8688  nnnps=nnnps+nnnpj-1
8689  ENDIF
8690  9977 continue
8691 C+++++++++++++++++++++++++++++ CHAIN 2: AQUARK-QUARK ++++++++++++++
8692  IF (nugluu.EQ.1) go to 5111
8693  ifb1=ijjaq2(i)
8694  ifb2=ijjq2(i)
8695  ifb1=iabs(ifb1)+6
8696  DO 23 j=1,4
8697  poj(j)=pjetb1(i,j)
8698  pat(j)=pjetb2(i,j)
8699  23 CONTINUE
8700  pt1=sqrt(poj(1)**2+poj(2)**2)
8701  pt2=sqrt(pat(1)**2+pat(2)**2)
8702  CALL parpt(2,pt1,pt2,6,nevt)
8703  iharlu=0
8704  qlun=0.
8705  IF(ipshow.EQ.1)THEN
8706  pojpt=sqrt(poj(2)**2+poj(1)**2)
8707  patpt=sqrt(pat(1)**2+pat(2)**2)
8708  DO iiii=1,10
8709  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
8710  * nnmije(iiii)+1
8711  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
8712  * nnmije(iiii)+1
8713  ENDDO
8714  qlun=min(pojpt,patpt)
8715  IF((qlun.LT.2.5d0).OR.(amjch2(i).LT.5.d0))THEN
8716  qlun=0.
8717  iharlu=0
8718  ELSE
8719  iharlu=1
8720  ENDIF
8721  ENDIF
8722 C
8723  CALL hadjet(nhad,amjch2(i),poj,pat,gamjh2(i),bgxjh2(i),
8724  * bgyjh2(i),bgzjh2(i),ifb1,ifb2,ifb3,ifb4,
8725  * 13,13,3,0,14)
8726  iharlu=0
8727  qlun=0.
8728 C ADD HADRONS/RESONANCES INTO
8729 C COMMON /ALLPAR/ STARTING AT NAUX
8730  nhkkau=nhkk+1
8731  DO 24 j=1,nhad
8732 C NHKK=NHKK+1
8733  IF (nhkk.EQ.nmxhkk) THEN
8734  WRITE (*,'(A,2I5/A)') .EQ.' HADRHH: NHKKNMXHKK ',
8735  & nhkk,nmxhkk
8736  RETURN
8737  ENDIF
8738 C
8739  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
8740  IF (abs(ehecc-hep(j)).GT.0.001d0) THEN
8741 C WRITE(*,'(2A/3I5,3E15.6)')
8742 C & ' HADRHH / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
8743 C * ' NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)',
8744 C * NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)
8745  hep(j)=ehecc
8746  ENDIF
8747  annhh=annhh+1.
8748  eehh=eehh+hep(j)
8749  pthh=sqrt(pxf(j)**2+pyf(j)**2)+pthh
8750 C PUT NN-CMS HADRONS INTO /HKKEVT/
8751  istist=1
8752  IF(ibarf(j).EQ.500)istist=2
8753  CALL hkkfil(istist,mpdgha(nref(j)),mhkkhh(i),0,
8754  * pxf(j),pyf(j),pzf(j),hep(j),nhkkau,iormo(j),10)
8755  IF(idhkk(nhkk).EQ.99999) WRITE (6,5009)nhkk,nref(j),
8756  * idhkk(nhkk)
8757 C WRITE(6,*)' Second chain HADRHH'
8758  IF (iphkk.GE.7) WRITE(6,5001) nhkk,
8759  * isthkk(nhkk),idhkk(nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk),
8760  & jdahkk(1,nhkk),jdahkk(2,nhkk),(phkk(khkk,nhkk),khkk=1,5),
8761  & (vhkk(khkk,nhkk),khkk=1,4)
8762  24 CONTINUE
8763 C JDAHKK(1,IMOHKK)=NHKKAU
8764 C JDAHKK(2,IMOHKK)=NHKK
8765  IF(nnnpj.GE.1)THEN
8766  nnnpso=nnnps
8767  nnnps=nnnps+1
8768  nnnpsu=nnnpso+nnnpj
8769  DO 187 j=nnnps,nnnpsu
8770  jj=j-nnnps+1
8771  IF(j.GT.40000.OR.jj.GT.1000)THEN
8772 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
8773  go to 187
8774  ENDIF
8775  pxs(j)=pxj(jj)
8776  pys(j)=pyj(jj)
8777  pzs(j)=pzj(jj)
8778  hes(j)=hej(jj)
8779  187 CONTINUE
8780  nnnps=nnnps+nnnpj-1
8781  ENDIF
8782  5111 CONTINUE
8783  ENDIF
8784  20 CONTINUE
8785  CALL dechkk(nhard1)
8786  nhkkha=nhkk
8787 C----------------------------------------------------------------
8788 C
8789  RETURN
8790  5001 FORMAT (i6,i4,5i6,9e10.2)
8791  5003 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
8792  5009 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
8793  END
8794 C
8795 C********************************************************************
8796 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
8797 C
8798  SUBROUTINE hadrzz
8799  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8800  SAVE
8801 C-------------------------
8802 C
8803 C HADRONIZE HARD CHAINS
8804 C
8805 C ADD GENERATED HADRONS TO /ALLPAR/
8806 C STARTING AT (NAUX + 1)
8807 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
8808 C
8809 C---------------------------------------------------------
8810  parameter(intmx=2488,intmd=252)
8811  COMMON /abrzz/ amczz1(intmx),amczz2(intmx),
8812  * gaczz1(intmx),gaczz2(intmx),
8813  * bgxzz1(intmx),bgyzz1(intmx),bgzzz1(intmx),
8814  * bgxzz2(intmx),bgyzz2(intmx),bgzzz2(intmx),
8815  * nchzz1(intmx),nchzz2(intmx),
8816  * ijczz1(intmx),ijczz2(intmx),
8817  * pqzza1(intmx,4),pqzza2(intmx,4),
8818  * pqzzb1(intmx,4),pqzzb2(intmx,4)
8819  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
8820  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
8821  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
8822  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
8823  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
8824  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
8825  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
8826  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
8827  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
8828  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
8829 *KEEP,INTNEW.
8830  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
8831  +ixpv,ixps,ixtv,ixts, intvv1(248),
8832  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
8833  +intss1(intmx),intss2(intmx),
8834  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
8835  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
8836 
8837 C /INTNEW/
8838 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
8839 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
8840 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
8841 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
8842 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
8843 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
8844 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
8845 C FROM PROJECTILE/TARGET NUCLEI
8846 C-------------------
8847  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx),
8848  * ifrovt(248),itovt(248),ifrost(intmx),
8849  * jsshs(intmx),jtshs(intmx),jhkknp(248),jhkknt(248),
8850  * jhkkpv(intmx),jhkkps(intmx),
8851  * jhkktv(intmx),jhkkts(intmx),
8852  * mhkkvv(intmx),mhkkss(intmx),
8853  & mhkkvs(intmx),mhkksv(intmx),
8854  & mhkkhh(intmx),
8855  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
8856 C-------------------
8857 *KEEP,DIQI.
8858  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
8859  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
8860  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
8861  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
8862 C.....................................................................
8863  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
8864  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),
8865  *zuost(intmx),
8866  * intlo(intmx),inloss(intmx)
8867 C /LOZUO/
8868 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
8869 C REJECTED IN KKEVT
8870 C
8871 C
8872 C modified DPMJET
8873  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
8874  * anndv,annvd,annds,annsd,
8875  * annhh,annzz,
8876  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
8877  * pthh,ptzz,
8878  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
8879  * eehh,eezz
8880  * ,anndi,ptdi,eedi
8881  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
8882  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
8883  * acouzz,acouhh,acouds,acousd,
8884  * acoudz,acouzd,acoudi,
8885  * acoudv,acouvd,acoucc
8886 C---------------------
8887  COMMON /pshow/ ipshow
8888 C COMMON /HARLUN/ IHARLU,QLUN
8889  COMMON /harlun/ qlun,iharlu
8890  COMMON /jspar/pxj(1000),pyj(1000),pzj(1000),hej(1000),nnnpj
8891  COMMON /jspa/pxs(40000),pys(40000),pzs(40000),hes(40000),nnnps
8892 C--------------------
8893 *KEEP,DFINPA.
8894  CHARACTER*8 anf
8895  parameter(nfimax=249)
8896  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
8897  +hep(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
8898  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
8899  * istath(nfimax)
8900 C-------------------
8901  parameter(nmxhkk= 89998)
8902  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
8903  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),phkk(5,nmxhkk),
8904  & vhkk(4,nmxhkk),whkk(4,nmxhkk)
8905 C
8906  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8907  COMMON /projk/ iprojk
8908  COMMON /gluspl/nugluu,nsgluu
8909  COMMON /nomije/ ptmije(10),nnmije(10)
8910 C
8911  dimension poj(4),pat(4)
8912  DATA ncalzz /0/
8913 C-----------------------------------------------------------------------
8914  DO 20 i=1,nonust
8915  IF(nch1(i).EQ.99.OR.nch1(i).EQ.88)go to 20
8916  IF(nch2(i).EQ.99.OR.nch2(i).EQ.88)go to 20
8917  ncalzz=ncalzz+1
8918 C
8919  IF (iphkk.GE.7)WRITE(6,7789)nonust,ncalzz,jhkksx(i)
8920  7789 FORMAT (' HADRZZ NONUST,NCALZZ,Jhkksx(i) ',3i10)
8921  IF (jhkksx(i).EQ.1)THEN
8922  IF (i.GT.intmx)THEN
8923  WRITE (6,7744)i,intmx
8924  7744 FORMAT (.GT.' HADRZZ IINTMX ',2i10)
8925  RETURN
8926  ENDIF
8927 C
8928 C++++++++++++++++++++++++++++++ CHAIN 1: QUARK-DIQUARK +++++++++++
8929  ifb1=ijsq1(i)
8930  ifb2=ijsaq1(i)
8931  ifb2=iabs(ifb2)+6
8932  DO 21 j=1,4
8933  poj(j)=psofa1(i,j)
8934  pat(j)=psofa2(i,j)
8935  21 CONTINUE
8936  pt1=sqrt(poj(1)**2+poj(2)**2)
8937  pt2=sqrt(pat(1)**2+pat(2)**2)
8938  CALL parpt(2,pt1,pt2,5,nevt)
8939  iharlu=0
8940  qlun=0.
8941  IF(ipshow.EQ.1)THEN
8942  pojpt=sqrt(poj(2)**2+poj(1)**2)
8943  patpt=sqrt(pat(1)**2+pat(2)**2)
8944  DO iiii=1,10
8945  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
8946  * nnmije(iiii)+1
8947  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
8948  * nnmije(iiii)+1
8949  ENDDO
8950  qlun=min(pojpt,patpt)
8951  IF((qlun.LT.2.5d0).OR.(amcch1(i).LT.5.d0))THEN
8952  qlun=0.
8953  iharlu=0
8954  ELSE
8955  iharlu=1
8956  ENDIF
8957  ENDIF
8958 C----------------------------------------------------------------
8959  IF (gamch1(i).LT.0.001d0)WRITE (6,7788)
8960  * i,nhad,amcch1(i),poj,pat,gamch1(i),bgxch1(i),
8961  * bgych1(i),bgzch1(i),ifb1,ifb2,ifb3,ifb4,jhkksx(i)
8962  7788 FORMAT (' HADRZZ ',2i5,10e12.2/3e12.2,5i5)
8963  CALL hadjet(nhad,amcch1(i),poj,pat,gamch1(i),bgxch1(i),
8964  * bgych1(i),bgzch1(i),ifb1,ifb2,ifb3,ifb4,
8965  * ijczz1(i),ijczz1(i),3,nchzz1(i),23)
8966  acouzz=acouzz+1
8967  iharlu=0
8968  qlun=0.
8969  nhkkau=nhkk+1
8970  IF (nhad.GT.nfimax) THEN
8971  WRITE (6,7755)nhad,nfimax
8972  7755 FORMAT (.GT.' NHADNFIMAX ',2i10)
8973  RETURN
8974  ENDIF
8975  DO 22 j=1,nhad
8976 C NHKK=NHKK+1
8977  IF (nhkk.EQ.nmxhkk) THEN
8978  WRITE (*,'(A,2I5/A)') .EQ.' HADRZZ: NHKKNMXHKK ',
8979  * nhkk,nmxhkk
8980  RETURN
8981  ENDIF
8982 C
8983  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
8984  IF (abs(ehecc-hep(j)).GT.0.001d0) THEN
8985 C WRITE(*,'(2A/3I5,3E15.6)')
8986 C & ' HADRZZ / CHAIN 1 : CORRECT INCONSISTENT ENERGY ',
8987 C * ' NCALZZ, NHKK,NREF(J), HEP(J),EHECC, AMF(J)',
8988 C * NCALHH, NHKK,NREF(J), HEP(J),EHECC, AMF(J)
8989  hep(j)=ehecc
8990  ENDIF
8991  annzz=annzz+1.
8992  eezz=eezz+hep(j)
8993  ptzz=sqrt(pxf(j)**2+pyf(j)**2)+ptzz
8994 C PUT NN-CMS HADRONS INTO /HKKEVT/
8995  istist=1
8996  IF(ibarf(j).EQ.500)istist=2
8997  CALL hkkfil(istist,mpdgha(nref(j)),mhkkhh(i)-3,0,
8998  * pxf(j),pyf(j),pzf(j),hep(j),nhkkau,iormo(j),11)
8999  IF(idhkk(nhkk).EQ.99999) WRITE (6,5009)nhkk,nref(j),
9000  * idhkk(nhkk)
9001 C WRITE(6,*)' First chain HADRZZ'
9002  IF (iphkk.GE.7) WRITE(6,5001) nhkk,
9003  * isthkk(nhkk),idhkk(nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk),
9004  & jdahkk(1,nhkk),jdahkk(2,nhkk),(phkk(khkk,nhkk),khkk=1,5),
9005  & (vhkk(khkk,nhkk),khkk=1,4)
9006  22 CONTINUE
9007 C JDAHKK(1,IMOHKK)=NHKKAU
9008 C JDAHKK(2,IMOHKK)=NHKK
9009  IF(nnnpj.GE.1)THEN
9010  nnnpso=nnnps
9011  nnnps=nnnps+1
9012  nnnpsu=nnnpso+nnnpj
9013  DO 137 j=nnnps,nnnpsu
9014  jj=j-nnnps+1
9015  IF(j.GT.40000.OR.jj.GT.1000)THEN
9016 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
9017  go to 137
9018  ENDIF
9019  pxs(j)=pxj(jj)
9020  pys(j)=pyj(jj)
9021  pzs(j)=pzj(jj)
9022  hes(j)=hej(jj)
9023  137 CONTINUE
9024  nnnps=nnnps+nnnpj-1
9025  ENDIF
9026 C+++++++++++++++++++++++++++++ CHAIN 2: AQUARK-QUARK ++++++++++++++
9027  ifb1=ijsaq2(i)
9028  ifb2=ijsq2(i)
9029  ifb1=iabs(ifb1)+6
9030  DO 23 j=1,4
9031  poj(j)=psofb1(i,j)
9032  pat(j)=psofb2(i,j)
9033  23 CONTINUE
9034  pt1=sqrt(poj(1)**2+poj(2)**2)
9035  pt2=sqrt(pat(1)**2+pat(2)**2)
9036  CALL parpt(2,pt1,pt2,5,nevt)
9037  iharlu=0
9038  qlun=0.
9039  IF(ipshow.EQ.1)THEN
9040  pojpt=sqrt(poj(2)**2+poj(1)**2)
9041  patpt=sqrt(pat(1)**2+pat(2)**2)
9042  DO iiii=1,10
9043  IF(pojpt.GE.ptmije(iiii))nnmije(iiii)=
9044  * nnmije(iiii)+1
9045  IF(patpt.GE.ptmije(iiii))nnmije(iiii)=
9046  * nnmije(iiii)+1
9047  ENDDO
9048  qlun=min(pojpt,patpt)
9049  IF((qlun.LT.2.5d0).OR.(amcch2(i).LT.5.d0))THEN
9050  qlun=0.
9051  iharlu=0
9052  ELSE
9053  iharlu=1
9054  ENDIF
9055  ENDIF
9056 C TURN 20.8.91
9057  CALL hadjet(nhad,amcch2(i),pat,poj,gamch2(i),bgxch2(i),
9058  * bgych2(i),bgzch2(i),ifb1,ifb2,ifb3,ifb4,
9059  * ijczz2(i),ijczz2(i),3,nchzz2(i),24)
9060  iharlu=0
9061  qlun=0.
9062 C ADD HADRONS/RESONANCES INTO
9063 C COMMON /ALLPAR/ STARTING AT NAUX
9064  nhkkau=nhkk+1
9065  DO 24 j=1,nhad
9066 C NHKK=NHKK+1
9067  IF (nhkk.EQ.nmxhkk) THEN
9068  WRITE (*,'(A,2I5/A)') .EQ.' HADRZZ: NHKKNMXHKK ',
9069  & nhkk,nmxhkk
9070  RETURN
9071  ENDIF
9072 C
9073  ehecc=sqrt(pxf(j)**2+pyf(j)**2+pzf(j)**2+amf(j)**2)
9074  IF (abs(ehecc-hep(j)).GT.0.001d0) THEN
9075 C WRITE(*,'(2A/3I5,3E15.6)')
9076 C & ' HADRZZ / CHAIN 2 : CORRECT INCONSISTENT ENERGY ',
9077 C * ' NCALZZ, NHKK,NREF(J), HEP(J),EHECC, AMF(J)',
9078 C * NCALZZ, NHKK,NREF(J), HEP(J),EHECC, AMF(J)
9079  hep(j)=ehecc
9080  ENDIF
9081  annzz=annzz+1.
9082  eezz=eezz+hep(j)
9083  ptzz=sqrt(pxf(j)**2+pyf(j)**2)+ptzz
9084 C PUT NN-CMS HADRONS INTO /HKKEVT/
9085  istist=1
9086  IF(ibarf(j).EQ.500)istist=2
9087  CALL hkkfil(istist,mpdgha(nref(j)),mhkkhh(i),0,
9088  * pxf(j),pyf(j),pzf(j),hep(j),nhkkau,iormo(j),12)
9089  IF(idhkk(nhkk).EQ.99999) WRITE (6,5009)nhkk,nref(j),
9090  * idhkk(nhkk)
9091 C WRITE(6,*)' Second chain HADRZZ'
9092  IF (iphkk.GE.7) WRITE(6,5001) nhkk,
9093  * isthkk(nhkk),idhkk(nhkk),jmohkk(1,nhkk),jmohkk(2,nhkk),
9094  & jdahkk(1,nhkk),jdahkk(2,nhkk),(phkk(khkk,nhkk),khkk=1,5),
9095  & (vhkk(khkk,nhkk),khkk=1,4)
9096  24 CONTINUE
9097 C JDAHKK(1,IMOHKK)=NHKKAU
9098 C JDAHKK(2,IMOHKK)=NHKK
9099  IF(nnnpj.GE.1)THEN
9100  nnnpso=nnnps
9101  nnnps=nnnps+1
9102  nnnpsu=nnnpso+nnnpj
9103  DO 187 j=nnnps,nnnpsu
9104  jj=j-nnnps+1
9105  IF(j.GT.40000.OR.jj.GT.1000)THEN
9106 C WRITE(6,'(A,2I10)')' J.gt.40000.or.jj.gt.1000 ',J,JJ
9107  go to 187
9108  ENDIF
9109  pxs(j)=pxj(jj)
9110  pys(j)=pyj(jj)
9111  pzs(j)=pzj(jj)
9112  hes(j)=hej(jj)
9113  187 CONTINUE
9114  nnnps=nnnps+nnnpj-1
9115  ENDIF
9116  5111 CONTINUE
9117  ENDIF
9118  20 CONTINUE
9119 C----------------------------------------------------------------
9120 C
9121  RETURN
9122  5001 FORMAT (i6,i4,5i6,9e10.2)
9123  5003 FORMAT (.GT.' HADRKK JNAUMAX SKIP NEXT PARTICLES ',3i10)
9124  5009 FORMAT (' NHKK,IDHKK(NHKK) ',3i10)
9125  END
9126 C
9127 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
9128 
9129  SUBROUTINE qinnuc(X,Y)
9130 
9131 C Este programa genera una distribucion de partones de tipo gaussiana
9132 C centrada en el centro del hadron. Distribucion: F(b)=A*(-b**2/c).
9133 C La distribucion la generamos en coordenadas polares porque asi
9134 C tenemos primitiva.
9135 C
9136  IMPLICIT DOUBLE PRECISION(a-h,o-z)
9137  SAVE
9138 
9139  CHARACTER*80 title
9140  CHARACTER*8 projty,targty
9141 C COMMON/USER/TITLE,PROJTY,TARGTY,CMENER,ISTRUF
9142 C & ,ISINGD,IDUBLD,SDFRAC,PTLAR
9143  COMMON /user1/title,projty,targty
9144  COMMON /user2/cmener,sdfrac,ptlar,istruf,isingd,idubld
9145 
9146  c=4.*(0.15d-24+0.01d-24*log(cmener))
9147  10 p=rndm(v1)
9148  IF ((p). eq .(1.d0)) THEN
9149  go to 10
9150  END IF
9151  z=rndm(v2)
9152  t=2.*3.1416*z
9153  r=dsqrt(-c*dlog(1.d00-p))
9154  x=r*dcos(t)
9155  y=r*dsin(t)
9156 
9157  RETURN
9158  END
9159 
9160 C
9161 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
9162 C
9163  SUBROUTINE casavs
9164  IMPLICIT DOUBLE PRECISION (a-h,o-z)
9165  SAVE
9166 C
9167 C-------------------------
9168 C
9169 C Casado diquarks VS
9170 C
9171 C ADD GENERATED HADRONS TO /ALLPAR/
9172 C STARTING AT (NAUX + 1)
9173 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
9174 C
9175 C-------------------------
9176 *KEEP,INTMX.
9177  parameter(intmx=2488,intmd=252)
9178 *KEEP,DXQX.
9179 C INCLUDE (XQXQ)
9180 * NOTE: INTMX set via INCLUDE(INTMX)
9181  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
9182  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
9183  * ,xpsu(248),xtsu(248)
9184  * ,xpsut(248),xtsut(248)
9185  common/popcck/pdbck,pdbse,pdbseu,
9186  * ijpock,irejck,ick4,ihad4,ick6,ihad6
9187  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
9188  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
9189  *isea43,isea63,irejao
9190 *KEEP,INTNEW.
9191  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
9192  +ixpv,ixps,ixtv,ixts, intvv1(248),
9193  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
9194  +intss1(intmx),intss2(intmx),
9195  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
9196  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
9197 
9198 C /INTNEW/
9199 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
9200 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
9201 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
9202 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
9203 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
9204 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
9205 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
9206 C FROM PROJECTILE/TARGET NUCLEI
9207 C-------------------
9208 *KEEP,IFROTO.
9209  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
9210  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
9211  +jhkknt
9212  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
9213  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
9214  & mhkkhh(intmx),
9215  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
9216 *KEEP,LOZUO.
9217  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
9218  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
9219  +intlo(intmx),inloss(intmx)
9220 C /LOZUO/
9221 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
9222 C REJECTED IN KKEVT
9223 C------------------
9224 *KEEP,DIQI.
9225  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
9226  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
9227  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
9228  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
9229 *KEEP,HKKEVT.
9230 c INCLUDE (HKKEVT)
9231  parameter(nmxhkk= 89998)
9232 c PARAMETER (NMXHKK=25000)
9233  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
9234  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
9235  +(4,nmxhkk)
9236 C
9237 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
9238 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
9239 C THE POSITIONS OF THE PROJECTILE NUCLEONS
9240 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
9241 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
9242 C COMPLETELY CONSISTENT. THE TIMES IN THE
9243 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
9244 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
9245 C
9246 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
9247 C
9248 C NMXHKK: maximum numbers of entries (partons/particles) that can be
9249 C stored in the commonblock.
9250 C
9251 C NHKK: the actual number of entries stored in current event. These are
9252 C found in the first NHKK positions of the respective arrays below.
9253 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
9254 C entry.
9255 C
9256 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
9257 C = 0 : null entry.
9258 C = 1 : an existing entry, which has not decayed or fragmented.
9259 C This is the main class of entries which represents the
9260 C "final state" given by the generator.
9261 C = 2 : an entry which has decayed or fragmented and therefore
9262 C is not appearing in the final state, but is retained for
9263 C event history information.
9264 C = 3 : a documentation line, defined separately from the event
9265 C history. (incoming reacting
9266 C particles, etc.)
9267 C = 4 - 10 : undefined, but reserved for future standards.
9268 C = 11 - 20 : at the disposal of each model builder for constructs
9269 C specific to his program, but equivalent to a null line in the
9270 C context of any other program. One example is the cone defining
9271 C vector of HERWIG, another cluster or event axes of the JETSET
9272 C analysis routines.
9273 C = 21 - : at the disposal of users, in particular for event tracking
9274 C in the detector.
9275 C
9276 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
9277 C standard.
9278 C
9279 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
9280 C The value is 0 for initial entries.
9281 C
9282 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
9283 C one mother exist, in which case the value 0 is used. In cluster
9284 C fragmentation models, the two mothers would correspond to the q
9285 C and qbar which join to form a cluster. In string fragmentation,
9286 C the two mothers of a particle produced in the fragmentation would
9287 C be the two endpoints of the string (with the range in between
9288 C implied).
9289 C
9290 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
9291 C entry has not decayed, this is 0.
9292 C
9293 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
9294 C entry has not decayed, this is 0. It is assumed that the daughters
9295 C of a particle (or cluster or string) are stored sequentially, so
9296 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
9297 C daughters. Even in cases where only one daughter is defined (e.g.
9298 C K0 -> K0S) both values should be defined, to make for a uniform
9299 C approach in terms of loop constructions.
9300 C
9301 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
9302 C
9303 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
9304 C
9305 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
9306 C
9307 C PHKK(4,IHKK) : energy, in GeV.
9308 C
9309 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
9310 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
9311 C
9312 C VHKK(1,IHKK) : production vertex x position, in mm.
9313 C
9314 C VHKK(2,IHKK) : production vertex y position, in mm.
9315 C
9316 C VHKK(3,IHKK) : production vertex z position, in mm.
9317 C
9318 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
9319 C********************************************************************
9320 *KEEP,ABRVS.
9321  COMMON /abrvs/ amcvs1(248),amcvs2(248),gacvs1(248),gacvs2(248),
9322  +bgxvs1(248),bgyvs1(248),bgzvs1(248), bgxvs2(248),bgyvs2(248),
9323  +bgzvs2(248), nchvs1(248),nchvs2(248),ijcvs1(248),ijcvs2(248),
9324  +pqvsa1(248,4),pqvsa2(248,4), pqvsb1(248,4),pqvsb2(248,4)
9325 *KEEP,DFINPA.
9326  CHARACTER*8 anf
9327  parameter(nfimax=249)
9328  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
9329  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
9330  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
9331  * istath(nfimax)
9332 *KEEP,DPRIN.
9333  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
9334 *KEEP,PROJK.
9335  COMMON /projk/ iprojk
9336 *KEEP,NUCC.
9337  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
9338 *KEND.
9339 C modified DPMJET
9340  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
9341  * anndv,annvd,annds,annsd,
9342  * annhh,annzz,
9343  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
9344  * pthh,ptzz,
9345  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
9346  * eehh,eezz
9347  * ,anndi,ptdi,eedi
9348  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
9349  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
9350  * acouzz,acouhh,acouds,acousd,
9351  * acoudz,acouzd,acoudi,
9352  * acoudv,acouvd,acoucc
9353 C---------------------
9354  COMMON /zsea/zseaav,zseasu,anzsea
9355  COMMON /casadi/casaxx,icasad
9356 C---------------------
9357 C-----------------------------------------------------------------------
9358  DO 50 i=1,nvs
9359 C-----------------------drop recombined chain pairs
9360  IF(nchvs1(i).EQ.99.AND.nchvs2(i).EQ.99) go to 50
9361  is1=intvs1(i)
9362  is2=intvs2(i)
9363 C
9364  IF (ipco.GE.6) WRITE (6,1010) ipvq(is1),ippv1(is1),ippv2(is1),
9365  + itsq(is2),itsaq(is2), amcvs1(i),amcvs2(i),gacvs1(i),gacvs2(i),
9366  + bgxvs1(i),bgyvs1(i),bgzvs1(i), bgxvs2(i),bgyvs2(i),bgzvs2(i),
9367  + nchvs1(i),nchvs2(i),ijcvs1(i),ijcvs2(i), pqvsa1(i,4),pqvsa2
9368  + (i,4),pqvsb1(i,4),pqvsb2(i,4)
9369 C
9370 C
9371 C++++++++++++++++++++++++++++++ CHAIN 2: DIQUARK-QUARK +++++++++++
9372  ifb1=ippv1(is1)
9373  ifb2=ippv2(is1)
9374  ifb3=itsq(is2)
9375 C------------------------------------------------------------------
9376 C check bookkeeping
9377 C-----------------------------------------------------------------
9378 C I= number of valence chain
9379 C Projectile Nr ippp= IFROVP(INTVS1(I))
9380 C No of Glauber sea q at Projectile JIPP=JSSHS(IPP)
9381  ippp = ifrovp(intvs1(i))
9382  jipp=jsshs(ippp)
9383 C------------------------------------------------------------------
9384 C check bookkeeping
9385 C-----------------------------------------------------------------
9386  IF(ipco.GE.1)THEN
9387  WRITE(6,*)' VS qq-q ,IFB1,IFB2,IFB3,',
9388  * 'INTVS1=IS1,INTVS2=IS2,JIPP,JITTX',
9389  * ifb1,ifb2,ifb3,intvs1(i),intvs2(i),jipp,jittx
9390  WRITE (6,*)' target sea quark IFB3=',ifb3,
9391  * ' from IS2=',intvs2(i)
9392  WRITE(6,*)' with ITSQ(IS2),XTSQ(IS2),IFROST(IS2)',
9393  * itsq(is2),xtsq(is2),ifrost(is2)
9394  ENDIF
9395  DO 797 ii=1,ixtv
9396  IF(ifrost(is2).EQ.ifrovt(ii))iii=ii
9397  797 CONTINUE
9398  IF(ipco.GE.1)THEN
9399  WRITE (6,*)' projectile III=',iii
9400  WRITE(6,*)' corresp. XTVQ(i),XTVD(i),ITVQ(I),ITTV1(I),ITTV2(I)',
9401  * xtvq(iii),xtvd(iii),itvq(iii),ittv1(iii),ittv2(iii)
9402  ENDIF
9403 C-------------------------------------------------------------------
9404 C Casado diquark option
9405 C+++++++++++++++++++++++++++++ VS CHAIN 2: DIQUARK-QUARK +++++++++
9406 C-------------------------------------------------------------------
9407  IF(icasad.EQ.1)THEN
9408  IF(rndm(vv).LE.casaxx)THEN
9409  IF(rndm(vvv).LE.0.5d0)THEN
9410  iscasa=itsq(is2)
9411  itvcas=ittv1(iii)
9412  itsq(is2)=itvcas
9413  ittv1(iii)=iscasa
9414  ifb3=itsq(is2)
9415  IF(ipco.GE.1)THEN
9416  WRITE(6,*)' Cas VS2 qq-q 1 ,IFB1,IFB2,IFB3,',
9417  * 'INTVS1=IS1,INTVS2=IS2,III',
9418  * ifb1,ifb2,ifb3,intvs1(i),intvs2(i),iii
9419  * ,'-----------------------------------------------------'
9420  ENDIF
9421  ELSE
9422  iscasa=itsq(is2)
9423  itvcas=ittv2(iii)
9424  itsq(is2)=itvcas
9425  ittv2(iii)=iscasa
9426  ifb3=itsq(is2)
9427  IF(ipco.GE.1)THEN
9428  WRITE(6,*)' Cas VS2 qq-q 2 ,IFB1,IFB2,IFB3,',
9429  * 'INTVS1=IS1,INTVS2=IS2,III',
9430  * ifb1,ifb2,ifb3,intvs1(i),intvs2(i),iii
9431  * ,'-----------------------------------------------------'
9432  ENDIF
9433  ENDIF
9434  ENDIF
9435  ENDIF
9436 C-------------------------------------------------------------------
9437 C Casado diquark option
9438 C-------------------------------------------------------------------
9439  50 CONTINUE
9440 C
9441  RETURN
9442  1010 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
9443  END
9444 C
9445 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
9446 C
9447  SUBROUTINE casasv
9448  IMPLICIT DOUBLE PRECISION (a-h,o-z)
9449  SAVE
9450 C-------------------------
9451 C
9452 C Casado diquarks SV
9453 C
9454 C ADD GENERATED HADRONS TO /ALLPAR/
9455 C STARTING AT (NAUX + 1)
9456 C AND TO /HKKEVT/ STARTING AT (NHKK + 1)
9457 C
9458 C---------------------------------------------------------
9459 *KEEP,INTMX.
9460  parameter(intmx=2488,intmd=252)
9461 *KEEP,DXQX.
9462 C INCLUDE (XQXQ)
9463 * NOTE: INTMX set via INCLUDE(INTMX)
9464  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
9465  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
9466  * ,xpsu(248),xtsu(248)
9467  * ,xpsut(248),xtsut(248)
9468  common/popcck/pdbck,pdbse,pdbseu,
9469  * ijpock,irejck,ick4,ihad4,ick6,ihad6
9470  *,irejse,ise4,ise6,irejs3,ise43,ise63,irejs0
9471  *,ihada4,ihada6,irejsa,isea4,isea6,ireja3,
9472  *isea43,isea63,irejao
9473 *KEEP,INTNEW.
9474  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
9475  +ixpv,ixps,ixtv,ixts, intvv1(248),
9476  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
9477  +intss1(intmx),intss2(intmx),
9478  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
9479  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
9480 
9481 C /INTNEW/
9482 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
9483 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
9484 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
9485 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
9486 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
9487 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
9488 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
9489 C FROM PROJECTILE/TARGET NUCLEI
9490 C-------------------
9491 *KEEP,IFROTO.
9492  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
9493  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
9494  +jhkknt
9495  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
9496  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
9497  & mhkkhh(intmx),
9498  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
9499 *KEEP,LOZUO.
9500  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
9501  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
9502  +intlo(intmx),inloss(intmx)
9503 C /LOZUO/
9504 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
9505 C REJECTED IN KKEVT
9506 C------------------
9507 *KEEP,DIQI.
9508  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
9509  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
9510  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
9511  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
9512 *KEEP,HKKEVT.
9513 c INCLUDE (HKKEVT)
9514  parameter(nmxhkk= 89998)
9515 c PARAMETER (NMXHKK=25000)
9516  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
9517  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
9518  +(4,nmxhkk)
9519 C
9520 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
9521 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
9522 C THE POSITIONS OF THE PROJECTILE NUCLEONS
9523 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
9524 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
9525 C COMPLETELY CONSISTENT. THE TIMES IN THE
9526 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
9527 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
9528 C
9529 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
9530 C
9531 C NMXHKK: maximum numbers of entries (partons/particles) that can be
9532 C stored in the commonblock.
9533 C
9534 C NHKK: the actual number of entries stored in current event. These are
9535 C found in the first NHKK positions of the respective arrays below.
9536 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
9537 C entry.
9538 C
9539 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
9540 C = 0 : null entry.
9541 C = 1 : an existing entry, which has not decayed or fragmented.
9542 C This is the main class of entries which represents the
9543 C "final state" given by the generator.
9544 C = 2 : an entry which has decayed or fragmented and therefore
9545 C is not appearing in the final state, but is retained for
9546 C event history information.
9547 C = 3 : a documentation line, defined separately from the event
9548 C history. (incoming reacting
9549 C particles, etc.)
9550 C = 4 - 10 : undefined, but reserved for future standards.
9551 C = 11 - 20 : at the disposal of each model builder for constructs
9552 C specific to his program, but equivalent to a null line in the
9553 C context of any other program. One example is the cone defining
9554 C vector of HERWIG, another cluster or event axes of the JETSET
9555 C analysis routines.
9556 C = 21 - : at the disposal of users, in particular for event tracking
9557 C in the detector.
9558 C
9559 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
9560 C standard.
9561 C
9562 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
9563 C The value is 0 for initial entries.
9564 C
9565 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
9566 C one mother exist, in which case the value 0 is used. In cluster
9567 C fragmentation models, the two mothers would correspond to the q
9568 C and qbar which join to form a cluster. In string fragmentation,
9569 C the two mothers of a particle produced in the fragmentation would
9570 C be the two endpoints of the string (with the range in between
9571 C implied).
9572 C
9573 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
9574 C entry has not decayed, this is 0.
9575 C
9576 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
9577 C entry has not decayed, this is 0. It is assumed that the daughters
9578 C of a particle (or cluster or string) are stored sequentially, so
9579 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
9580 C daughters. Even in cases where only one daughter is defined (e.g.
9581 C K0 -> K0S) both values should be defined, to make for a uniform
9582 C approach in terms of loop constructions.
9583 C
9584 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
9585 C
9586 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
9587 C
9588 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
9589 C
9590 C PHKK(4,IHKK) : energy, in GeV.
9591 C
9592 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
9593 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
9594 C
9595 C VHKK(1,IHKK) : production vertex x position, in mm.
9596 C
9597 C VHKK(2,IHKK) : production vertex y position, in mm.
9598 C
9599 C VHKK(3,IHKK) : production vertex z position, in mm.
9600 C
9601 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
9602 C********************************************************************
9603 *KEEP,ABRSV.
9604  COMMON /abrsv/ amcsv1(248),amcsv2(248),gacsv1(248),gacsv2(248),
9605  +bgxsv1(248),bgysv1(248),bgzsv1(248), bgxsv2(248),bgysv2(248),
9606  +bgzsv2(248), nchsv1(248),nchsv2(248),ijcsv1(248),ijcsv2(248),
9607  +pqsva1(248,4),pqsva2(248,4), pqsvb1(248,4),pqsvb2(248,4)
9608 *KEEP,DFINPA.
9609  CHARACTER*8 anf
9610  parameter(nfimax=249)
9611  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
9612  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
9613  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
9614  * istath(nfimax)
9615 *KEEP,DPRIN.
9616  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
9617 *KEEP,PROJK.
9618  COMMON /projk/ iprojk
9619 *KEEP,NUCC.
9620  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
9621 *KEND.
9622 C modified DPMJET
9623  COMMON /bufueh/ annvv,annss,annsv,annvs,anncc,
9624  * anndv,annvd,annds,annsd,
9625  * annhh,annzz,
9626  * ptvv,ptss,ptsv,ptvs,ptcc,ptdv,ptvd,ptds,ptsd,
9627  * pthh,ptzz,
9628  * eevv,eess,eesv,eevs,eecc,eedv,eevd,eeds,eesd,
9629  * eehh,eezz
9630  * ,anndi,ptdi,eedi
9631  * ,annzd,anndz,ptzd,ptdz,eezd,eedz
9632  COMMON /ncouch/ acouvv,acouss,acousv,acouvs,
9633  * acouzz,acouhh,acouds,acousd,
9634  * acoudz,acouzd,acoudi,
9635  * acoudv,acouvd,acoucc
9636 C---------------------
9637  COMMON /zsea/zseaav,zseasu,anzsea
9638  COMMON /casadi/casaxx,icasad
9639 C---------------------
9640  DATA ncalsv /0/
9641 C-----------------------------------------------------------------------
9642  ncalsv=ncalsv+1
9643  DO 50 i=1,nsv
9644 C-----------------------drop recombined chain pairs
9645  IF(nchsv1(i).EQ.99.AND.nchsv2(i).EQ.99) go to 50
9646  is1=intsv1(i)
9647  is2=intsv2(i)
9648 C
9649  IF (ipco.GE.6) WRITE (6,1000) ipsq(is1),ipsaq(is1),itvq(is2),
9650  + ittv1(is2),ittv2(is2), amcsv1(i),amcsv2(i),gacsv1(i),gacsv2(i),
9651  + bgxsv1(i),bgysv1(i),bgzsv1(i), bgxsv2(i),bgysv2(i),bgzsv2(i),
9652  + nchsv1(i),nchsv2(i),ijcsv1(i),ijcsv2(i), pqsva1(i,4),pqsva2
9653  + (i,4),pqsvb1(i,4),pqsvb2(i,4)
9654  1000 FORMAT(10x,5i5,10f9.2/10x,4i5,4f12.4)
9655 C
9656 C++++++++++++++++++++++++++++++ CHAIN 1: QUARK-DIQUARK +++++++++++
9657  ifb1=ipsq(is1)
9658  ifb2=ittv1(is2)
9659  ifb3=ittv2(is2)
9660 C------------------------------------------------------------------
9661 C------------------------------------------------------------------
9662 C check bookkeeping
9663 C-----------------------------------------------------------------
9664 C I= number of valence chain
9665 C Target Nr itt = IFROVT(INTSV2(I))
9666 C No of Glauber sea q at Target JITT=JTSHS(ITT)
9667  ittt = ifrovt(intsv2(i))
9668  jitt=jtshs(ittt)
9669 C------------------------------------------------------------------
9670 C check bookkeeping
9671 C-----------------------------------------------------------------
9672  IF(ipco.GE.1)THEN
9673  WRITE(6,*)' SV q-qq ,IFB1,IFB2,IFB3,',
9674  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITT',
9675  * ifb1,ifb2,ifb3,intsv1(i),intsv2(i),jippx,jitt
9676  WRITE (6,*)' projectile sea quark IFB1=',ifb1,
9677  * ' from IS1=',intsv1(i)
9678  WRITE(6,*)' with IPSQ(IS1),XPSQ(IS1),IFROSP(IS1)',
9679  * ipsq(is1),xpsq(is1),ifrosp(is1)
9680  ENDIF
9681  DO 798 ii=1,ixpv
9682  IF(ifrosp(is1).EQ.ifrovp(ii))iii=ii
9683  798 CONTINUE
9684  IF(ipco.GE.1)THEN
9685  WRITE (6,*)' projectile III=',iii
9686  WRITE(6,*)' corresp. XPVQ(i),XPVD(i),IPVQ(I),IPPV1(I),IPPV2(I)',
9687  * xpvq(iii),xpvd(iii),ipvq(iii),ippv1(iii),ippv2(iii)
9688  ENDIF
9689 C-------------------------------------------------------------------
9690 C Casado diquark option
9691 C++++++++++++++++++++++++++++ SV CHAIN 1: QUARK-DIQUARK +++++++++++
9692 C-------------------------------------------------------------------
9693  IF(icasad.EQ.1)THEN
9694  IF(rndm(vv).LE.casaxx)THEN
9695  IF(rndm(vvv).LE.0.5d0)THEN
9696  iscasa=ipsq(is1)
9697  ipvcas=ippv1(iii)
9698  ipsq(is1)=ipvcas
9699  ippv1(iii)=iscasa
9700  ifb1=ipsq(is1)
9701  IF(ipco.GE.1)THEN
9702  WRITE(6,*)' Cas SV1 q-qq 1 ,IFB1,IFB2,IFB3,',
9703  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITT,III',
9704  * ifb1,ifb2,ifb3,intsv1(i),intsv2(i),jippx,jitt,iii
9705  * ,'-----------------------------------------------------'
9706  ENDIF
9707  ELSE
9708  iscasa=ipsq(is1)
9709  ipvcas=ippv2(iii)
9710  ipsq(is1)=ipvcas
9711  ippv2(iii)=iscasa
9712  ifb1=ipsq(is1)
9713  IF(ipco.GE.1)THEN
9714  WRITE(6,*)' Cas SV1 q-qq 2 ,IFB1,IFB2,IFB3,',
9715  * 'INTSV1=IS1,INTSV2=IS2,JIPPX,JITT,III',
9716  * ifb1,ifb2,ifb3,intsv1(i),intsv2(i),jippx,jitt,iii
9717  * ,'-----------------------------------------------------'
9718  ENDIF
9719  ENDIF
9720  ENDIF
9721  ENDIF
9722 C-------------------------------------------------------------------
9723 C Casado diquark option
9724 C-------------------------------------------------------------------
9725  50 CONTINUE
9726 C----------------------------------------------------------------
9727 C
9728  RETURN
9729  END
mpdgha
function mpdgha(MCIND)
Definition: dpm25nulib.f:386
calbam
subroutine calbam(NNCH, I1, I2, IFB11, IFB22, IFB33, IFB44, AMCH, NOBAM, IHAD)
Definition: dpm25nuc7.f:2138
intmx
const int intmx
Definition: G4DPMJET2_5Interface.hh:68
HepGeom::Transform3D::yy
double yy() const
Definition: Transform3D.h:264
xksamp
subroutine xksamp(NN, ECM)
Definition: dpm25nuc3.f:1273
hadrds
subroutine hadrds
Definition: dpm25nuc5.f:3858
hadjse
subroutine hadjse(NHAD, AMCH, PPR, PTA, GAM, BGX, BGY, BGZ, IFB1, IFB2, IFB3, IFB4, I1, I2, NOBAM, NNCH, NORIG, IREJ, IISSQQ)
Definition: dpm25nuc4.f:1479
gm
#define gm
Definition: mymalloc.cc:2499
dbetar
double precision function dbetar(GAM, ETA)
Definition: dpm25nulib.f:289
mcihad
function mcihad(MCIND)
Definition: dpm25nulib.f:364
flksaa
subroutine flksaa(NN, ECM)
Definition: dpm25nuc3.f:922
hadrkk
subroutine hadrkk(NHKKH1, PPN)
Definition: dpm25nuc3.f:3259
dtrans
subroutine dtrans(XO, YO, ZO, CDE, SDE, SFE, CFE, X, Y, Z)
Definition: dpm25nulib.f:510
sltraf
subroutine sltraf(GA, BGA, EIN, PZIN, EOUT, PZOUT)
Definition: dpm25nuc3.f:72
saptre
subroutine saptre(AM1, G1, BGX1, BGY1, BGZ1, AM2, G2, BGX2, BGY2, BGZ2)
Definition: dpm25nuc3.f:1
z
G4double z
Definition: TRTMaterials.hh:39
dtwopd
subroutine dtwopd(UMO, ECM1, ECM2, PCM1, PCM2, COD1, COF1, SIF1, COD2, COF2, SIF2, AM1, AM2)
Definition: dpm25nuc7.f:3326
hadrdz
subroutine hadrdz
Definition: dpm25nuc5.f:6432
nucmom
subroutine nucmom
Definition: dpm25nuc3.f:83
p
const char * p
Definition: xmltok.h:285
dtrafo
subroutine dtrafo(GAM, BGAM, CX, CY, CZ, COD, COF, SIF, P, ECM, PL, CXL, CYL, CZL, EL)
Definition: dpm25nuc3.f:7346
lortmo
subroutine lortmo(N, GAM, BGX, BGY, BGZ)
Definition: dpm25nuc3.f:7420
flksam
subroutine flksam
Definition: dpm25nuc3.f:653
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
flahad
subroutine flahad(ITYP, IBAR, IF1, IF2, IF3)
Definition: dpm25nuc3.f:1194
pyp
function pyp(I, J)
Definition: pythia61.f:38097
a
G4double a
Definition: TRTMaterials.hh:39
dpoli
subroutine dpoli(CS, SI)
Definition: dpm25nulib.f:597
fer4mt
subroutine fer4mt(IT, PFERM, PXT, PYT, PZT, ET, KT)
Definition: dpm25nuc3.f:430
HepGeom::Transform3D::zz
double zz() const
Definition: Transform3D.h:276
sampex
double precision function sampex(X1, X2)
Definition: dpm25nulib.f:1118
HepGeom::Plane3D::d
T d() const
Definition: Plane3D.h:86
nmxhkk
const int nmxhkk
Definition: G4DPMJET2_5Interface.hh:78
selpt
subroutine selpt(PTXSQ1, PTYSQ1, PLQ1, EQ1, PTXSA1, PTYSA1, PLAQ1, EAQ1, PTXSQ2, PTYSQ2, PLQ2, EQ2, PTXSA2, PTYSA2, PLAQ2, EAQ2, AMCH1, AMCH2, IREJ, IKVALA, PTTQ1, PTTA1, PTTQ2, PTTA2, NSELPT)
Definition: dpm25nuc3.f:6620
selpt4
subroutine selpt4(PTXSQ1, PTYSQ1, PLQ1, EQ1, PTXSA1, PTYSA1, PLAQ1, EAQ1, PTXSQ2, PTYSQ2, PLQ2, EQ2, PTXSA2, PTYSA2, PLAQ2, EAQ2, AMCH1, AMCH2, IREJ, IKVALA, PTTQ1, PTTA1, NSELPT)
Definition: dpm25nuc3.f:6435
c2_transformation::one
static float_type one(float_type)
utility function f(x)=1 useful in axis transforms
Definition: c2_function.hh:1201
qinnuc
subroutine qinnuc(X, Y)
Definition: dpm25nuc3.f:9129
parpt
subroutine parpt(IFL, PT1, PT2, IPT, NEVT)
Definition: dpm25nuc1.f:6468
dbeta
double precision function dbeta(X1, X2, BET)
Definition: dpm25nuc7.f:2672
fer4m
subroutine fer4m(PFERM, PXT, PYT, PZT, ET, KT)
Definition: dpm25nuc3.f:320
sewew
subroutine sewew(IOP, NHKKH1)
Definition: dpm25nuc4.f:33
intmd
const int intmd
Definition: G4DPMJET2_5Interface.hh:66
hadrsv
subroutine hadrsv
Definition: dpm25nuc3.f:4279
sttran
subroutine sttran(XO, YO, ZO, CDE, SDE, SFE, CFE, X, Y, Z)
Definition: dpm25nuc3.f:7369
hadrvs
subroutine hadrvs
Definition: dpm25nuc3.f:5230
corval
subroutine corval(AMMM, IREJ, AMCH1, AMCH2, QTX1, QTY1, QZ1, QE1, QTX2, QTY2, QZ2, QE2, NORIG)
Definition: dpm25nuc3.f:8390
hadrsd
subroutine hadrsd
Definition: dpm25nuc5.f:5429
hadrvd
subroutine hadrvd
Definition: dpm25nuc5.f:2382
hadrhh
subroutine hadrhh
Definition: dpm25nuc3.f:8459
hadrss
subroutine hadrss
Definition: dpm25nuc3.f:4727
diqssd
subroutine diqssd(ECM, ITS, IPS, IREJ)
Definition: dpm25nuc5.f:4398
daltra
subroutine daltra(GA, BGX, BGY, BGZ, PCX, PCY, PCZ, EC, P, PX, PY, PZ, E)
Definition: dpm25nulib.f:542
hadjck
subroutine hadjck(NHAD, AMCH, PPR, PTA, GAM, BGX, BGY, BGZ, IFB1, IFB2, IFB3, IFB4, I1, I2, NOBAM, NNCH, NORIG, IREJ)
Definition: dpm25nuc4.f:958
diqdss
subroutine diqdss(ECM, ITS, IPS, IREJ)
Definition: dpm25nuc5.f:2829
diqsv
subroutine diqsv(ECM, ITV, J, IREJ)
Definition: dpm25nuc5.f:1
sampey
double precision function sampey(X1, X2)
Definition: dpm25nulib.f:1107
dechkk
subroutine dechkk(NHKKH1)
Definition: dpm25nuc3.f:6992
samppt
subroutine samppt(MODE, PT)
Definition: dpm25nuc1.f:4387
fer4mp
subroutine fer4mp(IP, PFERM, PXT, PYT, PZT, ET, KT)
Definition: dpm25nuc3.f:373
n
const G4int n
Definition: G4UrQMD1_3Interface.hh:144
rndm
double precision function rndm(RDUMMY)
Definition: dpm25nulib.f:1460
comcm2
subroutine comcm2(IQ1, IQ2, IAQ1, IAQ2, NNCH, IREJ, AMCH)
Definition: dpm25nuc3.f:6218
dsfecf
subroutine dsfecf(SFE, CFE)
Definition: dpm25nuc7.f:3354
dfermi
subroutine dfermi(GPART)
Definition: dpm25nulib.f:609
title
subroutine title(NA, NB, NCA, NCB)
Definition: dpm25nuc7.f:1744
evtest
subroutine evtest(IREJ)
Definition: dpm25nuc3.f:7496
c2_factory::log
static c2_log_p< float_type > & log()
make a *new object
Definition: c2_factory.hh:138
CLHEP::HepLorentzVector::et
double et() const
betrej
double precision function betrej(GAM, ETA, XMIN, XMAX)
Definition: dpm25nulib.f:344
cobcma
subroutine cobcma(IF1, IF2, IF3, IJNCH, NNCH, IREJ, AMCH, AMCHN, IKET)
Definition: dpm25nuc3.f:6049
casavs
subroutine casavs
Definition: dpm25nuc3.f:9163
hadrdv
subroutine hadrdv
Definition: dpm25nuc5.f:971
dfatpr
subroutine dfatpr(IP, PABS)
Definition: dpm25nuc3.f:571
casasv
subroutine casasv
Definition: dpm25nuc3.f:9447
G4Abla::tau
G4double tau(G4double bet, G4double homega, G4double ef, G4double t)
Definition: G4Abla.cc:2586
HepGeom::Transform3D::xx
double xx() const
Definition: Transform3D.h:252
c2_factory::sqrt
static c2_sqrt_p< float_type > & sqrt()
make a *new object
Definition: c2_factory.hh:142
hadrzz
subroutine hadrzz
Definition: dpm25nuc3.f:8798
hkkfil
subroutine hkkfil(IST, ID, M1, M2, PX, PY, PZ, E, NHKKAU, KORMO, ICALL)
Definition: dpm25nuc1.f:6509
parhkk
subroutine parhkk
Definition: dpm25nuc3.f:2859
comcma
subroutine comcma(IFQ, IFAQ, IJNCH, NNCH, IREJ, AMCH, AMCHN)
Definition: dpm25nuc3.f:6135
lortrp
subroutine lortrp(N, NAUX, GAM, BGX, BGY, BGZ)
Definition: dpm25nuc3.f:5983
hadrvv
subroutine hadrvv
Definition: dpm25nuc3.f:3726
print
void print(const std::vector< T > &data)
Definition: DicomRun.hh:111
dthrep
subroutine dthrep(UMO, ECM1, ECM2, ECM3, PCM1, PCM2, PCM3, COD1, COF1, SIF1, COD2, COF2, SIF2, COD3, COF3, SIF3, AM1, AM2, AM3)
Definition: dpm25nuc7.f:2748
hadrzd
subroutine hadrzd
Definition: dpm25nuc5.f:7422
sampxb
double precision function sampxb(X1, X2, B)
Definition: dpm25nulib.f:1133
dbklas
subroutine dbklas(I, J, K, I8, I10)
Definition: dpm25nuc7.f:6096
dfatta
subroutine dfatta(IT, PABS)
Definition: dpm25nuc3.f:489
hadjet
subroutine hadjet(NHAD, AMCH, PPR, PTA, GAM, BGX, BGY, BGZ, IFB1, IFB2, IFB3, IFB4, I1, I2, NOBAM, NNCH, NORIG)
Definition: dpm25nuc3.f:5651
c2_factory::exp
static c2_exp_p< float_type > & exp()
make a *new object
Definition: c2_factory.hh:140
Generated on Wed Apr 30 2014 15:54:31 for Geant4.10 by   doxygen 1.8.7