Geant4_10
dpm25nuc2.f
Go to the documentation of this file.
1 C----------------------------------------------------------------------
2 C
3 C FILE DPMNUC2.FOR
4 C
5 C----------------------------------------------------------------------
6 *
7  SUBROUTINE primpt(MPO,ECM)
8 C
9 C SELECT PRIMORDIAL PT FOR HARD SCATTERED PARTONS
10 C
11  IMPLICIT DOUBLE PRECISION(a-h,o-z)
12  SAVE
13  parameter(msh=250)
14  COMMON /abrhrd/xh1(msh),xh2(msh),ijhi1(msh),ijhi2(msh),
15  *ijhf1(msh),ijhf2(msh),phard1(msh,4),phard2(msh,4)
16  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
17  b33=4.0+3.0/log10(ecm+10.d0)
18  DO 20 i=1,mpo
19  es=-2./(b33**2)*log(rndm(v)*rndm(u))
20  hps=sqrt(es*es+2.*es*0.94)
21  CALL dsfecf(sfe,cfe)
22  ptxsq1=hps*cfe
23  ptysq1=hps*sfe
24  ptxsa1=-ptxsq1
25  ptysa1=-ptysq1
26  IF (iouxev.GE.6)WRITE(6,115)ptxsq1,ptysq1,ptxsa1,ptysa1
27  115 FORMAT (' PT S ',8f12.6)
28  phard1(i,1)=phard1(i,1)+ptxsq1
29  phard1(i,2)=phard1(i,2)+ptysq1
30  phard2(i,1)=phard2(i,1)+ptxsa1
31  phard2(i,2)=phard2(i,2)+ptysa1
32  de1=sqrt(phard1(i,1)**2+phard1(i,2)**2+phard1(i,3)**2)
33  * -phard1(i,4)
34  de2=sqrt(phard2(i,1)**2+phard2(i,2)**2+phard2(i,3)**2)
35  * -phard2(i,4)
36  phard1(i,4)=phard1(i,4)+de1
37  phard2(i,4)=phard2(i,4)+de2
38  dx1=2.*de1/ecm
39  dx2=2.*de2/ecm
40  xh1(i)=xh1(i)+dx1
41  xh2(i)=xh2(i)+dx2
42  20 CONTINUE
43  RETURN
44  END
45 
46 C______________________________________________________________________
47 C
48 C****************************************************************8**
49  SUBROUTINE selpth(PQUAR,PAQUAR,TQUAR,TAQUAR,ECM,
50  * ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1,
51  * ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
52  * amch1,amch2,irej,ikvala,pttq1,ptta1,pttq2,ptta2)
53 C SELECT PT VALUES FOR A TWO CHAIN SYSTEM
54 C SELECT SEA QUARK AND ANTIQUARK PT-VALUES
55  IMPLICIT DOUBLE PRECISION(a-h,o-z)
56  SAVE
57  dimension pquar(4),tquar(4),paquar(4),taquar(4)
58  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
59  b33=1.55
60  b33=4.0+3.0/log10(ecm+10.d0)
61  IF (ikvala.EQ.1)b33=8.0
62  icount=0
63  irej=0
64  1 CONTINUE
65  b33=2.*b33
66  icount=icount+1
67  IF (icount.EQ.4)THEN
68  irej=1
69 C REJECT EVENT
70  RETURN
71  ENDIF
72  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+1.e-18)
73  hps=sqrt(es*es+2.*es*0.94)
74  CALL dsfecf(sfe,cfe)
75  ptxsq1=hps*cfe+pquar(1)
76  ptysq1=hps*sfe+pquar(2)
77  ptxsa1=-ptxsq1+paquar(1)
78  ptysa1=-ptysq1+paquar(2)
79  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+1.e-18)
80  hps=sqrt(es*es+2.*es*0.94)
81  CALL dsfecf(sfe,cfe)
82  ptxsq2=hps*cfe+tquar(1)
83  ptysq2=hps*sfe+tquar(2)
84  ptxsa2=-ptxsq2+taquar(1)
85  ptysa2=-ptysq2+taquar(2)
86  IF (iouxev.GE.6)WRITE(6,115)ptxsq1,ptysq1,ptxsa1,ptysa1
87  * ,ptxsq2,ptysq2,ptxsa2,ptysa2
88  115 FORMAT (' PT S ',8f12.6)
89 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
90  pttq1=ptxsq1**2+ptysq1**2
91  ptta1=ptxsa1**2+ptysa1**2
92  pttq2=ptxsq2**2+ptysq2**2
93  ptta2=ptxsa2**2+ptysa2**2
94  eq1=pquar(4)
95  eaq1=paquar(4)
96  eq2=tquar(4)
97  eaq2=taquar(4)
98  IF((eq1**2.LE.pttq1).OR.(eq2**2.LE.pttq2)
99  * .OR.(eaq1**2.LE.ptta1).OR.(eaq2**2.LE.ptta2))THEN
100  go to 1
101  ENDIF
102  plq1=sqrt(eq1**2-pttq1+1.e-6)*pquar(3)/abs(pquar(3))
103  plq2=sqrt(eq2**2-pttq2+1.e-6)*tquar(3)/abs(tquar(3))
104  plaq1=sqrt(eaq1**2-ptta1+1.e-6)*paquar(3)/abs(paquar(3))
105  plaq2=sqrt(eaq2**2-ptta2+1.e-6)*taquar(3)/abs(taquar(3))
106 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
107  amch1=sqrt((eq1+eaq2)**2-(ptxsq1+ptxsa2)**2
108  * -(ptysq1+ptysa2)**2-(plq1+plaq2)**2)
109  amch2=sqrt((eq2+eaq1)**2-(ptxsq2+ptxsa1)**2
110  * -(ptysq2+ptysa1)**2-(plq2+plaq1)**2)
111  RETURN
112  END
113 C
114 C****************************************************************8**
115  SUBROUTINE xptfl(NHARD,NSEA,IREG,XMAX1,XMAX2)
116 C PARTON LEVEL COLLISION EVENTS (X,PT FLAVOR)
117 C THE ROUTINE XPTFL CALLS ONE EVENT (in DTUJET)
118 C in DTUNUC, DPMJET it calls the multiple soft and hard chains
119 C in one elementary collision
120 C
121 C IJPROJ,IJTAR: PROJECTILE AND TARGET PARTICLE OF THE REACTION
122 C 1=PROTON, 2=ANTIPROTON
123 C IJPVAL,IJTVAL =0 VALENCE QUARKS OF PROJECTILE OR TARGET NOT INVOLVED
124 C IN HARD SCATTERING
125 C IJPVAL,IJTVAL =1 VALENCE QUARKS OF PROJECTILE OR TARGET INVOLVED
126 C IN HARD SCATTERING
127 C
128 C PARTEV VERSIONS CONTROLLED BY NVERS
129 C NVERS=1: ALL HARD PARTONS CONSIDERED TO BE GLUONS
130 C soft x values by rejection
131 C NVERS=2: ALL HARD PARTONS CONSIDERED TO BE GLUONS
132 C soft x values by P.Aurenche P.Maire method
133 C
134 C THE RESULTS (HARD SCATTERING) ARE IN COMMON /ABRHRD/
135 C XH1(I),XH2(I): X-VALUES OF INITIAL PARTONS
136 C IJHI1(I),IJHI2(I): FLAVOR OF INITIAL PARTON
137 C 0 GLUON
138 C 1,2 VALENCE U,D QUARKS
139 C 11,12,13,14 SEA UDSC-QUARKS
140 C NEGATIVE ANTI S OR V QUARKS
141 C IJHF1(I),IJHF2(I): FLAVOR OF FINAL STATE PARTONS
142 C PHARD1(I,J),PHARD2(I,J): FINAL PART. MOMENTUM AND ENERGY
143 C J=1 PX
144 C =2 PY
145 C =3 PZ
146 C =4 ENERGY (MASSLESS PARTONS)
147  IMPLICIT DOUBLE PRECISION(a-h,o-z)
148  SAVE
149  parameter( one=1.d0,oneh=.5d0, zero=0.d0)
150  parameter(ummm=0.3d0)
151  parameter(smmm=0.5d0)
152  parameter(cmmm=1.3d0)
153  parameter(msh=250)
154  COMMON /abrhrd/xh1(msh),xh2(msh),ijhi1(msh),ijhi2(msh),
155  *ijhf1(msh),ijhf2(msh),phard1(msh,4),phard2(msh,4)
156  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
157  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
158 c addded as needed:
159  COMMON /singdi/silmsd,sigdi
160 C repl:COMMON/DIFFRA/ISINGD,IDUBLD,SDFRAC
161 C repl:COMMON /COLLIS/ECM,S,IJPROJ,IJTAR,PTTHR,IOPHRD,IJPRLU,IJTALU,PTTHR2
162 C COMMON /COLLIS/S,IJPROJ,IJTAR,PTTHR,IOPHRD,IJPRLU,IJTALU,PTTHR2
163  common/collis/s,ijproj,ijtar,ptthr,ptthr2,iophrd,ijprlu,ijtalu
164  CHARACTER*80 title
165  CHARACTER*8 projty,targty
166 C COMMON /USER/TITLE,PROJTY,TARGTY,CMENER,ISTRUF
167 C & ,ISINGD,IDUBLD,SDFRAC,PTLAR
168  COMMON /user1/title,projty,targty
169  COMMON /user2/cmener,sdfrac,ptlar,istruf,isingd,idubld
170 *
171  COMMON /colle/ nevhad,nvers,ihadrz,nfile
172  COMMON /pomtyp/ipim,icon,isig,lmax,mmax,nmax,defel,difnu
173  common/ipimm/ipimo
174 C-------------------------------------------------------------
175 
176  parameter(intmx=2488)
177  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
178  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
179  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
180  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
181  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
182  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
183  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
184  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
185  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
186  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
187  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
188  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
189  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
190  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
191  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
192  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
193  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
194  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
195 C-------------------------------------------------------------
196 C COMMON /SVSWAP/ISVSWP,ISVSWT,JSVSWP,JSVSWT,XPSVSW,XTSVSW
197  COMMON /valhvg/phpval(4),phtval(4),ijvgp,ijvgt,ivalhp,ivalht
198  COMMON /ptlarg/ xsmax
199  COMMON /gluspl/nugluu,nsgluu
200  COMMON /seasu3/seasq
201  common/vvdiff/nvalch,nvaldi,nsofvd,idiftp,amchdd,nvadud
202  common/intnez/ndz,nzd
203 C
204 C THE COMMON BLOCK /PART/ DEFINES THE PARTICLE PROPERTIES AS USED IN
205 C BAMJET AND DECAY
206 *KEEP,DPAR.
207 C /DPAR/ CONTAINS PARTICLE PROPERTIES
208 C ANAME = LITERAL NAME OF THE PARTICLE
209 C AAM = PARTICLE MASS IN GEV
210 C GA = DECAY WIDTH
211 C TAU = LIFE TIME OF INSTABLE PARTICLES
212 C IICH = ELECTRIC CHARGE OF THE PARTICLE
213 C IIBAR = BARYON NUMBER
214 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
215 C
216  CHARACTER*8 aname
217  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
218  +iibar(210),k1(210),k2(210)
219 C------------------
220 C THE COMMON BLOCK /INPDAT/ DEFINES QUANTITIES NEEDED IN THE BAMJET
221 C CHAIN DECAY CODE
222 *KEEP,DINPDA.
223  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
224  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
225  COMMON /lmmaxi/ lmmax
226  parameter(nstrmx=50)
227  common/skine1/ngluef,nnn,gl(nstrmx),gr(nstrmx),vl,vr,wl,wr,
228  * ptgl(2,nstrmx),ptvl(2),ptwl(2),
229  * ptgr(2,nstrmx),ptvr(2),ptwr(2)
230  COMMON /dropjj/dropjt,dropva
231 C COMMON /XYTES/XTEST(50),XYTEST(0:11,50)
232  DATA ncmpo/0/
233  DATA inicha/0/
234 C COMMON /OUTLEV/IOUTPO,IOUTPA,IOUXEV,IOUCOL
235  IF(xmax1.LE.0.d0.OR.xmax2.LE.0.d0)THEN
236  WRITE(6,'(A,3I5,2F10.4)')' XPTFL(',nhard,nsea,ireg,xmax1,xmax2
237  nhard=0
238  nsea=0
239  ireg=0
240  RETURN
241  ENDIF
242  ijpval=0
243  ijtval=0
244  nonuj1=nonujt+1
245  nonus1=nonust+1
246  ireg=0
247  iouxev=ipev
248  ioutpa=ippa
249  ioptpo=ipri
250  ioucol=ipco
251 C NDZ=0
252 C NZD=0
253 C to keep identical commons
254  ecm=cmener
255 C----------------------------------------------------------------------
256 C----------------------------------------------------------------------
257 C----------------------------------------------------------------------
258 C Initialize Charm selection at hard chain ends
259 C
260  IF(inicha.EQ.0)THEN
261  inicha=1
262  pccc=0.333*(ummm/(cmmm*log(cmmm/0.2)))**2
263  WRITE(6,4567)pccc
264  4567 FORMAT(' Charm at hard chain ends XPTFL: PCCC ',1f10.5)
265  ENDIF
266 C
267 C----------------------------------------------------------------------
268 *
269  zxc=5000.
270 C CALL NSOFT-NHARD EVENT
271  nhard=0
272  nsea=0
273  nval=0
274  IF (iouxev.GE.6)WRITE (6,107)iouxev,nhard,nsea,nval,nvers
275  107 FORMAT (' XPTFL IOUXEV,NHARD,NSEA,NVAL,NVERS = ',6i10)
276  nc1000=0
277  1000 CONTINUE
278  dropva=0.
279  nc1000=nc1000+1
280  IF (iouxev.GE.1.AND.mod(nc1000,20).EQ.0)WRITE(6,1100)nc1000
281  1100 FORMAT(' REJECTION IN XPTFL ',i10)
282  nnpo=0
283  IF (ipim.NE.2)THEN
284  CALL samplm(lpo,mpo,npo)
285  npolo=0
286  npodd=0
287  ELSEIF(ipim.EQ.2)THEN
288  IF (iouxev.GE.6)WRITE(6,'(A)')' XPTFL call SAMPLX'
289 
290  CALL samplx(lpo,mpo,npo,npodd,npolo)
291  ncmpo=ncmpo+mpo
292 C WRITE(6,*) ' NCMPO,MPO', NCMPO,MPO
293  ENDIF
294 C EACH HARD SCATTERING ALSO GETS SOFT COLOR MIXUP
295  lpo = lpo + mpo
296  IF (iouxev.GE.6)WRITE(6,107)iouxev,nhard,nsea,nval,nvers
297  nhard=mpo
298  IF (iouxev.GE.1)WRITE(6,101)lpo,mpo,npo ,nnpo
299  101 FORMAT (' XPTFL SAMPLM-LPO,MPO,NPO,NNPO= ',4i10
300  * /' NEXT CALL SELHRD')
301 C CALL HARD PARTON EVENT
302  nax12=0
303  2628 CONTINUE
304  hax1=0.
305  haxx1=0.
306  hax2=0.
307  haxx2=0.
308  7717 CONTINUE
309  IF(mpo.GE.1)THEN
310  IF (iouxev.GE.6)WRITE(6,'(A)')' XPTFL call SELHRD'
311  CALL selhrd(mpo,ijpval,ijtval,ptthr2)
312  nhard = mpo
313  7727 CONTINUE
314  IF (iouxev.GE.6)WRITE (6,107)iouxev,nhard,nsea,nval,nvers
315  DO 10 i=1,mpo
316  hax1=hax1+xh1(i)
317  hax2=hax2+xh2(i)
318  IF(iouxev.GE.1.AND.xh1(i).LT.0 )WRITE(6,7788) i,xh1(i)
319  IF(iouxev.GE.1.AND.xh2(i).LT.0 )WRITE(6,7787) i,xh2(i)
320  7788 FORMAT(' XPTFL: XH1(',i5,') =',e12.5)
321  7787 FORMAT(' XPTFL: XH2(',i5,') =',e12.5)
322  10 CONTINUE
323  ENDIF
324  soxm=0.
325  sox1=xmax1-hax1
326  sox2=xmax2-hax2
327  IF (sox1.LT.soxm .OR. sox2.LT.soxm)THEN
328  IF (ioutpa.GE.1)WRITE (6,2510)hax1,hax2,xmax1,xmax2,mpo
329  2510 FORMAT(.GT.' REJECT HAX1,HAX21 HAX1,HAX2,XMAX1,XMAX2MPO='
330  * ,4f10.3,i10)
331  nax12=nax12+1
332  IF(mod(nax12,2).EQ.0)THEN
333  go to 1000
334  ELSE
335  go to 2628
336  ENDIF
337  ENDIF
338  nc1002=0
339  go to 1002
340  1001 CONTINUE
341 C NDZ=0
342 C NZD=0
343  IF (lpo.GT.1) THEN
344  IF(mod(nc1002,6).EQ.0) THEN
345  lpo=lpo-1
346  ELSEIF( nc1002.GT.50 ) THEN
347  IF(iouxev.GE.3)WRITE(6,9874) mpo
348  9874 FORMAT(' XPTFL: 1001 SOFT X REJECTION TO 1000, MPO=',i5)
349  go to 1000
350  ENDIF
351  nc1002=nc1002 + 1
352  ENDIF
353  1002 CONTINUE
354  soxus1=0
355  soxus2=0
356  IF (iouxev.GE.3)WRITE (6,105)soxus1,soxus2,sox1,sox2,hax1,hax2
357  105 FORMAT('XPTFL SOXUS1,SOXUS2,SOX1,SOX2,HAX1,HAX2 ',6f10.6)
358  nhard=mpo
359  lpasof=0
360  IF (lpo.GT.1)THEN
361  IF (nvers.EQ.1) THEN
362  unoglu=5.
363  unoval=2.
364  IF (iouxev.GE.6)WRITE(6,*)' XPTFL call XPTFL1,NSEA,NVAL',nsea,nval
365  CALL xptfl1(nhard,nsea,nval,soxus1,soxus2,sox1,sox2,hax1,hax2,
366  * lpo,mpo,npo,lpasof,ijpval,ijtval,rj1000,xmax1,xmax2)
367  IF (rj1000.EQ.1.d0) THEN
368  IF (iouxev.GE.6) THEN
369  WRITE(6,*)'REJECTION TO 1001 AFTER XPTFL1 RJ1000=',rj1000
370  ENDIF
371 C IREG=1
372 C RETURN
373  go to 1001
374  ENDIF
375  ENDIF
376  ENDIF
377  2020 CONTINUE
378 C
379  nsea=lpasof
380  IF (iouxev.GE.3)THEN
381  WRITE (6,1303)nsea
382  1303 FORMAT (' XPTFL (after xptfl1/2): NSEA=',i10,
383  *'ii,ijsq1,ijsaq1,ijsq2,ijsaq2,amcch1,amcch2,...')
384  DO 305 ii=1,nsea
385  WRITE(6,304)ii,
386  * ijsq1(ii),ijsaq1(ii),ijsq2(ii),ijsaq2(ii),
387  * amcch1(ii),amcch2(ii),gamch1(ii),gamch2(ii),
388  * bgxch1(ii),bgych1(ii),bgzch1(ii),
389  * bgxch2(ii),bgych2(ii),bgzch2(ii),
390  * nch1(ii),nch2(ii),ijch1(ii),ijch2(ii),
391  * (psofa1(ii,ju),psofa2(ii,ju),psofb1(ii,ju),
392  * psofb2(ii,ju),ju=1,4)
393  304 FORMAT(5i4,6e18.8/4e18.8,4i4,2e18.8/7e18.8/7e18.8)
394  305 CONTINUE
395  ENDIF
396 C
397 C END LOOP OVER SOFT SEA-SEA CHAINS--------------------------------
398 C
399 C X-VALUES REMAINING FOR VALENCE CHAINS
400 C
401  soxva2=sox2-soxus2
402  soxva1=sox1-soxus1
403  IF(soxva1.LT.0.0d0.OR.soxva2.LT.0.0d0) THEN
404  IF(iouxev.GE.6) THEN
405  WRITE(6,*) ' XPTFL: REJECTION TO 1001 DUE TO SOXVA1/2 < 0.1'
406  * ,soxva1,soxva2
407  ENDIF
408  goto 1001
409  ENDIF
410 C
411 C PARTEV VERSIONS
412 C
413  IF ((nvers.EQ.1.OR.nvers.EQ.2).AND.mpo.GE.1) THEN
414 C PARTEV VERSION 1 : ALL HARD PARTONS CONSIDERED TO BE GLUONS
415 C IN AP-P ALSO VALENCE GLUON SCATTERING TREATED
416 C CHAINS FRAGMENTING:
417 C -SOFT VALENCE CHAINS
418 C -SOFT SEA CHAINS
419 C -SPLIT EACHHARD GLUON INTO Q-AQ PAIR
420 C -GLUON-GLUON BECOMES TWO Q-AQ CHAINS
421 C
422  i=0
423  nonujy=nonujt+1
424  DO 301 ixnujt=1,mpo
425  i=i+1
426  nonujt=nonujt+1
427 C FIRST SPLIT GLUON MOMENTUM
428  ic302=0
429  302 CONTINUE
430  ic302=ic302+1
431  IF (iouxev.GE.3.AND.mod(ic302,12).EQ.0)WRITE(6,1302)ic302
432  1302 FORMAT(' REJECTION IN XPTFL 302 HARD GLUON SPLIT ',i10)
433 C REJECT TOTAL EVENT FOR IC302=12
434  IF (ic302.EQ.12) go to 1001
435  xxxg1=(rndm(v))**0.50
436  xxxg2=(rndm(u))**0.50
437  IF (nugluu.EQ.1) THEN
438  xxxg1=0.999999999999d0
439  xxxg2=0.000000000001d0
440  ENDIF
441  xjq1(nonujt)=xh1(i)
442  xjq2(nonujt)=xh2(i)
443  DO 303 j=1,3
444  pjeta1(nonujt,j)=phard1(i,j)*xxxg1
445  pjetb1(nonujt,j)=phard2(i,j)*xxxg2
446  pjeta2(nonujt,j)=phard2(i,j)*(1.-xxxg2)
447  pjetb2(nonujt,j)=phard1(i,j)*(1.-xxxg1)
448  303 CONTINUE
449  pjeta1(nonujt,4)=sqrt(pjeta1(nonujt,1)**2+
450  * pjeta1(nonujt,2)**2
451  * +pjeta1(nonujt,3)**2)
452  pjetb1(nonujt,4)=sqrt(pjetb1(nonujt,1)**2+
453  * pjetb1(nonujt,2)**2
454  * +pjetb1(nonujt,3)**2)
455  pjeta2(nonujt,4)=sqrt(pjeta2(nonujt,1)**2+
456  * pjeta2(nonujt,2)**2
457  * +pjeta2(nonujt,3)**2)
458  pjetb2(nonujt,4)=sqrt(pjetb2(nonujt,1)**2+
459  * pjetb2(nonujt,2)**2
460  * +pjetb2(nonujt,3)**2)
461 C MASSES OF SUBCHAINS
462  amjch1(nonujt)=sqrt((pjeta1(nonujt,4)+
463  * pjeta2(nonujt,4))**2
464  * -(pjeta1(nonujt,1)+
465  * pjeta2(nonujt,1))**2
466  * -(pjeta1(nonujt,2)+
467  * pjeta2(nonujt,2))**2
468  * -(pjeta1(nonujt,3)+
469  * pjeta2(nonujt,3))**2)
470  amjch2(nonujt)=sqrt((pjetb1(nonujt,4)+
471  * pjetb2(nonujt,4))**2
472  * -(pjetb1(nonujt,1)+
473  * pjetb2(nonujt,1))**2
474  * -(pjetb1(nonujt,2)+
475  * pjetb2(nonujt,2))**2
476  * -(pjetb1(nonujt,3)+
477  * pjetb2(nonujt,3))**2)
478 C FLAVORS OF QUARKS
479  ai=i
480  bi=i+i
481  ipjq1=1.d0+rndm(qa1)*(2.d0+seasq)
482  IF(rndm(v3).LT.pccc)ipjq1=4
483  ipjaq1=-ipjq1
484  ipjq2=1.d0+rndm(qb1)*(2.d0+seasq)
485  IF(rndm(v4).LT.pccc)ipjq2=4
486  ipjaq2=-ipjq2
487  IF (iouxev.GE.6)WRITE (6,113)ipjq1,ipjq2
488  113 FORMAT(' IPJQ1,IPJQ2 ',2i10)
489 C REJECT SPLITTING FOR SMALL CHAIN MASSE
490  ifps1=imps(ipjq2,ipjq1)
491  ifv1=imve(ipjq2,ipjq1)
492  amps1=aam(ifps1)
493  amv1=aam(ifv1)
494  amff1=amv1+0.3
495 C
496  ifps2=imps(ipjq1,ipjq2)
497  ifv2=imve(ipjq1,ipjq2)
498  amps2=aam(ifps2)
499  amv2=aam(ifv2)
500  amff2=amv2+0.3
501 C
502  IF(nugluu.EQ.0.AND.
503  * ((amjch1(nonujt).LE.amff1).OR.
504  * (amjch2(nonujt).LE.amff2))) go to 302
505 C
506  gamjh1(nonujt)=(pjeta1(nonujt,4)+
507  * pjeta2(nonujt,4))/amjch1(nonujt)
508  bgxjh1(nonujt)=(pjeta1(nonujt,1)+
509  * pjeta2(nonujt,1))/amjch1(nonujt)
510  bgyjh1(nonujt)=(pjeta1(nonujt,2)+
511  * pjeta2(nonujt,2))/amjch1(nonujt)
512  bgzjh1(nonujt)=(pjeta1(nonujt,3)+
513  * pjeta2(nonujt,3))/amjch1(nonujt)
514  gamjh2(nonujt)=(pjetb1(nonujt,4)+
515  * pjetb2(nonujt,4))/amjch2(nonujt)
516  bgxjh2(nonujt)=(pjetb1(nonujt,1)+
517  * pjetb2(nonujt,1))/amjch2(nonujt)
518  bgyjh2(nonujt)=(pjetb1(nonujt,2)+
519  * pjetb2(nonujt,2))/amjch2(nonujt)
520  bgzjh2(nonujt)=(pjetb1(nonujt,3)+
521  * pjetb2(nonujt,3))/amjch2(nonujt)
522  ijjq1(nonujt)=ipjq1
523  ijjaq1(nonujt)=ipjaq1
524  ijjq2(nonujt)=ipjq2
525 C CHange r.e.21.4.94 flavor conservation
526 C IJJAQ2(NONUJT)=IPJAQ2
527  ijjaq2(nonujt)=-ipjq1
528  301 CONTINUE
529  403 FORMAT (i10)
530  DO 405 ii=nonujy,nonujt
531  IF (ioutpa.GE.3)
532  * WRITE(6,404)ii,
533  * ijjq1(ii),ijjaq1(ii),ijjq2(ii),ijjaq2(ii),
534  * amjch1(ii),amjch2(ii),gamjh1(ii),gamjh2(ii),
535  * bgxjh1(ii),bgyjh1(ii),bgzjh1(ii),
536  * bgxjh2(ii),bgyjh2(ii),bgzjh2(ii),
537  * (pjeta1(ii,ju),pjeta2(ii,ju),pjetb1(ii,ju),
538  * pjetb2(ii,ju),ju=1,4)
539  404 FORMAT(5i4,6e18.8/4e18.8,2e18.8/7e18.8/7e18.8)
540  405 CONTINUE
541  ENDIF
542  IF (iouxev.GE.6)WRITE (6,107)iouxev,nhard,nsea,nval,nvers
543  RETURN
544  END
545 C-----------------------------------------------------------------
546 C-----------------------------------------------------------------
547 C-----------------------------------------------------------------
548  SUBROUTINE xptfl1(NHARD,NSEA,NVAL,SOXUS1,SOXUS2,SOX1,SOX2,HAX1,
549  * hax2,lpo,mpo,npo,lpasof,ijpval,ijtval,rj1000,xmax1,xmax2)
550 C PARTON LEVEL COLLISION EVENTS (X,PT FLAVOR)
551 C THE ROUTINE XPTFL CALLS ONE EVENT
552 C
553 C IJPROJ,IJTAR: PROJECTILE AND TARGET PARTICLE OF THE REACTION
554 C 1=PROTON, 2=ANTIPROTON
555 C IJPVAL,IJTVAL =0 VALENCE QUARKS OF PROJECTILE OR TARGET NOT INVOLVED
556 C IN HARD SCATTERING
557 C IJPVAL,IJTVAL =1 VALENCE QUARKS OF PROJECTILE OR TARGET INVOLVED
558 C IN HARD SCATTERING
559 C
560 C PARTEV VERSIONS CONTROLLED BY NVERS
561 C NVERS=1: ALL HARD PARTONS CONSIDERED TO BE GLUONS
562 C soft x values by rejection
563 C NVERS=2: ALL HARD PARTONS CONSIDERED TO BE GLUONS
564 C soft x values by P.Aurenche P.Maire method
565 C
566 C THE RESULTS (HARD SCATTERING) ARE IN COMMON /ABRHRD/
567 C XH1(I),XH2(I): X-VALUES OF INITIAL PARTONS
568 C IJHI1(I),IJHI2(I): FLAVOR OF INITIAL PARTON
569 C 0 GLUON
570 C 1,2 VALENCE U,D QUARKS
571 C 11,12,13,14 SEA UDSC-QUARKS
572 C NEGATIVE ANTI S OR V QUARKS
573 C IJHF1(I),IJHF2(I): FLAVOR OF FINAL STATE PARTONS
574 C PHARD1(I,J),PHARD2(I,J): FINAL PART. MOMENTUM AND ENERGY
575 C J=1 PX
576 C =2 PY
577 C =3 PZ
578 C =4 ENERGY (MASSLESS PARTONS)
579  IMPLICIT DOUBLE PRECISION(a-h,o-z)
580  SAVE
581  parameter( one=1.d0,oneh=.5d0, zero=0.d0)
582  parameter(ummm=0.3d0)
583  parameter(smmm=0.5d0)
584  parameter(cmmm=1.3d0)
585  parameter(msh=250)
586  parameter(intmd=252)
587 *KEEP,NUCC.
588  COMMON /nucc/ it,itz,ip,ipz,mjproj,ibproj,ijtarg,ibtarg
589  COMMON /abrhrd/xh1(msh),xh2(msh),ijhi1(msh),ijhi2(msh),
590  *ijhf1(msh),ijhf2(msh),phard1(msh,4),phard2(msh,4)
591  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
592  common/intnez/ndz,nzd
593 C repl:COMMON /COLLIS/ECM,S,IJPROJ,IJTAR,PTTHR,IOPHRD,IJPRLU,IJTALU,PTTHR2
594 C COMMON /COLLIS/S,IJPROJ,IJTAR,PTTHR,IOPHRD,IJPRLU,IJTALU,PTTHR2
595  common/collis/s,ijproj,ijtar,ptthr,ptthr2,iophrd,ijprlu,ijtalu
596  CHARACTER*80 title
597  CHARACTER*8 projty,targty
598 C COMMON /USER/TITLE,PROJTY,TARGTY,CMENER,ISTRUF
599 C & ,ISINGD,IDUBLD,SDFRAC,PTLAR
600  COMMON /user1/title,projty,targty
601  COMMON /user2/cmener,sdfrac,ptlar,istruf,isingd,idubld
602 *
603  COMMON /colle/ nevhad,nvers,ihadrz,nfile
604  COMMON /ipimm/ipim
605  COMMON /seasu3/seasq
606  COMMON /pomtyp/ ipom2,ipom1,iposom(4),aposom(2)
607  COMMON /diquax/amedd,idiqua,idiquu
608 C-------------------------------------------------------------
609 
610  parameter(intmx=2488)
611  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
612  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
613  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
614  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
615  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
616  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
617  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
618  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
619  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
620  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
621  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
622  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
623  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
624  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
625  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
626  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
627  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
628 *KEEP,ABRZD.
629  COMMON /abrzd/ amczd1(intmd),amczd2(intmd),
630  +gaczd1(intmd),gaczd2(intmd),
631  +bgxzd1(intmd),bgyzd1(intmd),bgzzd1(intmd),
632  +bgxzd2(intmd),bgyzd2(intmd),
633  +bgzzd2(intmd), nchzd1(intmd),nchzd2(intmd),
634  +ijczd1(intmd),ijczd2(intmd),
635  +pqzda1(intmd,4),pqzda2(intmd,4), pqzdb1(intmd,4),
636  +pqzdb2(intmd,4),
637  +ipcq(intmd),itcq(intmd),itcq2(intmd),ipcaq(intmd),
638  +itcaq(intmd),itcaq2(intmd)
639  +,izdss(intmd)
640 *KEEP,ABRDZ.
641  COMMON /abrdz/ amcdz1(intmd),amcdz2(intmd),
642  +gacdz1(intmd),gacdz2(intmd),
643  +bgxdz1(intmd),bgydz1(intmd),bgzdz1(intmd),
644  +bgxdz2(intmd),bgydz2(intmd),
645  +bgzdz2(intmd), nchdz1(intmd),nchdz2(intmd),
646  +ijcdz1(intmd),ijcdz2(intmd),
647  +pqdza1(intmd,4),pqdza2(intmd,4), pqdzb1(intmd,4),
648  +pqdzb2(intmd,4),
649  +ipzq(intmd),ipzqq2(intmd),itzq(intmd),ipzaq(intmd),
650  +izaqq2(intmd),itzaq(intmd)
651  +,idzss(intmd)
652 C-------------------
653  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
654 C-------------------------------------------------------------
655 C COMMON /SVSWAP/ISVSWP,ISVSWT,JSVSWP,JSVSWT,XPSVSW,XTSVSW
656  COMMON /valhvg/phpval(4),phtval(4),ijvgp,ijvgt,ivalhp,ivalht
657  COMMON /ptlarg/xsmax
658  COMMON /gluspl/nugluu,nsgluu
659 C
660 C THE COMMON BLOCK /PART/ DEFINES THE PARTICLE PROPERTIES AS USED IN
661 C BAMJET AND DECAY
662 *KEEP,DPAR.
663 C /DPAR/ CONTAINS PARTICLE PROPERTIES
664 C ANAME = LITERAL NAME OF THE PARTICLE
665 C AAM = PARTICLE MASS IN GEV
666 C GA = DECAY WIDTH
667 C TAU = LIFE TIME OF INSTABLE PARTICLES
668 C IICH = ELECTRIC CHARGE OF THE PARTICLE
669 C IIBAR = BARYON NUMBER
670 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
671 C
672  CHARACTER*8 aname
673  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
674  +iibar(210),k1(210),k2(210)
675 C------------------
676 
677 C THE COMMON BLOCK /INPDAT/ DEFINES QUANTITIES NEEDED IN THE BAMJET
678 C CHAIN DECAY CODE
679 *KEEP,DINPDA.
680  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
681  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
682  COMMON /lmmaxi/ lmmax
683  parameter(nstrmx=50)
684  common/skine1/ngluef,nnn,gl(nstrmx),gr(nstrmx),vl,vr,wl,wr,
685  * ptgl(2,nstrmx),ptvl(2),ptwl(2),
686  * ptgr(2,nstrmx),ptvr(2),ptwr(2)
687  COMMON /pcharm/pc
688  COMMON /seaqxx/ seaqx,seaqxn
689 C DATA INIPRI/0/
690  DATA inicha/0/
691  DATA jtsp /0/
692 C to keep identical commons
693  ecm=cmener
694 *
695  IF(iouxev.GE.4)WRITE(6,*)'XPTFL1:entry:NDZ,NZD,NNDZ,NNZD,NHARD,',
696  *'NSEA,NVAL'
697  *,ndz,nzd,nndz,nnzd,nhard,nsea,nval
698  nostin=nonust
699  go to 1179
700  1199 CONTINUE
701  ndz=ndz-nndz
702  nzd=nzd-nnzd
703 C change 27.10.96
704 C NDZ=0
705 C NZD=0
706  IF (iouxev.GE.6)WRITE (6,*)'XPTFL1: 1199 ndz nzd nndz nnzd'
707  *,ndz,nzd,nndz,nnzd
708  IF (iouxev.GE.6)WRITE (6,107)iouxev,nhard,lpo,nzd,ndz,lpasof
709  1179 CONTINUE
710  nonust=nostin
711 C NDZ=0
712 C NZD=0
713  nndz=0
714  nnzd=0
715  ipim =0
716  rj1000=0.d0
717  nhard=mpo
718  unoglu=5.
719  unoval=2.
720  sox1=xmax1-hax1
721  sox2=xmax2-hax2
722  lpasof=0
723 C LLPPOO=LPO-1+MPO
724  llppoo=lpo-1
725  IF (llppoo.LE.0) go to 2020
726  alpo=lpo
727 C ALPO=LPO+MPO
728  nsea=0
729  IF(ipom1.EQ.48.AND.ipom2.EQ.2.AND.ecm.LT.20.d0)THEN
730  xpthro=1.5*log10(ecm/2000.)+5.
731  xpthro=1.5*log10(ecm/200.)+3.5
732  ELSEIF(ipom1.EQ.48.AND.ipom2.EQ.2.AND.ecm.GE.20.d0)THEN
733  xpthro=5.0
734  ENDIF
735  IF(ipom1.EQ.11.AND.ipom2.EQ.5)xpthro=15.
736  IF(ipom1.EQ.5.AND.ipom2.EQ.5)xpthro=20.
737  IF (ipim.EQ.2)xpthro=2.
738  xpthro=8.
739  IF(istruf.EQ.15) xpthro=5.
740  IF(istruf.EQ.22) xpthro=8.
741  IF( jtsp.EQ.0 ) THEN
742  WRITE(6,*)' XPTFL1: XPTHRO=',xpthro
743  jtsp=1
744  ENDIF
745 C j.r.5.12.94
746 C XPTHR=XPTHRO/ECM
747  xpthr=1.5*xpthro/(ecm**1.5*14.)
748 C------------------------------------------------------------
749 C j.r.11.5.94---16.5.94
750 C IF(IP.EQ.1)XPTHR=1.5*XPTHRO/ECM**2
751  IF(ip.EQ.1)xpthr=1.5*xpthro/(ecm**1.5*14.)
752 C------------------------------------------------------------
753  xpthr2=1.8
754  IF (xpthr2.GT.xpthro)xpthr2=xpthro
755 C j.r,5.12.94
756 C XSTHR2=XPTHR2/ECM
757  xsthr2=1.5*xpthr2/(ecm**1.5*14.)
758 C------------------------------------------------------------
759 C j.r.11.5.94---16.5.94
760 C IF(IP.EQ.1)XSTHR2=1.5*XPTHR2/ECM**2
761  IF(ip.EQ.1)xsthr2=1.5*xpthr2/(ecm**1.5*14.)
762 C------------------------------------------------------------
763 C IF(INIPRI.EQ.0)THEN
764 C INIPRI=1
765  alox1=log(sox1/xpthr)
766  alox2=log(sox2/xpthr)
767  aloox1=1.+alox1
768  aloox2=1.+alox2
769  alooo1=1./aloox1
770  alooo2=1./aloox2
771  IF( jtsp.EQ.1 ) THEN
772  WRITE(6,9753)xpthro,xpthr,xsthr2
773  9753 FORMAT(' XPTFL1: XPTHRO,XPTHR,XSTHR2= ',3e15.5)
774  jtsp=2
775  ENDIF
776 C ENDIF
777 C one pair of soft chains for each hard pomeron
778 C IF(NPO.EQ.1)LLPPOO=LPO-2
779 C IF(NPO.EQ.1)LLPPOO=LPO
780 C----------------------------------------------------------------------
781 C Initialize Charm selection at soft chain ends
782 C
783  IF(inicha.EQ.0)THEN
784  gm=2.140
785  x2=ummm
786  betoo=7.5d0
787  ENDIF
788  rx=xpthro
789  x1=rx
790  betcha=betoo+1.3-log10(ecm)
791  pu=dbeta(x1,x2,betcha)
792  x2=smmm
793  ps=dbeta(x1,x2,betcha)
794  x2=cmmm
795  pc=dbeta(x1,x2,betcha)
796 C PU1=PU/(2*PU+PS+PC)
797 C PS1=PS/(2*PU+PS+PC)
798  pc1=pc/(2*pu+ps+pc)
799  pc=pc1
800  pu1=pu/(2*pu+ps+pc)
801  ps1=ps/(2*pu+ps+pc)
802  IF(inicha.EQ.0)THEN
803  inicha=1
804  WRITE(6,4567)pc,betcha,pu1,ps1
805  4567 FORMAT(' Charm at chain ends XPTFL1: PC,BETCHA,PU,PS ',4f10.5)
806  ENDIF
807 C----------------------------------------------------------------------
808 C
809  DO 20 i=1,llppoo
810 C JSVSWP=0
811 C JSVSWT=0
812  ai=i-1
813 C XPTHRX=XPTHR-0.5*AI/ECM
814  xpthrx=xpthr-0.5*ai/ecm**2
815 C------------------------------------------------------------
816 C j.r.11.5.94---16.5.94
817  IF(ip.EQ.1)xpthrx=xpthr-0.5*ai/ecm**2
818 C------------------------------------------------------------
819 C IF (XPTHRX.LT.2.D0/ECM)XPTHRX=2./ECM
820  IF (xpthrx.LT.4.d0/ecm**2)xpthrx=4./ecm**2
821 C------------------------------------------------------------
822 C j.r.11.5.94---16.5.94
823  IF(ip.EQ.1.AND.xpthrx.LT.4.d0/ecm**2)xpthrx=4./ecm**2
824 C------------------------------------------------------------
825 C
826 C LOOP OVER (LPO-1) SOFT SEA-SEA CHAINS WITH GLUONS AT CHAIN ENDS
827 C GLUONS WILL BE SPLIT INTO QUARK-ANTIQUARK PAIRS
828 C AND TWO Q-AQ CHAINS FORMED PER COLLISION
829 C
830 C GLUON X-VALUES
831 C CHANGE J.R.21.5.90
832 C---------------------------------------------------------------
833  ncoglu=0
834  5577 CONTINUE
835  ncoglu=ncoglu+1
836  IF(ncoglu.GE.6)THEN
837 C REJECT XGLU values too large
838 C REJECT THE TOTAL EVENT
839  IF (iouxev.GE.6)WRITE (6,*)' REJECT EVENT XGLU-VALUES'
840  lpo=lpo-1
841  soxus1=0.
842  soxus2=0.
843  go to 1199
844  ENDIF
845  IF (rndm(v1).LT.alooo1)THEN
846  xglu1=rndm(a2)*(xpthrx-xsthr2)+xsthr2
847  ELSE
848  25 CONTINUE
849 C................................................................a
850  IF(seaqx.LE.0.75d0)THEN
851  xglu1=sampex(xpthrx,sox1)
852  ELSEIF(seaqx.GT.0.75d0)THEN
853  xglu1=sampey(xpthrx,sox1)
854  ENDIF
855 C................................................................
856  ENDIF
857  IF (rndm(v3).LT.alooo2)THEN
858  xglu2=rndm(a4)*(xpthrx-xsthr2)+xsthr2
859  ELSE
860  26 CONTINUE
861 C................................................................
862  IF(seaqx.LE.0.75d0)THEN
863  xglu2=sampex(xpthrx,sox1)
864  ELSEIF(seaqx.GT.0.75d0)THEN
865  xglu2=sampey(xpthrx,sox1)
866  ENDIF
867 C................................................................
868 C CHANGE 18.6.90 PREVENT EVENT LOOP
869  ENDIF
870 C---------------------------------------------------------------
871 C SPLIT GLUON INTO TWO SEA QUARKS
872 C FLAVORS OF SEA QUARKS
873  IF(iouxev.GE.6)WRITE (6,109) xglu1,xglu2
874 C Are these xglu values allowed
875  IF(xglu1+soxus1.GT.sox1.OR.xglu2+soxus2.GT.sox2)go to 5577
876  109 FORMAT (' XPTFL1 XGLU1,XGLU2 ',2f10.6)
877  ai=i
878  bi=i+i
879  ipsq1=1.d0+rndm(qa1)*(2.d0+seasq)
880  IF(rndm(w1).LT.pc)ipsq1=4
881  ipsaq1=-ipsq1
882  ipsq2=1.d0+rndm(qb1)*(2.d0+seasq)
883  IF(rndm(w2).LT.pc)ipsq2=4
884  ipsaq2=-ipsq2
885  IF (iouxev.GE.6)WRITE (6,113)ipsq1,ipsq2
886  113 FORMAT(' XPTFL1 IPSQ1,IPSQ2 ',2i10)
887 C X-FRAXTIONS OF SEA QUARKS
888 C------------------------------------------------------j.r.29.4.93
889  IF(ipsq1.LE.2)THEN
890  xpsq1=(0.2+(0.36*rndm(a1))**0.50)*xglu1
891  xpsaq1=xglu1-xpsq1
892  ELSEIF(ipsq1.EQ.3)THEN
893  bsq=0.7/ecm
894  xsthr=2./ecm
895  icoxs1=0
896  5588 CONTINUE
897  icoxs1=icoxs1+1
898  IF(icoxs1.GT.8)THEN
899 C REJECT XPSQ1 values too large
900 C REJECT THE TOTAL EVENT
901  IF (iouxev.GE.6)WRITE (6,*)' REJECT EVENT XPSQ1-VALUES'
902  lpo=lpo-1
903  soxus1=0.
904  soxus2=0.
905  IF(iouxev.GE.4) WRITE(6,*)' xptfl1 LPO,SOXUS1,SOXUS2 reject ',
906  * lpo,soxus1,soxus2
907  go to 1199
908  ENDIF
909  xpsq1=sampxb(xsthr+bsq,0.9d0,bsq)
910  IF(xpsq1.GE.xglu1)go to 5588
911  xpsaq1=xglu1-xpsq1
912 C XPSAQ1=SAMPXB(XSTHR+BSQ,0.9D0,BSQ)
913  ELSEIF(ipsq1.EQ.4)THEN
914  bcq=2./ecm
915  xsthr=2./ecm
916  xpsq1=sampxb(xsthr+bcq,0.9d0,bcq)
917  xpsaq1=sampxb(xsthr+bcq,0.9d0,bcq)
918  ENDIF
919  IF(ipsq2.LE.2)THEN
920  xpsq2=(0.2+(0.36*rndm(b1))**0.50)*xglu2
921  xpsaq2=xglu2-xpsq2
922  ELSEIF(ipsq2.EQ.3)THEN
923  bsq=0.7/ecm
924  xsthr=2./ecm
925  icoxs2=0
926  5599 CONTINUE
927  icoxs2=icoxs2+1
928  IF(icoxs2.GT.8)THEN
929 C REJECT XPSQ2 values too large
930 C REJECT THE TOTAL EVENT
931  IF (iouxev.GE.6)WRITE (6,*)' REJECT EVENT XPSQ2-VALUES'
932  lpo=lpo-1
933  soxus1=0.
934  soxus2=0.
935  go to 1199
936  ENDIF
937  xpsq2=sampxb(xsthr+bsq,0.9d0,bsq)
938  IF(xpsq2.GE.xglu2)go to 5599
939  xpsaq2=xglu2-xpsq2
940 C XPSAQ2=SAMPXB(XSTHR+BSQ,0.9D0,BSQ)
941  ELSEIF(ipsq2.EQ.4)THEN
942  bcq=2./ecm
943  xsthr=2./ecm
944  xpsq2=sampxb(xsthr+bcq,0.9d0,bcq)
945  xpsaq2=sampxb(xsthr+bcq,0.9d0,bcq)
946  ENDIF
947 C------------------------------------------------------j.r.29.4.93
948  IF (iouxev.GE.6)WRITE (6,107)iouxev,nhard,lpo,nzd,ndz,lpasof
949  107 FORMAT (' XPTFL1 IOUXEV,NHARD,LPO,NZD,NDZ,LPASOF = ',6i10)
950  IF(iouxev.GE.6)WRITE(6,114) xpsq1,xpsaq1,xpsq2,xpsaq2
951  114 FORMAT(' XPSQ1,XPSAQ1,XPSQ2,XPSAQ2 ',4f12.6)
952 C ------------------------------------------------------------------
953 C define eventually D-Z chains (sea-diquark--sea)
954 C
955  irejdz=0
956  irejzd=0
957  ndiqdz=0
958  ndiqzd=0
959 C AME=0.9
960  IF(rndm(v).GT.2.d0*amedd-1.d0)THEN
961  IF(idiquu.EQ.1)THEN
962  IF(iouxev.GE.3)WRITE(6,*)' XPTFL1 call DIQDZZ ',
963  * 'LPO,AMEDD',lpo,amedd
964  CALL diqdzz(ecm,xpsq1,xpsaq1,xpsq2,xpsaq2,ipsq1,ipsaq1,
965  * ipsq2,ipsaq2,irejdz)
966  IF(irejdz.EQ.1)THEN
967  IF (iouxev.GE.4)WRITE (6,'(2A,4I5)')'DIQDZZ1 ndz nzd nndz '
968  * ,'nnzd XPTFL1',ndz,nzd,nndz,nnzd
969  ENDIF
970  IF(irejdz.EQ.0) THEN
971  nndz=nndz+1
972  IF (iouxev.GE.3)WRITE (6,'(2A,4I5)')' DIQDZZ0 ndz nzd nndz'
973  * ,' nnzd XPTFL1',ndz,nzd,nndz,nnzd
974  ndiqdz=1
975 C TEST ARE THESE X VALUES ALLOWED
976  soxus1=soxus1+xpsq1+xpsaq1
977  soxus2=soxus2+xpsq2+xpsaq2
978  IF(iouxev.GE.3)WRITE (6,*)' SOXUS1,SOXUS2,SOX1,SOX2 ',
979  * 'HAX1,HAX2 after call diqdzz ',
980  * soxus1,soxus2,sox1,sox2,
981  * hax1,hax2
982  IF ((soxus1.GT.sox1).OR.(soxus2.GT.sox2)) THEN
983 C REJECT THE TOTAL EVENT
984  IF (iouxev.GE.3)WRITE (6,106)
985  rj1000=1.d0
986  ndz=ndz-nndz
987  nzd=nzd-nnzd
988 C change 27.10.96
989  nndz=0
990  nnzd=0
991 C change 27.10.96
992  ndiqdz=0
993  lpo=lpo-1
994  soxus1=0.
995  soxus2=0.
996  nonust=nostin
997  IF (iouxev.GE.3)WRITE (6,*)' RETURN ndz nzd '
998  * ,.GT.'nndz,nnzd,LPO soxussox DIQDZZ0',
999  * ndz,nzd,nndz,nnzd,lpo
1000  RETURN
1001  ENDIF
1002 C GO TO 20
1003  ENDIF
1004  ENDIF
1005  ENDIF
1006  IF(rndm(v).GT.2.d0*amedd-1.d0.AND.ndiqdz.EQ.0)THEN
1007  IF(idiquu.EQ.1)THEN
1008  IF(iouxev.GE.3)WRITE(6,*)' XPTFL1 call DIQZZD ',
1009  * 'LPO,AMEDD',lpo,amedd
1010  CALL diqzzd(ecm,xpsq1,xpsaq1,xpsq2,xpsaq2,ipsq1,ipsaq1,
1011  * ipsq2,ipsaq2,irejzd)
1012  IF(irejzd.EQ.1)THEN
1013  IF (iouxev.GE.3)WRITE (6,'(2A,4I5)')' DIQZZD1 ndz nzd nndz'
1014  * ,' nnzd XPTFL1',ndz,nzd,nndz,nnzd
1015 C NZD=NZD-1
1016  ENDIF
1017  IF(irejzd.EQ.0) THEN
1018  nnzd=nnzd+1
1019  IF (iouxev.GE.3)WRITE (6,'(2A,4I5)')' DIQZZD0 ndz nzd '
1020  * ,'nndz,nnzd XPTFL1',ndz,nzd,nndz,nnzd
1021  ndiqzd=1
1022 C TEST ARE THESE X VALUES ALLOWED
1023  soxus1=soxus1+xpsq1+xpsaq1
1024  soxus2=soxus2+xpsq2+xpsaq2
1025  IF(iouxev.GE.3)WRITE (6,*)' SOXUS1,SOXUS2,SOX1,SOX2 ,',
1026  * 'HAX1,HAX2 after call diqzzd0',
1027  * soxus1,soxus2,sox1,sox2,
1028  * hax1,hax2
1029  IF ((soxus1.GT.sox1).OR.(soxus2.GT.sox2)) THEN
1030 C REJECT THE TOTAL EVENT
1031  IF (iouxev.GE.3)WRITE (6,106)
1032  rj1000=1.d0
1033  nzd=nzd-nnzd
1034  ndz=ndz-nndz
1035 C change 27.10.96
1036 C NDZ=0
1037 C NZD=0
1038  nndz=0
1039  nnzd=0
1040 C change 27.10.96
1041  ndiqzd=0
1042  lpo=lpo-1
1043  soxus1=0.
1044  soxus2=0.
1045  nonust=nostin
1046  IF (iouxev.GE.3)WRITE (6,*)' RETURN2 ndz nzd '
1047  * ,.GT.'nndz,nnzd,LPO SOXUSSOX',
1048  * 'diqzzd0',ndz,nzd,nndz,nnzd,lpo
1049  RETURN
1050  ENDIF
1051 C GO TO 20
1052  ENDIF
1053  ENDIF
1054  ENDIF
1055  ame=0.95
1056  ptxsq1=0
1057  ptysq1=0
1058  ptxsa1=0
1059  ptysa1=0
1060  ptxsq2=0
1061  ptysq2=0
1062  ptxsa2=0
1063  ptysa2=0
1064  plq1 = xpsq1 *ecm/2.
1065  eq1 = xpsq1 *ecm/2.
1066  plaq1= xpsaq1*ecm/2.
1067  eaq1 = xpsaq1*ecm/2.
1068  plq2 =-xpsq2 *ecm/2.
1069  eq2 = xpsq2 *ecm/2.
1070  plaq2=-xpsaq2*ecm/2.
1071  eaq2 = xpsaq2*ecm/2.
1072 C ------------------------------------------------------------------
1073 
1074 C SELECT SEA QUARK AND ANTIQUARK PT-VALUES
1075 C
1076  ikvala=2
1077  nselpt=1
1078  IF(iouxev.GE.6)WRITE(6,'(A)')' XPTFL1 call SELPT'
1079  CALL selpt(
1080  * ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1,
1081  * ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
1082  * amch1,amch2,irej,ikvala,pttq1,ptta1,pttq2,ptta2,
1083  * nselpt)
1084 C
1085  IF (irej.EQ.1) THEN
1086  IF(iouxev.GE.6)WRITE(6,*)' XPTFL1: --> 9922 IREJ=',irej
1087  IF(iouxev.GE.6)WRITE(6,'(A,6I5)')
1088  *' XPTFL1:NDZ,NNDZ,NDIQDZ,NZD,NNZD,NDIQZD ',
1089  *ndz,nndz,ndiqdz,nzd,nnzd,ndiqzd
1090  IF(ndiqdz.EQ.1)THEN
1091  ndz=ndz-1
1092  ndiqdz=0
1093  nndz=nndz-1
1094  ENDIF
1095  IF(ndiqzd.EQ.1)THEN
1096  nzd=nzd-1
1097  ndiqzd=0
1098  nnzd=nnzd-1
1099  ENDIF
1100  go to 9922
1101  ENDIF
1102  IF (iouxev.GE.6)WRITE (6,*)'IOUXEV,NHARD,LPO,NZD,NDZ,LPASOF',
1103  *iouxev,nhard,lpo,nzd,ndz,lpasof
1104 C
1105 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS
1106 C FIRST FOR CHAIN 1
1107 C
1108  ifps1=imps(ipsq2,ipsq1)
1109  ifv1=imve(ipsq2,ipsq1)
1110  amps1=aam(ifps1)
1111  amv1=aam(ifv1)
1112  nnch1=0
1113  amff1=amv1+0.3
1114  IF(iouxev.GE.3)WRITE(6,102)amch1,amps1,amv1,ifps1,ifv1
1115  102 FORMAT(' AMCH1,AMPS1,AMV1,IFPS1,IFV1 ',3f12.4,2i10)
1116  IF(amch1.LT.amff1) THEN
1117  IF(iouxev.GE.6)WRITE(6,*)' XPTFL1: --> 9922 AMCH1 < AMFF1'
1118  IF(iouxev.GE.6)WRITE(6,'(A,6I5)')
1119  *' XPTFL1:NDZ,NNDZ,NDIQDZ,NZD,NNZD,NDIQZD ',
1120  *ndz,nndz,ndiqdz,nzd,nnzd,ndiqzd
1121  IF(ndiqdz.EQ.1)THEN
1122  ndz=ndz-1
1123  ndiqdz=0
1124  nndz=nndz-1
1125  ENDIF
1126  IF(ndiqzd.EQ.1)THEN
1127  nzd=nzd-1
1128  ndiqzd=0
1129  nnzd=nnzd-1
1130  ENDIF
1131  go to 9922
1132  ENDIF
1133  IF (amch1.LT.amv1)THEN
1134 C PRODUCE PSEUDOSCALAR
1135  ijnch1=ifps1
1136  nnch1=-1
1137 C CORRECT KINEMATICS
1138  xpsq1=xpsq1*amps1/amch1
1139  xpsaq2=xpsaq2*amps1/amch1
1140  amch1=amps1
1141 C GO TO REDO THE KINEMATICS
1142  ELSEIF(amch1.LT.amff1) THEN
1143 C PRODUCE VECTOR MESON
1144  ijnch1=ifv1
1145  nnch1=1
1146 C CORRECT KINEMATICS
1147  xpsq1=xpsq1*amv1/amch1
1148  xpsaq2=xpsaq2*amv1/amch1
1149  amch1=amv1
1150 C GO TO REDO THE KINEMATICS
1151  ELSE
1152 C NO CORRECTIONS BUT DO CHAIN 2
1153  go to 31
1154  ENDIF
1155 C CORRECT KINEMATICS FOR CHAIN 1
1156 
1157  eq1=xpsq1*ecm/2.
1158  eaq2=xpsaq2*ecm/2.
1159  IF( (eq1**2.LT.pttq1)
1160  * .OR.(eaq2**2.LT.ptta2)) THEN
1161  IF(iouxev.GE.6)WRITE(6,*)' XPTFL1: --> 9922 EQ^2 < PT'
1162  * ,'EQ1 PTTQ1 EAQ2 PTTA2',eq1,pttq1,eaq2,ptta2
1163  IF(iouxev.GE.6)WRITE(6,'(A,6I5)')
1164  *' XPTFL1:NDZ,NNDZ,NDIQDZ,NZD,NNZD,NDIQZD ',
1165  *ndz,nndz,ndiqdz,nzd,nnzd,ndiqzd
1166  IF(ndiqdz.EQ.1)THEN
1167  ndz=ndz-1
1168  ndiqdz=0
1169  nndz=nndz-1
1170  ENDIF
1171  IF(ndiqzd.EQ.1)THEN
1172  nzd=nzd-1
1173  ndiqzd=0
1174  nnzd=nnzd-1
1175  ENDIF
1176  go to 9922
1177  ENDIF
1178  plq1=sqrt(eq1**2-pttq1)
1179  plaq2=-sqrt(eaq2**2-ptta2)
1180  31 CONTINUE
1181  IF (iouxev.GE.6)WRITE (6,107)iouxev,nhard,lpo,nzd,ndz,lpasof
1182 C
1183 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS
1184 C SECOND FOR CHAIN 2
1185 C
1186  ifps2=imps(ipsq1,ipsq2)
1187  ifv2=imve(ipsq1,ipsq2)
1188  amps2=aam(ifps2)
1189  amv2=aam(ifv2)
1190  nnch2=0
1191  amff2=amv2+0.3
1192  IF(iouxev.GE.3)WRITE(6,103)amch2,amps2,amv2,ifps2,ifv2
1193  103 FORMAT(' AMCH2,AMPS2,AMV2,IFPS2,IFV2 ',3f12.4,2i10)
1194  IF(amch2.LT.amff2) THEN
1195  IF(iouxev.GE.6)WRITE(6,*)' XPTFL1: --> 9922 AMCH2 < AMFF2'
1196  IF(iouxev.GE.6)WRITE(6,'(A,6I5)')
1197  *' XPTFL1:NDZ,NNDZ,NDIQDZ,NZD,NNZD,NDIQZD ',
1198  *ndz,nndz,ndiqdz,nzd,nnzd,ndiqzd
1199  IF(ndiqdz.EQ.1)THEN
1200  ndz=ndz-1
1201  ndiqdz=0
1202  nndz=nndz-1
1203  ENDIF
1204  IF(ndiqzd.EQ.1)THEN
1205  nzd=nzd-1
1206  ndiqzd=0
1207  nnzd=nnzd-1
1208  ENDIF
1209  go to 9922
1210  ENDIF
1211  IF (amch2.LT.amv2)THEN
1212 C PRODUCE PSEUDO SCALAR
1213  ijnch2=ifps2
1214  nnch2=-1
1215 C CORRECT KINEMATICS
1216  xpsq2=xpsq2*amps2/amch2
1217  xpsaq1=xpsaq1*amps2/amch2
1218  amch2=amps2
1219 C GO TO REDO THE KINEMATICS
1220  ELSEIF(amch2.LT.amff2) THEN
1221 C PRODUCE VECTOR MESON
1222  ijnch2=ifv2
1223  nnch2=1
1224 C CORRECT KINEMATICS
1225  xpsq2=xpsq2*amv2/amch2
1226  xpsaq1=xpsaq1*amv2/amch2
1227  amch2=amv2
1228 C GO TO REDO THE KINEMATICS
1229  ELSE
1230 C NO CORRECTIONS
1231  go to 32
1232  ENDIF
1233 C CORRECT KINEMATICS FOR CHAIN 2
1234 
1235  eq2=xpsq2*ecm/2.
1236  eaq1=xpsaq1*ecm/2.
1237  IF( (eq2**2.LT.pttq2)
1238  * .OR.(eaq1**2.LT.ptta1)) THEN
1239  IF(iouxev.GE.6)WRITE(6,*)' XPTFL1: --> 9922 EQ^2 < PT'
1240  * ,'EQ2 PTTQ2 EAQ1 PTTA1',eq2,pttq2,eaq1,ptta1
1241  IF(iouxev.GE.6)WRITE(6,'(A,6I5)')
1242  *' XPTFL1:NDZ,NNDZ,NDIQDZ,NZD,NNZD,NDIQZD ',
1243  *ndz,nndz,ndiqdz,nzd,nnzd,ndiqzd
1244  IF(ndiqdz.EQ.1)THEN
1245  ndz=ndz-1
1246  ndiqdz=0
1247  nndz=nndz-1
1248  ENDIF
1249  IF(ndiqzd.EQ.1)THEN
1250  nzd=nzd-1
1251  ndiqzd=0
1252  nnzd=nnzd-1
1253  ENDIF
1254  go to 9922
1255  ENDIF
1256  plq2=-sqrt(eq2**2-pttq2)
1257  plaq1=sqrt(eaq1**2-ptta1)
1258  32 CONTINUE
1259 C TEST ARE THESE X VALUES ALLOWED
1260  IF(ndiqdz.EQ.0.AND.ndiqzd.EQ.0)THEN
1261  soxus1=soxus1+xpsq1+xpsaq1
1262  soxus2=soxus2+xpsq2+xpsaq2
1263  ENDIF
1264  IF(iouxev.GE.3)WRITE (6,105)soxus1,soxus2,sox1,sox2,hax1,hax2
1265  105 FORMAT('XPTFL1 SOXUS1,SOXUS2,SOX1,SOX2,HAX1,HAX2 ',6f10.6)
1266  IF ((soxus1.GT.sox1).OR.(soxus2.GT.sox2)) THEN
1267 C REJECT THE TOTAL EVENT
1268  IF (iouxev.GE.6)WRITE (6,106)
1269  106 FORMAT(' REJECT THE EVENT SEA X-VALUES')
1270 C j.r.10.5.94
1271  lpo=lpo-1
1272  soxus1=0.
1273  soxus2=0.
1274  go to 1199
1275  ENDIF
1276  go to 9923
1277  9922 CONTINUE
1278 CC LPO=LPO-1
1279  soxus1=0.
1280  soxus2=0.
1281  go to 1199
1282 C VALENCE-SEA SWAP-------------------
1283 C IF (JSVSWP.EQ.1)ISVSWP=0
1284 C IF (JSVSWT.EQ.1)ISVSWT=0
1285  go to 22
1286  9923 CONTINUE
1287 C NOW WE HAVE AN ACCEPTABLE SOFT GLUON-GLUON EVENT
1288 C AND PUT IT INTO THE HISTOGRAM
1289 C
1290  IF (iouxev.GE.6)WRITE (6,107)iouxev,nhard,lpo,nzd,ndz,lpasof
1291  lpasof=lpasof+1
1292  ii=lpasof
1293  nonust=nonust+1
1294  ii=nonust
1295  xsq1(ii)=xpsq1
1296  xsaq1(ii)=xpsaq1
1297  xsq2(ii)=xpsq2
1298  xsaq2(ii)=xpsaq2
1299  ijsq1(ii)=ipsq1
1300  ijsaq1(ii)=ipsaq1
1301  ijsq2(ii)=ipsq2
1302  ijsaq2(ii)=ipsaq2
1303  amcch1(ii)=amch1
1304  amcch2(ii)=amch2
1305  gamch1(ii)=(eq1+eaq2)/amch1
1306  bgxch1(ii)=(ptxsq1+ptxsa2)/amch1
1307  bgych1(ii)=(ptysq1+ptysa2)/amch1
1308  bgzch1(ii)=(plq1+plaq2)/amch1
1309  gamch2(ii)=(eq2+eaq1)/amch2
1310  bgxch2(ii)=(ptxsq2+ptxsa1)/amch2
1311  bgych2(ii)=(ptysq2+ptysa1)/amch2
1312  bgzch2(ii)=(plaq1+plq2)/amch2
1313  nch1(ii)=nnch1
1314  nch2(ii)=nnch2
1315  IF (irejdz.EQ.0.AND.ndiqdz.EQ.1)THEN
1316  nch1(ii)=88
1317  nch2(ii)=88
1318  ENDIF
1319  IF (irejzd.EQ.0.AND.ndiqzd.EQ.1)THEN
1320  nch1(ii)=88
1321  nch2(ii)=88
1322  ENDIF
1323  IF(ndiqdz.EQ.1.AND.ndz.GT.0)idzss(ndz)=ii
1324  IF(ndiqzd.EQ.1.AND.nzd.GT.0)izdss(nzd)=ii
1325  ijch1(ii)=ijnch1
1326  ijch2(ii)=ijnch2
1327  psofa1(ii,1)=ptxsq1
1328  psofa1(ii,2)=ptysq1
1329  psofa1(ii,3)=plq1
1330  psofa1(ii,4)=eq1
1331  psofa2(ii,1)=ptxsa2
1332  psofa2(ii,2)=ptysa2
1333  psofa2(ii,3)=plaq2
1334  psofa2(ii,4)=eaq2
1335  psofb1(ii,1)=ptxsq2
1336  psofb1(ii,2)=ptysq2
1337  psofb1(ii,3)=plq2
1338  psofb1(ii,4)=eq2
1339  psofb2(ii,1)=ptxsa1
1340  psofb2(ii,2)=ptysa1
1341  psofb2(ii,3)=plaq1
1342  psofb2(ii,4)=eaq1
1343  IF (iouxev.GE.3)WRITE(6,104)ii,
1344  * xsq1(ii),xsaq1(ii),xsq2(ii),xsaq2(ii),
1345  * ijsq1(ii),ijsaq1(ii),ijsq2(ii),ijsaq2(ii),
1346  * amcch1(ii),amcch2(ii),gamch1(ii),gamch2(ii),
1347  * bgch1(ii),bgch2(ii),thech1(ii),thech2(ii),
1348  * bgxch1(ii),bgych1(ii),bgzch1(ii),
1349  * bgxch2(ii),bgych2(ii),bgzch2(ii),
1350  * nch1(ii),nch2(ii),ijch1(ii),ijch2(ii),
1351  * (psofa1(ii,ju),psofa2(ii,ju),psofb1(ii,ju),
1352  * psofb2(ii,ju),ju=1,4)
1353  104 FORMAT(i10,4f12.7,4i5/10x,8f12.6/10x,6f12.6,4i5/8f15.5/8f15.5)
1354  22 CONTINUE
1355  20 CONTINUE
1356  IF (iouxev.GE.6) WRITE(6,*)' LPASOF =',lpasof
1357  2020 CONTINUE
1358  IF (iouxev.GE.4)WRITE (6,*)'END XPTFL1',
1359  * ' IOUXEV,NHARD,LPO,NZD,NDZ,LPASOF,IREJ',
1360  * iouxev,nhard,lpo,nzd,ndz,lpasof,irej
1361  RETURN
1362  END
1363 C*****************************************************************
1364  SUBROUTINE ptval(XP,XXP,XXT,XT,ECM,
1365  * ptxvq1,ptyvq1,plq1,eq1,ptxva1,ptyva1,plaq1,eaq1,
1366  * ptxvq2,ptyvq2,plq2,eq2,ptxva2,ptyva2,plaq2,eaq2,
1367  * amch1,amch2,irej,ikvala)
1368  IMPLICIT DOUBLE PRECISION(a-h,o-z)
1369  SAVE
1370  COMMON /colle/ nevhad,nvers,ihadrz,nfile
1371  parameter(nstrmx=50)
1372  common/skine1/ngluef,nnn,gl(nstrmx),gr(nstrmx),vl,vr,wl,wr,
1373  * ptgl(2,nstrmx),ptvl(2),ptwl(2),
1374  * ptgr(2,nstrmx),ptvr(2),ptwr(2)
1375  ptxvq1 = ptvl(1)
1376  ptyvq1 = ptvl(2)
1377  ptxva1 = ptwl(1)
1378  ptyva1 = ptwl(2)
1379  ptxvq2 = ptvr(1)
1380  ptyvq2 = ptvr(2)
1381  ptxva2 = ptwr(1)
1382  ptyva2 = ptwr(2)
1383  eq1 = xp*ecm/2.
1384  eq2 = xt*ecm/2.
1385  eaq1 = xxp*ecm/2.
1386  eaq2 = xxt*ecm/2.
1387 C PLQ1 = SQRT(EQ1**2-PTXVQ1**2-PTYVQ1**2)
1388 C PLQ2 = SQRT(EQ2**2-PTXVQ2**2-PTYVQ2**2)
1389 C PLAQ1 = SQRT(EAQ1**2-PTXVA1**2-PTYVA1**2)
1390 C PLAQ2 = SQRT(EAQ2**2-PTXVA2**2-PTYVA2**2)
1391  plq1 = eq1
1392  plq2 = -eq2
1393  plaq1 = eaq1
1394  plaq2 = -eaq2
1395  amch1=sqrt(xp*xxt*ecm*ecm-(ptxvq1+ptxva2)**2
1396  * -(ptyvq1+ptyva2)**2)
1397 C AMCH1=SQRT((EQ1+EAQ2)**2-(PTXVQ1+PTXVA2)**2
1398 C * -(PTYVQ1+PTYVA2)**2-(PLQ1+PLAQ2)**2)
1399  amch2=sqrt(xt*xxp*ecm*ecm-(ptxvq2+ptxva1)**2
1400  * -(ptyvq2+ptyva1)**2)
1401 C AMCH2=SQRT((EQ2+EAQ1)**2-(PTXVQ2+PTXVA1)**2
1402 C * -(PTYVQ2+PTYVA1)**2-(PLQ2+PLAQ1)**2)
1403  RETURN
1404  END
1405  SUBROUTINE kkevt(NHKKH1,EPN,PPN,KKMAT,IREJ)
1406 *
1407  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1408  SAVE
1409  common/intnez/ndz,nzd
1410 *KEEP,HKKEVT.
1411 c INCLUDE (HKKEVT)
1412  parameter(nmxhkk= 89998)
1413 c PARAMETER (NMXHKK=25000)
1414  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
1415  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
1416  +(4,nmxhkk)
1417 C
1418 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
1419 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
1420 C THE POSITIONS OF THE PROJECTILE NUCLEONS
1421 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
1422 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
1423 C COMPLETELY CONSISTENT. THE TIMES IN THE
1424 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
1425 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
1426 C
1427 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
1428 C
1429 C NMXHKK: maximum numbers of entries (partons/particles) that can be
1430 C stored in the commonblock.
1431 C
1432 C NHKK: the actual number of entries stored in current event. These are
1433 C found in the first NHKK positions of the respective arrays below.
1434 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
1435 C entry.
1436 C
1437 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
1438 C = 0 : null entry.
1439 C = 1 : an existing entry, which has not decayed or fragmented.
1440 C This is the main class of entries which represents the
1441 C "final state" given by the generator.
1442 C = 2 : an entry which has decayed or fragmented and therefore
1443 C is not appearing in the final state, but is retained for
1444 C event history information.
1445 C = 3 : a documentation line, defined separately from the event
1446 C history. (incoming reacting
1447 C particles, etc.)
1448 C = 4 - 10 : undefined, but reserved for future standards.
1449 C = 11 - 20 : at the disposal of each model builder for constructs
1450 C specific to his program, but equivalent to a null line in the
1451 C context of any other program. One example is the cone defining
1452 C vector of HERWIG, another cluster or event axes of the JETSET
1453 C analysis routines.
1454 C = 21 - : at the disposal of users, in particular for event tracking
1455 C in the detector.
1456 C
1457 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
1458 C standard.
1459 C
1460 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
1461 C The value is 0 for initial entries.
1462 C
1463 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
1464 C one mother exist, in which case the value 0 is used. In cluster
1465 C fragmentation models, the two mothers would correspond to the q
1466 C and qbar which join to form a cluster. In string fragmentation,
1467 C the two mothers of a particle produced in the fragmentation would
1468 C be the two endpoints of the string (with the range in between
1469 C implied).
1470 C
1471 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
1472 C entry has not decayed, this is 0.
1473 C
1474 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
1475 C entry has not decayed, this is 0. It is assumed that the daughters
1476 C of a particle (or cluster or string) are stored sequentially, so
1477 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
1478 C daughters. Even in cases where only one daughter is defined (e.g.
1479 C K0 -> K0S) both values should be defined, to make for a uniform
1480 C approach in terms of loop constructions.
1481 C
1482 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
1483 C
1484 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
1485 C
1486 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
1487 C
1488 C PHKK(4,IHKK) : energy, in GeV.
1489 C
1490 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
1491 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
1492 C
1493 C VHKK(1,IHKK) : production vertex x position, in mm.
1494 C
1495 C VHKK(2,IHKK) : production vertex y position, in mm.
1496 C
1497 C VHKK(3,IHKK) : production vertex z position, in mm.
1498 C
1499 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
1500 C********************************************************************
1501 *KEEP,INTMX.
1502  parameter(intmx=2488,intmd=252)
1503 *KEEP,DXQX.
1504 C INCLUDE (XQXQ)
1505 * NOTE: INTMX set via INCLUDE(INTMX)
1506  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
1507  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
1508  * ,xpsu(248),xtsu(248)
1509  * ,xpsut(248),xtsut(248)
1510 *KEEP,INTNEW.
1511  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
1512  +ixpv,ixps,ixtv,ixts, intvv1(248),
1513  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
1514  +intss1(intmx),intss2(intmx),
1515  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
1516  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
1517 
1518 C /INTNEW/
1519 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
1520 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
1521 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
1522 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
1523 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
1524 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
1525 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
1526 C FROM PROJECTILE/TARGET NUCLEI
1527 C-------------------
1528 *KEEP,IFROTO.
1529  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
1530  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
1531  +jhkknt
1532  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
1533  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
1534  & mhkkhh(intmx),
1535  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
1536 *KEEP,LOZUO.
1537  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
1538  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
1539  +intlo(intmx),inloss(intmx)
1540 C /LOZUO/
1541 C /
1542 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
1543 C REJECTED IN KKEVT
1544 C------------------
1545 *KEEP,DIQI.
1546  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
1547  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
1548  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
1549  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
1550 *KEEP,SHMAKL.
1551 C INCLUDE (SHMAKL)
1552 * NOTE: INTMX set via INCLUDE(INTMX)
1553  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
1554 *KEEP,NUCC.
1555  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1556 *KEEP,RPTSHM.
1557  COMMON /rptshm/ rproj,rtarg,bimpac
1558 *KEEP,NSHMAK.
1559  COMMON /nshmak/ nnshma,npshma,ntshma,nshmac,nshma2
1560 *KEEP,ZENTRA.
1561  COMMON /zentra/ icentr
1562 *KEEP,NUCIMP.
1563  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
1564  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
1565  +prebin,taebin,fermod,etacou
1566 *KEEP,DROPPT.
1567  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
1568  +ishmal,lpauli
1569  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
1570  +ipadis,ishmal,lpauli
1571 *KEEP,NNCMS.
1572  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
1573 *KEEP,NUCPOS.
1574  COMMON /nucpos/invvp(248),invvt(248),invsp(248),invst(248), nuvv,
1575  +nuvs,nusv,nuss,insvp(248),insvt(248),inssp(248),insst(248), isveap
1576  +(248),isveat(248),isseap(248),isseat(248), ivseap(248),ivseat
1577  +(248), islosp(248),islost(248),inoop(248),inoot(248),nuoo
1578 *KEEP,TAUFO.
1579  COMMON /taufo/ taufor,ktauge,itauve,incmod
1580  COMMON /evappp/ievap
1581 *KEEP,RTAR.
1582  COMMON /rtar/ rtarnu
1583 *KEEP,INNU.
1584  COMMON /innu/inudec
1585 *KEEP,HADTHR.
1586  COMMON /hadthr/ ehadth,inthad
1587 *KEEP,DINPDA.
1588  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
1589  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
1590 *KEEP,FERMI.
1591  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
1592  +(4,248)
1593 *KEEP,KETMAS.
1594  COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
1595 *KEEP,DPAR.
1596 C /DPAR/ CONTAINS PARTICLE PROPERTIES
1597 C ANAME = LITERAL NAME OF THE PARTICLE
1598 C AAM = PARTICLE MASS IN GEV
1599 C GA = DECAY WIDTH
1600 C TAU = LIFE TIME OF INSTABLE PARTICLES
1601 C IICH = ELECTRIC CHARGE OF THE PARTICLE
1602 C IIBAR = BARYON NUMBER
1603 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
1604 C
1605  CHARACTER*8 aname
1606  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
1607  +iibar(210),k1(210),k2(210)
1608 C------------------
1609 *KEEP,DPRIN.
1610  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1611 *KEEP,NUCKOO.
1612  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
1613  +tpoo(3,intmx)
1614 *KEEP,REJEC.
1615  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
1616  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
1617  +irvs14, irvv11,irvv12,irvv13,irvv14
1618 *KEEP,PROJK.
1619  COMMON /projk/ iprojk
1620 *KEEP,TANUIN.
1621  COMMON /tanuin/ tasuma,tasubi,tabi,tamasu,tama,taimma
1622 *KEND.
1623  COMMON /diffra/ isingd,idiftp,ioudif,iflagd
1624 *
1625  LOGICAL lseadi
1626  COMMON /seadiq/ lseadi
1627  COMMON /evflag/numev
1628  COMMON /diquax/amedd,idiqua,idiquu
1629 C
1630 C-----------------------------------------------------------------------
1631 C PARAMETER (INTMX=2488)
1632  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
1633  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
1634  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
1635  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
1636  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
1637  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
1638  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
1639  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
1640  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
1641  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
1642  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
1643  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
1644  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
1645  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
1646  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
1647  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
1648  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
1649 *KEEP,ABRSS.
1650 C INCLUDE (ABRSS)
1651  COMMON /abrss/ amcss1(intmx),amcss2(intmx), gacss1(intmx),gacss2
1652  +(intmx), bgxss1(intmx),bgyss1(intmx),bgzss1(intmx), bgxss2(intmx),
1653  +bgyss2(intmx),bgzss2(intmx), nchss1(intmx),nchss2(intmx), ijcss1
1654  +(intmx),ijcss2(intmx), pqssa1(intmx,4),pqssa2(intmx,4), pqssb1
1655  +(intmx,4),pqssb2(intmx,4)
1656  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
1657  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
1658  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
1659  COMMON /ncshxx/ncouxh,ncouxt
1660  common/intneu/ndzsu,nzdsu
1661  COMMON /vxsvd/vxsp(50),vxst(50),vxsap(50),vxsat(50),
1662  * vxvp(50),vxvt(50),vxdp(50),vxdt(50),
1663  * nxsp,nxst,nxsap,nxsat,nxvp,nxvt,nxdp,nxdt
1664  COMMON /npartt/npart
1665  COMMON /zsea/zseaav,zseasu,anzsea
1666  DATA ncoush/0/
1667  DATA ncoust/0/
1668  DATA sundz /0/
1669  DATA sunzd /0/
1670  anzsea=0.d0
1671  zseasu=0.d0
1672  zseaav=0.d0
1673 C
1674  DO 5533 jj=1,intmx
1675  nchss1(jj)=0
1676  nchss2(jj)=0
1677  5533 CONTINUE
1678 C smoth transition between HADRIN and DPM
1679  ehadtw=ehadth-rndm(v)*2.d0
1680 C*******************************************************************"
1681 C
1682 C KINEMATICS
1683 C
1684 C********************************************************************
1685 C
1686  irej = 0
1687 *
1688  aam(26)=aam(23)
1689 C
1690  kproj=1
1691  IF(ijproj.NE.0) kproj=ijproj
1692  ktarg=1
1693  atnuc=it
1694  itn=it-itz
1695  apnuc=ip
1696  ipn=ip-ipz
1697  amproj =aam(kproj)
1698  amtar =aam(ktarg)
1699 * nucleon-nucleon cms
1700 C IBPROJ=1
1701  eproj=epn
1702  pproj = sqrt((epn-amproj)*(epn+amproj))
1703  umo = sqrt(amproj**2 + amtar**2 + 2.*amtar*eproj)
1704  gamcm = (eproj+amtar)/umo
1705  bgcm=pproj/umo
1706  ecm=umo
1707  pcm=gamcm*pproj - bgcm*eproj
1708 C
1709  IF(ipev.GE.1) print 1000,ip,ipz,it,itz,ijproj,ibproj, eproj,pproj,
1710  +amproj,amtar,umo,gamcm,bgcm
1711  1000 FORMAT(' ENTRY KKEVT'/ ' IP,IPZ,IT,ITZ,IJPROJ,IBPROJ',6i5/
1712  +' EPROJ,PPROJ,AMPROJ,AMTAR,UMO,GAMCM,BGCM'/10e12.3)
1713 
1714 C
1715 C**** CHANGE PARAMETERS FROM COMMON \INPDAT\
1716  as=0.5
1717  b8=0.4
1718 C CHAIN PT BIGGER THAN PARTICLE PT
1719  n9483=0
1720 * entry after rejection of an event because of kinematical reasons
1721 * several trials are made to realize a sampled Glauber event
1722  10 CONTINUE
1723  ndz=0
1724  nzd=0
1725  n9483=n9483+1
1726  IF (mod(n9483,125000).EQ.0) THEN
1727  WRITE(6,'(A,I5,A,I5,A)') ' KKEVT: Glauber event',numev,
1728  + ' rejected after', n9483, ' trials'
1729  WRITE(6, 1010) nn,np,nt
1730  WRITE(6,1020) irco1,irco2,irco3,irco4,irco5, irss11,irss12,
1731  + irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,
1732  + irvs13,irvs14, irvv11,irvv12,irvv13,irvv14
1733  n9483=1
1734  go to 20
1735  ELSEIF(n9483.GT.1) THEN
1736  goto 30
1737  ENDIF
1738  1010 FORMAT (5x,' N9483 LOOP - NN, NP, NT',5i10)
1739  1020 FORMAT (5x,' N9483 LOOP - REJECTION COUNTERS ',/,5i8/2(8i8/))
1740 C
1741 C***************************************************************
1742 C
1743 C SAMPLE NUMBERS OF COLLISION A LA SHMAKOV---------------
1744 C
1745 C TOTAL NUMBER OF INTERACTIONS = NN
1746 C NUMBER OF INTERACTING NUCLEONS
1747 C FROM PROJECTILE = NP
1748 C FROM TARGET = NT
1749 C
1750  ncoush=ncoush+1
1751  ncouxh=ncoush
1752  go to 2077
1753  20 CONTINUE
1754  22 CONTINUE
1755  ncoust=ncoust+1
1756  ncouxt=ncoust
1757  2077 CONTINUE
1758  CALL shmako(ip,it,bimp,nn,np,nt,jssh,jtsh,pproj,kkmat)
1759 C WRITE(6,*)' IP,IT,BIMP,NN,NP,NT ',IP,IT,BIMP,NN,NP,NT
1760  npart=np+nt
1761 ************ score characteristics of all sampled Glauber events
1762  CALL shmak(2,nn,np,nt,ip,it,ecm,bimp)
1763  nshmac=nshmac+1
1764  IF ((isingd.GE.2).AND.((nt.NE.1).OR.(nn.NE.1))) goto 22
1765 *
1766  IF (nn.GT.intmx) THEN
1767  WRITE (6,1030)nn,np,nt
1768  1030 FORMAT (.GT.' NNINTMX SHMAKO SET TO INTMX ',3i10)
1769  nn=intmx
1770  ENDIF
1771  nnshma=nn
1772  npshma=np
1773  ntshma=nt
1774 C CENTRAL PRODUCTION FOR ICENTR.EQ.1 or 2
1775  IF (ip.LT.it.AND.it.LE.150)THEN
1776  IF(ip.LE.8)THEN
1777  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.np.LT.ip-1)go to 20
1778  ELSEIF(ip.LE.16)THEN
1779  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.np.LT.ip-2)go to 20
1780  ELSEIF(ip.LT.32)THEN
1781  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.np.LT.ip-3)go to 20
1782  ELSEIF(ip.GE.32)THEN
1783 C Example S-Ag
1784  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.np.LT.ip-1)go to 20
1785  ENDIF
1786  ELSEIF (ip.LT.it.AND.it.GT.150)THEN
1787  IF(ip.LE.8)THEN
1788  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.np.LT.ip-1)go to 20
1789  ELSEIF(ip.LE.16)THEN
1790  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.np.LT.ip-2)go to 20
1791  ELSEIF(ip.LT.32)THEN
1792  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.np.LT.ip-3)go to 20
1793  ELSEIF(ip.GE.32)THEN
1794 C Example S-Au
1795  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.np.LT.ip)go to 20
1796  ENDIF
1797  ELSEIF(ip.EQ.it)THEN
1798  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.ip.EQ.32)THEN
1799 C Example S-S
1800  IF(np.LT.22.OR.nt.LT.22) go to 20
1801  ELSEIF ((icentr.EQ.1.OR.icentr.EQ.2).
1802  *and.(umo.GT.100.).AND.(np.LT.ip-ip/10))THEN
1803 C Example Pb-Pb central like at RHIC,LHC UMO .GT.100
1804  go to 20
1805  ELSEIF ((icentr.EQ.1.OR.icentr.EQ.2).
1806  *and.(umo.LT.100.).AND.(np.LT.ip-ip/4))THEN
1807 C Example Pb-Pb central like at SPS umo .LT.100
1808  go to 20
1809  ELSEIF ((icentr.EQ.3).AND.np.LT.ip-2*ip/3)THEN
1810 C Example Pb-Pb less central
1811  go to 20
1812  ENDIF
1813  ELSEIF(abs(ip-it).LT.3)THEN
1814  IF ((icentr.EQ.1.OR.icentr.EQ.2).AND.np.LT.ip-ip/8)go to 20
1815  ENDIF
1816  bimpac=bimp
1817 C PERIPHERAL PRODUCTION FOR ICENTR.EQ.10
1818  IF (icentr.EQ.10.AND.np.GT.6) go to 20
1819 C------------------------------------------------------------
1820 C Drop diffractive collisions out of the Glauber
1821 C cascade in nucleus-nucleus collisions (For NN > 1 only)
1822  IF((isingd.LE.1).AND.(nn.GE.2).AND.(ip.GE.2).AND.(it.GE.2).AND.
1823  *(ip.LE.200))THEN
1824  CALL dropdi(nn,np,nt,ecm)
1825  IF (ipev.GE.3) THEN
1826  WRITE(6, 1040) ip,ipz,it,itz,eproj,pproj,nn,np,nt
1827  WRITE (6,'(/A,2I5,1PE10.2,3I5)') ' KKEVT: IP,IT,BIMP,NN,NP,NT ',
1828  + ip,it,bimp,nn,np,nt
1829  WRITE (6,'(/2A)')
1830  + ' KKEVT: JSSH(KKK),JTSH(KKK),INTER1(KKK),INTER2(KKK),',
1831  + ' PKOO(3,KKK),TKOO(3,KKK)'
1832  itum=max(it,ip,nn)
1833  DO 4011 kkk=1,itum
1834  WRITE (6,'(4I5,6(1PE11.3))') jssh(kkk),jtsh(kkk),inter1(kkk),
1835  + inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),pkoo(3,kkk), tkoo(1,kkk),
1836  + tkoo(2,kkk),tkoo(3,kkk)
1837  4011 CONTINUE
1838  ENDIF
1839  ENDIF
1840 ************ score characteristics of all sampled Glauber events
1841  CALL shmak1(2,nn,np,nt,ip,it,ecm,bimp)
1842  nshma2=nshma2+1
1843 C------------------------------------------------------------
1844 C
1845 * entry for repeated trial to realize a sampled Glauber event
1846  30 CONTINUE
1847  IF (ipev.GE.3) THEN
1848  WRITE(6, 1040) ip,ipz,it,itz,eproj,pproj,nn,np,nt
1849  1040 FORMAT (' 752 FORM ',4i10,2f10.3,5i10)
1850  WRITE (6,'(/A,2I5,1PE10.2,3I5)') ' KKEVT: IP,IT,BIMP,NN,NP,NT ',
1851  + ip,it,bimp,nn,np,nt
1852  WRITE (6,'(/2A)')
1853  + ' KKEVT: JSSH(KKK),JTSH(KKK),INTER1(KKK),INTER2(KKK),',
1854  + ' PKOO(3,KKK),TKOO(3,KKK)'
1855  itum=max(it,ip,nn)
1856  DO 40 kkk=1,itum
1857  WRITE (6,'(4I5,6(1PE11.3))') jssh(kkk),jtsh(kkk),inter1(kkk),
1858  + inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),pkoo(3,kkk), tkoo(1,kkk),
1859  + tkoo(2,kkk),tkoo(3,kkk)
1860 
1861  40 CONTINUE
1862  ENDIF
1863 C
1864 C-----------------------------------------------------------------------
1865 C STORE PROJECTILE HADRON/NUCLEONS INTO /HKKEVT/
1866 C - PROJECTILE CENTRE AT ORIGIN IN SPACE
1867 C - TARGET SHIFTED IN X DIRECTION BY
1868 C IMPACT PARAMETER 'BIMP'
1869 C
1870 C - SAMPLING OF NUCLEON TYPES
1871 C - CONSISTENCY CHECK
1872 C FOR SAMPLED P/N NUMBERS
1873 C - INTERACTING PROJECTILES ISTHKK=11
1874 C NONINTERACTING ... ISTHKK=13
1875 C - FERMI MOMENTA IN CORRESP. REST SYSTEM
1876 C-----------
1877  nhkk=0
1878 C
1879  ncpp=0
1880  ncpn=0
1881 C DEFINE FERMI MOMENTA/ENERGIES FOR PROJECTILE
1882 C
1883  pxfe=0.0
1884  pyfe=0.0
1885  pzfe=0.0
1886  DO 50 kkk=1,ip
1887  nhkk=nhkk+1
1888  IF (nhkk.EQ.nmxhkk)THEN
1889  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
1890  RETURN
1891  ENDIF
1892  IF (jssh(kkk).GT.0) THEN
1893  isthkk(nhkk)=11
1894  ELSE
1895  isthkk(nhkk)=13
1896  ENDIF
1897 C*
1898 C CHANGED 28.2.90.J.R.
1899 C IF(IJPROJ.EQ.0) THEN
1900  IF(ip.GE.2) THEN
1901 C
1902  frpneu=float(ipn)/apnuc
1903  samtes=rndm(v)
1904  IF(samtes.LT.frpneu.AND.ncpn.LT.ipn) THEN
1905  kproj=8
1906  ncpn=ncpn + 1
1907  ELSEIF(samtes.GE.frpneu.AND.ncpp.LT.ipz) THEN
1908  kproj=1
1909  ncpp=ncpp + 1
1910  ELSEIF(ncpn.LT.ipn) THEN
1911  kproj=8
1912  ncpn=ncpn + 1
1913  ELSEIF(ncpp.LT.ipz) THEN
1914  kproj=1
1915  ncpp=ncpp + 1
1916  ENDIF
1917 C
1918  IF(kproj.EQ.1) THEN
1919  pferm = prmfep
1920  ELSE
1921  pferm = prmfen
1922  ENDIF
1923 C CALL FER4M(PFERM,FPX,FPY,FPZ,FE,KPROJ)
1924  CALL fer4mp(ip,pferm,fpx,fpy,fpz,fe,kproj)
1925  pxfe=pxfe + fpx
1926  pyfe=pyfe + fpy
1927  pzfe=pzfe + fpz
1928  phkk(1,nhkk)=fpx
1929  phkk(2,nhkk)=fpy
1930  phkk(3,nhkk)=fpz
1931  phkk(4,nhkk)=fe
1932  phkk(5,nhkk)=aam(kproj)
1933 C
1934  ELSE
1935  kproj=ijproj
1936  phkk(1,nhkk)=0.
1937  phkk(2,nhkk)=0.
1938  phkk(3,nhkk)=0.
1939  phkk(4,nhkk)=aam(kproj)
1940  phkk(5,nhkk)=aam(kproj)
1941  ENDIF
1942 C
1943  kkproj(kkk)=kproj
1944  idhkk(nhkk)=mpdgha(kproj)
1945  jmohkk(1,nhkk)=0
1946  jmohkk(2,nhkk)=0
1947  jdahkk(1,nhkk)=0
1948  jdahkk(2,nhkk)=0
1949 C
1950  phkk(5,nhkk)=aam(kproj)
1951  vhkk(1,nhkk)=pkoo(1,kkk)*1.e-12
1952  vhkk(2,nhkk)=pkoo(2,kkk)*1.e-12
1953  vhkk(3,nhkk)=pkoo(3,kkk)*1.e-12
1954  vhkk(4,nhkk)=0.
1955  whkk(1,nhkk)=pkoo(1,kkk)*1.e-12
1956  whkk(2,nhkk)=pkoo(2,kkk)*1.e-12
1957  whkk(3,nhkk)=pkoo(3,kkk)*1.e-12
1958  whkk(4,nhkk)=0.
1959  jhkknp(kkk)=nhkk
1960 C
1961  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
1962  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
1963  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
1964 
1965  1050 FORMAT (i6,i4,5i6,9e10.2)
1966 C
1967  50 CONTINUE
1968 C balance Sampled Fermi momenta
1969  IF(ip.GE.2) THEN
1970  pxfe=pxfe/ip
1971  pyfe=pyfe/ip
1972  pzfe=pzfe/ip
1973  DO 60 kkk=1,ip
1974  ihkk=kkk
1975  phkk(1,ihkk)=phkk(1,ihkk) - pxfe
1976  phkk(2,ihkk)=phkk(2,ihkk) - pyfe
1977  phkk(3,ihkk)=phkk(3,ihkk) - pzfe
1978  phkk(4,ihkk)=sqrt(phkk(5,ihkk)** 2+ phkk(1,ihkk)** 2+ phkk
1979  + (2,ihkk)** 2+ phkk(3,ihkk)**2)
1980  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
1981  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
1982  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
1983  60 CONTINUE
1984  ENDIF
1985 C
1986 C-----------------------------------------------------------------------
1987 C STORE TARGET HADRON/NUCLEONS INTO /HKKEVT/
1988 C - PROJECTILE CENTRE AT ORIGIN IN SPACE
1989 C - TARGET SHIFTED IN X DIRECTION BY
1990 C IMPACT PARAMETER 'BIMP'
1991 C
1992 C - SAMPLING OF NUCLEON TYPES
1993 C - CONSISTENCY CHECK
1994 C FOR SAMPLED P/N NUMBERS
1995 C - INTERACTING TARGETS ISTHKK=12
1996 C NONINTERACTING ... ISTHKK=14
1997 C-----------
1998 C---------------------
1999  nhadri=0
2000  nctp=0
2001  nctn=0
2002 C
2003  txfe=0.0
2004  tyfe=0.0
2005  tzfe=0.0
2006  DO 70 kkk=1,it
2007  nhkk=nhkk+1
2008  IF (nhkk.EQ.nmxhkk)THEN
2009  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
2010  RETURN
2011  ENDIF
2012  IF (jtsh(kkk).GT.0) THEN
2013  isthkk(nhkk)=12
2014  nhadri=nhadri+1
2015  IF (nhadri.EQ.1) ihtaww=nhkk
2016  IF (epn.LE.ehadtw) THEN
2017  IF (nhadri.GT.1) isthkk(nhkk)=14
2018  ENDIF
2019  ELSE
2020  isthkk(nhkk)=14
2021  ENDIF
2022  IF(it.GE.2)THEN
2023  frtneu=float(itn)/atnuc
2024  samtes=rndm(v)
2025  IF(samtes.LT.frtneu.AND.nctn.LT.itn) THEN
2026  ktarg=8
2027  nctn=nctn + 1
2028  ELSEIF(samtes.GE.frtneu.AND.nctp.LT.itz) THEN
2029  ktarg=1
2030  nctp=nctp + 1
2031  ELSEIF(nctn.LT.itn) THEN
2032  ktarg=8
2033  nctn=nctn + 1
2034  ELSEIF(nctp.LT.itz) THEN
2035  ktarg=1
2036  nctp=nctp + 1
2037  ENDIF
2038 C
2039  IF(ktarg.EQ.1) THEN
2040  pferm = tamfep
2041  ELSE
2042  pferm = tamfen
2043  ENDIF
2044 C CALL FER4M(PFERM,FPX,FPY,FPZ,FE,KTARG)
2045  CALL fer4mt(it,pferm,fpx,fpy,fpz,fe,ktarg)
2046  txfe=txfe + fpx
2047  tyfe=tyfe + fpy
2048  tzfe=tzfe + fpz
2049  phkk(1,nhkk)=fpx
2050  phkk(2,nhkk)=fpy
2051  phkk(3,nhkk)=fpz
2052  phkk(4,nhkk)=fe
2053  phkk(5,nhkk)=aam(ktarg)
2054  ELSE
2055  phkk(1,nhkk)=0.
2056  phkk(2,nhkk)=0.
2057  phkk(3,nhkk)=0.
2058  phkk(4,nhkk)=aam(ktarg)
2059  phkk(5,nhkk)=aam(ktarg)
2060  ENDIF
2061 C
2062  kktarg(kkk)=ktarg
2063  idhkk(nhkk)=mpdgha(ktarg)
2064  jmohkk(1,nhkk)=0
2065  jmohkk(2,nhkk)=0
2066  jdahkk(1,nhkk)=0
2067  jdahkk(2,nhkk)=0
2068  vhkk(1,nhkk)=(tkoo(1,kkk)+bimp)*1.e-12
2069  vhkk(2,nhkk)=tkoo(2,kkk)*1.e-12
2070  vhkk(3,nhkk)=tkoo(3,kkk)*1.e-12
2071  vhkk(4,nhkk)=0.
2072  whkk(1,nhkk)=(tkoo(1,kkk)+bimp)*1.e-12
2073  whkk(2,nhkk)=tkoo(2,kkk)*1.e-12
2074  whkk(3,nhkk)=tkoo(3,kkk)*1.e-12
2075  whkk(4,nhkk)=0.
2076  jhkknt(kkk)=nhkk
2077 C
2078  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
2079  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
2080  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
2081 
2082 C
2083  70 CONTINUE
2084 C balance Sampled Fermi momenta
2085  IF(it.GE.2) THEN
2086  tasuma=itz*aam(1) + (it-itz)*aam(8)
2087  tasubi=0.0
2088  tamasu=0.0
2089  txfe=txfe/it
2090  tyfe=tyfe/it
2091  tzfe=tzfe/it
2092  DO 80 kkk=1,it
2093  ihkk=kkk + ip
2094  phkk(1,ihkk)=phkk(1,ihkk) - txfe
2095  phkk(2,ihkk)=phkk(2,ihkk) - tyfe
2096  phkk(3,ihkk)=phkk(3,ihkk) - tzfe
2097  phkk(4,ihkk)=sqrt(phkk(5,ihkk)** 2+ phkk(1,ihkk)** 2+ phkk
2098  + (2,ihkk)** 2+ phkk(3,ihkk)**2)
2099  itsec=mcihad(idhkk(ihkk))
2100  tasubi=tasubi + phkk(4,ihkk) - phkk(5,ihkk) - taepot(itsec)
2101  tamasu=tamasu + phkk(4,ihkk) - taepot(itsec)
2102  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
2103  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2104  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2105  80 CONTINUE
2106 C*** definition of initial state
2107  tabi=-ebind(it,itz)
2108  tama=(it-itz)*aam(8) + itz*aam(1) + tabi
2109  taimma=tama - tamasu
2110  ENDIF
2111 C
2112  IF(ipev.GT.3) THEN
2113  WRITE(6,'(/A/5X,A/5X,4(1PE11.3))') ' KKEVT: FERMI MOMENTA',
2114  + 'PRMFEP,PRMFEN, TAMFEP,TAMFEN', prmfep,prmfen, tamfep,tamfen
2115 
2116  ENDIF
2117 C-----------------------------------------------------------------------
2118  iflagd = 0
2119 C-----------------------------------------------------------------
2120 C
2121 C Test j.r. 2/94
2122 C
2123 C----------------------------------------------------------------
2124  iqqdd=0
2125  IF(ipev.GT.3) THEN
2126  WRITE(6,'(A,4I5)')' KKEVT before SDIFF',np,nt,nn,isingd
2127  ENDIF
2128  IF ((np.EQ.1).AND.(nt.EQ.1).AND.(nn.EQ.1)
2129 C Diffraction als for A-B collisions j.r. 2.2.99
2130 C &.AND.((IP.EQ.1).OR.(IT.EQ.1))
2131  &.AND.(epn.GT.ehadtw))
2132  & CALL sdiff(eproj,pproj,kproj,nhkkh1,iqqdd)
2133 C----------------------------------------------------------------
2134  IF (iflagd.EQ.1) RETURN
2135 *
2136 C----------------------------------------------------------------------
2137 C
2138 C******************************** SAMPLE THE X FRACTIONS
2139 C OF INTERACTING NUCLEONS / HADRONS
2140 C
2141  IF (epn.LE.ehadtw) THEN
2142  7107 CONTINUE
2143  itta=mcihad(idhkk(ihtaww))
2144  IF(ipev.GT.1) THEN
2145  WRITE(6,'(A,I5,2F10.3)')' HADRIN CALL, IREJFO=',irejfo, ehadtw
2146  * ,ehadth
2147  ENDIF
2148  CALL hadhad(epn,ppn,nhkkh1,ihtaww,itta,irejfo)
2149  IF(irejfo.EQ.1) go to 7107
2150 C Transform into cms
2151  DO 111 i=nhkkh1+1,nhkk
2152  pznn=phkk(3,i)
2153  enn=phkk(4,i)
2154  phkk(3,i)=gamcm*pznn-bgcm*enn
2155  phkk(4,i)=gamcm*enn-bgcm*pznn
2156  111 CONTINUE
2157 
2158  go to 110
2159  ENDIF
2160 C-----------------------------------------------------------------------
2161 C
2162 C********************* SAMPLE THE FLAVORS OF INTERACTING
2163 C PROJECTILE AND TARGET HADRONS/NUCLEONS
2164 C first run sea quarks
2165  CALL flksaa(nn,ecm)
2166 C
2167  CALL xksamp(nn,ecm)
2168  DO 90 n=1,nss
2169  inloss(n)=.true.
2170  90 CONTINUE
2171  IF(ipev.GE.6)WRITE(6,*)' KKEVT ,NSS,NVS,NSV,NVV,NDS,NSD,NDV,NVD ',
2172  *' after XKSAMP ',
2173  *nss,nvs,nsv,nvv,nds,nsd,ndv,nvd
2174 C
2175  IF (ipev.GE.6) THEN
2176  itum=max0(ip,it,nn)
2177  WRITE(6,'(A,I10)')' KKEVT ITUM loop limit',itum
2178  WRITE(6,'(A,2A)') ' KKEVT (AFTER XKSAMP):',
2179  + ' JSSH, JSSHS, JTSH, JTSHS, INTER1, INTER2',
2180  + ' PKOO(1),PKOO(2),PKOO(3), TKOO(1),TKOO(2),TKOO(3)'
2181  DO 100 kkk=1,itum
2182  WRITE (6,'(6I5,6(1PE11.3))') jssh(kkk),jsshs(kkk),jtsh(kkk),
2183  + jtshs(kkk), inter1(kkk),inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),
2184  + pkoo(3,kkk), tkoo(1,kkk),tkoo(2,kkk),tkoo(3,kkk)
2185 
2186 
2187  100 CONTINUE
2188  ENDIF
2189 C-----------------------------------------------------------------------
2190 C
2191 C********************* SAMPLE THE FLAVORS OF INTERACTING
2192 C PROJECTILE AND TARGET HADRONS/NUCLEONS
2193 C second run valence quarks
2194  IF(ipev.GE.6)WRITE(6,*)' KKEVT ,NSS,NVS,NSV,NVV,NDS,NSD,NDV,NVD ',
2195  *nss,nvs,nsv,nvv,nds,nsd,ndv,nvd
2196  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before flksam'
2197  CALL flksam
2198 C IPEV=8
2199  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after flksam'
2200 
2201  1012 FORMAT(' XKSAMP:',
2202  +' I,XPVQ(I),XPVD(I),IFROVP(I),ITOVP(I),ZUOVP(I),KKPROJ(I)')
2203  1022 FORMAT(i5,2e15.5,2i5,l5,i5)
2204  1032 FORMAT(' XKSAMP : I,XPSQ(I),XPSAQ(I),IFROSP(I),ZUOSP(I)')
2205  1042 FORMAT(i5,2e15.5,i5,l5)
2206  1060 FORMAT(' XKSAMP : I,XTSQ(I),XTSAQ(I),IFROST(I),ZUOST(I)')
2207  1052 FORMAT(' XKSAMP:',
2208  +' I,XTVQ(I),XTVD(I),IFROVT(I),ITOVT(I),ZUOVT(I),KKTARG(I)')
2209 C COMMON /IFROTO/ IFROVP(248),ITOVP(248),IFROSP(INTMX), IFROVT(248),
2210 C +ITOVT(248),IFROST(INTMX),JSSHS(INTMX),JTSHS(INTMX),JHKKNP(248),
2211 C +JHKKNT
2212 C +(248), JHKKPV(INTMX),JHKKPS(INTMX), JHKKTV(INTMX),JHKKTS(INTMX),
2213 C +MHKKVV(INTMX),MHKKSS(INTMX), MHKKVS(INTMX),MHKKSV(INTMX),
2214 C & MHKKHH(INTMX),
2215 C +MHKKDV(248),MHKKVD(248), MHKKDS(INTMD),MHKKSD(INTMD)
2216 C
2217  DO 511 i=1,ixpv
2218  iipv=1+xpvq(i)/0.02d0
2219  vxvp(iipv)=vxvp(iipv)+1.d0
2220  iipd=1+xpvd(i)/0.02d0
2221  vxdp(iipd)=vxdp(iipd)+1.d0
2222  nxvp=nxvp+1
2223  nxdp=nxdp+1
2224  511 CONTINUE
2225  DO 521 i=1,ixps
2226  iips=1+xpsq(i)/0.02d0
2227  vxsp(iips)=vxsp(iips)+1.d0
2228  iipa=1+xpsaq(i)/0.02d0
2229  vxsap(iipa)=vxsap(iipa)+1.d0
2230  nxsp=nxsp+1
2231  nxsap=nxsap+1
2232  521 CONTINUE
2233  DO 531 i=1,ixtv
2234  iitv=1+xtvq(i)/0.02d0
2235  vxvt(iitv)=vxvt(iitv)+1.d0
2236  iitd=1+xtvd(i)/0.02d0
2237  vxdt(iitd)=vxdt(iitd)+1.d0
2238  nxvt=nxvt+1
2239  nxdt=nxdt+1
2240  531 CONTINUE
2241  DO 541 i=1,ixts
2242  iits=1+xtsq(i)/0.02d0
2243  vxst(iits)=vxst(iits)+1.d0
2244  iita=1+xtsaq(i)/0.02d0
2245  vxsat(iita)=vxsat(iita)+1.d0
2246  nxst=nxst+1
2247  nxsat=nxsat+1
2248  541 CONTINUE
2249  IF(ipco.GE.1)THEN
2250  WRITE(6,'(A)')
2251  + ' XKSAMP : FINAL X-VALUES AFTER POTENTIAL CORRECTION'
2252  WRITE(6,1012)
2253  DO 510 i=1,ixpv
2254  WRITE(6,1022) i,xpvq(i),xpvd(i),ifrovp(i),itovp(i),zuovp(i)
2255  WRITE(6,*)' I(1-IXPV),IPVQ(I),IPPV1(I),IPPV2(I)JHKKPV(I) ',
2256  * i,ipvq(i),ippv1(i),ippv2(i),jhkkpv(i)
2257  510 CONTINUE
2258  WRITE(6,1032)
2259  DO 520 i=1,ixps
2260  WRITE(6,1042) i,xpsq(i),xpsaq(i),ifrosp(i),zuosp(i)
2261  WRITE(6,*)' I(1-IXPS),IPSQ(I),IPSAQ(I ),JHKKPS(I) ',
2262  * i,ipsq(i),ipsaq(i),jhkkps(i)
2263  520 CONTINUE
2264  WRITE(6,1052)
2265  DO 530 i=1,ixtv
2266  WRITE(6,1022) i,xtvq(i),xtvd(i),ifrovt(i),itovt(i),zuovt(i)
2267  WRITE(6,*)' I(1-IXTV),ITVQ(I),ITTV1(I),ITTV2(I),JHKKTV(I) ',
2268  * i,itvq(i),ittv1(i),ittv2(i),jhkktv(i)
2269  530 CONTINUE
2270  WRITE(6,1060)
2271  DO 540 i=1,ixts
2272  WRITE(6,1042) i,xtsq(i),xtsaq(i),ifrost(i),zuost(i)
2273  WRITE(6,*)' I(1-IXTS),ITSQ(I),ITSAQ(I),JHKKTS(I) ',
2274  * i,itsq(i),itsaq(i),jhkkts(i)
2275  540 CONTINUE
2276  ENDIF
2277  IF(ipev.GE.6)WRITE(6,'(A,6I5)')
2278  *' XKSAMP NSV,NDV,NVS,NVD',
2279  + nsv,ndv,nvs,nvd
2280 C IPEV=-1
2281 C
2282 C-------------------------
2283 C TRANSFORM MOMENTA OF INTERACTING NUCLEONS
2284 C (INCLUDING FERMI MOMENTA FROM NUCLEUS REST FRAMES)
2285 C INTO NUCLEON-NUCLEON CMS (DEFINED WITHOUT FERMI MOM.
2286  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before NUCMOM'
2287  DO 7745 ihkk=1,nhkk
2288  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
2289  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
2290  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2291  7745 CONTINUE
2292  CALL nucmom
2293  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after NUCMOM'
2294  nonust=0
2295  nonujt=0
2296  nomje=0
2297  nomjer=0
2298  IF(ipev.GE.6)WRITE(6,*)' KKEVT ,NSS,NVS,NSV,NVV,NDS,NSD,NDV,NVD ',
2299  *nss,nvs,nsv,nvv,nds,nsd,ndv,nvd
2300 C
2301 C-----------------------------------------------------------------------
2302 C
2303 C NOTE: THE FOLLOWING TREATMENT OF CHAIN SYSTEMS
2304 C **** GENERALLY STARTS FROM THE NUCLEON-NUCLEON CMS
2305 C (DEFINED WITHOUT FERMI MOMENTA)
2306 C------------------------- TREATMENT OF SEA-SEA CHAIN SYSTEMS
2307  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVSS, NSS',nss
2308  IF(nss.GT.0) CALL kkevss
2309  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVSS'
2310 C
2311 C----------------- TREATMENT OF sea diquark - sea CHAIN SYSTEMS
2312  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVDS, NDS',nds
2313 C IF(NDS.GT.0 .AND. LSEADI) THEN
2314  IF(nds.GT.0) THEN
2315  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before KKEVDS'
2316  IF(idiqua.EQ.1) CALL kkevds(irejds)
2317  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVDS'
2318 C IPEV=1
2319  IF (irejds.EQ.1) go to 10
2320  ENDIF
2321 C
2322 C
2323 C----------------- TREATMENT OF sea - sea-diquark CHAIN SYSTEMS
2324  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVSD NSD',nsd
2325 C IF(NSD.GT.0 .AND. LSEADI) THEN
2326  IF(nsd.GT.0) THEN
2327  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before KKEVSD'
2328  IF(idiqua.EQ.1) CALL kkevsd(irejsd)
2329  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVSD'
2330 C IPEV=1
2331  IF (irejsd.EQ.1) go to 10
2332  ENDIF
2333 C
2334 C
2335 C------------------------- TREATMENT OF SEA-VALENCE CHAIN SYSTEMS
2336 C IPEV=6
2337  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVSV, NSV',nsv
2338  IF(nsv.GT.0) THEN
2339  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before KKEVSV'
2340  CALL kkevsv(irejsv)
2341  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVSV'
2342 C IPEV=1
2343  IF (irejsv.EQ.1) go to 10
2344  ENDIF
2345 C
2346 C----------------- TREATMENT OF sea diquark - VALENCE CHAIN SYSTEMS
2347  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVDV, NDV',ndv
2348 C IF(NDV.GT.0 .AND. LSEADI) THEN
2349  IF(ndv.GT.0) THEN
2350  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before KKEVDV'
2351  IF(idiqua.EQ.1) CALL kkevdv(irejdv)
2352  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVDV'
2353 C IPEV=1
2354  IF (irejdv.EQ.1) go to 10
2355  ENDIF
2356 C
2357 C------------------------- TREATMENT OF VALENCE-SEA CHAIN SYSTEMS
2358 C IPEV=6
2359  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVVS, NVS',nvs
2360  IF(nvs.GT.0) THEN
2361  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before KKEVVS'
2362  CALL kkevvs(irejvs)
2363  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVVS'
2364 C IPEV=1
2365  IF (irejvs.EQ.1) go to 10
2366  ENDIF
2367 C
2368 C----------------- TREATMENT OF valence - sea diquark CHAIN SYSTEMS
2369  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVVD,NVD',nvd
2370 C IF(NVD.GT.0 .AND. LSEADI) THEN
2371  IF(nvd.GT.0) THEN
2372  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before KKEVVD'
2373  IF(idiqua.EQ.1) CALL kkevvd(irejvd)
2374  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVVD'
2375 C IPEV=1
2376  IF (irejvd.EQ.1) go to 10
2377  ENDIF
2378 C
2379 C------------------- TREATMENT OF VALENCE-VALENCE CHAIN SYSTEMS
2380 C
2381  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVVV, NVV',nvv
2382  CALL kkevvv(irejvv,ibproj)
2383  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVVV'
2384 C & IPVQ,IPPV1,IPPV2,ITVQ,ITTV1,ITTV2)
2385  IF (irejvv.EQ.1) go to 10
2386 C DO 5004 IHKK=1,NHKK
2387 C IF (IPHKK.GE.1) WRITE(6,5001)
2388 C * IHKK,ISTHKK(IHKK),IDHKK(IHKK),JMOHKK(1,IHKK),JMOHKK(2,IHKK),
2389 C & JDAHKK(1,IHKK),JDAHKK(2,IHKK),(PHKK(KHKK,IHKK),KHKK=1,5),
2390 C & (VHKK(KHKK,IHKK),KHKK=1,4)
2391 C5004 CONTINUE
2392 C
2393 
2394 C
2395 C------------------- TREATMENT OF HARD CHAIN SYSTEMS
2396 C
2397  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVHH, NHH',nhh
2398  IF (iminij.EQ.1) CALL kkevhh
2399  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVHH'
2400  IF(ipev.GE.6)WRITE(6,*)' KKEVT before KKEVZZ, NZZ',nzz
2401  CALL kkevzz
2402  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after KKEVZZ'
2403  nomjt=nomjt+nomje
2404  nomjtr=nomjtr+nomjer
2405  ievi=ievi+1
2406 C IF(IEVI.LE.20)WRITE (6,7233)NOMJE,NOMJER,NREJEV,NOMJT,NOMJTR
2407 C7233 FORMAT ( ' NOMJE,NOMJER,NREJEV,NOMJT,NOMJTR ',5I10)
2408  DO 7787 iii=1,nonujt
2409  IF (ijjq1(iii).EQ.0.OR.ijjaq1(iii).EQ.0)THEN
2410  WRITE (6,7786)iii,jhkkex(iii),ijjq1(iii),ijjaq1(iii),
2411  * amjch1(iii)
2412  7786 FORMAT(' KKEVHH: III,JHKKEX,IJJQ1,IJJAQ1,AMCH1 ',4i10,f10.3)
2413  jhkkex(iii)=0
2414  ENDIF
2415  7787 CONTINUE
2416 C-------------------------------------------------------------------
2417 C
2418 C COMBINE JETS
2419 C
2420 C------------------------------------------------------------------
2421 C IF(IPEV.GE.1)WRITE(6,*)' KKEVT before KKEVCC',LCOMBI
2422 C IF(LCOMBI) CALL KKEVCC(NN,IP,IT)
2423 C IF(IPEV.GE.6)WRITE(6,'(A)')' KKEVT after KKEVCC'
2424 C----------------------------------------------------------------------
2425 C - TEST OF ENERGY MOMENTUM CONSERVATION ON NIVEAU OF CHAINS
2426 C AND ON NIVEAU OF CHAIN ENDS
2427  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before EVTEST'
2428 C IF(IPEV.GE.1)CALL EVTEST(IREJ)
2429  CALL evtest(irej)
2430  IF (ipev.GE.1) THEN
2431  WRITE(6,'(/A/)') ' KKEVT: FINAL LIST OF ENTRIES TO /HKKEVT/'
2432  DO 121 ihkk=1,nhkk
2433  WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
2434  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
2435  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2436 
2437  121 CONTINUE
2438  ENDIF
2439  IF (irej.EQ.1)THEN
2440  IF(ipev.GE.1)WRITE(6,'(A)')' EVTEST REJECTION would be '
2441  irej=0
2442  IF (irej.EQ.1)go to 10
2443  ENDIF
2444  IF(ipev.GE.1)WRITE(6,'(A)')' KKEVT after EVTEST'
2445 C
2446 C-----------------------------------------------------------------------
2447 C CONSTRUCT HISTOGRAMS FROM PARTONS ON CHAIN ENDS
2448 C
2449 C IF(IPADIS) CALL DISTPA(2)
2450 C
2451 C-----------------------------------------------------------------------
2452 C - HADRONIZATION OF CHAINS (HADRKK)
2453 C AND BACK TRANSFORMATION FROM NN-CMS INTO LAB (HADRKK)
2454 C
2455  IF(ipev.GE.1)WRITE(6,'(A)')' KKEVT long before HADRKK'
2456  IF(ihada.OR.ihadss.OR.ihadsv.OR.ihadvs.OR.ihadvv) THEN
2457  IF(ipev.GE.1)WRITE(6,'(A)')' KKEVT before HADRKK'
2458  CALL hadrkk(nhkkh1,ppn)
2459  IF(ipev.GE.1)WRITE(6,'(A)')' KKEVT after HADRKK'
2460  ENDIF
2461 C
2462  110 CONTINUE
2463 C
2464 C Correct HKKEVT COMMON
2465 C ONLY FOR RUNS WITHOUT EVAPORATION
2466 C IF((IEVAP.EQ.0).AND.(KTAUGE.EQ.0))CALL CORRCO
2467 C not for runs with hadhad
2468  IF (epn.GE.ehadtw) THEN
2469  CALL corrco
2470  ENDIF
2471 C
2472 C Trigger ICENTR=8 NCH > 5 (NA35 p-S data)
2473  iiich=0
2474  IF (icentr.EQ.8)THEN
2475  DO 128 ihkk=1,nhkk
2476  IF(isthkk(ihkk).EQ.1)THEN
2477  nrhkk=mcihad(idhkk(ihkk))
2478  ichhkk=iich(nrhkk)
2479  IF(ichhkk.NE.0)THEN
2480 C PTT=PHKK(1,IHKK)**2+PHKK(2,IHKK)**2+0.000001
2481 C AMT=SQRT(PTT+PHKK(5,IHKK)**2)
2482 C YL=LOG((ABS(PHKK(3,IHKK) + PHKK(4,IHKK)))/AMT+1.E-18)
2483 C IF(YL.GT.0.6D0.AND.YL.LT.7.D0)THEN
2484  iiich=iiich+1
2485 C ENDIF
2486  ENDIF
2487  ENDIF
2488  128 CONTINUE
2489  IF(iiich.LE.14)THEN
2490  WRITE(6,*)' reject ',iiich
2491  go to 22
2492  ENDIF
2493  WRITE(6,*)' no reject ',iiich
2494  ENDIF
2495 C
2496  IF (ipev.GE.1) THEN
2497  WRITE(6,'(/A/)') ' KKEVT: FINAL LIST OF ENTRIES TO /HKKEVT/'
2498  DO 120 ihkk=1,nhkk
2499  WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
2500  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
2501  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
2502 
2503  120 CONTINUE
2504  ENDIF
2505 C
2506  sundz=sundz+ndz
2507  sunzd=sunzd+nzd
2508  nzdsu=sunzd
2509  ndzsu=sundz
2510  IF(ipev.GE.6)WRITE(6,*)' END KKEVT NZD,NZDSU,NDZ,NDZSU',
2511  * nzd,nzdsu,ndz,ndzsu
2512  RETURN
2513  END
2514 *-- Author :
2515 C
2516 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2517 C
2518  SUBROUTINE kkevvv(IREJVV,NBPROJ)
2519  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2520  SAVE
2521 C & IPVQ,IPPV1,IPPV2,ITVQ,ITTV1,ITTV2)
2522 C
2523 C------------------- TREATMENT OF VALENCE-VALENCE CHAIN SYSTEMS
2524 C
2525 C
2526 *KEEP,NNCMS.
2527  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
2528 *KEEP,HKKEVT.
2529 c INCLUDE (HKKEVT)
2530  parameter(nmxhkk= 89998)
2531 c PARAMETER (NMXHKK=25000)
2532  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
2533  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
2534  +(4,nmxhkk)
2535 C
2536 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
2537 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
2538 C THE POSITIONS OF THE PROJECTILE NUCLEONS
2539 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
2540 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
2541 C COMPLETELY CONSISTENT. THE TIMES IN THE
2542 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
2543 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
2544 C
2545 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
2546 C
2547 C NMXHKK: maximum numbers of entries (partons/particles) that can be
2548 C stored in the commonblock.
2549 C
2550 C NHKK: the actual number of entries stored in current event. These are
2551 C found in the first NHKK positions of the respective arrays below.
2552 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
2553 C entry.
2554 C
2555 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
2556 C = 0 : null entry.
2557 C = 1 : an existing entry, which has not decayed or fragmented.
2558 C This is the main class of entries which represents the
2559 C "final state" given by the generator.
2560 C = 2 : an entry which has decayed or fragmented and therefore
2561 C is not appearing in the final state, but is retained for
2562 C event history information.
2563 C = 3 : a documentation line, defined separately from the event
2564 C history. (incoming reacting
2565 C particles, etc.)
2566 C = 4 - 10 : undefined, but reserved for future standards.
2567 C = 11 - 20 : at the disposal of each model builder for constructs
2568 C specific to his program, but equivalent to a null line in the
2569 C context of any other program. One example is the cone defining
2570 C vector of HERWIG, another cluster or event axes of the JETSET
2571 C analysis routines.
2572 C = 21 - : at the disposal of users, in particular for event tracking
2573 C in the detector.
2574 C
2575 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
2576 C standard.
2577 C
2578 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
2579 C The value is 0 for initial entries.
2580 C
2581 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
2582 C one mother exist, in which case the value 0 is used. In cluster
2583 C fragmentation models, the two mothers would correspond to the q
2584 C and qbar which join to form a cluster. In string fragmentation,
2585 C the two mothers of a particle produced in the fragmentation would
2586 C be the two endpoints of the string (with the range in between
2587 C implied).
2588 C
2589 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
2590 C entry has not decayed, this is 0.
2591 C
2592 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
2593 C entry has not decayed, this is 0. It is assumed that the daughters
2594 C of a particle (or cluster or string) are stored sequentially, so
2595 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
2596 C daughters. Even in cases where only one daughter is defined (e.g.
2597 C K0 -> K0S) both values should be defined, to make for a uniform
2598 C approach in terms of loop constructions.
2599 C
2600 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
2601 C
2602 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
2603 C
2604 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
2605 C
2606 C PHKK(4,IHKK) : energy, in GeV.
2607 C
2608 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
2609 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
2610 C
2611 C VHKK(1,IHKK) : production vertex x position, in mm.
2612 C
2613 C VHKK(2,IHKK) : production vertex y position, in mm.
2614 C
2615 C VHKK(3,IHKK) : production vertex z position, in mm.
2616 C
2617 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
2618 C********************************************************************
2619 *KEEP,INTMX.
2620  parameter(intmx=2488,intmd=252)
2621 *KEEP,DXQX.
2622 C INCLUDE (XQXQ)
2623 * NOTE: INTMX set via INCLUDE(INTMX)
2624  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
2625  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
2626  * ,xpsu(248),xtsu(248)
2627  * ,xpsut(248),xtsut(248)
2628 *KEEP,INTNEW.
2629  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
2630  +ixpv,ixps,ixtv,ixts, intvv1(248),
2631  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
2632  +intss1(intmx),intss2(intmx),
2633  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
2634  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
2635 
2636 C /INTNEW/
2637 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
2638 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
2639 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
2640 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
2641 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
2642 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
2643 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
2644 C FROM PROJECTILE/TARGET NUCLEI
2645 C-------------------
2646 *KEEP,IFROTO.
2647  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
2648  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
2649  +jhkknt
2650  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
2651  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
2652  & mhkkhh(intmx),
2653  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
2654 *KEEP,LOZUO.
2655  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
2656  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
2657  +intlo(intmx),inloss(intmx)
2658 C /LOZUO/
2659 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
2660 C REJECTED IN KKEVT
2661 C------------------
2662 *KEEP,DIQI.
2663  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
2664  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
2665  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
2666  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
2667 *KEEP,TRAFOP.
2668  COMMON /trafop/ gamp,bgamp,betp
2669 *KEEP,NUCC.
2670  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
2671 *KEEP,NUCIMP.
2672  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
2673  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
2674  +prebin,taebin,fermod,etacou
2675 *KEEP,ABRVV.
2676  COMMON /abrvv/ amcvv1(248),amcvv2(248),gacvv1(248),gacvv2(248),
2677  +bgxvv1(248),bgyvv1(248),bgzvv1(248), bgxvv2(248),bgyvv2(248),
2678  +bgzvv2(248), nchvv1(248),nchvv2(248),ijcvv1(248),ijcvv2(248),
2679  +pqvva1(248,4),pqvva2(248,4), pqvvb1(248,4),pqvvb2(248,4)
2680 *KEEP,DROPPT.
2681  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
2682  +ishmal,lpauli
2683  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
2684  +ipadis,ishmal,lpauli
2685 *KEEP,NUCPOS.
2686  COMMON /nucpos/invvp(248),invvt(248),invsp(248),invst(248), nuvv,
2687  +nuvs,nusv,nuss,insvp(248),insvt(248),inssp(248),insst(248), isveap
2688  +(248),isveat(248),isseap(248),isseat(248), ivseap(248),ivseat
2689  +(248), islosp(248),islost(248),inoop(248),inoot(248),nuoo
2690 *KEEP,TAUFO.
2691  COMMON /taufo/ taufor,ktauge,itauve,incmod
2692 *KEEP,RTAR.
2693  COMMON /rtar/ rtarnu
2694 *KEEP,INNU.
2695  COMMON /innu/inudec
2696 *KEEP,DINPDA.
2697  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
2698  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
2699 *KEEP,FERMI.
2700  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
2701  +(4,248)
2702 *KEEP,KETMAS.
2703  COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
2704 *KEEP,DPAR.
2705 C /DPAR/ CONTAINS PARTICLE PROPERTIES
2706 C ANAME = LITERAL NAME OF THE PARTICLE
2707 C AAM = PARTICLE MASS IN GEV
2708 C GA = DECAY WIDTH
2709 C TAU = LIFE TIME OF INSTABLE PARTICLES
2710 C IICH = ELECTRIC CHARGE OF THE PARTICLE
2711 C IIBAR = BARYON NUMBER
2712 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
2713 C
2714  CHARACTER*8 aname
2715  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
2716  +iibar(210),k1(210),k2(210)
2717 C------------------
2718 *KEEP,DPRIN.
2719  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2720 *KEEP,NUCKOO.
2721  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
2722  +tpoo(3,intmx)
2723 *KEEP,REJEC.
2724  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
2725  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
2726  +irvs14, irvv11,irvv12,irvv13,irvv14
2727 *KEEP,PROJK.
2728  COMMON /projk/ iprojk
2729  common/rptshm/rproj,rtarg,bimpac
2730 *KEND.
2731 C
2732 C-----------------------------------------------------------------------
2733 C PARAMETER (INTMX=3988)
2734  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
2735  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
2736  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
2737  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
2738  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
2739  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
2740  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
2741  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
2742  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
2743  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
2744  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
2745  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
2746  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
2747  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
2748  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
2749  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
2750  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
2751  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
2752  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
2753  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
2754 C-----------------------------------------------------------------
2755 C-------------------------------Single Chain Option-----------
2756  COMMON /sincha/isicha
2757  COMMON /zsea/zseaav,zseasu,anzsea
2758  DATA isch/0/
2759  DATA nzsea/0/
2760  isch=isch+1
2761  zero=0
2762 C------------------------------Single Chain Option--------------------
2763  irejvv=0
2764 C
2765  iminij=1
2766  DO 20 n=1,nvv
2767 C
2768 C---------------------------drop recombined chain pairs
2769  IF(nchvv1(n).EQ.99.AND.nchvv2(n).EQ.99)go to 20
2770 C
2771 C
2772 C
2773  ixvpr=intvv1(n)
2774  inucpr=ifrovp(ixvpr)
2775 C
2776  ixvta=intvv2(n)
2777  inucta=ifrovt(ixvta)
2778 C
2779  xmax1=xpvq(ixvpr)+xpvd(ixvpr)-xvthr-xdthr
2780  xmax2=xtvq(ixvta)+xtvd(ixvta)-xvthr-xdthr
2781 C
2782 C
2783  IF(ipev.GE.1)WRITE(6,'(A,2I5,3F9.3)')' KKEVVV,bef xptfl:n,nvv'
2784  * ,n,nvv,xmax1,xmax2
2785  IF (iminij.EQ.1)THEN
2786  CALL xptfl(nhard,nsea,ireg,xmax1,xmax2)
2787 C NZSEA=NZSEA+1
2788 C ANZSEA=NZSEA
2789  anzsea=anzsea+1.d0
2790  zseasu=zseasu+nsea
2791  zseaav=zseasu/anzsea
2792  ENDIF
2793  IF(ipev.GE.1)WRITE(6,'(A,3I10)')' VV,xptfl:nhard,nsea,ireg '
2794  * ,nhard,nsea,ireg
2795  IF(ireg.EQ.1)nhard=0
2796  IF(ireg.EQ.1)nsea=0
2797  nomje=nomje+nhard
2798 C
2799 C SUBTRACT HARD SCATTERED X VALUES FROM DIQUARKS
2800 C
2801  IF (nhard.GE.1.AND.iminij.EQ.1)THEN
2802  DO 71 ixx=nonuj1,nonujt
2803  jhkkph(ixx)=ixvpr
2804  jhkkex(ixx)=0
2805  jhkke1(ixx)=0
2806  IF (xpvq(ixvpr)-xjq1(ixx).GT.xvthr)THEN
2807  xpvq(ixvpr)=xpvq(ixvpr)-xjq1(ixx)
2808  jhkke1(ixx)=1
2809  ELSEIF (xpvd(ixvpr)-xjq1(ixx).GT.xdthr)THEN
2810  xpvd(ixvpr)=xpvd(ixvpr)-xjq1(ixx)
2811  jhkke1(ixx)=2
2812  ENDIF
2813  71 CONTINUE
2814  ENDIF
2815 C
2816  IF(ipev.GE.1)THEN
2817  pqp=gamcm*prmom(3,inucpr)+bgcm*prmom(4,inucpr)
2818  pqe=gamcm*prmom(4,inucpr)+bgcm*prmom(3,inucpr)
2819  pqpq=gamcm*pvqpz+bgcm*pvqe
2820  pqeq=gamcm*pvqe+bgcm*pvqpz
2821  pqpd=gamcm*pvdqpz+bgcm*pvdqe
2822  pqed=gamcm*pvdqe+bgcm*pvdqpz
2823  WRITE(6,1655)prmom(3,inucpr),prmom(4,inucpr),pqp,pqe,
2824  + xpvq(ixvpr),xpvd(ixvpr),ixvpr
2825  WRITE(6,1656)pvqpz,pvqe,pqpq,pqeq
2826  WRITE(6,1657)pvdqpz,pvdqe,pqpd,pqed
2827  ENDIF
2828 C
2829 C
2830 C SUBTRACT HARD SCATTERED X VALUES FROM DIQUARKS
2831 C
2832  IF (nhard.GE.1.AND.iminij.EQ.1)THEN
2833  DO 771 ixx=nonuj1,nonujt
2834  jhkkth(ixx)=ixvta
2835  IF (jhkke1(ixx).EQ.0)THEN
2836  jhkkex(ixx)=0
2837  go to 771
2838  ENDIF
2839  IF (xtvq(ixvta)-xjq2(ixx).GT. xvthr) THEN
2840  xtvq(ixvta)=xtvq(ixvta)-xjq2(ixx)
2841  jhkkex(ixx)=1
2842  nomjer=nomjer+1
2843  ELSEIF(xtvd(ixvta)-xjq2(ixx).GT.xdthr)THEN
2844  xtvd(ixvta)=xtvd(ixvta)-xjq2(ixx)
2845  jhkkex(ixx)=1
2846  nomjer=nomjer+1
2847  ELSE
2848  jhkkex(ixx)=0
2849  IF (jhkke1(ixx).EQ.1)THEN
2850  xpvq(ixvpr)=xpvq(ixvpr)+xjq1(ixx)
2851  ELSEIF(jhkke1(ixx).EQ.2)THEN
2852  xpvd(ixvpr)=xpvd(ixvpr)+xjq1(ixx)
2853  ENDIF
2854  ENDIF
2855  771 CONTINUE
2856  ENDIF
2857 C
2858 C SUBTRACT SECONDARY SEA X VALUES FROM DIQUARKS
2859 C
2860  IF (nsea.GE.1)THEN
2861  IF(ipev.GE.1)WRITE(6,'(A,3I10)')' VV,NSEA:NONUS1,NONUST '
2862  * ,nsea,nonus1,nonust
2863  DO 271 ixx=nonus1,nonust
2864  jhkkpz(ixx)=ixvpr
2865  jhkksx(ixx)=0
2866  jhkks1(ixx)=0
2867  IF (xpvq(ixvpr)-xsq1(ixx)-xsaq1(ixx).GT.xvthr)THEN
2868  xpvq(ixvpr)=xpvq(ixvpr)-xsq1(ixx)-xsaq1(ixx)
2869  jhkks1(ixx)=1
2870  ELSEIF (xpvd(ixvpr)-xsq1(ixx)-xsaq1(ixx).GT.xdthr)THEN
2871  xpvd(ixvpr)=xpvd(ixvpr)-xsq1(ixx)-xsaq1(ixx)
2872  jhkks1(ixx)=2
2873  ENDIF
2874  271 CONTINUE
2875  ENDIF
2876 C
2877  ixvta=intvv2(n)
2878  inucta=ifrovt(ixvta)
2879 C
2880 C SUBTRACT SECONDARY SEA X VALUES FROM DIQUARKS
2881 C
2882  IF (nsea.GE.1)THEN
2883  DO 2771 ixx=nonus1,nonust
2884  jhkktz(ixx)=ixvta
2885  IF (jhkks1(ixx).EQ.0)THEN
2886  jhkksx(ixx)=0
2887  go to 2775
2888  ENDIF
2889  IF (xtvq(ixvta)-xsq2(ixx)-xsaq2(ixx).GT. xvthr) THEN
2890  xtvq(ixvta)=xtvq(ixvta)-xsq2(ixx)-xsaq2(ixx)
2891  jhkksx(ixx)=1
2892 C NOMJER=NOMJER+1
2893  ELSEIF(xtvd(ixvta)-xsq2(ixx)-xsaq2(ixx).GT.xdthr)THEN
2894  xtvd(ixvta)=xtvd(ixvta)-xsq2(ixx)-xsaq2(ixx)
2895  jhkksx(ixx)=1
2896 C NOMJER=NOMJER+1
2897  ELSE
2898  jhkksx(ixx)=0
2899  IF (jhkks1(ixx).EQ.1)THEN
2900  xpvq(ixvpr)=xpvq(ixvpr)+xsq1(ixx)+xsaq1(ixx)
2901  ELSEIF(jhkks1(ixx).EQ.2)THEN
2902  xpvd(ixvpr)=xpvd(ixvpr)+xsq1(ixx)+xsaq1(ixx)
2903  ENDIF
2904  ENDIF
2905  2775 CONTINUE
2906  IF(ipev.GE.1)WRITE(6,'(A,3I10)')' VV,ixx:jhkksx,jhkks1, '
2907  * ,ixx,jhkksx(ixx),jhkks1(ixx)
2908  2771 CONTINUE
2909  ENDIF
2910 Cx
2911 C
2912  xmax1=xpvq(ixvpr)+xpvd(ixvpr)-xvthr-xdthr
2913  xmax2=xtvq(ixvta)+xtvd(ixvta)-xvthr-xdthr
2914 C
2915 C
2916  IF(ipev.GE.1)WRITE(6,'(A,2I5,3F9.3)')' KKEVVV,aft xptfl:n,nvv'
2917  * ,n,nvv,xmax1,xmax2
2918 C-----------------------------------------------------------------------
2919  irejvv=0
2920 C
2921 C---------------------------drop recombined chain pairs
2922  IF(nchvv1(n).EQ.99.AND.nchvv2(n).EQ.99)go to 20
2923 C
2924 C*** 4-MOMENTA OF PROJECTILE QUARK-DIQUARK PAIRS IN NN-CMS
2925  ixvpr=intvv1(n)
2926  inucpr=ifrovp(ixvpr)
2927 C-------------------------------------Single Chain Option------
2928 C NSICHA=0 : Normal 2 chain event
2929 C NSICHA=1 : Single chain event
2930 C single chain Meson -Bayon : Chain 1 ( q-qq ) remains
2931 C single chain Abaryon-Baryon : Chain 2 (aqaq-qq) remains
2932  nsicha=0
2933  IF (isicha.EQ.1) THEN
2934  IF (nbproj.LE.0) THEN
2935 C Projectile particle
2936  is1=intvv1(n)
2937  is2=intvv2(n)
2938  khproj=kkproj(is1)
2939 C
2940 C Projectile Momentum(lab)
2941  pqp=gamcm*prmom(3,inucpr)+bgcm*prmom(4,inucpr)
2942  phproj=pqp
2943 C Original flavors
2944  iiqp=ipvq(is1)
2945  iidp1=ippv1(is1)
2946  iidp2=ippv2(is1)
2947  iiqt=itvq(is2)
2948  iidt1=ittv1(is2)
2949  iidt2=ittv2(is2)
2950 C Target particle
2951  iitsum=iiqt+iidt1+iidt2
2952  IF(iitsum.EQ.4)khtarg=1
2953  IF(iitsum.EQ.5)khtarg=8
2954 C KHTARG=KKTARG(IS2)
2955 C Single chain probability
2956  sichap=phnsch(khproj,khtarg,phproj)
2957  IF (rndm(v).LE.sichap)nsicha=1
2958 C IF (NBPROJ.EQ.-1)NSICHA=0
2959 C Single chain quark flavors
2960  aaaaa=schqua(jqfsc1,jqfsc2,jqbsc1,jqbsc2)
2961  IF(isch.LE.20)
2962  + WRITE(6,'(A,3I5,2F10.3,10I5)')' KKEVVV Single chain ',
2963  + nsicha,khproj,khtarg,phproj,sichap,
2964  + iiqp,iidp1,iidp2,iiqt,iidt1,iidt2,
2965  + jqfsc1,jqfsc2,jqbsc1,jqbsc2
2966  IF(nbproj.EQ.0.AND.nsicha.EQ.1)THEN
2967 C Correct x-values and quark flavors
2968  nchvv2(n)=99
2969  xpvq(ixvpr)=xpvq(ixvpr)+xpvd(ixvpr)
2970  xpvd(ixvpr)=0
2971  xtvd(ixvta)=xtvd(ixvta)+xtvq(ixvta)
2972  xtvq(ixvta)=0
2973 C IPVQ(IS1)=JQFSC1
2974  ittv1(is2)=jqbsc1
2975  ittv2(is2)=jqbsc2
2976  ELSEIF(nbproj.EQ.-1.AND.nsicha.EQ.1)THEN
2977 C Correct x-values and quark flavors
2978 C ?
2979  xpvd(ixvpr)=xpvq(ixvpr)+xpvd(ixvpr)
2980  xpvq(ixvpr)=0
2981  xtvd(ixvta)=xtvd(ixvta)+xtvq(ixvta)
2982  xtvq(ixvta)=0
2983  nchvv1(n)=99
2984  ippv1(is1)=jqfsc1
2985  ippv2(is1)=jqfsc2
2986  ittv1(is2)=jqbsc1
2987  ittv2(is2)=jqbsc2
2988  ENDIF
2989  ENDIF
2990  ENDIF
2991 C-------------------------------------Single Chain Option------
2992 C
2993  pvqpx=xpvq(ixvpr)*prmom(1,inucpr)
2994  pvqpy=xpvq(ixvpr)*prmom(2,inucpr)
2995  pvqpz=xpvq(ixvpr)*prmom(3,inucpr)
2996  pvqe =xpvq(ixvpr)*prmom(4,inucpr)
2997 C
2998  pvdqpx=xpvd(ixvpr)*prmom(1,inucpr)
2999  pvdqpy=xpvd(ixvpr)*prmom(2,inucpr)
3000  pvdqpz=xpvd(ixvpr)*prmom(3,inucpr)
3001  pvdqe =xpvd(ixvpr)*prmom(4,inucpr)
3002  IF(ipev.GE.1)THEN
3003  pqp=gamcm*prmom(3,inucpr)+bgcm*prmom(4,inucpr)
3004  pqe=gamcm*prmom(4,inucpr)+bgcm*prmom(3,inucpr)
3005  pqpq=gamcm*pvqpz+bgcm*pvqe
3006  pqeq=gamcm*pvqe+bgcm*pvqpz
3007  pqpd=gamcm*pvdqpz+bgcm*pvdqe
3008  pqed=gamcm*pvdqe+bgcm*pvdqpz
3009  WRITE(6,1655)prmom(3,inucpr),prmom(4,inucpr),pqp,pqe,
3010  + xpvq(ixvpr),xpvd(ixvpr),ixvpr
3011  1655 FORMAT(' vv PQP,PQE ',6f12.5,i5)
3012  WRITE(6,1656)pvqpz,pvqe,pqpq,pqeq
3013  1656 FORMAT(' vv PQPQ,PQEQ ',4f12.5)
3014  WRITE(6,1657)pvdqpz,pvdqe,pqpd,pqed
3015  1657 FORMAT(' vv PQPD,PQED ',4f12.5)
3016  ENDIF
3017 C
3018 C*** 4-MOMENTA OF TARGET QUARK-DIQUARK PAIRS IN NN-CMS
3019  ixvta=intvv2(n)
3020  inucta=ifrovt(ixvta)
3021 C
3022  tvqpx=xtvq(ixvta)*tamom(1,inucta)
3023  tvqpy=xtvq(ixvta)*tamom(2,inucta)
3024  tvqpz=xtvq(ixvta)*tamom(3,inucta)
3025  tvqe =xtvq(ixvta)*tamom(4,inucta)
3026 
3027 C
3028  tvdqpx=xtvd(ixvta)*tamom(1,inucta)
3029  tvdqpy=xtvd(ixvta)*tamom(2,inucta)
3030  tvdqpz=xtvd(ixvta)*tamom(3,inucta)
3031  tvdqe =xtvd(ixvta)*tamom(4,inucta)
3032  IF(ipev.GE.1)THEN
3033  tqp=gamcm*tamom(3,inucta)+bgcm*tamom(4,inucta)
3034  tqe=gamcm*tamom(4,inucta)+bgcm*tamom(3,inucta)
3035  tqpq=gamcm*tvqpz+bgcm*tvqe
3036  tqeq=gamcm*tvqe+bgcm*tvqpz
3037  tqpd=gamcm*tvdqpz+bgcm*tvdqe
3038  tqed=gamcm*tvdqe+bgcm*tvdqpz
3039  WRITE(6,1455)tamom(3,inucta),tamom(4,inucta),tqp,tqe
3040  1455 FORMAT(' vv TQP,TQE ',4f12.5)
3041  WRITE(6,1456)tvqpz,tvqe,tqpq,tqeq
3042  1456 FORMAT(' vv TQPQ,TQEQ ',4f12.5)
3043  WRITE(6,1457)tvdqpz,tvdqe,tqpd,tqed
3044  1457 FORMAT(' vv TQPD,TQED ',4f12.5)
3045  WRITE(6,1355)xpvq(ixvpr),xpvd(ixvpr),xtvq(ixvta),
3046  * xtvd(ixvta),prmom(4,inucpr),tamom(4,inucta)
3047  1355 FORMAT(' VV xpq.xpd,xtq,xtd,ep,et ',6f12.5)
3048  ENDIF
3049 C j.r.6.5.93
3050 C
3051 C multiple scattering of valence quark chain ends
3052 C
3053  IF(it.GT.1)THEN
3054  itnu=ip+inucta
3055  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
3056  rtiy=vhkk(2,itnu)*1.e12
3057  rtiz=vhkk(3,itnu)*1.e12
3058  CALL cromsc(pvqpx,pvqpy,pvqpz,pvqe,rtix,rtiy,rtiz,
3059  * pvqnx,pvqny,pvqnz,pvqne,1)
3060  pvqpx=pvqnx
3061  pvqpy=pvqny
3062  pvqpz=pvqnz
3063  pvqe=pvqne
3064  CALL cromsc(pvdqpx,pvdqpy,pvdqpz,pvdqe,rtix,rtiy,rtiz,
3065  * pvdqnx,pvdqny,pvdqnz,pvdqne,2)
3066  pvdqpx=pvdqnx
3067  pvdqpy=pvdqny
3068  pvdqpz=pvdqnz
3069  pvdqe=pvdqne
3070 C ---------
3071 
3072 C j.r.6.5.93
3073 C
3074 C multiple scattering of valence quark chain ends
3075 C
3076  itnu=ip+inucta
3077  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
3078  rtiy=vhkk(2,itnu)*1.e12
3079  rtiz=vhkk(3,itnu)*1.e12
3080  CALL cromsc(tvqpx,tvqpy,tvqpz,tvqe,rtix,rtiy,rtiz,
3081  * tvqnx,tvqny,tvqnz,tvqne,3)
3082  tvqpx=tvqnx
3083  tvqpy=tvqny
3084  tvqpz=tvqnz
3085  tvqe=tvqne
3086  CALL cromsc(tvdqpx,tvdqpy,tvdqpz,tvdqe,rtix,rtiy,rtiz,
3087  * tvdqnx,tvdqny,tvdqnz,tvdqne,4)
3088  tvdqpx=tvdqnx
3089  tvdqpy=tvdqny
3090  tvdqpz=tvdqnz
3091  tvdqe=tvdqne
3092  ENDIF
3093 
3094 C j.r.10.5.93
3095  IF(ip.GE.1)go to 1779
3096  pvqpz2=pvqe**2-pvqpx**2-pvqpy**2
3097  IF(pvqpz2.GE.0.)THEN
3098  pvqpz=sqrt(pvqpz2)
3099  ELSE
3100  pvqpx=0.
3101  pvqpy=0.
3102  pvqpz=pvqe
3103  ENDIF
3104 C
3105  pdqpz2=pvdqe**2-pvdqpx**2-pvdqpy**2
3106  IF(pdqpz2.GE.0.)THEN
3107  pvdqpz=sqrt(pdqpz2)
3108  ELSE
3109  pvdqpx=0.
3110  pvdqpy=0.
3111  pvdqpz=pvdqe
3112  ENDIF
3113 C
3114  tvqpz2=tvqe**2-tvqpx**2-tvqpy**2
3115  IF(tvqpz2.GE.0.)THEN
3116  tvqpz=-sqrt(tvqpz2)
3117  ELSE
3118  tvqpx=0.
3119  tvqpy=0.
3120  tvqpz=tvqe
3121  ENDIF
3122 C
3123  tdqpz2=tvdqe**2-tvdqpx**2-tvdqpy**2
3124  IF(tdqpz2.GE.0.)THEN
3125  tvdqpz=-sqrt(tdqpz2)
3126  ELSE
3127  tvdqpx=0.
3128  tvdqpy=0.
3129  tvdqpz=pvdqe
3130  ENDIF
3131  1779 CONTINUE
3132 C ----------------
3133 *** SAMPLE PARTON-PT VALUES / DETERMINE PARTON 4-MOMENTA AND CHAIN MAS
3134 C*** IN THE REST FRAME DEFINED ABOVE
3135 C
3136 C
3137 C changej.r.6.5.93
3138  ptxsq1=0.
3139  ptxsa1=0.
3140  ptxsq2=0.
3141  ptxsa2=0.
3142  ptysq1=0.
3143  ptysa1=0.
3144  ptysq2=0.
3145  ptysa2=0.
3146  ptxsq1=pvqpx
3147  ptxsa1=pvdqpx
3148  ptxsq2=tvqpx
3149  ptxsa2=tvdqpx
3150  ptysq1=pvqpy
3151  ptysa1=pvdqpy
3152  ptysq2=tvqpy
3153  ptysa2=tvdqpy
3154  plq1=pvqpz
3155  plaq1=pvdqpz
3156  plq2=tvqpz
3157  plaq2=tvdqpz
3158  eq1=pvqe
3159  eaq1=pvdqe
3160  eq2=tvqe
3161  eaq2=tvdqe
3162 C ---------------
3163  IF(ipev.GE.1) THEN
3164  WRITE(6,1050) ptxsq1,ptysq1,
3165  + plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,
3166  + ptxsa2,ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1
3167  bplq1=gamcm*plq1+bgcm*eq1
3168  beq1=gamcm*eq1+bgcm*plq1
3169  bplaq1=gamcm*plaq1+bgcm*eaq1
3170  beaq1=gamcm*eaq1+bgcm*plaq1
3171  bplq2=gamcm*plq2+bgcm*eq2
3172  beq2=gamcm*eq2+bgcm*plq2
3173  bplaq2=gamcm*plaq2+bgcm*eaq2
3174  beaq2=gamcm*eaq2+bgcm*plaq2
3175  WRITE(6,1050) ptxsq1,ptysq1,
3176  + bplq1,beq1,ptxsa1,ptysa1,bplaq1,beaq1,
3177  + ptxsq2,ptysq2,bplq2,beq2,
3178  + ptxsa2,ptysa2,bplaq2,beaq2,
3179  + amch1,amch2,irej,ikvala,pttq1,ptta1
3180  ENDIF
3181  ikvala=1
3182  nselpt=0
3183  IF(nsicha.EQ.0)THEN
3184  IF(nbproj.GE.0)THEN
3185  IF(iouxev.GE.6)WRITE(6,'(A)')' KKEVVV call SELPT'
3186  CALL selpt( ptxsq1,ptysq1,plq1,eq1,
3187  + ptxsa1,ptysa1,plaq1,eaq1,
3188  + ptxsq2,ptysq2,plq2,eq2,
3189  + ptxsa2,ptysa2,plaq2,eaq2,
3190  + amch1,amch2,
3191  + irej,ikvala,pttq1,ptta1,
3192  * pttq2,ptta2,
3193  + nselpt)
3194  ENDIF
3195  IF(nbproj.EQ.-1)THEN
3196  IF(iouxev.GE.6)WRITE(6,'(A)')' KKEVVV call SELPT'
3197  CALL selpt( ptxsq1,ptysq1,plq1,eq1,
3198  + ptxsa1,ptysa1,plaq1,eaq1,
3199  + ptxsa2,ptysa2,plaq2,eaq2,
3200  + ptxsq2,ptysq2,plq2,eq2,
3201  + amch1,amch2,
3202  + irej,ikvala,pttq1,ptta1,
3203  * pttq2,ptta2,
3204  + nselpt)
3205  ENDIF
3206  ENDIF
3207 C-------------------------------------Single Chain Option------
3208  IF(nsicha.EQ.1.AND.nbproj.EQ.0)THEN
3209  CALL selpts( ptxsq1,ptysq1,
3210  + plq1,eq1,ptxsa2,
3211  + ptysa2,plaq2,eaq2, amch1,irej,ikvala,pttq1)
3212  ENDIF
3213  IF(nsicha.EQ.1.AND.nbproj.EQ.-1)THEN
3214  CALL selpts( ptxsa1,ptysa1,
3215  + plaq1,eaq1,ptxsa2,
3216  + ptysa2,plaq2,eaq2, amch2,irej,ikvala,ptta1)
3217  ENDIF
3218 C-------------------------------------Single Chain Option------
3219  IF(ipev.GE.1) THEN
3220  WRITE(6,1050) ptxsq1,ptysq1,
3221  + plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,
3222  + ptxsa2,ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1
3223  ENDIF
3224 C
3225  IF (irej.EQ.1) THEN
3226  irvv13=irvv13 + 1
3227  IF(ipev.GE.1) THEN
3228  WRITE(6,1100) irvv13
3229  WRITE(6,1050) ptxsq1,
3230  + ptysq1,plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,
3231  + plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,
3232  + pttq1,ptta1
3233  ENDIF
3234  go to 10
3235  ENDIF
3236 C
3237 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
3238 C
3239  IF(nbproj.GE.0)THEN
3240  ptxch1=ptxsq1 + ptxsa2
3241  ptych1=ptysq1 + ptysa2
3242  ptzch1=plq1 + plaq2
3243  ech1=eq1 + eaq2
3244  ptxch2=ptxsq2 + ptxsa1
3245  ptych2=ptysq2 + ptysa1
3246  ptzch2=plq2 + plaq1
3247  ech2=eq2 + eaq1
3248  ENDIF
3249  IF(nbproj.EQ.-1)THEN
3250  ptxch1=ptxsq1 + ptxsq2
3251  ptych1=ptysq1 + ptysq2
3252  ptzch1=plq1 + plq2
3253  ech1=eq1 + eq2
3254  ptxch2=ptxsa2 + ptxsa1
3255  ptych2=ptysa2 + ptysa1
3256  ptzch2=plaq2 + plaq1
3257  ech2=eaq2 + eaq1
3258  ENDIF
3259  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
3260  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
3261 C
3262  IF (ipev.GE.6)WRITE(6,1040) irej,
3263  + amch1,ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
3264 
3265 C
3266 C REPLACE SMALL MASS CHAINS BY OCTETT OR DECUPLETT BARYONS
3267 C FIRST FOR CHAIN 1
3268 C PROJ VAL-QUARK - TAR DIQUARK FOR MESONS/BARYONS
3269 C PROJ VAL-AQUARK - TAR QUARK FOR ANTIBARYONS
3270 C
3271 C IF(NBPROJ.LE.100)GO TO 5559
3272  IF(nsicha.EQ.0)THEN
3273  IF(nbproj.GE.0) THEN
3274  CALL cobcma(ipvq(ixvpr),ittv1(ixvta),ittv2(ixvta), ijnch1,
3275  + nnch1,irej,amch1,amch1n,1)
3276  ELSE
3277  CALL comcma(itvq(ixvta),ipvq(ixvpr), ijnch1,nnch1,irej,amch1,
3278  + amch1n)
3279  ENDIF
3280 C*** MASS BELOW OCTETT BARYON MASS (MESON/BARYON)
3281 C*** MASS BELOW PSEUDOSCALAR MASS (ANTIBARYON)
3282  IF(irej.EQ.1) THEN
3283  irvv11=irvv11 + 1
3284  IF(ipev.GE.1) THEN
3285  WRITE(6,1110) irvv11
3286  WRITE(6,1060) ipvq(ixvpr),ittv1(ixvta),ittv2(ixvta), ijnch1,
3287  + nnch1,irej, xpvq(ixvpr),xpvd(ixvpr),xpvqcm,xpvdcm, xtvq
3288  + (ixvta),xtvd(ixvta),amch1,amch1n
3289 
3290  ENDIF
3291  goto 10
3292  ENDIF
3293 C CORRECT KINEMATICS FOR CHAIN 1
3294 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
3295  IF(nnch1.NE.0) THEN
3296  IF(nbproj.GE.0) THEN
3297  CALL cormom(amch1,amch2,amch1n,amch2n,
3298  + ptxsq1,ptysq1,plq1,eq1,
3299  + ptxsa1,ptysa1,plaq1,eaq1,
3300  + ptxsq2,ptysq2,plq2,eq2,
3301  + ptxsa2,ptysa2,plaq2,eaq2,
3302  + ptxch1,ptych1,ptzch1,ech1,
3303  + ptxch2,ptych2,ptzch2,ech2,irej)
3304  amch2=amch2n
3305  ELSE
3306  CALL cormom(amch1,amch2,amch1n,amch2n,
3307  + ptxsq1,ptysq1,plq1,eq1,
3308  + ptxsa1,ptysa1,plaq1,eaq1,
3309  + ptxsa2,ptysa2,plaq2,eaq2,
3310  + ptxsq2,ptysq2,plq2,eq2,
3311  + ptxch1,ptych1,ptzch1,ech1,
3312  + ptxch2,ptych2,ptzch2,ech2,irej)
3313  amch2=amch2n
3314  ENDIF
3315  IF(irej.EQ.1)THEN
3316  IF(ipev.GE.1)WRITE(6,'(A)')' vv cormom rej'
3317  go to 10
3318  ENDIF
3319 C
3320  IF (ipev.GE.1)WRITE(6,1040) irej,
3321  + amch1,ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,
3322  + ech2
3323  ENDIF
3324 C
3325 C SECOND FOR CHAIN 2:
3326 C PROJ VAL-DIQUARK - TAR VAL-QUARK FOR INC. BARYONS
3327 C PROJ VAL-AQUARK - TAR VAL-QUARK FOR INC. MESONS
3328 C PROJ VAL-ADIQUARK - TAR VAL-DIQUARK FOR INC. ANTIBARYON
3329 C
3330 C IF(NBPROJ.LE.100)GO TO 5557
3331  IF(nbproj.GT.0) THEN
3332  CALL cobcma(itvq(ixvta),ippv1(ixvpr),ippv2(ixvpr), ijnch2,
3333  + nnch2,irej,amch2,amch2n,2)
3334  ELSEIF(nbproj.EQ.0) THEN
3335  CALL comcma(itvq(ixvta),ippv1(ixvpr), ijnch2,nnch2,irej,amch2,
3336  + amch2n)
3337  ELSE
3338  CALL comcm2(ittv1(ixvta),ittv2(ixvta), ippv1(ixvpr),ippv2
3339  + (ixvpr), nnch2,irej,amch2)
3340 
3341  ENDIF
3342 C*** MASS BELOW OCTETT BARYON/PSEUDOSCALAR MESON MASS
3343 C OR INCONSISTENT QUARK FLAVORS FOR ANTIBARYONS
3344 C
3345 C5557 CONTINUE
3346 
3347  IF(irej.EQ.1) THEN
3348  irvv12=irvv12 + 1
3349  IF(ipev.GE.1) THEN
3350  WRITE(6,1120) irvv12
3351  WRITE(6,1080) ippv1(ixvpr),ippv2(ixvpr),ittv1(ixvta), ittv2
3352  + (ixvta),ijnch2,nnch2,irej, xpvq(ixvpr),xpvd(ixvpr),xpvqcm,
3353  + xpvdcm, xtvq(ixvta),xtvd(ixvta),xtvqcm,xtvdcm, amch2,amch2n
3354  ENDIF
3355  goto 10
3356  ENDIF
3357  ENDIF
3358 C5559 CONTINUE
3359  IF(nsicha.EQ.0)THEN
3360  IF(nnch2.NE.0) THEN
3361  amch2=amch2n
3362  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
3363  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
3364  eee=ech1+ech2
3365  pxxx=ptxch1+ptxch2
3366  pyyy=ptych1+ptych2
3367  pzzz=ptzch1+ptzch2
3368  gammm=eee/(ammm+1.e-4)
3369  bgggx=pxxx/(ammm+1.e-4)
3370  bgggy=pyyy/(ammm+1.e-4)
3371  bgggz=pzzz/(ammm+1.e-4)
3372 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
3373 C
3374 C 4-MOMENTA OF CHAINS
3375  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
3376  + ptxch1,ptych1,ptzch1,ech1,
3377  + pppch1, qtxch1,qtych1,qtzch1,qech1)
3378 C
3379  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
3380  + ptxch2,ptych2,ptzch2,ech2,
3381  + pppch2, qtxch2,qtych2,qtzch2,qech2)
3382 C
3383 C IF AMCH2 CHANGED IN COBCMA/COMCMA
3384 C CORRESPONDING REPLACEMENT IN CORMOM
3385  norig=21
3386 C IF(NBPROJ.LE.100)GO TO 5558
3387  CALL corval(ammm,irej,amch1,amch2, qtxch1,qtych1,qtzch1,qech1,
3388  + qtxch2,qtych2,qtzch2,qech2,norig)
3389 C5558 CONTINUE
3390 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
3391 C
3392 C 4-MOMENTA OF CHAINS
3393  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch1,qtych1,qtzch1,qech1,
3394  + pppch1, ptxch1,ptych1,ptzch1,ech1)
3395 C
3396  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch2,qtych2,qtzch2,qech2,
3397  + pppch2, ptxch2,ptych2,ptzch2,ech2)
3398 C
3399 C
3400  IF(ipev.GE.3) THEN
3401  WRITE(6,'(A/3(1PE15.4),3I5)')
3402  + ' VV - CALL CORVAL: AMMM, AMCH1, AMCH2, NNCH1, NNCH2, IREJ',
3403  + ammm, amch1, amch2, nnch1, nnch2, irej
3404  ENDIF
3405  IF(irej.EQ.1) THEN
3406  IF(ipev.GE.1)WRITE(6,'(A)')' vv14 rej.'
3407 C AMCH1N + AMCH2N > AMMM - 0.2
3408 C REJECT EVENT
3409  irvv14=irvv14+1
3410  goto 10
3411  ENDIF
3412  ENDIF
3413  ENDIF
3414  qtxch1=ptxch1
3415  qtych1=ptych1
3416  qtzch1=ptzch1
3417  qech1=ech1
3418  qtxch2=ptxch2
3419  qtych2=ptych2
3420  qtzch2=ptzch2
3421  qech2=ech2
3422  pqvva1(n,1)=ptxsq1
3423  pqvva1(n,2)=ptysq1
3424  pqvva1(n,3)=plq1
3425  pqvva1(n,4)=eq1
3426  pqvva2(n,1)=ptxsa2
3427  pqvva2(n,2)=ptysa2
3428  pqvva2(n,3)=plaq2
3429  pqvva2(n,4)=eaq2
3430  pqvvb1(n,1)=ptxsq2
3431  pqvvb1(n,2)=ptysq2
3432  pqvvb1(n,3)=plq2
3433  pqvvb1(n,4)=eq2
3434  pqvvb2(n,1)=ptxsa1
3435  pqvvb2(n,2)=ptysa1
3436  pqvvb2(n,3)=plaq1
3437  pqvvb2(n,4)=eaq1
3438 C-------------------
3439 C PUT V-V CHAIN ENDS AND CHAINS
3440 C INTO /HKKEVT/
3441 C MOMENTA IN NN-CMS
3442 C POSITION OF ORIGINAL NUCLEONS
3443 C
3444 C FLAG FOR VV-CHAIN ENDS
3445 C PROJECTILE: ISTHKK=121
3446 C TARGET: ISTHKK=122
3447 C FOR VV-CHAINS ISTHKK=3
3448  ihkkpd=jhkkpv(ixvpr)
3449  ihkkpo=ihkkpd - 1
3450 C*** hjm 27/08/90
3451  IF(nbproj.GE.0) THEN
3452  ihkktd=jhkktv(ixvta)
3453  ihkkto=ihkktd - 1
3454  ELSE
3455  ihkkto=jhkktv(ixvta)
3456  ihkktd=ihkkto - 1
3457  ENDIF
3458 C
3459 C
3460  IF (ipev.GT.3) THEN
3461  WRITE(6,1000) ixvpr,inucpr,ihkkpo,ihkkpd
3462  1000 FORMAT (' IXVPR,INUCPR,IHKKPO,IHKKPD ',5i5)
3463  WRITE(6,1010) ixvta,inucta,ihkkto,ihkktd
3464  1010 FORMAT (' IXVTA,INUCTA,IHKKTO,IHKKTD ',5i5)
3465  ENDIF
3466 C CHAIN 1 PROJECTILE QUARK
3467  nhkk=nhkk+1
3468  IF (nhkk.EQ.nmxhkk)THEN
3469  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
3470  RETURN
3471  ENDIF
3472  isthkk(nhkk)=121
3473  idhkk(nhkk)=idhkk(ihkkpo)
3474  jmohkk(1,nhkk)=ihkkpo
3475  jmohkk(2,nhkk)=jmohkk(1,ihkkpo)
3476  jdahkk(1,nhkk)=nhkk+2
3477  jdahkk(2,nhkk)=nhkk+2
3478  phkk(1,nhkk)=pqvva1(n,1)
3479  phkk(2,nhkk)=pqvva1(n,2)
3480  phkk(3,nhkk)=pqvva1(n,3)
3481  phkk(4,nhkk)=pqvva1(n,4)
3482  phkk(5,nhkk)=0.
3483  CALL qinnuc(xxpp,yypp)
3484  vhkk(1,nhkk)=vhkk(1,ihkkpo)+xxpp
3485  vhkk(2,nhkk)=vhkk(2,ihkkpo)+yypp
3486  vhkk(3,nhkk)=vhkk(3,ihkkpo)
3487  vhkk(4,nhkk)=vhkk(4,ihkkpo)
3488 C
3489  IF (iphkk.GE.2) WRITE(6,1020) nhkk,isthkk(nhkk),idhkk(nhkk),
3490  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3491  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3492 
3493  1020 FORMAT (i6,i4,5i6,9e10.2)
3494 C CHAIN 1 TARGET DIQUARK
3495  nhkk=nhkk+1
3496  IF (nhkk.EQ.nmxhkk)THEN
3497  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
3498  RETURN
3499  ENDIF
3500  isthkk(nhkk)=122
3501  idhkk(nhkk)=idhkk(ihkktd)
3502  jmohkk(1,nhkk)=ihkktd
3503  jmohkk(2,nhkk)=jmohkk(1,ihkktd)
3504  jdahkk(1,nhkk)=nhkk+1
3505  jdahkk(2,nhkk)=nhkk+1
3506  phkk(1,nhkk)=pqvva2(n,1)
3507  phkk(2,nhkk)=pqvva2(n,2)
3508  phkk(3,nhkk)=pqvva2(n,3)
3509  phkk(4,nhkk)=pqvva2(n,4)
3510  phkk(5,nhkk)=0.
3511  CALL qinnuc(xxpp,yypp)
3512  vhkk(1,nhkk)=vhkk(1,ihkktd)+xxpp
3513  vhkk(2,nhkk)=vhkk(2,ihkktd)+yypp
3514  vhkk(3,nhkk)=vhkk(3,ihkktd)
3515  vhkk(4,nhkk)=vhkk(4,ihkktd)
3516 C
3517  IF (iphkk.GE.2) WRITE(6,1020) nhkk,isthkk(nhkk),idhkk(nhkk),
3518  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3519  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3520 
3521 C
3522 C CHAIN 1 BEFORE FRAGMENTATION
3523  nhkk=nhkk+1
3524  IF (nhkk.EQ.nmxhkk)THEN
3525  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
3526  RETURN
3527  ENDIF
3528  isthkk(nhkk)=3
3529  idhkk(nhkk)=88888+nnch1
3530  IF(nchvv1(n).EQ.99)idhkk(nhkk)=77777
3531  jmohkk(1,nhkk)=nhkk-2
3532  jmohkk(2,nhkk)=nhkk-1
3533  phkk(1,nhkk)=qtxch1
3534  phkk(2,nhkk)=qtych1
3535  phkk(3,nhkk)=qtzch1
3536  phkk(4,nhkk)=qech1
3537  phkk(5,nhkk)=amch1
3538 C POSITION OF CREATED CHAIN IN LAB
3539 C =POSITION OF TARGET NUCLEON
3540 C TIME OF CHAIN CREATION IN LAB
3541 C =TIME OF PASSAGE OF PROJECTILE
3542 C NUCLEUS AT POSITION OF TAR. NUCLEUS
3543  vhkk(1,nhkk)= vhkk(1,nhkk-1)
3544  vhkk(2,nhkk)= vhkk(2,nhkk-1)
3545  vhkk(3,nhkk)= vhkk(3,nhkk-1)
3546  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
3547  mhkkvv(n)=nhkk
3548  IF (iprojk.EQ.1)THEN
3549  whkk(1,nhkk)= vhkk(1,nhkk-2)
3550  whkk(2,nhkk)= vhkk(2,nhkk-2)
3551  whkk(3,nhkk)= vhkk(3,nhkk-2)
3552  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
3553  IF (iphkk.GE.2) WRITE(6,1020) nhkk,isthkk(nhkk),idhkk(nhkk),
3554  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3555  + (phkk(khkk,nhkk),khkk=1,5), (whkk(khkk,nhkk),khkk=1,4)
3556 
3557  ENDIF
3558 C
3559  IF (iphkk.GE.1) WRITE(6,1020) nhkk,isthkk(nhkk),idhkk(nhkk),
3560  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3561  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3562 
3563 C
3564 C
3565 C CHAIN 2 PROJECTILE DIQUARK
3566  nhkk=nhkk+1
3567  IF (nhkk.EQ.nmxhkk)THEN
3568  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
3569  RETURN
3570  ENDIF
3571  isthkk(nhkk)=121
3572  idhkk(nhkk)=idhkk(ihkkpd)
3573  jmohkk(1,nhkk)=ihkkpd
3574  jmohkk(2,nhkk)=jmohkk(1,ihkkpd)
3575  jdahkk(1,nhkk)=nhkk+2
3576  jdahkk(2,nhkk)=nhkk+2
3577  phkk(1,nhkk)=pqvvb1(n,1)
3578  phkk(2,nhkk)=pqvvb1(n,2)
3579  phkk(3,nhkk)=pqvvb1(n,3)
3580  phkk(4,nhkk)=pqvvb1(n,4)
3581  phkk(5,nhkk)=0.
3582  CALL qinnuc(xxpp,yypp)
3583  vhkk(1,nhkk)=vhkk(1,ihkkpd)+xxpp
3584  vhkk(2,nhkk)=vhkk(2,ihkkpd)+yypp
3585  vhkk(3,nhkk)=vhkk(3,ihkkpd)
3586  vhkk(4,nhkk)=vhkk(4,ihkkpd)
3587 C
3588  IF (iphkk.GE.2) WRITE(6,1020) nhkk,isthkk(nhkk),idhkk(nhkk),
3589  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3590  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3591 
3592 C CHAIN 2 TARGET QUARK
3593  nhkk=nhkk+1
3594  IF (nhkk.EQ.nmxhkk)THEN
3595  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
3596  RETURN
3597  ENDIF
3598  isthkk(nhkk)=122
3599  idhkk(nhkk)=idhkk(ihkkto)
3600  jmohkk(1,nhkk)=ihkkto
3601  jmohkk(2,nhkk)=jmohkk(1,ihkkto)
3602  jdahkk(1,nhkk)=nhkk+1
3603  jdahkk(2,nhkk)=nhkk+1
3604  phkk(1,nhkk)=pqvvb2(n,1)
3605  phkk(2,nhkk)=pqvvb2(n,2)
3606  phkk(3,nhkk)=pqvvb2(n,3)
3607  phkk(4,nhkk)=pqvvb2(n,4)
3608  phkk(5,nhkk)=0.
3609  CALL qinnuc(xxpp,yypp)
3610  vhkk(1,nhkk)=vhkk(1,ihkkto)+xxpp
3611  vhkk(2,nhkk)=vhkk(2,ihkkto)+yypp
3612  vhkk(3,nhkk)=vhkk(3,ihkkto)
3613  vhkk(4,nhkk)=vhkk(4,ihkkto)
3614 C
3615  IF (iphkk.GE.2) WRITE(6,1020) nhkk,isthkk(nhkk),idhkk(nhkk),
3616  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3617  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3618 
3619 C
3620 C CHAIN 2 BEFORE FRAGMENTATION
3621  nhkk=nhkk+1
3622  IF (nhkk.EQ.nmxhkk)THEN
3623  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
3624  RETURN
3625  ENDIF
3626  isthkk(nhkk)=3
3627  idhkk(nhkk)=88888+nnch2
3628  IF(nchvv2(n).EQ.99)idhkk(nhkk)=77777
3629  jmohkk(1,nhkk)=nhkk-2
3630  jmohkk(2,nhkk)=nhkk-1
3631  phkk(1,nhkk)=qtxch2
3632  phkk(2,nhkk)=qtych2
3633  phkk(3,nhkk)=qtzch2
3634  phkk(4,nhkk)=qech2
3635  phkk(5,nhkk)=amch2
3636 C POSITION OF CREATED CHAIN IN LAB
3637 C =POSITION OF TARGET NUCLEON
3638 C TIME OF CHAIN CREATION IN LAB
3639 C =TIME OF PASSAGE OF PROJECTILE
3640 C NUCLEUS AT POSITION OF TAR. NUCLEUS
3641  vhkk(1,nhkk)= vhkk(1,nhkk-1)
3642  vhkk(2,nhkk)= vhkk(2,nhkk-1)
3643  vhkk(3,nhkk)= vhkk(3,nhkk-1)
3644  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
3645  mhkkvv(n)=nhkk
3646  IF (iprojk.EQ.1)THEN
3647  whkk(1,nhkk)= vhkk(1,nhkk-2)
3648  whkk(2,nhkk)= vhkk(2,nhkk-2)
3649  whkk(3,nhkk)= vhkk(3,nhkk-2)
3650  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
3651  IF (iphkk.GE.1) WRITE(6,1020) nhkk,isthkk(nhkk),idhkk(nhkk),
3652  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3653  + (phkk(khkk,nhkk),khkk=1,5), (whkk(khkk,nhkk),khkk=1,4)
3654 
3655  ENDIF
3656 C
3657  IF (iphkk.GE.1) WRITE(6,1020) nhkk,isthkk(nhkk),idhkk(nhkk),
3658  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
3659  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
3660 
3661 C
3662 C
3663 C NOW WE HAVE AN ACCEPTABLE VALENCE-VALENCE EVENT
3664 C AND PUT IT INTO THE HISTOGRAM
3665 C
3666  amcvv1(n)=amch1
3667  amcvv2(n)=amch2
3668  IF(amch1.GT.0.d0)THEN
3669  gacvv1(n)=qech1/amch1
3670  bgxvv1(n)=qtxch1/amch1
3671  bgyvv1(n)=qtych1/amch1
3672  bgzvv1(n)=qtzch1/amch1
3673  ELSE
3674  gacvv1(n)=0
3675  bgxvv1(n)=0
3676  bgyvv1(n)=0
3677  bgzvv1(n)=0
3678  ENDIF
3679  IF(amch2.GT.0.d0)THEN
3680  gacvv2(n)=qech2/amch2
3681  bgxvv2(n)=qtxch2/amch2
3682  bgyvv2(n)=qtych2/amch2
3683  bgzvv2(n)=qtzch2/amch2
3684  ELSE
3685  gacvv2(n)=0
3686  bgxvv2(n)=0
3687  bgyvv2(n)=0
3688  bgzvv2(n)=0
3689  ENDIF
3690  IF(nsicha.EQ.0)THEN
3691  nchvv1(n)=nnch1
3692  nchvv2(n)=nnch2
3693  ENDIF
3694 C-------------------------------------Single Chain Option------
3695  IF(nsicha.EQ.1.AND.ibproj.EQ.0)THEN
3696  nchvv1(n)=0
3697  nchvv2(n)=99
3698  ENDIF
3699  IF(nsicha.EQ.1.AND.ibproj.EQ.-1)THEN
3700  nchvv1(n)=99
3701  nchvv2(n)=0
3702  ENDIF
3703 C-------------------------------------Single Chain Option------
3704 C-----------------------------------------------------------------
3705  ijcvv1(n)=ijnch1
3706  ijcvv2(n)=ijnch2
3707 C
3708  IF (ipev.GE.6)WRITE(6,1030) n, xpvq(ixvpr),xpvd(ixvpr),xtvq
3709  + (ixvta),xtvd(ixvta), ipvq(ixvpr),ippv1(ixvpr),ippv2(ixvpr), itvq
3710  + (ixvta),ittv1(ixvta),ittv2(ixvta), amcvv1(n),amcvv2(n),gacvv1
3711  + (n),gacvv2(n), bgxvv1(n),bgyvv1(n),bgzvv1(n), bgxvv2(n),bgyvv2
3712  + (n),bgzvv2(n), nchvv1(n),nchvv2(n),ijcvv1(n),ijcvv2(n), (pqvva1
3713  + (n,ju),pqvva2(n,ju),pqvvb1(n,ju), pqvvb2(n,ju),ju=1,4)
3714 
3715 
3716 
3717 
3718  20 CONTINUE
3719 C--------------------------------------------------------
3720  RETURN
3721  10 CONTINUE
3722 C EVENT REJECTED
3723 C START A NEW ONE
3724  irejvv=1
3725  RETURN
3726 C
3727  1030 FORMAT(i10,4f12.7,6i5/10x,4f12.6/10x,6f12.6,4i5/8f15.5/8f15.5)
3728  1040 FORMAT (' VV IREJ ',i10/
3729  +' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
3730  +' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
3731  1050 FORMAT(' VV',4(4e12.4/),2e12.4/2i5/4e12.4)
3732  1060 FORMAT(' VV',6i5/6e12.4/2e12.4)
3733  1070 FORMAT(' VV',5i5/2(4e12.4/),2e12.4)
3734  1080 FORMAT(' VV',7i5/2(4e12.4/),2e12.4)
3735  1090 FORMAT(' VV',4i5/6e12.4/2e12.4)
3736  1100 FORMAT(' KKEVT - IRVV13=',i5)
3737  1110 FORMAT(' KKEVT - IRVV11=',i5)
3738  1120 FORMAT(' KKEVT - IRVV12=',i5)
3739 C
3740  END
3741 *-- Author :
3742 C
3743 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3744 C
3745  SUBROUTINE kkevss
3746  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3747  SAVE
3748 C
3749 C------------------------- TREATMENT OF SEA-SEA CHAIN SYSTEMS
3750 C
3751 *KEEP,HKKEVT.
3752 c INCLUDE (HKKEVT)
3753  parameter(nmxhkk= 89998)
3754 c PARAMETER (NMXHKK=25000)
3755  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
3756  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
3757  +(4,nmxhkk)
3758 C
3759 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
3760 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
3761 C THE POSITIONS OF THE PROJECTILE NUCLEONS
3762 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
3763 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
3764 C COMPLETELY CONSISTENT. THE TIMES IN THE
3765 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
3766 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
3767 C
3768 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
3769 C
3770 C NMXHKK: maximum numbers of entries (partons/particles) that can be
3771 C stored in the commonblock.
3772 C
3773 C NHKK: the actual number of entries stored in current event. These are
3774 C found in the first NHKK positions of the respective arrays below.
3775 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
3776 C entry.
3777 C
3778 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
3779 C = 0 : null entry.
3780 C = 1 : an existing entry, which has not decayed or fragmented.
3781 C This is the main class of entries which represents the
3782 C "final state" given by the generator.
3783 C = 2 : an entry which has decayed or fragmented and therefore
3784 C is not appearing in the final state, but is retained for
3785 C event history information.
3786 C = 3 : a documentation line, defined separately from the event
3787 C history. (incoming reacting
3788 C particles, etc.)
3789 C = 4 - 10 : undefined, but reserved for future standards.
3790 C = 11 - 20 : at the disposal of each model builder for constructs
3791 C specific to his program, but equivalent to a null line in the
3792 C context of any other program. One example is the cone defining
3793 C vector of HERWIG, another cluster or event axes of the JETSET
3794 C analysis routines.
3795 C = 21 - : at the disposal of users, in particular for event tracking
3796 C in the detector.
3797 C
3798 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
3799 C standard.
3800 C
3801 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
3802 C The value is 0 for initial entries.
3803 C
3804 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
3805 C one mother exist, in which case the value 0 is used. In cluster
3806 C fragmentation models, the two mothers would correspond to the q
3807 C and qbar which join to form a cluster. In string fragmentation,
3808 C the two mothers of a particle produced in the fragmentation would
3809 C be the two endpoints of the string (with the range in between
3810 C implied).
3811 C
3812 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
3813 C entry has not decayed, this is 0.
3814 C
3815 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
3816 C entry has not decayed, this is 0. It is assumed that the daughters
3817 C of a particle (or cluster or string) are stored sequentially, so
3818 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
3819 C daughters. Even in cases where only one daughter is defined (e.g.
3820 C K0 -> K0S) both values should be defined, to make for a uniform
3821 C approach in terms of loop constructions.
3822 C
3823 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
3824 C
3825 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
3826 C
3827 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
3828 C
3829 C PHKK(4,IHKK) : energy, in GeV.
3830 C
3831 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
3832 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
3833 C
3834 C VHKK(1,IHKK) : production vertex x position, in mm.
3835 C
3836 C VHKK(2,IHKK) : production vertex y position, in mm.
3837 C
3838 C VHKK(3,IHKK) : production vertex z position, in mm.
3839 C
3840 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
3841 C********************************************************************
3842 *KEEP,INTMX.
3843  parameter(intmx=2488,intmd=252)
3844 *KEEP,DXQX.
3845 C INCLUDE (XQXQ)
3846 * NOTE: INTMX set via INCLUDE(INTMX)
3847  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
3848  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
3849  * ,xpsu(248),xtsu(248)
3850  * ,xpsut(248),xtsut(248)
3851 *KEEP,INTNEW.
3852  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
3853  +ixpv,ixps,ixtv,ixts, intvv1(248),
3854  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
3855  +intss1(intmx),intss2(intmx),
3856  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
3857  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
3858 
3859 C /INTNEW/
3860 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
3861 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
3862 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
3863 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
3864 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
3865 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
3866 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
3867 C FROM PROJECTILE/TARGET NUCLEI
3868 C-------------------
3869 *KEEP,IFROTO.
3870  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
3871  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
3872  +jhkknt
3873  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
3874  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
3875  & mhkkhh(intmx),
3876  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
3877 *KEEP,LOZUO.
3878  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
3879  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
3880  +intlo(intmx),inloss(intmx)
3881 C /LOZUO/
3882 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
3883 C REJECTED IN KKEVT
3884 C------------------
3885 *KEEP,DIQI.
3886  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
3887  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
3888  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
3889  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
3890 *KEEP,ABRSS.
3891 C INCLUDE (ABRSS)
3892  COMMON /abrss/ amcss1(intmx),amcss2(intmx), gacss1(intmx),gacss2
3893  +(intmx), bgxss1(intmx),bgyss1(intmx),bgzss1(intmx), bgxss2(intmx),
3894  +bgyss2(intmx),bgzss2(intmx), nchss1(intmx),nchss2(intmx), ijcss1
3895  +(intmx),ijcss2(intmx), pqssa1(intmx,4),pqssa2(intmx,4), pqssb1
3896  +(intmx,4),pqssb2(intmx,4)
3897 *KEEP,TRAFOP.
3898  COMMON /trafop/ gamp,bgamp,betp
3899 *KEEP,NUCIMP.
3900  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
3901  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
3902  +prebin,taebin,fermod,etacou
3903 *KEEP,DROPPT.
3904  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
3905  +ishmal,lpauli
3906  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
3907  +ipadis,ishmal,lpauli
3908 *KEEP,DPRIN.
3909  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3910 *KEEP,REJEC.
3911  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
3912  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
3913  +irvs14, irvv11,irvv12,irvv13,irvv14
3914 *KEEP,PROJK.
3915  COMMON /projk/ iprojk
3916  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
3917  common/rptshm/rproj,rtarg,bimpac
3918 *KEND.
3919 C===================================================================
3920 
3921  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
3922  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
3923  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
3924  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
3925  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
3926  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
3927  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
3928  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
3929  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
3930  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
3931  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
3932  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
3933  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
3934  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
3935  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
3936  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
3937  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
3938  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
3939  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
3940  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
3941  COMMON /zsea/zseaav,zseasu,anzsea
3942 C
3943  xsothr=xsthr
3944  IF(nrejev.GE.0)xsothr=0.
3945  iminij=1
3946 C
3947  IF(ipev.GE.4)WRITE(6,*)' KKEVSS:NSS ',nss
3948 C-----------------------------------------------------------------------
3949  DO 20 n=1,nss
3950 C---------------------------drop recombined chain pairs
3951  IF(ipev.GE.4)WRITE(6,*)' KKEVSS:NCHSS1(N),NCHSS2(N)',
3952  * nchss1(n),nchss2(n)
3953  IF(nchss1(n).EQ.99.AND.nchss2(n).EQ.99)go to 20
3954 C
3955 C
3956 C*** 4-MOMENTA OF PROJECTILE SEA-QUARK PAIRS IN NN-CMS
3957  ixspr=intss1(n)
3958  ixspr1=intss1(n+1)
3959  IF (n.EQ.nss)THEN
3960  IF (nss.GE.2)THEN
3961  ixspr1=intss1(n-1)
3962  ELSE
3963  ixspr1=ixspr
3964  ENDIF
3965  ENDIF
3966  inucpr=ifrosp(ixspr)
3967  jnucpr=itovp(inucpr)
3968 C
3969 C SUBTRACT HARD SCATTERED X VALUES FROM DIQUARKS
3970 C
3971  iifrop=ifrosp(ixspr)
3972  ixvpr=itovp(iifrop)
3973 C
3974  ixsta=intss2(n)
3975  iifrot=ifrost(ixsta)
3976  ixvta=itovt(iifrot)
3977 C
3978  xmax1=xpsq(ixspr)+xpsaq(ixspr)+xpvq(ixvpr)+xpvd(ixvpr)
3979  * -2.d0*xsothr-xvthr-xdthr
3980  xmax2=xtsq(ixsta)+xtsaq(ixsta)+xtvq(ixvta)+xtvd(ixvta)
3981  * -2.d0*xsothr-xvthr-xdthr
3982 C
3983  IF(ipev.GE.1)WRITE(6,'(A,2I5,4F9.3/A,2I5,4F9.3/A,3F9.3)')
3984  *'IXSPR,IXVPR,XPSQ(IXSPR),XPSAQ(IXSPR),XPVQ(IXVPR),XPVD(IXVPR)'
3985  *,ixspr,ixvpr,xpsq(ixspr),xpsaq(ixspr),xpvq(ixvpr),xpvd(ixvpr),
3986  *'IXSTA,IXVTA,XTSQ(IXSTA),XTSAQ(IXSTA),XTVQ(IXVTA),XTVD(IXVTA)'
3987  *,ixsta,ixvta,xtsq(ixsta),xtsaq(ixsta),xtvq(ixvta),xtvd(ixvta),
3988  *'XSOTHR,XVTHR,XDTHR'
3989  *,xsothr,xvthr,xdthr
3990  IF(ipev.GE.1)WRITE(6,'(A,2I5,2F9.3)')' KKEVSS,bef xptfl:n,nss'
3991  * ,n,nss,xmax1,xmax2
3992  IF (iminij.EQ.1)THEN
3993  CALL xptfl(nhard,nsea,ireg,xmax1,xmax2)
3994 C NZSEA=NZSEA+1
3995 C ANZSEA=NZSEA
3996  anzsea=anzsea+1.d0
3997  zseasu=zseasu+nsea
3998  zseaav=zseasu/anzsea
3999  ENDIF
4000  IF(ipev.GE.1)WRITE(6,'(A,3I10)')' SS,xptfl:nhard,nsea,ireg '
4001  * ,nhard,nsea,ireg
4002  IF(ireg.EQ.1)nhard=0
4003  IF(ireg.EQ.1)nsea=0
4004 C
4005  nomje=nomje+nhard
4006 C
4007  IF (nhard.GE.1.AND.iminij.EQ.1)THEN
4008  DO 71 ixx=nonuj1,nonujt
4009  jhkkph(ixx)=ixvpr
4010  jhkkex(ixx)=0
4011  jhkke1(ixx)=0
4012  IF (xpsq(ixspr)-xjq1(ixx).GE.xsothr) THEN
4013  xpsq(ixspr)=xpsq(ixspr)-xjq1(ixx)
4014  jhkke1(ixx)=1
4015  ELSEIF (xpsaq(ixspr)-xjq1(ixx).GE.xsothr) THEN
4016  xpsaq(ixspr)=xpsaq(ixspr)-xjq1(ixx)
4017  jhkke1(ixx)=2
4018  ELSEIF (xpsaq(ixspr)-xjq1(ixx)/2..GE.xsothr.AND.
4019  * xpsq(ixspr)-xjq1(ixx)/2..GE.xsothr) THEN
4020  xpsq(ixspr)=xpsq(ixspr)-xjq1(ixx)/2.
4021  xpsaq(ixspr)=xpsaq(ixspr)-xjq1(ixx)/2.
4022  jhkke1(ixx)=5
4023  ELSEIF (xpsq(ixspr1)-xjq1(ixx).GE.xsothr) THEN
4024  xpsq(ixspr1)=xpsq(ixspr1)-xjq1(ixx)
4025  jhkke1(ixx)=6
4026  ELSEIF (xpsaq(ixspr1)-xjq1(ixx).GE.xsothr) THEN
4027  xpsaq(ixspr1)=xpsaq(ixspr1)-xjq1(ixx)
4028  jhkke1(ixx)=7
4029  ELSEIF (xpsaq(ixspr1)-xjq1(ixx)/2..GE.xsothr.AND.
4030  * xpsq(ixspr1)-xjq1(ixx)/2..GE.xsothr) THEN
4031  xpsq(ixspr1)=xpsq(ixspr1)-xjq1(ixx)/2.
4032  xpsaq(ixspr1)=xpsaq(ixspr1)-xjq1(ixx)/2.
4033  jhkke1(ixx)=8
4034  ELSEIF (xpvq(ixvpr)-xjq1(ixx).GE.xvthr) THEN
4035  xpvq(ixvpr)=xpvq(ixvpr)-xjq1(ixx)
4036  jhkke1(ixx)=3
4037  ELSEIF(xpvd(ixvpr)-xjq1(ixx).GE.xdthr) THEN
4038  xpvd(ixvpr)=xpvd(ixvpr)-xjq1(ixx)
4039  jhkke1(ixx)=4
4040  ENDIF
4041  71 CONTINUE
4042  ENDIF
4043 C
4044  ixsta=intss2(n)
4045  ixsta1=intss2(n+1)
4046  IF (n.EQ.nss)THEN
4047  IF (nss.GE.2)THEN
4048  ixsta1=intss2(n-1)
4049  ELSE
4050  ixsta1=ixsta
4051  ENDIF
4052  ENDIF
4053  inucta=ifrost(ixsta)
4054  jnucta=itovt(inucta)
4055 C
4056 C
4057 C SUBTRACT HARD SCATTERED X VALUES FROM DIQUARKS
4058 C
4059  iifrot=ifrost(ixsta)
4060  ixvta=itovt(iifrot)
4061 C
4062  IF (nhard.GE.1.AND.iminij.EQ.1) THEN
4063  DO 771 ixx=nonuj1,nonujt
4064  jhkkth(ixx)=ixvta
4065  IF(jhkke1(ixx).EQ.0) THEN
4066  jhkkex(ixx)=0
4067  go to 771
4068  ENDIF
4069  IF (xtsq(ixsta)-xjq2(ixx).GE.xsothr) THEN
4070  xtsq(ixsta)=xtsq(ixsta)-xjq2(ixx)
4071  jhkkex(ixx)=1
4072  nomjer=nomjer+1
4073  ELSEIF (xtsaq(ixsta)-xjq2(ixx).GE.xsothr) THEN
4074  xtsaq(ixsta)=xtsaq(ixsta)-xjq2(ixx)
4075  jhkkex(ixx)=1
4076  nomjer=nomjer+1
4077  ELSEIF (xtsaq(ixsta)-xjq2(ixx)/2..GE.xsothr.AND.
4078  * xtsq(ixsta)-xjq2(ixx)/2..GE.xsothr) THEN
4079  xtsaq(ixsta)=xtsaq(ixsta)-xjq2(ixx)/2.
4080  xtsq(ixsta)=xtsq(ixsta)-xjq2(ixx)/2.
4081  jhkkex(ixx)=1
4082  nomjer=nomjer+1
4083  ELSEIF (xtsq(ixsta1)-xjq2(ixx).GE.xsothr) THEN
4084  xtsq(ixsta1)=xtsq(ixsta1)-xjq2(ixx)
4085  jhkkex(ixx)=1
4086  nomjer=nomjer+1
4087  ELSEIF (xtsaq(ixsta1)-xjq2(ixx).GE.xsothr) THEN
4088  xtsaq(ixsta1)=xtsaq(ixsta1)-xjq2(ixx)
4089  jhkkex(ixx)=1
4090  nomjer=nomjer+1
4091  ELSEIF (xtsaq(ixsta1)-xjq2(ixx)/2..GE.xsothr.AND.
4092  * xtsq(ixsta1)-xjq2(ixx)/2..GE.xsothr) THEN
4093  xtsaq(ixsta1)=xtsaq(ixsta1)-xjq2(ixx)/2.
4094  xtsq(ixsta1)=xtsq(ixsta1)-xjq2(ixx)/2.
4095  jhkkex(ixx)=1
4096  nomjer=nomjer+1
4097  ELSEIF (xtvq(ixvta)-xjq2(ixx).GE.xvthr) THEN
4098  xtvq(ixvta)=xtvq(ixvta)-xjq2(ixx)
4099  jhkkex(ixx)=1
4100  nomjer=nomjer+1
4101  ELSEIF(xtvd(ixvta)-xjq2(ixx).GE.xdthr) THEN
4102  xtvd(ixvta)=xtvd(ixvta)-xjq2(ixx)
4103  jhkkex(ixx)=1
4104  nomjer=nomjer+1
4105  ELSE
4106  jhkkex(ixx)=0
4107  IF (jhkke1(ixx).EQ.1) THEN
4108  xpsq(ixspr)=xpsq(ixspr)+xjq1(ixx)
4109  ELSEIF (jhkke1(ixx).EQ.2) THEN
4110  xpsaq(ixspr)=xpsaq(ixspr)+xjq1(ixx)
4111  ELSEIF (jhkke1(ixx).EQ.3) THEN
4112  xpvq(ixvpr)=xpvq(ixvpr)+xjq1(ixx)
4113  ELSEIF (jhkke1(ixx).EQ.4) THEN
4114  xpvd(ixvpr)=xpvd(ixvpr)+xjq1(ixx)
4115  ELSEIF (jhkke1(ixx).EQ.5) THEN
4116  xpsq(ixspr)=xpsq(ixspr)+xjq1(ixx)/2.
4117  xpsaq(ixspr)=xpsaq(ixspr)+xjq1(ixx)/2.
4118  ELSEIF (jhkke1(ixx).EQ.6) THEN
4119  xpsq(ixspr1)=xpsq(ixspr1)+xjq1(ixx)
4120  ELSEIF (jhkke1(ixx).EQ.7) THEN
4121  xpsaq(ixspr1)=xpsaq(ixspr1)+xjq1(ixx)
4122  ELSEIF (jhkke1(ixx).EQ.8) THEN
4123  xpsq(ixspr1)=xpsq(ixspr1)+xjq1(ixx)/2.
4124  xpsaq(ixspr1)=xpsaq(ixspr1)+xjq1(ixx)/2.
4125  ENDIF
4126  ENDIF
4127  771 CONTINUE
4128  ENDIF
4129 C
4130 C SUBTRACT SECONDARY SEA X VALUES FROM DIQUARKS
4131 C
4132  IF (nsea.GE.1)THEN
4133  DO 271 ixx=nonus1,nonust
4134  jhkkpz(ixx)=ixvpr
4135  jhkksx(ixx)=0
4136  jhkks1(ixx)=0
4137  IF (xpsq(ixspr)-xsq1(ixx)-xsaq1(ixx).GT.xvthr)THEN
4138  xpsq(ixspr)=xpsq(ixspr)-xsq1(ixx)-xsaq1(ixx)
4139  jhkks1(ixx)=3
4140  ELSEIF (xpsaq(ixspr)-xsq1(ixx)-xsaq1(ixx).GT.xvthr)THEN
4141  xpsaq(ixspr)=xpsaq(ixspr)-xsq1(ixx)-xsaq1(ixx)
4142  jhkks1(ixx)=4
4143  ELSEIF (xpvq(ixvpr)-xsq1(ixx)-xsaq1(ixx).GT.xvthr)THEN
4144  xpvq(ixvpr)=xpvq(ixvpr)-xsq1(ixx)-xsaq1(ixx)
4145  jhkks1(ixx)=1
4146  ELSEIF (xpvd(ixvpr)-xsq1(ixx)-xsaq1(ixx).GT.xdthr)THEN
4147  xpvd(ixvpr)=xpvd(ixvpr)-xsq1(ixx)-xsaq1(ixx)
4148  jhkks1(ixx)=2
4149  ENDIF
4150  271 CONTINUE
4151  ENDIF
4152 C
4153  inucta=ifrovt(ixvta)
4154 C
4155 C SUBTRACT SECONDARY SEA X VALUES FROM DIQUARKS
4156 C
4157  IF (nsea.GE.1)THEN
4158  DO 2771 ixx=nonus1,nonust
4159  jhkktz(ixx)=ixvta
4160  IF (jhkks1(ixx).EQ.0)THEN
4161  jhkksx(ixx)=0
4162  go to 2771
4163  ENDIF
4164  IF (xtsq(ixsta)-xsq2(ixx)-xsaq2(ixx).GT. xvthr) THEN
4165  xtsq(ixsta)=xtsq(ixsta)-xsq2(ixx)-xsaq2(ixx)
4166  jhkksx(ixx)=1
4167 C NOMJER=NOMJER+1
4168  ELSEIF (xtsaq(ixsta)-xsq2(ixx)-xsaq2(ixx).GT. xvthr) THEN
4169  xtsaq(ixsta)=xtsaq(ixsta)-xsq2(ixx)-xsaq2(ixx)
4170  jhkksx(ixx)=1
4171 C NOMJER=NOMJER+1
4172  ELSEIF (xtvq(ixvta)-xsq2(ixx)-xsaq2(ixx).GT. xvthr) THEN
4173  xtvq(ixvta)=xtvq(ixvta)-xsq2(ixx)-xsaq2(ixx)
4174  jhkksx(ixx)=1
4175 C NOMJER=NOMJER+1
4176  ELSEIF(xtvd(ixvta)-xsq2(ixx)-xsaq2(ixx).GT.xdthr)THEN
4177  xtvd(ixvta)=xtvd(ixvta)-xsq2(ixx)-xsaq2(ixx)
4178  jhkksx(ixx)=1
4179 C NOMJER=NOMJER+1
4180  ELSE
4181  jhkksx(ixx)=0
4182  IF (jhkks1(ixx).EQ.1)THEN
4183  xpvq(ixvpr)=xpvq(ixvpr)+xsq1(ixx)+xsaq1(ixx)
4184  ELSEIF(jhkks1(ixx).EQ.2)THEN
4185  xpvd(ixvpr)=xpvd(ixvpr)+xsq1(ixx)+xsaq1(ixx)
4186  ELSEIF(jhkks1(ixx).EQ.3)THEN
4187  xpsq(ixspr)=xpsq(ixspr)+xsq1(ixx)+xsaq1(ixx)
4188  ELSEIF(jhkks1(ixx).EQ.4)THEN
4189  xpsaq(ixspr)=xpsaq(ixspr)+xsq1(ixx)+xsaq1(ixx)
4190  ENDIF
4191  ENDIF
4192  2771 CONTINUE
4193  ENDIF
4194 C
4195 C
4196  xmax1=xpsq(ixspr)+xpsaq(ixspr)+xpvq(ixvpr)+xpvd(ixvpr)
4197  * -2.d0*xsothr-xvthr-xdthr
4198  xmax2=xtsq(ixsta)+xtsaq(ixsta)+xtvq(ixvta)+xtvd(ixvta)
4199  * -2.d0*xsothr-xvthr-xdthr
4200 C
4201  IF(ipev.GE.1)WRITE(6,'(A,2I5,4F9.3/A,2I5,4F9.3/A,3F9.3)')
4202  *'IXSPR,IXVPR,XPSQ(IXSPR),XPSAQ(IXSPR),XPVQ(IXVPR),XPVD(IXVPR)'
4203  *,ixspr,ixvpr,xpsq(ixspr),xpsaq(ixspr),xpvq(ixvpr),xpvd(ixvpr),
4204  *'IXSTA,IXVTA,XTSQ(IXSTA),XTSAQ(IXSTA),XTVQ(IXVTA),XTVD(IXVTA)'
4205  *,ixsta,ixvta,xtsq(ixsta),xtsaq(ixsta),xtvq(ixvta),xtvd(ixvta),
4206  *'XSOTHR,XVTHR,XDTHR'
4207  *,xsothr,xvthr,xdthr
4208  IF(ipev.GE.1)WRITE(6,'(A,2I5,2F9.3)')' KKEVSS,aft xptfl:n,nss'
4209  * ,n,nss,xmax1,xmax2
4210 C===================================================================
4211 C-----------------------------------------------------------------------
4212 C DO 20 N=1,NSS
4213 C---------------------------drop recombined chain pairs
4214 C IF(NCHSS1(N).EQ.99.AND.NCHSS2(N).EQ.99)GO TO 20
4215 C*** 4-MOMENTA OF PROJECTILE SEA-QUARK PAIRS IN NN-CMS
4216  ixspr=intss1(n)
4217  inucpr=ifrosp(ixspr)
4218  jnucpr=itovp(inucpr)
4219 C
4220  psqpx=xpsq(ixspr)*prmom(1,inucpr)
4221  psqpy=xpsq(ixspr)*prmom(2,inucpr)
4222  psqpz=xpsq(ixspr)*prmom(3,inucpr)
4223  psqe=xpsq(ixspr)*prmom(4,inucpr)
4224  psaqpx=xpsaq(ixspr)*prmom(1,inucpr)
4225  psaqpy=xpsaq(ixspr)*prmom(2,inucpr)
4226  psaqpz=xpsaq(ixspr)*prmom(3,inucpr)
4227  psaqe=xpsaq(ixspr)*prmom(4,inucpr)
4228 C
4229 C*** 4-MOMENTA OF TARGET SEA-QUARK PAIRS IN NN-CMS
4230  ixsta=intss2(n)
4231  inucta=ifrost(ixsta)
4232  jnucta=itovt(inucta)
4233 C
4234  tsqpx=xtsq(ixsta)*tamom(1,inucta)
4235  tsqpy=xtsq(ixsta)*tamom(2,inucta)
4236  tsqpz=xtsq(ixsta)*tamom(3,inucta)
4237  tsqe=xtsq(ixsta)*tamom(4,inucta)
4238  tsaqpx=xtsaq(ixsta)*tamom(1,inucta)
4239  tsaqpy=xtsaq(ixsta)*tamom(2,inucta)
4240  tsaqpz=xtsaq(ixsta)*tamom(3,inucta)
4241  tsaqe=xtsaq(ixsta)*tamom(4,inucta)
4242 C j.r.6.5.93
4243 C
4244 C multiple scattering of sea quark chain ends
4245 C
4246  IF(it.GT.1)THEN
4247  itnu=ip+inucta
4248  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
4249  rtiy=vhkk(2,itnu)*1.e12
4250  rtiz=vhkk(3,itnu)*1.e12
4251  CALL cromsc(psqpx,psqpy,psqpz,psqe,rtix,rtiy,rtiz,
4252  * psqnx,psqny,psqnz,psqne,5)
4253  psqpx=psqnx
4254  psqpy=psqny
4255  psqpz=psqnz
4256  psqe=psqne
4257  CALL cromsc(psaqpx,psaqpy,psaqpz,psaqe,rtix,rtiy,rtiz,
4258  * psaqnx,psaqny,psaqnz,psaqne,6)
4259  psaqpx=psaqnx
4260  psaqpy=psaqny
4261  psaqpz=psaqnz
4262  psaqe=psaqne
4263 C ---------
4264 
4265 C j.r.6.5.93
4266 C
4267 C multiple scattering of sea quark chain ends
4268 C
4269  itnu=ip+inucta
4270  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
4271  rtiy=vhkk(2,itnu)*1.e12
4272  rtiz=vhkk(3,itnu)*1.e12
4273  CALL cromsc(tsqpx,tsqpy,tsqpz,tsqe,rtix,rtiy,rtiz,
4274  * tsqnx,tsqny,tsqnz,tsqne,7)
4275  tsqpx=tsqnx
4276  tsqpy=tsqny
4277  tsqpz=tsqnz
4278  tsqe=tsqne
4279  CALL cromsc(tsaqpx,tsaqpy,tsaqpz,tsaqe,rtix,rtiy,rtiz,
4280  * tsaqnx,tsaqny,tsaqnz,tsaqne,8)
4281  tsaqpx=tsaqnx
4282  tsaqpy=tsaqny
4283  tsaqpz=tsaqnz
4284  tsaqe=tsaqne
4285  ENDIF
4286 C j.r.10.5.93
4287  IF(ip.GE.1)go to 1779
4288  psqpz2=psqe**2-psqpx**2-psqpy**2
4289  IF(psqpz2.GE.0.)THEN
4290  psqpz=sqrt(psqpz2)
4291  ELSE
4292  psqpx=0.
4293  psqpy=0.
4294  psqpz=psqe
4295  ENDIF
4296 C
4297  paqpz2=psaqe**2-psaqpx**2-psaqpy**2
4298  IF(paqpz2.GE.0.)THEN
4299  psaqpz=sqrt(paqpz2)
4300  ELSE
4301  psaqpx=0.
4302  psaqpy=0.
4303  psaqpz=psaqe
4304  ENDIF
4305 C
4306  tsqpz2=tsqe**2-tsqpx**2-tsqpy**2
4307  IF(tsqpz2.GE.0.)THEN
4308  tsqpz=-sqrt(tsqpz2)
4309  ELSE
4310  tsqpx=0.
4311  tsqpy=0.
4312  tsqpz=tsqe
4313  ENDIF
4314 C
4315  taqpz2=tsaqe**2-tsaqpx**2-tsaqpy**2
4316  IF(taqpz2.GE.0.)THEN
4317  tsaqpz=-sqrt(taqpz2)
4318  ELSE
4319  tsaqpx=0.
4320  tsaqpy=0.
4321  tsaqpz=psaqe
4322  ENDIF
4323  1779 CONTINUE
4324 C ---------
4325 C
4326 C changej.r.6.5.93
4327  ptxsq1=0.
4328  ptxsa1=0.
4329  ptxsq2=0.
4330  ptxsa2=0.
4331  ptysq1=0.
4332  ptysa1=0.
4333  ptysq2=0.
4334  ptysa2=0.
4335  ptxsq1=psqpx
4336  ptxsa1=psaqpx
4337  ptxsq2=tsqpx
4338  ptxsa2=tsaqpx
4339  ptysq1=psqpy
4340  ptysa1=psaqpy
4341  ptysq2=tsqpy
4342  ptysa2=tsaqpy
4343  plq1=psqpz
4344  plaq1=psaqpz
4345  plq2=tsqpz
4346  plaq2=tsaqpz
4347  eq1=psqe
4348  eaq1=psaqe
4349  eq2=tsqe
4350  eaq2=tsaqe
4351 C ---------------
4352  IF(ipev.GE.1) THEN
4353  WRITE(6,1060) irss13
4354  WRITE(6,1070) ptxsq1,
4355  + ptysq1,plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,
4356  + plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,
4357  + pttq1,ptta1
4358  ENDIF
4359  ikvala=0
4360  nselpt=0
4361  IF(ip.EQ.1)nselpt=1
4362  IF(iouxev.GE.6)WRITE(6,'(A)')' KKEVSS call SELPT'
4363  IF(nselpt.EQ.1)CALL selpt( ptxsq1,ptysq1,plq1,
4364  + eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
4365  + ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
4366  * pttq2,ptta2,
4367  + nselpt)
4368  IF(nselpt.EQ.0)CALL selpt4( ptxsq1,ptysq1,plq1,
4369  + eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
4370  + ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
4371  + nselpt)
4372  IF(ipev.GE.1) THEN
4373  WRITE(6,1060) irss13
4374  WRITE(6,1070) ptxsq1,
4375  + ptysq1,plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,
4376  + plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,
4377  + pttq1,ptta1
4378  ENDIF
4379  IF (irej.EQ.1) THEN
4380  irss13=irss13 + 1
4381  IF(ipev.GE.1) THEN
4382  WRITE(6,1060) irss13
4383  WRITE(6,1070) ptxsq1,
4384  + ptysq1,plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,
4385  + plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,
4386  + pttq1,ptta1
4387  ENDIF
4388  go to 10
4389  ENDIF
4390 C
4391 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
4392 C
4393  ptxch1=ptxsq1 + ptxsa2
4394  ptych1=ptysq1 + ptysa2
4395  ptzch1=plq1 + plaq2
4396  ech1=eq1 + eaq2
4397  ptxch2=ptxsq2 + ptxsa1
4398  ptych2=ptysq2 + ptysa1
4399  ptzch2=plq2 + plaq1
4400  ech2=eq2 + eaq1
4401  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
4402  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
4403 C
4404 *
4405  IF (ipev.GE.6) WRITE(6,1040) irej,
4406  + amch1,ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
4407 
4408 C
4409 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS
4410 C FIRST FOR CHAIN 1 (PROSQ - TARASQ, I.E. QUARK-AQUARK)
4411 C
4412  CALL comcma(ipsq(ixspr),itsaq(ixsta), ijnch1,nnch1,irej,amch1,
4413  + amch1n)
4414 C*** MASS BELOW PSEUDOSCALAR MASS
4415  IF(irej.EQ.1) THEN
4416  irss11=irss11 + 1
4417  IF(ipev.GE.1) THEN
4418  WRITE(6,1080) irss11
4419  WRITE(6,1100) ipsq(ixspr),itsaq(ixsta),ijnch1,nnch1,irej,
4420  + xpsq(ixspr),xpsaq(ixspr),xpsqcm,xpsacm, xtsq(ixsta),xtsaq
4421  + (ixsta),xtsqcm,xtsacm, amch1,amch1n
4422 
4423  ENDIF
4424  goto 10
4425  ENDIF
4426 C CORRECT KINEMATICS FOR CHAIN 1
4427 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
4428  IF(nnch1.NE.0)THEN
4429  CALL cormom(amch1,amch2,amch1n,amch2n,
4430  + ptxsq1,ptysq1,plq1,eq1,
4431  + ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,
4432  + plaq2,eaq2, ptxch1,ptych1,ptzch1,ech1, ptxch2,ptych2,ptzch2,
4433  + ech2,irej)
4434  amch2=amch2n
4435  ENDIF
4436  IF(irej.EQ.1)go to 10
4437 C
4438  IF(ipev.GE.6)WRITE(6,1050) irej,
4439  + amch1,ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
4440 
4441 C
4442 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS
4443 C SECOND FOR CHAIN 2 (PROSAQ - TARSQ, I.E. AQUARK-QUARK)
4444 C
4445  CALL comcma(itsq(ixsta),ipsaq(ixspr), ijnch2,nnch2,irej,amch2,
4446  + amch2n)
4447 c rejection of both s-s chains if mass of chain 2 too low
4448  IF(irej.EQ.1) THEN
4449  irss12=irss12 + 1
4450  IF(ipev.GE.1) THEN
4451  WRITE(6,1090) irss12
4452  WRITE(6,1100) ipsaq(ixspr),itsq(ixsta),ijnch2,nnch2,irej,
4453  + xpsq(ixspr),xpsaq(ixspr),xpsqcm,xpsacm, xtsq(ixsta),xtsaq
4454  + (ixsta),xtsqcm,xtsacm, amch2,amch2n
4455 
4456  ENDIF
4457  goto 10
4458  ENDIF
4459 C if AMCH2 changed in COBCMA/COMCMA
4460 C CORVAL corrects chain kinematics
4461 C according to 2-body kinem.
4462 C with fixed masses
4463  IF(nnch2.NE.0) THEN
4464  amch2=amch2n
4465  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
4466  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
4467  eee=ech1+ech2
4468  pxxx=ptxch1+ptxch2
4469  pyyy=ptych1+ptych2
4470  pzzz=ptzch1+ptzch2
4471  gammm=eee/(ammm+1.e-4)
4472  bgggx=pxxx/(ammm+1.e-4)
4473  bgggy=pyyy/(ammm+1.e-4)
4474  bgggz=pzzz/(ammm+1.e-4)
4475 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
4476 C
4477 C 4-MOMENTA OF CHAINS
4478  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
4479  + ptxch1,ptych1,ptzch1,ech1,
4480  + pppch1, qtxch1,qtych1,qtzch1,qech1)
4481 C
4482  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
4483  + ptxch2,ptych2,ptzch2,ech2,
4484  + pppch2, qtxch2,qtych2,qtzch2,qech2)
4485 C
4486  norig=22
4487  CALL corval(ammm,irej,amch1,amch2, qtxch1,qtych1,qtzch1,qech1,
4488  + qtxch2,qtych2,qtzch2,qech2,norig)
4489 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
4490 C
4491 C 4-MOMENTA OF CHAINS
4492 
4493  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch1,qtych1,qtzch1,qech1,
4494  + pppch1, ptxch1,ptych1,ptzch1,ech1)
4495 C
4496  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch2,qtych2,qtzch2,qech2,
4497  + pppch2, ptxch2,ptych2,ptzch2,ech2)
4498 C
4499 C
4500  IF(ipev.GE.6) THEN
4501  WRITE(6,'(A/3(1PE15.4),3I5)')
4502  + ' SS - CALL CORVAL: AMMM, AMCH1, AMCH2, NNCH1, NNCH2, IREJ',
4503  + ammm, amch1, amch2, nnch1, nnch2, irej
4504  WRITE(6,1050) irej, amch1,
4505  + ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
4506 
4507  ENDIF
4508  IF(irej.EQ.1) THEN
4509 * AMCH1N + AMCH2N > AMMM - 0.2
4510 * reject event
4511  irss14=irss14+1
4512  goto 10
4513  ENDIF
4514  ENDIF
4515  qtxch1=ptxch1
4516  qtych1=ptych1
4517  qtzch1=ptzch1
4518  qech1=ech1
4519  qtxch2=ptxch2
4520  qtych2=ptych2
4521  qtzch2=ptzch2
4522  qech2=ech2
4523  pqssa1(n,1)=ptxsq1
4524  pqssa1(n,2)=ptysq1
4525  pqssa1(n,3)=plq1
4526  pqssa1(n,4)=eq1
4527  pqssa2(n,1)=ptxsa2
4528  pqssa2(n,2)=ptysa2
4529  pqssa2(n,3)=plaq2
4530  pqssa2(n,4)=eaq2
4531  pqssb1(n,1)=ptxsq2
4532  pqssb1(n,2)=ptysq2
4533  pqssb1(n,3)=plq2
4534  pqssb1(n,4)=eq2
4535  pqssb2(n,1)=ptxsa1
4536  pqssb2(n,2)=ptysa1
4537  pqssb2(n,3)=plaq1
4538  pqssb2(n,4)=eaq1
4539 C-------------------
4540 
4541 C
4542 C PUT S-S CHAIN ENDS INTO /HKKEVT/
4543 C MOMENTA IN NN-CMS
4544 C POSITION OF ORIGINAL NUCLEONS
4545 C
4546  ihkkpd=jhkkps(ixspr)
4547  ihkkpo=ihkkpd -1
4548  ihkktd=jhkkts(ixsta)
4549  ihkkto=ihkktd - 1
4550  IF (ipev.GT.3)WRITE(6,1000)ixspr,inucpr,jnucpr,ihkkpo,ihkkpd
4551  1000 FORMAT (' IXSPR,INUCPR,JNUCPR,IHKKPO,IHKKPD ',5i5)
4552  IF (ipev.GT.3)WRITE(6,1010)ixsta,inucta,jnucta,ihkkto,ihkktd
4553  1010 FORMAT (' IXSTA,INUCTA,JNUCTA,IHKKTO,IHKKTD ',5i5)
4554 C CHAIN 1 PROJECTILE SEA-QUARK
4555  nhkk=nhkk+1
4556  IF (nhkk.EQ.nmxhkk)THEN
4557  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
4558  RETURN
4559  ENDIF
4560  ihkk=nhkk
4561  isthkk(ihkk)=131
4562  idhkk(ihkk)=idhkk(ihkkpo)
4563  jmohkk(1,ihkk)=ihkkpo
4564  jmohkk(2,ihkk)=jmohkk(2,ihkkpo)
4565  jdahkk(1,ihkk)=ihkk+2
4566  jdahkk(2,ihkk)=ihkk+2
4567  phkk(1,ihkk)=pqssa1(n,1)
4568  phkk(2,ihkk)=pqssa1(n,2)
4569  phkk(3,ihkk)=pqssa1(n,3)
4570  phkk(4,ihkk)=pqssa1(n,4)
4571  phkk(5,ihkk)=0.
4572 C Add position of parton in hadron
4573  CALL qinnuc(xxpp,yypp)
4574  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
4575  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
4576  vhkk(3,ihkk)=vhkk(3,ihkkpo)
4577  vhkk(4,ihkk)=vhkk(4,ihkkpo)
4578  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
4579  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
4580  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
4581 
4582  1020 FORMAT (i6,i4,5i6,9e10.2)
4583 C CHAIN 1 TARGET SEA-QUARK
4584  nhkk=nhkk+1
4585  IF (nhkk.EQ.nmxhkk)THEN
4586  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
4587  RETURN
4588  ENDIF
4589  ihkk=nhkk
4590  isthkk(ihkk)=132
4591  idhkk(ihkk)=idhkk(ihkktd)
4592  jmohkk(1,ihkk)=ihkktd
4593  jmohkk(2,ihkk)=jmohkk(2,ihkktd)
4594  jdahkk(1,ihkk)=ihkk+1
4595  jdahkk(2,ihkk)=ihkk+1
4596  phkk(1,ihkk)=pqssa2(n,1)
4597  phkk(2,ihkk)=pqssa2(n,2)
4598  phkk(3,ihkk)=pqssa2(n,3)
4599  phkk(4,ihkk)=pqssa2(n,4)
4600  phkk(5,ihkk)=0.
4601 C Add position of parton in hadron
4602  CALL qinnuc(xxpp,yypp)
4603  vhkk(1,ihkk)=vhkk(1,ihkktd)+xxpp
4604  vhkk(2,ihkk)=vhkk(2,ihkktd)+yypp
4605  vhkk(3,ihkk)=vhkk(3,ihkktd)
4606  vhkk(4,ihkk)=vhkk(4,ihkktd)
4607  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
4608  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
4609  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
4610 
4611 C
4612 C CHAIN 1 BEFORE FRAGMENTATION
4613  nhkk=nhkk+1
4614  IF (nhkk.EQ.nmxhkk)THEN
4615  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
4616  RETURN
4617  ENDIF
4618  ihkk=nhkk
4619  isthkk(ihkk)=6
4620  idhkk(ihkk)=88888+nnch1
4621  jmohkk(1,ihkk)=ihkk-2
4622  jmohkk(2,ihkk)=ihkk-1
4623  phkk(1,ihkk)=qtxch1
4624  phkk(2,ihkk)=qtych1
4625  phkk(3,ihkk)=qtzch1
4626  phkk(4,ihkk)=qech1
4627  phkk(5,ihkk)=amch1
4628 C POSITION OF CREATED CHAIN IN LAB
4629 C =POSITION OF TARGET NUCLEON
4630 C TIME OF CHAIN CREATION IN LAB
4631 C =TIME OF PASSAGE OF PROJECTILE
4632 C NUCLEUS AT POSITION OF TAR. NUCLEUS
4633  vhkk(1,nhkk)= vhkk(1,nhkk-1)
4634  vhkk(2,nhkk)= vhkk(2,nhkk-1)
4635  vhkk(3,nhkk)= vhkk(3,nhkk-1)
4636  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
4637  mhkkss(n)=ihkk
4638  IF (iprojk.EQ.1)THEN
4639  whkk(1,nhkk)= vhkk(1,nhkk-2)
4640  whkk(2,nhkk)= vhkk(2,nhkk-2)
4641  whkk(3,nhkk)= vhkk(3,nhkk-2)
4642  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
4643  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
4644  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
4645  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
4646 
4647  ENDIF
4648  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
4649  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
4650  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
4651 
4652 C
4653 C
4654 C CHAIN 2 PROJECTILE SEA-QUARK
4655  nhkk=nhkk+1
4656  IF (nhkk.EQ.nmxhkk)THEN
4657  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
4658  RETURN
4659  ENDIF
4660  ihkk=nhkk
4661  isthkk(ihkk)=131
4662  idhkk(ihkk)=idhkk(ihkkpd)
4663  jmohkk(1,ihkk)=ihkkpd
4664  jmohkk(2,ihkk)=jmohkk(2,ihkkpd)
4665  jdahkk(1,ihkk)=ihkk+2
4666  jdahkk(2,ihkk)=ihkk+2
4667  phkk(1,ihkk)=pqssb1(n,1)
4668  phkk(2,ihkk)=pqssb1(n,2)
4669  phkk(3,ihkk)=pqssb1(n,3)
4670  phkk(4,ihkk)=pqssb1(n,4)
4671  phkk(5,ihkk)=0.
4672 C Add position of parton in hadron
4673  CALL qinnuc(xxpp,yypp)
4674  vhkk(1,ihkk)=vhkk(1,ihkkpd)+xxpp
4675  vhkk(2,ihkk)=vhkk(2,ihkkpd)+yypp
4676  vhkk(3,ihkk)=vhkk(3,ihkkpd)
4677  vhkk(4,ihkk)=vhkk(4,ihkkpd)
4678  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
4679  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
4680  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
4681 
4682 C CHAIN 2 TARGET SEA-QUARK
4683  nhkk=nhkk+1
4684  IF (nhkk.EQ.nmxhkk)THEN
4685  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
4686  RETURN
4687  ENDIF
4688  ihkk=nhkk
4689  isthkk(ihkk)=132
4690  idhkk(ihkk)=idhkk(ihkkto)
4691  jmohkk(1,ihkk)=ihkkto
4692  jmohkk(2,ihkk)=jmohkk(2,ihkkto)
4693  jdahkk(1,ihkk)=ihkk+1
4694  jdahkk(2,ihkk)=ihkk+1
4695  phkk(1,ihkk)=pqssb2(n,1)
4696  phkk(2,ihkk)=pqssb2(n,2)
4697  phkk(3,ihkk)=pqssb2(n,3)
4698  phkk(4,ihkk)=pqssb2(n,4)
4699  phkk(5,ihkk)=0.
4700 C Add position of parton in hadron
4701  CALL qinnuc(xxpp,yypp)
4702  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
4703  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
4704  vhkk(3,ihkk)=vhkk(3,ihkkto)
4705  vhkk(4,ihkk)=vhkk(4,ihkkto)
4706  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
4707  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
4708  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
4709 
4710 C
4711 C CHAIN 2 BEFORE FRAGMENTATION
4712  nhkk=nhkk+1
4713  IF (nhkk.EQ.nmxhkk)THEN
4714  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
4715  RETURN
4716  ENDIF
4717  ihkk=nhkk
4718  isthkk(ihkk)=6
4719  idhkk(ihkk)=88888+nnch2
4720  jmohkk(1,ihkk)=ihkk-2
4721  jmohkk(2,ihkk)=ihkk-1
4722  phkk(1,ihkk)=qtxch2
4723  phkk(2,ihkk)=qtych2
4724  phkk(3,ihkk)=qtzch2
4725  phkk(4,ihkk)=qech2
4726  phkk(5,ihkk)=amch2
4727 C POSITION OF CREATED CHAIN IN LAB
4728 C =POSITION OF TARGET NUCLEON
4729 C TIME OF CHAIN CREATION IN LAB
4730 C =TIME OF PASSAGE OF PROJECTILE
4731 C NUCLEUS AT POSITION OF TAR. NUCLEUS
4732  vhkk(1,nhkk)= vhkk(1,nhkk-1)
4733  vhkk(2,nhkk)= vhkk(2,nhkk-1)
4734  vhkk(3,nhkk)= vhkk(3,nhkk-1)
4735  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
4736  mhkkss(n)=ihkk
4737  IF (iprojk.EQ.1)THEN
4738  whkk(1,nhkk)= vhkk(1,nhkk-2)
4739  whkk(2,nhkk)= vhkk(2,nhkk-2)
4740  whkk(3,nhkk)= vhkk(3,nhkk-2)
4741  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
4742  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
4743  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
4744  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
4745 
4746  ENDIF
4747  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
4748  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
4749  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
4750 
4751 C
4752 C NOW WE HAVE AN ACCEPTABLE SEA--SEA EVENT
4753 C AND PUT IT INTO THE HISTOGRAM
4754 C
4755  amcss1(n)=amch1
4756  amcss2(n)=amch2
4757  gacss1(n)=qech1/amch1
4758  bgxss1(n)=qtxch1/amch1
4759  bgyss1(n)=qtych1/amch1
4760  bgzss1(n)=qtzch1/amch1
4761  gacss2(n)=qech2/amch2
4762  bgxss2(n)=qtxch2/amch2
4763  bgyss2(n)=qtych2/amch2
4764  bgzss2(n)=qtzch2/amch2
4765  nchss1(n)=nnch1
4766  nchss2(n)=nnch2
4767  ijcss1(n)=ijnch1
4768  ijcss2(n)=ijnch2
4769  IF (ipev.GE.6)WRITE(6,1030)n, xpsq(ixspr),xpsaq(ixspr),xtsq
4770  + (ixsta),xtsaq(ixsta), ipsq(ixspr),ipsaq(ixspr),itsq(ixsta),itsaq
4771  + (ixsta), itsaq(ixsta), amcss1(n),amcss2(n),gacss1(n),gacss2(n),
4772  + bgxss1(n),bgyss1(n),bgzss1(n), bgxss2(n),bgyss2(n),bgzss2(n),
4773  + nchss1(n),nchss2(n),ijcss1(n),ijcss2(n), (pqssa1(n,ju),pqssa2
4774  + (n,ju),pqssb1(n,ju), pqssb2(n,ju),ju=1,4)
4775 
4776 
4777 
4778 
4779  go to 20
4780 C*** TREATMENT OF REJECTED SEA-SEA INTERACTIONS
4781  10 CONTINUE
4782  inloss(n)=.false.
4783  xpvd(jnucpr)=xpvd(jnucpr) + xpsq(ixspr) + xpsaq(ixspr)
4784  xtvd(jnucta)=xtvd(jnucta) + xtsaq(ixsta) + xtsq(ixsta)
4785  20 CONTINUE
4786 C
4787  1030 FORMAT(' SS - 104', i10,4f12.7,5i5/10x,4f12.6/10x,6f12.6,4i5/8f15.
4788  +5/8f15.5)
4789  1040 FORMAT (' SS: IREJ ',i10/
4790  +' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
4791  +' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
4792  1050 FORMAT (' SS: IREJ ',i10/
4793  +' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
4794  +' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
4795  1060 FORMAT(' KKEVSS - IRSS13=',i5)
4796  1070 FORMAT( ' SS - 8002',4(4e12.4/),2e12.4/2i5/4e12.4)
4797  1080 FORMAT(' KKEVSS - IRSS11=',i5)
4798  1090 FORMAT(' KKEVSS - IRSS12=',i5)
4799  1100 FORMAT(' SS - 8006', 5i5/2(4e12.4/),2e12.4)
4800  RETURN
4801  END
4802 *-- Author :
4803 C
4804 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4805 C
4806  SUBROUTINE kkevvs(IREJVS)
4807  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4808  SAVE
4809 C
4810 C TREATMENT OF VALENCE-SEA CHAIN SYSTEMS
4811 C
4812 C---------------------------------------------------------------------
4813 C
4814 *KEEP,HKKEVT.
4815 c INCLUDE (HKKEVT)
4816  parameter(nmxhkk= 89998)
4817 c PARAMETER (NMXHKK=25000)
4818  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
4819  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
4820  +(4,nmxhkk)
4821 C
4822 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
4823 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
4824 C THE POSITIONS OF THE PROJECTILE NUCLEONS
4825 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
4826 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
4827 C COMPLETELY CONSISTENT. THE TIMES IN THE
4828 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
4829 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
4830 C
4831 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
4832 C
4833 C NMXHKK: maximum numbers of entries (partons/particles) that can be
4834 C stored in the commonblock.
4835 C
4836 C NHKK: the actual number of entries stored in current event. These are
4837 C found in the first NHKK positions of the respective arrays below.
4838 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
4839 C entry.
4840 C
4841 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
4842 C = 0 : null entry.
4843 C = 1 : an existing entry, which has not decayed or fragmented.
4844 C This is the main class of entries which represents the
4845 C "final state" given by the generator.
4846 C = 2 : an entry which has decayed or fragmented and therefore
4847 C is not appearing in the final state, but is retained for
4848 C event history information.
4849 C = 3 : a documentation line, defined separately from the event
4850 C history. (incoming reacting
4851 C particles, etc.)
4852 C = 4 - 10 : undefined, but reserved for future standards.
4853 C = 11 - 20 : at the disposal of each model builder for constructs
4854 C specific to his program, but equivalent to a null line in the
4855 C context of any other program. One example is the cone defining
4856 C vector of HERWIG, another cluster or event axes of the JETSET
4857 C analysis routines.
4858 C = 21 - : at the disposal of users, in particular for event tracking
4859 C in the detector.
4860 C
4861 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
4862 C standard.
4863 C
4864 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
4865 C The value is 0 for initial entries.
4866 C
4867 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
4868 C one mother exist, in which case the value 0 is used. In cluster
4869 C fragmentation models, the two mothers would correspond to the q
4870 C and qbar which join to form a cluster. In string fragmentation,
4871 C the two mothers of a particle produced in the fragmentation would
4872 C be the two endpoints of the string (with the range in between
4873 C implied).
4874 C
4875 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
4876 C entry has not decayed, this is 0.
4877 C
4878 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
4879 C entry has not decayed, this is 0. It is assumed that the daughters
4880 C of a particle (or cluster or string) are stored sequentially, so
4881 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
4882 C daughters. Even in cases where only one daughter is defined (e.g.
4883 C K0 -> K0S) both values should be defined, to make for a uniform
4884 C approach in terms of loop constructions.
4885 C
4886 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
4887 C
4888 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
4889 C
4890 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
4891 C
4892 C PHKK(4,IHKK) : energy, in GeV.
4893 C
4894 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
4895 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
4896 C
4897 C VHKK(1,IHKK) : production vertex x position, in mm.
4898 C
4899 C VHKK(2,IHKK) : production vertex y position, in mm.
4900 C
4901 C VHKK(3,IHKK) : production vertex z position, in mm.
4902 C
4903 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
4904 C********************************************************************
4905 *KEEP,INTMX.
4906  parameter(intmx=2488,intmd=252)
4907 *KEEP,DXQX.
4908 C INCLUDE (XQXQ)
4909 * NOTE: INTMX set via INCLUDE(INTMX)
4910  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
4911  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
4912  * ,xpsu(248),xtsu(248)
4913  * ,xpsut(248),xtsut(248)
4914 *KEEP,INTNEW.
4915  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
4916  +ixpv,ixps,ixtv,ixts, intvv1(248),
4917  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
4918  +intss1(intmx),intss2(intmx),
4919  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
4920  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
4921 
4922 C /INTNEW/
4923 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
4924 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
4925 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
4926 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
4927 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
4928 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
4929 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
4930 C FROM PROJECTILE/TARGET NUCLEI
4931 C-------------------
4932 *KEEP,IFROTO.
4933  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
4934  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
4935  +jhkknt
4936  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
4937  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
4938  & mhkkhh(intmx),
4939  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
4940 *KEEP,LOZUO.
4941  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
4942  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
4943  +intlo(intmx),inloss(intmx)
4944 C /LOZUO/
4945 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
4946 C REJECTED IN KKEVT
4947 C------------------
4948 *KEEP,DIQI.
4949  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
4950  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
4951  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
4952  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
4953 *KEEP,TRAFOP.
4954  COMMON /trafop/ gamp,bgamp,betp
4955 *KEEP,NUCC.
4956  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
4957 *KEEP,NUCIMP.
4958  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
4959  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
4960  +prebin,taebin,fermod,etacou
4961 *KEEP,ABRVS.
4962  COMMON /abrvs/ amcvs1(248),amcvs2(248),gacvs1(248),gacvs2(248),
4963  +bgxvs1(248),bgyvs1(248),bgzvs1(248), bgxvs2(248),bgyvs2(248),
4964  +bgzvs2(248), nchvs1(248),nchvs2(248),ijcvs1(248),ijcvs2(248),
4965  +pqvsa1(248,4),pqvsa2(248,4), pqvsb1(248,4),pqvsb2(248,4)
4966 *KEEP,DROPPT.
4967  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
4968  +ishmal,lpauli
4969  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
4970  +ipadis,ishmal,lpauli
4971 *KEEP,NUCPOS.
4972  COMMON /nucpos/invvp(248),invvt(248),invsp(248),invst(248), nuvv,
4973  +nuvs,nusv,nuss,insvp(248),insvt(248),inssp(248),insst(248), isveap
4974  +(248),isveat(248),isseap(248),isseat(248), ivseap(248),ivseat
4975  +(248), islosp(248),islost(248),inoop(248),inoot(248),nuoo
4976 *KEEP,TAUFO.
4977  COMMON /taufo/ taufor,ktauge,itauve,incmod
4978 *KEEP,RTAR.
4979  COMMON /rtar/ rtarnu
4980 *KEEP,INNU.
4981  COMMON /innu/inudec
4982 *KEEP,DINPDA.
4983  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
4984  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
4985 *KEEP,FERMI.
4986  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
4987  +(4,248)
4988 *KEEP,KETMAS.
4989  COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
4990 *KEEP,DPAR.
4991 C /DPAR/ CONTAINS PARTICLE PROPERTIES
4992 C ANAME = LITERAL NAME OF THE PARTICLE
4993 C AAM = PARTICLE MASS IN GEV
4994 C GA = DECAY WIDTH
4995 C TAU = LIFE TIME OF INSTABLE PARTICLES
4996 C IICH = ELECTRIC CHARGE OF THE PARTICLE
4997 C IIBAR = BARYON NUMBER
4998 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
4999 C
5000  CHARACTER*8 aname
5001  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
5002  +iibar(210),k1(210),k2(210)
5003 C------------------
5004 *KEEP,DPRIN.
5005  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
5006 *KEEP,NUCKOO.
5007  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
5008  +tpoo(3,intmx)
5009 *KEEP,REJEC.
5010  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
5011  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
5012  +irvs14, irvv11,irvv12,irvv13,irvv14
5013 *KEEP,PROJK.
5014  COMMON /projk/ iprojk
5015  common/rptshm/rproj,rtarg,bimpac
5016 
5017 *KEND.
5018 C===============================================================
5019 
5020  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
5021  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
5022  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
5023  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
5024  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
5025  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
5026  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
5027  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
5028  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
5029  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
5030  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
5031  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
5032  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
5033  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
5034  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
5035  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
5036  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
5037  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
5038  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
5039  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
5040  COMMON /zsea/zseaav,zseasu,anzsea
5041  irejvs=0
5042  iminij=1
5043 C
5044  DO 10 n=1,nvs
5045 C---------------------------drop recombined chain pairs
5046  IF(nchvs1(n).EQ.99.AND.nchvs2(n).EQ.99)go to 10
5047 C
5048 C-----------------------------------------------------------
5049  ixvpr=intvs1(n)
5050  inucpr=ifrovp(ixvpr)
5051  jnucpr=itovp(inucpr)
5052 C---
5053  ixsta=intvs2(n)
5054  inucta=ifrost(ixsta)
5055  jnucta=itovt(inucta)
5056  iifrot=ifrost(ixsta)
5057  ixvta=itovt(iifrot)
5058 C
5059  xmax1=xpvq(ixvpr)+xpvd(ixvpr)-xvthr-xdthr
5060  xmax2=xtsq(ixsta)+xtsaq(ixsta)+xtvq(ixvta)+xtvd(ixvta)
5061  * -2.d0*xsthr-xvthr-xdthr
5062 C
5063  IF(ipev.GE.1)WRITE(6,'(A,2I5,2F9.3)')' KKEVVS,bef xptfl:n,nvs'
5064  * ,n,nvs,xmax1,xmax2
5065  IF (iminij.EQ.1)THEN
5066  CALL xptfl(nhard,nsea,ireg,xmax1,xmax2)
5067 C NZSEA=NZSEA+1
5068 C ANZSEA=NZSEA
5069  anzsea=anzsea+1.d0
5070  zseasu=zseasu+nsea
5071  zseaav=zseasu/anzsea
5072  ENDIF
5073  IF(ipev.GE.1)WRITE(6,'(A,3I10)')' VS,xptfl:nhard,nsea,ireg '
5074  * ,nhard,nsea,ireg
5075  IF(ireg.EQ.1)nhard=0
5076  IF(ireg.EQ.1)nsea=0
5077  nomje=nomje+nhard
5078 C
5079 C
5080 C SUBTRACT HARD SCATTERED X VALUES FROM DIQUARKS
5081 C
5082  IF (nhard.GE.1.AND.iminij.EQ.1)THEN
5083  DO 71 ixx=nonuj1,nonujt
5084  jhkkph(ixx)=ixvpr
5085  jhkkex(ixx)=0
5086  jhkke1(ixx)=0
5087  IF (xpvq(ixvpr)-xjq1(ixx).GE.xvthr) THEN
5088  xpvq(ixvpr)=xpvq(ixvpr)-xjq1(ixx)
5089  jhkke1(ixx)=1
5090  ELSEIF(xpvd(ixvpr)-xjq1(ixx).GE.xdthr) THEN
5091  xpvd(ixvpr)=xpvd(ixvpr)-xjq1(ixx)
5092  jhkke1(ixx)=2
5093  ENDIF
5094  71 CONTINUE
5095  ENDIF
5096 C---
5097  ixsta=intvs2(n)
5098  inucta=ifrost(ixsta)
5099  jnucta=itovt(inucta)
5100 C
5101 C SUBTRACT HARD SCATTERED X VALUES FROM DIQUARKS
5102 C
5103  iifrot=ifrost(ixsta)
5104  ixvta=itovt(iifrot)
5105 C
5106  IF (nhard.GE.1.AND.iminij.EQ.1) THEN
5107  DO 771 ixx=nonuj1,nonujt
5108  jhkkth(ixx)=ixvta
5109  IF (jhkke1(ixx).EQ.0)THEN
5110  jhkkex(ixx)=0
5111  goto 771
5112  ENDIF
5113  IF (xtsq(ixsta)-xjq2(ixx).GE.xsthr) THEN
5114  xtsq(ixsta)=xtsq(ixsta)-xjq2(ixx)
5115  jhkkex(ixx)=1
5116  nomjer=nomjer+1
5117  ELSEIF (xtsaq(ixsta)-xjq2(ixx).GE.xsthr) THEN
5118  xtsaq(ixsta)=xtsaq(ixsta)-xjq2(ixx)
5119  jhkkex(ixx)=1
5120  nomjer=nomjer+1
5121  ELSEIF (xtvq(ixvta)-xjq2(ixx).GE.xvthr) THEN
5122  xtvq(ixvta)=xtvq(ixvta)-xjq2(ixx)
5123  jhkkex(ixx)=1
5124  nomjer=nomjer+1
5125  ELSEIF (xtvd(ixvta)-xjq2(ixx).GE.xdthr)THEN
5126  xtvd(ixvta)=xtvd(ixvta)-xjq2(ixx)
5127  jhkkex(ixx)=1
5128  nomjer=nomjer+1
5129  ELSE
5130  jhkkex(ixx)=0
5131  IF (jhkke1(ixx).EQ.1)THEN
5132  xpvq(ixvpr)=xpvq(ixvpr)+xjq1(ixx)
5133  ELSEIF (jhkke1(ixx).EQ.2)THEN
5134  xpvd(ixvpr)=xpvd(ixvpr)+xjq1(ixx)
5135  ENDIF
5136  ENDIF
5137  771 CONTINUE
5138  ENDIF
5139 C
5140 C
5141 C SUBTRACT SECONDARY SEA X VALUES FROM DIQUARKS
5142 C
5143  IF (nsea.GE.1)THEN
5144  DO 271 ixx=nonus1,nonust
5145  jhkkpz(ixx)=ixvpr
5146  jhkksx(ixx)=0
5147  jhkks1(ixx)=0
5148  IF (xpvq(ixvpr)-xsq1(ixx)-xsaq1(ixx).GT.xvthr)THEN
5149  xpvq(ixvpr)=xpvq(ixvpr)-xsq1(ixx)-xsaq1(ixx)
5150  jhkks1(ixx)=1
5151  ELSEIF (xpvd(ixvpr)-xsq1(ixx)-xsaq1(ixx).GT.xdthr)THEN
5152  xpvd(ixvpr)=xpvd(ixvpr)-xsq1(ixx)-xsaq1(ixx)
5153  jhkks1(ixx)=2
5154  ENDIF
5155  271 CONTINUE
5156  ENDIF
5157 C
5158  inucta=ifrovt(ixvta)
5159 C
5160 C SUBTRACT SECONDARY SEA X VALUES FROM DIQUARKS
5161 C
5162  IF (nsea.GE.1)THEN
5163  DO 2771 ixx=nonus1,nonust
5164  jhkktz(ixx)=ixvta
5165  IF (jhkks1(ixx).EQ.0)THEN
5166  jhkksx(ixx)=0
5167  go to 2771
5168  ENDIF
5169  IF (xtsq(ixsta)-xsq2(ixx)-xsaq2(ixx).GT. xvthr) THEN
5170  xtsq(ixsta)=xtsq(ixsta)-xsq2(ixx)-xsaq2(ixx)
5171  jhkksx(ixx)=1
5172 C NOMJER=NOMJER+1
5173  ELSEIF (xtsaq(ixsta)-xsq2(ixx)-xsaq2(ixx).GT. xvthr) THEN
5174  xtsaq(ixsta)=xtsaq(ixsta)-xsq2(ixx)-xsaq2(ixx)
5175  jhkksx(ixx)=1
5176 C NOMJER=NOMJER+1
5177  ELSEIF (xtvq(ixvta)-xsq2(ixx)-xsaq2(ixx).GT. xvthr) THEN
5178  xtvq(ixvta)=xtvq(ixvta)-xsq2(ixx)-xsaq2(ixx)
5179  jhkksx(ixx)=1
5180 C NOMJER=NOMJER+1
5181  ELSEIF(xtvd(ixvta)-xsq2(ixx)-xsaq2(ixx).GT.xdthr)THEN
5182  xtvd(ixvta)=xtvd(ixvta)-xsq2(ixx)-xsaq2(ixx)
5183  jhkksx(ixx)=1
5184 C NOMJER=NOMJER+1
5185  ELSE
5186  jhkksx(ixx)=0
5187  IF (jhkks1(ixx).EQ.1)THEN
5188  xpvq(ixvpr)=xpvq(ixvpr)+xsq1(ixx)+xsaq1(ixx)
5189  ELSEIF(jhkks1(ixx).EQ.2)THEN
5190  xpvd(ixvpr)=xpvd(ixvpr)+xsq1(ixx)+xsaq1(ixx)
5191  ENDIF
5192  ENDIF
5193  2771 CONTINUE
5194  ENDIF
5195 C
5196 C
5197  xmax1=xpvq(ixvpr)+xpvd(ixvpr)-xvthr-xdthr
5198  xmax2=xtsq(ixsta)+xtsaq(ixsta)+xtvq(ixvta)+xtvd(ixvta)
5199  * -2.d0*xsthr-xvthr-xdthr
5200 C
5201  IF(ipev.GE.1)WRITE(6,'(A,2I5,2F9.3)')' KKEVVS,aft xptfl:n,nvs'
5202  * ,n,nvs,xmax1,xmax2
5203  go to 1302
5204  2302 CONTINUE
5205 C
5206 C TRY TO INCREASE THE X-FRACTION OF TARGET SEA QUARK
5207 C ANTIQUARK PAIR BY XSTHR XTSQ(IXSTA) XTSAQ(IXSTA)
5208 C DECREASING TARGET DIQUARK XTVD(IXVTA)
5209 C
5210 C IF(XTSUT(IXVTA).EQ.0..AND.
5211 C * XTVD(IXVTA)-2.*XSTHR.GE.XDTHR) THEN
5212 C XTSQ(IXSTA)=XTSQ(IXSTA)+XSTHR
5213 C XTSAQ(IXSTA)=XTSAQ(IXSTA)+XSTHR
5214 C XTVD(IXVTA)=XTVD(IXVTA)-2.*XSTHR
5215 C IREJ=0
5216 C ELSE
5217 C GO TO 302
5218 C GO TO 10
5219 C ENDIF
5220  1302 CONTINUE
5221 C===============================================================
5222 C*** 4-MOMENTA OF PROJECTILE QUARKS AND DIQUARK-PAIRS IN NN-CMS
5223  ixvpr=intvs1(n)
5224  inucpr=ifrovp(ixvpr)
5225  jnucpr=itovp(inucpr)
5226 C
5227  pvqpx=xpvq(ixvpr)*prmom(1,inucpr)
5228  pvqpy=xpvq(ixvpr)*prmom(2,inucpr)
5229  pvqpz=xpvq(ixvpr)*prmom(3,inucpr)
5230  pvqe=xpvq(ixvpr)*prmom(4,inucpr)
5231  pvdqpx=xpvd(ixvpr)*prmom(1,inucpr)
5232  pvdqpy=xpvd(ixvpr)*prmom(2,inucpr)
5233  pvdqpz=xpvd(ixvpr)*prmom(3,inucpr)
5234  pvdqe=xpvd(ixvpr)*prmom(4,inucpr)
5235 C
5236  IF(ipev.GE.7) THEN
5237  WRITE(6,1000) pvqpx,pvqpy,pvqpz,pvqe, pvdqpx,pvdqpy,pvdqpz,
5238  + pvdqe
5239  1000 FORMAT(' VS: PVQPX,PVQPY,PVQPZ,PVQE',
5240  +' PVDQPX,PVDQPY,PVDQPZ,PVDQE',/4e15.5/15x,4e15.5)
5241  ENDIF
5242 C
5243 C*** 4-MOMENTA OF TARGET SEA-QUARK PAIRS IN NN-CMS
5244  ixsta=intvs2(n)
5245  inucta=ifrost(ixsta)
5246  jnucta=itovt(inucta)
5247 C
5248  tsqpx=xtsq(ixsta)*tamom(1,inucta)
5249  tsqpy=xtsq(ixsta)*tamom(2,inucta)
5250  tsqpz=xtsq(ixsta)*tamom(3,inucta)
5251  tsqe=xtsq(ixsta)*tamom(4,inucta)
5252  tsaqpx=xtsaq(ixsta)*tamom(1,inucta)
5253  tsaqpy=xtsaq(ixsta)*tamom(2,inucta)
5254  tsaqpz=xtsaq(ixsta)*tamom(3,inucta)
5255  tsaqe=xtsaq(ixsta)*tamom(4,inucta)
5256 C j.r.6.5.93
5257 C
5258 C multiple scattering of valence quark chain ends
5259 C
5260  IF(it.GT.1)THEN
5261  itnu=ip+inucta
5262  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
5263  rtiy=vhkk(2,itnu)*1.e12
5264  rtiz=vhkk(3,itnu)*1.e12
5265  CALL cromsc(pvqpx,pvqpy,pvqpz,pvqe,rtix,rtiy,rtiz,
5266  * pvqnx,pvqny,pvqnz,pvqne,9)
5267  pvqpx=pvqnx
5268  pvqpy=pvqny
5269  pvqpz=pvqnz
5270  pvqe=pvqne
5271  CALL cromsc(pvdqpx,pvdqpy,pvdqpz,pvdqe,rtix,rtiy,rtiz,
5272  * pvdqnx,pvdqny,pvdqnz,pvdqne,10)
5273  pvdqpx=pvdqnx
5274  pvdqpy=pvdqny
5275  pvdqpz=pvdqnz
5276  pvdqe=pvdqne
5277 C ---------
5278 C
5279  IF(ipev.GE.7) THEN
5280  WRITE(6,1010) n,nvs,ixvpr,inucpr,inucpr,ixsta,inucta,jnucta
5281  1010 FORMAT(' VS: N,NVS,IXVPR,INUCPR,INUCPR,IXSTA,INUCTA,JNUCTA'/ 8i5)
5282 
5283  WRITE(6,1020) tsqpx,tsqpy,tsqpz,tsqe, tsaqpx,tsaqpy,tsaqpz,
5284  + tsaqe
5285  1020 FORMAT(' VS: TSQPX,TSQPY,TSQPZ,TSQE',
5286  +' TSAQPX,TSAQPY,TSAQPZ,TSAQE',/4e15.5/15x,4e15.5)
5287  ENDIF
5288 C j.r.6.5.93
5289 C
5290 C multiple scattering of sea quark chain ends
5291 C
5292  itnu=ip+inucta
5293  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
5294  rtiy=vhkk(2,itnu)*1.e12
5295  rtiz=vhkk(3,itnu)*1.e12
5296  CALL cromsc(tsqpx,tsqpy,tsqpz,tsqe,rtix,rtiy,rtiz,
5297  * tsqnx,tsqny,tsqnz,tsqne,11)
5298  tsqpx=tsqnx
5299  tsqpy=tsqny
5300  tsqpz=tsqnz
5301  tsqe=tsqne
5302  CALL cromsc(tsaqpx,tsaqpy,tsaqpz,tsaqe,rtix,rtiy,rtiz,
5303  * tsaqnx,tsaqny,tsaqnz,tsaqne,12)
5304  tsaqpx=tsaqnx
5305  tsaqpy=tsaqny
5306  tsaqpz=tsaqnz
5307  tsaqe=tsaqne
5308  ENDIF
5309 C ---------
5310 C j.r.10.5.93
5311  IF(ip.GE.1)go to 1779
5312  pvqpz2=pvqe**2-pvqpx**2-pvqpy**2
5313  IF(pvqpz2.GE.0.)THEN
5314  pvqpz=sqrt(pvqpz2)
5315  ELSE
5316  pvqpx=0.
5317  pvqpy=0.
5318  pvqpz=pvqe
5319  ENDIF
5320 C
5321  pdqpz2=pvdqe**2-pvdqpx**2-pvdqpy**2
5322  IF(pdqpz2.GE.0.)THEN
5323  pvdqpz=sqrt(pdqpz2)
5324  ELSE
5325  pvdqpx=0.
5326  pvdqpy=0.
5327  pvdqpz=pvdqe
5328  ENDIF
5329 C
5330  tsqpz2=tsqe**2-tsqpx**2-tsqpy**2
5331  IF(tsqpz2.GE.0.)THEN
5332  tsqpz=-sqrt(tsqpz2)
5333  ELSE
5334  tsqpx=0.
5335  tsqpy=0.
5336  tsqpz=tsqe
5337  ENDIF
5338 C
5339  taqpz2=tsaqe**2-tsaqpx**2-tsaqpy**2
5340  IF(taqpz2.GE.0.)THEN
5341  tsaqpz=-sqrt(taqpz2)
5342  ELSE
5343  tsaqpx=0.
5344  tsaqpy=0.
5345  tsaqpz=tsaqe
5346  ENDIF
5347  1779 CONTINUE
5348 C ----------------
5349 C
5350 C*** SAMPLE PARTON-PT VALUES / DETERMINE PARTON 4-MOMENTA AND CHAIN MAS
5351 C*** IN THE REST FRAME DEFINED ABOVE
5352 C
5353  ikvala=0
5354 C changej.r.6.5.93
5355  ptxsq1=0.
5356  ptxsa1=0.
5357  ptxsq2=0.
5358  ptxsa2=0.
5359  ptysq1=0.
5360  ptysa1=0.
5361  ptysq2=0.
5362  ptysa2=0.
5363  ptxsq1=pvqpx
5364  ptxsa1=pvdqpx
5365  ptxsq2=tsqpx
5366  ptxsa2=tsaqpx
5367  ptysq1=pvqpy
5368  ptysa1=pvdqpy
5369  ptysq2=tsqpy
5370  ptysa2=tsaqpy
5371  plq1=pvqpz
5372  plaq1=pvdqpz
5373  plq2=tsqpz
5374  plaq2=tsaqpz
5375  eq1=pvqe
5376  eaq1=pvdqe
5377  eq2=tsqe
5378  eaq2=tsaqe
5379 C ---------------
5380  IF(ipev.GE.1) THEN
5381  WRITE(6,1140) irvs13
5382  WRITE(6,1090) ptxsq1,
5383  + ptysq1,plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,
5384  + plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,
5385  + pttq1,ptta1
5386  ENDIF
5387  ikvala=0
5388  nselpt=1
5389  nselpt=0
5390  IF(ip.EQ.1)nselpt=1
5391  IF(iouxev.GE.6)WRITE(6,'(A)')' KKEVVS call SELPT'
5392  IF(nselpt.EQ.1)CALL selpt( ptxsq1,ptysq1,plq1,
5393  + eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
5394  + ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
5395  * pttq2,ptta2,
5396  + nselpt)
5397  IF(nselpt.EQ.0)CALL selpt4( ptxsq1,ptysq1,plq1,
5398  + eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
5399  + ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
5400  + nselpt)
5401  IF (ipev.GE.1) WRITE(6,1070) irej
5402  IF (irej.EQ.1) THEN
5403  irvs13=irvs13 + 1
5404  IF(ipev.GE.1) THEN
5405  WRITE(6,1140) irvs13
5406  WRITE(6,1090) ptxsq1,
5407  + ptysq1,plq1,eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,
5408  + plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,
5409  + pttq1,ptta1
5410  ENDIF
5411  go to 20
5412  ENDIF
5413 C
5414 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
5415 C
5416  ptxch1=ptxsq1 + ptxsa2
5417  ptych1=ptysq1 + ptysa2
5418  ptzch1=plq1 + plaq2
5419  ech1=eq1 + eaq2
5420  ptxch2=ptxsq2 + ptxsa1
5421  ptych2=ptysq2 + ptysa1
5422  ptzch2=plq2 + plaq1
5423  ech2=eq2 + eaq1
5424  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
5425  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
5426 C
5427 C
5428  IF (ipev.GE.6)WRITE(6,1070) irej,
5429  + amch1,ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
5430 
5431 C
5432 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS OR OCTETT
5433 C OR DECUPLETT BARYONS
5434 C FIRST FOR CHAIN 1 (PROJ VAL-QUARK - TARGET SEA-AQUARK)
5435 C
5436  CALL comcma(ipvq(ixvpr),itsaq(ixsta), ijnch1,nnch1,irej,amch1,
5437  + amch1n)
5438 C*** MASS BELOW PSEUDOSCALAR MASS
5439  IF(irej.EQ.1) THEN
5440  irvs11=irvs11 + 1
5441  IF(ipev.GE.1) THEN
5442  WRITE(6,1150) irvs11
5443  WRITE(6,1110) ipvq(ixvpr),itsaq(ixsta),ijnch1,nnch1,irej,
5444  + xpvq(ixvpr),xpvd(ixvpr),xpvqcm,xpvdcm, xtsq(ixsta),xtsaq
5445  + (ixsta),xtsqcm,xtsacm, amch1,amch1n
5446 
5447  ENDIF
5448  goto 20
5449  ENDIF
5450 C CORRECT KINEMATICS FOR CHAIN 1
5451 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
5452  IF(nnch1.NE.0) THEN
5453  CALL cormom(amch1,amch2,amch1n,amch2n,
5454  + ptxsq1,ptysq1,plq1,eq1,
5455  + ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,
5456  + plaq2,eaq2, ptxch1,ptych1,ptzch1,ech1, ptxch2,ptych2,ptzch2,
5457  + ech2,irej)
5458  amch2=amch2n
5459  ENDIF
5460  IF(irej.EQ.1)THEN
5461  IF(ipev.EQ.1)WRITE(6,'(A)')' VS CORMOM REJECTION'
5462  go to 20
5463  ENDIF
5464 C
5465  IF (ipev.GE.6)WRITE(6,1080) irej,
5466  + amch1,ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
5467 
5468 C
5469 C SECOND FOR CHAIN 2 (PROJ VAL-DIQUARK - TAR SEA-QUARK)
5470 C
5471  CALL cobcma(itsq(ixsta),ippv1(ixvpr),ippv2(ixvpr), ijnch2,nnch2,
5472  + irej,amch2,amch2n,2)
5473 C*** MASS BELOW OCTETT BARYON MASS
5474 C
5475 C AT PRESENT NO CORRECTION FOR CHAIN 2
5476  IF(irej.EQ.1) THEN
5477  irvs12=irvs12 + 1
5478  IF(ipev.GE.1) THEN
5479  WRITE(6,1160) irvs12
5480  WRITE(6,1100) ippv1(ixvpr),ippv2(ixvpr),itsq(ixsta), ijnch2,
5481  + nnch2,irej, xpvq(ixvpr),xpvd(ixvpr),xpvqcm,xpvdcm, xtsq
5482  + (ixsta),xtsaq(ixsta),amch2,amch2n
5483 
5484  ENDIF
5485  goto 20
5486  ENDIF
5487  IF(nnch2.NE.0) THEN
5488  amch2=amch2n
5489  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
5490  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
5491  eee=ech1+ech2
5492  pxxx=ptxch1+ptxch2
5493  pyyy=ptych1+ptych2
5494  pzzz=ptzch1+ptzch2
5495  gammm=eee/(ammm+1.e-4)
5496  bgggx=pxxx/(ammm+1.e-4)
5497  bgggy=pyyy/(ammm+1.e-4)
5498  bgggz=pzzz/(ammm+1.e-4)
5499 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
5500 C
5501 C 4-MOMENTA OF CHAINS
5502  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
5503  + ptxch1,ptych1,ptzch1,ech1,
5504  + pppch1, qtxch1,qtych1,qtzch1,qech1)
5505 C
5506  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
5507  + ptxch2,ptych2,ptzch2,ech2,
5508  + pppch2, qtxch2,qtych2,qtzch2,qech2)
5509 C
5510 
5511 C if AMCH2 changed in COBCMA/COMCMA
5512 C CORVAL corrects chain kinematics
5513 C according to 2-body kinem.
5514 C with fixed masses
5515  norig=23
5516  CALL corval(ammm,irej,amch1,amch2, qtxch1,qtych1,qtzch1,qech1,
5517  + qtxch2,qtych2,qtzch2,qech2,norig)
5518 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
5519 C
5520 C 4-MOMENTA OF CHAINS
5521 C IREJ=1
5522  IF(irej.EQ.1) THEN
5523  IF(ipev.GE.1)WRITE(6,'(A)')' vs14 rej. '
5524 C AMCH1N + AMCH2N > AMMM - 0.2
5525 C REJECT EVENT
5526  irvs14=irvs14+1
5527  goto 20
5528  ENDIF
5529 
5530  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch1,qtych1,qtzch1,qech1,
5531  + pppch1, ptxch1,ptych1,ptzch1,ech1)
5532 C
5533  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch2,qtych2,qtzch2,qech2,
5534  + pppch2, ptxch2,ptych2,ptzch2,ech2)
5535 C
5536 
5537 C
5538  IF(ipev.GE.6) THEN
5539  WRITE(6,'(A/3(1PE15.4),3I5)')
5540  + ' VS - CALL CORVAL: AMMM, AMCH1, AMCH2, NNCH1, NNCH2, IREJ',
5541  + ammm, amch1, amch2, nnch1, nnch2, irej
5542  WRITE(6,1080) irej, amch1,
5543  + ptxch1,ptych1,ptzch1,ech1, amch2,ptxch2,ptych2,ptzch2,ech2
5544 
5545  ENDIF
5546 C
5547  IF(irej.EQ.1) THEN
5548  IF(ipev.GE.1)WRITE(6,'(A)')' vs14 rej. '
5549 C AMCH1N + AMCH2N > AMMM - 0.2
5550 C REJECT EVENT
5551  irvs14=irvs14+1
5552  goto 20
5553  ENDIF
5554  ENDIF
5555  qtxch1=ptxch1
5556  qtych1=ptych1
5557  qtzch1=ptzch1
5558  qech1=ech1
5559  qtxch2=ptxch2
5560  qtych2=ptych2
5561  qtzch2=ptzch2
5562  qech2=ech2
5563  pqvsa1(n,1)=ptxsq1
5564  pqvsa1(n,2)=ptysq1
5565  pqvsa1(n,3)=plq1
5566  pqvsa1(n,4)=eq1
5567  pqvsa2(n,1)=ptxsa2
5568  pqvsa2(n,2)=ptysa2
5569  pqvsa2(n,3)=plaq2
5570  pqvsa2(n,4)=eaq2
5571  pqvsb1(n,1)=ptxsq2
5572  pqvsb1(n,2)=ptysq2
5573  pqvsb1(n,3)=plq2
5574  pqvsb1(n,4)=eq2
5575  pqvsb2(n,1)=ptxsa1
5576  pqvsb2(n,2)=ptysa1
5577  pqvsb2(n,3)=plaq1
5578  pqvsb2(n,4)=eaq1
5579 C-------------------
5580 
5581 C
5582 C PUT V-S CHAIN ENDS INTO /HKKEVT/
5583 C MOMENTA IN NN-CMS
5584 C POSITION OF ORIGINAL NUCLEONS
5585 C
5586  ihkkpd=jhkkpv(ixvpr )
5587  ihkkpo=jhkkpv(ixvpr )-1
5588  ihkktd=jhkkts(ixsta )
5589  ihkkto=jhkkts(ixsta )-1
5590  IF (ipev.GT.3)WRITE(6,1030)ixvpr,inucpr,jnucpr,ihkkpo,ihkkpd
5591  1030 FORMAT (' VS: IXVPR,INUCPR,JNUCPR,IHKKPO,IHKKPD ',5i5)
5592  IF (ipev.GT.3)WRITE(6,1040)ixsta,inucta,jnucta,ihkkto,ihkktd
5593  1040 FORMAT (' VS: IXSTA,INUCTA,JNUCTA,IHKKTO,IHKKTD ',5i5)
5594 C CHAIN 1 PROJECTILE QUARK
5595  nhkk=nhkk+1
5596  IF (nhkk.EQ.nmxhkk)THEN
5597  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
5598  RETURN
5599  ENDIF
5600  ihkk=nhkk
5601  isthkk(ihkk)=121
5602  idhkk(ihkk)=idhkk(ihkkpo)
5603  jmohkk(1,ihkk)=ihkkpo
5604  jmohkk(2,ihkk)=jmohkk(1,ihkkpo)
5605  jdahkk(1,ihkk)=ihkk+2
5606  jdahkk(2,ihkk)=ihkk+2
5607  phkk(1,ihkk)=pqvsa1(n,1)
5608  phkk(2,ihkk)=pqvsa1(n,2)
5609  phkk(3,ihkk)=pqvsa1(n,3)
5610  phkk(4,ihkk)=pqvsa1(n,4)
5611  phkk(5,ihkk)=0.
5612 C Add position of parton in hadron
5613  CALL qinnuc(xxpp,yypp)
5614  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
5615  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
5616  vhkk(3,ihkk)=vhkk(3,ihkkpo)
5617  vhkk(4,ihkk)=vhkk(4,ihkkpo)
5618  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
5619  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5620  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5621 
5622  1050 FORMAT (i6,i4,5i6,9e10.2)
5623 C CHAIN 1 TARGET SEA-QUARK
5624  nhkk=nhkk+1
5625  IF (nhkk.EQ.nmxhkk)THEN
5626  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
5627  RETURN
5628  ENDIF
5629  ihkk=nhkk
5630  isthkk(ihkk)=132
5631  idhkk(ihkk)=idhkk(ihkktd)
5632  jmohkk(1,ihkk)=ihkktd
5633  jmohkk(2,ihkk)=jmohkk(1,ihkktd)
5634  jdahkk(1,ihkk)=ihkk+1
5635  jdahkk(2,ihkk)=ihkk+1
5636  phkk(1,ihkk)=pqvsa2(n,1)
5637  phkk(2,ihkk)=pqvsa2(n,2)
5638  phkk(3,ihkk)=pqvsa2(n,3)
5639  phkk(4,ihkk)=pqvsa2(n,4)
5640  phkk(5,ihkk)=0.
5641 C Add position of parton in hadron
5642  CALL qinnuc(xxpp,yypp)
5643  vhkk(1,ihkk)=vhkk(1,ihkktd)+xxpp
5644  vhkk(2,ihkk)=vhkk(2,ihkktd)+yypp
5645  vhkk(3,ihkk)=vhkk(3,ihkktd)
5646  vhkk(4,ihkk)=vhkk(4,ihkktd)
5647  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
5648  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5649  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5650 
5651 C
5652 C CHAIN 1 BEFORE FRAGMENTATION
5653  nhkk=nhkk+1
5654  IF (nhkk.EQ.nmxhkk)THEN
5655  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
5656  RETURN
5657  ENDIF
5658  ihkk=nhkk
5659  isthkk(ihkk)=5
5660  idhkk(ihkk)=88888+nnch1
5661  jmohkk(1,ihkk)=ihkk-2
5662  jmohkk(2,ihkk)=ihkk-1
5663  phkk(1,ihkk)=qtxch1
5664  phkk(2,ihkk)=qtych1
5665  phkk(3,ihkk)=qtzch1
5666  phkk(4,ihkk)=qech1
5667  phkk(5,ihkk)=amch1
5668 C POSITION OF CREATED CHAIN IN LAB
5669 C =POSITION OF TARGET NUCLEON
5670 C TIME OF CHAIN CREATION IN LAB
5671 C =TIME OF PASSAGE OF PROJECTILE
5672 C NUCLEUS AT POSITION OF TAR. NUCLEUS
5673  vhkk(1,nhkk)= vhkk(1,nhkk-1)
5674  vhkk(2,nhkk)= vhkk(2,nhkk-1)
5675  vhkk(3,nhkk)= vhkk(3,nhkk-1)
5676  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
5677  mhkkvs(n)=ihkk
5678  IF (iprojk.EQ.1)THEN
5679  whkk(1,nhkk)= vhkk(1,nhkk-2)
5680  whkk(2,nhkk)= vhkk(2,nhkk-2)
5681  whkk(3,nhkk)= vhkk(3,nhkk-2)
5682  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
5683  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
5684  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
5685  + (phkk(khkk,nhkk),khkk=1,5), (whkk(khkk,nhkk),khkk=1,4)
5686 
5687  ENDIF
5688  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
5689  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
5690  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
5691 
5692 C
5693 C
5694 C CHAIN 2 PROJECTILE DIQUARK
5695  nhkk=nhkk+1
5696  IF (nhkk.EQ.nmxhkk)THEN
5697  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
5698  RETURN
5699  ENDIF
5700  ihkk=nhkk
5701  isthkk(ihkk)=121
5702  idhkk(ihkk)=idhkk(ihkkpd)
5703  jmohkk(1,ihkk)=ihkkpd
5704  jmohkk(2,ihkk)=jmohkk(1,ihkkpd)
5705  jdahkk(1,ihkk)=ihkk+2
5706  jdahkk(2,ihkk)=ihkk+2
5707  phkk(1,ihkk)=pqvsb1(n,1)
5708  phkk(2,ihkk)=pqvsb1(n,2)
5709  phkk(3,ihkk)=pqvsb1(n,3)
5710  phkk(4,ihkk)=pqvsb1(n,4)
5711  phkk(5,ihkk)=0.
5712 C Add position of parton in hadron
5713  CALL qinnuc(xxpp,yypp)
5714  vhkk(1,ihkk)=vhkk(1,ihkkpd)+xxpp
5715  vhkk(2,ihkk)=vhkk(2,ihkkpd)+yypp
5716  vhkk(3,ihkk)=vhkk(3,ihkkpd)
5717  vhkk(4,ihkk)=vhkk(4,ihkkpd)
5718  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
5719  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5720  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5721 
5722 C CHAIN 2 TARGET SEA-QUARK
5723  nhkk=nhkk+1
5724  IF (nhkk.EQ.nmxhkk)THEN
5725  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
5726  RETURN
5727  ENDIF
5728  ihkk=nhkk
5729  isthkk(ihkk)=132
5730  idhkk(ihkk)=idhkk(ihkkto)
5731  jmohkk(1,ihkk)=ihkkto
5732  jmohkk(2,ihkk)=jmohkk(1,ihkkto)
5733  jdahkk(1,ihkk)=ihkk+1
5734  jdahkk(2,ihkk)=ihkk+1
5735  phkk(1,ihkk)=pqvsb2(n,1)
5736  phkk(2,ihkk)=pqvsb2(n,2)
5737  phkk(3,ihkk)=pqvsb2(n,3)
5738  phkk(4,ihkk)=pqvsb2(n,4)
5739  phkk(5,ihkk)=0.
5740 C Add position of parton in hadron
5741  CALL qinnuc(xxpp,yypp)
5742  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
5743  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
5744  vhkk(3,ihkk)=vhkk(3,ihkkto)
5745  vhkk(4,ihkk)=vhkk(4,ihkkto)
5746  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
5747  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5748  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5749 
5750 C
5751 C CHAIN 2 BEFORE FRAGMENTATION
5752  nhkk=nhkk+1
5753  IF (nhkk.EQ.nmxhkk)THEN
5754  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
5755  RETURN
5756  ENDIF
5757  ihkk=nhkk
5758  isthkk(ihkk)=5
5759  idhkk(ihkk)=88888+nnch2
5760  jmohkk(1,ihkk)=ihkk-2
5761  jmohkk(2,ihkk)=ihkk-1
5762  phkk(1,ihkk)=qtxch2
5763  phkk(2,ihkk)=qtych2
5764  phkk(3,ihkk)=qtzch2
5765  phkk(4,ihkk)=qech2
5766  phkk(5,ihkk)=amch2
5767 C POSITION OF CREATED CHAIN IN LAB
5768 C =POSITION OF TARGET NUCLEON
5769 C TIME OF CHAIN CREATION IN LAB
5770 C =TIME OF PASSAGE OF PROJECTILE
5771 C NUCLEUS AT POSITION OF TAR. NUCLEUS
5772  vhkk(1,nhkk)= vhkk(1,nhkk-1)
5773  vhkk(2,nhkk)= vhkk(2,nhkk-1)
5774  vhkk(3,nhkk)= vhkk(3,nhkk-1)
5775  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
5776  mhkkvs(n)=ihkk
5777  IF (iprojk.EQ.1)THEN
5778  whkk(1,nhkk)= vhkk(1,nhkk-2)
5779  whkk(2,nhkk)= vhkk(2,nhkk-2)
5780  whkk(3,nhkk)= vhkk(3,nhkk-2)
5781  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
5782  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
5783  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5784  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
5785 
5786  ENDIF
5787  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
5788  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
5789  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
5790 
5791 C
5792 C NOW WE HAVE AN ACCEPTABLE VALENCE-SEA EVENT
5793 C AND PUT IT INTO THE HISTOGRAM
5794 C
5795  amcvs1(n)=amch1
5796  amcvs2(n)=amch2
5797  gacvs1(n)=qech1/amch1
5798  bgxvs1(n)=qtxch1/amch1
5799  bgyvs1(n)=qtych1/amch1
5800  bgzvs1(n)=qtzch1/amch1
5801  gacvs2(n)=qech2/amch2
5802  bgxvs2(n)=qtxch2/amch2
5803  bgyvs2(n)=qtych2/amch2
5804  bgzvs2(n)=qtzch2/amch2
5805  nchvs1(n)=nnch1
5806  nchvs2(n)=nnch2
5807  ijcvs1(n)=ijnch1
5808  ijcvs2(n)=ijnch2
5809  IF (ipev.GE.6)WRITE(6,1060) n, xpvq(ixvpr),xpvd(ixvpr),xtsq
5810  + (ixsta),xtsaq(ixsta), ipvq(ixvpr),ippv1(ixvpr),ippv2(ixvpr),
5811  + itsq(ixsta),itsaq(ixsta), amcvs1(n),amcvs2(n),gacvs1(n),gacvs2
5812  + (n), bgxvs1(n),bgyvs1(n),bgzvs1(n), bgxvs2(n),bgyvs2(n),bgzvs2
5813  + (n), nchvs1(n),nchvs2(n),ijcvs1(n),ijcvs2(n), (pqvsa1(n,ju),
5814  + pqvsa2(n,ju),pqvsb1(n,ju), pqvsb2(n,ju),ju=1,4)
5815 
5816 
5817 
5818 
5819  10 CONTINUE
5820  RETURN
5821  20 CONTINUE
5822 C EVENT REJECTED
5823 C START A NEW ONE
5824  irejvs=1
5825 C---------------------------------------------------------------------
5826 C
5827  RETURN
5828 C
5829  1060 FORMAT(i10,4f12.7,5i5/10x,4f12.6/10x,6f12.6,4i5/8f15.5/8f15.5)
5830  1070 FORMAT (' VS IREJ ',i10/
5831  +' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
5832  +' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
5833  1080 FORMAT (' VS IREJ ',i10/
5834  +' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
5835  +' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
5836 C
5837  1090 FORMAT(' VS', 4(4e12.4/),2e12.4/2i5/4e12.4)
5838  1100 FORMAT(' VS',6i5/6e12.4/2e12.4)
5839  1110 FORMAT(' VS ',5i5/2(4e12.4/),2e12.4)
5840  1120 FORMAT(' VS',7i5/2(4e12.4/),2e12.4)
5841  1130 FORMAT(' VS',4i5/6e12.4/2e12.4)
5842  1140 FORMAT(' KKEVT - IRVS13=',i5)
5843  1150 FORMAT(' KKEVT - IRVS11=',i5)
5844  1160 FORMAT(' KKEVT - IRVS12=',i5)
5845 C
5846  END
5847 *-- Author :
5848 C
5849 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5850 C
5851  SUBROUTINE kkevsv(IREJSV)
5852  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5853  SAVE
5854 C
5855 C------------------------- TREATMENT OF SEA-VALENCE CHAIN SYSTEMS
5856 C
5857 *KEEP,NNCMS.
5858  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
5859 *KEEP,HKKEVT.
5860 c INCLUDE (HKKEVT)
5861  parameter(nmxhkk= 89998)
5862 c PARAMETER (NMXHKK=25000)
5863  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
5864  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
5865  +(4,nmxhkk)
5866 C
5867 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
5868 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
5869 C THE POSITIONS OF THE PROJECTILE NUCLEONS
5870 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
5871 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
5872 C COMPLETELY CONSISTENT. THE TIMES IN THE
5873 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
5874 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
5875 C
5876 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
5877 C
5878 C NMXHKK: maximum numbers of entries (partons/particles) that can be
5879 C stored in the commonblock.
5880 C
5881 C NHKK: the actual number of entries stored in current event. These are
5882 C found in the first NHKK positions of the respective arrays below.
5883 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
5884 C entry.
5885 C
5886 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
5887 C = 0 : null entry.
5888 C = 1 : an existing entry, which has not decayed or fragmented.
5889 C This is the main class of entries which represents the
5890 C "final state" given by the generator.
5891 C = 2 : an entry which has decayed or fragmented and therefore
5892 C is not appearing in the final state, but is retained for
5893 C event history information.
5894 C = 3 : a documentation line, defined separately from the event
5895 C history. (incoming reacting
5896 C particles, etc.)
5897 C = 4 - 10 : undefined, but reserved for future standards.
5898 C = 11 - 20 : at the disposal of each model builder for constructs
5899 C specific to his program, but equivalent to a null line in the
5900 C context of any other program. One example is the cone defining
5901 C vector of HERWIG, another cluster or event axes of the JETSET
5902 C analysis routines.
5903 C = 21 - : at the disposal of users, in particular for event tracking
5904 C in the detector.
5905 C
5906 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
5907 C standard.
5908 C
5909 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
5910 C The value is 0 for initial entries.
5911 C
5912 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
5913 C one mother exist, in which case the value 0 is used. In cluster
5914 C fragmentation models, the two mothers would correspond to the q
5915 C and qbar which join to form a cluster. In string fragmentation,
5916 C the two mothers of a particle produced in the fragmentation would
5917 C be the two endpoints of the string (with the range in between
5918 C implied).
5919 C
5920 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
5921 C entry has not decayed, this is 0.
5922 C
5923 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
5924 C entry has not decayed, this is 0. It is assumed that the daughters
5925 C of a particle (or cluster or string) are stored sequentially, so
5926 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
5927 C daughters. Even in cases where only one daughter is defined (e.g.
5928 C K0 -> K0S) both values should be defined, to make for a uniform
5929 C approach in terms of loop constructions.
5930 C
5931 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
5932 C
5933 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
5934 C
5935 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
5936 C
5937 C PHKK(4,IHKK) : energy, in GeV.
5938 C
5939 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
5940 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
5941 C
5942 C VHKK(1,IHKK) : production vertex x position, in mm.
5943 C
5944 C VHKK(2,IHKK) : production vertex y position, in mm.
5945 C
5946 C VHKK(3,IHKK) : production vertex z position, in mm.
5947 C
5948 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
5949 C********************************************************************
5950 *KEEP,INTMX.
5951  parameter(intmx=2488,intmd=252)
5952 *KEEP,DXQX.
5953 C INCLUDE (XQXQ)
5954 * NOTE: INTMX set via INCLUDE(INTMX)
5955  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
5956  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
5957  * ,xpsu(248),xtsu(248)
5958  * ,xpsut(248),xtsut(248)
5959 *KEEP,INTNEW.
5960  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
5961  +ixpv,ixps,ixtv,ixts, intvv1(248),
5962  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
5963  +intss1(intmx),intss2(intmx),
5964  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
5965  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
5966 
5967 C /INTNEW/
5968 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
5969 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
5970 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
5971 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
5972 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
5973 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
5974 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
5975 C FROM PROJECTILE/TARGET NUCLEI
5976 C-------------------
5977 *KEEP,IFROTO.
5978  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
5979  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
5980  +jhkknt
5981  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
5982  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
5983  & mhkkhh(intmx),
5984  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
5985 *KEEP,LOZUO.
5986  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
5987  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
5988  +intlo(intmx),inloss(intmx)
5989 C /LOZUO/
5990 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
5991 C REJECTED IN KKEVT
5992 C------------------
5993 *KEEP,DIQI.
5994  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
5995  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
5996  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
5997  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
5998 *KEEP,TRAFOP.
5999  COMMON /trafop/ gamp,bgamp,betp
6000 *KEEP,NUCIMP.
6001  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
6002  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
6003  +prebin,taebin,fermod,etacou
6004 *KEEP,ABRSV.
6005  COMMON /abrsv/ amcsv1(248),amcsv2(248),gacsv1(248),gacsv2(248),
6006  +bgxsv1(248),bgysv1(248),bgzsv1(248), bgxsv2(248),bgysv2(248),
6007  +bgzsv2(248), nchsv1(248),nchsv2(248),ijcsv1(248),ijcsv2(248),
6008  +pqsva1(248,4),pqsva2(248,4), pqsvb1(248,4),pqsvb2(248,4)
6009 *KEEP,FERMI.
6010  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
6011  +(4,248)
6012 *KEEP,DPAR.
6013 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6014 C ANAME = LITERAL NAME OF THE PARTICLE
6015 C AAM = PARTICLE MASS IN GEV
6016 C GA = DECAY WIDTH
6017 C TAU = LIFE TIME OF INSTABLE PARTICLES
6018 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6019 C IIBAR = BARYON NUMBER
6020 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6021 C
6022  CHARACTER*8 aname
6023  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
6024  +iibar(210),k1(210),k2(210)
6025 C------------------
6026 *KEEP,DPRIN.
6027  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
6028 *KEEP,REJEC.
6029  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
6030  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
6031  +irvs14, irvv11,irvv12,irvv13,irvv14
6032 *KEEP,PROJK.
6033  COMMON /projk/ iprojk
6034  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
6035  common/rptshm/rproj,rtarg,bimpac
6036 *KEND.
6037 C=============================================================
6038 
6039  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
6040  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
6041  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
6042  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
6043  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
6044  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
6045  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
6046  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
6047  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
6048  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
6049  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
6050  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
6051  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
6052  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
6053  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
6054  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
6055  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
6056  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
6057  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
6058  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
6059  COMMON /zsea/zseaav,zseasu,anzsea
6060 C
6061  thmod=1.
6062  iminij=1
6063  IF(ip.GT.1)thmod=20.
6064 C DO 201 N=1,NSV
6065 C-------------------
6066  irejsv=0
6067  IF(ipev.GE.1)THEN
6068  WRITE(6,6589) nvv,nsv,nvs,nss,ndv,nvd,nds,nsd
6069  6589 FORMAT(' KKEVSV: NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD',8i5)
6070  ENDIF
6071  DO 10 n=1,nsv
6072 C---------------------------drop recombined chain pairs
6073  IF(nchsv1(n).EQ.99.OR.nchsv2(n).EQ.99)go to 10
6074 C
6075  ixspr=intsv1(n)
6076  inucpr=ifrosp(ixspr)
6077  jnucpr=itovp(inucpr)
6078  IF(ipev.GE.1)THEN
6079  pqp=gamcm*prmom(3,inucpr)+bgcm*prmom(4,inucpr)
6080  pqe=gamcm*prmom(4,inucpr)+bgcm*prmom(3,inucpr)
6081  pqpq=gamcm*psqpz+bgcm*psqe
6082  pqeq=gamcm*psqe+bgcm*psqpz
6083  pqpd=gamcm*psaqpz+bgcm*psaqe
6084  pqed=gamcm*psaqe+bgcm*psaqpz
6085  WRITE(6,1655)prmom(3,inucpr),prmom(4,inucpr),pqp,pqe,
6086  + xpsq(ixspr),xpsaq(ixspr),ixspr
6087  WRITE(6,1656)pvqpz,pvqe,pqpq,pqeq
6088  WRITE(6,1657)pvdqpz,pvdqe,pqpd,pqed
6089  ENDIF
6090 C
6091 C
6092 C SUBTRACT HARD SCATTERED X VALUES FROM DIQUARKS
6093 C
6094  iifrop=ifrosp(ixspr)
6095  ixvpr=itovp(iifrop)
6096 C
6097  ixvta=intsv2(n)
6098  inucta=ifrovt(ixvta)
6099  jnucta=itovt(inucta)
6100 C
6101 C
6102  xmax1=xpsq(ixspr)+xpsaq(ixspr)+xpvq(ixvpr)+xpvd(ixvpr)
6103  * -2.d0*xsthr-xvthr-xdthr
6104  xmax2=xtvq(ixvta)+xtvd(ixvta)-xvthr-xdthr
6105 C
6106  IF(ipev.GE.1)WRITE(6,'(A,2I5,2F9.3)')' KKEVSV,bef xptfl:n,nsv'
6107  * ,n,nsv,xmax1,xmax2
6108  IF (iminij.EQ.1)THEN
6109  CALL xptfl(nhard,nsea,ireg,xmax1,xmax2)
6110 C NZSEA=NZSEA+1
6111 C ANZSEA=NZSEA
6112  anzsea=anzsea+1.d0
6113  zseasu=zseasu+nsea
6114  zseaav=zseasu/anzsea
6115  ENDIF
6116  IF(ipev.GE.1)WRITE(6,'(A,3I10)')' SV,xptfl:nhard,nsea,ireg '
6117  * ,nhard,nsea,ireg
6118  IF(ireg.EQ.1)nhard=0
6119  IF(ireg.EQ.1)nsea=0
6120  nomje=nomje+nhard
6121 C
6122 C
6123  IF (nhard.GE.1.AND.iminij.EQ.1)THEN
6124  DO 71 ixx=nonuj1,nonujt
6125  jhkkph(ixx)=ixvpr
6126  jhkkex(ixx)=0
6127  jhkke1(ixx)=0
6128  IF (xpsq(ixspr)-xjq1(ixx).GE.thmod*xsthr) THEN
6129  xpsq(ixspr)=xpsq(ixspr)-xjq1(ixx)
6130  jhkke1(ixx)=1
6131  ELSEIF (xpsaq(ixspr)-xjq1(ixx).GE.thmod*xsthr) THEN
6132  xpsaq(ixspr)=xpsaq(ixspr)-xjq1(ixx)
6133  jhkke1(ixx)=2
6134  ELSEIF (xpvq(ixvpr)-xjq1(ixx).GE.thmod*xvthr) THEN
6135  xpvq(ixvpr)=xpvq(ixvpr)-xjq1(ixx)
6136  jhkke1(ixx)=3
6137  ELSEIF(xpvd(ixvpr)-xjq1(ixx).GE.thmod*xdthr) THEN
6138  xpvd(ixvpr)=xpvd(ixvpr)-xjq1(ixx)
6139  jhkke1(ixx)=4
6140  ENDIF
6141  71 CONTINUE
6142  ENDIF
6143 C
6144  ixvta=intsv2(n)
6145  inucta=ifrovt(ixvta)
6146  jnucta=itovt(inucta)
6147 C
6148 C SUBTRACT HARD SCATTERED X VALUES FROM DIQUARKS
6149 C
6150  IF (nhard.GE.1.AND.iminij.EQ.1) THEN
6151  DO 771 ixx=nonuj1,nonujt
6152  jhkkth(ixx)=ixvta
6153  IF (jhkke1(ixx).EQ.0)THEN
6154  jhkkex(ixx)=0
6155  go to 771
6156  ENDIF
6157  IF (xtvq(ixvta)-xjq2(ixx).GE.thmod*xvthr) THEN
6158  xtvq(ixvta)=xtvq(ixvta)-xjq2(ixx)
6159  jhkkex(ixx)=1
6160  nomjer=nomjer+1
6161  ELSEIF (xtvd(ixvta)-xjq2(ixx).GE.thmod*xdthr)THEN
6162  xtvd(ixvta)=xtvd(ixvta)-xjq2(ixx)
6163  jhkkex(ixx)=1
6164  nomjer=nomjer+1
6165  ELSE
6166  jhkkex(ixx)=0
6167  IF (jhkke1(ixx).EQ.1)THEN
6168  xpsq(ixspr)=xpsq(ixspr)+xjq1(ixx)
6169  ELSEIF (jhkke1(ixx).EQ.2)THEN
6170  xpsaq(ixspr)=xpsaq(ixspr)+xjq1(ixx)
6171  ELSEIF (jhkke1(ixx).EQ.3)THEN
6172  xpvq(ixvpr)=xpvq(ixvpr)+xjq1(ixx)
6173  ELSEIF (jhkke1(ixx).EQ.4)THEN
6174  xpvd(ixvpr)=xpvd(ixvpr)+xjq1(ixx)
6175  ENDIF
6176  ENDIF
6177  771 CONTINUE
6178  ENDIF
6179 C
6180 C
6181 C SUBTRACT SECONDARY SEA X VALUES FROM DIQUARKS
6182 C
6183  IF(ipev.GE.1)WRITE(6,'(A,2I10)')' sv: NONUS1,NONUST ',
6184  * nonus1,nonust
6185  IF (nsea.GE.1)THEN
6186  DO 271 ixx=nonus1,nonust
6187  jhkkpz(ixx)=ixvpr
6188  jhkksx(ixx)=0
6189  jhkks1(ixx)=0
6190  IF (xpsq(ixspr)-xsq1(ixx)-xsaq1(ixx).GT.thmod*xsthr)THEN
6191  xpsq(ixspr)=xpsq(ixspr)-xsq1(ixx)-xsaq1(ixx)
6192  jhkks1(ixx)=3
6193  ELSEIF (xpsaq(ixspr)-xsq1(ixx)-xsaq1(ixx).GT.thmod*xsthr)THEN
6194  xpsaq(ixspr)=xpsaq(ixspr)-xsq1(ixx)-xsaq1(ixx)
6195  jhkks1(ixx)=4
6196  ELSEIF (xpvq(ixvpr)-xsq1(ixx)-xsaq1(ixx).GT.thmod*xvthr)THEN
6197  xpvq(ixvpr)=xpvq(ixvpr)-xsq1(ixx)-xsaq1(ixx)
6198  jhkks1(ixx)=1
6199  ELSEIF (xpvd(ixvpr)-xsq1(ixx)-xsaq1(ixx).GT.thmod*xdthr)THEN
6200  xpvd(ixvpr)=xpvd(ixvpr)-xsq1(ixx)-xsaq1(ixx)
6201  jhkks1(ixx)=2
6202  ENDIF
6203  IF(ipev.GE.1)WRITE(6,'(A,2I10)')' sv:JHKKS1(IXX), SX ',
6204  * jhkks1(ixx),jhkksx(ixx)
6205  IF(ipev.GE.1)WRITE(6,'(A,I10)')' sv:IXSPR ',
6206  * ixspr
6207  IF(ipev.GE.1)WRITE(6,'(A,2F10.2)')' sv:XPSQ(IXSPR),SAQ',
6208  * xpsq(ixspr),xpsaq(ixspr)
6209  271 CONTINUE
6210  ENDIF
6211 C
6212  inucta=ifrovt(ixvta)
6213 C
6214 C SUBTRACT SECONDARY SEA X VALUES FROM DIQUARKS
6215 C
6216  IF (nsea.GE.1)THEN
6217  DO 2771 ixx=nonus1,nonust
6218  jhkktz(ixx)=ixvta
6219  IF (jhkks1(ixx).EQ.0)THEN
6220  jhkksx(ixx)=0
6221  go to 2771
6222  ENDIF
6223  IF (xtvq(ixvta)-xsq2(ixx)-xsaq2(ixx).GT. thmod*xvthr) THEN
6224  xtvq(ixvta)=xtvq(ixvta)-xsq2(ixx)-xsaq2(ixx)
6225  jhkksx(ixx)=1
6226 C NOMJER=NOMJER+1
6227  ELSEIF(xtvd(ixvta)-xsq2(ixx)-xsaq2(ixx).GT.thmod*xdthr)THEN
6228  xtvd(ixvta)=xtvd(ixvta)-xsq2(ixx)-xsaq2(ixx)
6229  jhkksx(ixx)=1
6230 C NOMJER=NOMJER+1
6231  ELSE
6232  jhkksx(ixx)=0
6233  IF (jhkks1(ixx).EQ.1)THEN
6234  xpvq(ixvpr)=xpvq(ixvpr)+xsq1(ixx)+xsaq1(ixx)
6235  ELSEIF(jhkks1(ixx).EQ.2)THEN
6236  xpvd(ixvpr)=xpvd(ixvpr)+xsq1(ixx)+xsaq1(ixx)
6237  ELSEIF(jhkks1(ixx).EQ.3)THEN
6238  xpsq(ixspr)=xpsq(ixspr)+xsq1(ixx)+xsaq1(ixx)
6239  ELSEIF(jhkks1(ixx).EQ.4)THEN
6240  xpsaq(ixspr)=xpsaq(ixspr)+xsq1(ixx)+xsaq1(ixx)
6241  ENDIF
6242  ENDIF
6243  IF(ipev.GE.1)WRITE(6,'(A,2I10)')' sv:JHKKS1(IXX), SX ',
6244  * jhkks1(ixx),jhkksx(ixx)
6245  IF(ipev.GE.1)WRITE(6,'(A,2F10.2)')' sv:XPSQ(IXSPR),SAQ',
6246  * xpsq(ixspr),xpsaq(ixspr)
6247  2771 CONTINUE
6248  ENDIF
6249 C
6250 C
6251  xmax1=xpsq(ixspr)+xpsaq(ixspr)+xpvq(ixvpr)+xpvd(ixvpr)
6252  * -2.d0*xsthr-xvthr-xdthr
6253  xmax2=xtvq(ixvta)+xtvd(ixvta)-xvthr-xdthr
6254 C
6255  IF(ipev.GE.1)WRITE(6,'(A,2I5,2F9.3)')' KKEVSV,aft xptfl:n,nsv'
6256  * ,n,nsv,xmax1,xmax2
6257  go to 1202
6258  2202 CONTINUE
6259 C
6260 C TRY TO INCREASE X-FRACTION OF PROJECTILE SEA
6261 C QUARK ANTIQUARK PAIR BY XSTHR
6262 C XPSQ(IXSPR), XPSAQ(IXSPR)
6263 C DECREASING VALENCE DIQUARK XPVD(IXVPR)
6264 C
6265 C IF (XPSUT(IXVPR).EQ.0..AND.
6266 C * XPVD(IXVPR)-2.*XSTHR.GE.XDTHR) THEN
6267 C XPSQ(IXSPR)=XPSQ(IXSPR)+XSTHR
6268 C XPSAQ(IXSPR)=XPSAQ(IXSPR)+XSTHR
6269 C XPVD(IXVPR)=XPVD(IXVPR)-2.*XSTHR
6270 C IREJ=0
6271 C ELSE
6272 C GO TO 202
6273 C GO TO 10
6274 C ENDIF
6275  1202 CONTINUE
6276 C============================================================
6277 C-------------------
6278 C IREJSV=0
6279 C IF(IPEV.GE.1)THEN
6280 C WRITE(6,6589) NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD
6281 C6589 FORMAT(' KKEVSV: NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD',8I5)
6282 C ENDIF
6283 C DO 10 N=1,NSV
6284 C---------------------------drop recombined chain pairs
6285 C IF(NCHSV1(N).EQ.99.OR.NCHSV2(N).EQ.99)GO TO 10
6286  IF(ipev.GE.1)THEN
6287  WRITE(6,6588)nchsv1(n),nchsv2(n)
6288  6588 FORMAT(' NCHSV1(N),NCHSV2(N)',2i5)
6289  ENDIF
6290 C
6291 C*** 4-MOMENTA OF PROJECTILE SEA-QUARK PAIRS IN NN-CMS
6292  ixspr=intsv1(n)
6293  inucpr=ifrosp(ixspr)
6294  jnucpr=itovp(inucpr)
6295 C
6296  pramom=sqrt(prmom(1,inucpr)**2
6297  + +prmom(2,inucpr)**2
6298  + +prmom(3,inucpr)**2)
6299  IF(pramom.EQ.0.)THEN
6300  xxqq=1.
6301  ELSE
6302  xxqq=prmom(4,inucpr)/pramom
6303  ENDIF
6304  xxqq=1.
6305  psqpx=xpsq(ixspr)*prmom(1,inucpr)*xxqq
6306  psqpy=xpsq(ixspr)*prmom(2,inucpr)*xxqq
6307  psqpz=xpsq(ixspr)*prmom(3,inucpr)*xxqq
6308  psqe=xpsq(ixspr)*prmom(4,inucpr)
6309  psaqpx=xpsaq(ixspr)*prmom(1,inucpr)*xxqq
6310  psaqpy=xpsaq(ixspr)*prmom(2,inucpr)*xxqq
6311  psaqpz=xpsaq(ixspr)*prmom(3,inucpr)*xxqq
6312  psaqe=xpsaq(ixspr)*prmom(4,inucpr)
6313  IF(ipev.GE.1)THEN
6314  pqp=gamcm*prmom(3,inucpr)+bgcm*prmom(4,inucpr)
6315  pqe=gamcm*prmom(4,inucpr)+bgcm*prmom(3,inucpr)
6316  pqpq=gamcm*psqpz+bgcm*psqe
6317  pqeq=gamcm*psqe+bgcm*psqpz
6318  pqpd=gamcm*psaqpz+bgcm*psaqe
6319  pqed=gamcm*psaqe+bgcm*psaqpz
6320 C DO III=1,200
6321  WRITE(6,1655)prmom(3,inucpr),prmom(4,inucpr),pqp,pqe,
6322  + xpsq(ixspr),xpsaq(ixspr),ixspr
6323 C ENDDO
6324  1655 FORMAT(' sv PQP,PQE ',6e12.3,i5)
6325 C DO III=1,200
6326  WRITE(6,1656)pvqpz,pvqe,pqpq,pqeq
6327 C ENDDO
6328  1656 FORMAT(' sv PQPQ,PQEQ ',4e15.5)
6329 C DO III=1,200
6330  WRITE(6,1657)pvdqpz,pvdqe,pqpd,pqed
6331 C ENDDO
6332  1657 FORMAT(' sv PQPD,PQED ',4e15.5)
6333  ENDIF
6334 C
6335 C*** 4-MOMENTA OF TARGET QUARK-DIQUARK PAIRS IN NN-CMS
6336  ixvta=intsv2(n)
6337  inucta=ifrovt(ixvta)
6338  jnucta=itovt(inucta)
6339 C
6340  taamom=sqrt(tamom(1,inucpr)**2
6341  + +tamom(2,inucpr)**2
6342  + +tamom(3,inucpr)**2)
6343  IF(taamom.EQ.0.)THEN
6344  xxqq=1.
6345  ELSE
6346  xxqq=tamom(4,inucta)/taamom
6347  ENDIF
6348  xxqq=1.
6349  tvqpx=xtvq(ixvta)*tamom(1,inucta)*xxqq
6350  tvqpy=xtvq(ixvta)*tamom(2,inucta)*xxqq
6351  tvqpz=xtvq(ixvta)*tamom(3,inucta)*xxqq
6352  tvqe=xtvq(ixvta)*tamom(4,inucta)
6353  tvdqpx=xtvd(ixvta)*tamom(1,inucta)*xxqq
6354  tvdqpy=xtvd(ixvta)*tamom(2,inucta)*xxqq
6355  tvdqpz=xtvd(ixvta)*tamom(3,inucta)*xxqq
6356  tvdqe=xtvd(ixvta)*tamom(4,inucta)
6357  IF(psaqe.LT.0..OR.psqe.LE.0..OR.tvdqe.LT.0..OR.tvqe.LT.0.)
6358  + THEN
6359 C DO III=1,200
6360  WRITE(6,7799)psqpx,psqpy,psqpz,psqe,
6361  + psaqpx,psaqpy,psaqpz, psaqe,
6362  + tvqpx,tvqpy,tvqpz,tvqe,
6363  + tvdqpx,tvdqpy,tvdqpz,tvdqe
6364  7799 FORMAT('PSQPX,PSQPY,PSQPZ,PSQE,PSAQPX,PSAQPY,PSAQPZ
6365  + PSAQE,TVQPX,TVQPY,TVQPZ,TVQE,TVDQPX,TVDQPY,TVDQPZ,TVDQE',
6366  + /4(4e15.5/))
6367  WRITE (6,7798)ixspr,inucpr,ixvta,inucta,
6368  + xpsq(ixspr),xpsaq(ixspr),xtvq(ixvta),xtvd(ixvta),
6369  + prmom(4,inucpr),tamom(4,inucta)
6370  7798 FORMAT('IXSPR,INUCPR,IXVTA,INUCTA,
6371  + XPSQ(IXSPR),XPSAQ(IXSPR),XTVQ(IXVTA),XTVD(IXVTA),
6372  + PRMOM(4,INUCPR),TAMOM(4,INUCTA)'/4i10/4e15.5/2e15.5)
6373 C ENDDO
6374  ENDIF
6375  IF(ipev.GE.1)THEN
6376  tqp=gamcm*tamom(3,inucta)+bgcm*tamom(4,inucta)
6377  tqe=gamcm*tamom(4,inucta)+bgcm*tamom(3,inucta)
6378  tqpq=gamcm*tvqpz+bgcm*tvqe
6379  tqeq=gamcm*tvqe+bgcm*tvqpz
6380  tqpd=gamcm*tvdqpz+bgcm*tvdqe
6381  tqed=gamcm*tvdqe+bgcm*tvdqpz
6382 C DO III=1,200
6383  WRITE(6,1455)tamom(3,inucta),tamom(4,inucta),tqp,tqe
6384  1455 FORMAT(' sv TQP,TQE ',4f12.5)
6385  WRITE(6,1456)tvqpz,tvqe,tqpq,tqeq
6386  1456 FORMAT(' sv TQPQ,TQEQ ',4f12.5)
6387  WRITE(6,1457)tvdqpz,tvdqe,tqpd,tqed
6388  1457 FORMAT(' sv TQPD,TQED ',4e15.5)
6389  WRITE(6,7799)psqpx,psqpy,psqpz,psqe,
6390  + psaqpx,psaqpy,psaqpz, psaqe,
6391  + tvqpx,tvqpy,tvqpz,tvqe,
6392  + tvdqpx,tvdqpy,tvdqpz,tvdqe
6393  WRITE (6,7798)ixspr,inucpr,ixvta,inucta,
6394  + xpsq(ixspr),xpsaq(ixspr),xtvq(ixvta),xtvd(ixvta),
6395  + prmom(4,inucpr),tamom(4,inucta)
6396 C ENDDO
6397  ENDIF
6398 C j.r.6.5.93
6399 C
6400 C multiple scattering of valence quark chain ends
6401 C
6402  IF(it.GT.1)THEN
6403  itnu=ip+inucta
6404  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
6405  rtiy=vhkk(2,itnu)*1.e12
6406  rtiz=vhkk(3,itnu)*1.e12
6407  CALL cromsc(tvqpx,tvqpy,tvqpz,tvqe,rtix,rtiy,rtiz,
6408  * tvqnx,tvqny,tvqnz,tvqne,13)
6409  tvqpx=tvqnx
6410  tvqpy=tvqny
6411  tvqpz=tvqnz
6412  tvqe=tvqne
6413  CALL cromsc(tvdqpx,tvdqpy,tvdqpz,tvdqe,rtix,rtiy,rtiz,
6414  * tvdqnx,tvdqny,tvdqnz,tvdqne,14)
6415  tvdqpx=tvdqnx
6416  tvdqpy=tvdqny
6417  tvdqpz=tvdqnz
6418  tvdqe=tvdqne
6419 C j.r.6.5.93
6420 C
6421 C multiple scattering of sea quark chain ends
6422 C
6423  itnu=ip+inucta
6424  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
6425  rtiy=vhkk(2,itnu)*1.e12
6426  rtiz=vhkk(3,itnu)*1.e12
6427  CALL cromsc(psqpx,psqpy,psqpz,psqe,rtix,rtiy,rtiz,
6428  * psqnx,psqny,psqnz,psqne,15)
6429  psqpx=psqnx
6430  psqpy=psqny
6431  psqpz=psqnz
6432  psqe=psqne
6433  CALL cromsc(psaqpx,psaqpy,psaqpz,psaqe,rtix,rtiy,rtiz,
6434  * psaqnx,psaqny,psaqnz,psaqne,16)
6435  psaqpx=psaqnx
6436  psaqpy=psaqny
6437  psaqpz=psaqnz
6438  psaqe=psaqne
6439  ENDIF
6440 C ---------
6441 C
6442 C j.r.10.5.93
6443  IF(ip.GE.1) go to 1779
6444  psqpz2=psqe**2-psqpx**2-psqpy**2
6445  IF(psqpz2.GE.0.)THEN
6446  psqpz=sqrt(psqpz2)
6447  ELSE
6448  psqpx=0.
6449  psqpy=0.
6450  psqpz=psqe
6451  ENDIF
6452 C
6453  psaqp2=psaqe**2-psaqpx**2-psaqpy**2
6454  IF(psaqp2.GE.0.)THEN
6455  psaqpz=sqrt(psaqp2)
6456  ELSE
6457  psaqpx=0.
6458  psaqpy=0.
6459  psaqpz=psaqe
6460  ENDIF
6461 C
6462  tvqpz2=tvqe**2-tvqpx**2-tvqpy**2
6463  IF(tvqpz2.GE.0.)THEN
6464  tvqpz=-sqrt(tvqpz2)
6465  ELSE
6466  tvqpx=0.
6467  tvqpy=0.
6468  tvqpz=tvqe
6469  ENDIF
6470 C
6471  tdqpz2=tvdqe**2-tvdqpx**2-tvdqpy**2
6472  IF(tdqpz2.GE.0.)THEN
6473  tvdqpz=-sqrt(tdqpz2)
6474  ELSE
6475  tvdqpx=0.
6476  tvdqpy=0.
6477  tvdqpz=tvdqe
6478  ENDIF
6479  1779 CONTINUE
6480 C ----------------
6481 
6482 C
6483 C*** SAMPLE PARTON-PT VALUES / DETERMINE PARTON 4-MOMENTA AND CHAIN MAS
6484 C*** IN THE REST FRAME DEFINED ABOVE
6485 C
6486  ikvala=0
6487 C changej.r.6.5.93
6488  ptxsq1=0.
6489  ptxsa1=0.
6490  ptxsq2=0.
6491  ptxsa2=0.
6492  ptysq1=0.
6493  ptysa1=0.
6494  ptysq2=0.
6495  ptysa2=0.
6496  ptxsq1=psqpx
6497  ptxsa1=psaqpx
6498  ptxsq2=tvqpx
6499  ptxsa2=tvdqpx
6500  ptysq1=psqpy
6501  ptysa1=psaqpy
6502  ptysq2=tvqpy
6503  ptysa2=tvdqpy
6504  plq1=psqpz
6505  plaq1=psaqpz
6506  plq2=tvqpz
6507  plaq2=tvdqpz
6508  eq1=psqe
6509  eaq1=psaqe
6510  eq2=tvqe
6511  eaq2=tvdqe
6512 C ---------------
6513 C ---------------
6514  IF(ipev.GE.1) THEN
6515 C DO III=1,200
6516  WRITE(6,'(A,I5)') ' HAEVSV - IRSV13=',irsv13
6517  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
6518  + ' SV: ...',
6519  + ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
6520  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,
6521  + ptxsa2,ptysa2,plaq2,eaq2,
6522  + amch1,amch2,irej,ikvala,pttq1,ptta1
6523  bplq1=gamcm*plq1+bgcm*eq1
6524  beq1=gamcm*eq1+bgcm*plq1
6525  bplaq1=gamcm*plaq1+bgcm*eaq1
6526  beaq1=gamcm*eaq1+bgcm*plaq1
6527  bplq2=gamcm*plq2+bgcm*eq2
6528  beq2=gamcm*eq2+bgcm*plq2
6529  bplaq2=gamcm*plaq2+bgcm*eaq2
6530  beaq2=gamcm*eaq2+bgcm*plaq2
6531  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
6532  + ' SV: ...',
6533  + ptxsq1,ptysq1,bplq1,beq1,ptxsa1,ptysa1,
6534  + bplaq1,beaq1, ptxsq2,ptysq2,bplq2,beq2,
6535  + ptxsa2,ptysa2,bplaq2,beaq2,
6536  + amch1,amch2,irej,ikvala,pttq1,ptta1
6537 C ENDDO
6538  ENDIF
6539  ikvala=0
6540  nselpt=1
6541  nselpt=0
6542  IF(ip.EQ.1)nselpt=1
6543 C DO III=1,200
6544  IF(iouxev.GE.6)WRITE(6,'(A)')' KKEVSV call SELPT'
6545 C ENDDO
6546  IF(nselpt.EQ.1)CALL selpt( ptxsq1,ptysq1,plq1,
6547  + eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6548  + ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6549  * pttq2,ptta2,
6550  + nselpt)
6551  IF(nselpt.EQ.0)CALL selpt4( ptxsq1,ptysq1,plq1,
6552  + eq1,ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,
6553  + ptysa2,plaq2,eaq2, amch1,amch2,irej,ikvala,pttq1,ptta1,
6554  + nselpt)
6555  IF(ipev.GE.1) THEN
6556 C DO III=1,200
6557  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
6558  + ' SV: ...',
6559  + ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
6560  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
6561  + amch1,amch2,irej,ikvala,pttq1,ptta1
6562 C ENDDO
6563  ENDIF
6564 
6565  IF (ipev.GE.1) WRITE(6,'(A/5X,I10)')
6566  + 'SV ,IREJ ',
6567  + irej
6568  IF (irej.EQ.1) THEN
6569  irsv13=irsv13 + 1
6570  IF(ipev.GE.1) THEN
6571  WRITE(6,'(A,I5)') ' HAEVSV - IRSV13=',irsv13
6572  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
6573  + ' SV: ...',
6574  + ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
6575  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
6576  + amch1,amch2,irej,ikvala,pttq1,ptta1
6577  ENDIF
6578  go to 20
6579  ENDIF
6580 C
6581 C*** 4-MOMENTA OF CHAINS IN THIS FRAME
6582 C
6583  ptxch1=ptxsq1 + ptxsa2
6584  ptych1=ptysq1 + ptysa2
6585  ptzch1=plq1 + plaq2
6586  ech1=eq1 + eaq2
6587  ptxch2=ptxsq2 + ptxsa1
6588  ptych2=ptysq2 + ptysa1
6589  ptzch2=plq2 + plaq1
6590  ech2=eq2 + eaq1
6591  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
6592  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
6593 C
6594 C
6595  IF (ipev.GE.6) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
6596  + ' SV: IREJ ',
6597  + irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
6598  + amch1,ptxch1,ptych1,ptzch1,ech1,
6599  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
6600  + ptzch2,ech2
6601 
6602 C
6603 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS OR OCTETT
6604 C OR DECUPLETT BARYONS
6605 C FIRST FOR CHAIN 1 (PROJ SEA-QUARK - TAR DIQUARK)
6606 C
6607  CALL cobcma(ipsq(ixspr),ittv1(ixvta),ittv2(ixvta), ijnch1,nnch1,
6608  + irej,amch1,amch1n,1)
6609  IF(ipev.GE.2) THEN
6610  WRITE(6,'(A,I5)') ' HAEVSV - IRSV11=',irsv11
6611  WRITE(6,'(A,6I5/6E12.4/2E12.4)') ' SV:', ipsq(ixspr),ittv1
6612  + (ixvta),ittv2(ixvta),ijnch1,nnch1,irej, xpsq(ixspr),xpsaq
6613  + (ixspr),xpsqcm,xpsacm, xtvq(ixvta),xtvd(ixvta),amch1,amch1n
6614  ENDIF
6615 
6616 C*** MASS BELOW OCTETT BARYON MASS
6617  IF(irej.EQ.1) THEN
6618  IF(ipev.GE.1)WRITE(6,'(A)')' sv11 rej.'
6619  IF(ipev.GE.1) THEN
6620  WRITE(6,'(A,I5)') ' HAEVSV - IRSV11=',irsv11
6621  WRITE(6,'(A,6I5/6E12.4/2E12.4)') ' SV:', ipsq(ixspr),ittv1
6622  + (ixvta),ittv2(ixvta),ijnch1,nnch1,irej, xpsq(ixspr),xpsaq
6623  + (ixspr),xpsqcm,xpsacm, xtvq(ixvta),xtvd(ixvta),amch1,amch1n
6624  ENDIF
6625  irsv11=irsv11 + 1
6626  goto 20
6627  ENDIF
6628 C CORRECT KINEMATICS FOR CHAIN 1
6629 C*** MOMENTUM CORRECTION FOR CHANGED MASS OF CHAIN 1
6630  IF(nnch1.NE.0) THEN
6631  CALL cormom(amch1,amch2,amch1n,amch2n,
6632  + ptxsq1,ptysq1,plq1,eq1,
6633  + ptxsa1,ptysa1,plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,
6634  + plaq2,eaq2, ptxch1,ptych1,ptzch1,ech1, ptxch2,ptych2,ptzch2,
6635  + ech2,irej)
6636  amch2=amch2n
6637  ENDIF
6638 C
6639  IF (ipev.GE.6) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
6640  + ' SV(2): IREJ ',
6641  + irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
6642  + amch1,ptxch1,ptych1,ptzch1,ech1,
6643  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
6644  + ptzch2,ech2
6645  IF(ipev.GE.2) THEN
6646  WRITE(6,'(A,I5)') ' HAEVSV - IRSV11=',irsv11
6647  WRITE(6,'(A,6I5/6E12.4/2E12.4)') ' SV:', ipsq(ixspr),ittv1
6648  + (ixvta),ittv2(ixvta),ijnch1,nnch1,irej, xpsq(ixspr),xpsaq
6649  + (ixspr),xpsqcm,xpsacm, xtvq(ixvta),xtvd(ixvta),amch1,amch1n
6650  ENDIF
6651  IF(irej.EQ.1) THEN
6652  IF(ipev.GE.1)WRITE(6,'(A)')' sv cormom rej.'
6653  go to 20
6654  ENDIF
6655 
6656 C
6657 C REPLACE SMALL MASS CHAINS BY PSEUDOSCALAR OR VECTOR MESONS
6658 C SECOND FOR CHAIN 2 XPSAQ(N)---XTVQ(ITTA) ANTIQUARK-QUARK
6659 C
6660  CALL comcma(itvq(ixvta),ipsaq(ixspr), ijnch2,nnch2,irej,amch2,
6661  + amch2n)
6662 C
6663 C AT PRESENT NO CORRECTION FOR CHAIN 2
6664  IF(irej.EQ.1) THEN
6665  irsv12=irsv12 + 1
6666  IF(ipev.GE.1) THEN
6667  WRITE(6,'(A,I5)') ' HAEVSV - IRSV12=',irsv12
6668  WRITE(6,'(A/5I5/2(4E12.4/),2E12.4)')
6669  + ' SV: ITVQ(IXVTA),IPSAQ(IXSPR),IJNCH2,NNCH2,IREJ...', itvq
6670  + (ixvta),ipsaq(ixspr),ijnch2,nnch2,irej, xpsq(ixspr),xpsaq
6671  + (ixspr),xpsqcm,xpsacm, xtvq(ixvta),xtvd(ixvta),xtvqcm,
6672  + xtvdcm, amch2,amch2n
6673 
6674  ENDIF
6675  goto 20
6676  ENDIF
6677  amch2=amch2n
6678 C
6679  IF (ipev.GE.2) WRITE(6,'(A,I10/A,5F12.5/A,5F12.5)')
6680  + ' SV: IREJ ',
6681  + irej, ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',
6682  + amch1,ptxch1,ptych1,ptzch1,ech1,
6683  + ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ', amch2,ptxch2,ptych2,
6684  + ptzch2,ech2
6685  IF(ipev.GE.1) THEN
6686  WRITE(6,'(A/4(4E12.4/),2E12.4/2I5/4E12.4)')
6687  + ' SV: ...',
6688  + ptxsq1,ptysq1,plq1,eq1,ptxsa1,ptysa1,
6689  + plaq1,eaq1, ptxsq2,ptysq2,plq2,eq2,ptxsa2,ptysa2,plaq2,eaq2,
6690  + amch1,amch2,irej,ikvala,pttq1,ptta1
6691 
6692  ENDIF
6693 
6694  IF(nnch2.NE.0) THEN
6695  amch2=amch2n
6696 C IF AMCH1 CHANGED IN COBCMA/COMCMA
6697 C CORRESPONDING REPLACEMENT IN CORMOM
6698  ammm=sqrt((ech1+ech2)**2-(ptxch1+ptxch2)**2
6699  + -(ptych1+ptych2)**2-(ptzch1+ptzch2)**2)
6700  eee=ech1+ech2
6701  pxxx=ptxch1+ptxch2
6702  pyyy=ptych1+ptych2
6703  pzzz=ptzch1+ptzch2
6704  gammm=eee/(ammm+1.e-4)
6705  bgggx=pxxx/(ammm+1.e-4)
6706  bgggy=pyyy/(ammm+1.e-4)
6707  bgggz=pzzz/(ammm+1.e-4)
6708 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
6709 C
6710 C 4-MOMENTA OF CHAINS
6711  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
6712  + ptxch1,ptych1,ptzch1,ech1,
6713  + pppch1, qtxch1,qtych1,qtzch1,qech1)
6714 C
6715  CALL daltra(gammm,-bgggx,-bgggy,-bgggz,
6716  + ptxch2,ptych2,ptzch2,ech2,
6717  + pppch2, qtxch2,qtych2,qtzch2,qech2)
6718 C
6719  norig=24
6720  CALL corval(ammm,
6721  + irej,amch1,amch2, qtxch1,qtych1,qtzch1,qech1,
6722  + qtxch2,qtych2,qtzch2,qech2,norig)
6723 C TRANSFORM BOTH CHAINS INTO TWO CHAIN-CMS
6724 C
6725 C 4-MOMENTA OF CHAINS
6726 
6727  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch1,qtych1,qtzch1,qech1,
6728  + pppch1, ptxch1,ptych1,ptzch1,ech1)
6729 C
6730  CALL daltra(gammm,bgggx,bgggy,bgggz, qtxch2,qtych2,qtzch2,qech2,
6731  + pppch2, ptxch2,ptych2,ptzch2,ech2)
6732 C
6733 
6734 C
6735  IF(ipev.GE.6) THEN
6736  WRITE(6,'(A/3(1PE15.4),3I5)')
6737  + ' SV - CALL CORVAL: AMMM, AMCH1, AMCH2, NNCH1, NNCH2, IREJ',
6738  + ammm, amch1, amch2, nnch1, nnch2, irej
6739  ENDIF
6740  IF(irej.EQ.1) THEN
6741  IF(ipev.GE.1)WRITE(6,'(A)')' sv14 rej.'
6742 C AMCH1N + AMCH2N > AMMM - 0.2
6743 C REJECT EVENT
6744  irsv14=irsv14+1
6745  goto 20
6746  ENDIF
6747 C 12.5.95
6748 C GO TO 20
6749  ENDIF
6750 C
6751  qtxch1=ptxch1
6752  qtych1=ptych1
6753  qtzch1=ptzch1
6754  qech1=ech1
6755  qtxch2=ptxch2
6756  qtych2=ptych2
6757  qtzch2=ptzch2
6758  qech2=ech2
6759  pqsva1(n,1)=ptxsq1
6760  pqsva1(n,2)=ptysq1
6761  pqsva1(n,3)=plq1
6762  pqsva1(n,4)=eq1
6763  pqsva2(n,1)=ptxsa2
6764  pqsva2(n,2)=ptysa2
6765  pqsva2(n,3)=plaq2
6766  pqsva2(n,4)=eaq2
6767  pqsvb1(n,1)=ptxsq2
6768  pqsvb1(n,2)=ptysq2
6769  pqsvb1(n,3)=plq2
6770  pqsvb1(n,4)=eq2
6771  pqsvb2(n,1)=ptxsa1
6772  pqsvb2(n,2)=ptysa1
6773  pqsvb2(n,3)=plaq1
6774  pqsvb2(n,4)=eaq1
6775 C-------------------
6776 
6777 C
6778 C PUT S-V CHAIN ENDS INTO /HKKEVT/
6779 C MOMENTA IN NN-CMS
6780 C POSITION OF ORIGINAL NUCLEONS
6781 C
6782 C FLAG FOR SV-CHAIN ENDS
6783 C PROJECTILE: ISTHKK=131
6784 C TARGET: ISTHKK=122
6785 C FOR SV-CHAINS ISTHKK=4
6786 C
6787  ihkkpd=jhkkps(ixspr )
6788  ihkkpo=jhkkps(ixspr )-1
6789  ihkktd=jhkktv(ixvta )
6790  ihkkto=jhkktv(ixvta )-1
6791  IF (ipev.GT.3)WRITE(6,1000)ixspr,inucpr,jnucpr,ihkkpo,ihkkpd
6792  1000 FORMAT (' IXSPR,INUCPR,JNUCPR,IHKKPO,IHKKPD ',5i5)
6793  IF (ipev.GT.3)WRITE(6,1010)ixvta,inucta,jnucta,ihkkto,ihkktd
6794  1010 FORMAT (' IXVTA,INUCTA,JNUCTA,IHKKTO,IHKKTD ',5i5)
6795 C CHAIN 1 PROJECTILE SEA-QUARK
6796  nhkk=nhkk+1
6797  IF (nhkk.EQ.nmxhkk)THEN
6798  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
6799  RETURN
6800  ENDIF
6801  ihkk=nhkk
6802  isthkk(ihkk)=131
6803  idhkk(ihkk)=idhkk(ihkkpo)
6804  jmohkk(1,ihkk)=ihkkpo
6805  jmohkk(2,ihkk)=jmohkk(1,ihkkpo)
6806  jdahkk(1,ihkk)=ihkk+2
6807  jdahkk(2,ihkk)=ihkk+2
6808  phkk(1,ihkk)=pqsva1(n,1)
6809  phkk(2,ihkk)=pqsva1(n,2)
6810  phkk(3,ihkk)=pqsva1(n,3)
6811  phkk(4,ihkk)=pqsva1(n,4)
6812  phkk(5,ihkk)=0.
6813 C Add position of parton in hadron
6814  CALL qinnuc(xxpp,yypp)
6815  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
6816  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
6817  vhkk(3,ihkk)=vhkk(3,ihkkpo)
6818  vhkk(4,ihkk)=vhkk(4,ihkkpo)
6819  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
6820  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
6821  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
6822 
6823  1020 FORMAT (i6,i4,5i6,9e10.2)
6824 C CHAIN 1 TARGET DIQUARK
6825  nhkk=nhkk+1
6826  IF (nhkk.EQ.nmxhkk)THEN
6827  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
6828  RETURN
6829  ENDIF
6830  ihkk=nhkk
6831  isthkk(ihkk)=122
6832  idhkk(ihkk)=idhkk(ihkktd)
6833  jmohkk(1,ihkk)=ihkktd
6834  jmohkk(2,ihkk)=jmohkk(1,ihkktd)
6835  jdahkk(1,ihkk)=ihkk+1
6836  jdahkk(2,ihkk)=ihkk+1
6837  phkk(1,ihkk)=pqsva2(n,1)
6838  phkk(2,ihkk)=pqsva2(n,2)
6839  phkk(3,ihkk)=pqsva2(n,3)
6840  phkk(4,ihkk)=pqsva2(n,4)
6841  phkk(5,ihkk)=0.
6842 C Add position of parton in hadron
6843  CALL qinnuc(xxpp,yypp)
6844  vhkk(1,ihkk)=vhkk(1,ihkktd)+xxpp
6845  vhkk(2,ihkk)=vhkk(2,ihkktd)+yypp
6846  vhkk(3,ihkk)=vhkk(3,ihkktd)
6847  vhkk(4,ihkk)=vhkk(4,ihkktd)
6848  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
6849  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
6850  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
6851 
6852 C
6853 C CHAIN 1 BEFORE FRAGMENTATION
6854  nhkk=nhkk+1
6855  IF (nhkk.EQ.nmxhkk)THEN
6856  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
6857  RETURN
6858  ENDIF
6859  ihkk=nhkk
6860  isthkk(ihkk)=4
6861  idhkk(ihkk)=88888+nnch1
6862  jmohkk(1,ihkk)=ihkk-2
6863  jmohkk(2,ihkk)=ihkk-1
6864  phkk(1,ihkk)=qtxch1
6865  phkk(2,ihkk)=qtych1
6866  phkk(3,ihkk)=qtzch1
6867  phkk(4,ihkk)=qech1
6868  phkk(5,ihkk)=amch1
6869 C POSITION OF CREATED CHAIN IN LAB
6870 C =POSITION OF TARGET NUCLEON
6871 C TIME OF CHAIN CREATION IN LAB
6872 C =TIME OF PASSAGE OF PROJECTILE
6873 C NUCLEUS AT POSITION OF TAR. NUCLEUS
6874  IF (ipev.GT.3)WRITE(6,'(A,3E12.3)')' BETP,GAMP,BGAMP',
6875  * betp,gamp,bgamp
6876  vhkk(1,nhkk)= vhkk(1,nhkk-1)
6877  vhkk(2,nhkk)= vhkk(2,nhkk-1)
6878  vhkk(3,nhkk)= vhkk(3,nhkk-1)
6879  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
6880  mhkksv(n)=ihkk
6881  IF (iprojk.EQ.1)THEN
6882  whkk(1,nhkk)= vhkk(1,nhkk-2)
6883  whkk(2,nhkk)= vhkk(2,nhkk-2)
6884  whkk(3,nhkk)= vhkk(3,nhkk-2)
6885  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
6886  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
6887  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
6888  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
6889 
6890  ENDIF
6891  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
6892  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
6893  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
6894 
6895 C
6896 C
6897 C CHAIN 2 PROJECTILE SEA-ANTIQUARK
6898  nhkk=nhkk+1
6899  IF (nhkk.EQ.nmxhkk)THEN
6900  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
6901  RETURN
6902  ENDIF
6903  ihkk=nhkk
6904  isthkk(ihkk)=131
6905  idhkk(ihkk)=idhkk(ihkkpd)
6906  jmohkk(1,ihkk)=ihkkpd
6907  jmohkk(2,ihkk)=jmohkk(1,ihkkpd)
6908  jdahkk(1,ihkk)=ihkk+2
6909  jdahkk(2,ihkk)=ihkk+2
6910  phkk(1,ihkk)=pqsvb1(n,1)
6911  phkk(2,ihkk)=pqsvb1(n,2)
6912  phkk(3,ihkk)=pqsvb1(n,3)
6913  phkk(4,ihkk)=pqsvb1(n,4)
6914  phkk(5,ihkk)=0.
6915 C Add position of parton in hadron
6916  CALL qinnuc(xxpp,yypp)
6917  vhkk(1,ihkk)=vhkk(1,ihkkpd)+xxpp
6918  vhkk(2,ihkk)=vhkk(2,ihkkpd)+yypp
6919  vhkk(3,ihkk)=vhkk(3,ihkkpd)
6920  vhkk(4,ihkk)=vhkk(4,ihkkpd)
6921  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
6922  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
6923  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
6924 
6925 C CHAIN 2 TARGET QUARK
6926  nhkk=nhkk+1
6927  IF (nhkk.EQ.nmxhkk)THEN
6928  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
6929  RETURN
6930  ENDIF
6931  ihkk=nhkk
6932  isthkk(ihkk)=122
6933  idhkk(ihkk)=idhkk(ihkkto)
6934  jmohkk(1,ihkk)=ihkkto
6935  jmohkk(2,ihkk)=jmohkk(1,ihkkto)
6936  jdahkk(1,ihkk)=ihkk+1
6937  jdahkk(2,ihkk)=ihkk+1
6938  phkk(1,ihkk)=pqsvb2(n,1)
6939  phkk(2,ihkk)=pqsvb2(n,2)
6940  phkk(3,ihkk)=pqsvb2(n,3)
6941  phkk(4,ihkk)=pqsvb2(n,4)
6942  phkk(5,ihkk)=0.
6943 C Add position of parton in hadron
6944  CALL qinnuc(xxpp,yypp)
6945  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
6946  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
6947  vhkk(3,ihkk)=vhkk(3,ihkkto)
6948  vhkk(4,ihkk)=vhkk(4,ihkkto)
6949  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
6950  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
6951  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
6952 
6953 C
6954 C CHAIN 2 BEFORE FRAGMENTATION
6955  nhkk=nhkk+1
6956  IF (nhkk.EQ.nmxhkk)THEN
6957  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
6958  RETURN
6959  ENDIF
6960  ihkk=nhkk
6961  isthkk(ihkk)=4
6962  idhkk(ihkk)=88888+nnch2
6963  jmohkk(1,ihkk)=ihkk-2
6964  jmohkk(2,ihkk)=ihkk-1
6965  phkk(1,ihkk)=qtxch2
6966  phkk(2,ihkk)=qtych2
6967  phkk(3,ihkk)=qtzch2
6968  phkk(4,ihkk)=qech2
6969  phkk(5,ihkk)=amch2
6970 C POSITION OF CREATED CHAIN IN LAB
6971 C =POSITION OF TARGET NUCLEON
6972 C TIME OF CHAIN CREATION IN LAB
6973 C =TIME OF PASSAGE OF PROJECTILE
6974 C NUCLEUS AT POSITION OF TAR. NUCLEUS
6975  vhkk(1,nhkk)= vhkk(1,nhkk-1)
6976  vhkk(2,nhkk)= vhkk(2,nhkk-1)
6977  vhkk(3,nhkk)= vhkk(3,nhkk-1)
6978  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
6979  mhkksv(n)=ihkk
6980  IF (iprojk.EQ.1)THEN
6981  whkk(1,nhkk)= vhkk(1,nhkk-2)
6982  whkk(2,nhkk)= vhkk(2,nhkk-2)
6983  whkk(3,nhkk)= vhkk(3,nhkk-2)
6984  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
6985  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
6986  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
6987  + (phkk(khkk,ihkk),khkk=1,5), (whkk(khkk,ihkk),khkk=1,4)
6988 
6989  ENDIF
6990  IF (iphkk.GE.2) WRITE(6,1020) ihkk,isthkk(ihkk),idhkk(ihkk),
6991  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
6992  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
6993 
6994 C
6995 C
6996 C NOW WE HAVE AN ACCEPTABLE SEA--VALENCE EVENT
6997 C AND PUT IT INTO THE HISTOGRAM
6998 C
6999  amcsv1(n)=amch1
7000  amcsv2(n)=amch2
7001  gacsv1(n)=qech1/amch1
7002  bgxsv1(n)=qtxch1/amch1
7003  bgysv1(n)=qtych1/amch1
7004  bgzsv1(n)=qtzch1/amch1
7005  gacsv2(n)=qech2/amch2
7006  bgxsv2(n)=qtxch2/amch2
7007  bgysv2(n)=qtych2/amch2
7008  bgzsv2(n)=qtzch2/amch2
7009  nchsv1(n)=nnch1
7010  nchsv2(n)=nnch2
7011  ijcsv1(n)=ijnch1
7012  ijcsv2(n)=ijnch2
7013  IF (ipev.GE.2) WRITE(6,'(A/I10,4F12.7,5I5/10X,4F12.6/10X,6F12.6,
7014  +4I5/8F15.5/ 8F15.5)') ' SV / FINAL PRINT',n, xpsq
7015  + (ixspr),xpsaq(ixspr),xtvq(ixvta),xtvd(ixvta), ipsq(ixspr),ipsaq
7016  + (ixspr), itvq(ixvta),ittv1(ixvta),ittv2(ixvta), amcsv1(n),amcsv2
7017  + (n),gacsv1(n),gacsv2(n), bgxsv1(n),bgysv1(n),bgzsv1(n), bgxsv2
7018  + (n),bgysv2(n),bgzsv2(n), nchsv1(n),nchsv2(n),ijcsv1(n),ijcsv2
7019  + (n), (pqsva1(n,ju),pqsva2(n,ju),pqsvb1(n,ju), pqsvb2(n,ju),ju=1,
7020  + 4)
7021 
7022 
7023 
7024 
7025  10 CONTINUE
7026  RETURN
7027 C
7028  20 CONTINUE
7029 C EVENT REJECTED
7030 C START A NEW ONE
7031  irejsv=1
7032  RETURN
7033  END
7034 C-------------------------------------------------------------------
7035 
7036 C-------------------------------------------------------------------
7037  SUBROUTINE cromsc(PX,PY,PZ,E,RX,RY,RZ,PXN,PYN,PZN,EN,IORIG)
7038  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7039  SAVE
7040 C j.r.6.5.93
7041 C parton with momentum components px,py,pz
7042 C at position rx,ry,rz in target nucleus
7043 C gets multiple scattering during travel through target
7044 C
7045  COMMON /nncms/gamcm,bgcm,umo,pcm,eproj,pproj
7046  common/rptshm/rproj,rtarg,bimpac
7047  common/cronin/cronco,mkcron
7048  common/dprin/ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7049 C IPRI=1
7050  IF(e.LE.0.d0)ipri=1
7051  IF(mkcron.EQ.0) THEN
7052  pxn=px
7053  pyn=py
7054  pzn=pz
7055  en=e
7056  RETURN
7057  ENDIF
7058  IF(ipri.GE.1)
7059  * WRITE(6,'(A,7E12.3,I5)')
7060  * ' CROMSC:PX,PY,PZ,E,RX,RY,RZ,IORIG',
7061  * px,py,pz,e,rx,ry,rz,iorig
7062 C
7063 C first transform parton momenta px,py,pz,e back into target systen
7064 C
7065  IF(ipri.GE.1)
7066  * WRITE(6,'(A,7E12.3)')' CROMSC:GAMCM,BGCM',
7067  * gamcm,bgcm
7068  CALL sltraf(gamcm,-bgcm,e,pz,el,pzl)
7069  IF(ipri.GE.1)
7070  * WRITE(6,'(A,4E12.3)')' CROMSC:E,PZ,EL,PZL',
7071  * e,pz,el,pzl
7072 C
7073 C direction cosines of parton
7074 C
7075  pp=px**2+py**2+pzl**2
7076  p=sqrt(pp)
7077  IF(p.LE.2.0)THEN
7078  pxn=px
7079  pyn=py
7080  pzn=pz
7081  en=e
7082  RETURN
7083  ENDIF
7084 C
7085  cx=px/p
7086  cy=py/p
7087  cz=pzl/p
7088  IF(ipri.GE.1)
7089  * WRITE(6,'(A,4E12.3)')' CROMSC:P,CX,CY,CZ',
7090  * p,cx,cy,cz
7091 C
7092 C is position of parton within standard target nucleus (r=rtarg)
7093 C
7094  rtesq= rx**2+ry**2+rz**2-rtarg**2
7095  IF(ipri.GE.1)
7096  * WRITE(6,'(A,2E12.3)')' CROMSC:RTARG,RTESQ',
7097  * rtarg,rtesq
7098  IF(rtesq.GE.-0.001)THEN
7099  pxn=px
7100  pyn=py
7101  pzn=pz
7102  en=e
7103  RETURN
7104  ENDIF
7105 C
7106 C calculate distance from point rx,ry,rz to surface of rtarg sphere
7107 C (origin:0,0,0)
7108 C
7109  b=rtesq
7110  a=cx*rx+cy*ry+cz*rz
7111 C distance to surface ts
7112  ts=-a+sqrt(a**2-b)
7113  IF(ipri.GE.1)
7114  * WRITE(6,'(A,3E12.3)')' CROMSC:A,B,TS',
7115  * a,b,ts
7116 
7117 C
7118 C calculate multiple scattering angle
7119 C
7120  theto=cronco*sqrt(ts)/p
7121 C IF(IPRI.GE.0.AND.THETO.GT.0.10D0)
7122 C * WRITE(6,'(A,4E12.3)')' CROMSC:A,B,TS,THETO,truncate',
7123 C * A,B,TS,THETO
7124 C IF(THETO.GT.0.10D0)THETO=0.1
7125 C PXN=PX
7126 C PYN=PY
7127 C PZN=PZ
7128 C EN=E
7129 C RETURN
7130 C ENDIF
7131  1212 CONTINUE
7132 C
7133 C Gaussian sampling of space angle
7134 C
7135  CALL rannor(r1,r2)
7136  theta=abs(r1*theto)
7137 C IF(THETA.GE.0.3D0)THEN
7138  IF(theta.GE.0.9d0)THEN
7139  IF(ipri.GE.1)
7140  * WRITE(6,'(A,4E12.3)')' CROMSC:A,B,TS,THETA,reject',
7141  * a,b,ts,theta
7142  pxn=px
7143  pyn=py
7144  pzn=pz
7145  en=e
7146  RETURN
7147  ENDIF
7148  CALL dsfecf(sfe,cfe)
7149  ct=cos(theta)
7150  st=sin(theta)
7151  IF(ipri.GE.1)
7152  * WRITE(6,'(A,2E12.3)')' CROMSC:THETO,THETA',
7153  * theto,theta
7154 C
7155 C new direction cosines
7156 C
7157  CALL dtrans(cx,cy,cz,ct,st,cfe,sfe,cxn,cyn,czn)
7158  IF(ipri.GE.1)
7159  * WRITE(6,'(A,3E12.3)')' CROMSC:CXN,CYN,CZN',
7160  * cxn,cyn,czn
7161 C
7162 C new momenta in target system
7163 C
7164  pxln=cxn*p
7165  pyln=cyn*p
7166  pzln=czn*p
7167  IF(ipri.GE.1)
7168  * WRITE(6,'(A,3E12.3)')' CROMSC:PXLN,PYLN,PZLN',
7169  * pxln,pyln,pzln
7170 C
7171 C transformation back into cms
7172 C
7173  pxn=pxln
7174  pyn=pyln
7175  IF(ipri.GE.1)
7176  * WRITE(6,'(A,7E12.3)')' CROMSC:GAMCM,BGCM',
7177  * gamcm,bgcm
7178  CALL sltraf(gamcm,bgcm,el,pzln,en,pzn)
7179  IF(ipri.GE.1)
7180  * WRITE(6,'(A,4E12.3)')' CROMSC:PXN,PYN,PZN,EN',
7181  * pxn,pyn,pzn,en
7182  IF(abs(e-en).GT.0.2)THEN
7183  theto=theto/2.
7184  go to 1212
7185  ENDIF
7186 C IPRI=0
7187  IF (e.LE.0.)ipri=0
7188  RETURN
7189  END
7190 
7191 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7192 C
7193  SUBROUTINE kkevhh
7194  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7195  SAVE
7196 C
7197 C------------------------- TREATMENT OF Hard scattered CHAIN SYSTEMS
7198 C
7199 *KEEP,NUCC.
7200  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
7201 *KEEP,RPTSHM.
7202  COMMON /rptshm/ rproj,rtarg,bimpac
7203  parameter(intmx=2488,intmd=252)
7204  COMMON /trafop/ gamp,bgamp,betp
7205  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248),
7206  * xpsq(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
7207  * ,xpsu(248),xtsu(248)
7208  * ,xpsut(248),xtsut(248)
7209 *KEEP,INTNEW.
7210  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
7211  +ixpv,ixps,ixtv,ixts, intvv1(248),
7212  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
7213  +intss1(intmx),intss2(intmx),
7214  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
7215  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
7216 
7217 C /INTNEW/
7218 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
7219 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
7220 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
7221 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
7222 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
7223 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
7224 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
7225 C FROM PROJECTILE/TARGET NUCLEI
7226 C-------------------
7227 C--------------------
7228  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx),
7229  * ifrovt(248),itovt(248),ifrost(intmx),
7230  * jsshs(intmx),jtshs(intmx),jhkknp(248),jhkknt(248),
7231  * jhkkpv(intmx),jhkkps(intmx),
7232  * jhkktv(intmx),jhkkts(intmx),
7233  * mhkkvv(intmx),mhkkss(intmx),
7234  & mhkkvs(intmx),mhkksv(intmx),
7235  + mhkkhh(intmx),
7236  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
7237 C-------------------
7238  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
7239  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
7240  * intlo(intmx),inloss(intmx)
7241 C-------------------
7242 *KEEP,DIQI.
7243  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
7244  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
7245  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
7246  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
7247 C--------------------
7248  COMMON /nucimp/ prmom(5,248),tamom(5,248),
7249  & prmfep,prmfen,tamfep,tamfen,
7250  & prefep,prefen,taefep,taefen,
7251  & prepot(210),taepot(210),prebin,taebin,fermod,etacou
7252 C--------------------
7253 C--------------------
7254  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
7255  * ipadis,ishmal,lpauli
7256  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
7257  * ipadis,ishmal,lpauli
7258 C-------------------
7259  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7260  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5,irss11,irss12,irss13,
7261  * irss14,
7262  * irsv11,irsv12,irsv13,irsv14,
7263  * irvs11,irvs12,irvs13,irvs14,
7264  * irvv11,irvv12,irvv13,irvv14
7265  COMMON /abrhh/ amchh1(intmx),amchh2(intmx),
7266  * gachh1(intmx),gachh2(intmx),
7267  * bgxhh1(intmx),bgyhh1(intmx),bgzhh1(intmx),
7268  * bgxhh2(intmx),bgyhh2(intmx),bgzhh2(intmx),
7269  * nchhh1(intmx),nchhh2(intmx),
7270  * ijchh1(intmx),ijchh2(intmx),
7271  * pqhha1(intmx,4),pqhha2(intmx,4),
7272  * pqhhb1(intmx,4),pqhhb2(intmx,4)
7273 C-------------------
7274  parameter(nmxhkk= 89998)
7275  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
7276  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
7277  & phkk(5,nmxhkk),
7278  & vhkk(4,nmxhkk),whkk(4,nmxhkk)
7279 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
7280 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
7281 C THE POSITIONS OF THE PROJECTILE NUCLEONS
7282 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
7283 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
7284 C COMPLETELY CONSISTENT. THE TIMES IN THE
7285 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
7286 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
7287  COMMON /projk/ iprojk
7288 C
7289 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
7290 C
7291 C NMXHKK: maximum numbers of entries (partons/particles) that can be
7292 C stored in the commonblock.
7293 C
7294 C NHKK: the actual number of entries stored in current event. These are
7295 C found in the first NHKK positions of the respective arrays below.
7296 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
7297 C entry.
7298 C
7299 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
7300 C = 0 : null entry.
7301 C = 1 : an existing entry, which has not decayed or fragmented.
7302 C This is the main class of entries which represents the
7303 C "final state" given by the generator.
7304 C = 2 : an entry which has decayed or fragmented and therefore
7305 C is not appearing in the final state, but is retained for
7306 C event history information.
7307 C = 3 : a documentation line, defined separately from the event
7308 C history. (incoming reacting
7309 C particles, etc.)
7310 C = 4 - 10 : undefined, but reserved for future standards.
7311 C = 11 - 20 : at the disposal of each model builder for constructs
7312 C specific to his program, but equivalent to a null line in the
7313 C context of any other program. One example is the cone defining
7314 C vector of HERWIG, another cluster or event axes of the JETSET
7315 C analysis routines.
7316 C = 21 - : at the disposal of users, in particular for event tracking
7317 C in the detector.
7318 C
7319 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
7320 C standard.
7321 C
7322 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
7323 C The value is 0 for initial entries.
7324 C
7325 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
7326 C one mother exist, in which case the value 0 is used. In cluster
7327 C fragmentation models, the two mothers would correspond to the q
7328 C and qbar which join to form a cluster. In string fragmentation,
7329 C the two mothers of a particle produced in the fragmentation would
7330 C be the two endpoints of the string (with the range in between
7331 C implied).
7332 C
7333 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
7334 C entry has not decayed, this is 0.
7335 C
7336 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
7337 C entry has not decayed, this is 0. It is assumed that the daughters
7338 C of a particle (or cluster or string) are stored sequentially, so
7339 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
7340 C daughters. Even in cases where only one daughter is defined (e.g.
7341 C K0 -> K0S) both values should be defined, to make for a uniform
7342 C approach in terms of loop constructions.
7343 C
7344 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
7345 C
7346 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
7347 C
7348 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
7349 C
7350 C PHKK(4,IHKK) : energy, in GeV.
7351 C
7352 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
7353 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
7354 C
7355 C VHKK(1,IHKK) : production vertex x position, in mm.
7356 C
7357 C VHKK(2,IHKK) : production vertex y position, in mm.
7358 C
7359 C VHKK(3,IHKK) : production vertex z position, in mm.
7360 C
7361 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
7362 C
7363 C-----------------------------------------------------------------------
7364  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
7365  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
7366  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
7367  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
7368  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
7369  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
7370  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
7371  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
7372  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
7373  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
7374 C----------------------------------------------------------------------
7375  dimension ihkkq(-6:6)
7376  DATA ihkkq/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
7377 C
7378 C----------------------------------------------------------------------
7379  DO 101 n=1,nonujt
7380  IF (jhkkex(n).EQ.1)THEN
7381 C
7382  ixvpr=jhkkph(n)
7383  ixvta=jhkkth(n)
7384  ihkkpo=jhkkpv(ixvpr)
7385  ihkkto=jhkktv(ixvta)
7386 C
7387 C Cronin multiple scattering
7388  IF(it.GT.1)THEN
7389  itnu=ihkkto
7390  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
7391  rtiy=vhkk(2,itnu)*1.e12
7392  rtiz=vhkk(3,itnu)*1.e12
7393  rtir2=(rtix**2+rtiy**2+rtiz**2)
7394  IF(rtir2.GT.rtarg**2)THEN
7395  IF(ipev.GE.2)
7396  * WRITE(6,774)rtarg,rtix,rtiy,rtiz,bimpac,ihkkto,ixvta
7397  774 FORMAT(' KKEVHH: RTARG,RTIX,RTIY,RTIZ,BIMPAC,IHKKTO,IXVTA'
7398  * ,5e12.4,2i10)
7399  go to 779
7400  ENDIF
7401  pvqpx=pjeta1(n,1)
7402  pvqpy=pjeta1(n,2)
7403  pvqpz=pjeta1(n,3)
7404  pvqe =pjeta1(n,4)
7405  CALL cromsc(pvqpx,pvqpy,pvqpz,pvqe,rtix,rtiy,rtiz,
7406  * pvqnx,pvqny,pvqnz,pvqne,20)
7407  pvdqpx=pjeta2(n,1)
7408  pvdqpy=pjeta2(n,2)
7409  pvdqpz=pjeta2(n,3)
7410  pvdqe =pjeta2(n,4)
7411  CALL cromsc(pvdqpx,pvdqpy,pvdqpz,pvdqe,rtix,rtiy,rtiz,
7412  * pvdqnx,pvdqny,pvdqnz,pvdqne,21)
7413  amtes2=((pvqne+pvdqne)**2-(pvqnx+pvdqnx)**2
7414  * -(pvqny+pvdqny)**2-(pvqnz+pvdqnz)**2)
7415  IF(amtes2.GE.amjch1(n)**2.OR.amtes2.GE.25.d0)THEN
7416  pjeta1(n,1)=pvqnx
7417  pjeta1(n,2)=pvqny
7418  pjeta1(n,3)=pvqnz
7419  pjeta1(n,4)=pvqne
7420  pjeta2(n,1)=pvdqnx
7421  pjeta2(n,2)=pvdqny
7422  pjeta2(n,3)=pvdqnz
7423  pjeta2(n,4)=pvdqne
7424  ENDIF
7425 C MASSES OF SUBCHAINS
7426  xmjch1=sqrt((pjeta1(n,4)+
7427  * pjeta2(n,4))**2
7428  * -(pjeta1(n,1)+
7429  * pjeta2(n,1))**2
7430  * -(pjeta1(n,2)+
7431  * pjeta2(n,2))**2
7432  * -(pjeta1(n,3)+
7433  * pjeta2(n,3))**2)
7434  IF(xmjch1.GE.amjch1(n))THEN
7435  amjch1(n)=xmjch1
7436 C
7437  gamjh1(n)=(pjeta1(n,4)+
7438  * pjeta2(n,4))/amjch1(n)
7439  bgxjh1(n)=(pjeta1(n,1)+
7440  * pjeta2(n,1))/amjch1(n)
7441  bgyjh1(n)=(pjeta1(n,2)+
7442  * pjeta2(n,2))/amjch1(n)
7443  bgzjh1(n)=(pjeta1(n,3)+
7444  * pjeta2(n,3))/amjch1(n)
7445  ENDIF
7446  ENDIF
7447  779 CONTINUE
7448 C ---------
7449 C
7450 C
7451 C PUT h-h CHAIN ENDS INTO /HKKEVT/
7452 C MOMENTA IN NN-CMS
7453 C POSITION OF ORIGINAL NUCLEONS
7454 c flags for h-h chain ends
7455 c projectile: isthkk=151
7456 c target: isthkk=152
7457 c h-h chains: isthkk=7
7458 C
7459  ixvpr=jhkkph(n)
7460  ixvta=jhkkth(n)
7461  ihkkpo=jhkkpv(ixvpr)
7462  ihkkto=jhkktv(ixvta)
7463  IF (ipev.GT.3)WRITE(6,5002)ixvpr,ihkkpo
7464  5002 FORMAT (' IXVPR,IHKKPO ',5i5)
7465  IF (ipev.GT.3)WRITE(6,5003)ixvta,ihkkto
7466  5003 FORMAT (' IXVTA,IHKKTO ',5i5)
7467 C CHAIN 1 PROJECTILE SEA-QUARK
7468  nhkk=nhkk+1
7469  IF (nhkk.EQ.nmxhkk)THEN
7470  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
7471  RETURN
7472  ENDIF
7473  ihkk=nhkk
7474  isthkk(ihkk)=151
7475  idhkk(ihkk)=ihkkq(ijjq1(n))
7476  jmohkk(1,ihkk)=ihkkpo
7477  jmohkk(2,ihkk)=ihkkpo
7478  jdahkk(1,ihkk)=ihkk+2
7479  jdahkk(2,ihkk)=ihkk+2
7480  phkk(1,ihkk)=pjeta1(n,1)
7481  phkk(2,ihkk)=pjeta1(n,2)
7482  phkk(3,ihkk)=pjeta1(n,3)
7483  phkk(4,ihkk)=pjeta1(n,4)
7484  phkk(5,ihkk)=0.
7485 C Add position of parton in hadron
7486  CALL qinnuc(xxpp,yypp)
7487  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
7488  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
7489  vhkk(3,ihkk)=vhkk(3,ihkkpo)
7490  vhkk(4,ihkk)=vhkk(4,ihkkpo)
7491  IF (iphkk.GE.2) WRITE(6,5001)
7492  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
7493  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
7494  & (vhkk(khkk,ihkk),khkk=1,4)
7495  5001 FORMAT (i6,i4,5i6,9e10.2)
7496 C CHAIN 1 TARGET SEA-QUARK
7497  nhkk=nhkk+1
7498  IF (nhkk.EQ.nmxhkk)THEN
7499  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
7500  RETURN
7501  ENDIF
7502  ihkk=nhkk
7503  isthkk(ihkk)=152
7504  idhkk(ihkk)=ihkkq(ijjaq2(n))
7505  jmohkk(1,ihkk)=ihkkto
7506  jmohkk(2,ihkk)=ihkkto
7507  jdahkk(1,ihkk)=ihkk+1
7508  jdahkk(2,ihkk)=ihkk+1
7509  phkk(1,ihkk)=pjeta2(n,1)
7510  phkk(2,ihkk)=pjeta2(n,2)
7511  phkk(3,ihkk)=pjeta2(n,3)
7512  phkk(4,ihkk)=pjeta2(n,4)
7513  phkk(5,ihkk)=0.
7514 C Add position of parton in hadron
7515  CALL qinnuc(xxpp,yypp)
7516  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
7517  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
7518  vhkk(3,ihkk)=vhkk(3,ihkkto)
7519  vhkk(4,ihkk)=vhkk(4,ihkkto)
7520  IF (iphkk.GE.2) WRITE(6,5001)
7521  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
7522  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
7523  & (vhkk(khkk,ihkk),khkk=1,4)
7524 C
7525 C CHAIN 1 BEFORE FRAGMENTATION
7526  nhkk=nhkk+1
7527  IF (nhkk.EQ.nmxhkk)THEN
7528  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
7529  RETURN
7530  ENDIF
7531  ihkk=nhkk
7532  isthkk(ihkk)=7
7533  idhkk(ihkk)=88888
7534  jmohkk(1,ihkk)=ihkk-2
7535  jmohkk(2,ihkk)=ihkk-1
7536  phkk(1,ihkk)=phkk(1,ihkk-2)+phkk(1,ihkk-1)
7537  phkk(2,ihkk)=phkk(2,ihkk-2)+phkk(2,ihkk-1)
7538  phkk(3,ihkk)=phkk(3,ihkk-2)+phkk(3,ihkk-1)
7539  phkk(4,ihkk)=phkk(4,ihkk-2)+phkk(4,ihkk-1)
7540  phkk(5,ihkk)=amjch1(n)
7541 C POSITION OF CREATED CHAIN IN LAB
7542 C =POSITION OF TARGET NUCLEON
7543 C TIME OF CHAIN CREATION IN LAB
7544 C =TIME OF PASSAGE OF PROJECTILE
7545 C NUCLEUS AT POSITION OF TAR. NUCLEUS
7546  vhkk(1,nhkk)= vhkk(1,nhkk-1)
7547  vhkk(2,nhkk)= vhkk(2,nhkk-1)
7548  vhkk(3,nhkk)= vhkk(3,nhkk-1)
7549  vhkk(4,nhkk)=0.
7550  mhkkhh(n)=ihkk
7551  IF (iprojk.EQ.1)THEN
7552  whkk(1,nhkk)= vhkk(1,nhkk-2)
7553  whkk(2,nhkk)= vhkk(2,nhkk-2)
7554  whkk(3,nhkk)= vhkk(3,nhkk-2)
7555  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
7556  IF (iphkk.GE.2) WRITE(6,5001)
7557  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
7558  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
7559  & (whkk(khkk,ihkk),khkk=1,4)
7560  ENDIF
7561  IF (iphkk.GE.1)THEN
7562  WRITE(6,'(A)')' KKEVHH:'
7563  WRITE(6,5001)
7564  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
7565  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
7566  & (vhkk(khkk,ihkk),khkk=1,4)
7567  ENDIF
7568 C
7569 C
7570 C CHAIN 2 PROJECTILE SEA-QUARK
7571  iijjkk=0
7572  IF(iijjkk.EQ.0)go to 33446
7573  nhkk=nhkk+1
7574  IF (nhkk.EQ.nmxhkk)THEN
7575  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
7576  RETURN
7577  ENDIF
7578  ihkk=nhkk
7579  isthkk(ihkk)=151
7580  idhkk(ihkk)=ihkkq(ijjaq1(n))
7581  jmohkk(1,ihkk)=ihkkpo
7582  jmohkk(2,ihkk)=ihkkpo
7583  jdahkk(1,ihkk)=ihkk+2
7584  jdahkk(2,ihkk)=ihkk+2
7585  phkk(1,ihkk)=pjetb1(n,1)
7586  phkk(2,ihkk)=pjetb1(n,2)
7587  phkk(3,ihkk)=pjetb1(n,3)
7588  phkk(4,ihkk)=pjetb1(n,4)
7589  phkk(5,ihkk)=0.
7590 C Add position of parton in hadron
7591  CALL qinnuc(xxpp,yypp)
7592  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
7593  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
7594  vhkk(3,ihkk)=vhkk(3,ihkkpo)
7595  vhkk(4,ihkk)=vhkk(4,ihkkpo)
7596  IF (iphkk.GE.2) WRITE(6,5001)
7597  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
7598  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
7599  & (vhkk(khkk,ihkk),khkk=1,4)
7600 C CHAIN 2 TARGET SEA-QUARK
7601  nhkk=nhkk+1
7602  IF (nhkk.EQ.nmxhkk)THEN
7603  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
7604  RETURN
7605  ENDIF
7606  ihkk=nhkk
7607  isthkk(ihkk)=152
7608  idhkk(ihkk)=ihkkq(ijjq2(n))
7609  jmohkk(1,ihkk)=ihkkto
7610  jmohkk(2,ihkk)=ihkkto
7611  jdahkk(1,ihkk)=ihkk+1
7612  jdahkk(2,ihkk)=ihkk+1
7613  phkk(1,ihkk)=pjetb2(n,1)
7614  phkk(2,ihkk)=pjetb2(n,2)
7615  phkk(3,ihkk)=pjetb2(n,3)
7616  phkk(4,ihkk)=pjetb2(n,4)
7617  phkk(5,ihkk)=0.
7618 C Add position of parton in hadron
7619  CALL qinnuc(xxpp,yypp)
7620  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
7621  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
7622  vhkk(3,ihkk)=vhkk(3,ihkkto)
7623  vhkk(4,ihkk)=vhkk(4,ihkkto)
7624  IF (iphkk.GE.2) WRITE(6,5001)
7625  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
7626  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
7627  & (vhkk(khkk,ihkk),khkk=1,4)
7628 C
7629 C CHAIN 2 BEFORE FRAGMENTATION
7630  nhkk=nhkk+1
7631  IF (nhkk.EQ.nmxhkk)THEN
7632  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
7633  RETURN
7634  ENDIF
7635  ihkk=nhkk
7636  isthkk(ihkk)=7
7637  idhkk(ihkk)=88888
7638  jmohkk(1,ihkk)=ihkk-2
7639  jmohkk(2,ihkk)=ihkk-1
7640  phkk(1,ihkk)=phkk(1,ihkk-2)+phkk(1,ihkk-1)
7641  phkk(2,ihkk)=phkk(2,ihkk-2)+phkk(2,ihkk-1)
7642  phkk(3,ihkk)=phkk(3,ihkk-2)+phkk(3,ihkk-1)
7643  phkk(4,ihkk)=phkk(4,ihkk-2)+phkk(4,ihkk-1)
7644  phkk(5,ihkk)=amjch2(n)
7645 C POSITION OF CREATED CHAIN IN LAB
7646 C =POSITION OF TARGET NUCLEON
7647 C TIME OF CHAIN CREATION IN LAB
7648 C =TIME OF PASSAGE OF PROJECTILE
7649 C NUCLEUS AT POSITION OF TAR. NUCLEUS
7650  vhkk(1,nhkk)= vhkk(1,nhkk-1)
7651  vhkk(2,nhkk)= vhkk(2,nhkk-1)
7652  vhkk(3,nhkk)= vhkk(3,nhkk-1)
7653  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
7654  mhkkhh(n)=ihkk
7655  IF (iprojk.EQ.1)THEN
7656  whkk(1,nhkk)= vhkk(1,nhkk-2)
7657  whkk(2,nhkk)= vhkk(2,nhkk-2)
7658  whkk(3,nhkk)= vhkk(3,nhkk-2)
7659  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
7660  IF (iphkk.GE.2) THEN
7661  WRITE(6,'(A)')' KKEVHH:'
7662  WRITE(6,5001)
7663  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
7664  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
7665  & (whkk(khkk,ihkk),khkk=1,4)
7666  ENDIF
7667  ENDIF
7668  IF (iphkk.GE.2) THEN
7669  WRITE(6,'(A)')' KKEVHH:'
7670  WRITE(6,5001)
7671  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
7672  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
7673  & (vhkk(khkk,ihkk),khkk=1,4)
7674  ENDIF
7675 33446 CONTINUE
7676 C
7677 C NOW WE HAVE AN ACCEPTABLE HARD EVENT
7678 C AND PUT IT INTO THE HISTOGRAM
7679 C
7680  amchh1(n)=amjch1(n)
7681  amchh2(n)=amjch2(n)
7682  gachh1(n)=gamjh1(n)
7683  bgxhh1(n)=bgxjh1(n)
7684  bgyhh1(n)=bgyjh1(n)
7685  bgzhh1(n)=bgzjh1(n)
7686  gachh2(n)=gamjh2(n)
7687  bgxhh2(n)=bgxjh2(n)
7688  bgyhh2(n)=bgyjh2(n)
7689  bgzhh2(n)=bgzjh2(n)
7690  nnch1=0
7691  nnch2=0
7692  ijnch1=0
7693  ijnch2=0
7694  nchhh1(n)=nnch1
7695  nchhh2(n)=nnch2
7696  ijchh1(n)=ijnch1
7697  ijchh2(n)=ijnch2
7698  DO 1234 iii=1,4
7699  pqhha1(n,iii)=pjeta1(n,iii)
7700  pqhha2(n,iii)=pjeta2(n,iii)
7701  pqhhb1(n,iii)=pjetb1(n,iii)
7702  pqhhb2(n,iii)=pjetb2(n,iii)
7703  1234 CONTINUE
7704  IF (ipev.GE.6)WRITE(6,104)n,
7705  * amchh1(n),amchh2(n),gachh1(n),gachh2(n),
7706  * bgxhh1(n),bgyhh1(n),bgzhh1(n),
7707  * bgxhh2(n),bgyhh2(n),bgzhh2(n),
7708  * nchhh1(n),nchhh2(n),ijchh1(n),ijchh2(n)
7709  ENDIF
7710  101 CONTINUE
7711 C
7712  104 FORMAT(' HH - 104',
7713  * i10,4f12.7 /10x,6f12.6,4i5)
7714  211 FORMAT (' HH: AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJ ',5f12.5,i10/
7715  * ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
7716  * ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
7717  212 FORMAT (' HH: AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJ || ',5f12.5,i10/
7718  * ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
7719  * ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
7720  8001 FORMAT(' KKEVHH - IRHH13=',i5)
7721  8002 FORMAT( ' HH - 8002',5e12.4/4(4e12.4/),2e12.4/2i5/4e12.4)
7722  8003 FORMAT(' KKEVHH - IRHH11=',i5)
7723  8005 FORMAT(' KKEVHH - IRHH12=',i5)
7724  8006 FORMAT(' HH - 8006', 5i5/2(4e12.4/),2e12.4)
7725  RETURN
7726  END
7727 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7728 C
7729  SUBROUTINE kkevzz
7730  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7731  SAVE
7732 C
7733 C--------------- TREATMENT OF SUPPLEMENTARY SEA CHAIN SYSTEMS
7734 C
7735 *KEEP,NUCC.
7736  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
7737 *KEEP,RPTSHM.
7738  COMMON /rptshm/ rproj,rtarg,bimpac
7739  parameter(intmx=2488,intmd=252)
7740  COMMON /trafop/ gamp,bgamp,betp
7741  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248),
7742  * xpsq(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
7743  * ,xpsu(248),xtsu(248)
7744  * ,xpsut(248),xtsut(248)
7745 *KEEP,INTNEW.
7746  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
7747  +ixpv,ixps,ixtv,ixts, intvv1(248),
7748  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
7749  +intss1(intmx),intss2(intmx),
7750  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
7751  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
7752 
7753 C /INTNEW/
7754 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
7755 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
7756 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
7757 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
7758 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
7759 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
7760 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
7761 C FROM PROJECTILE/TARGET NUCLEI
7762 C-------------------
7763 C--------------------
7764  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx),
7765  * ifrovt(248),itovt(248),ifrost(intmx),
7766  * jsshs(intmx),jtshs(intmx),jhkknp(248),jhkknt(248),
7767  * jhkkpv(intmx),jhkkps(intmx),
7768  * jhkktv(intmx),jhkkts(intmx),
7769  * mhkkvv(intmx),mhkkss(intmx),
7770  & mhkkvs(intmx),mhkksv(intmx),
7771  & mhkkhh(intmx),
7772  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
7773 C-------------------
7774  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
7775  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
7776  * intlo(intmx),inloss(intmx)
7777 C-------------------
7778 *KEEP,DIQI.
7779  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
7780  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
7781  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
7782  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
7783 C--------------------
7784  COMMON /nucimp/ prmom(5,248),tamom(5,248),
7785  & prmfep,prmfen,tamfep,tamfen,
7786  & prefep,prefen,taefep,taefen,
7787  & prepot(210),taepot(210),prebin,taebin,fermod,etacou
7788 C--------------------
7789 C--------------------
7790  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
7791  * ipadis,ishmal,lpauli
7792  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
7793  * ipadis,ishmal,lpauli
7794 C-------------------
7795  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7796  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5,irss11,irss12,irss13,
7797  * irss14,
7798  * irsv11,irsv12,irsv13,irsv14,
7799  * irvs11,irvs12,irvs13,irvs14,
7800  * irvv11,irvv12,irvv13,irvv14
7801  COMMON /abrzz/ amczz1(intmx),amczz2(intmx),
7802  * gaczz1(intmx),gaczz2(intmx),
7803  * bgxzz1(intmx),bgyzz1(intmx),bgzzz1(intmx),
7804  * bgxzz2(intmx),bgyzz2(intmx),bgzzz2(intmx),
7805  * nchzz1(intmx),nchzz2(intmx),
7806  * ijczz1(intmx),ijczz2(intmx),
7807  * pqzza1(intmx,4),pqzza2(intmx,4),
7808  * pqzzb1(intmx,4),pqzzb2(intmx,4)
7809 C-------------------
7810  parameter(nmxhkk= 89998)
7811  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
7812  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
7813  & phkk(5,nmxhkk),
7814  & vhkk(4,nmxhkk),whkk(4,nmxhkk)
7815 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
7816 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
7817 C THE POSITIONS OF THE PROJECTILE NUCLEONS
7818 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
7819 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
7820 C COMPLETELY CONSISTENT. THE TIMES IN THE
7821 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
7822 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
7823  COMMON /projk/ iprojk
7824 C
7825 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
7826 C
7827 C NMXHKK: maximum numbers of entries (partons/particles) that can be
7828 C stored in the commonblock.
7829 C
7830 C NHKK: the actual number of entries stored in current event. These are
7831 C found in the first NHKK positions of the respective arrays below.
7832 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
7833 C entry.
7834 C
7835 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
7836 C = 0 : null entry.
7837 C = 1 : an existing entry, which has not decayed or fragmented.
7838 C This is the main class of entries which represents the
7839 C "final state" given by the generator.
7840 C = 2 : an entry which has decayed or fragmented and therefore
7841 C is not appearing in the final state, but is retained for
7842 C event history information.
7843 C = 3 : a documentation line, defined separately from the event
7844 C history. (incoming reacting
7845 C particles, etc.)
7846 C = 4 - 10 : undefined, but reserved for future standards.
7847 C = 11 - 20 : at the disposal of each model builder for constructs
7848 C specific to his program, but equivalent to a null line in the
7849 C context of any other program. One example is the cone defining
7850 C vector of HERWIG, another cluster or event axes of the JETSET
7851 C analysis routines.
7852 C = 21 - : at the disposal of users, in particular for event tracking
7853 C in the detector.
7854 C
7855 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
7856 C standard.
7857 C
7858 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
7859 C The value is 0 for initial entries.
7860 C
7861 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
7862 C one mother exist, in which case the value 0 is used. In cluster
7863 C fragmentation models, the two mothers would correspond to the q
7864 C and qbar which join to form a cluster. In string fragmentation,
7865 C the two mothers of a particle produced in the fragmentation would
7866 C be the two endpoints of the string (with the range in between
7867 C implied).
7868 C
7869 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
7870 C entry has not decayed, this is 0.
7871 C
7872 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
7873 C entry has not decayed, this is 0. It is assumed that the daughters
7874 C of a particle (or cluster or string) are stored sequentially, so
7875 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
7876 C daughters. Even in cases where only one daughter is defined (e.g.
7877 C K0 -> K0S) both values should be defined, to make for a uniform
7878 C approach in terms of loop constructions.
7879 C
7880 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
7881 C
7882 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
7883 C
7884 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
7885 C
7886 C PHKK(4,IHKK) : energy, in GeV.
7887 C
7888 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
7889 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
7890 C
7891 C VHKK(1,IHKK) : production vertex x position, in mm.
7892 C
7893 C VHKK(2,IHKK) : production vertex y position, in mm.
7894 C
7895 C VHKK(3,IHKK) : production vertex z position, in mm.
7896 C
7897 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
7898 C
7899 C-----------------------------------------------------------------------
7900  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
7901  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
7902  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
7903  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
7904  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
7905  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
7906  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
7907  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
7908  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
7909 *KEEP,ABRZD.
7910  COMMON /abrzd/ amczd1(intmd),amczd2(intmd),
7911  +gaczd1(intmd),gaczd2(intmd),
7912  +bgxzd1(intmd),bgyzd1(intmd),bgzzd1(intmd),
7913  +bgxzd2(intmd),bgyzd2(intmd),
7914  +bgzzd2(intmd), nchzd1(intmd),nchzd2(intmd),
7915  +ijczd1(intmd),ijczd2(intmd),
7916  +pqzda1(intmd,4),pqzda2(intmd,4), pqzdb1(intmd,4),
7917  +pqzdb2(intmd,4),
7918  +ipcq(intmd),itcq(intmd),itcq2(intmd),ipcaq(intmd),
7919  +itcaq(intmd),itcaq2(intmd)
7920  +,izdss(intmd)
7921 *KEEP,ABRDZ.
7922  COMMON /abrdz/ amcdz1(intmd),amcdz2(intmd),
7923  +gacdz1(intmd),gacdz2(intmd),
7924  +bgxdz1(intmd),bgydz1(intmd),bgzdz1(intmd),
7925  +bgxdz2(intmd),bgydz2(intmd),
7926  +bgzdz2(intmd), nchdz1(intmd),nchdz2(intmd),
7927  +ijcdz1(intmd),ijcdz2(intmd),
7928  +pqdza1(intmd,4),pqdza2(intmd,4), pqdzb1(intmd,4),
7929  +pqdzb2(intmd,4),
7930  +ipzq(intmd),ipzqq2(intmd),itzq(intmd),ipzaq(intmd),
7931  +izaqq2(intmd),itzaq(intmd)
7932  +,idzss(intmd)
7933 C-------------------
7934  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
7935  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
7936  common/intnez/ndz,nzd
7937 C----------------------------------------------------------------------
7938  dimension ihkkq(-6:6)
7939  DATA ihkkq/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
7940 C
7941 C----------------------------------------------------------------------
7942  DO 1001 n=1,nonust
7943  DO 1002 i=1,ndz
7944  IF(idzss(i).EQ.n.AND.nch1(n).EQ.99)THEN
7945  nchdz1(i)=99
7946  nchdz2(i)=99
7947  ENDIF
7948  IF(idzss(i).EQ.n.AND.jhkksx(n).NE.1)THEN
7949  nchdz1(i)=99
7950  nchdz2(i)=99
7951  ENDIF
7952  IF(ipev.EQ.2)THEN
7953  WRITE(6,'(A,6I10)')' kkevzz:n,i,ndz,nchdz1,jhkksx,idzss'
7954  * ,n,i,ndz,nchdz1(i),jhkksx(n),idzss(i)
7955  ENDIF
7956  1002 CONTINUE
7957  DO 1003 i=1,nzd
7958  IF(izdss(i).EQ.n.AND.nch1(n).EQ.99)THEN
7959  nchzd1(i)=99
7960  nchzd2(i)=99
7961  ENDIF
7962  IF(izdss(i).EQ.n.AND.jhkksx(n).NE.1)THEN
7963  nchzd1(i)=99
7964  nchzd2(i)=99
7965  ENDIF
7966  IF(ipev.EQ.2)THEN
7967  WRITE(6,'(A,6I10)')' kkevzz:n,i,nzd,nchzd1,jhkksx,izdss'
7968  * ,n,i,nzd,nchzd1(i),jhkksx(n),izdss(i)
7969  ENDIF
7970  1003 CONTINUE
7971  1001 CONTINUE
7972  DO 101 n=1,nonust
7973  IF(nch1(n).EQ.88)go to 101
7974  IF(nch2(n).EQ.88)go to 101
7975  IF (jhkksx(n).EQ.1)THEN
7976  ixvpr=jhkkpz(n)
7977  ixvta=jhkktz(n)
7978  ihkkpo=jhkkpv(ixvpr)
7979  ihkkto=jhkktv(ixvta)
7980 C
7981 C Cronin multiple scattering
7982 C IF(IT.GT.1.AND.N.GT.100)THEN
7983  IF(it.GT.1)THEN
7984  itnu=ihkkto
7985  rtix=(vhkk(1,itnu))*1.e12-bimpac*0.1
7986  rtiy=vhkk(2,itnu)*1.e12
7987  rtiz=vhkk(3,itnu)*1.e12
7988  rtir2=(rtix**2+rtiy**2+rtiz**2)
7989  IF(rtir2.GT.rtarg**2)THEN
7990  IF(ipev.GE.2)
7991  * WRITE(6,774)rtarg,rtix,rtiy,rtiz,bimpac,ihkkto,ixvta
7992  774 FORMAT(' KKEVZZ: RTARG,RTIX,RTIY,RTIZ,BIMPAC,IHKKTO,IXVTA'
7993  * ,5e12.4,2i10)
7994  go to 779
7995  ENDIF
7996  IF(nch1(n).EQ.0)THEN
7997  pvqpx=psofa1(n,1)
7998  pvqpy=psofa1(n,2)
7999  pvqpz=psofa1(n,3)
8000  pvqe =psofa1(n,4)
8001  IF(pvqe.LE.0.d0)THEN
8002  pvqen=sqrt(pvqpx**2+pvqpy**2+pvqpz**2)
8003  WRITE(6,776)pvqe,pvqen,n,nonust
8004  776 FORMAT(' KKEVZZ: PVQE,PVQEN,N,NONUST ',2e12.4,2i5)
8005  pvqe=pvqen
8006  ENDIF
8007  CALL cromsc(pvqpx,pvqpy,pvqpz,pvqe,rtix,rtiy,rtiz,
8008  * pvqnx,pvqny,pvqnz,pvqne,30)
8009  pvdqpx=psofa2(n,1)
8010  pvdqpy=psofa2(n,2)
8011  pvdqpz=psofa2(n,3)
8012  pvdqe =psofa2(n,4)
8013  IF(pvdqe.LE.0.d0)THEN
8014  pvdqen=sqrt(pvdqpx**2+pvdqpy**2+pvdqpz**2)
8015  WRITE(6,778)pvdqe,pvdqen,n,nonust
8016  778 FORMAT(' KKEVZZ: PVDQE,PVDQEN,N,NONUST ',2e12.4,2i5)
8017  pvdqe=pvdqen
8018  ENDIF
8019  CALL cromsc(pvdqpx,pvdqpy,pvdqpz,pvdqe,rtix,rtiy,rtiz,
8020  * pvdqnx,pvdqny,pvdqnz,pvdqne,31)
8021  amtes2=((pvqne+pvdqne)**2-(pvqnx+pvdqnx)**2
8022  * -(pvqny+pvdqny)**2-(pvqnz+pvdqnz)**2)
8023  IF(amtes2.GE.amcch1(n)**2.OR.amtes2.GE.25.d0)THEN
8024  psofa1(n,1)=pvqnx
8025  psofa1(n,2)=pvqny
8026  psofa1(n,3)=pvqnz
8027  psofa1(n,4)=pvqne
8028  psofa2(n,1)=pvdqnx
8029  psofa2(n,2)=pvdqny
8030  psofa2(n,3)=pvdqnz
8031  psofa2(n,4)=pvdqne
8032  ENDIF
8033 C MASSES OF SUBCHAINS
8034  xmcch1=sqrt((psofa1(n,4)+
8035  * psofa2(n,4))**2
8036  * -(psofa1(n,1)+
8037  * psofa2(n,1))**2
8038  * -(psofa1(n,2)+
8039  * psofa2(n,2))**2
8040  * -(psofa1(n,3)+
8041  * psofa2(n,3))**2)
8042  IF(xmcch1.GE.amcch1(n))THEN
8043  amcch1(n)=xmcch1
8044 C
8045  gamch1(n)=(psofa1(n,4)+
8046  * psofa2(n,4))/amcch1(n)
8047  bgxch1(n)=(psofa1(n,1)+
8048  * psofa2(n,1))/amcch1(n)
8049  bgych1(n)=(psofa1(n,2)+
8050  * psofa2(n,2))/amcch1(n)
8051  bgzch1(n)=(psofa1(n,3)+
8052  * psofa2(n,3))/amcch1(n)
8053  ENDIF
8054  ENDIF
8055  IF(nch2(n).EQ.0)THEN
8056  pvqtx=psofb1(n,1)
8057  pvqty=psofb1(n,2)
8058  pvqtz=psofb1(n,3)
8059  pvqte=psofb1(n,4)
8060  IF(pvqte.LE.0.d0)THEN
8061  pvqten=sqrt(pvqtx**2+pvqty**2+pvqtz**2)
8062  WRITE(6,786)pvqte,pvqten,n,nonust
8063  786 FORMAT(' KKEVZZ: PVQTE,PVQTEN,N,NONUST ',2e12.4,2i5)
8064  pvqte=pvqten
8065  ENDIF
8066  CALL cromsc(pvqtx,pvqty,pvqtz,pvqte,rtix,rtiy,rtiz,
8067  * pvqntx,pvqnty,pvqntz,pvqnte,32)
8068  pvdqtx=psofb2(n,1)
8069  pvdqty=psofb2(n,2)
8070  pvdqtz=psofb2(n,3)
8071  pvdqte=psofb2(n,4)
8072  IF(pvdqte.LE.0.d0)THEN
8073  pvdten=sqrt(pvdqtx**2+pvdqty**2+pvdqtz**2)
8074  WRITE(6,796)pvdqte,pvdten,n,nonust
8075  796 FORMAT(' KKEVZZ: PVQTE,PVQTEN,N,NONUST ',2e12.4,2i5)
8076  pvdqte=pvdten
8077  ENDIF
8078  CALL cromsc(pvdqtx,pvdqty,pvdqtz,pvdqte,rtix,rtiy,rtiz,
8079  * pvtqnx,pvtqny,pvtqnz,pvtqne,33)
8080  amtes2=((pvqnte+pvtqne)**2-(pvqntx+pvtqnx)**2
8081  * -(pvqnty+pvtqny)**2-(pvqntz+pvtqnz)**2)
8082  IF(amtes2.GE.amcch1(n)**2.OR.amtes2.GE.25.d0)THEN
8083  psofb1(n,1)=pvqntx
8084  psofb1(n,2)=pvqnty
8085  psofb1(n,3)=pvqntz
8086  psofb1(n,4)=pvqnte
8087  psofb2(n,1)=pvtqnx
8088  psofb2(n,2)=pvtqny
8089  psofb2(n,3)=pvtqnz
8090  psofb2(n,4)=pvtqne
8091  ENDIF
8092 C MASSES OF SUBCHAINS
8093  xmcch2=sqrt((psofb1(n,4)+
8094  * psofb2(n,4))**2
8095  * -(psofb1(n,1)+
8096  * psofb2(n,1))**2
8097  * -(psofb1(n,2)+
8098  * psofb2(n,2))**2
8099  * -(psofb1(n,3)+
8100  * psofb2(n,3))**2)
8101  IF(xmcch2.GE.amcch2(n))THEN
8102  amcch2(n)=xmcch2
8103 C
8104  gamch2(n)=(psofb1(n,4)+
8105  * psofb2(n,4))/amcch2(n)
8106  bgxch2(n)=(psofb1(n,1)+
8107  * psofb2(n,1))/amcch2(n)
8108  bgych2(n)=(psofb1(n,2)+
8109  * psofb2(n,2))/amcch2(n)
8110  bgzch2(n)=(psofb1(n,3)+
8111  * psofb2(n,3))/amcch2(n)
8112  ENDIF
8113  ENDIF
8114  ENDIF
8115  779 CONTINUE
8116 C
8117 C
8118 C PUT Z-Z CHAIN ENDS INTO /HKKEVT/
8119 C MOMENTA IN NN-CMS
8120 C POSITION OF ORIGINAL NUCLEONS
8121 c flags for Z-Z chain ends
8122 c projectile: isthkk=251
8123 c target: isthkk=252
8124 c h-h chains: isthkk=9
8125 C
8126  ixvpr=jhkkpz(n)
8127  ixvta=jhkktz(n)
8128  ihkkpo=jhkkpv(ixvpr)
8129  ihkkto=jhkktv(ixvta)
8130  IF (ipev.GT.3)WRITE(6,5002)ixvpr,ihkkpo
8131  5002 FORMAT (' IXVPR,IHKKPO ',5i5)
8132  IF (ipev.GT.3)WRITE(6,5003)ixvta,ihkkto
8133  5003 FORMAT (' IXVTA,IHKKTO ',5i5)
8134 C CHAIN 1 PROJECTILE SEA-QUARK
8135  nhkk=nhkk+1
8136  IF (nhkk.EQ.nmxhkk)THEN
8137  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
8138  RETURN
8139  ENDIF
8140  ihkk=nhkk
8141  isthkk(ihkk)=251
8142  idhkk(ihkk)=ihkkq(ijsq1(n))
8143  jmohkk(1,ihkk)=ihkkpo
8144  jmohkk(2,ihkk)=ihkkpo
8145  jdahkk(1,ihkk)=ihkk+2
8146  jdahkk(2,ihkk)=ihkk+2
8147  phkk(1,ihkk)=psofa1(n,1)
8148  phkk(2,ihkk)=psofa1(n,2)
8149  phkk(3,ihkk)=psofa1(n,3)
8150  phkk(4,ihkk)=psofa1(n,4)
8151  phkk(5,ihkk)=0.
8152 C Add position of parton in hadron
8153  CALL qinnuc(xxpp,yypp)
8154  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
8155  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
8156  vhkk(3,ihkk)=vhkk(3,ihkkpo)
8157  vhkk(4,ihkk)=vhkk(4,ihkkpo)
8158  IF (iphkk.GE.2) WRITE(6,5001)
8159  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
8160  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
8161  & (vhkk(khkk,ihkk),khkk=1,4)
8162  5001 FORMAT (i6,i4,5i6,9e10.2)
8163 C CHAIN 1 TARGET SEA-QUARK
8164  nhkk=nhkk+1
8165  IF (nhkk.EQ.nmxhkk)THEN
8166  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
8167  RETURN
8168  ENDIF
8169  ihkk=nhkk
8170  isthkk(ihkk)=252
8171  idhkk(ihkk)=ihkkq(ijsaq2(n))
8172  jmohkk(1,ihkk)=ihkkto
8173  jmohkk(2,ihkk)=ihkkto
8174  jdahkk(1,ihkk)=ihkk+1
8175  jdahkk(2,ihkk)=ihkk+1
8176  phkk(1,ihkk)=psofa2(n,1)
8177  phkk(2,ihkk)=psofa2(n,2)
8178  phkk(3,ihkk)=psofa2(n,3)
8179  phkk(4,ihkk)=psofa2(n,4)
8180  phkk(5,ihkk)=0.
8181 C Add position of parton in hadron
8182  CALL qinnuc(xxpp,yypp)
8183  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
8184  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
8185  vhkk(3,ihkk)=vhkk(3,ihkkto)
8186  vhkk(4,ihkk)=vhkk(4,ihkkto)
8187  IF (iphkk.GE.2) WRITE(6,5001)
8188  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
8189  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
8190  & (vhkk(khkk,ihkk),khkk=1,4)
8191 C
8192 C CHAIN 1 BEFORE FRAGMENTATION
8193  nhkk=nhkk+1
8194  IF (nhkk.EQ.nmxhkk)THEN
8195  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
8196  RETURN
8197  ENDIF
8198  ihkk=nhkk
8199  isthkk(ihkk)=9
8200  idhkk(ihkk)=88888+nch1(n)
8201  jmohkk(1,ihkk)=ihkk-2
8202  jmohkk(2,ihkk)=ihkk-1
8203  phkk(1,ihkk)=phkk(1,ihkk-2)+phkk(1,ihkk-1)
8204  phkk(2,ihkk)=phkk(2,ihkk-2)+phkk(2,ihkk-1)
8205  phkk(3,ihkk)=phkk(3,ihkk-2)+phkk(3,ihkk-1)
8206  phkk(4,ihkk)=phkk(4,ihkk-2)+phkk(4,ihkk-1)
8207  phkk(5,ihkk)=amcch1(n)
8208 C POSITION OF CREATED CHAIN IN LAB
8209 C =POSITION OF TARGET NUCLEON
8210 C TIME OF CHAIN CREATION IN LAB
8211 C =TIME OF PASSAGE OF PROJECTILE
8212 C NUCLEUS AT POSITION OF TAR. NUCLEUS
8213  vhkk(1,nhkk)= vhkk(1,nhkk-1)
8214  vhkk(2,nhkk)= vhkk(2,nhkk-1)
8215  vhkk(3,nhkk)= vhkk(3,nhkk-1)
8216  vhkk(4,nhkk)=0.
8217  mhkkhh(n)=ihkk
8218  IF (iprojk.EQ.1)THEN
8219  whkk(1,nhkk)= vhkk(1,nhkk-2)
8220  whkk(2,nhkk)= vhkk(2,nhkk-2)
8221  whkk(3,nhkk)= vhkk(3,nhkk-2)
8222  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
8223  IF (iphkk.GE.2) WRITE(6,5001)
8224  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
8225  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
8226  & (whkk(khkk,ihkk),khkk=1,4)
8227  ENDIF
8228  IF (iphkk.GE.2) WRITE(6,5001)
8229  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
8230  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
8231  & (vhkk(khkk,ihkk),khkk=1,4)
8232 C
8233 C
8234 C CHAIN 2 PROJECTILE SEA-QUARK
8235  nhkk=nhkk+1
8236  IF (nhkk.EQ.nmxhkk)THEN
8237  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
8238  RETURN
8239  ENDIF
8240  ihkk=nhkk
8241  isthkk(ihkk)=251
8242  idhkk(ihkk)=ihkkq(ijsaq1(n))
8243  jmohkk(1,ihkk)=ihkkpo
8244  jmohkk(2,ihkk)=ihkkpo
8245  jdahkk(1,ihkk)=ihkk+2
8246  jdahkk(2,ihkk)=ihkk+2
8247  phkk(1,ihkk)=psofb1(n,1)
8248  phkk(2,ihkk)=psofb1(n,2)
8249  phkk(3,ihkk)=psofb1(n,3)
8250  phkk(4,ihkk)=psofb1(n,4)
8251  phkk(5,ihkk)=0.
8252 C Add position of parton in hadron
8253  CALL qinnuc(xxpp,yypp)
8254  vhkk(1,ihkk)=vhkk(1,ihkkpo)+xxpp
8255  vhkk(2,ihkk)=vhkk(2,ihkkpo)+yypp
8256  vhkk(3,ihkk)=vhkk(3,ihkkpo)
8257  vhkk(4,ihkk)=vhkk(4,ihkkpo)
8258  IF (iphkk.GE.2) WRITE(6,5001)
8259  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
8260  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
8261  & (vhkk(khkk,ihkk),khkk=1,4)
8262 C CHAIN 2 TARGET SEA-QUARK
8263  nhkk=nhkk+1
8264  IF (nhkk.EQ.nmxhkk)THEN
8265  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
8266  RETURN
8267  ENDIF
8268  ihkk=nhkk
8269  isthkk(ihkk)=252
8270  idhkk(ihkk)=ihkkq(ijsq2(n))
8271  jmohkk(1,ihkk)=ihkkto
8272  jmohkk(2,ihkk)=ihkkto
8273  jdahkk(1,ihkk)=ihkk+1
8274  jdahkk(2,ihkk)=ihkk+1
8275  phkk(1,ihkk)=psofb2(n,1)
8276  phkk(2,ihkk)=psofb2(n,2)
8277  phkk(3,ihkk)=psofb2(n,3)
8278  phkk(4,ihkk)=psofb2(n,4)
8279  phkk(5,ihkk)=0.
8280 C Add position of parton in hadron
8281  CALL qinnuc(xxpp,yypp)
8282  vhkk(1,ihkk)=vhkk(1,ihkkto)+xxpp
8283  vhkk(2,ihkk)=vhkk(2,ihkkto)+yypp
8284  vhkk(3,ihkk)=vhkk(3,ihkkto)
8285  vhkk(4,ihkk)=vhkk(4,ihkkto)
8286  IF (iphkk.GE.2) WRITE(6,5001)
8287  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
8288  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
8289  & (vhkk(khkk,ihkk),khkk=1,4)
8290 C
8291 C CHAIN 2 BEFORE FRAGMENTATION
8292  nhkk=nhkk+1
8293  IF (nhkk.EQ.nmxhkk)THEN
8294  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
8295  RETURN
8296  ENDIF
8297  ihkk=nhkk
8298  isthkk(ihkk)=9
8299  idhkk(ihkk)=88888+nch2(n)
8300  jmohkk(1,ihkk)=ihkk-2
8301  jmohkk(2,ihkk)=ihkk-1
8302  phkk(1,ihkk)=phkk(1,ihkk-2)+phkk(1,ihkk-1)
8303  phkk(2,ihkk)=phkk(2,ihkk-2)+phkk(2,ihkk-1)
8304  phkk(3,ihkk)=phkk(3,ihkk-2)+phkk(3,ihkk-1)
8305  phkk(4,ihkk)=phkk(4,ihkk-2)+phkk(4,ihkk-1)
8306  phkk(5,ihkk)=amcch2(n)
8307 C POSITION OF CREATED CHAIN IN LAB
8308 C =POSITION OF TARGET NUCLEON
8309 C TIME OF CHAIN CREATION IN LAB
8310 C =TIME OF PASSAGE OF PROJECTILE
8311 C NUCLEUS AT POSITION OF TAR. NUCLEUS
8312  vhkk(1,nhkk)= vhkk(1,nhkk-1)
8313  vhkk(2,nhkk)= vhkk(2,nhkk-1)
8314  vhkk(3,nhkk)= vhkk(3,nhkk-1)
8315  vhkk(4,nhkk)=vhkk(3,nhkk)/betp-vhkk(3,nhkk-2)/bgamp
8316  mhkkhh(n)=ihkk
8317  IF (iprojk.EQ.1)THEN
8318  whkk(1,nhkk)= vhkk(1,nhkk-2)
8319  whkk(2,nhkk)= vhkk(2,nhkk-2)
8320  whkk(3,nhkk)= vhkk(3,nhkk-2)
8321  whkk(4,nhkk)=vhkk(4,nhkk)*gamp-vhkk(3,nhkk)*bgamp
8322  IF (iphkk.GE.2) WRITE(6,5001)
8323  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
8324  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
8325  & (whkk(khkk,ihkk),khkk=1,4)
8326  ENDIF
8327  IF (iphkk.GE.2) WRITE(6,5001)
8328  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),jmohkk(2,ihkk),
8329  & jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk(khkk,ihkk),khkk=1,5),
8330  & (vhkk(khkk,ihkk),khkk=1,4)
8331 C
8332 C NOW WE HAVE AN ACCEPTABLE HARD EVENT
8333 C AND PUT IT INTO THE HISTOGRAM
8334 C
8335  amczz1(n)=amcch1(n)
8336  amczz2(n)=amcch2(n)
8337  gaczz1(n)=gamch1(n)
8338  bgxzz1(n)=bgxch1(n)
8339  bgyzz1(n)=bgych1(n)
8340  bgzzz1(n)=bgzch1(n)
8341  gaczz2(n)=gamch2(n)
8342  bgxzz2(n)=bgxch2(n)
8343  bgyzz2(n)=bgych2(n)
8344  bgzzz2(n)=bgzch2(n)
8345  nchzz1(n)=nch1(n)
8346  nchzz2(n)=nch2(n)
8347  ijczz1(n)=ijch1(n)
8348  ijczz2(n)=ijch2(n)
8349  DO 1234 iii=1,4
8350  pqzza1(n,iii)=psofa1(n,iii)
8351  pqzza2(n,iii)=psofa2(n,iii)
8352  pqzzb1(n,iii)=psofb1(n,iii)
8353  pqzzb2(n,iii)=psofb2(n,iii)
8354  1234 CONTINUE
8355  IF (ipev.GE.6)WRITE(6,104)n,
8356  * amczz1(n),amczz2(n),gaczz1(n),gaczz2(n),
8357  * bgxzz1(n),bgyzz1(n),bgzzz1(n),
8358  * bgxzz2(n),bgyzz2(n),bgzzz2(n),
8359  * nchzz1(n),nchzz2(n),ijczz1(n),ijczz2(n)
8360  ENDIF
8361  101 CONTINUE
8362 C
8363  104 FORMAT(' ZZ - 104',
8364  * i10,4f12.7 /10x,6f12.6, 4i5 )
8365  211 FORMAT (' ZZ: AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJ ',5f12.5,i10/
8366  * ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
8367  * ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
8368  212 FORMAT (' ZZ: AMMM,GAMMM,BGGGX,BGGGY,BGGGZ,IREJ || ',5f12.5,i10/
8369  * ' AMCH1,PTXCH1,PTYCH1,PTZCH1,ECH1 ',5f12.5/
8370  * ' AMCH2,PTXCH2,PTYCH2,PTZCH2,ECH2 ',5f12.5)
8371  8001 FORMAT(' KKEVZZ - IRZZ13=',i5)
8372  8002 FORMAT( ' ZZ - 8002',5e12.4/4(4e12.4/),2e12.4/2i5/4e12.4)
8373  8003 FORMAT(' KKEVZZ - IRZZ11=',i5)
8374  8005 FORMAT(' KKEVZZ - IRZZ12=',i5)
8375  8006 FORMAT(' ZZ - 8006', 5i5/2(4e12.4/),2e12.4)
8376  RETURN
8377  END
8378 C------------------------------------------------------------------------
8379  SUBROUTINE corrco
8380 *
8381  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8382  SAVE
8383 *KEEP,HKKEVT.
8384 C INCLUDE (HKKEVT)
8385  parameter(nmxhkk= 89998)
8386 C PARAMETER (NMXHKK=25000)
8387  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
8388  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
8389  +(4,nmxhkk)
8390 C
8391 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
8392 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
8393 C THE POSITIONS OF THE PROJECTILE NUCLEONS
8394 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
8395 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
8396 C COMPLETELY CONSISTENT. THE TIMES IN THE
8397 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
8398 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
8399 C
8400 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
8401 C
8402 C NMXHKK: maximum numbers of entries (partons/particles) that can be
8403 C stored in the commonblock.
8404 C
8405 C NHKK: the actual number of entries stored in current event. These are
8406 C found in the first NHKK positions of the respective arrays below.
8407 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
8408 C entry.
8409 C
8410 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
8411 C = 0 : null entry.
8412 C = 1 : an existing entry, which has not decayed or fragmented.
8413 C This is the main class of entries which represents the
8414 C "final state" given by the generator.
8415 C = 2 : an entry which has decayed or fragmented and therefore
8416 C is not appearing in the final state, but is retained for
8417 C event history information.
8418 C = 3 : a documentation line, defined separately from the event
8419 C history. (incoming reacting
8420 C particles, etc.)
8421 C = 4 - 10 : undefined, but reserved for future standards.
8422 C = 11 - 20 : at the disposal of each model builder for constructs
8423 C specific to his program, but equivalent to a null line in the
8424 C context of any other program. One example is the cone defining
8425 C vector of HERWIG, another cluster or event axes of the JETSET
8426 C analysis routines.
8427 C = 21 - : at the disposal of users, in particular for event tracking
8428 C in the detector.
8429 C
8430 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
8431 C standard.
8432 C
8433 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
8434 C The value is 0 for initial entries.
8435 C
8436 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
8437 C one mother exist, in which case the value 0 is used. In cluster
8438 C fragmentation models, the two mothers would correspond to the q
8439 C and qbar which join to form a cluster. In string fragmentation,
8440 C the two mothers of a particle produced in the fragmentation would
8441 C be the two endpoints of the string (with the range in between
8442 C implied).
8443 C
8444 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
8445 C entry has not decayed, this is 0.
8446 C
8447 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
8448 C entry has not decayed, this is 0. It is assumed that the daughters
8449 C of a particle (or cluster or string) are stored sequentially, so
8450 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
8451 C daughters. Even in cases where only one daughter is defined (e.g.
8452 C K0 -> K0S) both values should be defined, to make for a uniform
8453 C approach in terms of loop constructions.
8454 C
8455 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
8456 C
8457 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
8458 C
8459 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
8460 C
8461 C PHKK(4,IHKK) : energy, in GeV.
8462 C
8463 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
8464 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
8465 C
8466 C VHKK(1,IHKK) : production vertex x position, in mm.
8467 C
8468 C VHKK(2,IHKK) : production vertex y position, in mm.
8469 C
8470 C VHKK(3,IHKK) : production vertex z position, in mm.
8471 C
8472 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
8473 C********************************************************************
8474 
8475  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
8476  + idbam(nmxhkk),idch(nmxhkk),npoint(10)
8477 
8478  DO 1 i=1,nhkk
8479  IF (idhkk(i).EQ.88888) THEN
8480  m1=i-2
8481  m2=i-1
8482  IF (jmohkk(2,m1).EQ.0) THEN
8483  jm1=jmohkk(1,m1)
8484  jmohkk(2,m1)=jmohkk(1,jm1)
8485  ENDIF
8486  IF (jmohkk(2,m2).EQ.0) THEN
8487  jm2=jmohkk(1,m2)
8488  jmohkk(2,m2)=jmohkk(1,jm2)
8489  ENDIF
8490  ENDIF
8491  1 CONTINUE
8492 
8493  DO 2 i=1,nhkk
8494  IF (idhkk(i).EQ.88888) THEN
8495  m1=i-2
8496  m2=i-1
8497  m2m1=jmohkk(2,m1)
8498  m2m2=jmohkk(2,m2)
8499  IF (jdahkk(1,m2m1).EQ.0) THEN
8500  jdahkk(1,m2m1)=m1
8501  ELSE
8502  IF (jdahkk(2,m2m1).EQ.0) THEN
8503  jdahkk(2,m2m1)=m1
8504  ENDIF
8505  ENDIF
8506  IF (jdahkk(1,m2m2).EQ.0) THEN
8507  jdahkk(1,m2m2)=m2
8508  ELSE
8509  IF (jdahkk(2,m2m2).EQ.0) THEN
8510  jdahkk(2,m2m2)=m2
8511  ENDIF
8512  ENDIF
8513  ENDIF
8514  mo1=jmohkk(1,m1)
8515  mo2=jmohkk(1,m2)
8516  IF(jdahkk(1,mo1).EQ.0)jdahkk(1,mo1)=m1
8517  IF(jdahkk(2,mo1).EQ.0)jdahkk(2,mo1)=m1
8518  IF(jdahkk(1,mo2).EQ.0)jdahkk(1,mo2)=m2
8519  IF(jdahkk(2,mo2).EQ.0)jdahkk(2,mo2)=m2
8520  2 CONTINUE
8521 
8522  DO 3 i=1,nhkk
8523  IF (isthkk(i).EQ.11) THEN
8524  IF ((jdahkk(1,i).EQ.0).AND.(jdahkk(2,i).EQ.0)) THEN
8525  isthkk(i)=13
8526  ENDIF
8527  ENDIF
8528  IF (isthkk(i).EQ.12) THEN
8529  IF ((jdahkk(1,i).EQ.0).AND.(jdahkk(2,i).EQ.0)) THEN
8530  isthkk(i)=14
8531  ENDIF
8532  ENDIF
8533  3 CONTINUE
8534 
8535  RETURN
8536  END
8537 
8538 C--------------------------------------------------------------
8539  SUBROUTINE kkevnu(NHKKH1,EPN,PPN,KKMAT,IREJ,ECM)
8540 *
8541  IMPLICIT DOUBLE PRECISION (a-h,o-z)
8542  SAVE
8543  common/intnez/ndz,nzd
8544 *KEEP,HKKEVT.
8545 c INCLUDE (HKKEVT)
8546  parameter(nmxhkk= 89998)
8547 c PARAMETER (NMXHKK=25000)
8548  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
8549  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
8550  +(4,nmxhkk)
8551 C
8552 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
8553 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
8554 C THE POSITIONS OF THE PROJECTILE NUCLEONS
8555 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
8556 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
8557 C COMPLETELY CONSISTENT. THE TIMES IN THE
8558 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
8559 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
8560 C
8561 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
8562 C
8563 C NMXHKK: maximum numbers of entries (partons/particles) that can be
8564 C stored in the commonblock.
8565 C
8566 C NHKK: the actual number of entries stored in current event. These are
8567 C found in the first NHKK positions of the respective arrays below.
8568 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
8569 C entry.
8570 C
8571 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
8572 C = 0 : null entry.
8573 C = 1 : an existing entry, which has not decayed or fragmented.
8574 C This is the main class of entries which represents the
8575 C "final state" given by the generator.
8576 C = 2 : an entry which has decayed or fragmented and therefore
8577 C is not appearing in the final state, but is retained for
8578 C event history information.
8579 C = 3 : a documentation line, defined separately from the event
8580 C history. (incoming reacting
8581 C particles, etc.)
8582 C = 4 - 10 : undefined, but reserved for future standards.
8583 C = 11 - 20 : at the disposal of each model builder for constructs
8584 C specific to his program, but equivalent to a null line in the
8585 C context of any other program. One example is the cone defining
8586 C vector of HERWIG, another cluster or event axes of the JETSET
8587 C analysis routines.
8588 C = 21 - : at the disposal of users, in particular for event tracking
8589 C in the detector.
8590 C
8591 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
8592 C standard.
8593 C
8594 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
8595 C The value is 0 for initial entries.
8596 C
8597 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
8598 C one mother exist, in which case the value 0 is used. In cluster
8599 C fragmentation models, the two mothers would correspond to the q
8600 C and qbar which join to form a cluster. In string fragmentation,
8601 C the two mothers of a particle produced in the fragmentation would
8602 C be the two endpoints of the string (with the range in between
8603 C implied).
8604 C
8605 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
8606 C entry has not decayed, this is 0.
8607 C
8608 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
8609 C entry has not decayed, this is 0. It is assumed that the daughters
8610 C of a particle (or cluster or string) are stored sequentially, so
8611 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
8612 C daughters. Even in cases where only one daughter is defined (e.g.
8613 C K0 -> K0S) both values should be defined, to make for a uniform
8614 C approach in terms of loop constructions.
8615 C
8616 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
8617 C
8618 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
8619 C
8620 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
8621 C
8622 C PHKK(4,IHKK) : energy, in GeV.
8623 C
8624 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
8625 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
8626 C
8627 C VHKK(1,IHKK) : production vertex x position, in mm.
8628 C
8629 C VHKK(2,IHKK) : production vertex y position, in mm.
8630 C
8631 C VHKK(3,IHKK) : production vertex z position, in mm.
8632 C
8633 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
8634 C********************************************************************
8635 *KEEP,INTMX.
8636  parameter(intmx=2488,intmd=252)
8637 *KEEP,DXQX.
8638 C INCLUDE (XQXQ)
8639 * NOTE: INTMX set via INCLUDE(INTMX)
8640  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
8641  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
8642  * ,xpsu(248),xtsu(248)
8643  * ,xpsut(248),xtsut(248)
8644 *KEEP,INTNEW.
8645  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
8646  +ixpv,ixps,ixtv,ixts, intvv1(248),
8647  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
8648  +intss1(intmx),intss2(intmx),
8649  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
8650  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
8651 
8652 C /INTNEW/
8653 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
8654 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
8655 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
8656 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
8657 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
8658 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
8659 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
8660 C FROM PROJECTILE/TARGET NUCLEI
8661 C-------------------
8662 *KEEP,IFROTO.
8663  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
8664  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
8665  +jhkknt
8666  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
8667  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
8668  & mhkkhh(intmx),
8669  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
8670 *KEEP,LOZUO.
8671  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
8672  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
8673  +intlo(intmx),inloss(intmx)
8674 C /LOZUO/
8675 C /
8676 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
8677 C REJECTED IN KKEVT
8678 C------------------
8679 *KEEP,DIQI.
8680  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
8681  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
8682  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
8683  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
8684 *KEEP,SHMAKL.
8685 C INCLUDE (SHMAKL)
8686 * NOTE: INTMX set via INCLUDE(INTMX)
8687  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
8688 *KEEP,NUCC.
8689  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
8690 *KEEP,RPTSHM.
8691  COMMON /rptshm/ rproj,rtarg,bimpac
8692 *KEEP,NSHMAK.
8693  COMMON /nshmak/ nnshma,npshma,ntshma,nshmac,nshma2
8694 *KEEP,ZENTRA.
8695  COMMON /zentra/ icentr
8696 *KEEP,NUCIMP.
8697  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
8698  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
8699  +prebin,taebin,fermod,etacou
8700 *KEEP,DROPPT.
8701  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
8702  +ishmal,lpauli
8703  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
8704  +ipadis,ishmal,lpauli
8705 *KEEP,NNCMS.
8706  COMMON /nncms/ gamcm,bgcm,umoj,pcmj,eprojj,pprojj
8707  COMMON /nuccms/ gacms,bgcms,galab,bglab,blab,umo,pcm,eproj,pproj
8708 *KEEP,NUCPOS.
8709  COMMON /nucpos/invvp(248),invvt(248),invsp(248),invst(248), nuvv,
8710  +nuvs,nusv,nuss,insvp(248),insvt(248),inssp(248),insst(248), isveap
8711  +(248),isveat(248),isseap(248),isseat(248), ivseap(248),ivseat
8712  +(248), islosp(248),islost(248),inoop(248),inoot(248),nuoo
8713 *KEEP,TAUFO.
8714  COMMON /taufo/ taufor,ktauge,itauve,incmod
8715  COMMON /evappp/ievap
8716  COMMON /neutyy/neutyp,neudec
8717 *KEEP,RTAR.
8718  COMMON /rtar/ rtarnu
8719 *KEEP,INNU.
8720  COMMON /innu/inudec
8721 *KEEP,HADTHR.
8722  COMMON /hadthr/ ehadth,inthad
8723 *KEEP,DINPDA.
8724  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
8725  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
8726 *KEEP,FERMI.
8727  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
8728  +(4,248)
8729 *KEEP,KETMAS.
8730  COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
8731 *KEEP,DPAR.
8732 C /DPAR/ CONTAINS PARTICLE PROPERTIES
8733 C ANAME = LITERAL NAME OF THE PARTICLE
8734 C AAM = PARTICLE MASS IN GEV
8735 C GA = DECAY WIDTH
8736 C TAU = LIFE TIME OF INSTABLE PARTICLES
8737 C IICH = ELECTRIC CHARGE OF THE PARTICLE
8738 C IIBAR = BARYON NUMBER
8739 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
8740 C
8741  CHARACTER*8 aname
8742  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
8743  +iibar(210),k1(210),k2(210)
8744 C------------------
8745 *KEEP,DPRIN.
8746  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
8747 *KEEP,NUCKOO.
8748  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
8749  +tpoo(3,intmx)
8750 *KEEP,REJEC.
8751  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
8752  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
8753  +irvs14, irvv11,irvv12,irvv13,irvv14
8754 *KEEP,PROJK.
8755  COMMON /projk/ iprojk
8756 *KEEP,TANUIN.
8757  COMMON /tanuin/ tasuma,tasubi,tabi,tamasu,tama,taimma
8758 *KEND.
8759  COMMON /diffra/ isingd,idiftp,ioudif,iflagd
8760 *
8761  LOGICAL lseadi
8762  COMMON /seadiq/ lseadi
8763  COMMON /evflag/numev
8764  COMMON /diquax/amedd,idiqua,idiquu
8765 C
8766 C-----------------------------------------------------------------------
8767 C PARAMETER (INTMX=2488)
8768  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
8769  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
8770  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
8771  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
8772  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
8773  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
8774  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
8775  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
8776  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
8777  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
8778  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
8779  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
8780  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
8781  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
8782  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
8783  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
8784  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
8785  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
8786  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
8787  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
8788  common/pyjets/nlu,npad,klu(4000,5),plu(4000,5),vlu(4000,5)
8789  common/pol/polarx(4),pmodul
8790  COMMON /neurej/ noneur
8791 C DIMENSION KKQ(1000,2),PPP(1000,5)
8792  DATA iniqel /0/
8793 C*******************************************************************"
8794 C
8795 C KINEMATICS
8796 C
8797 C********************************************************************
8798 C
8799  irej = 0
8800 *
8801  aam(26)=aam(23)
8802 C
8803  kproj=1
8804  IF(ijproj.NE.0) kproj=ijproj
8805  kproj=5
8806  ijproj=5
8807  ktarg=1
8808  atnuc=it
8809  itn=it-itz
8810  apnuc=ip
8811  ipn=ip-ipz
8812  amproj =aam(kproj)
8813  amtar =aam(ktarg)
8814 * nucleon-nucleon cms
8815 C IBPROJ=1
8816  eprojj=epn
8817  pprojj= sqrt((epn-amproj)*(epn+amproj))
8818 C PPROJJ= EPN
8819  umoj= sqrt(amproj**2 + amtar**2 + 2.*amtar*eprojj)
8820 C UMOJ= SQRT( AMTAR**2 + 2.*AMTAR*EPROJJ)
8821  gamcm = (eprojj+amtar)/umoj
8822  bgcm=pprojj/umoj
8823  ecm=umoj
8824  pcmj=gamcm*pprojj - bgcm*eprojj
8825 C
8826  IF(ipev.GE.1)WRITE(6, 1000)ip,ipz,it,itz,ijproj,ibproj,
8827  + eprojj,pprojj,
8828  +amproj,amtar,umo,gamcm,bgcm
8829  1000 FORMAT(' ENTRY KKEVNU'/ ' IP,IPZ,IT,ITZ,IJPROJ,IBPROJ',6i5/
8830  +' EPROJJ,PPROJJ,AMPROJ,AMTAR,UMO,GAMCM,BGCM'/10e12.3)
8831 
8832 C
8833 C**** CHANGE PARAMETERS FROM COMMON \INPDAT\
8834  as=0.5
8835  b8=0.4
8836 C CHAIN PT BIGGER THAN PARTICLE PT
8837  n9483=0
8838 * entry after rejection of an event because of kinematical reasons
8839 * several trials are made to realize a sampled Glauber event
8840  10 CONTINUE
8841  ndz=0
8842  nzd=0
8843  n9483=n9483+1
8844  IF (mod(n9483,200).EQ.0) THEN
8845  WRITE(6,'(A,I5,A,I5,A)') ' KKEVT: Glauber event',numev,
8846  + ' rejected after', n9483, ' trials'
8847  WRITE(6, 1010) nn,np,nt
8848  WRITE(6,1020) irco1,irco2,irco3,irco4,irco5, irss11,irss12,
8849  + irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,
8850  + irvs13,irvs14, irvv11,irvv12,irvv13,irvv14
8851  n9483=1
8852  go to 20
8853  ELSEIF(n9483.GT.1) THEN
8854  goto 30
8855  ENDIF
8856  1010 FORMAT (5x,' N9483 LOOP - NN, NP, NT',5i10)
8857  1020 FORMAT (5x,' N9483 LOOP - REJECTION COUNTERS ',/,5i8/2(8i8/))
8858 C
8859 C***************************************************************
8860 C
8861 C SAMPLE NUMBERS OF COLLISION A LA SHMAKOV---------------
8862 C
8863 C
8864 C This is done here for a h-A event to obtain
8865 C the positions of the nucleons of A
8866 C
8867 C
8868 C TOTAL NUMBER OF INTERACTIONS = NN
8869 C NUMBER OF INTERACTING NUCLEONS
8870 C FROM PROJECTILE = NP
8871 C FROM TARGET = NT
8872 C
8873  20 CONTINUE
8874  22 CONTINUE
8875  CALL shmako(ip,it,bimp,nn,np,nt,jssh,jtsh,pproj,kkmat)
8876  bimpac=bimp
8877  nshmac=nshmac+1
8878  nnshma=nn
8879  npshma=np
8880  ntshma=nt
8881 * entry for repeated trial to realize a sampled Glauber event
8882  30 CONTINUE
8883  IF (ipev.GE.2) THEN
8884  WRITE(6, 1040) ip,ipz,it,itz,eproj,pproj,nn,np,nt
8885  1040 FORMAT (' 752 FORM ',4i10,2f10.3,5i10)
8886  WRITE (6,'(/A,2I5,1PE10.2,3I5)') ' KKEVT: IP,IT,BIMP,NN,NP,NT ',
8887  + ip,it,bimp,nn,np,nt
8888  WRITE (6,'(/2A)')
8889  + ' KKEVT: JSSH(KKK),JTSH(KKK),INTER1(KKK),INTER2(KKK),',
8890  + ' PKOO(3,KKK),TKOO(3,KKK)'
8891  itum=max(it,ip)
8892  DO 40 kkk=1,itum
8893  WRITE (6,'(4I5,6(1PE11.3))') jssh(kkk),jtsh(kkk),inter1(kkk),
8894  + inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),pkoo(3,kkk), tkoo(1,kkk),
8895  + tkoo(2,kkk),tkoo(3,kkk)
8896 
8897  40 CONTINUE
8898  ENDIF
8899 C
8900 C-----------------------------------------------------------------------
8901 C STORE PROJECTILE HADRON/NUCLEONS INTO /HKKEVT/
8902 C - PROJECTILE CENTRE AT ORIGIN IN SPACE
8903 C - TARGET SHIFTED IN X DIRECTION BY
8904 C IMPACT PARAMETER 'BIMP'
8905 C
8906 C - SAMPLING OF NUCLEON TYPES
8907 C - CONSISTENCY CHECK
8908 C FOR SAMPLED P/N NUMBERS
8909 C - INTERACTING PROJECTILES ISTHKK=11
8910 C NONINTERACTING ... ISTHKK=13
8911 C - FERMI MOMENTA IN CORRESP. REST SYSTEM
8912 C-----------
8913  nhkk=0
8914  IF (nhkk.EQ.nmxhkk)THEN
8915  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
8916  RETURN
8917  ENDIF
8918 C
8919  ncpp=0
8920  ncpn=0
8921 C DEFINE FERMI MOMENTA/ENERGIES FOR PROJECTILE
8922 C
8923  pxfe=0.0
8924  pyfe=0.0
8925  pzfe=0.0
8926  DO 50 kkk=1,ip
8927  nhkk=nhkk+1
8928  IF (nhkk.EQ.nmxhkk)THEN
8929  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
8930  RETURN
8931  ENDIF
8932 C IF (JSSH(KKK).GT.0) THEN
8933  isthkk(nhkk)=11
8934 C ELSE
8935 C ISTHKK(NHKK)=13
8936 C ENDIF
8937 C*
8938  kproj=ijproj
8939  phkk(1,nhkk)=0.
8940  phkk(2,nhkk)=0.
8941  phkk(3,nhkk)=0.
8942  phkk(4,nhkk)=aam(kproj)
8943  phkk(5,nhkk)=aam(kproj)
8944 C
8945  kkproj(kkk)=kproj
8946  idhkk(nhkk)=mpdgha(kproj)
8947  jmohkk(1,nhkk)=0
8948  jmohkk(2,nhkk)=0
8949  jdahkk(1,nhkk)=0
8950  jdahkk(2,nhkk)=0
8951 C
8952  phkk(5,nhkk)=aam(kproj)
8953  vhkk(1,nhkk)=pkoo(1,kkk)*1.e-12
8954  vhkk(2,nhkk)=pkoo(2,kkk)*1.e-12
8955  vhkk(3,nhkk)=pkoo(3,kkk)*1.e-12
8956  vhkk(4,nhkk)=0.
8957  whkk(1,nhkk)=pkoo(1,kkk)*1.e-12
8958  whkk(2,nhkk)=pkoo(2,kkk)*1.e-12
8959  whkk(3,nhkk)=pkoo(3,kkk)*1.e-12
8960  whkk(4,nhkk)=0.
8961  jhkknp(kkk)=nhkk
8962 C
8963  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
8964  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
8965  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
8966 
8967  1050 FORMAT (i6,i4,5i6,9e10.2)
8968 C
8969  50 CONTINUE
8970 C
8971 C-----------------------------------------------------------------------
8972 C STORE TARGET HADRON/NUCLEONS INTO /HKKEVT/
8973 C - PROJECTILE CENTRE AT ORIGIN IN SPACE
8974 C - TARGET SHIFTED IN X DIRECTION BY
8975 C IMPACT PARAMETER 'BIMP'
8976 C
8977 C - SAMPLING OF NUCLEON TYPES
8978 C - CONSISTENCY CHECK
8979 C FOR SAMPLED P/N NUMBERS
8980 C - INTERACTING TARGETS ISTHKK=12
8981 C NONINTERACTING ... ISTHKK=14
8982 C-----------
8983 C---------------------
8984  nhadri=0
8985  nctp=0
8986  nctn=0
8987 C
8988  txfe=0.0
8989  tyfe=0.0
8990  tzfe=0.0
8991  DO 70 kkk=1,it
8992  nhkk=nhkk+1
8993  IF (nhkk.EQ.nmxhkk)THEN
8994  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
8995  RETURN
8996  ENDIF
8997 C IF (JTSH(KKK).GT.0) THEN
8998 C ISTHKK(NHKK)=12
8999 C NHADRI=NHADRI+1
9000 C IF (NHADRI.EQ.1) IHTAWW=NHKK
9001 C IF (EPN.LE.EHADTW) THEN
9002 C IF (NHADRI.GT.1) ISTHKK(NHKK)=14
9003 C ENDIF
9004 C ELSE
9005  isthkk(nhkk)=14
9006 C ENDIF
9007  IF(it.GE.2)THEN
9008  frtneu=float(itn)/atnuc
9009  samtes=rndm(v)
9010  IF(samtes.LT.frtneu.AND.nctn.LT.itn) THEN
9011  ktarg=8
9012  nctn=nctn + 1
9013  ELSEIF(samtes.GE.frtneu.AND.nctp.LT.itz) THEN
9014  ktarg=1
9015  nctp=nctp + 1
9016  ELSEIF(nctn.LT.itn) THEN
9017  ktarg=8
9018  nctn=nctn + 1
9019  ELSEIF(nctp.LT.itz) THEN
9020  ktarg=1
9021  nctp=nctp + 1
9022  ENDIF
9023 C
9024  IF(ktarg.EQ.1) THEN
9025  pferm = tamfep
9026  ELSE
9027  pferm = tamfen
9028  ENDIF
9029 C CALL FER4M(PFERM,FPX,FPY,FPZ,FE,KTARG)
9030  CALL fer4mt(it,pferm,fpx,fpy,fpz,fe,ktarg)
9031 CWRITE(6,*)' Fermi PFERM;FPX,FPY,FPZ,FE '
9032 C & ,PFERM,FPX,FPY,FPZ,FE
9033  txfe=txfe + fpx
9034  tyfe=tyfe + fpy
9035  tzfe=tzfe + fpz
9036  phkk(1,nhkk)=fpx
9037  phkk(2,nhkk)=fpy
9038  phkk(3,nhkk)=fpz
9039  phkk(4,nhkk)=fe
9040  phkk(5,nhkk)=aam(ktarg)
9041  ELSE
9042  phkk(1,nhkk)=0.
9043  phkk(2,nhkk)=0.
9044  phkk(3,nhkk)=0.
9045  phkk(4,nhkk)=aam(ktarg)
9046  phkk(5,nhkk)=aam(ktarg)
9047  ENDIF
9048 C
9049  kktarg(kkk)=ktarg
9050  idhkk(nhkk)=mpdgha(ktarg)
9051  jmohkk(1,nhkk)=0
9052  jmohkk(2,nhkk)=0
9053  jdahkk(1,nhkk)=0
9054  jdahkk(2,nhkk)=0
9055  vhkk(1,nhkk)=(tkoo(1,kkk)+bimp)*1.e-12
9056  vhkk(2,nhkk)=tkoo(2,kkk)*1.e-12
9057  vhkk(3,nhkk)=tkoo(3,kkk)*1.e-12
9058  vhkk(4,nhkk)=0.
9059  whkk(1,nhkk)=(tkoo(1,kkk)+bimp)*1.e-12
9060  whkk(2,nhkk)=tkoo(2,kkk)*1.e-12
9061  whkk(3,nhkk)=tkoo(3,kkk)*1.e-12
9062  whkk(4,nhkk)=0.
9063  jhkknt(kkk)=nhkk
9064 C
9065  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
9066  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
9067  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
9068 
9069 C
9070  70 CONTINUE
9071 C balance Sampled Fermi momenta
9072  IF(it.GE.2) THEN
9073  tasuma=itz*aam(1) + (it-itz)*aam(8)
9074  tasubi=0.0
9075  tamasu=0.0
9076  txfe=txfe/it
9077  tyfe=tyfe/it
9078  tzfe=tzfe/it
9079  DO 80 kkk=1,it
9080  ihkk=kkk + ip
9081  phkk(1,ihkk)=phkk(1,ihkk) - txfe
9082  phkk(2,ihkk)=phkk(2,ihkk) - tyfe
9083  phkk(3,ihkk)=phkk(3,ihkk) - tzfe
9084  phkk(4,ihkk)=sqrt(phkk(5,ihkk)** 2+ phkk(1,ihkk)** 2+ phkk
9085  + (2,ihkk)** 2+ phkk(3,ihkk)**2)
9086  itsec=mcihad(idhkk(ihkk))
9087  tasubi=tasubi + phkk(4,ihkk) - phkk(5,ihkk) - taepot(itsec)
9088  tamasu=tamasu + phkk(4,ihkk) - taepot(itsec)
9089  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
9090  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
9091  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
9092  80 CONTINUE
9093 C*** definition of initial state
9094  tabi=-ebind(it,itz)
9095  tama=(it-itz)*aam(8) + itz*aam(1) + tabi
9096  taimma=tama - tamasu
9097  ENDIF
9098 C
9099  IF(ipev.GT.2) THEN
9100  WRITE(6,'(/A/5X,A/5X,4(1PE11.3))') ' KKEVT: FERMI MOMENTA',
9101  + 'PRMFEP,PRMFEN, TAMFEP,TAMFEN', prmfep,prmfen, tamfep,tamfen
9102 
9103  ENDIF
9104 C-----------------------------------------------------------------------
9105  iflagd = 0
9106 C-----------------------------------------------------------------------
9107 C
9108  IF (ipev.GE.6) THEN
9109  itum=max0(ip,it,nn)
9110  WRITE(6,'(A,I10)')' KKEVT ITUM loop limit',itum
9111  WRITE(6,'(A,2A)') ' KKEVT (AFTER XKSAMP):',
9112  + ' JSSH, JSSHS, JTSH, JTSHS, INTER1, INTER2',
9113  + ' PKOO(1),PKOO(2),PKOO(3), TKOO(1),TKOO(2),TKOO(3)'
9114  DO 100 kkk=1,itum
9115  WRITE (6,'(6I5,6(1PE11.3))') jssh(kkk),jsshs(kkk),jtsh(kkk),
9116  + jtshs(kkk), inter1(kkk),inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),
9117  + pkoo(3,kkk), tkoo(1,kkk),tkoo(2,kkk),tkoo(3,kkk)
9118 
9119 
9120  100 CONTINUE
9121  ENDIF
9122 C-----------------------------------------------------------------------
9123 C TRANSFORM MOMENTA OF INTERACTING NUCLEONS
9124 C (INCLUDING FERMI MOMENTA FROM NUCLEUS REST FRAMES)
9125 C INTO NUCLEON-NUCLEON CMS (DEFINED WITHOUT FERMI MOM.
9126  IF(ipev.GE.2)WRITE(6,'(A)')' KKEVT before NUCMOM'
9127  DO 7745 ihkk=1,nhkk
9128  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
9129  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
9130  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
9131  7745 CONTINUE
9132  CALL nucmom
9133  IF(ipev.GE.2)THEN
9134 C DO IKI=1,200
9135  WRITE(6,'(A)')' KKEVNU after NUCMOM'
9136 C ENDDO
9137  ENDIF
9138  nonust=0
9139  nonujt=0
9140  nomje=0
9141  nomjer=0
9142 C
9143 C-----------------------------------------------------------------------
9144 C-----------------------------------------------------------------------
9145 C
9146  iniqel=iniqel+1
9147  IF(iniqel.EQ.1)CALL mass_ini
9148  IF(ipev.GE.2)THEN
9149 C DO IKI=1,200
9150  WRITE(6,'(A)')' KKEVNU after MASS_INI'
9151 C ENDDO
9152  ENDIF
9153  nhkkh1=nhkk
9154 C-----------------------------------------------------------
9155 C
9156 C-----------------------------------------------------------
9157 C
9158 C Select target nucleon
9159 C
9160 C NEUDEC < 9 qel_pol events
9161 C
9162 C. INPUT : LTYP = neutrino type (1,...,6)nue,anue,numu,anumu
9163 C nutau,anutau
9164 C for LTYP=1,3,5 Target is neutron
9165 C for LTYP=2,4,6 Target is proton
9166 C
9167 C-----------------------------------------------------------
9168 C
9169 C NEUDEC > 10 gen_delta events
9170 C
9171 C. INPUT : LTYP = neutrino type (1,...,6)nue,anue,numu,anumu
9172 C nutau,anutau
9173 C The target nucleus is choosen randomly p or n
9174 C
9175 C-----------------------------------------------------------
9176  IF(neudec.LE.9)THEN
9177  ltyp=neutyp
9178  IF(ltyp.EQ.1.OR.ltyp.EQ.3.OR.ltyp.EQ.5)nuctyp=2112
9179  IF(ltyp.EQ.2.OR.ltyp.EQ.4.OR.ltyp.EQ.6)nuctyp=2212
9180  ELSEIF(neudec.GE.10)THEN
9181  ltyp=neutyp
9182  nuctyp=2112
9183  rtyp=rndm(v)*it+1.
9184  aitz=itz
9185  IF(rtyp.LE.aitz)nuctyp=2212
9186  ENDIF
9187 C Neutrino energy is EPN in lab
9188  202 CONTINUE
9189  ikta=it*rndm(v)+2.
9190  IF(ipev.GE.2)THEN
9191  WRITE(6,*)' NEUTYP,NUCTYP,IKTA,IDHKK(IKTA)',
9192  * neutyp,nuctyp,ikta,idhkk(ikta)
9193  ENDIF
9194  IF(idhkk(ikta).NE.nuctyp) go to 202
9195  isthkk(ikta)=12
9196 C ENDIF
9197 C IF(KKQ(III,1).EQ.1)THEN
9198  IF(nuctyp.EQ.2112)nuctop=2
9199  IF(nuctyp.EQ.2212)nuctop=1
9200  plu21=phkk(1,ikta)
9201  plu22=phkk(2,ikta)
9202  plu23=phkk(3,ikta)
9203  plu24=phkk(4,ikta)
9204  plu25=phkk(5,ikta)
9205 C Call one qeldmo event
9206 C CALL GEN_QEL(EPN,LTYP,PLU21,PLU22,PLU23,PLU24,PLU25)
9207 C Call one qel-pol event
9208  IF(neudec.LT.9)THEN
9209  CALL qel_pol(epn,ltyp,plu21,plu22,plu23,plu24,plu25)
9210  ELSEIF(neudec.EQ.10)THEN
9211  jint=1
9212  IF(ipev.GE.2)THEN
9213  WRITE(6,*)' CALL GEN_DELTA',epn,ltyp,nuctop,jint,
9214  & plu21,plu22,plu23,plu24,plu25
9215  ENDIF
9216  CALL gen_delta(epn,ltyp,nuctop,jint,
9217  & plu21,plu22,plu23,plu24,plu25)
9218  ELSEIF(neudec.EQ.11)THEN
9219  jint=2
9220  CALL gen_delta(epn,ltyp,nuctop,jint,
9221  & plu21,plu22,plu23,plu24,plu25)
9222  ELSEIF(neudec.EQ.20)THEN
9223  CALL filenu(epnn,ltyp,nutyp,plu21,plu22,plu23,
9224  & nhad,iflag,lend )
9225  CALL rotate
9226  epn=epnn
9227 C
9228 C first initialize everything for energy EPN
9229 
9230  CALL ltini(5,epn,pppn,eeecm)
9231 C
9232 C
9233  kproj=1
9234  IF(ijproj.NE.0) kproj=ijproj
9235  kproj=5
9236  ijproj=5
9237  ktarg=1
9238  atnuc=it
9239  itn=it-itz
9240  apnuc=ip
9241  ipn=ip-ipz
9242  amproj =aam(kproj)
9243  amtar =aam(ktarg)
9244 * nucleon-nucleon cms
9245 C IBPROJ=1
9246  eprojj=epn
9247  pprojj= sqrt((epn-amproj)*(epn+amproj))
9248  ppn=pprojj
9249 C PPROJJ= EPN
9250  umoj= sqrt(amproj**2 + amtar**2 + 2.*amtar*eprojj)
9251 C UMOJ= SQRT( AMTAR**2 + 2.*AMTAR*EPROJJ)
9252  gamcm = (eprojj+amtar)/umoj
9253  bgcm=pprojj/umoj
9254  gacms=gamcm
9255  bgcms=bgcm
9256  umo=umoj
9257  eproj=eprojj
9258  pproj=pprojj
9259 C COMMON /NUCCMS/ GACMS,BGCMS,GALAB,BGLAB,BLAB,UMO,PCM,EPROJ,PPROJ
9260  ecm=umoj
9261  pcmj=gamcm*pprojj - bgcm*eprojj
9262  pcm=pcmj
9263 C
9264  IF(ipev.GE.1)WRITE(6,*)' EPN,PPROJJ,UMOJ,GAMCM,BGCM,PCMJ,ECM',
9265  &epn,pprojj,umoj,gamcm,bgcm,pcmj,ecm
9266 
9267 C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
9268 C
9269 C pick out interacting nucleon and give the
9270 C Fermi momentum PLU21,PLU22,PLU23 to it
9271  nuctyp=nutyp
9272  neutyp=ltyp
9273  702 CONTINUE
9274  ikta=it*rndm(v)+2.
9275  IF(ipev.GE.1)THEN
9276  WRITE(6,*)' NEUTYP,NUCTYP,IKTA,IDHKK(IKTA)',
9277  * neutyp,nuctyp,ikta,idhkk(ikta)
9278  ENDIF
9279  IF(idhkk(ikta).NE.nutyp) go to 702
9280  isthkk(ikta)=12
9281  phkk(1,ikta)=plu21
9282  phkk(2,ikta)=plu22
9283  phkk(3,ikta)=plu23
9284  phkk(4,ikta)=sqrt(phkk(5,ikta)**2+
9285  + phkk(1,ikta)**2+ phkk(2,ikta)**2+ phkk(3,ikta)**2)
9286 C Balance Fermi momenta
9287  txfe=0.0
9288  tyfe=0.0
9289  tzfe=0.0
9290  DO 704 kkk=1,it
9291  iii=kkk+1
9292  txfe=txfe+phkk(1,iii)
9293  tyfe=tyfe+phkk(2,iii)
9294  tzfe=tzfe+phkk(3,iii)
9295  704 CONTINUE
9296  txfe=txfe/(it-1)
9297  tyfe=tyfe/(it-1)
9298  tzfe=tzfe/(it-1)
9299  DO 705 kkk=1,it
9300  ihkk=kkk + 1
9301  IF(ihkk.NE.ikta)THEN
9302  phkk(1,ihkk)=phkk(1,ihkk) - txfe
9303  phkk(2,ihkk)=phkk(2,ihkk) - tyfe
9304  phkk(3,ihkk)=phkk(3,ihkk) - tzfe
9305  phkk(4,ihkk)=sqrt(phkk(5,ihkk)**2+
9306  + phkk(1,ihkk)**2+ phkk(2,ihkk)**2+ phkk(3,ihkk)**2)
9307  ENDIF
9308  705 CONTINUE
9309  ENDIF
9310  IF(iniqel.LE.20)THEN
9311 C DO IKI=1,40
9312  CALL pylist(1)
9313 C ENDDO
9314  ENDIF
9315 C
9316 C Write events to file qeld.evt
9317 C this is now done in dpmnuc6.f
9318 C
9319 C ADD particle to HKKEVT COMMON
9320  iiimax = 5
9321  IF(neudec.GE.10)iiimax=7
9322  IF(neudec.EQ.20)iiimax=nhad
9323  IF(klu(1,2).EQ.16.OR.klu(1,2).EQ.-16)THEN
9324  IF(neudec.EQ.1)THEN
9325  iiimax = 8
9326  ENDIF
9327  ENDIF
9328  DO 200 iii=4,iiimax
9329  IF(klu(iii,1).EQ.1)THEN
9330  nhkk=nhkk+1
9331  IF (nhkk.EQ.nmxhkk)THEN
9332  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
9333  RETURN
9334  ENDIF
9335  isthkk(nhkk)=klu(iii,1)
9336  idhkk(nhkk)=klu(iii,2)
9337  IF (isthkk(nhkk).EQ.15)isthkk(nhkk)=2
9338  IF (isthkk(nhkk).EQ.11)isthkk(nhkk)=2
9339  jmohkk(1,nhkk)=ikta
9340  jmohkk(2,nhkk)=0
9341  jdahkk(1,nhkk)=0
9342  jdahkk(2,nhkk)=0
9343  phkk(1,nhkk)=plu(iii,1)
9344  phkk(2,nhkk)=plu(iii,2)
9345  phkk(3,nhkk)=plu(iii,3)
9346  phkk(4,nhkk)=plu(iii,4)
9347 C WRITE(6,*)'PHKK',NHKK,(PHKK(IKLO,NHKK),IKLO=1,4)
9348  nrhkk=mcihad(idhkk(nhkk))
9349 C drop Pauli blocking test (is in dpmqelpo)
9350 C IF(NRHKK.EQ.1.OR.NRHKK.EQ.8)THEN
9351 C IF(NRHKK.EQ.1)THEN
9352 C IF(PHKK(4,NHKK).LE.TAEFEP+AAM(NRHKK))THEN
9353 C WRITE(6,*)' Pauli Blocking of p',PHKK(4,NHKK),TAEFEP
9354 C ENDIF
9355 C ENDIF
9356 C IF(NRHKK.EQ.8)THEN
9357 C IF(PHKK(4,NHKK).LE.TAEFEN+AAM(NRHKK))THEN
9358 C WRITE(6,*)' Pauli Blocking of n',PHKK(4,NHKK),TAEFEN
9359 C ENDIF
9360 C ENDIF
9361  IF(nrhkk.EQ.1.OR.nrhkk.EQ.8)THEN
9362  IF(phkk(4,nhkk)-aam(nrhkk).LE.taepot(nrhkk))THEN
9363  isthkk(nhkk)=16
9364  ENDIF
9365  ENDIF
9366 C ENDIF
9367 C PHKK(5,NHKK)=AAM(NRHKK)
9368  phkk(5,nhkk)=plu(iii,5)
9369  vhkk(1,nhkk)=vhkk(1,ikta)
9370  vhkk(2,nhkk)=vhkk(2,ikta)
9371  vhkk(3,nhkk)=vhkk(3,ikta)
9372  vhkk(4,nhkk)=vhkk(4,ikta)
9373  IF(iii.EQ.4)THEN
9374  whkk(1,nhkk)=polarx(1)
9375  whkk(2,nhkk)=polarx(2)
9376  whkk(3,nhkk)=polarx(3)
9377  whkk(4,nhkk)=polarx(4)
9378  ELSE
9379  whkk(1,nhkk)=whkk(1,ikta)
9380  whkk(2,nhkk)=whkk(2,ikta)
9381  whkk(3,nhkk)=whkk(3,ikta)
9382  whkk(4,nhkk)=whkk(4,ikta)
9383  ENDIF
9384 C ENDIF
9385  ENDIF
9386  200 CONTINUE
9387  201 CONTINUE
9388  CALL backrot
9389  IF(iniqel.LE.20)THEN
9390  CALL pylist(1)
9391  ENDIF
9392 C
9393 C Transform into cms
9394  DO 111 i=nhkkh1+1,nhkk
9395  pznn=phkk(3,i)
9396  enn=phkk(4,i)
9397  phkk(3,i)=gacms*pznn-bgcms*enn
9398  phkk(4,i)=gacms*enn-bgcms*pznn
9399 C WRITE(6,*)'PHKK',I,(PHKK(IKLO,I),IKLO=1,4)
9400  111 CONTINUE
9401 C-----------------------------------------------------------------------
9402 C
9403 C
9404 C-----------------------------------------------------------------------
9405 C-----------------------------------------------------------------------
9406 
9407  IF (ipev.GE.1) THEN
9408 C DO IKI=1,200
9409  WRITE(6,'(/A/)') ' KKEVT: FINAL LIST OF ENTRIES TO /HKKEVT/'
9410 C ENDDO
9411  DO 121 ihkk=1,nhkk
9412  WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
9413  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
9414  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
9415 
9416  121 CONTINUE
9417  ENDIF
9418 C
9419 C
9420  110 CONTINUE
9421 C
9422 C
9423 C
9424  RETURN
9425  END
9426  SUBROUTINE kkevdi(NHKKH1,EPN,PPN,KKMAT,IREJ)
9427 *
9428  IMPLICIT DOUBLE PRECISION (a-h,o-z)
9429  SAVE
9430  common/intnez/ndz,nzd
9431 *KEEP,HKKEVT.
9432 c INCLUDE (HKKEVT)
9433  parameter(nmxhkk= 89998)
9434 c PARAMETER (NMXHKK=25000)
9435  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
9436  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
9437  +(4,nmxhkk)
9438 C
9439 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
9440 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
9441 C THE POSITIONS OF THE PROJECTILE NUCLEONS
9442 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
9443 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
9444 C COMPLETELY CONSISTENT. THE TIMES IN THE
9445 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
9446 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
9447 C
9448 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
9449 C
9450 C NMXHKK: maximum numbers of entries (partons/particles) that can be
9451 C stored in the commonblock.
9452 C
9453 C NHKK: the actual number of entries stored in current event. These are
9454 C found in the first NHKK positions of the respective arrays below.
9455 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
9456 C entry.
9457 C
9458 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
9459 C = 0 : null entry.
9460 C = 1 : an existing entry, which has not decayed or fragmented.
9461 C This is the main class of entries which represents the
9462 C "final state" given by the generator.
9463 C = 2 : an entry which has decayed or fragmented and therefore
9464 C is not appearing in the final state, but is retained for
9465 C event history information.
9466 C = 3 : a documentation line, defined separately from the event
9467 C history. (incoming reacting
9468 C particles, etc.)
9469 C = 4 - 10 : undefined, but reserved for future standards.
9470 C = 11 - 20 : at the disposal of each model builder for constructs
9471 C specific to his program, but equivalent to a null line in the
9472 C context of any other program. One example is the cone defining
9473 C vector of HERWIG, another cluster or event axes of the JETSET
9474 C analysis routines.
9475 C = 21 - : at the disposal of users, in particular for event tracking
9476 C in the detector.
9477 C
9478 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
9479 C standard.
9480 C
9481 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
9482 C The value is 0 for initial entries.
9483 C
9484 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
9485 C one mother exist, in which case the value 0 is used. In cluster
9486 C fragmentation models, the two mothers would correspond to the q
9487 C and qbar which join to form a cluster. In string fragmentation,
9488 C the two mothers of a particle produced in the fragmentation would
9489 C be the two endpoints of the string (with the range in between
9490 C implied).
9491 C
9492 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
9493 C entry has not decayed, this is 0.
9494 C
9495 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
9496 C entry has not decayed, this is 0. It is assumed that the daughters
9497 C of a particle (or cluster or string) are stored sequentially, so
9498 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
9499 C daughters. Even in cases where only one daughter is defined (e.g.
9500 C K0 -> K0S) both values should be defined, to make for a uniform
9501 C approach in terms of loop constructions.
9502 C
9503 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
9504 C
9505 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
9506 C
9507 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
9508 C
9509 C PHKK(4,IHKK) : energy, in GeV.
9510 C
9511 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
9512 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
9513 C
9514 C VHKK(1,IHKK) : production vertex x position, in mm.
9515 C
9516 C VHKK(2,IHKK) : production vertex y position, in mm.
9517 C
9518 C VHKK(3,IHKK) : production vertex z position, in mm.
9519 C
9520 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
9521 C********************************************************************
9522 *KEEP,INTMX.
9523  parameter(intmx=2488,intmd=252)
9524 *KEEP,DXQX.
9525 C INCLUDE (XQXQ)
9526 * NOTE: INTMX set via INCLUDE(INTMX)
9527  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
9528  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
9529  * ,xpsu(248),xtsu(248)
9530  * ,xpsut(248),xtsut(248)
9531 *KEEP,INTNEW.
9532  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
9533  +ixpv,ixps,ixtv,ixts, intvv1(248),
9534  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
9535  +intss1(intmx),intss2(intmx),
9536  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
9537  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
9538 
9539 C /INTNEW/
9540 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
9541 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
9542 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
9543 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
9544 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
9545 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
9546 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
9547 C FROM PROJECTILE/TARGET NUCLEI
9548 C-------------------
9549 *KEEP,IFROTO.
9550  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
9551  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
9552  +jhkknt
9553  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
9554  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
9555  & mhkkhh(intmx),
9556  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
9557 *KEEP,LOZUO.
9558  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
9559  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
9560  +intlo(intmx),inloss(intmx)
9561 C /LOZUO/
9562 C /
9563 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
9564 C REJECTED IN KKEVT
9565 C------------------
9566 *KEEP,DIQI.
9567  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
9568  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
9569  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
9570  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
9571 *KEEP,SHMAKL.
9572 C INCLUDE (SHMAKL)
9573 * NOTE: INTMX set via INCLUDE(INTMX)
9574  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
9575 *KEEP,NUCC.
9576  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
9577 *KEEP,RPTSHM.
9578  COMMON /rptshm/ rproj,rtarg,bimpac
9579 *KEEP,NSHMAK.
9580  COMMON /nshmak/ nnshma,npshma,ntshma,nshmac,nshma2
9581 *KEEP,ZENTRA.
9582  COMMON /zentra/ icentr
9583 *KEEP,NUCIMP.
9584  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
9585  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
9586  +prebin,taebin,fermod,etacou
9587 *KEEP,DROPPT.
9588  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
9589  +ishmal,lpauli
9590  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
9591  +ipadis,ishmal,lpauli
9592 *KEEP,NNCMS.
9593  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
9594 *KEEP,NUCPOS.
9595  COMMON /nucpos/invvp(248),invvt(248),invsp(248),invst(248), nuvv,
9596  +nuvs,nusv,nuss,insvp(248),insvt(248),inssp(248),insst(248), isveap
9597  +(248),isveat(248),isseap(248),isseat(248), ivseap(248),ivseat
9598  +(248), islosp(248),islost(248),inoop(248),inoot(248),nuoo
9599 *KEEP,TAUFO.
9600  COMMON /taufo/ taufor,ktauge,itauve,incmod
9601  COMMON /evappp/ievap
9602 *KEEP,RTAR.
9603  COMMON /rtar/ rtarnu
9604 *KEEP,INNU.
9605  COMMON /innu/inudec
9606 *KEEP,HADTHR.
9607  COMMON /hadthr/ ehadth,inthad
9608 *KEEP,DINPDA.
9609  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
9610  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
9611 *KEEP,FERMI.
9612  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
9613  +(4,248)
9614 *KEEP,KETMAS.
9615  COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
9616 *KEEP,DPAR.
9617 C /DPAR/ CONTAINS PARTICLE PROPERTIES
9618 C ANAME = LITERAL NAME OF THE PARTICLE
9619 C AAM = PARTICLE MASS IN GEV
9620 C GA = DECAY WIDTH
9621 C TAU = LIFE TIME OF INSTABLE PARTICLES
9622 C IICH = ELECTRIC CHARGE OF THE PARTICLE
9623 C IIBAR = BARYON NUMBER
9624 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
9625 C
9626  CHARACTER*8 aname
9627  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
9628  +iibar(210),k1(210),k2(210)
9629 C------------------
9630 *KEEP,DPRIN.
9631  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
9632 *KEEP,NUCKOO.
9633  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
9634  +tpoo(3,intmx)
9635 *KEEP,REJEC.
9636  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
9637  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
9638  +irvs14, irvv11,irvv12,irvv13,irvv14
9639 *KEEP,PROJK.
9640  COMMON /projk/ iprojk
9641 *KEEP,TANUIN.
9642  COMMON /tanuin/ tasuma,tasubi,tabi,tamasu,tama,taimma
9643 *KEND.
9644  COMMON /diffra/ isingd,idiftp,ioudif,iflagd
9645 *
9646  LOGICAL lseadi
9647  CHARACTER*108 a109
9648  COMMON /seadiq/ lseadi
9649  COMMON /evflag/numev
9650  COMMON /diquax/amedd,idiqua,idiquu
9651 C
9652 C-----------------------------------------------------------------------
9653 C PARAMETER (INTMX=2488)
9654  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
9655  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
9656  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
9657  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
9658  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
9659  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
9660  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
9661  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
9662  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
9663  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
9664  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
9665  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
9666  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
9667  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
9668  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
9669  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
9670  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
9671  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
9672  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
9673  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
9674  COMMON /felire/amrecd,kjpro
9675  dimension pppp(4),rmax(5),nomax(5)
9676 C*******************************************************************"
9677 C
9678 C KINEMATICS
9679 C
9680 C********************************************************************
9681 C
9682  irej = 0
9683 *
9684  aam(26)=aam(23)
9685 C
9686  kproj=1
9687  IF(ijproj.NE.0) kproj=ijproj
9688  ktarg=1
9689  atnuc=it
9690  itn=it-itz
9691  apnuc=ip
9692  ipn=ip-ipz
9693  amproj =aam(kproj)
9694  amtar =aam(ktarg)
9695 * nucleon-nucleon cms
9696 C IBPROJ=1
9697  eproj=epn
9698  pproj = sqrt((epn-amproj)*(epn+amproj))
9699  umo = sqrt(amproj**2 + amtar**2 + 2.*amtar*eproj)
9700  gamcm = (eproj+amtar)/umo
9701  bgcm=pproj/umo
9702  ecm=umo
9703  pcm=gamcm*pproj - bgcm*eproj
9704 C
9705  IF(ipev.GE.1) print 1000,ip,ipz,it,itz,ijproj,ibproj, eproj,pproj,
9706  +amproj,amtar,umo,gamcm,bgcm
9707  1000 FORMAT(' ENTRY KKEVDI'/ ' IP,IPZ,IT,ITZ,IJPROJ,IBPROJ',6i5/
9708  +' EPROJ,PPROJ,AMPROJ,AMTAR,UMO,GAMCM,BGCM'/10e12.3)
9709 
9710 C
9711 C**** CHANGE PARAMETERS FROM COMMON \INPDAT\
9712  as=0.5
9713  b8=0.4
9714 C CHAIN PT BIGGER THAN PARTICLE PT
9715  n9483=0
9716 * entry after rejection of an event because of kinematical reasons
9717 * several trials are made to realize a sampled Glauber event
9718  10 CONTINUE
9719  ndz=0
9720  nzd=0
9721  n9483=n9483+1
9722  IF (mod(n9483,200).EQ.0) THEN
9723  WRITE(6,'(A,I5,A,I5,A)') ' KKEVT: Glauber event',numev,
9724  + ' rejected after', n9483, ' trials'
9725  WRITE(6, 1010) nn,np,nt
9726  WRITE(6,1020) irco1,irco2,irco3,irco4,irco5, irss11,irss12,
9727  + irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,
9728  + irvs13,irvs14, irvv11,irvv12,irvv13,irvv14
9729  n9483=1
9730  go to 20
9731  ELSEIF(n9483.GT.1) THEN
9732  goto 30
9733  ENDIF
9734  1010 FORMAT (5x,' N9483 LOOP - NN, NP, NT',5i10)
9735  1020 FORMAT (5x,' N9483 LOOP - REJECTION COUNTERS ',/,5i8/2(8i8/))
9736 C
9737 C***************************************************************
9738 C
9739 C SAMPLE NUMBERS OF COLLISION A LA SHMAKOV---------------
9740 C
9741 C
9742 C This is done here for a h-A event to obtain
9743 C the positions of the nucleons of A
9744 C
9745 C
9746 C TOTAL NUMBER OF INTERACTIONS = NN
9747 C NUMBER OF INTERACTING NUCLEONS
9748 C FROM PROJECTILE = NP
9749 C FROM TARGET = NT
9750 C
9751  20 CONTINUE
9752  22 CONTINUE
9753  CALL shmako(ip,it,bimp,nn,np,nt,jssh,jtsh,pproj,kkmat)
9754  bimpac=bimp
9755  nshmac=nshmac+1
9756  nnshma=nn
9757  npshma=np
9758  ntshma=nt
9759 * entry for repeated trial to realize a sampled Glauber event
9760  30 CONTINUE
9761  IF (ipev.GE.3) THEN
9762  WRITE(6, 1040) ip,ipz,it,itz,eproj,pproj,nn,np,nt
9763  1040 FORMAT (' 752 FORM ',4i10,2f10.3,5i10)
9764  WRITE (6,'(/A,2I5,1PE10.2,3I5)') ' KKEVT: IP,IT,BIMP,NN,NP,NT ',
9765  + ip,it,bimp,nn,np,nt
9766  WRITE (6,'(/2A)')
9767  + ' KKEVT: JSSH(KKK),JTSH(KKK),INTER1(KKK),INTER2(KKK),',
9768  + ' PKOO(3,KKK),TKOO(3,KKK)'
9769  itum=max(it,ip)
9770  DO 40 kkk=1,itum
9771  WRITE (6,'(4I5,6(1PE11.3))') jssh(kkk),jtsh(kkk),inter1(kkk),
9772  + inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),pkoo(3,kkk), tkoo(1,kkk),
9773  + tkoo(2,kkk),tkoo(3,kkk)
9774 
9775  40 CONTINUE
9776  ENDIF
9777 C
9778 C-----------------------------------------------------------------------
9779 C STORE PROJECTILE HADRON/NUCLEONS INTO /HKKEVT/
9780 C - PROJECTILE CENTRE AT ORIGIN IN SPACE
9781 C - TARGET SHIFTED IN X DIRECTION BY
9782 C IMPACT PARAMETER 'BIMP'
9783 C
9784 C - SAMPLING OF NUCLEON TYPES
9785 C - CONSISTENCY CHECK
9786 C FOR SAMPLED P/N NUMBERS
9787 C - INTERACTING PROJECTILES ISTHKK=11
9788 C NONINTERACTING ... ISTHKK=13
9789 C - FERMI MOMENTA IN CORRESP. REST SYSTEM
9790 C-----------
9791  nhkk=0
9792 C
9793  ncpp=0
9794  ncpn=0
9795 C DEFINE FERMI MOMENTA/ENERGIES FOR PROJECTILE
9796 C
9797  pxfe=0.0
9798  pyfe=0.0
9799  pzfe=0.0
9800  DO 50 kkk=1,ip
9801  nhkk=nhkk+1
9802  IF (nhkk.EQ.nmxhkk)THEN
9803  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
9804  RETURN
9805  ENDIF
9806 C IF (JSSH(KKK).GT.0) THEN
9807  isthkk(nhkk)=11
9808 C ELSE
9809 C ISTHKK(NHKK)=13
9810 C ENDIF
9811 C*
9812  kproj=ijproj
9813  phkk(1,nhkk)=0.
9814  phkk(2,nhkk)=0.
9815  phkk(3,nhkk)=0.
9816  phkk(4,nhkk)=aam(kproj)
9817  phkk(5,nhkk)=aam(kproj)
9818 C
9819  kkproj(kkk)=kproj
9820  idhkk(nhkk)=mpdgha(kproj)
9821  jmohkk(1,nhkk)=0
9822  jmohkk(2,nhkk)=0
9823  jdahkk(1,nhkk)=0
9824  jdahkk(2,nhkk)=0
9825 C
9826  phkk(5,nhkk)=aam(kproj)
9827  vhkk(1,nhkk)=pkoo(1,kkk)*1.e-12
9828  vhkk(2,nhkk)=pkoo(2,kkk)*1.e-12
9829  vhkk(3,nhkk)=pkoo(3,kkk)*1.e-12
9830  vhkk(4,nhkk)=0.
9831  whkk(1,nhkk)=pkoo(1,kkk)*1.e-12
9832  whkk(2,nhkk)=pkoo(2,kkk)*1.e-12
9833  whkk(3,nhkk)=pkoo(3,kkk)*1.e-12
9834  whkk(4,nhkk)=0.
9835  jhkknp(kkk)=nhkk
9836 C
9837  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
9838  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
9839  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
9840 
9841  1050 FORMAT (i6,i4,5i6,9e10.2)
9842 C
9843  50 CONTINUE
9844 C
9845 C-----------------------------------------------------------------------
9846 C STORE TARGET HADRON/NUCLEONS INTO /HKKEVT/
9847 C - PROJECTILE CENTRE AT ORIGIN IN SPACE
9848 C - TARGET SHIFTED IN X DIRECTION BY
9849 C IMPACT PARAMETER 'BIMP'
9850 C
9851 C - SAMPLING OF NUCLEON TYPES
9852 C - CONSISTENCY CHECK
9853 C FOR SAMPLED P/N NUMBERS
9854 C - INTERACTING TARGETS ISTHKK=12
9855 C NONINTERACTING ... ISTHKK=14
9856 C-----------
9857 C---------------------
9858  nhadri=0
9859  nctp=0
9860  nctn=0
9861 C
9862  txfe=0.0
9863  tyfe=0.0
9864  tzfe=0.0
9865  DO 70 kkk=1,it
9866  nhkk=nhkk+1
9867  IF (nhkk.EQ.nmxhkk)THEN
9868  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
9869  RETURN
9870  ENDIF
9871 C IF (JTSH(KKK).GT.0) THEN
9872 C ISTHKK(NHKK)=12
9873 C NHADRI=NHADRI+1
9874 C IF (NHADRI.EQ.1) IHTAWW=NHKK
9875 C IF (EPN.LE.EHADTW) THEN
9876 C IF (NHADRI.GT.1) ISTHKK(NHKK)=14
9877 C ENDIF
9878 C ELSE
9879  isthkk(nhkk)=14
9880 C ENDIF
9881  IF(it.GE.2)THEN
9882  frtneu=float(itn)/atnuc
9883  samtes=rndm(v)
9884  IF(samtes.LT.frtneu.AND.nctn.LT.itn) THEN
9885  ktarg=8
9886  nctn=nctn + 1
9887  ELSEIF(samtes.GE.frtneu.AND.nctp.LT.itz) THEN
9888  ktarg=1
9889  nctp=nctp + 1
9890  ELSEIF(nctn.LT.itn) THEN
9891  ktarg=8
9892  nctn=nctn + 1
9893  ELSEIF(nctp.LT.itz) THEN
9894  ktarg=1
9895  nctp=nctp + 1
9896  ENDIF
9897 C
9898  IF(ktarg.EQ.1) THEN
9899  pferm = tamfep
9900  ELSE
9901  pferm = tamfen
9902  ENDIF
9903 C CALL FER4M(PFERM,FPX,FPY,FPZ,FE,KTARG)
9904  CALL fer4mt(it,pferm,fpx,fpy,fpz,fe,ktarg)
9905  txfe=txfe + fpx
9906  tyfe=tyfe + fpy
9907  tzfe=tzfe + fpz
9908  phkk(1,nhkk)=fpx
9909  phkk(2,nhkk)=fpy
9910  phkk(3,nhkk)=fpz
9911  phkk(4,nhkk)=fe
9912  phkk(5,nhkk)=aam(ktarg)
9913  ELSE
9914  phkk(1,nhkk)=0.
9915  phkk(2,nhkk)=0.
9916  phkk(3,nhkk)=0.
9917  phkk(4,nhkk)=aam(ktarg)
9918  phkk(5,nhkk)=aam(ktarg)
9919  ENDIF
9920 C
9921  kktarg(kkk)=ktarg
9922  idhkk(nhkk)=mpdgha(ktarg)
9923  jmohkk(1,nhkk)=0
9924  jmohkk(2,nhkk)=0
9925  jdahkk(1,nhkk)=0
9926  jdahkk(2,nhkk)=0
9927  vhkk(1,nhkk)=(tkoo(1,kkk))*1.e-12
9928  vhkk(2,nhkk)=tkoo(2,kkk)*1.e-12
9929  vhkk(3,nhkk)=tkoo(3,kkk)*1.e-12
9930  vhkk(4,nhkk)=0.
9931  whkk(1,nhkk)=(tkoo(1,kkk)+bimp)*1.e-12
9932  whkk(2,nhkk)=tkoo(2,kkk)*1.e-12
9933  whkk(3,nhkk)=tkoo(3,kkk)*1.e-12
9934  whkk(4,nhkk)=0.
9935  jhkknt(kkk)=nhkk
9936 C
9937  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
9938  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
9939  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
9940 
9941 C
9942  70 CONTINUE
9943 C balance Sampled Fermi momenta
9944  IF(it.GE.2) THEN
9945  tasuma=itz*aam(1) + (it-itz)*aam(8)
9946  tasubi=0.0
9947  tamasu=0.0
9948  txfe=txfe/it
9949  tyfe=tyfe/it
9950  tzfe=tzfe/it
9951  DO 80 kkk=1,it
9952  ihkk=kkk + ip
9953  phkk(1,ihkk)=phkk(1,ihkk) - txfe
9954  phkk(2,ihkk)=phkk(2,ihkk) - tyfe
9955  phkk(3,ihkk)=phkk(3,ihkk) - tzfe
9956  phkk(4,ihkk)=sqrt(phkk(5,ihkk)** 2+ phkk(1,ihkk)** 2+ phkk
9957  + (2,ihkk)** 2+ phkk(3,ihkk)**2)
9958  itsec=mcihad(idhkk(ihkk))
9959  tasubi=tasubi + phkk(4,ihkk) - phkk(5,ihkk) - taepot(itsec)
9960  tamasu=tamasu + phkk(4,ihkk) - taepot(itsec)
9961  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
9962  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
9963  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
9964  80 CONTINUE
9965 C*** definition of initial state
9966  tabi=-ebind(it,itz)
9967  tama=(it-itz)*aam(8) + itz*aam(1) + tabi
9968  taimma=tama - tamasu
9969  ENDIF
9970 C
9971  IF(ipev.GT.3) THEN
9972  WRITE(6,'(/A/5X,A/5X,4(1PE11.3))') ' KKEVT: FERMI MOMENTA',
9973  + 'PRMFEP,PRMFEN, TAMFEP,TAMFEN', prmfep,prmfen, tamfep,tamfen
9974 
9975  ENDIF
9976 C-----------------------------------------------------------------------
9977  iflagd = 0
9978 C-----------------------------------------------------------------------
9979 C
9980  IF (ipev.GE.6) THEN
9981  itum=max0(ip,it,nn)
9982  WRITE(6,'(A,I10)')' KKEVT ITUM loop limit',itum
9983  WRITE(6,'(A,2A)') ' KKEVT (AFTER XKSAMP):',
9984  + ' JSSH, JSSHS, JTSH, JTSHS, INTER1, INTER2',
9985  + ' PKOO(1),PKOO(2),PKOO(3), TKOO(1),TKOO(2),TKOO(3)'
9986  DO 100 kkk=1,itum
9987  WRITE (6,'(6I5,6(1PE11.3))') jssh(kkk),jsshs(kkk),jtsh(kkk),
9988  + jtshs(kkk), inter1(kkk),inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),
9989  + pkoo(3,kkk), tkoo(1,kkk),tkoo(2,kkk),tkoo(3,kkk)
9990 
9991 
9992  100 CONTINUE
9993  ENDIF
9994 C-----------------------------------------------------------------------
9995 C TRANSFORM MOMENTA OF INTERACTING NUCLEONS
9996 C (INCLUDING FERMI MOMENTA FROM NUCLEUS REST FRAMES)
9997 C INTO NUCLEON-NUCLEON CMS (DEFINED WITHOUT FERMI MOM.
9998  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT before NUCMOM'
9999  DO 7745 ihkk=1,nhkk
10000  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
10001  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
10002  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
10003  7745 CONTINUE
10004  CALL nucmom
10005  IF(ipev.GE.6)WRITE(6,'(A)')' KKEVT after NUCMOM'
10006  nonust=0
10007  nonujt=0
10008  nomje=0
10009  nomjer=0
10010 C
10011 C-----------------------------------------------------------------------
10012 C-----------------------------------------------------------------------
10013 C
10014  nhkkh1=nhkk
10015 C-----------------------------------------------------------------------
10016 C
10017 C Read momentum shifts for nucleons from file
10018 C diffnuc.evt
10019 C
10020 C KFORM=1 J.R.file diffnuc.evt
10021 C KFORM=2 R.E.file diffnuc.evt
10022 C----------------------------------------------------------------------
10023  kform=2
10024  214 CONTINUE
10025  IF(kform.EQ.1)THEN
10026  READ(29,'(I5,4E15.6)')ndiffn,pppp(1),pppp(2),pppp(3),pppp(4)
10027  ELSEIF(kform.EQ.2)THEN
10028  READ(29,'(1X,I5,E12.4)')kjpro,amrecd
10029  WRITE(6,'(1X,I5,E12.4)')kjpro,amrecd
10030  READ(29,'(1X,I5)')imist
10031 C WRITE(6,'(1X,I5)')IMIST
10032  READ(29,'(1X,I5)')imist
10033 C WRITE(6,'(1X,I5)')IMIST
10034  READ(29,'(1X,I5,4E18.10)')imist,pppp(1),pppp(2),pppp(3),pppp(4)
10035  WRITE(6,'(1X,I5,4E18.10)')imist,pppp(1),pppp(2),pppp(3),pppp(4)
10036 C The following READ were fine for CD
10037 C READ(29,'(1X,I5)')IMIST
10038 C WRITE(6,'(1X,I5)')IMIST
10039 C READ(29,'(1X,I5)')IMIST
10040 C WRITE(6,'(1X,I5)')IMIST
10041 C READ(29,'(1X,I5)')IMIST
10042 C WRITE(6,'(1X,I5)')IMIST
10043  ENDIF
10044 C-----------------------------------------------------------------------
10045 C
10046 C determine one of the target nucleons as involved
10047 C in the diffractive scattering
10048 C
10049 C-----------------------------------------------------------------------
10050  rmax(1)=0.
10051  rmax(2)=0.
10052  rmax(3)=0.
10053  rmax(4)=0.
10054  rmax(5)=0.
10055  nomax(1)=0
10056  nomax(2)=0
10057  nomax(3)=0
10058  nomax(4)=0
10059  nomax(5)=0
10060  DO 211 i=2,nhkk
10061  rrrn=sqrt(vhkk(1,i)**2+vhkk(2,i)**2)
10062  IF(rmax(1).LT.rrrn)THEN
10063  rmax(1)=rrrn
10064  nomax(1)=i
10065  ENDIF
10066  211 CONTINUE
10067  DO 212 i=2,nhkk
10068  IF(i.EQ.nomax(1))go to 212
10069  rrrn=sqrt(vhkk(1,i)**2+vhkk(2,i)**2)
10070  IF(rmax(2).LT.rrrn)THEN
10071  rmax(2)=rrrn
10072  nomax(2)=i
10073  ENDIF
10074  212 CONTINUE
10075  DO 213 i=2,nhkk
10076  IF(i.EQ.nomax(1))go to 213
10077  IF(i.EQ.nomax(2))go to 213
10078  rrrn=sqrt(vhkk(1,i)**2+vhkk(2,i)**2)
10079  IF(rmax(3).LT.rrrn)THEN
10080  rmax(3)=rrrn
10081  nomax(3)=i
10082  ENDIF
10083  213 CONTINUE
10084 C-----------------------------------------------------------------------
10085 C
10086 C have interaction with nucleon nomax(3)
10087 C
10088 C READ(29,'(I5,4E15.6)')NDIFFN,PPPP(1),PPPP(2),PPPP(3),PPPP(4)
10089 C-----------------------------------------------------------------------
10090 C
10091  nwepau=0
10092  215 CONTINUE
10093  IF(nwepau.EQ.0)iint=nomax(3)
10094  IF(nwepau.EQ.1)iint=nomax(2)
10095  IF(nwepau.EQ.2)iint=nomax(1)
10096  nhkk=nhkk+1
10097  IF (nhkk.EQ.nmxhkk)THEN
10098  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
10099  RETURN
10100  ENDIF
10101  isthkk(nhkk)=1
10102  idhkk(nhkk)=idhkk(iint)
10103  jmohkk(1,nhkk)=iint
10104  jmohkk(2,nhkk)=0
10105  jdahkk(1,nhkk)=0
10106  jdahkk(2,nhkk)=0
10107  nrhkk=mcihad(idhkk(nhkk))
10108  phkk(1,nhkk)=phkk(1,iint)+pppp(1)
10109  phkk(2,nhkk)=phkk(2,iint)+pppp(2)
10110  phkk(3,nhkk)=phkk(3,iint)+pppp(3)
10111  phkk(4,nhkk)=sqrt(phkk(1,nhkk)**2+phkk(2,nhkk)**2+
10112  * phkk(3,nhkk)**2+aam(nrhkk)**2)
10113  phkk(5,nhkk)=aam(nrhkk)
10114  IF(nrhkk.EQ.-1.OR.nrhkk.EQ.-8)THEN
10115  IF(nrhkk.EQ.1)THEN
10116  IF(phkk(4,nhkk).LE.taefep+aam(nrhkk))THEN
10117  WRITE(6,*)' Pauli Blocking of p',nwepau,phkk(4,nhkk),taefep
10118  nwepau=nwepau+1
10119  nhkk=nhkk-1
10120  IF (nhkk.EQ.nmxhkk)THEN
10121  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
10122  RETURN
10123  ENDIF
10124 C IF(NWEPAU.LE.2)GO TO 215
10125  kform=2
10126  IF(kform.EQ.1)THEN
10127  aabbcc=0.
10128  ELSEIF(kform.EQ.2.AND.irej.EQ.0)THEN
10129 C The next 3 lines only for 6 (J/psi)
10130  READ(29,'(1X,I5)')krepa
10131  READ(29,'(1X,I5)')krepa
10132  READ(29,'(1X,I5)')krepa
10133 C
10134  READ(29,'(1X,I5)')krepa
10135  DO 1975 kre=1,krepa
10136  READ(29,'(1X,A)')a109
10137  1975 CONTINUE
10138  ENDIF
10139  go to 214
10140  ENDIF
10141  ENDIF
10142  IF(nrhkk.EQ.8)THEN
10143  IF(phkk(4,nhkk).LE.taefen+aam(nrhkk))THEN
10144  WRITE(6,*)' Pauli Blocking of n',nwepau,phkk(4,nhkk),taefen
10145  nwepau=nwepau+1
10146  nhkk=nhkk-1
10147  IF (nhkk.EQ.nmxhkk)THEN
10148  WRITE (6,'(A,2I5)').EQ.' :NHKKNMXHKK ',nhkk,nmxhkk
10149  RETURN
10150  ENDIF
10151 C IF(NWEPAU.LE.2)GO TO 215
10152  kform=2
10153  IF(kform.EQ.1)THEN
10154  aabbcc=0.
10155  ELSEIF(kform.EQ.2.AND.irej.EQ.0)THEN
10156 C The next 3 lines only for 6 (J/psi)
10157  READ(29,'(1X,I5)')krepa
10158  READ(29,'(1X,I5)')krepa
10159  READ(29,'(1X,I5)')krepa
10160 C
10161  READ(29,'(1X,I5)')krepa
10162  DO 1976 kre=1,krepa
10163  READ(29,'(1X,A)')a109
10164  1976 CONTINUE
10165  ENDIF
10166  go to 214
10167  ENDIF
10168  ENDIF
10169  IF(phkk(4,nhkk)-aam(nrhkk).LE.taepot(nrhkk))THEN
10170  isthkk(nhkk)=16
10171  ENDIF
10172  ENDIF
10173  isthkk(iint)=12
10174  ikta=iint
10175  vhkk(1,nhkk)=vhkk(1,ikta)
10176  vhkk(2,nhkk)=vhkk(2,ikta)
10177  vhkk(3,nhkk)=vhkk(3,ikta)
10178  vhkk(4,nhkk)=vhkk(4,ikta)
10179  whkk(1,nhkk)=whkk(1,ikta)
10180  whkk(2,nhkk)=whkk(2,ikta)
10181  whkk(3,nhkk)=whkk(3,ikta)
10182  whkk(4,nhkk)=whkk(4,ikta)
10183 C
10184 C-----------------------------------------------------------------------
10185  IF (ipev.GE.1) THEN
10186  WRITE(6,'(/A/)') ' KKEVT: FINAL LIST OF ENTRIES TO /HKKEVT/'
10187  DO 121 ihkk=1,nhkk
10188  WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
10189  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
10190  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
10191 
10192  121 CONTINUE
10193  ENDIF
10194 C
10195 C
10196  110 CONTINUE
10197 C
10198 C
10199 C
10200  RETURN
10201  END
10202  SUBROUTINE luinol
10203 C
10204 C
10205  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
10206 C Prevent particles dacaying
10207 C KOS
10208  kc=lucomp(310)
10209  mdcy(kc,1)=0
10210 C PIO
10211  kc=lucomp(111)
10212  mdcy(kc,1)=0
10213 C LAMBDA
10214  kc=lucomp(3122)
10215  mdcy(kc,1)=0
10216 C ALAMBDA
10217  kc=lucomp(-3122)
10218  mdcy(kc,1)=0
10219 C SIG+
10220  kc=lucomp(3222)
10221  mdcy(kc,1)=0
10222 C ASIG+
10223  kc=lucomp(-3222)
10224  mdcy(kc,1)=0
10225 C SIG-
10226  kc=lucomp(3112)
10227  mdcy(kc,1)=0
10228 C ASIG-
10229  kc=lucomp(-3112)
10230  mdcy(kc,1)=0
10231 C SIG0
10232 C KC=LUCOMP(3212)
10233 C MDCY(KC,1)=0
10234 C ASIG0
10235 C KC=LUCOMP(-3212)
10236 C MDCY(KC,1)=0
10237 C TET0
10238  kc=lucomp(3322)
10239  mdcy(kc,1)=0
10240 C ATET0
10241  kc=lucomp(-3322)
10242  mdcy(kc,1)=0
10243 C TET-
10244  kc=lucomp(3312)
10245  mdcy(kc,1)=0
10246 C ATET-
10247  kc=lucomp(-3312)
10248  mdcy(kc,1)=0
10249 C OMEGA-
10250  kc=lucomp(3334)
10251  mdcy(kc,1)=0
10252 C AOMEGA-
10253  kc=lucomp(-3334)
10254  mdcy(kc,1)=0
10255 C
10256  RETURN
10257  END
10258  SUBROUTINE testfilenu
10259  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10260  SAVE
10261 C COMMON/BATLUND/N,K(4000,5),P(4000,5),V(4000,5)
10262  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10263  common/phirot/phr1,phr2,phr3
10264  INTEGER nflag(7)
10265  DO nev = 1,100000
10266  CALL filenu(epn,ltyp,nutyp,plu21,plu22,plu23,nhad,iflag,lend)
10267  IF(lend.EQ.1) go to 100
10268  nflag(iflag) = nflag(iflag) + 1
10269  write(6,150) (kw,k(kw,1),k(kw,2),(p(kw,j),j=1,5),kw=1,n)
10270  write(6,*)
10271 C
10272 C Here rotates the event with the neutrino along +z
10273 C
10274  CALL rotate
10275  write(6,150) (kw,k(kw,1),k(kw,2),(p(kw,j),j=1,5),kw=1,n)
10276  write(6,*)
10277 c
10278 c Here returns the control to DPMJET
10279 c
10280 C
10281 C Here rotates the event back to lab frame
10282 C
10283  CALL backrot
10284  write(6,150) (kw,k(kw,1),k(kw,2),(p(kw,j),j=1,5),kw=1,n)
10285  write(6,*)
10286  END DO
10287  100 CONTINUE
10288  WRITE(6,*) (nflag(j),j=1,7)
10289  stop
10290  150 FORMAT(i5,2i5,5g10.3)
10291  END
10292 
10293  SUBROUTINE filenu(EPN,LTYP,NUTYP,PLU21,PLU22,PLU23,NHO,
10294  $ iflag,lend)
10295  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10296  SAVE
10297 C COMMON/BATLUND/N,K(4000,5),P(4000,5),V(4000,5)
10298  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10299  COMMON /clout/ lun
10300  LOGICAL first
10301  DATA first/.true./
10302  DATA lun /25/
10303  DATA init/0/
10304  SAVE first
10305  OPEN (lun,file='nuatm_new.dat',status='OLD')
10306  IF(first) THEN
10307  CALL read_ini
10308  first = .false.
10309  ENDIF
10310  init=init+1
10311  lend = 0
10312  iflag = 0
10313  nhad = 0
10314  READ (lun, 10, err=1) nev, n, (v(1,j),j=1,3)
10315  nho=n
10316  DO l=1,n
10317  READ (lun, 15)ll, (k(l,j),j=1,5),(p(l,j),j=1,5)
10318  IF(l.GT.4.AND.k(l,1).EQ.1) nhad = nhad + 1
10319  ENDDO
10320  nono=6
10321  IF(init.LE.20) THEN
10322  DO l=1,n
10323  WRITE(6, 15) l, (k(l,j),j=1,5),(p(l,j),j=1,5)
10324  ENDDO
10325  ENDIF
10326  epn = p(1,4)
10327  ltyp = k(1,2)
10328  nutyp = k(2,2)
10329  plu21 = p(2,1)
10330  plu21 = p(2,2)
10331  plu21 = p(2,3)
10332  IF(n.EQ.4.OR.n.EQ.5) THEN
10333  IF(k(4,2).NE.k(1,2)) THEN
10334  iflag = 1 ! quasi-elastic CC
10335  ELSE IF(k(4,2).EQ.k(1,2)) THEN
10336  iflag = 2 ! quasi-elastic NC
10337  ENDIF
10338  ELSE IF(n.EQ.7) THEN
10339  IF(k(4,2).NE.k(1,2)) THEN
10340  iflag = 3 ! delta resonance CC
10341  ELSE IF(k(4,2).EQ.k(1,2)) THEN
10342  iflag = 4 ! delta resonance NC
10343  ENDIF
10344  ELSE IF(n.GT.7) THEN
10345  IF(k(4,2).NE.k(1,2)) THEN
10346  iflag = 5 ! DIS CC
10347  ELSE IF(k(4,2).EQ.k(1,2)) THEN
10348  iflag = 6 ! DIS NC
10349  ENDIF
10350  ELSE
10351  WRITE(6,*) n,nev,k(1,2),k(4,2)
10352  iflag = 7 ! impossible
10353  ENDIF
10354  RETURN
10355 1 lend = 1
10356 10 FORMAT(1x,i7, 3x, i3, 2x, 3g12.4)
10357 15 FORMAT(i5,5i7,5g12.4)
10358  END
10359 
10360  SUBROUTINE read_ini
10361  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10362  SAVE
10363  COMMON /clout/ lun
10364  REAL*4 rrat(6),emin,vers,ak
10365  CHARACTER*50 line
10366  DO j=1,10000
10367  READ(lun, 10) line
10368  IF (line(1:1) .EQ. '!') goto 100
10369  ENDDO
10370  100 CONTINUE
10371  READ (lun, 110) vers, jcode, jflux, jrat, ak
10372  READ (lun, 120) emin, (rrat(j),j=1,6)
10373  RETURN
10374  10 FORMAT (a50)
10375  110 FORMAT(1x,f5.2,3x, i2, 3x, 2i2, 3x, f10.2)
10376  120 FORMAT(1x,f12.4, 3x, 6g12.4)
10377  END
10378 
10379 
10380  SUBROUTINE testrot1s(PI,PO,PHI)
10381  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10382  SAVE
10383  dimension rot(3,3),pi(3),po(3)
10384  rot(1,1)=1.d0
10385  rot(1,2)=0.d0
10386  rot(1,3)=0.d0
10387  rot(2,1)=0.d0
10388  rot(2,2)=cos(phi)
10389  rot(2,3)=-sin(phi)
10390  rot(3,1)=0.d0
10391  rot(3,2)=sin(phi)
10392  rot(3,3)=cos(phi)
10393  DO 140 j=1,3
10394  po(j)=rot(j,1)*pi(1)+rot(j,2)*pi(2)+rot(j,3)*pi(3)
10395  140 CONTINUE
10396  RETURN
10397  END
10398 
10399 
10400  SUBROUTINE testrot2s(PI,PO,PHI)
10401  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10402  SAVE
10403  dimension rot(3,3),pi(3),po(3)
10404  rot(1,1)=0.d0
10405  rot(1,2)=1.d0
10406  rot(1,3)=0.d0
10407  rot(2,1)=cos(phi)
10408  rot(2,2)=0.d0
10409  rot(2,3)=-sin(phi)
10410  rot(3,1)=sin(phi)
10411  rot(3,2)=0.d0
10412  rot(3,3)=cos(phi)
10413  DO 140 j=1,3
10414  po(j)=rot(j,1)*pi(1)+rot(j,2)*pi(2)+rot(j,3)*pi(3)
10415  140 CONTINUE
10416  RETURN
10417  END
10418 
10419  SUBROUTINE testrot3s(PI,PO,PHI)
10420  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10421  SAVE
10422  dimension rot(3,3),pi(3),po(3)
10423  rot(1,1)=0.d0
10424  rot(2,1)=1.d0
10425  rot(3,1)=0.d0
10426  rot(1,2)=cos(phi)
10427  rot(2,2)=0.d0
10428  rot(3,2)=-sin(phi)
10429  rot(1,3)=sin(phi)
10430  rot(2,3)=0.d0
10431  rot(3,3)=cos(phi)
10432  DO 140 j=1,3
10433  po(j)=rot(j,1)*pi(1)+rot(j,2)*pi(2)+rot(j,3)*pi(3)
10434  140 CONTINUE
10435  RETURN
10436  END
10437 
10438  SUBROUTINE testrot4s(PI,PO,PHI)
10439  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10440  SAVE
10441  dimension rot(3,3),pi(3),po(3)
10442  rot(1,1)=1.d0
10443  rot(2,1)=0.d0
10444  rot(3,1)=0.d0
10445  rot(1,2)=0.d0
10446  rot(2,2)=cos(phi)
10447  rot(3,2)=-sin(phi)
10448  rot(1,3)=0.d0
10449  rot(2,3)=sin(phi)
10450  rot(3,3)=cos(phi)
10451  DO 140 j=1,3
10452  po(j)=rot(j,1)*pi(1)+rot(j,2)*pi(2)+rot(j,3)*pi(3)
10453  140 CONTINUE
10454  RETURN
10455  END
10456 
10457  SUBROUTINE rotate
10458  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10459  SAVE
10460  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10461  common/phirot/phr1,phr2,phr3
10462  dimension pi(3),po(3)
10463 C
10464 C Rotate events so that neutrino goeas along +z
10465 C
10466  phr1=atan(p(1,2)/p(1,3))
10467  DO kw=1,n
10468  pi(1)=p(kw,1)
10469  pi(2)=p(kw,2)
10470  pi(3)=p(kw,3)
10471  CALL testrot1s(pi,po,phr1)
10472  DO ll=1,3
10473  IF(abs(po(ll)).LT.1.d-07) po(ll)=0.
10474  END DO
10475  p(kw,1)=po(1)
10476  p(kw,2)=po(2)
10477  p(kw,3)=po(3)
10478  END DO
10479  phr2=atan(p(1,1)/p(1,3))
10480  DO kw=1,n
10481  pi(1)=p(kw,1)
10482  pi(2)=p(kw,2)
10483  pi(3)=p(kw,3)
10484  CALL testrot2s(pi,po,phr2)
10485  DO ll=1,3
10486  IF(abs(po(ll)).LT.1.d-07) po(ll)=0.
10487  END DO
10488  p(kw,1)=po(1)
10489  p(kw,2)=po(2)
10490  p(kw,3)=po(3)
10491  END DO
10492  phr3 = 0
10493  IF(p(1,3).lt.0) THEN
10494  phr3 = -1.
10495  DO kw=1,n
10496  p(kw,3) = -p(kw,3)
10497  END DO
10498  ENDIF
10499  RETURN
10500  END
10501 
10502  SUBROUTINE backrot
10503  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10504  SAVE
10505  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10506  common/phirot/phr1,phr2,phr3
10507  dimension pi(3),po(3)
10508 
10509 c
10510 c Rotates back event to lab frame
10511 c
10512  IF(phr3.EQ.-1.) THEN
10513  DO kw=1,n
10514  p(kw,3) = -p(kw,3)
10515  END DO
10516  END IF
10517  DO kw=1,n
10518  pi(1)=p(kw,1)
10519  pi(2)=p(kw,2)
10520  pi(3)=p(kw,3)
10521  CALL testrot3s(pi,po,phr2)
10522  DO ll=1,3
10523  IF(abs(po(ll)).LT.1.d-07) po(ll)=0.
10524  END DO
10525  p(kw,1)=po(1)
10526  p(kw,2)=po(2)
10527  p(kw,3)=po(3)
10528  END DO
10529  DO kw=1,n
10530  pi(1)=p(kw,1)
10531  pi(2)=p(kw,2)
10532  pi(3)=p(kw,3)
10533  CALL testrot4s(pi,po,phr1)
10534  DO ll=1,3
10535  IF(abs(po(ll)).LT.1.d-07) po(ll)=0.
10536  END DO
10537  p(kw,1)=po(1)
10538  p(kw,2)=po(2)
10539  p(kw,3)=po(3)
10540  END DO
10541  RETURN
10542  END
10543 
10544  SUBROUTINE backdpm
10545  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10546  SAVE
10547 *KEEP,HKKEVT.
10548 c INCLUDE (HKKEVT)
10549  parameter(nmxhkk= 89998)
10550 c PARAMETER (NMXHKK=25000)
10551  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
10552  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
10553  +(4,nmxhkk)
10554 C
10555  common/phirot/phr1,phr2,phr3
10556  dimension pi(3),po(3)
10557 
10558 c
10559 c Rotates back event to lab frame
10560 c
10561  IF(phr3.EQ.-1.) THEN
10562  DO kw=1,nhkk
10563  IF((isthkk(kw).EQ.-1).OR.
10564  * (isthkk(kw).EQ.1).OR.
10565  * (isthkk(kw).EQ.1001))THEN
10566  phkk(3,kw) = -phkk(3,kw)
10567  ENDIF
10568  END DO
10569  END IF
10570  DO kw=1,nhkk
10571  IF((isthkk(kw).EQ.-1).OR.
10572  * (isthkk(kw).EQ.1).OR.
10573  * (isthkk(kw).EQ.1001))THEN
10574  pi(1)=phkk(1,kw)
10575  pi(2)=phkk(2,kw)
10576  pi(3)=phkk(3,kw)
10577  CALL testrot3s(pi,po,phr2)
10578  DO ll=1,3
10579  IF(abs(po(ll)).LT.1.d-07) po(ll)=0.
10580  END DO
10581  phkk(1,kw)=po(1)
10582  phkk(2,kw)=po(2)
10583  phkk(3,kw)=po(3)
10584  ENDIF
10585  END DO
10586  DO kw=1,nhkk
10587  IF((isthkk(kw).EQ.-1).OR.
10588  * (isthkk(kw).EQ.1).OR.
10589  * (isthkk(kw).EQ.1001))THEN
10590  pi(1)=phkk(1,kw)
10591  pi(2)=phkk(2,kw)
10592  pi(3)=phkk(3,kw)
10593  CALL testrot4s(pi,po,phr1)
10594  DO ll=1,3
10595  IF(abs(po(ll)).LT.1.d-07) po(ll)=0.
10596  END DO
10597  phkk(1,kw)=po(1)
10598  phkk(2,kw)=po(2)
10599  phkk(3,kw)=po(3)
10600  ENDIF
10601  END DO
10602  RETURN
10603  END
10604 
10605  SUBROUTINE dropdi(NN,NP,NT,ECM)
10606 C Drop diffractive collisions out of the Glauber
10607 C cascade in nuclear collisions (For NN > 1 only)
10608  IMPLICIT DOUBLE PRECISION (a-h,o-z)
10609  SAVE
10610  parameter(intmx=2488)
10611  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
10612 C Fraction of diffractive collisions at given Energy
10613  fracdif=sippsd(ecm)/siinel(1,1,ecm)
10614  ann=nn
10615  dann=fracdif*ann
10616  idann=dann
10617  aidann=idann
10618  fdann=dann-aidann
10619  IF(rndm(v).LT.fdann)idann=idann+1
10620 C Total number of collisions NN is reduced by IDANN
10621 C WRITE(6,*)'NN,FRACDIF,FDANN,IDANN ',NN,FRACDIF,FDANN,IDANN
10622  nnnew=nn-idann
10623  npnew=np
10624  ntnew=nt
10625  IF(idann.GT.0)THEN
10626  DO 1 i= nn-idann+1,nn
10627  ni1=inter1(i)
10628  ni2=inter2(i)
10629  jssh(ni1)=jssh(ni1)-1
10630  jtsh(ni2)=jtsh(ni2)-1
10631  IF(jssh(ni1).EQ.0)npnew=npnew-1
10632  IF(jtsh(ni2).EQ.0)ntnew=ntnew-1
10633  inter1(i)=0
10634  inter2(i)=0
10635  1 CONTINUE
10636  ENDIF
10637 C WRITE (6,*)'NNNEW,NPNEW,NTNEW ',NNNEW,NPNEW,NTNEW
10638  nn=nnnew
10639  np=npnew
10640  nt=ntnew
10641  RETURN
10642  END
mpdgha
function mpdgha(MCIND)
Definition: dpm25nulib.f:386
kkevss
subroutine kkevss
Definition: dpm25nuc2.f:3745
c2_transformation::zero
static float_type zero(float_type)
utility function f(x)=0 useful in axis transforms
Definition: c2_function.hh:1203
kkevdv
subroutine kkevdv(IREJDV)
Definition: dpm25nuc5.f:208
intmx
const int intmx
Definition: G4DPMJET2_5Interface.hh:68
z
Double_t z
Definition: plot.C:279
xksamp
subroutine xksamp(NN, ECM)
Definition: dpm25nuc3.f:1273
kkevvd
subroutine kkevvd(IREJVD)
Definition: dpm25nuc5.f:1622
gm
#define gm
Definition: mymalloc.cc:2499
mcihad
function mcihad(MCIND)
Definition: dpm25nulib.f:364
cromsc
subroutine cromsc(PX, PY, PZ, E, RX, RY, RZ, PXN, PYN, PZN, EN, IORIG)
Definition: dpm25nuc2.f:7037
plu
function plu(I, J)
Definition: jetset74ku.f:6207
shmak1
subroutine shmak1(ICASE, NN, NNA, NNB, NA, NB, UMO, BIMP)
Definition: dpm25nuc7.f:4358
flksaa
subroutine flksaa(NN, ECM)
Definition: dpm25nuc3.f:922
hadrkk
subroutine hadrkk(NHKKH1, PPN)
Definition: dpm25nuc3.f:3259
x2
Double_t x2[nxs]
Definition: Style.C:19
dtrans
subroutine dtrans(XO, YO, ZO, CDE, SDE, SFE, CFE, X, Y, Z)
Definition: dpm25nulib.f:510
d
Float_t d
Definition: plot.C:237
CLHEP::HepBoost::xt
double xt() const
sltraf
subroutine sltraf(GA, BGA, EIN, PZIN, EOUT, PZOUT)
Definition: dpm25nuc3.f:72
xptfl1
subroutine xptfl1(NHARD, NSEA, NVAL, SOXUS1, SOXUS2, SOX1, SOX2, HAX1, HAX2, LPO, MPO, NPO, LPASOF, IJPVAL, IJTVAL, RJ1000, XMAX1, XMAX2)
Definition: dpm25nuc2.f:548
testrot1s
subroutine testrot1s(PI, PO, PHI)
Definition: dpm25nuc2.f:10380
rndm
DOUBLE PRECISION function rndm(RDUMMY)
Definition: dpm25nulib.f:1460
s
const XML_Char * s
Definition: expat.h:262
diqzzd
subroutine diqzzd(ECM, XPSQ1, XPSAQ1, XPSQ2, XPSAQ2, IPSQ1, IPSAQ1, IPSQ2, IPSAQ2, IREJSD)
Definition: dpm25nuc5.f:6951
nucmom
subroutine nucmom
Definition: dpm25nuc3.f:83
p
const char * p
Definition: xmltok.h:285
lucomp
function lucomp(KF)
Definition: dpm25nonu.f:31
sampex
DOUBLE PRECISION function sampex(X1, X2)
Definition: dpm25nulib.f:1118
selhrd
subroutine selhrd(MHARD, IJPVAL, IJTVAL, PTTHRE)
Definition: dpm25lap.f:153
kkevhh
subroutine kkevhh
Definition: dpm25nuc2.f:7193
kkevnu
subroutine kkevnu(NHKKH1, EPN, PPN, KKMAT, IREJ, ECM)
Definition: dpm25nuc2.f:8539
flksam
subroutine flksam
Definition: dpm25nuc3.f:653
selpth
subroutine selpth(PQUAR, PAQUAR, TQUAR, TAQUAR, ECM, PTXSQ1, PTYSQ1, PLQ1, EQ1, PTXSA1, PTYSA1, PLAQ1, EAQ1, PTXSQ2, PTYSQ2, PLQ2, EQ2, PTXSA2, PTYSA2, PLAQ2, EAQ2, AMCH1, AMCH2, IREJ, IKVALA, pttq1, ptta1, pttq2, ptta2)
Definition: dpm25nuc2.f:49
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
rotate
subroutine rotate
Definition: dpm25nuc2.f:10457
shmak
subroutine shmak(ICASE, NN, NNA, NNB, NA, NB, UMO, BIMP)
Definition: dpm25nuc7.f:4192
luinol
subroutine luinol
Definition: dpm25nuc2.f:10202
hadhad
subroutine hadhad(EPN, PPN, NHKKH1, IHTAWW, ITTA, IREJFO)
Definition: dpm25nuc1.f:6026
ltini
subroutine ltini(IDP, EPN, PPN, ECM)
Definition: dpm25nuc6.f:4036
a
G4double a
Definition: TRTMaterials.hh:39
kkevvv
subroutine kkevvv(IREJVV, NBPROJ)
Definition: dpm25nuc2.f:2518
read_ini
subroutine read_ini
Definition: dpm25nuc2.f:10360
fer4mt
subroutine fer4mt(IT, PFERM, PXT, PYT, PZT, ET, KT)
Definition: dpm25nuc3.f:430
sampxb
DOUBLE PRECISION function sampxb(X1, X2, B)
Definition: dpm25nulib.f:1133
samplm
subroutine samplm(L2STR, M2STR, N2STR)
Definition: dpm25pom.f:1859
nmxhkk
const int nmxhkk
Definition: G4DPMJET2_5Interface.hh:78
file
TFile * file
Definition: comparison_ascii.C:5
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
filenu
subroutine filenu(EPN, LTYP, NUTYP, PLU21, PLU22, PLU23, NHO, IFLAG, LEND)
Definition: dpm25nuc2.f:10293
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
ebind
DOUBLE PRECISION function ebind(IA, IZ)
Definition: dpm25nuc1.f:5789
qinnuc
subroutine qinnuc(X, Y)
Definition: dpm25nuc3.f:9129
G4Abla::mod
G4int mod(G4int a, G4int b)
Definition: G4Abla.cc:3675
samplx
subroutine samplx(L2STR, M2STR, N2STR, NN2STR, NL2STR)
Definition: dpm25pom.f:1749
testrot2s
subroutine testrot2s(PI, PO, PHI)
Definition: dpm25nuc2.f:10400
kkevds
subroutine kkevds(IREJDS)
Definition: dpm25nuc5.f:3040
qel_pol
subroutine qel_pol(ENU, LTYP, P21, P22, P23, P24, P25)
Definition: dpm25nonu.f:1
intmd
const int intmd
Definition: G4DPMJET2_5Interface.hh:66
primpt
subroutine primpt(MPO, ECM)
Definition: dpm25nuc2.f:7
phnsch
DOUBLE PRECISION function phnsch(KP, KTARG, PLAB)
Definition: dpm25nuc7.f:6170
backdpm
subroutine backdpm
Definition: dpm25nuc2.f:10544
n
Char_t n[5]
Definition: comparison_ascii.C:55
testem0.App.init
def init
Definition: testem0.py:56
corval
subroutine corval(AMMM, IREJ, AMCH1, AMCH2, QTX1, QTY1, QZ1, QE1, QTX2, QTY2, QZ2, QE2, NORIG)
Definition: dpm25nuc3.f:8390
gen_delta
subroutine gen_delta(ENU, LLEP, LTARG, JINT, P21, P22, P23, P24, P25)
Definition: dpm25nonu.f:19
CLHEP::HepLorentzVector::py
double py() const
kkevzz
subroutine kkevzz
Definition: dpm25nuc2.f:7729
corrco
subroutine corrco
Definition: dpm25nuc2.f:8379
daltra
subroutine daltra(GA, BGX, BGY, BGZ, PCX, PCY, PCZ, EC, P, PX, PY, PZ, E)
Definition: dpm25nulib.f:542
x1
Double_t x1[nxs]
Definition: Style.C:18
nt
TTree * nt
Definition: plotHisto.C:21
CLHEP::HepLorentzVector::px
double px() const
nmax
const G4int nmax
Definition: G4UrQMD1_3Interface.hh:69
pyjets
#define pyjets
Definition: pythia6_common_address.c:39
fer4mp
subroutine fer4mp(IP, PFERM, PXT, PYT, PZT, ET, KT)
Definition: dpm25nuc3.f:373
sdiff
subroutine sdiff(EPROJ, PPROJ, KPROJ, NHKKH1, IQQDD)
Definition: dpm25diff.f:4
comcm2
subroutine comcm2(IQ1, IQ2, IAQ1, IAQ2, NNCH, IREJ, AMCH)
Definition: dpm25nuc3.f:6218
x
Double_t x
Definition: plot.C:279
kkevt
subroutine kkevt(NHKKH1, EPN, PPN, KKMAT, IREJ)
Definition: dpm25nuc2.f:1405
sampey
DOUBLE PRECISION function sampey(X1, X2)
Definition: dpm25nulib.f:1107
status
int status
Definition: tracer.cxx:24
dsfecf
subroutine dsfecf(SFE, CFE)
Definition: dpm25nuc7.f:3354
kkevdi
subroutine kkevdi(NHKKH1, EPN, PPN, KKMAT, IREJ)
Definition: dpm25nuc2.f:9426
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
cobcma
subroutine cobcma(IF1, IF2, IF3, IJNCH, NNCH, IREJ, AMCH, AMCHN, IKET)
Definition: dpm25nuc3.f:6049
pylist
subroutine pylist(MLIST)
Definition: pythia61.f:37135
first
G4int first
Definition: G4NeutronHPJENDLHEData.cc:262
testrot3s
subroutine testrot3s(PI, PO, PHI)
Definition: dpm25nuc2.f:10419
lend
Definition: G4DataQuestionaire.hh:35
G4Abla::tau
G4double tau(G4double bet, G4double homega, G4double ef, G4double t)
Definition: G4Abla.cc:2586
klu
function klu(I, J)
Definition: jetset74ku.f:6077
kkevvs
subroutine kkevvs(IREJVS)
Definition: dpm25nuc2.f:4806
c2_factory::sqrt
static c2_sqrt_p< float_type > & sqrt()
make a *new object
Definition: c2_factory.hh:142
CLHEP::HepLorentzVector::pz
double pz() const
xptfl
subroutine xptfl(NHARD, NSEA, IREG, XMAX1, XMAX2)
Definition: dpm25nuc2.f:115
npart
Int_t npart
Definition: Style.C:7
dropdi
subroutine dropdi(NN, NP, NT, ECM)
Definition: dpm25nuc2.f:10605
siinel
DOUBLE PRECISION function siinel(KPROJ, KTARG, UMO)
Definition: dpm25nuc7.f:6156
comcma
subroutine comcma(IFQ, IFAQ, IJNCH, NNCH, IREJ, AMCH, AMCHN)
Definition: dpm25nuc3.f:6135
sippsd
DOUBLE PRECISION function sippsd(ECM)
Definition: dpm25nuc7.f:6127
print
void print(const std::vector< T > &data)
Definition: DicomRun.hh:111
testrot4s
subroutine testrot4s(PI, PO, PHI)
Definition: dpm25nuc2.f:10438
kkevsd
subroutine kkevsd(IREJSD)
Definition: dpm25nuc5.f:4612
c2_factory::cos
static c2_cos_p< float_type > & cos()
make a *new object
Definition: c2_factory.hh:134
testfilenu
subroutine testfilenu
Definition: dpm25nuc2.f:10258
selpts
subroutine selpts(PTXSQ1, PTYSQ1, PLQ1, EQ1, PTXSA2, PTYSA2, PLAQ2, EAQ2, AMCH1, IREJ, IKVALA, PTTQ1)
Definition: dpm25nuc7.f:7324
dbeta
DOUBLE PRECISION function dbeta(X1, X2, BET)
Definition: dpm25nuc7.f:2672
ptval
subroutine ptval(XP, XXP, XXT, XT, ECM, PTXVQ1, PTYVQ1, PLQ1, EQ1, PTXVA1, PTYVA1, PLAQ1, EAQ1, PTXVQ2, PTYVQ2, PLQ2, EQ2, PTXVA2, PTYVA2, PLAQ2, EAQ2, AMCH1, AMCH2, IREJ, IKVALA)
Definition: dpm25nuc2.f:1364
kkevsv
subroutine kkevsv(IREJSV)
Definition: dpm25nuc2.f:5851
diqdzz
subroutine diqdzz(ECM, XPSQ1, XPSAQ1, XPSQ2, XPSAQ2, IPSQ1, IPSAQ1, IPSQ2, IPSAQ2, IREJDS)
Definition: dpm25nuc5.f:5958
backrot
subroutine backrot
Definition: dpm25nuc2.f:10502
rannor
subroutine rannor(X, Y)
Definition: dpm25nulib.f:164
mass_ini
subroutine mass_ini
Definition: dpm25nonu.f:14
c2_factory::sin
static c2_sin_p< float_type > & sin()
make a *new object
Definition: c2_factory.hh:132
shmako
subroutine shmako(NA, NB, B, INTT, INTA, INTB, JS, JT, PPN, KKMAT)
Definition: dpm25nuc7.f:1606
fe
G4fissionEvent * fe
Definition: G4LLNLFission.cc:63
Generated on Sat Dec 14 2013 14:33:17 for Geant4_10 by   doxygen 1.8.5