C++ Interface to Tauola
demo-factory/back/attic/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  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
82  real*4 gfermi,gv,ga,ccabib,scabib,gamel
83  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
84  * ,ampiz,ampi,amro,gamro,ama1,gama1
85  * ,amk,amkz,amkst,gamkst
86 *
87  real*4 amtau,amnuta,amel,amnue,ammu,amnumu
88  * ,ampiz,ampi,amro,gamro,ama1,gama1
89  * ,amk,amkz,amkst,gamkst
90  COMMON / taubra / gamprt(30),jlist(30),nchan
91  COMMON / taukle / bra1,brk0,brk0b,brks
92  real*4 bra1,brk0,brk0b,brks
93 #if defined (ALEPH)
94  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
95  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
96  & ,names
97  CHARACTER NAMES(NMODE)*31
98 #else
99  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
100  COMMON / decomp /idffin(9,nmode),mulpik(nmode)
101  & ,names
102  CHARACTER NAMES(NMODE)*31
103 #endif
104  CHARACTER OLDNAMES(7)*31
105  CHARACTER*80 bxINIT
106  parameter(
107  $ bxinit ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
108  $ )
109  real*4 pi,pol1(4)
110 *
111 *
112 * LIST OF BRANCHING RATIOS
113 CAM normalised to e nu nutau channel
114 CAM enu munu pinu rhonu A1nu Knu K*nu pi
115 CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
116 #if defined (ALEPH)
117 CAM /0.1779,0.1731,0.1106,0.2530,0.1811,0.0072,0.0139
118 CAM DATA GAMPRT / 1.000,0.9732,0.6217,1.4221,1.0180,0.0405,0.0781
119 CAM DATA GAMPRT /1.000,0.9676,0.6154,1.3503,1.0225,0.0368,O.O758
120 CAM
121 C
122 C conventions of particles names
123 c
124 cam mode (JAK) 8 9
125 CAM channel pi- pi- pi0 pi+ 3pi0 pi-
126 cam particle code -1,-1, 2, 1, 0, 0, 2, 2, 2,-1, 0, 0,
127 CAM BR relative to electron .2414, .0601,
128 c
129 * 10 11
130 * 1 3pi+- 2pi0 5pi+-
131 * 1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
132 * 1 .0281, .0045,
133 
134 * 12 13
135 * 2 5pi+- pi0 3pi+- 3pi0
136 * 2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
137 * 2 .0010, .0062,
138 
139 * 14 15
140 * 3 K- pi- K+ K0 pi- KB
141 * 3 -3,-1, 3, 0, 0, 0, 4,-1,-4, 0, 0, 0,
142 * 3 .0096, .0169,
143 
144 * 16 17
145 * 4 K- pi0 K0 2pi0 K-
146 * 4 -3, 2, 4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
147 * 4 .0056, .0045,
148 
149 * 18 19
150 * 5 K- pi- pi+ pi- KB pi0
151 * 5 -3,-1, 1, 0, 0, 0, -1,-4, 2, 0, 0, 0,
152 * 5 .0219, .0180,
153 
154 * 20 21
155 * 6 eta pi- pi0 pi- pi0 gamma
156 * 6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
157 * 6 .0096, .0088,
158 
159 * 22 /
160 * 7 K- K0 /
161 * 7 -3, 4 /
162 * 7 .0146 /
163 #else
164 *AM DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
165 *AM
166 *AM multipion decays
167 *
168 * conventions of particles names
169 * K-,P-,K+, K0,P-,KB, K-,P0,K0
170 * 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
171 * P0,P0,K-, K-,P-,P+, P-,KB,P0
172 * 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
173 * ET,P-,P0 P-,P0,GM
174 * 9, 1, 2 , 1, 2, 8
175 *
176 #endif
177 C
178  dimension nopik(6,nmode),npik(nmode)
179 *AM outgoing multiplicity and flavors of multi-pion /multi-K modes
180  DATA npik / 4, 4,
181  1 5, 5,
182  2 6, 6,
183  3 3, 3,
184  4 3, 3,
185  5 3, 3,
186  6 3, 3,
187  7 2 /
188 #if defined (ALEPH)
189  DATA nopik / -1,-1, 2, 1, 0, 0, 2, 2, 2,-1, 0, 0,
190  1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
191  2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
192  3 -3,-1, 3, 0, 0, 0, 4,-1,-4, 0, 0, 0,
193  4 -3, 2, 4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
194  5 -3,-1, 1, 0, 0, 0, -1,-4, 2, 0, 0, 0,
195  6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
196 #else
197  DATA nopik / -1,-1, 1, 2, 0, 0, 2, 2, 2,-1, 0, 0,
198  1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
199  2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
200  3 -3,-1, 3, 0, 0, 0, -4,-1, 4, 0, 0, 0,
201  4 -3, 2,-4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
202  5 -3,-1, 1, 0, 0, 0, -1, 4, 2, 0, 0, 0,
203  6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
204 #endif
205 #if defined (CLEO)
206 C AJWMOD fix sign bug, 2/22/99
207  7 -3,-4, 0, 0, 0, 0 /
208 #else
209  7 -3, 4, 0, 0, 0, 0 /
210 #endif
211 * LIST OF BRANCHING RATIOS
212  nchan = nmode + 7
213  DO 1 i = 1,30
214  IF (i.LE.nchan) THEN
215  jlist(i) = i
216 #if defined (CePeCe)
217  IF(i.EQ. 1) gamprt(i) = 1.0000
218  IF(i.EQ. 2) gamprt(i) = 1.0000
219  IF(i.EQ. 3) gamprt(i) = 1.0000
220  IF(i.EQ. 4) gamprt(i) = 1.0000
221  IF(i.EQ. 5) gamprt(i) = 1.0000
222  IF(i.EQ. 6) gamprt(i) = 1.0000
223  IF(i.EQ. 7) gamprt(i) = 1.0000
224  IF(i.EQ. 8) gamprt(i) = 1.0000
225  IF(i.EQ. 9) gamprt(i) = 1.0000
226  IF(i.EQ.10) gamprt(i) = 1.0000
227  IF(i.EQ.11) gamprt(i) = 1.0000
228  IF(i.EQ.12) gamprt(i) = 1.0000
229  IF(i.EQ.13) gamprt(i) = 1.0000
230  IF(i.EQ.14) gamprt(i) = 1.0000
231  IF(i.EQ.15) gamprt(i) = 1.0000
232  IF(i.EQ.16) gamprt(i) = 1.0000
233  IF(i.EQ.17) gamprt(i) = 1.0000
234  IF(i.EQ.18) gamprt(i) = 1.0000
235  IF(i.EQ.19) gamprt(i) = 1.0000
236  IF(i.EQ.20) gamprt(i) = 1.0000
237  IF(i.EQ.21) gamprt(i) = 1.0000
238  IF(i.EQ.22) gamprt(i) = 1.0000
239 #elif defined (CLEO)
240  IF(i.EQ. 1) gamprt(i) =0.1800
241  IF(i.EQ. 2) gamprt(i) =0.1751
242  IF(i.EQ. 3) gamprt(i) =0.1110
243  IF(i.EQ. 4) gamprt(i) =0.2515
244  IF(i.EQ. 5) gamprt(i) =0.1790
245  IF(i.EQ. 6) gamprt(i) =0.0071
246  IF(i.EQ. 7) gamprt(i) =0.0134
247  IF(i.EQ. 8) gamprt(i) =0.0450
248  IF(i.EQ. 9) gamprt(i) =0.0100
249  IF(i.EQ.10) gamprt(i) =0.0009
250  IF(i.EQ.11) gamprt(i) =0.0004
251  IF(i.EQ.12) gamprt(i) =0.0003
252  IF(i.EQ.13) gamprt(i) =0.0005
253  IF(i.EQ.14) gamprt(i) =0.0015
254  IF(i.EQ.15) gamprt(i) =0.0015
255  IF(i.EQ.16) gamprt(i) =0.0015
256  IF(i.EQ.17) gamprt(i) =0.0005
257  IF(i.EQ.18) gamprt(i) =0.0050
258  IF(i.EQ.19) gamprt(i) =0.0055
259  IF(i.EQ.20) gamprt(i) =0.0017
260  IF(i.EQ.21) gamprt(i) =0.0013
261  IF(i.EQ.22) gamprt(i) =0.0010
262 #elif defined (ALEPH)
263  IF(i.EQ. 1) gamprt(i) = 1.0000
264  IF(i.EQ. 2) gamprt(i) = .9732
265  IF(i.EQ. 3) gamprt(i) = .6217
266  IF(i.EQ. 4) gamprt(i) = 1.4221
267  IF(i.EQ. 5) gamprt(i) = 1.0180
268  IF(i.EQ. 6) gamprt(i) = .0405
269  IF(i.EQ. 7) gamprt(i) = .0781
270  IF(i.EQ. 8) gamprt(i) = .2414
271  IF(i.EQ. 9) gamprt(i) = .0601
272  IF(i.EQ.10) gamprt(i) = .0281
273  IF(i.EQ.11) gamprt(i) = .0045
274  IF(i.EQ.12) gamprt(i) = .0010
275  IF(i.EQ.13) gamprt(i) = .0062
276  IF(i.EQ.14) gamprt(i) = .0096
277  IF(i.EQ.15) gamprt(i) = .0169
278  IF(i.EQ.16) gamprt(i) = .0056
279  IF(i.EQ.17) gamprt(i) = .0045
280  IF(i.EQ.18) gamprt(i) = .0219
281  IF(i.EQ.19) gamprt(i) = .0180
282  IF(i.EQ.20) gamprt(i) = .0096
283  IF(i.EQ.21) gamprt(i) = .0088
284  IF(i.EQ.22) gamprt(i) = .0146
285 #else
286 #endif
287  IF(i.EQ. 1) oldnames(i)=' TAU- --> E- '
288  IF(i.EQ. 2) oldnames(i)=' TAU- --> MU- '
289  IF(i.EQ. 3) oldnames(i)=' TAU- --> PI- '
290  IF(i.EQ. 4) oldnames(i)=' TAU- --> PI-, PI0 '
291  IF(i.EQ. 5) oldnames(i)=' TAU- --> A1- (two subch) '
292  IF(i.EQ. 6) oldnames(i)=' TAU- --> K- '
293  IF(i.EQ. 7) oldnames(i)=' TAU- --> K*- (two subch) '
294  IF(i.EQ. 8) names(i-7)=' TAU- --> 2PI-, PI0, PI+ '
295  IF(i.EQ. 9) names(i-7)=' TAU- --> 3PI0, PI- '
296  IF(i.EQ.10) names(i-7)=' TAU- --> 2PI-, PI+, 2PI0 '
297  IF(i.EQ.11) names(i-7)=' TAU- --> 3PI-, 2PI+, '
298  IF(i.EQ.12) names(i-7)=' TAU- --> 3PI-, 2PI+, PI0 '
299  IF(i.EQ.13) names(i-7)=' TAU- --> 2PI-, PI+, 3PI0 '
300  IF(i.EQ.14) names(i-7)=' TAU- --> K-, PI-, K+ '
301  IF(i.EQ.15) names(i-7)=' TAU- --> K0, PI-, K0B '
302 #if defined (ALEPH)
303  IF(i.EQ.16) names(i-7)=' TAU- --> K- PI0 K0 '
304 #else
305  IF(i.EQ.16) names(i-7)=' TAU- --> K-, K0, PI0 '
306 #endif
307  IF(i.EQ.17) names(i-7)=' TAU- --> PI0 PI0 K- '
308  IF(i.EQ.18) names(i-7)=' TAU- --> K- PI- PI+ '
309  IF(i.EQ.19) names(i-7)=' TAU- --> PI- K0B PI0 '
310  IF(i.EQ.20) names(i-7)=' TAU- --> ETA PI- PI0 '
311  IF(i.EQ.21) names(i-7)=' TAU- --> PI- PI0 GAM '
312  IF(i.EQ.22) names(i-7)=' TAU- --> K- K0 '
313  ELSE
314  jlist(i) = 0
315  gamprt(i) = 0.
316  ENDIF
317  1 CONTINUE
318  DO i=1,nmode
319  mulpik(i)=npik(i)
320  DO j=1,mulpik(i)
321  idffin(j,i)=nopik(j,i)
322  ENDDO
323  ENDDO
324 *
325 *
326 * --- COEFFICIENTS TO FIX RATIO OF:
327 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
328 * --- PROBABILITY OF K0 TO BE KS
329 * --- PROBABILITY OF K0B TO BE KS
330 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
331 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
332 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
333 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
334  bra1=0.5
335  brk0=0.5
336  brk0b=0.5
337  brks=0.6667
338 *
339 
340  gfermi = 1.16637e-5
341  ccabib = 0.975
342  gv = 1.0
343  ga =-1.0
344  gfermi = xpar(32)
345  IF (xpar(itauxpar+100+1).GT.-1d0) THEN
346 C initialization form KK
347  ccabib = xpar(itauxpar+7)
348  gv = xpar(itauxpar+8)
349  ga = xpar(itauxpar+9)
350 
351  bra1 = xpar(itauxpar+10)
352  brks = xpar(itauxpar+11)
353  brk0 = xpar(itauxpar+12)
354  brk0b = xpar(itauxpar+13)
355  DO k=1,nchan
356  gamprt(k)=xpar(itauxpar+100+k)
357  ENDDO
358  ENDIF
359 * ZW 13.04.89 HERE WAS AN ERROR
360  scabib = sqrt(1.-ccabib**2)
361  pi =4.*atan(1.)
362  gamel = gfermi**2*amtau**5/(192*pi**3)
363 *
364 * CALL DEXAY(-1,pol1)
365 *
366 * PRINTOUTS FOR KK version
367 
368  sum=0
369  DO k=1,nchan
370  sum=sum+gamprt(k)
371  ENDDO
372 
373 
374  WRITE(iout,bxope)
375  WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INITDK: '
376  WRITE(iout,bxtxt) ' Adopted to read from KK '
377  WRITE(iout,bxtxt) ' '
378  WRITE(iout,bxtxt) ' Choice Probability -- Decay Channel'
379  DO k=1,7
380  WRITE(iout,bxinit) gamprt(k)/sum, oldnames(k),'****','***'
381  ENDDO
382  DO k=8,7+nmode
383  WRITE(iout,bxinit) gamprt(k)/sum, names(k-7),'****','***'
384  ENDDO
385  WRITE(iout,bxtxt) ' In addition:'
386  WRITE(iout,bxinit) gv, 'Vector W-tau-nu coupl. ','****','***'
387  WRITE(iout,bxinit) ga, 'Axial W-tau-nu coupl. ','****','***'
388  WRITE(iout,bxinit) gfermi,'Fermi Coupling ','****','***'
389  WRITE(iout,bxinit) ccabib,'cabibo angle ','****','***'
390  WRITE(iout,bxinit) bra1, 'a1 br ratio (massless) ','****','***'
391  WRITE(iout,bxinit) brks, 'K* br ratio (massless) ','****','***'
392  WRITE(iout,bxclo)
393 
394  RETURN
395  END
396 
397  SUBROUTINE iniphy(XK00)
398 * ----------------------------------------------------------------------
399 * INITIALISATION OF PARAMETERS
400 * USED IN QED and/or GSW ROUTINES
401 * ----------------------------------------------------------------------
402  COMMON / qedprm /alfinv,alfpi,xk0
403  real*8 alfinv,alfpi,xk0
404  real*8 pi8,xk00
405 *
406  pi8 = 4.d0*datan(1.d0)
407  alfinv = 137.03604d0
408  alfpi = 1d0/(alfinv*pi8)
409  xk0=xk00
410  END
411 
412  SUBROUTINE inimas(ITAUXPAR,xpar)
413 * ----------------------------------------------------------------------
414 * INITIALISATION OF MASSES
415 *
416 * called by : KORALZ
417 * ----------------------------------------------------------------------
418  include "BXformat.h"
419  INTEGER INUT,IOUT
420  COMMON /inout/
421  $ inut, ! Input unit number (not used)
422  $ iout ! Ounput unit number
423  real*8 xpar(*)
424  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
425  * ,ampiz,ampi,amro,gamro,ama1,gama1
426  * ,amk,amkz,amkst,gamkst
427 *
428  real*4 amtau,amnuta,amel,amnue,ammu,amnumu
429  * ,ampiz,ampi,amro,gamro,ama1,gama1
430  * ,amk,amkz,amkst,gamkst
431  CHARACTER*80 bxINIT
432  parameter(
433  $ bxinit ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
434  $ )
435 *
436 * IN-COMING / OUT-GOING FERMION MASSES
437  amtau = xpar(656)
438  amnuta = 0.010
439  amel = xpar(616)
440  amnue = 0.0
441  ammu = xpar(636)
442  amnumu = 0.0
443 *
444 * MASSES USED IN TAU DECAYS
445 #if defined (CePeCe)
446  ampiz = 0.134964
447  ampi = 0.139568
448  amro = 0.773
449  gamro = 0.145
450 *C GAMRO = 0.666
451  ama1 = 1.251
452  gama1 = 0.599
453  amk = 0.493667
454  amkz = 0.49772
455  amkst = 0.8921
456  gamkst = 0.0513
457 #elif defined (CLEO)
458  ampiz = 0.134964
459  ampi = 0.139568
460  amro = 0.773
461  gamro = 0.145
462 *C GAMRO = 0.666
463  ama1 = 1.251
464  gama1 = 0.599
465  amk = 0.493667
466  amkz = 0.49772
467  amkst = 0.8921
468  gamkst = 0.0513
469 C
470 C
471 C IN-COMING / OUT-GOING FERMION MASSES
472 !! AMNUTA = PKORB(1,2)
473 !! AMNUE = PKORB(1,4)
474 !! AMNUMU = PKORB(1,6)
475 C
476 C MASSES USED IN TAU DECAYS Cleo settings
477 !! AMPIZ = PKORB(1,7)
478 !! AMPI = PKORB(1,8)
479 !! AMRO = PKORB(1,9)
480 !! GAMRO = PKORB(2,9)
481  ama1 = 1.275 !! PKORB(1,10)
482  gama1 = 0.615 !! PKORB(2,10)
483 !! AMK = PKORB(1,11)
484 !! AMKZ = PKORB(1,12)
485 !! AMKST = PKORB(1,13)
486 !! GAMKST = PKORB(2,13)
487 C
488 #elif defined (ALEPH)
489  ampiz = 0.134964
490  ampi = 0.139568
491  amro = 0.7714
492  gamro = 0.153
493 cam AMRO = 0.773
494 cam GAMRO = 0.145
495  ama1 = 1.251! PMAS(LUCOMP(ia1),1) ! AMA1 = 1.251
496  gama1 = 0.599! PMAS(LUCOMP(ia1),2) ! GAMA1 = 0.599
497  print *,'INIMAS a1 mass= ',ama1,gama1
498  amk = 0.493667
499  amkz = 0.49772
500  amkst = 0.8921
501  gamkst = 0.0513
502 #else
503 #endif
504  WRITE(iout,bxope)
505  WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INIMAS: '
506  WRITE(iout,bxtxt) ' Adopted to read from KK '
507  WRITE(iout,bxinit) amtau, 'AMTAU tau-mass ','****','***'
508  WRITE(iout,bxinit) amel , 'AMEL electron-mass ','****','***'
509  WRITE(iout,bxinit) ammu , 'AMMU muon-mass ','****','***'
510  WRITE(iout,bxclo)
511 
512  END
513 
514  SUBROUTINE choice(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
515  $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
516  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
517  * ,ampiz,ampi,amro,gamro,ama1,gama1
518  * ,amk,amkz,amkst,gamkst
519 *
520  real*4 amtau,amnuta,amel,amnue,ammu,amnumu
521  * ,ampiz,ampi,amro,gamro,ama1,gama1
522  * ,amk,amkz,amkst,gamkst
523 *
524  amrop=1.1
525  gamrop=0.36
526  amom=.782
527  gamom=0.0084
528 * XXXXA CORRESPOND TO S2 CHANNEL !
529  IF(mnum.EQ.0) THEN
530  prob1=0.5
531  prob2=0.5
532  amrx =ama1
533  gamrx=gama1
534  amra =amro
535  gamra=gamro
536  amrb =amro
537  gamrb=gamro
538  ELSEIF(mnum.EQ.1) THEN
539  prob1=0.5
540  prob2=0.5
541  amrx =1.57
542  gamrx=0.9
543  amrb =amkst
544  gamrb=gamkst
545  amra =amro
546  gamra=gamro
547  ELSEIF(mnum.EQ.2) THEN
548  prob1=0.5
549  prob2=0.5
550  amrx =1.57
551  gamrx=0.9
552  amrb =amkst
553  gamrb=gamkst
554  amra =amro
555  gamra=gamro
556  ELSEIF(mnum.EQ.3) THEN
557  prob1=0.5
558  prob2=0.5
559  amrx =1.27
560  gamrx=0.3
561  amra =amkst
562  gamra=gamkst
563  amrb =amkst
564  gamrb=gamkst
565  ELSEIF(mnum.EQ.4) THEN
566  prob1=0.5
567  prob2=0.5
568  amrx =1.27
569  gamrx=0.3
570  amra =amkst
571  gamra=gamkst
572  amrb =amkst
573  gamrb=gamkst
574  ELSEIF(mnum.EQ.5) THEN
575  prob1=0.5
576  prob2=0.5
577  amrx =1.27
578  gamrx=0.3
579  amra =amkst
580  gamra=gamkst
581  amrb =amro
582  gamrb=gamro
583  ELSEIF(mnum.EQ.6) THEN
584  prob1=0.4
585  prob2=0.4
586  amrx =1.27
587  gamrx=0.3
588  amra =amro
589  gamra=gamro
590  amrb =amkst
591  gamrb=gamkst
592  ELSEIF(mnum.EQ.7) THEN
593  prob1=0.0
594  prob2=1.0
595  amrx =1.27
596  gamrx=0.9
597  amra =amro
598  gamra=gamro
599  amrb =amro
600  gamrb=gamro
601  ELSEIF(mnum.EQ.8) THEN
602  prob1=0.0
603  prob2=1.0
604  amrx =amrop
605  gamrx=gamrop
606  amrb =amom
607  gamrb=gamom
608  amra =amro
609  gamra=gamro
610  ELSEIF(mnum.EQ.101) THEN
611  prob1=.35
612  prob2=.35
613  amrx =1.2
614  gamrx=.46
615  amrb =amom
616  gamrb=gamom
617  amra =amom
618  gamra=gamom
619  ELSEIF(mnum.EQ.102) THEN
620  prob1=0.0
621  prob2=0.0
622  amrx =1.4
623  gamrx=.6
624  amrb =amom
625  gamrb=gamom
626  amra =amom
627  gamra=gamom
628  ELSE
629  prob1=0.0
630  prob2=0.0
631  amrx =ama1
632  gamrx=gama1
633  amra =amro
634  gamra=gamro
635  amrb =amro
636  gamrb=gamro
637  ENDIF
638 *
639  IF (rr.LE.prob1) THEN
640  ichan=1
641  ELSEIF(rr.LE.(prob1+prob2)) THEN
642  ichan=2
643  ax =amra
644  gx =gamra
645  amra =amrb
646  gamra=gamrb
647  amrb =ax
648  gamrb=gx
649  px =prob1
650  prob1=prob2
651  prob2=px
652  ELSE
653  ichan=3
654  ENDIF
655 *
656  prob3=1.0-prob1-prob2
657  END
658 
659  FUNCTION dcdmas(IDENT)
660  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
661  * ,ampiz,ampi,amro,gamro,ama1,gama1
662  * ,amk,amkz,amkst,gamkst
663 *
664  real*4 amtau,amnuta,amel,amnue,ammu,amnumu
665  * ,ampiz,ampi,amro,gamro,ama1,gama1
666  * ,amk,amkz,amkst,gamkst
667  IF (ident.EQ. 1) THEN
668  apkmas=ampi
669  ELSEIF (ident.EQ.-1) THEN
670  apkmas=ampi
671  ELSEIF (ident.EQ. 2) THEN
672  apkmas=ampiz
673  ELSEIF (ident.EQ.-2) THEN
674  apkmas=ampiz
675  ELSEIF (ident.EQ. 3) THEN
676  apkmas=amk
677  ELSEIF (ident.EQ.-3) THEN
678  apkmas=amk
679  ELSEIF (ident.EQ. 4) THEN
680  apkmas=amkz
681  ELSEIF (ident.EQ.-4) THEN
682  apkmas=amkz
683  ELSEIF (ident.EQ. 8) THEN
684  apkmas=0.0001
685  ELSEIF (ident.EQ.-8) THEN
686  apkmas=0.0001
687  ELSEIF (ident.EQ. 9) THEN
688  apkmas=0.5488
689  ELSEIF (ident.EQ.-9) THEN
690  apkmas=0.5488
691  ELSE
692  print *, 'STOP IN APKMAS, WRONG IDENT=',ident
693  stop
694  ENDIF
695  dcdmas=apkmas
696  END
697  FUNCTION lunpik(ID,ISGN)
698  COMMON / taukle / bra1,brk0,brk0b,brks
699  real*4 bra1,brk0,brk0b,brks
700  real*4 xio(1)
701  ident=id*isgn
702 #if defined (ALEPH)
703  IF (ident.EQ. 1) THEN
704  ipkdef= 211
705  ELSEIF (ident.EQ.-1) THEN
706  ipkdef=-211
707  ELSEIF (ident.EQ. 2) THEN
708  ipkdef= 111
709  ELSEIF (ident.EQ.-2) THEN
710  ipkdef= 111
711  ELSEIF (ident.EQ. 3) THEN
712  ipkdef= 321
713  ELSEIF (ident.EQ.-3) THEN
714  ipkdef=-321
715 #else
716  IF (ident.EQ. 1) THEN
717  ipkdef=-211
718  ELSEIF (ident.EQ.-1) THEN
719  ipkdef= 211
720  ELSEIF (ident.EQ. 2) THEN
721  ipkdef=111
722  ELSEIF (ident.EQ.-2) THEN
723  ipkdef=111
724  ELSEIF (ident.EQ. 3) THEN
725  ipkdef=-321
726  ELSEIF (ident.EQ.-3) THEN
727  ipkdef= 321
728 #endif
729  ELSEIF (ident.EQ. 4) THEN
730 *
731 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
732  CALL ranmar(xio,1)
733  IF (xio(1).GT.brk0) THEN
734  ipkdef= 130
735  ELSE
736  ipkdef= 310
737  ENDIF
738  ELSEIF (ident.EQ.-4) THEN
739 *
740 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
741  CALL ranmar(xio,1)
742  IF (xio(1).GT.brk0b) THEN
743  ipkdef= 130
744  ELSE
745  ipkdef= 310
746  ENDIF
747  ELSEIF (ident.EQ. 8) THEN
748  ipkdef= 22
749  ELSEIF (ident.EQ.-8) THEN
750  ipkdef= 22
751  ELSEIF (ident.EQ. 9) THEN
752  ipkdef= 221
753  ELSEIF (ident.EQ.-9) THEN
754  ipkdef= 221
755  ELSE
756  print *, 'STOP IN IPKDEF, WRONG IDENT=',ident
757  stop
758  ENDIF
759  lunpik=ipkdef
760  END
761 
762 
763 #if defined (CLEO)
764 
765  SUBROUTINE taurdf(KTO)
766 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
767 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
768 C CONTENTS
769  COMMON / taukle / bra1,brk0,brk0b,brks
770  real*4 bra1,brk0,brk0b,brks
771  COMMON / taubra / gamprt(30),jlist(30),nchan
772  IF (kto.EQ.1) THEN
773 C ==================
774 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
775  bra1 = pkorb(4,1)
776  brks = pkorb(4,3)
777  brk0 = pkorb(4,5)
778  brk0b = pkorb(4,6)
779  ELSE
780 C ====
781 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
782  bra1 = pkorb(4,2)
783  brks = pkorb(4,4)
784  brk0 = pkorb(4,5)
785  brk0b = pkorb(4,6)
786  ENDIF
787 C =====
788  END
789 #else
790 
791  SUBROUTINE taurdf(KTO)
792 * THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
793 * IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
794 * CONTENTS
795  COMMON / taukle / bra1,brk0,brk0b,brks
796  real*4 bra1,brk0,brk0b,brks
797  COMMON / taubra / gamprt(30),jlist(30),nchan
798  IF (kto.EQ.1) THEN
799 * ==================
800 * LIST OF BRANCHING RATIOS
801  nchan = 19
802  DO 1 i = 1,30
803  IF (i.LE.nchan) THEN
804  jlist(i) = i
805  IF(i.EQ. 1) gamprt(i) = .0000
806  IF(i.EQ. 2) gamprt(i) = .0000
807  IF(i.EQ. 3) gamprt(i) = .0000
808  IF(i.EQ. 4) gamprt(i) = .0000
809  IF(i.EQ. 5) gamprt(i) = .0000
810  IF(i.EQ. 6) gamprt(i) = .0000
811  IF(i.EQ. 7) gamprt(i) = .0000
812  IF(i.EQ. 8) gamprt(i) = 1.0000
813  IF(i.EQ. 9) gamprt(i) = 1.0000
814  IF(i.EQ.10) gamprt(i) = 1.0000
815  IF(i.EQ.11) gamprt(i) = 1.0000
816  IF(i.EQ.12) gamprt(i) = 1.0000
817  IF(i.EQ.13) gamprt(i) = 1.0000
818  IF(i.EQ.14) gamprt(i) = 1.0000
819  IF(i.EQ.15) gamprt(i) = 1.0000
820  IF(i.EQ.16) gamprt(i) = 1.0000
821  IF(i.EQ.17) gamprt(i) = 1.0000
822  IF(i.EQ.18) gamprt(i) = 1.0000
823  IF(i.EQ.19) gamprt(i) = 1.0000
824  ELSE
825  jlist(i) = 0
826  gamprt(i) = 0.
827  ENDIF
828  1 CONTINUE
829 * --- COEFFICIENTS TO FIX RATIO OF:
830 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
831 * --- PROBABILITY OF K0 TO BE KS
832 * --- PROBABILITY OF K0B TO BE KS
833 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
834 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
835 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
836 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
837  bra1=0.5
838  brk0=0.5
839  brk0b=0.5
840  brks=0.6667
841  ELSE
842 * ====
843 * LIST OF BRANCHING RATIOS
844  nchan = 19
845  DO 2 i = 1,30
846  IF (i.LE.nchan) THEN
847  jlist(i) = i
848  IF(i.EQ. 1) gamprt(i) = .0000
849  IF(i.EQ. 2) gamprt(i) = .0000
850  IF(i.EQ. 3) gamprt(i) = .0000
851  IF(i.EQ. 4) gamprt(i) = .0000
852  IF(i.EQ. 5) gamprt(i) = .0000
853  IF(i.EQ. 6) gamprt(i) = .0000
854  IF(i.EQ. 7) gamprt(i) = .0000
855  IF(i.EQ. 8) gamprt(i) = 1.0000
856  IF(i.EQ. 9) gamprt(i) = 1.0000
857  IF(i.EQ.10) gamprt(i) = 1.0000
858  IF(i.EQ.11) gamprt(i) = 1.0000
859  IF(i.EQ.12) gamprt(i) = 1.0000
860  IF(i.EQ.13) gamprt(i) = 1.0000
861  IF(i.EQ.14) gamprt(i) = 1.0000
862  IF(i.EQ.15) gamprt(i) = 1.0000
863  IF(i.EQ.16) gamprt(i) = 1.0000
864  IF(i.EQ.17) gamprt(i) = 1.0000
865  IF(i.EQ.18) gamprt(i) = 1.0000
866  IF(i.EQ.19) gamprt(i) = 1.0000
867  ELSE
868  jlist(i) = 0
869  gamprt(i) = 0.
870  ENDIF
871  2 CONTINUE
872 * --- COEFFICIENTS TO FIX RATIO OF:
873 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
874 * --- PROBABILITY OF K0 TO BE KS
875 * --- PROBABILITY OF K0B TO BE KS
876 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
877 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
878 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
879 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
880  bra1=0.5
881  brk0=0.5
882  brk0b=0.5
883  brks=0.6667
884  ENDIF
885 * =====
886  END
887 */////////////////////////////////////////////////////////////////////////////////////
888 *// //
889 *// THE END of //
890 *// Standard Tauola interface/initialization routines of functionality exactly //
891 *// as in Tauola CPC //
892 *// //
893 */////////////////////////////////////////////////////////////////////////////////////
894 #endif
895 
896 
897