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