Geant4  9.6.p02
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
dpm25lepto.f
Go to the documentation of this file.
1 C****************************************************************
2  SUBROUTINE kkevle(NHKKH1,EPN,PPN,KKMAT,IREJ)
3 *
4  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5  common/intnez/ndz,nzd
6 *KEEP,HKKEVT.
7 c INCLUDE (HKKEVT)
8  parameter(nmxhkk= 89998)
9 c PARAMETER (NMXHKK=25000)
10  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk), jmohkk
11  +(2,nmxhkk),jdahkk(2,nmxhkk), phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk
12  +(4,nmxhkk)
13 C
14 C WHKK(4,NMXHKK) GIVES POSITIONS AND TIMES IN
15 C PROJECTILE FRAME, THE CHAINS ARE CREATED ON
16 C THE POSITIONS OF THE PROJECTILE NUCLEONS
17 C IN THE PROJECTILE FRAME (TARGET NUCLEONS IN
18 C TARGET FRAME) BOTH POSITIONS ARE THREFORE NOT
19 C COMPLETELY CONSISTENT. THE TIMES IN THE
20 C PROJECTILE FRAME HOWEVER ARE OBTAINED BY
21 C LORENTZ TRANSFORMING FROM THE LAB SYSTEM.
22 C
23 C Based on the proposed standard COMMON block (Sjostrand Memo 17.3,89)
24 C
25 C NMXHKK: maximum numbers of entries (partons/particles) that can be
26 C stored in the commonblock.
27 C
28 C NHKK: the actual number of entries stored in current event. These are
29 C found in the first NHKK positions of the respective arrays below.
30 C Index IHKK, 1 <= IHKK <= NHKK, is below used to denote a given
31 C entry.
32 C
33 C ISTHKK(IHKK): status code for entry IHKK, with following meanings:
34 C = 0 : null entry.
35 C = 1 : an existing entry, which has not decayed or fragmented.
36 C This is the main class of entries which represents the
37 C "final state" given by the generator.
38 C = 2 : an entry which has decayed or fragmented and therefore
39 C is not appearing in the final state, but is retained for
40 C event history information.
41 C = 3 : a documentation line, defined separately from the event
42 C history. (incoming reacting
43 C particles, etc.)
44 C = 4 - 10 : undefined, but reserved for future standards.
45 C = 11 - 20 : at the disposal of each model builder for constructs
46 C specific to his program, but equivalent to a null line in the
47 C context of any other program. One example is the cone defining
48 C vector of HERWIG, another cluster or event axes of the JETSET
49 C analysis routines.
50 C = 21 - : at the disposal of users, in particular for event tracking
51 C in the detector.
52 C
53 C IDHKK(IHKK) : particle identity, according to the Particle Data Group
54 C standard.
55 C
56 C JMOHKK(1,IHKK) : pointer to the position where the mother is stored.
57 C The value is 0 for initial entries.
58 C
59 C JMOHKK(2,IHKK) : pointer to position of second mother. Normally only
60 C one mother exist, in which case the value 0 is used. In cluster
61 C fragmentation models, the two mothers would correspond to the q
62 C and qbar which join to form a cluster. In string fragmentation,
63 C the two mothers of a particle produced in the fragmentation would
64 C be the two endpoints of the string (with the range in between
65 C implied).
66 C
67 C JDAHKK(1,IHKK) : pointer to the position of the first daughter. If an
68 C entry has not decayed, this is 0.
69 C
70 C JDAHKK(2,IHKK) : pointer to the position of the last daughter. If an
71 C entry has not decayed, this is 0. It is assumed that the daughters
72 C of a particle (or cluster or string) are stored sequentially, so
73 C that the whole range JDAHKK(1,IHKK) - JDAHKK(2,IHKK) contains
74 C daughters. Even in cases where only one daughter is defined (e.g.
75 C K0 -> K0S) both values should be defined, to make for a uniform
76 C approach in terms of loop constructions.
77 C
78 C PHKK(1,IHKK) : momentum in the x direction, in GeV/c.
79 C
80 C PHKK(2,IHKK) : momentum in the y direction, in GeV/c.
81 C
82 C PHKK(3,IHKK) : momentum in the z direction, in GeV/c.
83 C
84 C PHKK(4,IHKK) : energy, in GeV.
85 C
86 C PHKK(5,IHKK) : mass, in GeV/c**2. For spacelike partons, it is allowed
87 C to use a negative mass, according to PHKK(5,IHKK) = -sqrt(-m**2).
88 C
89 C VHKK(1,IHKK) : production vertex x position, in mm.
90 C
91 C VHKK(2,IHKK) : production vertex y position, in mm.
92 C
93 C VHKK(3,IHKK) : production vertex z position, in mm.
94 C
95 C VHKK(4,IHKK) : production time, in mm/c (= 3.33*10**(-12) s).
96 C********************************************************************
97 *KEEP,INTMX.
98  parameter(intmx=2488,intmd=252)
99 *KEEP,DXQX.
100 C INCLUDE (XQXQ)
101 * NOTE: INTMX set via INCLUDE(INTMX)
102  COMMON /dxqx/ xpvq(248),xpvd(248),xtvq(248),xtvd(248), xpsq
103  +(intmx),xpsaq(intmx),xtsq(intmx),xtsaq(intmx)
104  * ,xpsu(248),xtsu(248)
105  * ,xpsut(248),xtsut(248)
106 *KEEP,INTNEW.
107  COMMON /intnew/ nvv,nsv,nvs,nss,ndv,nvd,nds,nsd,
108  +ixpv,ixps,ixtv,ixts, intvv1(248),
109  +intvv2(248),intsv1(248),intsv2(248), intvs1(248),intvs2(248),
110  +intss1(intmx),intss2(intmx),
111  +intdv1(248),intdv2(248),intvd1(248),intvd2(248),
112  +intds1(intmd),intds2(intmd),intsd1(intmd),intsd2(intmd)
113 
114 C /INTNEW/
115 C NVV : NUMBER OF INTERACTING VALENCE-VALENCE SYSTEMS
116 C NSV : NUMBER OF INTERACTING SEA-VALENCE SYSTEMS
117 C NVS : NUMBER OF INTERACTING VALENCE-SEA SYSTEMS
118 C NSS : NUMBER OF INTERACTING SEA-SEA SYSTEMS
119 C IXPV, IXTV : NUMBER OF GENERATED X-VALUES FOR VALENCE-QUARK
120 C SYSTEMS FROM PROJECTILE/TARGET NUCLEI
121 C IXPS, IXTS : NUMBER OF GENERATED X-VALUES FOR SEA-QUARK PAIRS
122 C FROM PROJECTILE/TARGET NUCLEI
123 C-------------------
124 *KEEP,IFROTO.
125  COMMON /ifroto/ ifrovp(248),itovp(248),ifrosp(intmx), ifrovt(248),
126  +itovt(248),ifrost(intmx),jsshs(intmx),jtshs(intmx),jhkknp(248),
127  +jhkknt
128  +(248), jhkkpv(intmx),jhkkps(intmx), jhkktv(intmx),jhkkts(intmx),
129  +mhkkvv(intmx),mhkkss(intmx), mhkkvs(intmx),mhkksv(intmx),
130  & mhkkhh(intmx),
131  +mhkkdv(248),mhkkvd(248), mhkkds(intmd),mhkksd(intmd)
132 *KEEP,LOZUO.
133  LOGICAL zuovp,zuosp,zuovt,zuost,intlo,inloss
134  COMMON /lozuo/ zuovp(248),zuosp(intmx),zuovt(248),zuost(intmx),
135  +intlo(intmx),inloss(intmx)
136 C /LOZUO/
137 C /
138 C INLOSS : .FALSE. IF CORRESPONDING SEA-SEA INTERACTION
139 C REJECTED IN KKEVT
140 C------------------
141 *KEEP,DIQI.
142  COMMON /diqi/ ipvq(248),ippv1(248),ippv2(248), itvq(248),ittv1
143  +(248),ittv2(248), ipsq(intmx),ipsq2(intmx),
144  +ipsaq(intmx),ipsaq2(intmx),itsq(intmx),itsq2(intmx),
145  +itsaq(intmx),itsaq2(intmx),kkproj(248),kktarg(248)
146 *KEEP,SHMAKL.
147 C INCLUDE (SHMAKL)
148 * NOTE: INTMX set via INCLUDE(INTMX)
149  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
150 *KEEP,NUCC.
151  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
152 *KEEP,RPTSHM.
153  COMMON /rptshm/ rproj,rtarg,bimpac
154 *KEEP,NSHMAK.
155  COMMON /nshmak/ nnshma,npshma,ntshma,nshmac
156 *KEEP,ZENTRA.
157  COMMON /zentra/ icentr
158 *KEEP,NUCIMP.
159  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
160  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
161  +prebin,taebin,fermod,etacou
162 *KEEP,DROPPT.
163  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
164  +ishmal,lpauli
165  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
166  +ipadis,ishmal,lpauli
167 *KEEP,NNCMS.
168  COMMON /nncms/ gamcm,bgcm,umoj,pcmj,eprojj,pprojj
169  COMMON /nuccms/ gacms,bgcms,galab,bglab,blab,umo,pcm,eproj,pproj
170 *KEEP,NUCPOS.
171  COMMON /nucpos/invvp(248),invvt(248),invsp(248),invst(248), nuvv,
172  +nuvs,nusv,nuss,insvp(248),insvt(248),inssp(248),insst(248), isveap
173  +(248),isveat(248),isseap(248),isseat(248), ivseap(248),ivseat
174  +(248), islosp(248),islost(248),inoop(248),inoot(248),nuoo
175 *KEEP,TAUFO.
176  COMMON /taufo/ taufor,ktauge,itauve,incmod
177  COMMON /evappp/ievap
178  COMMON /neutyy/neutyp,neudec
179 *KEEP,RTAR.
180  COMMON /rtar/ rtarnu
181 *KEEP,INNU.
182  COMMON /innu/inudec
183 *KEEP,HADTHR.
184  COMMON /hadthr/ ehadth,inthad
185 *KEEP,DINPDA.
186  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
187  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
188 *KEEP,FERMI.
189  COMMON /fermi/ pquar(4,248),paquar(4,248), tquar(4,248),taquar
190  +(4,248)
191 *KEEP,KETMAS.
192  COMMON /ketmas/ am8(2),am10(2),ib88(2),ib1010(2),amch1n,amch2n
193 *KEEP,DPAR.
194 C /DPAR/ CONTAINS PARTICLE PROPERTIES
195 C ANAME = LITERAL NAME OF THE PARTICLE
196 C AAM = PARTICLE MASS IN GEV
197 C GA = DECAY WIDTH
198 C TAU = LIFE TIME OF INSTABLE PARTICLES
199 C IICH = ELECTRIC CHARGE OF THE PARTICLE
200 C IIBAR = BARYON NUMBER
201 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
202 C
203  CHARACTER*8 aname
204  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
205  +iibar(210),k1(210),k2(210)
206 C------------------
207 *KEEP,DPRIN.
208  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
209 *KEEP,NUCKOO.
210  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
211  +tpoo(3,intmx)
212 *KEEP,REJEC.
213  COMMON /rejec/ irco1,irco2,irco3,irco4,irco5, irss11,irss12,
214  +irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,irvs13,
215  +irvs14, irvv11,irvv12,irvv13,irvv14
216 *KEEP,PROJK.
217  COMMON /projk/ iprojk
218 *KEEP,TANUIN.
219  COMMON /tanuin/ tasuma,tasubi,tabi,tamasu,tama,taimma
220 *KEND.
221  COMMON /diffra/ isingd,idiftp,ioudif,iflagd
222 *
223  LOGICAL lseadi
224  COMMON /seadiq/ lseadi
225  COMMON /evflag/numev
226  COMMON /diquax/idiqua
227 C
228 C-----------------------------------------------------------------------
229 C PARAMETER (INTMX=2488)
230  COMMON /abrjt/xjq1(intmx),xjaq1(intmx),xjq2(intmx),xjaq2(intmx),
231  * ijjq1(intmx),ijjaq1(intmx),ijjq2(intmx),ijjaq2(intmx),
232  * amjch1(intmx),amjch2(intmx),gamjh1(intmx),gamjh2(intmx),
233  * bgjh1(intmx),bgjh2(intmx),thejh1(intmx),thejh2(intmx),
234  * bgxjh1(intmx),bgyjh1(intmx),bgzjh1(intmx),
235  * bgxjh2(intmx),bgyjh2(intmx),bgzjh2(intmx),
236  * pjeta1(intmx,4),pjeta2(intmx,4),pjetb1(intmx,4),pjetb2(intmx,4)
237  * ,jhkkph(intmx),jhkkth(intmx),jhkkex(intmx),jhkke1(intmx)
238  COMMON /abrsof/xsq1(intmx),xsaq1(intmx),xsq2(intmx),xsaq2(intmx),
239  * ijsq1(intmx),ijsaq1(intmx),ijsq2(intmx),ijsaq2(intmx),
240  * amcch1(intmx),amcch2(intmx),gamch1(intmx),gamch2(intmx),
241  * bgch1(intmx),bgch2(intmx),thech1(intmx),thech2(intmx),
242  * bgxch1(intmx),bgych1(intmx),bgzch1(intmx),
243  * bgxch2(intmx),bgych2(intmx),bgzch2(intmx),
244  * nch1(intmx),nch2(intmx),ijch1(intmx),ijch2(intmx),
245  * psofa1(intmx,4),psofa2(intmx,4),psofb1(intmx,4),psofb2(intmx,4)
246  * ,jhkkpz(intmx),jhkktz(intmx),jhkksx(intmx),jhkks1(intmx)
247  COMMON /nucjtn/nonuj1,nonujt,nonus1,nonust
248  COMMON /xsvthr/ xsthr,xvthr,xdthr,xssthr
249  COMMON /minij/iminij,nomje,nomjer,nrejev,nomjt,nomjtr
250  INTEGER nlu,klu,lst,mdcy,mdme,kfdp
251  REAL plu,vlu,cut,parl,x,y,w2,q2,u,brat,elab
252  common/lujets/nlu,klu(4000,5),plu(4000,5),vlu(4000,5)
253  COMMON /leptou/cut(14),lst(40),parl(30),x,y,w2,q2,u
254  common/ludat3/mdcy(500,3),mdme(2000,2),brat(2000),kfdp(2000,5)
255  COMMON /neurej/ noneur
256  DATA iniqel /0/
257 C*******************************************************************"
258 C
259 C KINEMATICS
260 C
261 C********************************************************************
262 C
263  irej = 0
264 *
265  aam(26)=aam(23)
266 C
267  kproj=1
268  IF(ijproj.NE.0) kproj=ijproj
269  ktarg=1
270  atnuc=it
271  itn=it-itz
272  apnuc=ip
273  ipn=ip-ipz
274  amproj =aam(kproj)
275  amtar =aam(ktarg)
276 * nucleon-nucleon cms
277 C IBPROJ=1
278  eprojj=epn
279  pprojj= sqrt((epn-amproj)*(epn+amproj))
280  umoj= sqrt(amproj**2 + amtar**2 + 2.*amtar*eprojj)
281  gamcm = (eprojj+amtar)/umoj
282  bgcm=pprojj/umoj
283  ecm=umoj
284  pcmj=gamcm*pprojj - bgcm*eprojj
285 C
286  IF(ipev.GE.1) print 1000,ip,ipz,it,itz,ijproj,ibproj, eproj,pproj,
287  +amproj,amtar,umo,gamcm,bgcm
288  1000 FORMAT(' ENTRY KKEVNU'/ ' IP,IPZ,IT,ITZ,IJPROJ,IBPROJ',6i5/
289  +' EPROJ,PPROJ,AMPROJ,AMTAR,UMO,GAMCM,BGCM'/10e12.3)
290 
291 C
292 C**** CHANGE PARAMETERS FROM COMMON \INPDAT\
293  as=0.5
294  b8=0.4
295 C CHAIN PT BIGGER THAN PARTICLE PT
296  n9483=0
297 * entry after rejection of an event because of kinematical reasons
298 * several trials are made to realize a sampled Glauber event
299  10 CONTINUE
300  ndz=0
301  nzd=0
302  n9483=n9483+1
303  IF (mod(n9483,200).EQ.0) THEN
304  WRITE(6,'(A,I5,A,I5,A)') ' KKEVT: Glauber event',numev,
305  + ' rejected after', n9483, ' trials'
306  WRITE(6, 1010) nn,np,nt
307  WRITE(6,1020) irco1,irco2,irco3,irco4,irco5, irss11,irss12,
308  + irss13,irss14, irsv11,irsv12,irsv13,irsv14, irvs11,irvs12,
309  + irvs13,irvs14, irvv11,irvv12,irvv13,irvv14
310  n9483=1
311  go to 20
312  ELSEIF(n9483.GT.1) THEN
313  goto 30
314  ENDIF
315  1010 FORMAT (5x,' N9483 LOOP - NN, NP, NT',5i10)
316  1020 FORMAT (5x,' N9483 LOOP - REJECTION COUNTERS ',/,5i8/2(8i8/))
317 C
318 C***************************************************************
319 C
320 C SAMPLE NUMBERS OF COLLISION A LA SHMAKOV---------------
321 C
322 C
323 C This is done here for a h-A event to obtain
324 C the positions of the nucleons of A
325 C
326 C
327 C TOTAL NUMBER OF INTERACTIONS = NN
328 C NUMBER OF INTERACTING NUCLEONS
329 C FROM PROJECTILE = NP
330 C FROM TARGET = NT
331 C
332  20 CONTINUE
333  22 CONTINUE
334  CALL shmako(ip,it,bimp,nn,np,nt,jssh,jtsh,pproj,kkmat)
335  bimpac=bimp
336  nshmac=nshmac+1
337  nnshma=nn
338  npshma=np
339  ntshma=nt
340 * entry for repeated trial to realize a sampled Glauber event
341  30 CONTINUE
342  IF (ipev.GE.2) THEN
343  WRITE(6, 1040) ip,ipz,it,itz,eproj,pproj,nn,np,nt
344  1040 FORMAT (' 752 FORM ',4i10,2f10.3,5i10)
345  WRITE (6,'(/A,2I5,1PE10.2,3I5)') ' KKEVT: IP,IT,BIMP,NN,NP,NT ',
346  + ip,it,bimp,nn,np,nt
347  WRITE (6,'(/2A)')
348  + ' KKEVT: JSSH(KKK),JTSH(KKK),INTER1(KKK),INTER2(KKK),',
349  + ' PKOO(3,KKK),TKOO(3,KKK)'
350  itum=max(it,ip)
351  DO 40 kkk=1,itum
352  WRITE (6,'(4I5,6(1PE11.3))') jssh(kkk),jtsh(kkk),inter1(kkk),
353  + inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),pkoo(3,kkk), tkoo(1,kkk),
354  + tkoo(2,kkk),tkoo(3,kkk)
355 
356  40 CONTINUE
357  ENDIF
358 C
359 C-----------------------------------------------------------------------
360 C STORE PROJECTILE HADRON/NUCLEONS INTO /HKKEVT/
361 C - PROJECTILE CENTRE AT ORIGIN IN SPACE
362 C - TARGET SHIFTED IN X DIRECTION BY
363 C IMPACT PARAMETER 'BIMP'
364 C
365 C - SAMPLING OF NUCLEON TYPES
366 C - CONSISTENCY CHECK
367 C FOR SAMPLED P/N NUMBERS
368 C - INTERACTING PROJECTILES ISTHKK=11
369 C NONINTERACTING ... ISTHKK=13
370 C - FERMI MOMENTA IN CORRESP. REST SYSTEM
371 C-----------
372  nhkk=0
373 C
374  ncpp=0
375  ncpn=0
376 C DEFINE FERMI MOMENTA/ENERGIES FOR PROJECTILE
377 C
378  pxfe=0.0
379  pyfe=0.0
380  pzfe=0.0
381  DO 50 kkk=1,ip
382  nhkk=nhkk+1
383 C IF (JSSH(KKK).GT.0) THEN
384  isthkk(nhkk)=11
385 C ELSE
386 C ISTHKK(NHKK)=13
387 C ENDIF
388 C*
389  kproj=ijproj
390  phkk(1,nhkk)=0.
391  phkk(2,nhkk)=0.
392  phkk(3,nhkk)=0.
393  phkk(4,nhkk)=aam(kproj)
394  phkk(5,nhkk)=aam(kproj)
395 C
396  kkproj(kkk)=kproj
397  idhkk(nhkk)=mpdgha(kproj)
398  jmohkk(1,nhkk)=0
399  jmohkk(2,nhkk)=0
400  jdahkk(1,nhkk)=0
401  jdahkk(2,nhkk)=0
402 C
403  phkk(5,nhkk)=aam(kproj)
404  vhkk(1,nhkk)=pkoo(1,kkk)*1.e-12
405  vhkk(2,nhkk)=pkoo(2,kkk)*1.e-12
406  vhkk(3,nhkk)=pkoo(3,kkk)*1.e-12
407  vhkk(4,nhkk)=0.
408  whkk(1,nhkk)=pkoo(1,kkk)*1.e-12
409  whkk(2,nhkk)=pkoo(2,kkk)*1.e-12
410  whkk(3,nhkk)=pkoo(3,kkk)*1.e-12
411  whkk(4,nhkk)=0.
412  jhkknp(kkk)=nhkk
413 C
414  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
415  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
416  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
417 
418  1050 FORMAT (i6,i4,5i6,9e10.2)
419 C
420  50 CONTINUE
421 C
422 C-----------------------------------------------------------------------
423 C STORE TARGET HADRON/NUCLEONS INTO /HKKEVT/
424 C - PROJECTILE CENTRE AT ORIGIN IN SPACE
425 C - TARGET SHIFTED IN X DIRECTION BY
426 C IMPACT PARAMETER 'BIMP'
427 C
428 C - SAMPLING OF NUCLEON TYPES
429 C - CONSISTENCY CHECK
430 C FOR SAMPLED P/N NUMBERS
431 C - INTERACTING TARGETS ISTHKK=12
432 C NONINTERACTING ... ISTHKK=14
433 C-----------
434 C---------------------
435  nhadri=0
436  nctp=0
437  nctn=0
438 C
439  txfe=0.0
440  tyfe=0.0
441  tzfe=0.0
442  DO 70 kkk=1,it
443  nhkk=nhkk+1
444 C IF (JTSH(KKK).GT.0) THEN
445 C ISTHKK(NHKK)=12
446 C NHADRI=NHADRI+1
447 C IF (NHADRI.EQ.1) IHTAWW=NHKK
448 C IF (EPN.LE.EHADTW) THEN
449 C IF (NHADRI.GT.1) ISTHKK(NHKK)=14
450 C ENDIF
451 C ELSE
452  isthkk(nhkk)=14
453 C ENDIF
454  IF(it.GE.2)THEN
455  frtneu=float(itn)/atnuc
456  samtes=rndm(v)
457  IF(samtes.LT.frtneu.AND.nctn.LT.itn) THEN
458  ktarg=8
459  nctn=nctn + 1
460  ELSEIF(samtes.GE.frpneu.AND.nctp.LT.itz) THEN
461  ktarg=1
462  nctp=nctp + 1
463  ELSEIF(nctn.LT.itn) THEN
464  ktarg=8
465  nctn=nctn + 1
466  ELSEIF(nctp.LT.itz) THEN
467  ktarg=1
468  nctp=nctp + 1
469  ENDIF
470 C
471  IF(ktarg.EQ.1) THEN
472  pferm = tamfep
473  ELSE
474  pferm = tamfen
475  ENDIF
476  CALL fer4m(pferm,fpx,fpy,fpz,fe,ktarg)
477  txfe=txfe + fpx
478  tyfe=tyfe + fpy
479  tzfe=tzfe + fpz
480  phkk(1,nhkk)=fpx
481  phkk(2,nhkk)=fpy
482  phkk(3,nhkk)=fpz
483  phkk(4,nhkk)=fe
484  phkk(5,nhkk)=aam(ktarg)
485  ELSE
486  phkk(1,nhkk)=0.
487  phkk(2,nhkk)=0.
488  phkk(3,nhkk)=0.
489  phkk(4,nhkk)=aam(ktarg)
490  phkk(5,nhkk)=aam(ktarg)
491  ENDIF
492 C
493  kktarg(kkk)=ktarg
494  idhkk(nhkk)=mpdgha(ktarg)
495  jmohkk(1,nhkk)=0
496  jmohkk(2,nhkk)=0
497  jdahkk(1,nhkk)=0
498  jdahkk(2,nhkk)=0
499  vhkk(1,nhkk)=(tkoo(1,kkk)+bimp)*1.e-12
500  vhkk(2,nhkk)=tkoo(2,kkk)*1.e-12
501  vhkk(3,nhkk)=tkoo(3,kkk)*1.e-12
502  vhkk(4,nhkk)=0.
503  whkk(1,nhkk)=(tkoo(1,kkk)+bimp)*1.e-12
504  whkk(2,nhkk)=tkoo(2,kkk)*1.e-12
505  whkk(3,nhkk)=tkoo(3,kkk)*1.e-12
506  whkk(4,nhkk)=0.
507  jhkknt(kkk)=nhkk
508 C
509  IF (iphkk.GE.2) WRITE(6,1050) nhkk,isthkk(nhkk),idhkk(nhkk),
510  + jmohkk(1,nhkk),jmohkk(2,nhkk), jdahkk(1,nhkk),jdahkk(2,nhkk),
511  + (phkk(khkk,nhkk),khkk=1,5), (vhkk(khkk,nhkk),khkk=1,4)
512 
513 C
514  70 CONTINUE
515 C balance Sampled Fermi momenta
516  IF(it.GE.2) THEN
517  tasuma=itz*aam(1) + (it-itz)*aam(8)
518  tasubi=0.0
519  tamasu=0.0
520  txfe=txfe/it
521  tyfe=tyfe/it
522  tzfe=tzfe/it
523  DO 80 kkk=1,it
524  ihkk=kkk + ip
525  phkk(1,ihkk)=phkk(1,ihkk) - txfe
526  phkk(2,ihkk)=phkk(2,ihkk) - tyfe
527  phkk(3,ihkk)=phkk(3,ihkk) - tzfe
528  phkk(4,ihkk)=sqrt(phkk(5,ihkk)** 2+ phkk(1,ihkk)** 2+ phkk
529  + (2,ihkk)** 2+ phkk(3,ihkk)**2)
530  itsec=mcihad(idhkk(ihkk))
531  tasubi=tasubi + phkk(4,ihkk) - phkk(5,ihkk) - taepot(itsec)
532  tamasu=tamasu + phkk(4,ihkk) - taepot(itsec)
533  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
534  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
535  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
536  80 CONTINUE
537 C*** definition of initial state
538  tabi=-ebind(it,itz)
539  tama=(it-itz)*aam(8) + itz*aam(1) + tabi
540  taimma=tama - tamasu
541  ENDIF
542 C
543  IF(ipev.GT.2) THEN
544  WRITE(6,'(/A/5X,A/5X,4(1PE11.3))') ' KKEVT: FERMI MOMENTA',
545  + 'PRMFEP,PRMFEN, TAMFEP,TAMFEN', prmfep,prmfen, tamfep,tamfen
546 
547  ENDIF
548 C-----------------------------------------------------------------------
549  iflagd = 0
550 C-----------------------------------------------------------------------
551 C
552  IF (ipev.GE.6) THEN
553  itum=max0(ip,it,nn)
554  WRITE(6,'(A,I10)')' KKEVT ITUM loop limit',itum
555  WRITE(6,'(A,2A)') ' KKEVT (AFTER XKSAMP):',
556  + ' JSSH, JSSHS, JTSH, JTSHS, INTER1, INTER2',
557  + ' PKOO(1),PKOO(2),PKOO(3), TKOO(1),TKOO(2),TKOO(3)'
558  DO 100 kkk=1,itum
559  WRITE (6,'(6I5,6(1PE11.3))') jssh(kkk),jsshs(kkk),jtsh(kkk),
560  + jtshs(kkk), inter1(kkk),inter2(kkk), pkoo(1,kkk),pkoo(2,kkk),
561  + pkoo(3,kkk), tkoo(1,kkk),tkoo(2,kkk),tkoo(3,kkk)
562 
563 
564  100 CONTINUE
565  ENDIF
566 C-----------------------------------------------------------------------
567 C TRANSFORM MOMENTA OF INTERACTING NUCLEONS
568 C (INCLUDING FERMI MOMENTA FROM NUCLEUS REST FRAMES)
569 C INTO NUCLEON-NUCLEON CMS (DEFINED WITHOUT FERMI MOM.
570  IF(ipev.GE.2)WRITE(6,'(A)')' KKEVT before NUCMOM'
571  DO 7745 ihkk=1,nhkk
572  IF (iphkk.GE.2) WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),
573  + jmohkk(1,ihkk),jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),
574  + (phkk(khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
575  7745 CONTINUE
576  CALL nucmom
577  IF(ipev.GE.2)THEN
578  DO iki=1,200
579  WRITE(6,'(A)')' KKEVNU after NUCMOM'
580  ENDDO
581  ENDIF
582  nonust=0
583  nonujt=0
584  nomje=0
585  nomjer=0
586 C
587 C-----------------------------------------------------------------------
588 C-----------------------------------------------------------------------
589 C
590  nhkkh1=nhkk
591 C-----------------------------------------------------------
592 C
593 C
594 C Select target nucleon
595 C
596 C-----------------------------------------------------------
597  ltyp=neutyp
598 C IF(LTYP.EQ.1.OR.LTYP.EQ.3.OR.LTYP.EQ.5)NUCTYP=2112
599 C IF(LTYP.EQ.2.OR.LTYP.EQ.4.OR.LTYP.EQ.6)NUCTYP=2212
600 C Neutrino energy is EPN in lab
601  202 CONTINUE
602  ikta=it*rndm(v)+2.
603  IF(ipev.GE.2)THEN
604  WRITE(6,*)' NEUTYP,NUCTYP,IKTA,IDHKK(IKTA)',
605  * neutyp,nuctyp,ikta,idhkk(ikta)
606  ENDIF
607  IF(idhkk(ikta).EQ.2112) itar=2
608  IF(idhkk(ikta).EQ.2212) itar=1
609  inu=neutyp
610  isthkk(ikta)=12
611  elab=epn
612  cut(10)=elab+1.
613  cut(11)=0.
614  cut(12)=elab+1.
615  cut(13)=0.
616  cut(14)=3.1314
617  lst(22)=itar
618  lst(17)=1
619 C LST(19)=-1
620  lst(8)=0
621 * GRID SUITABLE FOR FIXED TARGET < 300 GEV
622  lst(19)=1
623  plu(1,1)=0.
624  plu(1,2)=0.
625  plu(1,3)=elab
626  plu(1,4)=elab
627  plu(1,5)=0.
628  plu(2,1)=phkk(1,ikta)
629  plu(2,2)=phkk(2,ikta)
630  plu(2,3)=phkk(3,ikta)
631  plu(2,4)=phkk(4,ikta)
632  plu(2,5)=phkk(5,ikta)
633 C Call one lepto event
634  IF(iniqel.EQ.0)CALL linit(0,inu,elab,0.,2)
635  iniqel=iniqel+1
636  plu(1,1)=0.
637  plu(1,2)=0.
638  plu(1,3)=elab
639  plu(1,4)=elab
640  plu(1,5)=0.
641  plu(2,1)=phkk(1,ikta)
642  plu(2,2)=phkk(2,ikta)
643  plu(2,3)=phkk(3,ikta)
644  plu(2,4)=phkk(4,ikta)
645  plu(2,5)=phkk(5,ikta)
646  lst(22)=itar
647  CALL lepto
648 C event in lab frame
649  CALL lframe(3,1)
650  IF(lst(21).NE.0)THEN
651  CALL lulist(1)
652  WRITE(6,*)' event rejected '
653  go to 10
654  ENDIF
655  IF(iniqel.LE.100)WRITE(6,*)' Event ',iniqel
656  IF(iniqel.LE.100)CALL lulist(1)
657 C Write events to file lepto.evt
658  iiii=0
659  DO 205 iii=1,nlu
660  IF(klu(iii,1).EQ.1.OR.iii.LE.2) THEN
661  iiii=iiii+1
662  WRITE(29,'(3I6,5F10.3)')iiii,klu(iii,1),klu(iii,2),
663  * (plu(iii,kk),kk=1,5)
664  ENDIF
665  205 CONTINUE
666  iiii=-1
667  WRITE(29,'(I6)')iiii
668 C ADD particle to HKKEVT COMMON
669  DO 206 iii=4,nlu
670  IF(klu(iii,1).EQ.1)THEN
671  nhkk=nhkk+1
672  isthkk(nhkk)=1
673  idhkk(nhkk)=klu(iii,2)
674  jmohkk(1,nhkk)=ikta
675  jmohkk(2,nhkk)=0
676  jdahkk(1,nhkk)=0
677  jdahkk(2,nhkk)=0
678  phkk(1,nhkk)=plu(iii,1)
679  phkk(2,nhkk)=plu(iii,2)
680  phkk(3,nhkk)=plu(iii,3)
681  phkk(4,nhkk)=plu(iii,4)
682  nrhkk=mcihad(idhkk(nhkk))
683  IF(nrhkk.EQ.1.OR.nrhkk.EQ.8)THEN
684  IF(nrhkk.EQ.1)THEN
685  IF(phkk(4,nhkk).LE.taefep+aam(nrhkk))THEN
686  WRITE(6,*)' Pauli Blocking of p',phkk(4,nhkk),taefep
687  ENDIF
688  ENDIF
689  IF(nrhkk.EQ.8)THEN
690  IF(phkk(4,nhkk).LE.taefen+aam(nrhkk))THEN
691  WRITE(6,*)' Pauli Blocking of n',phkk(4,nhkk),taefen
692  ENDIF
693  ENDIF
694  IF(phkk(4,nhkk)-aam(nrhkk).LE.taepot(nrhkk))THEN
695  isthkk(nhkk)=16
696  ENDIF
697  ENDIF
698  phkk(5,nhkk)=aam(nrhkk)
699  vhkk(1,nhkk)=vhkk(1,ikta)
700  vhkk(2,nhkk)=vhkk(2,ikta)
701  vhkk(3,nhkk)=vhkk(3,ikta)
702  vhkk(4,nhkk)=vhkk(4,ikta)
703  whkk(1,nhkk)=whkk(1,ikta)
704  whkk(2,nhkk)=whkk(2,ikta)
705  whkk(3,nhkk)=whkk(3,ikta)
706  whkk(4,nhkk)=whkk(4,ikta)
707  ENDIF
708  206 CONTINUE
709  201 CONTINUE
710 C
711 C Transform into cms
712  DO 111 i=nhkkh1+1,nhkk
713  pznn=phkk(3,i)
714  enn=phkk(4,i)
715  phkk(3,i)=gacms*pznn-bgcms*enn
716  phkk(4,i)=gacms*enn-bgcms*pznn
717  111 CONTINUE
718 C-----------------------------------------------------------------------
719 C
720 C
721 C-----------------------------------------------------------------------
722 C-----------------------------------------------------------------------
723  IF (ipev.GE.1) THEN
724 C DO IKI=1,200
725  WRITE(6,'(/A/)') ' KKEVT: FINAL LIST OF ENTRIES TO /HKKEVT/'
726 C ENDDO
727  DO 121 ihkk=1,nhkk
728  WRITE(6,1050) ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
729  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
730  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
731 
732  121 CONTINUE
733  ENDIF
734 C
735 C
736  110 CONTINUE
737 C
738 C
739 C
740  RETURN
741  END
Generated on Sat May 25 2013 14:32:28 for Geant4 by   doxygen 1.8.4