C++ Interface to Tauola
tauola/demo-KK-face/Tauface.f
1/* copyright(c) 1991-2024 free software foundation, inc.
2 this file is part of the gnu c library.
3
4 the gnu c library is free software; you can redistribute it and/or
5 modify it under the terms of the gnu lesser general Public
6 license as published by the free software foundation; either
7 version 2.1 of the license, or(at your option) any later version.
8
9 the gnu c library is distributed in the hope that it will be useful,
10 but without any warranty; without even the implied warranty of
11 merchantability or fitness for a particular purpose. see the gnu
12 lesser general Public license for more details.
13
14 you should have received a copy of the gnu lesser general Public
15 license along with the gnu c library; if not, see
16 <https://www.gnu.org/licenses/>. */
17
18
19/* this header is separate from features.h so that the compiler can
20 include it implicitly at the start of every compilation. it must
21 not itself include <features.h> or any other header that includes
22 <features.h> because the implicit include comes before any feature
23 test macros that may be defined in a source file before it first
24 explicitly includes a system header. gcc knows the name of this
25 header in order to preinclude it. */
26
27/* glibc's intent is to support the IEC 559 math functionality, real
28 and complex. If the GCC (4.9 and later) predefined macros
29 specifying compiler intent are available, use them to determine
30 whether the overall intent is to support these features; otherwise,
31 presume an older compiler has intent to support these features and
32 define these macros by default. */
33
34
35
36/* wchar_t uses Unicode 10.0.0. Version 10.0 of the Unicode Standard is
37 synchronized with ISO/IEC 10646:2017, fifth edition, plus
38 the following additions from Amendment 1 to the fifth edition:
39 - 56 emoji characters
40 - 285 hentaigana
41 - 3 additional Zanabazar Square characters */
42
43*/////////////////////////////////////////////////////////////////////////////////////
44*// //
45*// !!!!!!! WARNING!!!!! This source is agressive !!!! //
46*// //
47*// Due to short common block names it owerwrites variables in other parts //
48*// of the code. //
49*// //
50*// One should add suffix c_Taul_ to names of all commons as soon as possible!!!! //
51*// //
52*/////////////////////////////////////////////////////////////////////////////////////
53
54*/////////////////////////////////////////////////////////////////////////////////////
55*// //
56*// Standard Tauola interface/initialization routines of functionality exactly //
57*// as in Tauola CPC but input is partially from xpar(*) matrix //
58*// ITAUXPAR is for indirect adressing //
59*// //
60*/////////////////////////////////////////////////////////////////////////////////////
61
62
63 SUBROUTINE INIETC(ITAUXPAR,xpar)
64 INCLUDE "BXformat.h"
65 REAL*8 xpar(*)
66 INTEGER INUT,IOUT
67 COMMON /INOUT/
68 $ INUT, ! Input unit number (not used)
69 $ IOUT ! Ounput unit number
70 COMMON / IDFC / IDFF
71 COMMON / TAURAD / XK0DEC,ITDKRC
72 DOUBLE PRECISION XK0DEC
73 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
74* Note: I dont see KeyA1=2,3 realy implemented in the code SJ. ??????
75 INTEGER KeyA1
76 COMMON /TESTA1/
77 $ KeyA1 ! Special switch for tests of dGamma/dQ**2 in a1 decay
78* KeyA1=1 constant width of a1 and rho
79* KeyA1=2 free choice of rho propagator (defined in function FPIK)
80* and free choice of a1 mass and width. function g(Q**2)
81* (see formula 3.48 in Comp. Phys. Comm. 64 (1991) 275)
82* hard coded both in Monte Carlo and in testing distribution.
83* KeyA1=3 function g(Q**2) hardcoded in the Monte Carlo
84* (it is timy to calculate!), but appropriately adjusted in testing distribution.
85 SAVE
86 idff = xpar(ITAUXPAR+3) ! Lund identifier for first tau (15 for tau-)
87C XK0 for tau decays.
88 xk0dec = xpar(ITAUXPAR+5) ! IR-cut for QED rad. in leptonic decays
89C radiative correction switch in tau --> e (mu) decays !
90 itdkRC = xpar(ITAUXPAR+4) ! QED rad. in leptonic decays
91C switches of tau+ tau- decay modes !!
92 Jak1 = xpar(ITAUXPAR+1) ! Decay Mask for first tau
93 Jak2 = xpar(ITAUXPAR+2) ! Decay Mask for second tau
94C output file number for TAUOLA
95 IOUT = xpar(4)
96C KeyA1 is used for formfactors actually not in use
97 KeyA1 = xpar(ITAUXPAR+6) ! Type of a1 current
98
99 WRITE(iout,bxope)
100 WRITE(iout,bxtxt) ' parameters passed from kk to tauola: '
101 WRITE(iout,bxl1i) Jak1, 'dec. type 1-st tau ','jak1 ','t01'
102 WRITE(iout,bxl1i) Jak2, 'dec. type 2-nd tau ','jak2 ','t02'
103 WRITE(iout,bxl1i) KeyA1, 'current type a1 dec.','keya1 ','t03'
104 WRITE(iout,bxl1i) idff, 'pdg id 1-st tau ','idff ','t04'
105 WRITE(iout,bxl1i) itdkRC, 'r.c. switch lept dec','itdkrc','t05'
106 WRITE(iout,bxl1g) xk0dec, 'ir-cut for lept r.c.','xk0dec','t06'
107 WRITE(iout,bxclo)
108
109 end
110
111 SUBROUTINE INITDK(ITAUXPAR,xpar)
112* ----------------------------------------------------------------------
113* INITIALISATION OF TAU DECAY PARAMETERS and routines
114*
115* called by : KORALZ
116* ----------------------------------------------------------------------
117 INCLUDE "BXformat.h"
118 INTEGER INUT,IOUT
119 COMMON /INOUT/
120 $ INUT, ! Input unit number (not used)
121 $ IOUT ! Ounput unit number
122 REAL*8 xpar(*)
123
124 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
125 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
126 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
127 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
128 * ,AMK,AMKZ,AMKST,GAMKST
129*
130 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
131 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
132 * ,AMK,AMKZ,AMKST,GAMKST
133 COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
134 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
135 REAL*4 BRA1,BRK0,BRK0B,BRKS
136 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
137 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
138 & ,NAMES
139 CHARACTER NAMES(NMODE)*31
140 CHARACTER OLDNAMES(7)*31
141 CHARACTER*80 bxINIT
142 PARAMETER (
143 $ bxINIT ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
144 $ )
145 REAL*4 PI,POL1(4)
146*
147*
148* LIST OF BRANCHING RATIOS
149CAM normalised to e nu nutau channel
150CAM enu munu pinu rhonu A1nu Knu K*nu pi
151CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
152*AM DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
153*AM
154*AM multipion decays
155*
156* conventions of particles names
157* K-,P-,K+, K0,P-,KB, K-,P0,K0
158* 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
159* P0,P0,K-, K-,P-,P+, P-,KB,P0
160* 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
161* ET,P-,P0 P-,P0,GM
162* 9, 1, 2 , 1, 2, 8
163*
164C
165 DIMENSION NOPIK(6,NMODE),NPIK(NMODE)
166*AM outgoing multiplicity and flavors of multi-pion /multi-K modes
167 DATA NPIK / 4, 4,
168 1 5, 5,
169 2 6, 6,
170 3 3, 3,
171 4 3, 3,
172 5 3, 3,
173 6 3, 3,
174 7 2 /
175 DATA NOPIK / -1,-1, 1, 2, 0, 0, 2, 2, 2,-1, 0, 0,
176 1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
177 2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
178 3 -3,-1, 3, 0, 0, 0, -4,-1, 4, 0, 0, 0,
179 4 -3, 2,-4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
180 5 -3,-1, 1, 0, 0, 0, -1, 4, 2, 0, 0, 0,
181 6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
182C AJWMOD fix sign bug, 2/22/99
183 7 -3,-4, 0, 0, 0, 0 /
184* LIST OF BRANCHING RATIOS
185 NCHAN = NMODE + 7
186 DO 1 I = 1,30
187.LE. IF (INCHAN) THEN
188 JLIST(I) = I
189.EQ. IF(I 1) GAMPRT(I) =0.1800
190.EQ. IF(I 2) GAMPRT(I) =0.1751
191.EQ. IF(I 3) GAMPRT(I) =0.1110
192.EQ. IF(I 4) GAMPRT(I) =0.2515
193.EQ. IF(I 5) GAMPRT(I) =0.1790
194.EQ. IF(I 6) GAMPRT(I) =0.0071
195.EQ. IF(I 7) GAMPRT(I) =0.0134
196.EQ. IF(I 8) GAMPRT(I) =0.0450
197.EQ. IF(I 9) GAMPRT(I) =0.0100
198.EQ. IF(I10) GAMPRT(I) =0.0009
199.EQ. IF(I11) GAMPRT(I) =0.0004
200.EQ. IF(I12) GAMPRT(I) =0.0003
201.EQ. IF(I13) GAMPRT(I) =0.0005
202.EQ. IF(I14) GAMPRT(I) =0.0015
203.EQ. IF(I15) GAMPRT(I) =0.0015
204.EQ. IF(I16) GAMPRT(I) =0.0015
205.EQ. IF(I17) GAMPRT(I) =0.0005
206.EQ. IF(I18) GAMPRT(I) =0.0050
207.EQ. IF(I19) GAMPRT(I) =0.0055
208.EQ. IF(I20) GAMPRT(I) =0.0017
209.EQ. IF(I21) GAMPRT(I) =0.0013
210.EQ. IF(I22) GAMPRT(I) =0.0010
211.EQ. IF(I 1) OLDNAMES(I)=' tau- --> e- '
212.EQ. IF(I 2) OLDNAMES(I)=' tau- --> mu- '
213.EQ. IF(I 3) OLDNAMES(I)=' tau- --> pi- '
214.EQ. IF(I 4) OLDNAMES(I)=' tau- --> pi-, pi0 '
215.EQ. IF(I 5) OLDNAMES(I)=' tau- --> a1- (two subch) '
216.EQ. IF(I 6) OLDNAMES(I)=' tau- --> k- '
217.EQ. IF(I 7) OLDNAMES(I)=' tau- --> k*- (two subch) '
218.EQ. IF(I 8) NAMES(I-7)=' tau- --> 2pi-, pi0, pi+ '
219.EQ. IF(I 9) NAMES(I-7)=' tau- --> 3pi0, pi- '
220.EQ. IF(I10) NAMES(I-7)=' tau- --> 2pi-, pi+, 2pi0 '
221.EQ. IF(I11) NAMES(I-7)=' tau- --> 3pi-, 2pi+, '
222.EQ. IF(I12) NAMES(I-7)=' tau- --> 3pi-, 2pi+, pi0 '
223.EQ. IF(I13) NAMES(I-7)=' tau- --> 2pi-, pi+, 3pi0 '
224.EQ. IF(I14) NAMES(I-7)=' tau- --> k-, pi-, k+ '
225.EQ. IF(I15) NAMES(I-7)=' tau- --> k0, pi-, k0b '
226.EQ. IF(I16) NAMES(I-7)=' tau- --> k-, k0, pi0 '
227.EQ. IF(I17) NAMES(I-7)=' tau- --> pi0 pi0 k- '
228.EQ. IF(I18) NAMES(I-7)=' tau- --> k- pi- pi+ '
229.EQ. IF(I19) NAMES(I-7)=' tau- --> pi- k0b pi0 '
230.EQ. IF(I20) NAMES(I-7)=' tau- --> eta pi- pi0 '
231.EQ. IF(I21) NAMES(I-7)=' tau- --> pi- pi0 gam '
232.EQ. IF(I22) NAMES(I-7)=' tau- --> k- k0 '
233 ELSE
234 JLIST(I) = 0
235 GAMPRT(I) = 0.
236 ENDIF
237 1 CONTINUE
238 DO I=1,NMODE
239 MULPIK(I)=NPIK(I)
240 DO J=1,MULPIK(I)
241 IDFFIN(J,I)=NOPIK(J,I)
242 ENDDO
243 ENDDO
244*
245*
246* --- COEFFICIENTS TO FIX RATIO OF:
247* --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
248* --- PROBABILITY OF K0 TO BE KS
249* --- PROBABILITY OF K0B TO BE KS
250* --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
251* --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
252* --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
253* --- NEGLECTS MASS-PHASE SPACE EFFECTS
254 BRA1=0.5
255 BRK0=0.5
256 BRK0B=0.5
257 BRKS=0.6667
258*
259
260 GFERMI = 1.16637E-5
261 CCABIB = 0.975
262 GV = 1.0
263 GA =-1.0
264
265
266
267 GFERMI = xpar(32)
268.GT. IF (XPAR(ITAUXPAR+100+1)-1D0) THEN
269C initialization form KK
270 CCABIB = XPAR(ITAUXPAR+7)
271 GV = XPAR(ITAUXPAR+8)
272 GA = XPAR(ITAUXPAR+9)
273
274 BRA1 = XPAR(ITAUXPAR+10)
275 BRKS = XPAR(ITAUXPAR+11)
276 BRK0 = XPAR(ITAUXPAR+12)
277 BRK0B = XPAR(ITAUXPAR+13)
278 DO K=1,NCHAN
279 GAMPRT(K)=XPAR(ITAUXPAR+100+K)
280 ENDDO
281 ENDIF
282* ZW 13.04.89 HERE WAS AN ERROR
283 SCABIB = SQRT(1.-CCABIB**2)
284 PI =4.*ATAN(1.)
285 GAMEL = GFERMI**2*AMTAU**5/(192*PI**3)
286*
287* CALL DEXAY(-1,pol1)
288*
289* PRINTOUTS FOR KK version
290
291 SUM=0
292 DO K=1,NCHAN
293 SUM=SUM+GAMPRT(K)
294 ENDDO
295
296
297 WRITE(iout,bxope)
298 WRITE(iout,bxtxt) ' tauola initialization SUBROUTINE initdk: '
299 WRITE(iout,bxtxt) ' adopted to read from kk '
300 WRITE(iout,bxtxt) ' '
301 WRITE(iout,bxtxt) ' choice probability -- decay channel'
302 DO K=1,7
303 WRITE(iout,bxINIT) GAMPRT(K)/SUM, OLDNAMES(K),'****','***'
304 ENDDO
305 DO K=8,7+NMODE
306 WRITE(iout,bxINIT) GAMPRT(K)/SUM, NAMES(K-7),'****','***'
307 ENDDO
308 WRITE(iout,bxtxt) ' in addition:'
309 WRITE(iout,bxINIT) GV, 'vector w-tau-nu coupl. ','****','***'
310 WRITE(iout,bxINIT) GA, 'axial w-tau-nu coupl. ','****','***'
311 WRITE(iout,bxINIT) GFERMI,'fermi coupling ','****','***'
312 WRITE(iout,bxINIT) CCABIB,'cabibo angle ','****','***'
313 WRITE(iout,bxINIT) BRA1, 'a1 br ratio (massless) ','****','***'
314 WRITE(iout,bxINIT) BRKS, 'k* br ratio (massless) ','****','***'
315 WRITE(iout,bxclo)
316
317 RETURN
318 END
319
320 SUBROUTINE INIPHY(XK00)
321* ----------------------------------------------------------------------
322* INITIALISATION OF PARAMETERS
323* USED IN QED and/or GSW ROUTINES
324* ----------------------------------------------------------------------
325 COMMON / QEDPRM /ALFINV,ALFPI,XK0
326 REAL*8 ALFINV,ALFPI,XK0
327 REAL*8 PI8,XK00
328*
329 PI8 = 4.D0*DATAN(1.D0)
330 ALFINV = 137.03604D0
331 ALFPI = 1D0/(ALFINV*PI8)
332 XK0=XK00
333 END
334
335 SUBROUTINE INIMAS(ITAUXPAR,xpar)
336* ----------------------------------------------------------------------
337* INITIALISATION OF MASSES
338*
339* called by : KORALZ
340* ----------------------------------------------------------------------
341 INCLUDE "BXformat.h"
342 INTEGER INUT,IOUT
343 COMMON /INOUT/
344 $ INUT, ! Input unit number (not used)
345 $ IOUT ! Ounput unit number
346 REAL*8 xpar(*)
347 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
348 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
349 * ,AMK,AMKZ,AMKST,GAMKST
350*
351 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
352 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
353 * ,AMK,AMKZ,AMKST,GAMKST
354 CHARACTER*80 bxINIT
355 PARAMETER (
356 $ bxINIT ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
357 $ )
358*
359* IN-COMING / OUT-GOING FERMION MASSES
360 AMTAU = xpar(656)
361 AMNUTA = 0.010
362 AMEL = xpar(616)
363 AMNUE = 0.0
364 AMMU = xpar(636)
365 AMNUMU = 0.0
366*
367* MASSES USED IN TAU DECAYS
368 AMPIZ = 0.134964
369 AMPI = 0.139568
370 AMRO = 0.773
371 GAMRO = 0.145
372*C GAMRO = 0.666
373 AMA1 = 1.251
374 GAMA1 = 0.599
375 AMK = 0.493667
376 AMKZ = 0.49772
377 AMKST = 0.8921
378 GAMKST = 0.0513
379C
380C
381C IN-COMING / OUT-GOING FERMION MASSES
382!! AMNUTA = PKORB(1,2)
383!! AMNUE = PKORB(1,4)
384!! AMNUMU = PKORB(1,6)
385C
386C MASSES USED IN TAU DECAYS Cleo settings
387!! AMPIZ = PKORB(1,7)
388!! AMPI = PKORB(1,8)
389!! AMRO = PKORB(1,9)
390!! GAMRO = PKORB(2,9)
391 AMA1 = 1.275 !! PKORB(1,10)
392 GAMA1 = 0.615 !! PKORB(2,10)
393!! AMK = PKORB(1,11)
394!! AMKZ = PKORB(1,12)
395!! AMKST = PKORB(1,13)
396!! GAMKST = PKORB(2,13)
397C
398
399 WRITE(iout,bxope)
400 WRITE(iout,bxtxt) ' tauola initialization subroutine inimas: '
401 WRITE(iout,bxtxt) ' adopted to read from kk '
402 WRITE(iout,bxINIT) amtau, 'amtau tau-mass ','****','***'
403 WRITE(iout,bxINIT) amel , 'amel electron-mass ','****','***'
404 WRITE(iout,bxINIT) ammu , 'ammu muon-mass ','****','***'
405 WRITE(iout,bxclo)
406
407 END
408 SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
409 $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
410 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
411 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
412 * ,AMK,AMKZ,AMKST,GAMKST
413C
414 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
415 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
416 * ,AMK,AMKZ,AMKST,GAMKST
417C
418 AMROP=1.1
419 GAMROP=0.36
420 AMOM=.782
421 GAMOM=0.0084
422C XXXXA CORRESPOND TO S2 CHANNEL !
423.EQ. IF(MNUM0) THEN
424 PROB1=0.5
425 PROB2=0.5
426 AMRX =AMA1
427 GAMRX=GAMA1
428 AMRA =AMRO
429 GAMRA=GAMRO
430 AMRB =AMRO
431 GAMRB=GAMRO
432.EQ. ELSEIF(MNUM1) THEN
433 PROB1=0.5
434 PROB2=0.5
435 AMRX =1.57
436 GAMRX=0.9
437 AMRB =AMKST
438 GAMRB=GAMKST
439 AMRA =AMRO
440 GAMRA=GAMRO
441.EQ. ELSEIF(MNUM2) THEN
442 PROB1=0.5
443 PROB2=0.5
444 AMRX =1.57
445 GAMRX=0.9
446 AMRB =AMKST
447 GAMRB=GAMKST
448 AMRA =AMRO
449 GAMRA=GAMRO
450.EQ. ELSEIF(MNUM3) THEN
451 PROB1=0.5
452 PROB2=0.5
453 AMRX =1.27
454 GAMRX=0.3
455 AMRA =AMKST
456 GAMRA=GAMKST
457 AMRB =AMKST
458 GAMRB=GAMKST
459.EQ. ELSEIF(MNUM4) THEN
460 PROB1=0.5
461 PROB2=0.5
462 AMRX =1.27
463 GAMRX=0.3
464 AMRA =AMKST
465 GAMRA=GAMKST
466 AMRB =AMKST
467 GAMRB=GAMKST
468.EQ. ELSEIF(MNUM5) THEN
469 PROB1=0.5
470 PROB2=0.5
471 AMRX =1.27
472 GAMRX=0.3
473 AMRA =AMKST
474 GAMRA=GAMKST
475 AMRB =AMRO
476 GAMRB=GAMRO
477.EQ. ELSEIF(MNUM6) THEN
478 PROB1=0.4
479 PROB2=0.4
480 AMRX =1.27
481 GAMRX=0.3
482 AMRA =AMRO
483 GAMRA=GAMRO
484 AMRB =AMKST
485 GAMRB=GAMKST
486.EQ. ELSEIF(MNUM7) THEN
487 PROB1=0.0
488 PROB2=1.0
489 AMRX =1.27
490 GAMRX=0.9
491 AMRA =AMRO
492 GAMRA=GAMRO
493 AMRB =AMRO
494 GAMRB=GAMRO
495.EQ. ELSEIF(MNUM8) THEN
496 PROB1=0.0
497 PROB2=1.0
498 AMRX =AMROP
499 GAMRX=GAMROP
500 AMRB =AMOM
501 GAMRB=GAMOM
502 AMRA =AMRO
503 GAMRA=GAMRO
504.EQ. ELSEIF(MNUM101) THEN
505 PROB1=.35
506 PROB2=.35
507 AMRX =1.2
508 GAMRX=.46
509 AMRB =AMOM
510 GAMRB=GAMOM
511 AMRA =AMOM
512 GAMRA=GAMOM
513.EQ. ELSEIF(MNUM102) THEN
514 PROB1=0.0
515 PROB2=0.0
516 AMRX =1.4
517 GAMRX=.6
518 AMRB =AMOM
519 GAMRB=GAMOM
520 AMRA =AMOM
521 GAMRA=GAMOM
522 ELSE
523 PROB1=0.0
524 PROB2=0.0
525 AMRX =AMA1
526 GAMRX=GAMA1
527 AMRA =AMRO
528 GAMRA=GAMRO
529 AMRB =AMRO
530 GAMRB=GAMRO
531 ENDIF
532C
533.LE. IF (RRPROB1) THEN
534 ICHAN=1
535.LE. ELSEIF(RR(PROB1+PROB2)) THEN
536 ICHAN=2
537 AX =AMRA
538 GX =GAMRA
539 AMRA =AMRB
540 GAMRA=GAMRB
541 AMRB =AX
542 GAMRB=GX
543 PX =PROB1
544 PROB1=PROB2
545 PROB2=PX
546 ELSE
547 ICHAN=3
548 ENDIF
549C
550 PROB3=1.0-PROB1-PROB2
551 END
552 FUNCTION DCDMAS(IDENT)
553 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
554 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
555 * ,AMK,AMKZ,AMKST,GAMKST
556*
557 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
558 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
559 * ,AMK,AMKZ,AMKST,GAMKST
560.EQ. IF (IDENT 1) THEN
561 APKMAS=AMPI
562.EQ. ELSEIF (IDENT-1) THEN
563 APKMAS=AMPI
564.EQ. ELSEIF (IDENT 2) THEN
565 APKMAS=AMPIZ
566.EQ. ELSEIF (IDENT-2) THEN
567 APKMAS=AMPIZ
568.EQ. ELSEIF (IDENT 3) THEN
569 APKMAS=AMK
570.EQ. ELSEIF (IDENT-3) THEN
571 APKMAS=AMK
572.EQ. ELSEIF (IDENT 4) THEN
573 APKMAS=AMKZ
574.EQ. ELSEIF (IDENT-4) THEN
575 APKMAS=AMKZ
576.EQ. ELSEIF (IDENT 8) THEN
577 APKMAS=0.0001
578.EQ. ELSEIF (IDENT-8) THEN
579 APKMAS=0.0001
580.EQ. ELSEIF (IDENT 9) THEN
581 APKMAS=0.5488
582.EQ. ELSEIF (IDENT-9) THEN
583 APKMAS=0.5488
584 ELSE
585 PRINT *, 'stop in apkmas, wrong ident=',IDENT
586 STOP
587 ENDIF
588 DCDMAS=APKMAS
589 END
590 FUNCTION LUNPIK(ID,ISGN)
591 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
592 REAL*4 BRA1,BRK0,BRK0B,BRKS
593 REAL*4 XIO(1)
594 IDENT=ID*ISGN
595.EQ. IF (IDENT 1) THEN
596 IPKDEF=-211
597.EQ. ELSEIF (IDENT-1) THEN
598 IPKDEF= 211
599.EQ. ELSEIF (IDENT 2) THEN
600 IPKDEF=111
601.EQ. ELSEIF (IDENT-2) THEN
602 IPKDEF=111
603.EQ. ELSEIF (IDENT 3) THEN
604 IPKDEF=-321
605.EQ. ELSEIF (IDENT-3) THEN
606 IPKDEF= 321
607.EQ. ELSEIF (IDENT 4) THEN
608*
609* K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
610 CALL RANMAR(XIO,1)
611.GT. IF (XIO(1)BRK0) THEN
612 IPKDEF= 130
613 ELSE
614 IPKDEF= 310
615 ENDIF
616.EQ. ELSEIF (IDENT-4) THEN
617*
618* K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
619 CALL RANMAR(XIO,1)
620.GT. IF (XIO(1)BRK0B) THEN
621 IPKDEF= 130
622 ELSE
623 IPKDEF= 310
624 ENDIF
625.EQ. ELSEIF (IDENT 8) THEN
626 IPKDEF= 22
627.EQ. ELSEIF (IDENT-8) THEN
628 IPKDEF= 22
629.EQ. ELSEIF (IDENT 9) THEN
630 IPKDEF= 221
631.EQ. ELSEIF (IDENT-9) THEN
632 IPKDEF= 221
633 ELSE
634 PRINT *, 'stop in ipkdef, wrong ident=',IDENT
635 STOP
636 ENDIF
637 LUNPIK=IPKDEF
638 END
639
640
641
642 SUBROUTINE TAURDF(KTO)
643C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
644C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
645C CONTENTS
646 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
647 REAL*4 BRA1,BRK0,BRK0B,BRKS
648 COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
649.EQ. IF (KTO1) THEN
650C ==================
651C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
652 BRA1 = PKORB(4,1)
653 BRKS = PKORB(4,3)
654 BRK0 = PKORB(4,5)
655 BRK0B = PKORB(4,6)
656 ELSE
657C ====
658C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
659 BRA1 = PKORB(4,2)
660 BRKS = PKORB(4,4)
661 BRK0 = PKORB(4,5)
662 BRK0B = PKORB(4,6)
663 ENDIF
664C =====
665 END