C++ Interface to Tauola
tauola/demo-KK-face/Tauface.f
1 /* copyright(c) 1991-2021 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-)
87 C XK0 for tau decays.
88  xk0dec = xpar(ITAUXPAR+5) ! IR-cut for QED rad. in leptonic decays
89 C radiative correction switch in tau --> e (mu) decays !
90  itdkRC = xpar(ITAUXPAR+4) ! QED rad. in leptonic decays
91 C 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
94 C output file number for TAUOLA
95  IOUT = xpar(4)
96 C 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
149 CAM normalised to e nu nutau channel
150 CAM enu munu pinu rhonu A1nu Knu K*nu pi
151 CAM 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 *
164 C
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,
182 C 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
269 C 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
379 C
380 C
381 C IN-COMING / OUT-GOING FERMION MASSES
382 !! AMNUTA = PKORB(1,2)
383 !! AMNUE = PKORB(1,4)
384 !! AMNUMU = PKORB(1,6)
385 C
386 C 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)
397 C
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
413 C
414  REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
415  * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
416  * ,AMK,AMKZ,AMKST,GAMKST
417 C
418  AMROP=1.1
419  GAMROP=0.36
420  AMOM=.782
421  GAMOM=0.0084
422 C 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
532 C
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
549 C
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)
643 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
644 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
645 C 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
650 C ==================
651 C 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
657 C ====
658 C 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
664 C =====
665  END