C++InterfacetoTauola
BBB/standalone-F/taumain.f
1  PROGRAM taudem
2 C **************
3 C NOTE THAT THE ROUTINES ARE NOT LIKE IN CPC DECK THIS IS HISTORICAL !!
4 C=======================================================================
5 C====================== DECTES : TEST OF TAU DECAY LIBRARY===========
6 C====================== KTORY = 1 : INTERFACE OF KORAL-Z TYPE ==========
7 C====================== KTORY = 2 : INTERFACE OF KORAL-B TYPE =========
8 C=======================================================================
9 C 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)
24 C CALL testresu ! fine tune inputs: masses etc.
25  END
26  SUBROUTINE dectes(KTORY)
27 C ************************
28  REAL POL(4)
29  DOUBLE PRECISION HH(4)
30 C SWITCHES FOR TAUOLA;
31  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
32  COMMON / idfc / idff
33 C I/O UNITS NUMBERS
34  COMMON / inout / inut,iout
35 C LUND TYPE IDENTIFIER FOR A1
36  COMMON / idpart / ia1
37 C /PTAU/ IS USED IN ROUTINE TRALO4
38  COMMON /ptau/ ptau
39  COMMON / taurad / xk0dec,itdkrc
40  REAL*8 XK0DEC
41  COMMON /testa1/ keya1
42 C special switch for tests of dGamma/dQ**2 in a1 decay
43 C KEYA1=1 constant width of a1 and rho
44 C KEYA1=2 free choice of rho propagator (defined in function FPIK)
45 C and free choice of a1 mass and width. function g(Q**2)
46 C (see formula 3.48 in Comp. Phys. Comm. 64 (1991) 275)
47 C hard coded both in Monte Carlo and in testing distribution.
48 C KEYA1=3 function g(Q**2) hardcoded in the Monte Carlo
49 C (it is timy to calculate!), but appropriately adjusted in
50 C testing distribution.
51 C-----------------------------------------------------------------------
52 C INITIALIZATION
53 C-----------------------------------------------------------------------
54 C======================================
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
68 C======================================
69 C 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
79 C======================================
80  jak=0
81 C JAK1=5
82 C JAK2=5
83 C LUND IDENTIFIER (FOR TAU+) -15
84  IF (ktory.EQ.1) THEN
85  idff=-15
86  ELSE
87  idff= 15
88  ENDIF
89 C KTO=1 DENOTES TAU DEFINED BY IDFF (I.E. TAU+)
90 C 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
97 C TAU POLARIZATION IN ITS RESTFRAME;
98  pol(1)=0.
99  pol(2)=0.
100  pol(3)=.9
101 C TAU MOMENTUM IN GEV;
102 C PTAU=CMSENE/2.D0
103 C NUMBER OF EVENTS TO BE GENERATED;
104  nevtes=10
105  nevtes=nevt
106  print *, 'NEVTES= ',nevtes
107  WRITE(iout,7011) keya1
108 C
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
114 C INITIALISATION OF TAU DECAY PACKAGE TAUOLA
115 C ******************************************
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
125 C-----------------------------------------------------------------------
126 C GENERATION
127 C-----------------------------------------------------------------------
128  nev=0
129  DO 300 iev=1,nevtes
130  nev=nev+1
131 C RESLU INITIALISE THE LUND RECORD
132 
133 
134  CALL taufil
135 C 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
148 C 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
156 C-----------------------------------------------------------------------
157 C POSTGENERATION
158 C-----------------------------------------------------------------------
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
196 C
197  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
198  * ,ampiz,ampi,amro,gamro,ama1,gama1
199  * ,amk,amkz,amkst,gamkst
200 C
201  amrop=1.1
202  gamrop=0.36
203  amom=.782
204  gamom=0.0084
205 C 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
335 C
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
352 C
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
389 CAM normalised to e nu nutau channel
390 CAM enu munu pinu rhonu A1nu Knu K*nu pi
391 CAM 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 
406 C
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 
490 C 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)
803 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
804 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
805 C 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
810 C ==================
811 C 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
817 C ====
818 C 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
824 C =====
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
844 C ----------------------------------------------------------------------
845 C INITIALISATION OF MASSES
846 C
847 C called by : KORALZ
848 C ----------------------------------------------------------------------
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
856 C
857 C IN-COMING / OUT-GOING FERMION MASSES
858  amtau = 1.7842
859 C --- 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
880 C
881 C
882 C IN-COMING / OUT-GOING FERMION MASSES
883 !! AMNUTA = PKORB(1,2)
884 !! AMNUE = PKORB(1,4)
885 !! AMNUMU = PKORB(1,6)
886 C
887 C 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)
898 C
899 
900 
901  RETURN
902  END
903  SUBROUTINE taufil
904 C *****************
905 C SUBSITUTE OF tau PRODUCTION GENERATOR
906 C
907  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
908  * ,ampiz,ampi,amro,gamro,ama1,gama1
909  * ,amk,amkz,amkst,gamkst
910 C
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
915 C positions of taus in the LUND common block
916 C it will be used by TAUOLA output routines.
917  COMMON /taupos / npa,npb
918  dimension xpb1(4),xpb2(4),aqf1(4),aqf2(4)
919 C
920 C --- 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
929 C --- TAU MOMENTA
930  CALL tralo4(1,aqf1,aqf1,am)
931  CALL tralo4(2,aqf2,aqf2,am)
932 C --- 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))
943 C --- Position of first and second tau in LUND common
944  npa=3
945  npb=4
946 C --- 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)
953 C **************************
954 C SUBSITUTE OF TRALO4
955  REAL P(4),Q(4)
956 C
957  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
958  * ,ampiz,ampi,amro,gamro,ama1,gama1
959  * ,amk,amkz,amkst,gamkst
960 C
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)
970 C ======================================================================
971 C END OF THE TEST JOB
972 C ======================================================================
973  END
974  SUBROUTINE filhep(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
975 C ----------------------------------------------------------------------
976 C this subroutine fills one entry into the HEPEVT common
977 C and updates the information for affected mother entries
978 C
979 C written by Martin W. Gruenewald (91/01/28)
980 C
981 C called by : ZTOHEP,BTOHEP,DWLUxy
982 C ----------------------------------------------------------------------
983 C
984 C this is the hepevt class in old style. No d_h_ class pre-name
985  INTEGER NMXHEP
986  parameter(nmxhep=4000)
987  REAL*8 phep, vhep ! to be real*4/ *8 depending on host
988  INTEGER nevhep,nhep,isthep,idhep,jmohep,
989  $ jdahep
990  COMMON /hepevt/
991  $ nevhep, ! serial number
992  $ nhep, ! number of particles
993  $ isthep(nmxhep), ! status code
994  $ idhep(nmxhep), ! particle ident KF
995  $ jmohep(2,nmxhep), ! parent particles
996  $ jdahep(2,nmxhep), ! childreen particles
997  $ phep(5,nmxhep), ! four-momentum, mass [GeV]
998  $ vhep(4,nmxhep) ! vertex [mm]
999 * ----------------------------------------------------------------------
1000  LOGICAL qedrad
1001  COMMON /phoqed/
1002  $ qedrad(nmxhep) ! Photos flag
1003 * ----------------------------------------------------------------------
1004  SAVE hepevt,phoqed
1005 
1006 
1007 C PARAMETER (NMXHEP=2000)
1008 C COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
1009 C &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
1010 C SAVE /HEPEVT/
1011 C COMMON/PHOQED/QEDRAD(NMXHEP)
1012 C LOGICAL QEDRAD
1013 C SAVE /PHOQED/
1014  LOGICAL PHFLAG
1015 C
1016  REAL*4 P4(4)
1017 C
1018 C check address mode
1019  IF (n.EQ.0) THEN
1020 C
1021 C append mode
1022  ihep=nhep+1
1023  ELSE IF (n.GT.0) THEN
1024 C
1025 C absolute position
1026  ihep=n
1027  ELSE
1028 C
1029 C relative position
1030  ihep=nhep+n
1031  END IF
1032 C
1033 C check on IHEP
1034  IF ((ihep.LE.0).OR.(ihep.GT.nmxhep)) RETURN
1035 C
1036 C add entry
1037  nhep=ihep
1038  isthep(ihep)=ist
1039  idhep(ihep)=id
1040  jmohep(1,ihep)=jmo1
1041  IF(jmo1.LT.0)jmohep(1,ihep)=jmohep(1,ihep)+ihep
1042  jmohep(2,ihep)=jmo2
1043  IF(jmo2.LT.0)jmohep(2,ihep)=jmohep(2,ihep)+ihep
1044  jdahep(1,ihep)=jda1
1045  jdahep(2,ihep)=jda2
1046 C
1047  DO i=1,4
1048  phep(i,ihep)=p4(i)
1049 C
1050 C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
1051  vhep(i,ihep)=0.0
1052  END DO
1053  phep(5,ihep)=pinv
1054 C FLAG FOR PHOTOS...
1055  qedrad(ihep)=phflag
1056 C
1057 C update process:
1058  DO ip=jmohep(1,ihep),jmohep(2,ihep)
1059  IF(ip.GT.0)THEN
1060 C
1061 C if there is a daughter at IHEP, mother entry at IP has decayed
1062  IF(isthep(ip).EQ.1)isthep(ip)=2
1063 C
1064 C and daughter pointers of mother entry must be updated
1065  IF(jdahep(1,ip).EQ.0)THEN
1066  jdahep(1,ip)=ihep
1067  jdahep(2,ip)=ihep
1068  ELSE
1069  jdahep(2,ip)=max(ihep,jdahep(2,ip))
1070  END IF
1071  END IF
1072  END DO
1073 C
1074  RETURN
1075  END