C++ Interface to Tauola
tauola-BBB/standalone-F/taumain.F
1 PROGRAM taudem
2C **************
3C NOTE THAT THE ROUTINES ARE NOT LIKE IN CPC DECK THIS IS HISTORICAL !!
4C=======================================================================
5C====================== DECTES : TEST OF TAU DECAY LIBRARY===========
6C====================== KTORY = 1 : INTERFACE OF KORAL-Z TYPE ==========
7C====================== KTORY = 2 : INTERFACE OF KORAL-B TYPE =========
8C=======================================================================
9C COMMON /PAWC/ BLAN(10000)
10 COMMON / / blan(10000)
11 CHARACTER*7 DNAME
12 COMMON / inout / inut,iout
13 dname='KKPI'
14! CALL GLIMIT(20000)
15! CALL GOUTPU(16)
16 inut=5
17 iout=6
18 OPEN(iout,file="./tauola.output")
19 OPEN(inut,file="./dane.dat")
20 ktory=1
21 CALL dectes(ktory)
22 ktory=2
23 CALL dectes(ktory)
24C CALL testresu ! fine tune inputs: masses etc.
25 END
26 SUBROUTINE dectes(KTORY)
27C ************************
28 REAL POL(4)
29 DOUBLE PRECISION HH(4)
30C SWITCHES FOR TAUOLA;
31 COMMON / jaki / jak1,jak2,jakp,jakm,ktom
32 COMMON / idfc / idff
33C I/O UNITS NUMBERS
34 COMMON / inout / inut,iout
35C LUND TYPE IDENTIFIER FOR A1
36 COMMON / idpart / ia1
37C /PTAU/ IS USED IN ROUTINE TRALO4
38 COMMON /ptau/ ptau
39 COMMON / taurad / xk0dec,itdkrc
40 real*8 xk0dec
41 COMMON /testa1/ keya1
42C special switch for tests of dGamma/dQ**2 in a1 decay
43C KEYA1=1 constant width of a1 and rho
44C KEYA1=2 free choice of rho propagator (defined in function FPIK)
45C and free choice of a1 mass and width. function g(Q**2)
46C (see formula 3.48 in Comp. Phys. Comm. 64 (1991) 275)
47C hard coded both in Monte Carlo and in testing distribution.
48C KEYA1=3 function g(Q**2) hardcoded in the Monte Carlo
49C (it is timy to calculate!), but appropriately adjusted in
50C testing distribution.
51C-----------------------------------------------------------------------
52C INITIALIZATION
53C-----------------------------------------------------------------------
54C======================================
55 ninp=inut
56 nout=iout
57 3000 FORMAT(a80)
58 3001 FORMAT(8i2)
59 3002 FORMAT(i10)
60 3003 FORMAT(f10.0)
61 IF (ktory.EQ.1) THEN
62 READ( ninp,3000) testit
63 WRITE(nout,3000) testit
64 READ( ninp,3001) kat1,kat2,kat3,kat4,kat5,kat6
65 READ( ninp,3002) nevt,jak1,jak2,itdkrc
66 READ( ninp,3003) ptau,xk0dec
67 ENDIF
68C======================================
69C control output
70 WRITE(nout,'(6A6/6I6)')
71 $ 'KAT1','KAT2','KAT3','KAT4','KAT5','KAT6',
72 $ kat1 , kat2 , kat3 , kat4 , kat5 , kat6
73 WRITE(nout,'(4A12/4I12)')
74 $ 'NEVT','JAK1','JAK2','ITDKRC',
75 $ nevt, jak1 , jak2 , itdkrc
76 WRITE(nout,'(2A12/2F12.6)')
77 $ 'PTAU','XK0DEC',
78 $ ptau , xk0dec
79C======================================
80 jak=0
81C JAK1=5
82C JAK2=5
83C LUND IDENTIFIER (FOR TAU+) -15
84 IF (ktory.EQ.1) THEN
85 idff=-15
86 ELSE
87 idff= 15
88 ENDIF
89C KTO=1 DENOTES TAU DEFINED BY IDFF (I.E. TAU+)
90C KTO=2 DENOTES THE OPPOSITE (I.E. TAU-)
91 kto=2
92 IF (kto.NE.2) THEN
93 print *, 'for the sake of these tests KTO has to be 2'
94 print *, 'to change tau- to tau+ change IDFF from -15 to 15'
95 stop
96 ENDIF
97C TAU POLARIZATION IN ITS RESTFRAME;
98 pol(1)=0.
99 pol(2)=0.
100 pol(3)=.9
101C TAU MOMENTUM IN GEV;
102C PTAU=CMSENE/2.D0
103C NUMBER OF EVENTS TO BE GENERATED;
104 nevtes=10
105 nevtes=nevt
106 print *, 'NEVTES= ',nevtes
107 WRITE(iout,7011) keya1
108C
109 IF (ktory.EQ.1) THEN
110 WRITE(iout,7001) jak,idff,pol(3),ptau
111 ELSE
112 WRITE(iout,7004) jak,idff,pol(3),ptau
113 ENDIF
114C INITIALISATION OF TAU DECAY PACKAGE TAUOLA
115C ******************************************
116 CALL inimas
117 CALL initdk
118
119 CALL iniphy(0.1d0)
120 IF (ktory.EQ.1) THEN
121 CALL dexay(-1,pol)
122 ELSE
123 CALL dekay(-1,hh)
124 ENDIF
125C-----------------------------------------------------------------------
126C GENERATION
127C-----------------------------------------------------------------------
128 nev=0
129 DO 300 iev=1,nevtes
130 nev=nev+1
131C RESLU INITIALISE THE LUND RECORD
132
133
134 CALL taufil
135C DECAY....
136 IF (ktory.EQ.1) THEN
137 CALL dexay(kto,pol)
138 ELSE
139 CALL dekay(kto,hh)
140 CALL dekay(kto+10,hh)
141 ENDIF
142 CALL luhepc(2)
143 IF(iev.LE.44) THEN
144 WRITE(iout,7002) iev
145 IF (ktory.NE.1) THEN
146 WRITE(iout,7003) hh
147 ENDIF
148C CALL LULIST(11)
149 CALL lulist(2)
150 ENDIF
151 ipri=mod(nev,1000)
152
153 IF(ipri.EQ.1) write(*,*) ' event no: ',nev,' NEVTES: ',nevtes
154 300 CONTINUE
155 301 CONTINUE
156C-----------------------------------------------------------------------
157C POSTGENERATION
158C-----------------------------------------------------------------------
159 IF (ktory.EQ.1) THEN
160 CALL dexay(100,pol)
161 ELSE
162 CALL dekay(100,hh)
163 ENDIF
164 RETURN
165 7001 FORMAT(//4(/1x,15(5h=====))
166 $ /,' ', 19x,' NON INITIALIZED BBB-VERSION OF TAUOLA ',9x,1h ,
167 $ /,' ', 19x,' TESTS OF TAU DECAY ROUTINES ',9x,1h ,
168 $ /,' ', 19x,' INTERFACE OF THE KORAL-Z TYPE ',9x,1h ,
169 $ 2(/,1x,15(5h=====)),
170 $ /,5x ,'JAK =',i7 ,' KEY DEFINING DECAY TYPE ',9x,1h ,
171 $ /,5x ,'IDFF =',i7 ,' LUND IDENTIFIER FOR FIRST TAU ',9x,1h ,
172 $ /,5x ,'POL(3)=',f7.2,' THIRD COMPONENT OF TAU POLARIZ. ',9x,1h ,
173 $ /,5x ,'PTAU =',f7.2,' THIRD COMPONENT OF TAU MOM. GEV ',9x,1h ,
174 $ 2(/,1x,15(5h=====))/)
175 7002 FORMAT(///1x, '===== EVENT NO.',i4,1x,5h=====)
176 7003 FORMAT(5x,'POLARIMETRIC VECTOR: ',
177 $ 7x,'HH(1)',7x,'HH(2)',7x,'HH(3)',7x,'HH(4)',
178 $ /, 5x,' ', 4(1x,f11.8) )
179 7004 FORMAT(//4(/1x,15(5h=====))
180 $ /,' ', 19x,' NON INITIALIZED BBB-VERSION OF TAUOLA ',9x,1h ,
181 $ /,' ', 19x,' TESTS OF TAU DECAY ROUTINES ',9x,1h ,
182 $ /,' ', 19x,' INTERFACE OF THE KORAL-B TYPE ',9x,1h ,
183 $ 2(/,1x,15(5h=====)),
184 $ /,5x ,'JAK =',i7 ,' KEY DEFINING DECAY TYPE ',9x,1h ,
185 $ /,5x ,'IDFF =',i7 ,' LUND IDENTIFIER FOR FIRST TAU ',9x,1h ,
186 $ /,5x ,'POL(3)=',f7.2,' THIRD COMPONENT OF TAU POLARIZ. ',9x,1h ,
187 $ /,5x ,'PTAU =',f7.2,' THIRD COMPONENT OF TAU MOM. GEV ',9x,1h ,
188 $ 2(/,1x,15(5h=====))/)
189 7011 FORMAT(///1x, '===== TYPE OF CURRENT',i4,1x,5h=====)
190 END
191 SUBROUTINE choice(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
192 $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
193 COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
194 * ,ampiz,ampi,amro,gamro,ama1,gama1
195 * ,amk,amkz,amkst,gamkst
196C
197 real*4 amtau,amnuta,amel,amnue,ammu,amnumu
198 * ,ampiz,ampi,amro,gamro,ama1,gama1
199 * ,amk,amkz,amkst,gamkst
200C
201 amrop=1.1
202 gamrop=0.36
203 amom=.782
204 gamom=0.0084
205C XXXXA CORRESPOND TO S2 CHANNEL !
206 IF(mnum.EQ.0) THEN
207 prob1=0.5
208 prob2=0.5
209 amrx =ama1
210 gamrx=gama1
211 amra =amro
212 gamra=gamro
213 amrb =amro
214 gamrb=gamro
215 ELSEIF(mnum.EQ.1) THEN
216 prob1=0.5
217 prob2=0.5
218 amrx =1.57
219 gamrx=0.9
220 amrb =amkst
221 gamrb=gamkst
222 amra =amro
223 gamra=gamro
224 ELSEIF(mnum.EQ.2) THEN
225 prob1=0.5
226 prob2=0.5
227 amrx =1.57
228 gamrx=0.9
229 amrb =amkst
230 gamrb=gamkst
231 amra =amro
232 gamra=gamro
233 ELSEIF(mnum.EQ.3) THEN
234 prob1=0.5
235 prob2=0.5
236 amrx =1.27
237 gamrx=0.3
238 amra =amkst
239 gamra=gamkst
240 amrb =amkst
241 gamrb=gamkst
242 ELSEIF(mnum.EQ.4) THEN
243 prob1=0.5
244 prob2=0.5
245 amrx =1.27
246 gamrx=0.3
247 amra =amkst
248 gamra=gamkst
249 amrb =amkst
250 gamrb=gamkst
251 ELSEIF(mnum.EQ.5) THEN
252 prob1=0.5
253 prob2=0.5
254 amrx =1.27
255 gamrx=0.3
256 amra =amkst
257 gamra=gamkst
258 amrb =amro
259 gamrb=gamro
260 ELSEIF(mnum.EQ.6) THEN
261 prob1=0.4
262 prob2=0.4
263 amrx =1.27
264 gamrx=0.3
265 amra =amro
266 gamra=gamro
267 amrb =amkst
268 gamrb=gamkst
269 ELSEIF(mnum.EQ.7) THEN
270 prob1=0.0
271 prob2=1.0
272 amrx =1.27
273 gamrx=0.9
274 amra =amro
275 gamra=gamro
276 amrb =amro
277 gamrb=gamro
278 ELSEIF(mnum.EQ.8) THEN
279 prob1=0.0
280 prob2=1.0
281 amrx =amrop
282 gamrx=gamrop
283 amrb =amom
284 gamrb=gamom
285 amra =amro
286 gamra=gamro
287 ELSEIF(mnum.EQ.9) THEN
288 prob1=0.5
289 prob2=0.5
290 amrx =ama1
291 gamrx=gama1
292 amra =amro
293 gamra=gamro
294 amrb =amro
295 gamrb=gamro
296 ELSEIF(mnum.EQ.101) THEN
297 prob1=.35
298 prob2=.35
299 amrx =1.2
300 gamrx=.46
301 amrb =amom
302 gamrb=gamom
303 amra =amom
304 gamra=gamom
305 ELSEIF(mnum.EQ.102) THEN
306 prob1=0.0
307 prob2=0.0
308 amrx =1.4
309 gamrx=.6
310 amrb =amom
311 gamrb=gamom
312 amra =amom
313 gamra=gamom
314 ELSEIF(mnum.GE.103.AND.mnum.LE.112) THEN
315 prob1=0.0
316 prob2=0.0
317 amrx =1.4
318 gamrx=.6
319 amrb =amom
320 gamrb=gamom
321 amra =amom
322 gamra=gamom
323
324
325 ELSE
326 prob1=0.0
327 prob2=0.0
328 amrx =ama1
329 gamrx=gama1
330 amra =amro
331 gamra=gamro
332 amrb =amro
333 gamrb=gamro
334 ENDIF
335C
336 IF (rr.LE.prob1) THEN
337 ichan=1
338 ELSEIF(rr.LE.(prob1+prob2)) THEN
339 ichan=2
340 ax =amra
341 gx =gamra
342 amra =amrb
343 gamra=gamrb
344 amrb =ax
345 gamrb=gx
346 px =prob1
347 prob1=prob2
348 prob2=px
349 ELSE
350 ichan=3
351 ENDIF
352C
353 prob3=1.0-prob1-prob2
354 END
355 SUBROUTINE initdk
356* ----------------------------------------------------------------------
357* INITIALISATION OF TAU DECAY PARAMETERS and routines
358*
359* called by : KORALZ
360* ----------------------------------------------------------------------
361
362 COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
363 real*4 gfermi,gv,ga,ccabib,scabib,gamel
364 COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
365 * ,ampiz,ampi,amro,gamro,ama1,gama1
366 * ,amk,amkz,amkst,gamkst
367*
368 real*4 amtau,amnuta,amel,amnue,ammu,amnumu
369 * ,ampiz,ampi,amro,gamro,ama1,gama1
370 * ,amk,amkz,amkst,gamkst
371 COMMON / taubra / gamprt(500),jlist(500),nchan
372 COMMON / taukle / bra1,brk0,brk0b,brks
373 real*4 bra1,brk0,brk0b,brks
374
375 parameter(nmode=86,nm1=0,nm2=11,nm3=19,nm4=22,nm5=21,nm6=13)
376 COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
377 & ,names
378 CHARACTER NAMES(NMODE)*31
379
380 CHARACTER OLDNAMES(7)*31
381 CHARACTER*80 bxINIT
382 parameter(
383 $ bxinit ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
384 $ )
385 real*4 pi,pol1(4)
386*
387*
388* LIST OF BRANCHING RATIOS
389CAM normalised to e nu nutau channel
390CAM enu munu pinu rhonu A1nu Knu K*nu pi
391CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
392
393*AM DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
394*AM
395*AM multipion decays
396*
397* conventions of particles names
398* K-,P-,K+, K0,P-,KB, K-,P0,K0
399* 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
400* P0,P0,K-, K-,P-,P+, P-,KB,P0
401* 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
402* ET,P-,P0 , P-,P0,GM , P-,P0,P0
403* 9, 1, 2 , 1, 2, 8 , 1, 2, 2
404*
405
406C
407 dimension nopik(9,nmode),npik(nmode)
408*AM outgoing multiplicity and flavors of multi-pion /multi-K modes
409 DATA npik / 4, 4, ! old 4scalar
410 a 4, 4, ! new (may 2004)
411 b 4, 4,
412 c 4, 4,
413 d 4, 4,
414 e 4, 4, ! new (may 2004)
415 e 4, 4, ! new (sep 2004)
416 e 4, 4,
417 e 4, 4,
418 e 4, 4,
419 e 4, 4, ! new (sep 2004)
420 1 5,
421 a 5, 5, ! new (may 2004)
422 b 5, 5,
423 c 5, 5,
424 d 5, 5,
425 e 5, 5, ! new (may 2004)
426 a 5, 5, ! new (sep 2004)
427 b 5, 5,
428 c 5, 5,
429 d 5, 5,
430 e 5, 5, ! new (sep 2004)
431 x 5, ! old npi starts here
432 2 6, 6,
433 a 6, 6, ! new (may 2004)
434 b 6, 6, ! new (may 2004)
435 c 6, 6, ! new (may 2004)
436 d 6, 6, ! new (may 2004)
437 e 6, 6, ! new (may 2004)
438 3 3, 3,
439 4 3, 3,
440 5 3, 3,
441 6 3, 3,
442 7 3, ! new (may 2004) and useful
443 a 3, 3, ! new (may 2004)
444 a 3, 3, ! new (may 2004)
445 a 3, 3, ! new (may 2004)
446 a 3, 3, ! new (may 2004)
447 a 3, 3, ! new (may 2004)
448 8 2,
449 9 2, 2, ! new (may 2004)
450 9 2, 2, ! new (may 2004)
451 9 2, 2, ! new (may 2004)
452 9 2, 2, ! new (may 2004)
453 9 2, 2/ ! new (may 2004)
454
455 DATA nopik / -1,-1, 1, 2, 0, 0,3*0, 2, 2, 2,-1, 0, 0,3*0,
456 a 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
457 b 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
458 c 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
459 d 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
460 e 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
461 a 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
462 b 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
463 c 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
464 d 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
465 e 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
466 1 -1,-1, 1, 2, 2, 0,3*0,
467 a -1,-1, 1, 2, 2, 0,3*0, 2, 2, 2, 2, 2, 0,3*0, ! new (may 2004)
468 a 1,-1,-1, 2, 2, 0,3*0, -1, 2, 2, 2, 2, 0,3*0, ! new (may 2004)
469 a -1, 1, 1,-1,-1, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
470 a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
471 a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
472 a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
473 a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
474 a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
475 a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
476 a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
477 x -1,-1,-1, 1, 1, 0,3*0, ! old npi starts here
478 2 -1,-1,-1, 1, 1, 2,3*0, -1,-1, 1, 2, 2, 2,3*0,
479 a -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
480 b -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
481 c -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
482 d -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
483 e -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
484 3 -3,-1, 3, 0, 0, 0,3*0, -4,-1, 4, 0, 0, 0,3*0,
485 4 -3, 2,-4, 0, 0, 0,3*0, 2, 2,-3, 0, 0, 0,3*0,
486 5 -3,-1, 1, 0, 0, 0,3*0, -1, 4, 2, 0, 0, 0,3*0,
487 6 9,-1, 2, 0, 0, 0,3*0, -1, 2, 8, 0, 0, 0,3*0,
488
489
490C AJWMOD fix sign bug, 2/22/99
491 7 2, 2,-1, 0, 0, 0,3*0, ! new (may 2004) but useful
492 7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
493 7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
494 7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
495 7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
496 7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
497
498 8 -3,-4, 0, 0, 0, 0,3*0,
499 8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
500 8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
501 8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
502 8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
503 8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0 /! new (may 2004)
504
505
506* LIST OF BRANCHING RATIOS
507 nchan = nmode + 7
508 DO 1 i = 1,500
509 IF (i.LE.nchan) THEN
510 jlist(i) = i
511
512 IF(i.EQ. 1) gamprt(i) =0.1800
513 IF(i.EQ. 2) gamprt(i) =0.1751
514 IF(i.EQ. 3) gamprt(i) =0.1110
515 IF(i.EQ. 4) gamprt(i) =0.2515
516 IF(i.EQ. 5) gamprt(i) =0.1790 /2
517 IF(i.EQ. 6) gamprt(i) =0.0071
518 IF(i.EQ. 7) gamprt(i) =0.0134
519 IF(i.EQ. 8) gamprt(i) =0.0450
520 IF(i.EQ. 9) gamprt(i) =0.0100
521
522 IF(i.EQ.30) gamprt(i) =0.0009
523 IF(i.EQ.33) gamprt(i) =0.004
524 IF(i.EQ.34) gamprt(i) =0.002
525 IF(i.EQ.35) gamprt(i) =0.001
526
527 IF(i.EQ.51) gamprt(i) =0.0004
528 IF(i.EQ.52) gamprt(i) =0.0003
529 IF(i.EQ.53) gamprt(i) =0.0005
530
531 IF(i.EQ.64) gamprt(i) =0.0015
532 IF(i.EQ.65) gamprt(i) =0.0015
533 IF(i.EQ.66) gamprt(i) =0.0015
534 IF(i.EQ.67) gamprt(i) =0.0005
535 IF(i.EQ.68) gamprt(i) =0.0050
536 IF(i.EQ.69) gamprt(i) =0.0055
537 IF(i.EQ.70) gamprt(i) =0.0017
538 IF(i.EQ.71) gamprt(i) =0.0013
539 IF(i.EQ.72) gamprt(i) =0.1790 /2
540
541 IF(i.EQ.83) gamprt(i) =0.0010
542
543 IF(i.EQ. 1) oldnames(i)=' TAU- --> E- '
544 IF(i.EQ. 2) oldnames(i)=' TAU- --> MU- '
545 IF(i.EQ. 3) oldnames(i)=' TAU- --> PI- '
546 IF(i.EQ. 4) oldnames(i)=' TAU- --> PI-, PI0 '
547 IF(i.EQ. 5) oldnames(i)=' TAU- --> PI-, PI-, PI+ '
548 IF(i.EQ. 6) oldnames(i)=' TAU- --> K- '
549 IF(i.EQ. 7) oldnames(i)=' TAU- --> K*- (two subch) '
550 IF(i.EQ. 8) names(i-7)=' TAU- --> 2PI-, PI0, PI+ '
551 IF(i.EQ. 9) names(i-7)=' TAU- --> 3PI0, PI- '
552
553 IF(i.EQ.10) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
554 IF(i.EQ.11) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
555 IF(i.EQ.12) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
556 IF(i.EQ.13) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
557 IF(i.EQ.14) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
558 IF(i.EQ.15) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
559 IF(i.EQ.16) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
560 IF(i.EQ.17) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
561 IF(i.EQ.18) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
562 IF(i.EQ.19) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
563 IF(i.EQ.20) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
564 IF(i.EQ.21) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
565 IF(i.EQ.22) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
566 IF(i.EQ.23) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
567 IF(i.EQ.24) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
568 IF(i.EQ.25) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
569 IF(i.EQ.26) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
570 IF(i.EQ.27) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
571 IF(i.EQ.28) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
572 IF(i.EQ.29) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
573
574
575 IF(i.EQ.30) names(i-7)=' TAU- --> 2PI-, PI+, 2PI0 old'
576
577 IF(i.EQ.31) names(i-7)=' TAU- --> a1 --> rho omega ' ! (may 2004)
578 IF(i.EQ.32) names(i-7)=' TAU- --> benchmark curr ' ! (may 2004)
579 IF(i.EQ.33) names(i-7)=' TAU- --> 2PI0, 2PI-, PI+ ' ! (may 2004)
580 IF(i.EQ.34) names(i-7)=' TAU- --> PI- 4PI0 ' ! (may 2004)
581 IF(i.EQ.35) names(i-7)=' TAU- --> 3PI- 2PI+ ' ! (may 2004)
582 IF(i.EQ.36) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
583 IF(i.EQ.37) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
584 IF(i.EQ.38) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
585 IF(i.EQ.39) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
586 IF(i.EQ.40) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
587
588 IF(i.EQ.41) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
589 IF(i.EQ.42) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
590 IF(i.EQ.43) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
591 IF(i.EQ.44) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
592 IF(i.EQ.45) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
593 IF(i.EQ.46) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
594 IF(i.EQ.47) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
595 IF(i.EQ.48) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
596 IF(i.EQ.49) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
597 IF(i.EQ.50) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
598
599 IF(i.EQ.51) names(i-7)=' TAU- --> 3PI-, 2PI+, '
600 IF(i.EQ.52) names(i-7)=' TAU- --> 3PI-, 2PI+, PI0 '
601 IF(i.EQ.53) names(i-7)=' TAU- --> 2PI-, PI+, 3PI0 '
602 IF(i.EQ.54) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
603 IF(i.EQ.55) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
604 IF(i.EQ.56) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
605 IF(i.EQ.57) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
606 IF(i.EQ.58) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
607 IF(i.EQ.59) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
608 IF(i.EQ.60) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
609 IF(i.EQ.61) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
610 IF(i.EQ.62) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
611 IF(i.EQ.63) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
612
613 IF(i.EQ.64) names(i-7)=' TAU- --> K-, PI-, K+ '
614 IF(i.EQ.65) names(i-7)=' TAU- --> K0, PI-, K0B '
615
616 IF(i.EQ.66) names(i-7)=' TAU- --> K-, K0, PI0 '
617
618 IF(i.EQ.67) names(i-7)=' TAU- --> PI0 PI0 K- '
619 IF(i.EQ.68) names(i-7)=' TAU- --> K- PI- PI+ '
620 IF(i.EQ.69) names(i-7)=' TAU- --> PI- K0B PI0 '
621 IF(i.EQ.70) names(i-7)=' TAU- --> ETA PI- PI0 '
622 IF(i.EQ.71) names(i-7)=' TAU- --> PI- PI0 GAM '
623 IF(i.EQ.72) names(i-7)=' TAU- --> PI- PI0 PI0 '
624 IF(i.EQ.73) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
625 IF(i.EQ.74) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
626 IF(i.EQ.75) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
627 IF(i.EQ.76) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
628 IF(i.EQ.77) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
629 IF(i.EQ.78) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
630 IF(i.EQ.79) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
631 IF(i.EQ.80) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
632 IF(i.EQ.81) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
633 IF(i.EQ.82) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
634
635
636 IF(i.EQ.83) names(i-7)=' TAU- --> K- K0 '
637 IF(i.EQ.84) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
638 IF(i.EQ.85) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
639 IF(i.EQ.86) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
640 IF(i.EQ.87) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
641 IF(i.EQ.88) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
642 IF(i.EQ.89) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
643 IF(i.EQ.90) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
644 IF(i.EQ.91) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
645 IF(i.EQ.92) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
646 IF(i.EQ.93) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
647
648 ELSE
649 jlist(i) = 0
650 gamprt(i) = 0.
651 ENDIF
652 1 CONTINUE
653 DO i=1,nmode
654 mulpik(i)=npik(i)
655 DO j=1,mulpik(i)
656 idffin(j,i)=nopik(j,i)
657 ENDDO
658 ENDDO
659 DO i=1,nchan
660 gamprt(i) = 1d0/nchan
661 ENDDO
662 gamprt(31)=gamprt(31)*0.001
663 gamprt(32)=gamprt(32)*0.001
664 do k=1,10 ! these are brs for empty slots prepared for new channels
665 gamprt(36+k)=gamprt(36+k)*0.001
666 gamprt(30-k)=gamprt(30-k)*0.001
667 gamprt(30+10+k)=gamprt(30+10+k)*0.001
668 gamprt(30-10-k)=gamprt(30-10-k)*0.001
669
670 gamprt(53+k)=gamprt(53+k)*0.001
671 gamprt(72+k)=gamprt(72+k)*0.001
672 gamprt(83+k)=gamprt(83+k)*0.001
673 enddo
674 gamprt(72)=gamprt(72)/2
675 gamprt(5)=gamprt(5)/2
676
677*
678*
679* --- COEFFICIENTS TO FIX RATIO OF:
680* --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
681* --- PROBABILITY OF K0 TO BE KS
682* --- PROBABILITY OF K0B TO BE KS
683* --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
684* --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
685* --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
686* --- NEGLECTS MASS-PHASE SPACE EFFECTS
687 bra1=1d0 ! 0.5
688 brk0=0.5
689 brk0b=0.5
690 brks=0.6667
691*
692
693 gfermi = 1.16637e-5
694 ccabib = 0.975
695 gv = 1.0
696 ga =-1.0
697
698
699
700* ZW 13.04.89 HERE WAS AN ERROR
701 scabib = sqrt(1.-ccabib**2)
702 pi =4.*atan(1.)
703 gamel = gfermi**2*amtau**5/(192*pi**3)
704*
705* CALL DEXAY(-1,pol1)
706*
707 RETURN
708 END
709 FUNCTION dcdmas(IDENT)
710 COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
711 * ,ampiz,ampi,amro,gamro,ama1,gama1
712 * ,amk,amkz,amkst,gamkst
713*
714 real*4 amtau,amnuta,amel,amnue,ammu,amnumu
715 * ,ampiz,ampi,amro,gamro,ama1,gama1
716 * ,amk,amkz,amkst,gamkst
717 IF (ident.EQ. 1) THEN
718 apkmas=ampi
719 ELSEIF (ident.EQ.-1) THEN
720 apkmas=ampi
721 ELSEIF (ident.EQ. 2) THEN
722 apkmas=ampiz
723 ELSEIF (ident.EQ.-2) THEN
724 apkmas=ampiz
725 ELSEIF (ident.EQ. 3) THEN
726 apkmas=amk
727 ELSEIF (ident.EQ.-3) THEN
728 apkmas=amk
729 ELSEIF (ident.EQ. 4) THEN
730 apkmas=amkz
731 ELSEIF (ident.EQ.-4) THEN
732 apkmas=amkz
733 ELSEIF (ident.EQ. 8) THEN
734 apkmas=0.0001
735 ELSEIF (ident.EQ.-8) THEN
736 apkmas=0.0001
737 ELSEIF (ident.EQ. 9) THEN
738 apkmas=0.5488
739 ELSEIF (ident.EQ.-9) THEN
740 apkmas=0.5488
741 ELSE
742 print *, 'STOP IN APKMAS, WRONG IDENT=',ident
743 stop
744 ENDIF
745 dcdmas=apkmas
746 END
747 FUNCTION lunpik(ID,ISGN)
748 COMMON / taukle / bra1,brk0,brk0b,brks
749 real*4 bra1,brk0,brk0b,brks
750 real*4 xio(1)
751 ident=id*isgn
752
753 IF (ident.EQ. 1) THEN
754 ipkdef=-211
755 ELSEIF (ident.EQ.-1) THEN
756 ipkdef= 211
757 ELSEIF (ident.EQ. 2) THEN
758 ipkdef=111
759 ELSEIF (ident.EQ.-2) THEN
760 ipkdef=111
761 ELSEIF (ident.EQ. 3) THEN
762 ipkdef=-321
763 ELSEIF (ident.EQ.-3) THEN
764 ipkdef= 321
765
766 ELSEIF (ident.EQ. 4) THEN
767*
768* K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
769 CALL ranmar(xio,1)
770 IF (xio(1).GT.brk0) THEN
771 ipkdef= 130
772 ELSE
773 ipkdef= 310
774 ENDIF
775 ELSEIF (ident.EQ.-4) THEN
776*
777* K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
778 CALL ranmar(xio,1)
779 IF (xio(1).GT.brk0b) THEN
780 ipkdef= 130
781 ELSE
782 ipkdef= 310
783 ENDIF
784 ELSEIF (ident.EQ. 8) THEN
785 ipkdef= 22
786 ELSEIF (ident.EQ.-8) THEN
787 ipkdef= 22
788 ELSEIF (ident.EQ. 9) THEN
789 ipkdef= 221
790 ELSEIF (ident.EQ.-9) THEN
791 ipkdef= 221
792 ELSE
793 print *, 'STOP IN IPKDEF, WRONG IDENT=',ident
794 stop
795 ENDIF
796 lunpik=ipkdef
797 END
798
799
800
801
802 SUBROUTINE taurdf(KTO)
803C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
804C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
805C CONTENTS
806 COMMON / taukle / bra1,brk0,brk0b,brks
807 real*4 bra1,brk0,brk0b,brks
808 COMMON / taubra / gamprt(500),jlist(500),nchan
809 IF (kto.EQ.1) THEN
810C ==================
811C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
812 bra1 = pkorb(4,1)
813 brks = pkorb(4,3)
814 brk0 = pkorb(4,5)
815 brk0b = pkorb(4,6)
816 ELSE
817C ====
818C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
819 bra1 = pkorb(4,2)
820 brks = pkorb(4,4)
821 brk0 = pkorb(4,5)
822 brk0b = pkorb(4,6)
823 ENDIF
824C =====
825 END
826
827
828 SUBROUTINE iniphy(XK00)
829* ----------------------------------------------------------------------
830* INITIALISATION OF PARAMETERS
831* USED IN QED and/or GSW ROUTINES
832* ----------------------------------------------------------------------
833 COMMON / qedprm /alfinv,alfpi,xk0
834 real*8 alfinv,alfpi,xk0
835 real*8 pi8,xk00
836*
837 pi8 = 4.d0*datan(1.d0)
838 alfinv = 137.03604d0
839 alfpi = 1d0/(alfinv*pi8)
840 xk0=xk00
841 END
842
843 SUBROUTINE inimas
844C ----------------------------------------------------------------------
845C INITIALISATION OF MASSES
846C
847C called by : KORALZ
848C ----------------------------------------------------------------------
849 COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
850 * ,ampiz,ampi,amro,gamro,ama1,gama1
851 * ,amk,amkz,amkst,gamkst
852*
853 real*4 amtau,amnuta,amel,amnue,ammu,amnumu
854 * ,ampiz,ampi,amro,gamro,ama1,gama1
855 * ,amk,amkz,amkst,gamkst
856C
857C IN-COMING / OUT-GOING FERMION MASSES
858 amtau = 1.7842
859C --- let us update tau mass ...
860 amtau = 1.777
861 amnuta = 0.010
862 amel = 0.0005111
863 amnue = 0.0
864 ammu = 0.105659
865 amnumu = 0.0
866*
867* MASSES USED IN TAU DECAYS
868
869 ampiz = 0.134964
870 ampi = 0.139568
871 amro = 0.773
872 gamro = 0.145
873*C GAMRO = 0.666
874 ama1 = 1.251
875 gama1 = 0.599
876 amk = 0.493667
877 amkz = 0.49772
878 amkst = 0.8921
879 gamkst = 0.0513
880C
881C
882C IN-COMING / OUT-GOING FERMION MASSES
883!! AMNUTA = PKORB(1,2)
884!! AMNUE = PKORB(1,4)
885!! AMNUMU = PKORB(1,6)
886C
887C MASSES USED IN TAU DECAYS Cleo settings
888!! AMPIZ = PKORB(1,7)
889!! AMPI = PKORB(1,8)
890!! AMRO = PKORB(1,9)
891!! GAMRO = PKORB(2,9)
892 ama1 = 1.275 !! PKORB(1,10)
893 gama1 = 0.615 !! PKORB(2,10)
894!! AMK = PKORB(1,11)
895!! AMKZ = PKORB(1,12)
896!! AMKST = PKORB(1,13)
897!! GAMKST = PKORB(2,13)
898C
899
900
901 RETURN
902 END
903 SUBROUTINE taufil
904C *****************
905C SUBSITUTE OF tau PRODUCTION GENERATOR
906C
907 COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
908 * ,ampiz,ampi,amro,gamro,ama1,gama1
909 * ,amk,amkz,amkst,gamkst
910C
911 real*4 amtau,amnuta,amel,amnue,ammu,amnumu
912 * ,ampiz,ampi,amro,gamro,ama1,gama1
913 * ,amk,amkz,amkst,gamkst
914 COMMON / idfc / idff
915C positions of taus in the LUND common block
916C it will be used by TAUOLA output routines.
917 COMMON /taupos / npa,npb
918 dimension xpb1(4),xpb2(4),aqf1(4),aqf2(4)
919C
920C --- DEFINING DUMMY EVENTS MOMENTA
921 DO 4 k=1,3
922 xpb1(k)=0.0
923 xpb2(k)=0.0
924 aqf1(k)=0.0
925 aqf2(k)=0.0
926 4 CONTINUE
927 aqf1(4)=amtau
928 aqf2(4)=amtau
929C --- TAU MOMENTA
930 CALL tralo4(1,aqf1,aqf1,am)
931 CALL tralo4(2,aqf2,aqf2,am)
932C --- BEAMS MOMENTA AND IDENTIFIERS
933 kfb1= 11*idff/iabs(idff)
934 kfb2=-11*idff/iabs(idff)
935 xpb1(4)= aqf1(4)
936 xpb1(3)= aqf1(4)
937 IF(aqf1(3).NE.0.0)
938 $ xpb1(3)= aqf1(4)*aqf1(3)/abs(aqf1(3))
939 xpb2(4)= aqf2(4)
940 xpb2(3)=-aqf2(4)
941 IF(aqf2(3).NE.0.0)
942 $ xpb2(3)= aqf2(4)*aqf2(3)/abs(aqf2(3))
943C --- Position of first and second tau in LUND common
944 npa=3
945 npb=4
946C --- FILL TO LUND COMMON
947 CALL filhep( 1,3, kfb1,0,0,0,0,xpb1, amel,.true.)
948 CALL filhep( 2,3, kfb2,0,0,0,0,xpb2, amel,.true.)
949 CALL filhep(npa,1, idff,1,2,0,0,aqf1,amtau,.true.)
950 CALL filhep(npb,1,-idff,1,2,0,0,aqf2,amtau,.true.)
951 END
952 SUBROUTINE tralo4(KTO,P,Q,AM)
953C **************************
954C SUBSITUTE OF TRALO4
955 REAL P(4),Q(4)
956C
957 COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
958 * ,ampiz,ampi,amro,gamro,ama1,gama1
959 * ,amk,amkz,amkst,gamkst
960C
961 real*4 amtau,amnuta,amel,amnue,ammu,amnumu
962 * ,ampiz,ampi,amro,gamro,ama1,gama1
963 * ,amk,amkz,amkst,gamkst
964 COMMON /ptau/ ptau
965 am=amas4(p)
966 etau=sqrt(ptau**2+amtau**2)
967 exe=(etau+ptau)/amtau
968 IF(kto.EQ.2) exe=(etau-ptau)/amtau
969 CALL bostr3(exe,p,q)
970C ======================================================================
971C END OF THE TEST JOB
972C ======================================================================
973 END
974 SUBROUTINE filhep(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
975C ----------------------------------------------------------------------
976C this subroutine fills one entry into the HEPEVT common
977C and updates the information for affected mother entries
978C
979C written by Martin W. Gruenewald (91/01/28)
980C
981C called by : ZTOHEP,BTOHEP,DWLUxy
982C ----------------------------------------------------------------------
983C
984#include "../../include/HEPEVT.h"
985C PARAMETER (NMXHEP=2000)
986C COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
987C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
988C SAVE /HEPEVT/
989C COMMON/PHOQED/QEDRAD(NMXHEP)
990C LOGICAL QEDRAD
991C SAVE /PHOQED/
992 LOGICAL PHFLAG
993C
994 real*4 p4(4)
995C
996C check address mode
997 IF (n.EQ.0) THEN
998C
999C append mode
1000 ihep=nhep+1
1001 ELSE IF (n.GT.0) THEN
1002C
1003C absolute position
1004 ihep=n
1005 ELSE
1006C
1007C relative position
1008 ihep=nhep+n
1009 END IF
1010C
1011C check on IHEP
1012 IF ((ihep.LE.0).OR.(ihep.GT.nmxhep)) RETURN
1013C
1014C add entry
1015 nhep=ihep
1016 isthep(ihep)=ist
1017 idhep(ihep)=id
1018 jmohep(1,ihep)=jmo1
1019 IF(jmo1.LT.0)jmohep(1,ihep)=jmohep(1,ihep)+ihep
1020 jmohep(2,ihep)=jmo2
1021 IF(jmo2.LT.0)jmohep(2,ihep)=jmohep(2,ihep)+ihep
1022 jdahep(1,ihep)=jda1
1023 jdahep(2,ihep)=jda2
1024C
1025 DO i=1,4
1026 phep(i,ihep)=p4(i)
1027C
1028C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
1029 vhep(i,ihep)=0.0
1030 END DO
1031 phep(5,ihep)=pinv
1032C FLAG FOR PHOTOS...
1033 qedrad(ihep)=phflag
1034C
1035C update process:
1036 DO ip=jmohep(1,ihep),jmohep(2,ihep)
1037 IF(ip.GT.0)THEN
1038C
1039C if there is a daughter at IHEP, mother entry at IP has decayed
1040 IF(isthep(ip).EQ.1)isthep(ip)=2
1041C
1042C and daughter pointers of mother entry must be updated
1043 IF(jdahep(1,ip).EQ.0)THEN
1044 jdahep(1,ip)=ihep
1045 jdahep(2,ip)=ihep
1046 ELSE
1047 jdahep(2,ip)=max(ihep,jdahep(2,ip))
1048 END IF
1049 END IF
1050 END DO
1051C
1052 RETURN
1053 END