1/* copyright(c) 1991-2025 free software foundation, inc.
2 this file is part of the gnu c library.
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.
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.
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/>. */
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. */
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. */
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:
41 - 3 additional Zanabazar Square characters */
43*/////////////////////////////////////////////////////////////////////////////////////
45*// !!!!!!! WARNING!!!!! This source is agressive !!!! //
47*// Due to short common block names it owerwrites variables in other parts //
50*// One should add suffix c_Taul_ to names of all commons as soon as possible!!!! //
52*/////////////////////////////////////////////////////////////////////////////////////
54*/////////////////////////////////////////////////////////////////////////////////////
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 //
60*/////////////////////////////////////////////////////////////////////////////////////
63 SUBROUTINE INIETC(ITAUXPAR,xpar)
68 $ INUT, ! Input unit number (not used)
69 $ IOUT ! Ounput unit number
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. ??????
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.
86 idff = xpar(ITAUXPAR+3) ! Lund identifier for first tau (15 for tau-)
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
96C KeyA1 is used for formfactors actually not in use
97 KeyA1 = xpar(ITAUXPAR+6) ! Type of a1 current
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
'
111 SUBROUTINE INITDK(ITAUXPAR,xpar)
112* ----------------------------------------------------------------------
113* INITIALISATION OF TAU DECAY PARAMETERS and routines
116* ----------------------------------------------------------------------
120 $ INUT, ! Input unit number (not used)
121 $ IOUT ! Ounput unit number
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
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)
139 CHARACTER NAMES(NMODE)*31
140 CHARACTER OLDNAMES(7)*31
143 $ bxINIT ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)
'
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
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 ,
165 DIMENSION NOPIK(6,NMODE),NPIK(NMODE)
166*AM outgoing multiplicity and flavors of multi-pion /multi-K modes
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
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
'
241 IDFFIN(J,I)=NOPIK(J,I)
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
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)
274 BRA1 = XPAR(ITAUXPAR+10)
275 BRKS = XPAR(ITAUXPAR+11)
276 BRK0 = XPAR(ITAUXPAR+12)
277 BRK0B = XPAR(ITAUXPAR+13)
279 GAMPRT(K)=XPAR(ITAUXPAR+100+K)
282* ZW 13.04.89 HERE WAS AN ERROR
283 SCABIB = SQRT(1.-CCABIB**2)
285 GAMEL = GFERMI**2*AMTAU**5/(192*PI**3)
289* PRINTOUTS FOR KK version
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
'
303 WRITE(iout,bxINIT) GAMPRT(K)/SUM, OLDNAMES(K),'****
','***
'
306 WRITE(iout,bxINIT) GAMPRT(K)/SUM, NAMES(K-7),'****
','***
'
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)
','****
','***
'
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
329 PI8 = 4.D0*DATAN(1.D0)
331 ALFPI = 1D0/(ALFINV*PI8)
335 SUBROUTINE INIMAS(ITAUXPAR,xpar)
336* ----------------------------------------------------------------------
337* INITIALISATION OF MASSES
340* ----------------------------------------------------------------------
344 $ INUT, ! Input unit number (not used)
345 $ IOUT ! Ounput unit number
347 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
348 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
349 * ,AMK,AMKZ,AMKST,GAMKST
351 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
352 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
353 * ,AMK,AMKZ,AMKST,GAMKST
356 $ bxINIT ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)
'
359* IN-COMING / OUT-GOING FERMION MASSES
367* MASSES USED IN TAU DECAYS
381C IN-COMING / OUT-GOING FERMION MASSES
382!! AMNUTA = PKORB(1,2)
384!! AMNUMU = PKORB(1,6)
386C MASSES USED IN TAU DECAYS Cleo settings
391 AMA1 = 1.275 !! PKORB(1,10)
392 GAMA1 = 0.615 !! PKORB(2,10)
395!! AMKST = PKORB(1,13)
396!! GAMKST = PKORB(2,13)
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
','****
','***
'
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
414 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
415 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
416 * ,AMK,AMKZ,AMKST,GAMKST
422C XXXXA CORRESPOND TO S2 CHANNEL !
432.EQ.
ELSEIF(MNUM1) THEN
441.EQ.
ELSEIF(MNUM2) THEN
450.EQ.
ELSEIF(MNUM3) THEN
459.EQ.
ELSEIF(MNUM4) THEN
468.EQ.
ELSEIF(MNUM5) THEN
477.EQ.
ELSEIF(MNUM6) THEN
486.EQ.
ELSEIF(MNUM7) THEN
495.EQ.
ELSEIF(MNUM8) THEN
504.EQ.
ELSEIF(MNUM101) THEN
513.EQ.
ELSEIF(MNUM102) THEN
533.LE.
IF (RRPROB1) THEN
535.LE.
ELSEIF(RR(PROB1+PROB2)) THEN
550 PROB3=1.0-PROB1-PROB2
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
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
562.EQ.
ELSEIF (IDENT-1) THEN
564.EQ.
ELSEIF (IDENT 2) THEN
566.EQ.
ELSEIF (IDENT-2) THEN
568.EQ.
ELSEIF (IDENT 3) THEN
570.EQ.
ELSEIF (IDENT-3) THEN
572.EQ.
ELSEIF (IDENT 4) THEN
574.EQ.
ELSEIF (IDENT-4) THEN
576.EQ.
ELSEIF (IDENT 8) THEN
578.EQ.
ELSEIF (IDENT-8) THEN
580.EQ.
ELSEIF (IDENT 9) THEN
582.EQ.
ELSEIF (IDENT-9) THEN
585 PRINT *, 'stop in apkmas, wrong ident=
',IDENT
590 FUNCTION LUNPIK(ID,ISGN)
591 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
592 REAL*4 BRA1,BRK0,BRK0B,BRKS
595.EQ.
IF (IDENT 1) THEN
597.EQ.
ELSEIF (IDENT-1) THEN
599.EQ.
ELSEIF (IDENT 2) THEN
601.EQ.
ELSEIF (IDENT-2) THEN
603.EQ.
ELSEIF (IDENT 3) THEN
605.EQ.
ELSEIF (IDENT-3) THEN
607.EQ.
ELSEIF (IDENT 4) THEN
609* K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
611.GT.
IF (XIO(1)BRK0) THEN
616.EQ.
ELSEIF (IDENT-4) THEN
618* K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
620.GT.
IF (XIO(1)BRK0B) THEN
625.EQ.
ELSEIF (IDENT 8) THEN
627.EQ.
ELSEIF (IDENT-8) THEN
629.EQ.
ELSEIF (IDENT 9) THEN
631.EQ.
ELSEIF (IDENT-9) THEN
634 PRINT *, 'stop in ipkdef, wrong ident=
',IDENT
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
646 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
647 REAL*4 BRA1,BRK0,BRK0B,BRKS
648 COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
651C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
658C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)