C++InterfacetoTauola
tauola-BBB/tauface-KK-F/Tauface.F
1 */////////////////////////////////////////////////////////////////////////////////////
2 *// //
3 *// !!!!!!! WARNING!!!!! This source is agressive !!!! //
4 *// //
5 *// Due to short common block names it owerwrites variables in other parts //
6 *// of the code. //
7 *// //
8 *// One should add suffix c_Taul_ to names of all commons as soon as possible!!!! //
9 *// //
10 */////////////////////////////////////////////////////////////////////////////////////
11 
12 */////////////////////////////////////////////////////////////////////////////////////
13 *// //
14 *// Standard Tauola interface/initialization routines of functionality exactly //
15 *// as in Tauola CPC but input is partially from xpar(*) matrix //
16 *// ITAUXPAR is for indirect adressing //
17 *// //
18 */////////////////////////////////////////////////////////////////////////////////////
19 
20 
21  SUBROUTINE inietc(ITAUXPAR,xpar)
22  include "BXformat.h"
23  REAL*8 xpar(*)
24  INTEGER inut,iout
25  COMMON /inout/
26  $ inut, ! Input unit number (not used)
27  $ iout ! Ounput unit number
28  COMMON / idfc / idff
29  COMMON / taurad / xk0dec,itdkrc
30  DOUBLE PRECISION xk0dec
31  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
32 * Note: I dont see KeyA1=2,3 realy implemented in the code SJ. ??????
33  INTEGER keya1
34  COMMON /testa1/
35  $ keya1 ! Special switch for tests of dGamma/dQ**2 in a1 decay
36 * KeyA1=1 constant width of a1 and rho
37 * KeyA1=2 free choice of rho propagator (defined in function FPIK)
38 * and free choice of a1 mass and width. function g(Q**2)
39 * (see formula 3.48 in Comp. Phys. Comm. 64 (1991) 275)
40 * hard coded both in Monte Carlo and in testing distribution.
41 * KeyA1=3 function g(Q**2) hardcoded in the Monte Carlo
42 * (it is timy to calculate!), but appropriately adjusted in testing distribution.
43  SAVE
44  idff = xpar(itauxpar+3) ! Lund identifier for first tau (15 for tau-)
45 C XK0 for tau decays.
46  xk0dec = xpar(itauxpar+5) ! IR-cut for QED rad. in leptonic decays
47 C radiative correction switch in tau --> e (mu) decays !
48  itdkrc = xpar(itauxpar+4) ! QED rad. in leptonic decays
49 C switches of tau+ tau- decay modes !!
50  jak1 = xpar(itauxpar+1) ! Decay Mask for first tau
51  jak2 = xpar(itauxpar+2) ! Decay Mask for second tau
52 C output file number for TAUOLA
53  iout = xpar(4)
54 C KeyA1 is used for formfactors actually not in use
55  keya1 = xpar(itauxpar+6) ! Type of a1 current
56 
57  WRITE(iout,bxope)
58  WRITE(iout,bxtxt) ' Parameters passed from KK to Tauola: '
59  WRITE(iout,bxl1i) jak1, 'dec. type 1-st tau ','Jak1 ','t01'
60  WRITE(iout,bxl1i) jak2, 'dec. type 2-nd tau ','Jak2 ','t02'
61  WRITE(iout,bxl1i) keya1, 'current type a1 dec.','KeyA1 ','t03'
62  WRITE(iout,bxl1i) idff, 'PDG id 1-st tau ','idff ','t04'
63  WRITE(iout,bxl1i) itdkrc, 'R.c. switch lept dec','itdkRC','t05'
64  WRITE(iout,bxl1g) xk0dec, 'IR-cut for lept r.c.','xk0dec','t06'
65  WRITE(iout,bxclo)
66 
67  end
68 
69  SUBROUTINE initdk(ITAUXPAR,xpar)
70 * ----------------------------------------------------------------------
71 * INITIALISATION OF TAU DECAY PARAMETERS and routines
72 *
73 * called by : KORALZ
74 * ----------------------------------------------------------------------
75  include "BXformat.h"
76  INTEGER inut,iout
77  COMMON /inout/
78  $ inut, ! Input unit number (not used)
79  $ iout ! Ounput unit number
80  REAL*8 xpar(*)
81 
82  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
83  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
84  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
85  * ,ampiz,ampi,amro,gamro,ama1,gama1
86  * ,amk,amkz,amkst,gamkst
87 *
88  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
89  * ,ampiz,ampi,amro,gamro,ama1,gama1
90  * ,amk,amkz,amkst,gamkst
91  COMMON / taubra / gamprt(500),jlist(500),nchan
92  COMMON / taukle / bra1,brk0,brk0b,brks
93  REAL*4 bra1,brk0,brk0b,brks
94 
95  parameter(nmode=86,nm1=0,nm2=11,nm3=19,nm4=22,nm5=21,nm6=13)
96  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
97  & ,names
98  CHARACTER names(nmode)*31
99 
100  CHARACTER oldnames(7)*31
101  CHARACTER*80 bxinit
102  parameter(
103  $ bxinit ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
104  $ )
105  REAL*4 pi,pol1(4)
106 *
107 *
108 * LIST OF BRANCHING RATIOS
109 CAM normalised to e nu nutau channel
110 CAM enu munu pinu rhonu A1nu Knu K*nu pi
111 CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
112 
113 *AM DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
114 *AM
115 *AM multipion decays
116 *
117 * conventions of particles names
118 * K-,P-,K+, K0,P-,KB, K-,P0,K0
119 * 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
120 * P0,P0,K-, K-,P-,P+, P-,KB,P0
121 * 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
122 * ET,P-,P0 P-,P0,GM
123 * 9, 1, 2 , 1, 2, 8
124 *
125 
126 C
127  dimension nopik(9,nmode),npik(nmode)
128 *AM outgoing multiplicity and flavors of multi-pion /multi-K modes
129  DATA npik / 4, 4, ! old 4scalar
130  a 4, 4, ! new (may 2004)
131  b 4, 4,
132  c 4, 4,
133  d 4, 4,
134  e 4, 4, ! new (may 2004)
135  e 4, 4, ! new (sep 2004)
136  e 4, 4,
137  e 4, 4,
138  e 4, 4,
139  e 4, 4, ! new (sep 2004)
140  1 5,
141  a 5, 5, ! new (may 2004)
142  b 5, 5,
143  c 5, 5,
144  d 5, 5,
145  e 5, 5, ! new (may 2004)
146  a 5, 5, ! new (sep 2004)
147  b 5, 5,
148  c 5, 5,
149  d 5, 5,
150  e 5, 5, ! new (sep 2004)
151  x 5, ! old npi starts here
152  2 6, 6,
153  a 6, 6, ! new (may 2004)
154  b 6, 6, ! new (may 2004)
155  c 6, 6, ! new (may 2004)
156  d 6, 6, ! new (may 2004)
157  e 6, 6, ! new (may 2004)
158  3 3, 3,
159  4 3, 3,
160  5 3, 3,
161  6 3, 3,
162  7 3, ! new (may 2004) and useful
163  a 3, 3, ! new (may 2004)
164  a 3, 3, ! new (may 2004)
165  a 3, 3, ! new (may 2004)
166  a 3, 3, ! new (may 2004)
167  a 3, 3, ! new (may 2004)
168  8 2,
169  9 2, 2, ! new (may 2004)
170  9 2, 2, ! new (may 2004)
171  9 2, 2, ! new (may 2004)
172  9 2, 2, ! new (may 2004)
173  9 2, 2/ ! new (may 2004)
174 
175  DATA nopik / -1,-1, 1, 2, 0, 0,3*0, 2, 2, 2,-1, 0, 0,3*0,
176  a 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
177  b 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
178  c 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
179  d 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
180  e 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (may 2004)
181  a 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
182  b 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
183  c 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
184  d 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
185  e 4, 2, 2,-1, 0, 0,3*0, 4, 2, 2,-1, 0, 0,3*0, ! new (sep 2004)
186  1 -1,-1, 1, 2, 2, 0,3*0,
187  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
188  a 1,-1,-1, 2, 2, 0,3*0, -1, 2, 2, 2, 2, 0,3*0, ! new (may 2004)
189  a -1, 1, 1,-1,-1, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
190  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
191  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (may 2004)
192  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
193  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
194  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
195  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
196  a -1,-1, 1, 2, 4, 0,3*0, -1,-1, 1, 2, 4, 0,3*0, ! new (sep 2004)
197  x -1,-1,-1, 1, 1, 0,3*0, ! old npi starts here
198  2 -1,-1,-1, 1, 1, 2,3*0, -1,-1, 1, 2, 2, 2,3*0,
199  a -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
200  b -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
201  c -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
202  d -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
203  e -1,-1,-1, 1, 1, 1,3*0, -1,-1, 1, 2, 2, 1,3*0, ! new (may 2004)
204  3 -3,-1, 3, 0, 0, 0,3*0, -4,-1, 4, 0, 0, 0,3*0,
205  4 -3, 2,-4, 0, 0, 0,3*0, 2, 2,-3, 0, 0, 0,3*0,
206  5 -3,-1, 1, 0, 0, 0,3*0, -1, 4, 2, 0, 0, 0,3*0,
207  6 9,-1, 2, 0, 0, 0,3*0, -1, 2, 8, 0, 0, 0,3*0,
208 
209 
210 C AJWMOD fix sign bug, 2/22/99
211  7 2, 2,-1, 0, 0, 0,3*0, ! new (may 2004) but useful
212  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
213  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
214  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
215  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
216  7 2, 2, 2, 0, 0, 0,3*0, 2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
217 
218  8 -3,-4, 0, 0, 0, 0,3*0,
219  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
220  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
221  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
222  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
223  8 -3,-3, 0, 0, 0, 0,3*0, -3,-3, 0, 0, 0, 0,3*0 /! new (may 2004)
224 
225 
226 * LIST OF BRANCHING RATIOS
227  nchan = nmode + 7
228  DO 1 i = 1,500
229  IF (i.LE.nchan) THEN
230  jlist(i) = i
231 
232  IF(i.EQ. 1) gamprt(i) = 1.0000
233  IF(i.EQ. 2) gamprt(i) = 1.0000
234  IF(i.EQ. 3) gamprt(i) = 1.0000
235  IF(i.EQ. 4) gamprt(i) = 1.0000
236  IF(i.EQ. 5) gamprt(i) = 1.0000
237  IF(i.EQ. 6) gamprt(i) = 1.0000
238  IF(i.EQ. 7) gamprt(i) = 1.0000
239  IF(i.EQ. 8) gamprt(i) = 1.0000
240  IF(i.EQ. 9) gamprt(i) = 1.0000
241  IF(i.EQ.10) gamprt(i) = 1.0000
242  IF(i.EQ.11) gamprt(i) = 1.0000
243  IF(i.EQ.12) gamprt(i) = 1.0000
244  IF(i.EQ.13) gamprt(i) = 1.0000
245  IF(i.EQ.14) gamprt(i) = 1.0000
246  IF(i.EQ.15) gamprt(i) = 1.0000
247  IF(i.EQ.16) gamprt(i) = 1.0000
248  IF(i.EQ.17) gamprt(i) = 1.0000
249  IF(i.EQ.18) gamprt(i) = 1.0000
250  IF(i.EQ.19) gamprt(i) = 1.0000
251  IF(i.EQ.20) gamprt(i) = 1.0000
252  IF(i.EQ.21) gamprt(i) = 1.0000
253  IF(i.EQ.22) gamprt(i) = 1.0000
254  IF(i.GT.22.AND.i.LE.93) gamprt(i) = 1.0000
255 C second default
256  IF(i.GT.0.AND.i.LE.93) gamprt(i) = 0.0000
257  IF(i.EQ. 1) gamprt(i) =0.1800
258  IF(i.EQ. 2) gamprt(i) =0.1751
259  IF(i.EQ. 3) gamprt(i) =0.1110
260  IF(i.EQ. 4) gamprt(i) =0.2515
261  IF(i.EQ. 5) gamprt(i) =0.1790 /2
262  IF(i.EQ. 6) gamprt(i) =0.0071
263  IF(i.EQ. 7) gamprt(i) =0.0134
264  IF(i.EQ. 8) gamprt(i) =0.0450
265  IF(i.EQ. 9) gamprt(i) =0.0100
266 
267  IF(i.EQ.30) gamprt(i) =0.0009
268  IF(i.EQ.33) gamprt(i) =0.004
269  IF(i.EQ.34) gamprt(i) =0.002
270  IF(i.EQ.35) gamprt(i) =0.001
271 
272  IF(i.EQ.51) gamprt(i) =0.0004
273  IF(i.EQ.52) gamprt(i) =0.0003
274  IF(i.EQ.53) gamprt(i) =0.0005
275 
276  IF(i.EQ.64) gamprt(i) =0.0015
277  IF(i.EQ.65) gamprt(i) =0.0015
278  IF(i.EQ.66) gamprt(i) =0.0015
279  IF(i.EQ.67) gamprt(i) =0.0005
280  IF(i.EQ.68) gamprt(i) =0.0050
281  IF(i.EQ.69) gamprt(i) =0.0055
282  IF(i.EQ.70) gamprt(i) =0.0017
283  IF(i.EQ.71) gamprt(i) =0.0013
284  IF(i.EQ.72) gamprt(i) =0.1790 /2
285 
286  IF(i.EQ.83) gamprt(i) =0.0010
287 
288  IF(i.EQ. 1) oldnames(i)=' TAU- --> E- '
289  IF(i.EQ. 2) oldnames(i)=' TAU- --> MU- '
290  IF(i.EQ. 3) oldnames(i)=' TAU- --> PI- '
291  IF(i.EQ. 4) oldnames(i)=' TAU- --> PI-, PI0 '
292  IF(i.EQ. 5) oldnames(i)=' TAU- --> PI-, PI-, PI+ '
293  IF(i.EQ. 6) oldnames(i)=' TAU- --> K- '
294  IF(i.EQ. 7) oldnames(i)=' TAU- --> K*- (two subch) '
295  IF(i.EQ. 8) names(i-7)=' TAU- --> 2PI-, PI0, PI+ '
296  IF(i.EQ. 9) names(i-7)=' TAU- --> 3PI0, PI- '
297 
298  IF(i.EQ.10) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
299  IF(i.EQ.11) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
300  IF(i.EQ.12) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
301  IF(i.EQ.13) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
302  IF(i.EQ.14) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
303  IF(i.EQ.15) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
304  IF(i.EQ.16) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
305  IF(i.EQ.17) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
306  IF(i.EQ.18) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
307  IF(i.EQ.19) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (may 2004)
308  IF(i.EQ.20) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
309  IF(i.EQ.21) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
310  IF(i.EQ.22) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
311  IF(i.EQ.23) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
312  IF(i.EQ.24) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
313  IF(i.EQ.25) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
314  IF(i.EQ.26) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
315  IF(i.EQ.27) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
316  IF(i.EQ.28) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
317  IF(i.EQ.29) names(i-7)=' TAU- --> xxxxxxx4xxxxxxxx ' ! (sep 2004)
318 
319 
320  IF(i.EQ.30) names(i-7)=' TAU- --> 2PI-, PI+, 2PI0 '
321 
322  IF(i.EQ.31) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
323  IF(i.EQ.32) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
324  IF(i.EQ.33) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
325  IF(i.EQ.34) names(i-7)=' TAU- --> PI- 4PI0 ' ! (may 2004)
326  IF(i.EQ.35) names(i-7)=' TAU- --> 3PI- 2PI+ ' ! (may 2004)
327  IF(i.EQ.36) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
328  IF(i.EQ.37) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
329  IF(i.EQ.38) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
330  IF(i.EQ.39) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
331  IF(i.EQ.40) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (may 2004)
332 
333  IF(i.EQ.41) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
334  IF(i.EQ.42) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
335  IF(i.EQ.43) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
336  IF(i.EQ.44) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
337  IF(i.EQ.45) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
338  IF(i.EQ.46) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
339  IF(i.EQ.47) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
340  IF(i.EQ.48) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
341  IF(i.EQ.49) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
342  IF(i.EQ.50) names(i-7)=' TAU- --> xxxxxxxxx5xxxxxx ' ! (sep 2004)
343 
344  IF(i.EQ.51) names(i-7)=' TAU- --> 3PI-, 2PI+, '
345  IF(i.EQ.52) names(i-7)=' TAU- --> 3PI-, 2PI+, PI0 '
346  IF(i.EQ.53) names(i-7)=' TAU- --> 2PI-, PI+, 3PI0 '
347  IF(i.EQ.54) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
348  IF(i.EQ.55) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
349  IF(i.EQ.56) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
350  IF(i.EQ.57) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
351  IF(i.EQ.58) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
352  IF(i.EQ.59) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
353  IF(i.EQ.60) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
354  IF(i.EQ.61) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
355  IF(i.EQ.62) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
356  IF(i.EQ.63) names(i-7)=' TAU- --> xxxxxxxxxnxxxxxx ' ! (may 2004)
357 
358  IF(i.EQ.64) names(i-7)=' TAU- --> K-, PI-, K+ '
359  IF(i.EQ.65) names(i-7)=' TAU- --> K0, PI-, K0B '
360 
361  IF(i.EQ.66) names(i-7)=' TAU- --> K-, K0, PI0 '
362 
363  IF(i.EQ.67) names(i-7)=' TAU- --> PI0 PI0 K- '
364  IF(i.EQ.68) names(i-7)=' TAU- --> K- PI- PI+ '
365  IF(i.EQ.69) names(i-7)=' TAU- --> PI- K0B PI0 '
366  IF(i.EQ.70) names(i-7)=' TAU- --> ETA PI- PI0 '
367  IF(i.EQ.71) names(i-7)=' TAU- --> PI- PI0 GAM '
368  IF(i.EQ.72) names(i-7)=' TAU- --> PI- PI0 PI0 '
369  IF(i.EQ.73) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
370  IF(i.EQ.74) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
371  IF(i.EQ.75) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
372  IF(i.EQ.76) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
373  IF(i.EQ.77) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
374  IF(i.EQ.78) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
375  IF(i.EQ.79) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
376  IF(i.EQ.80) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
377  IF(i.EQ.81) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
378  IF(i.EQ.82) names(i-7)=' TAU- --> xxxxxxxxx3xxxxxx ' ! (may 2004)
379 
380 
381  IF(i.EQ.83) names(i-7)=' TAU- --> K- K0 '
382  IF(i.EQ.84) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
383  IF(i.EQ.85) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
384  IF(i.EQ.86) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
385  IF(i.EQ.87) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
386  IF(i.EQ.88) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
387  IF(i.EQ.89) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
388  IF(i.EQ.90) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
389  IF(i.EQ.91) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
390  IF(i.EQ.92) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
391  IF(i.EQ.93) names(i-7)=' TAU- --> xxxxxxxxx2xxxxxx ' ! (may 2004)
392 
393  ELSE
394  jlist(i) = 0
395  gamprt(i) = 0.
396  ENDIF
397  1 CONTINUE
398  DO i=1,nmode
399  mulpik(i)=npik(i)
400  DO j=1,mulpik(i)
401  idffin(j,i)=nopik(j,i)
402  ENDDO
403  ENDDO
404 *
405 *
406 * --- COEFFICIENTS TO FIX RATIO OF:
407 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
408 * --- PROBABILITY OF K0 TO BE KS
409 * --- PROBABILITY OF K0B TO BE KS
410 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
411 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
412 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
413 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
414  bra1=1d0 ! 0.5
415  brk0=0.5
416  brk0b=0.5
417  brks=0.6667
418 *
419 
420  gfermi = 1.16637e-5
421  ccabib = 0.975
422  gv = 1.0
423  ga =-1.0
424 
425 
426 
427  gfermi = xpar(32)
428  IF (xpar(itauxpar+100+1).GT.-1d0) THEN
429 C initialization form KK
430  ccabib = xpar(itauxpar+7)
431  gv = xpar(itauxpar+8)
432  ga = xpar(itauxpar+9)
433 
434  bra1 = 1d0 ! XPAR(ITAUXPAR+10) ! input is overruled; must be 1d0 now
435  brks = xpar(itauxpar+11)
436  brk0 = xpar(itauxpar+12)
437  brk0b = xpar(itauxpar+13)
438  DO k=1,nchan
439 C GAMPRT(K)=XPAR(ITAUXPAR+100+K)
440 
441  IF(k.EQ. 1) gamprt(k) =xpar(itauxpar+100+k)
442  IF(k.EQ. 2) gamprt(k) =xpar(itauxpar+100+k)
443  IF(k.EQ. 3) gamprt(k) =xpar(itauxpar+100+k)
444  IF(k.EQ. 4) gamprt(k) =xpar(itauxpar+100+k)
445  IF(k.EQ. 5) gamprt(k) =xpar(itauxpar+100+k) /2
446  IF(k.EQ. 6) gamprt(k) =xpar(itauxpar+100+k)
447  IF(k.EQ. 7) gamprt(k) =xpar(itauxpar+100+k)
448  IF(k.EQ. 8) gamprt(k) =xpar(itauxpar+100+k)
449  IF(k.EQ. 9) gamprt(k) =xpar(itauxpar+100+k)
450 
451  IF(k.EQ.30) gamprt(k) =xpar(itauxpar+100+10)
452 
453  IF(k.EQ.51) gamprt(k) =xpar(itauxpar+100+11)
454  IF(k.EQ.52) gamprt(k) =xpar(itauxpar+100+12)
455  IF(k.EQ.53) gamprt(k) =xpar(itauxpar+100+13)
456 
457  IF(k.EQ.64) gamprt(k) =xpar(itauxpar+100+14)
458  IF(k.EQ.65) gamprt(k) =xpar(itauxpar+100+15)
459  IF(k.EQ.66) gamprt(k) =xpar(itauxpar+100+16)
460  IF(k.EQ.67) gamprt(k) =xpar(itauxpar+100+17)
461  IF(k.EQ.68) gamprt(k) =xpar(itauxpar+100+18)
462  IF(k.EQ.69) gamprt(k) =xpar(itauxpar+100+19)
463  IF(k.EQ.70) gamprt(k) =xpar(itauxpar+100+20)
464  IF(k.EQ.71) gamprt(k) =xpar(itauxpar+100+21)
465  IF(k.EQ.72) gamprt(k) =xpar(itauxpar+100+5) /2
466 
467  IF(k.EQ.83) gamprt(k) =xpar(itauxpar+100+22)
468 
469  IF(k.EQ.33) gamprt(i) =xpar(itauxpar+100+23)
470  IF(k.EQ.34) gamprt(i) =xpar(itauxpar+100+24)
471  IF(k.EQ.35) gamprt(i) =xpar(itauxpar+100+25)
472 
473  ENDDO
474  ENDIF
475 * ZW 13.04.89 HERE WAS AN ERROR
476  scabib = sqrt(1.-ccabib**2)
477  pi =4.*atan(1.)
478  gamel = gfermi**2*amtau**5/(192*pi**3)
479 *
480 * CALL DEXAY(-1,pol1)
481 *
482 * PRINTOUTS FOR KK version
483 
484  sum=0
485  DO k=1,nchan
486  sum=sum+gamprt(k)
487  ENDDO
488 
489 
490  WRITE(iout,bxope)
491  WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INITDK: '
492  WRITE(iout,bxtxt) ' Adopted to read from KK '
493  WRITE(iout,bxtxt) ' '
494  WRITE(iout,bxtxt) ' Choice Probability -- Decay Channel'
495  DO k=1,7
496  WRITE(iout,bxinit) gamprt(k)/sum, oldnames(k),'****','***'
497  ENDDO
498  DO k=8,7+nmode
499  WRITE(iout,bxinit) gamprt(k)/sum, names(k-7),'****','***'
500  ENDDO
501  WRITE(iout,bxtxt) ' In addition:'
502  WRITE(iout,bxinit) gv, 'Vector W-tau-nu coupl. ','****','***'
503  WRITE(iout,bxinit) ga, 'Axial W-tau-nu coupl. ','****','***'
504  WRITE(iout,bxinit) gfermi,'Fermi Coupling ','****','***'
505  WRITE(iout,bxinit) ccabib,'cabibo angle ','****','***'
506  WRITE(iout,bxinit) bra1, 'a1 br ratio (massless) ','****','***'
507  WRITE(iout,bxinit) brks, 'K* br ratio (massless) ','****','***'
508  WRITE(iout,bxclo)
509 
510  RETURN
511  END
512 
513  SUBROUTINE iniphy(XK00)
514 * ----------------------------------------------------------------------
515 * INITIALISATION OF PARAMETERS
516 * USED IN QED and/or GSW ROUTINES
517 * ----------------------------------------------------------------------
518  COMMON / qedprm /alfinv,alfpi,xk0
519  REAL*8 alfinv,alfpi,xk0
520  REAL*8 pi8,xk00
521 *
522  pi8 = 4.d0*datan(1.d0)
523  alfinv = 137.03604d0
524  alfpi = 1d0/(alfinv*pi8)
525  xk0=xk00
526  END
527 
528  SUBROUTINE inimas(ITAUXPAR,xpar)
529 * ----------------------------------------------------------------------
530 * INITIALISATION OF MASSES
531 *
532 * called by : KORALZ
533 * ----------------------------------------------------------------------
534  include "BXformat.h"
535  INTEGER inut,iout
536  COMMON /inout/
537  $ inut, ! Input unit number (not used)
538  $ iout ! Ounput unit number
539  REAL*8 xpar(*)
540  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
541  * ,ampiz,ampi,amro,gamro,ama1,gama1
542  * ,amk,amkz,amkst,gamkst
543 *
544  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
545  * ,ampiz,ampi,amro,gamro,ama1,gama1
546  * ,amk,amkz,amkst,gamkst
547  CHARACTER*80 bxinit
548  parameter(
549  $ bxinit ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
550  $ )
551 *
552 * IN-COMING / OUT-GOING FERMION MASSES
553  amtau = xpar(656)
554  amnuta = 0.010
555  amel = xpar(616)
556  amnue = 0.0
557  ammu = xpar(636)
558  amnumu = 0.0
559 *
560 * MASSES USED IN TAU DECAYS
561 
562  ampiz = 0.134964
563  ampi = 0.139568
564  amro = 0.773
565  gamro = 0.145
566 *C GAMRO = 0.666
567  ama1 = 1.251
568  gama1 = 0.599
569  amk = 0.493667
570  amkz = 0.49772
571  amkst = 0.8921
572  gamkst = 0.0513
573 
574 
575  WRITE(iout,bxope)
576  WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INIMAS: '
577  WRITE(iout,bxtxt) ' Adopted to read from KK '
578  WRITE(iout,bxinit) amtau, 'AMTAU tau-mass ','****','***'
579  WRITE(iout,bxinit) amel , 'AMEL electron-mass ','****','***'
580  WRITE(iout,bxinit) ammu , 'AMMU muon-mass ','****','***'
581  WRITE(iout,bxclo)
582 
583  END
584  SUBROUTINE choice(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
585  $ amrx,gamrx,amra,gamra,amrb,gamrb)
586  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
587  * ,ampiz,ampi,amro,gamro,ama1,gama1
588  * ,amk,amkz,amkst,gamkst
589 C
590  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
591  * ,ampiz,ampi,amro,gamro,ama1,gama1
592  * ,amk,amkz,amkst,gamkst
593 C
594  amrop=1.1
595  gamrop=0.36
596  amom=.782
597  gamom=0.0084
598 C XXXXA CORRESPOND TO S2 CHANNEL !
599  IF(mnum.EQ.0) THEN
600  prob1=0.5
601  prob2=0.5
602  amrx =ama1
603  gamrx=gama1
604  amra =amro
605  gamra=gamro
606  amrb =amro
607  gamrb=gamro
608  ELSEIF(mnum.EQ.1) THEN
609  prob1=0.5
610  prob2=0.5
611  amrx =1.57
612  gamrx=0.9
613  amrb =amkst
614  gamrb=gamkst
615  amra =amro
616  gamra=gamro
617  ELSEIF(mnum.EQ.2) THEN
618  prob1=0.5
619  prob2=0.5
620  amrx =1.57
621  gamrx=0.9
622  amrb =amkst
623  gamrb=gamkst
624  amra =amro
625  gamra=gamro
626  ELSEIF(mnum.EQ.3) THEN
627  prob1=0.5
628  prob2=0.5
629  amrx =1.27
630  gamrx=0.3
631  amra =amkst
632  gamra=gamkst
633  amrb =amkst
634  gamrb=gamkst
635  ELSEIF(mnum.EQ.4) THEN
636  prob1=0.5
637  prob2=0.5
638  amrx =1.27
639  gamrx=0.3
640  amra =amkst
641  gamra=gamkst
642  amrb =amkst
643  gamrb=gamkst
644  ELSEIF(mnum.EQ.5) THEN
645  prob1=0.5
646  prob2=0.5
647  amrx =1.27
648  gamrx=0.3
649  amra =amkst
650  gamra=gamkst
651  amrb =amro
652  gamrb=gamro
653  ELSEIF(mnum.EQ.6) THEN
654  prob1=0.4
655  prob2=0.4
656  amrx =1.27
657  gamrx=0.3
658  amra =amro
659  gamra=gamro
660  amrb =amkst
661  gamrb=gamkst
662  ELSEIF(mnum.EQ.7) THEN
663  prob1=0.0
664  prob2=1.0
665  amrx =1.27
666  gamrx=0.9
667  amra =amro
668  gamra=gamro
669  amrb =amro
670  gamrb=gamro
671  ELSEIF(mnum.EQ.8) THEN
672  prob1=0.0
673  prob2=1.0
674  amrx =amrop
675  gamrx=gamrop
676  amrb =amom
677  gamrb=gamom
678  amra =amro
679  gamra=gamro
680  ELSEIF(mnum.EQ.9) THEN
681  prob1=0.5
682  prob2=0.5
683  amrx =ama1
684  gamrx=gama1
685  amra =amro
686  gamra=gamro
687  amrb =amro
688  gamrb=gamro
689  ELSEIF(mnum.EQ.101) THEN
690  prob1=.35
691  prob2=.35
692  amrx =1.2
693  gamrx=.46
694  amrb =amom
695  gamrb=gamom
696  amra =amom
697  gamra=gamom
698  ELSEIF(mnum.EQ.102) THEN
699  prob1=0.0
700  prob2=0.0
701  amrx =1.4
702  gamrx=.6
703  amrb =amom
704  gamrb=gamom
705  amra =amom
706  gamra=gamom
707  ELSEIF(mnum.GE.103.AND.mnum.LE.112) THEN
708  prob1=0.0
709  prob2=0.0
710  amrx =1.4
711  gamrx=.6
712  amrb =amom
713  gamrb=gamom
714  amra =amom
715  gamra=gamom
716 
717 
718  ELSE
719  prob1=0.0
720  prob2=0.0
721  amrx =ama1
722  gamrx=gama1
723  amra =amro
724  gamra=gamro
725  amrb =amro
726  gamrb=gamro
727  ENDIF
728 C
729  IF (rr.LE.prob1) THEN
730  ichan=1
731  ELSEIF(rr.LE.(prob1+prob2)) THEN
732  ichan=2
733  ax =amra
734  gx =gamra
735  amra =amrb
736  gamra=gamrb
737  amrb =ax
738  gamrb=gx
739  px =prob1
740  prob1=prob2
741  prob2=px
742  ELSE
743  ichan=3
744  ENDIF
745 C
746  prob3=1.0-prob1-prob2
747  END
748  FUNCTION dcdmas(IDENT)
749  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
750  * ,ampiz,ampi,amro,gamro,ama1,gama1
751  * ,amk,amkz,amkst,gamkst
752 *
753  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
754  * ,ampiz,ampi,amro,gamro,ama1,gama1
755  * ,amk,amkz,amkst,gamkst
756  IF (ident.EQ. 1) THEN
757  apkmas=ampi
758  ELSEIF (ident.EQ.-1) THEN
759  apkmas=ampi
760  ELSEIF (ident.EQ. 2) THEN
761  apkmas=ampiz
762  ELSEIF (ident.EQ.-2) THEN
763  apkmas=ampiz
764  ELSEIF (ident.EQ. 3) THEN
765  apkmas=amk
766  ELSEIF (ident.EQ.-3) THEN
767  apkmas=amk
768  ELSEIF (ident.EQ. 4) THEN
769  apkmas=amkz
770  ELSEIF (ident.EQ.-4) THEN
771  apkmas=amkz
772  ELSEIF (ident.EQ. 8) THEN
773  apkmas=0.0001
774  ELSEIF (ident.EQ.-8) THEN
775  apkmas=0.0001
776  ELSEIF (ident.EQ. 9) THEN
777  apkmas=0.5488
778  ELSEIF (ident.EQ.-9) THEN
779  apkmas=0.5488
780  ELSE
781  print *, 'STOP IN APKMAS, WRONG IDENT=',ident
782  stop
783  ENDIF
784  dcdmas=apkmas
785  END
786  FUNCTION lunpik(ID,ISGN)
787  COMMON / taukle / bra1,brk0,brk0b,brks
788  REAL*4 bra1,brk0,brk0b,brks
789  REAL*4 xio(1)
790  ident=id*isgn
791 
792  IF (ident.EQ. 1) THEN
793  ipkdef=-211
794  ELSEIF (ident.EQ.-1) THEN
795  ipkdef= 211
796  ELSEIF (ident.EQ. 2) THEN
797  ipkdef=111
798  ELSEIF (ident.EQ.-2) THEN
799  ipkdef=111
800  ELSEIF (ident.EQ. 3) THEN
801  ipkdef=-321
802  ELSEIF (ident.EQ.-3) THEN
803  ipkdef= 321
804 
805  ELSEIF (ident.EQ. 4) THEN
806 *
807 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
808  CALL ranmar(xio,1)
809  IF (xio(1).GT.brk0) THEN
810  ipkdef= 130
811  ELSE
812  ipkdef= 310
813  ENDIF
814  ELSEIF (ident.EQ.-4) THEN
815 *
816 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
817  CALL ranmar(xio,1)
818  IF (xio(1).GT.brk0b) THEN
819  ipkdef= 130
820  ELSE
821  ipkdef= 310
822  ENDIF
823  ELSEIF (ident.EQ. 8) THEN
824  ipkdef= 22
825  ELSEIF (ident.EQ.-8) THEN
826  ipkdef= 22
827  ELSEIF (ident.EQ. 9) THEN
828  ipkdef= 221
829  ELSEIF (ident.EQ.-9) THEN
830  ipkdef= 221
831  ELSE
832  print *, 'STOP IN IPKDEF, WRONG IDENT=',ident
833  stop
834  ENDIF
835  lunpik=ipkdef
836  END
837 
838 
839 
840 
841  SUBROUTINE taurdf(KTO)
842 * THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
843 * IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
844 * CONTENTS
845  COMMON / taukle / bra1,brk0,brk0b,brks
846  REAL*4 bra1,brk0,brk0b,brks
847  COMMON / taubra / gamprt(500),jlist(500),nchan
848  RETURN ! this routine is called somewhere and is now deactivated, one has to fill it in properly for use.
849  IF (kto.EQ.1) THEN
850 * ==================
851 * LIST OF BRANCHING RATIOS
852  nchan = 19
853  DO 1 i = 1,500
854  IF (i.LE.nchan) THEN
855  jlist(i) = i
856  IF(i.EQ. 1) gamprt(i) = .0000
857  IF(i.EQ. 2) gamprt(i) = .0000
858  IF(i.EQ. 3) gamprt(i) = .0000
859  IF(i.EQ. 4) gamprt(i) = .0000
860  IF(i.EQ. 5) gamprt(i) = .0000
861  IF(i.EQ. 6) gamprt(i) = .0000
862  IF(i.EQ. 7) gamprt(i) = .0000
863  IF(i.EQ. 8) gamprt(i) = 1.0000
864  IF(i.EQ. 9) gamprt(i) = 1.0000
865  IF(i.EQ.10) gamprt(i) = 1.0000
866  IF(i.EQ.11) gamprt(i) = 1.0000
867  IF(i.EQ.12) gamprt(i) = 1.0000
868  IF(i.EQ.13) gamprt(i) = 1.0000
869  IF(i.EQ.14) gamprt(i) = 1.0000
870  IF(i.EQ.15) gamprt(i) = 1.0000
871  IF(i.EQ.16) gamprt(i) = 1.0000
872  IF(i.EQ.17) gamprt(i) = 1.0000
873  IF(i.EQ.18) gamprt(i) = 1.0000
874  IF(i.EQ.19) gamprt(i) = 1.0000
875  ELSE
876  jlist(i) = 0
877  gamprt(i) = 0.
878  ENDIF
879  1 CONTINUE
880 * --- COEFFICIENTS TO FIX RATIO OF:
881 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
882 * --- PROBABILITY OF K0 TO BE KS
883 * --- PROBABILITY OF K0B TO BE KS
884 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
885 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
886 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
887 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
888  bra1=0.5
889  brk0=0.5
890  brk0b=0.5
891  brks=0.6667
892  ELSE
893 * ====
894 * LIST OF BRANCHING RATIOS
895  nchan = 19
896  DO 2 i = 1,500
897  IF (i.LE.nchan) THEN
898  jlist(i) = i
899  IF(i.EQ. 1) gamprt(i) = .0000
900  IF(i.EQ. 2) gamprt(i) = .0000
901  IF(i.EQ. 3) gamprt(i) = .0000
902  IF(i.EQ. 4) gamprt(i) = .0000
903  IF(i.EQ. 5) gamprt(i) = .0000
904  IF(i.EQ. 6) gamprt(i) = .0000
905  IF(i.EQ. 7) gamprt(i) = .0000
906  IF(i.EQ. 8) gamprt(i) = 1.0000
907  IF(i.EQ. 9) gamprt(i) = 1.0000
908  IF(i.EQ.10) gamprt(i) = 1.0000
909  IF(i.EQ.11) gamprt(i) = 1.0000
910  IF(i.EQ.12) gamprt(i) = 1.0000
911  IF(i.EQ.13) gamprt(i) = 1.0000
912  IF(i.EQ.14) gamprt(i) = 1.0000
913  IF(i.EQ.15) gamprt(i) = 1.0000
914  IF(i.EQ.16) gamprt(i) = 1.0000
915  IF(i.EQ.17) gamprt(i) = 1.0000
916  IF(i.EQ.18) gamprt(i) = 1.0000
917  IF(i.EQ.19) gamprt(i) = 1.0000
918  ELSE
919  jlist(i) = 0
920  gamprt(i) = 0.
921  ENDIF
922  2 CONTINUE
923 * --- COEFFICIENTS TO FIX RATIO OF:
924 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
925 * --- PROBABILITY OF K0 TO BE KS
926 * --- PROBABILITY OF K0B TO BE KS
927 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
928 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
929 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
930 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
931  bra1=0.5
932  brk0=0.5
933  brk0b=0.5
934  brks=0.6667
935  ENDIF
936 * =====
937  END
938