tauola-BBB/tauface-KK-F/Tauface.F

00001 */////////////////////////////////////////////////////////////////////////////////////
00002 *//                                                                                 //
00003 *//  !!!!!!! WARNING!!!!!   This source is agressive !!!!                           //
00004 *//                                                                                 //
00005 *//  Due to short common block names it  owerwrites variables in other parts        //
00006 *//  of the code.                                                                   //
00007 *//                                                                                 //
00008 *//  One should add suffix c_Taul_ to names of all commons as soon as possible!!!!  //
00009 *//                                                                                 //
00010 */////////////////////////////////////////////////////////////////////////////////////
00011 
00012 */////////////////////////////////////////////////////////////////////////////////////
00013 *//                                                                                 //
00014 *//   Standard Tauola interface/initialization routines of functionality exactly    //
00015 *//   as in Tauola CPC  but input is partially from xpar(*) matrix                  //
00016 *//   ITAUXPAR is for indirect adressing                                            //
00017 *//                                                                                 //
00018 */////////////////////////////////////////////////////////////////////////////////////
00019 
00020 
00021       SUBROUTINE INIETC(ITAUXPAR,xpar)
00022       INCLUDE "BXformat.h"
00023       REAL*8 xpar(*)
00024       INTEGER   INUT,IOUT
00025       COMMON /INOUT/  
00026      $     INUT,         ! Input  unit  number (not used)
00027      $     IOUT          ! Ounput unit  number
00028       COMMON / IDFC  / IDFF
00029       COMMON / TAURAD / XK0DEC,ITDKRC
00030       DOUBLE PRECISION            XK0DEC
00031       COMMON / JAKI   /  JAK1,JAK2,JAKP,JAKM,KTOM
00032 * Note: I dont see KeyA1=2,3 realy implemented in the code SJ. ??????
00033       INTEGER  KeyA1
00034       COMMON /TESTA1/
00035      $     KeyA1           ! Special switch for tests of dGamma/dQ**2 in a1 decay
00036 * KeyA1=1 constant width of a1 and rho
00037 * KeyA1=2 free choice of rho propagator (defined in function FPIK)
00038 *         and free choice of a1 mass and width. function g(Q**2)
00039 *         (see formula 3.48 in Comp. Phys. Comm. 64 (1991) 275)
00040 *         hard coded both in Monte Carlo and in testing distribution.
00041 * KeyA1=3 function g(Q**2) hardcoded in the Monte Carlo
00042 *         (it is timy to calculate!), but appropriately adjusted in testing distribution.
00043       SAVE
00044        idff    = xpar(ITAUXPAR+3)        ! Lund identifier for first tau (15 for  tau-)
00045 C XK0 for tau decays.
00046        xk0dec  = xpar(ITAUXPAR+5)        ! IR-cut for QED rad. in leptonic decays
00047 C radiative correction switch in tau --> e (mu) decays !
00048        itdkRC  = xpar(ITAUXPAR+4)        ! QED rad. in leptonic decays
00049 C switches of tau+ tau- decay modes !!
00050        Jak1            = xpar(ITAUXPAR+1)   ! Decay Mask for first tau
00051        Jak2            = xpar(ITAUXPAR+2)   ! Decay Mask for second tau
00052 C output file number for TAUOLA
00053        IOUT    = xpar(4)
00054 C  KeyA1 is used for formfactors actually not in use
00055       KeyA1   = xpar(ITAUXPAR+6)        ! Type of a1 current
00056 
00057         WRITE(iout,bxope)
00058         WRITE(iout,bxtxt) ' Parameters passed from KK  to Tauola:   '
00059         WRITE(iout,bxl1i) Jak1,      'dec. type 1-st tau  ','Jak1  ','t01'
00060         WRITE(iout,bxl1i) Jak2,      'dec. type 2-nd tau  ','Jak2  ','t02'
00061         WRITE(iout,bxl1i) KeyA1,     'current type a1 dec.','KeyA1 ','t03'
00062         WRITE(iout,bxl1i) idff,      'PDG id 1-st tau     ','idff  ','t04'
00063         WRITE(iout,bxl1i) itdkRC,    'R.c. switch lept dec','itdkRC','t05'
00064         WRITE(iout,bxl1g) xk0dec,    'IR-cut for lept r.c.','xk0dec','t06'
00065         WRITE(iout,bxclo)
00066 
00067       end
00068 
00069       SUBROUTINE INITDK(ITAUXPAR,xpar)
00070 * ----------------------------------------------------------------------
00071 *     INITIALISATION OF TAU DECAY PARAMETERS  and routines
00072 *
00073 *     called by : KORALZ
00074 * ----------------------------------------------------------------------
00075       INCLUDE "BXformat.h"
00076       INTEGER   INUT,IOUT
00077       COMMON /INOUT/  
00078      $     INUT,         ! Input  unit  number (not used)
00079      $     IOUT          ! Ounput unit  number
00080       REAL*8 xpar(*)
00081 
00082       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00083       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00084       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00085      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00086      *                 ,AMK,AMKZ,AMKST,GAMKST
00087 *
00088       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00089      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00090      *                 ,AMK,AMKZ,AMKST,GAMKST
00091       COMMON / TAUBRA / GAMPRT(500),JLIST(500),NCHAN
00092       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00093       REAL*4            BRA1,BRK0,BRK0B,BRKS
00094 
00095       PARAMETER (NMODE=86,NM1=0,NM2=11,NM3=19,NM4=22,NM5=21,NM6=13)
00096       COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00097      &                ,NAMES
00098       CHARACTER NAMES(NMODE)*31
00099 
00100       CHARACTER OLDNAMES(7)*31
00101       CHARACTER*80 bxINIT
00102       PARAMETER (
00103      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00104      $ )
00105       REAL*4 PI,POL1(4)
00106 *
00107 *
00108 * LIST OF BRANCHING RATIOS
00109 CAM normalised to e nu nutau channel
00110 CAM                  enu   munu   pinu  rhonu   A1nu   Knu    K*nu   pi
00111 CAM   DATA JLIST  /    1,     2,     3,     4,     5,     6,     7,
00112 
00113 *AM   DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
00114 *AM
00115 *AM  multipion decays
00116 *
00117 *    conventions of particles names
00118 *                 K-,P-,K+,  K0,P-,KB,  K-,P0,K0
00119 *                  3, 1,-3  , 4, 1,-4  , 3, 2, 4  ,
00120 *                 P0,P0,K-,  K-,P-,P+,  P-,KB,P0
00121 *                  2, 2, 3  , 3, 1,-1  , 1,-4, 2  ,
00122 *                 ET,P-,P0   P-,P0,GM
00123 *                  9, 1, 2  , 1, 2, 8
00124 *
00125 
00126 C
00127       DIMENSION NOPIK(9,NMODE),NPIK(NMODE)
00128 *AM   outgoing multiplicity and flavors of multi-pion /multi-K modes    
00129       DATA   NPIK  /                4,                    4,    ! old 4scalar
00130      a                              4,                    4,    ! new (may 2004)
00131      b                              4,                    4,
00132      c                              4,                    4,
00133      d                              4,                    4,
00134      e                              4,                    4,    ! new (may 2004)
00135      e                              4,                    4,    ! new (sep 2004)
00136      e                              4,                    4,    
00137      e                              4,                    4,    
00138      e                              4,                    4,    
00139      e                              4,                    4,    ! new (sep 2004)
00140      1                              5,       
00141      a                              5,                    5,    ! new (may 2004)
00142      b                              5,                    5,
00143      c                              5,                    5,
00144      d                              5,                    5,
00145      e                              5,                    5,    ! new (may 2004)
00146      a                              5,                    5,    ! new (sep 2004)
00147      b                              5,                    5,
00148      c                              5,                    5,
00149      d                              5,                    5,
00150      e                              5,                    5,    ! new (sep 2004)
00151      x                                                    5,    ! old npi starts here
00152      2                              6,                    6,
00153      a                              6,                    6,    ! new (may 2004)
00154      b                              6,                    6,    ! new (may 2004)
00155      c                              6,                    6,    ! new (may 2004)
00156      d                              6,                    6,    ! new (may 2004)
00157      e                              6,                    6,    ! new (may 2004)
00158      3                              3,                    3,            
00159      4                              3,                    3,            
00160      5                              3,                    3,            
00161      6                              3,                    3,  
00162      7                              3,                          ! new (may 2004) and useful
00163      a                              3,                    3,    ! new (may 2004)
00164      a                              3,                    3,    ! new (may 2004)
00165      a                              3,                    3,    ! new (may 2004)
00166      a                              3,                    3,    ! new (may 2004)
00167      a                              3,                    3,    ! new (may 2004)
00168      8                                                    2, 
00169      9                              2,                    2,    ! new (may 2004)
00170      9                              2,                    2,    ! new (may 2004)
00171      9                              2,                    2,    ! new (may 2004)
00172      9                              2,                    2,    ! new (may 2004)
00173      9                              2,                    2/    ! new (may 2004)          
00174 
00175       DATA  NOPIK / -1,-1, 1, 2, 0, 0,3*0,     2, 2, 2,-1, 0, 0,3*0,  
00176      a               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00177      b               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00178      c               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00179      d               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00180      e               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00181      a               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00182      b               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00183      c               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00184      d               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00185      e               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00186      1              -1,-1, 1, 2, 2, 0,3*0,  
00187      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00188      a               1,-1,-1, 2, 2, 0,3*0,    -1, 2, 2, 2, 2, 0,3*0,     ! new (may 2004)
00189      a              -1, 1, 1,-1,-1, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00190      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00191      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00192      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00193      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00194      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00195      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00196      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00197      x                                        -1,-1,-1, 1, 1, 0,3*0,     ! old npi starts here
00198      2              -1,-1,-1, 1, 1, 2,3*0,    -1,-1, 1, 2, 2, 2,3*0, 
00199      a              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00200      b              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00201      c              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00202      d              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00203      e              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00204      3              -3,-1, 3, 0, 0, 0,3*0,    -4,-1, 4, 0, 0, 0,3*0,  
00205      4              -3, 2,-4, 0, 0, 0,3*0,     2, 2,-3, 0, 0, 0,3*0,  
00206      5              -3,-1, 1, 0, 0, 0,3*0,    -1, 4, 2, 0, 0, 0,3*0,  
00207      6               9,-1, 2, 0, 0, 0,3*0,    -1, 2, 8, 0, 0, 0,3*0,
00208 
00209 
00210 C AJWMOD fix sign bug, 2/22/99
00211      7               2, 2,-1, 0, 0, 0,3*0,                           ! new (may 2004) but useful
00212      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00213      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00214      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00215      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00216      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00217 
00218      8                                        -3,-4, 0, 0, 0, 0,3*0,
00219      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00220      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00221      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00222      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00223      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0 /! new (may 2004)
00224 
00225 
00226 * LIST OF BRANCHING RATIOS
00227       NCHAN = NMODE + 7
00228       DO 1 I = 1,500
00229       IF (I.LE.NCHAN) THEN
00230         JLIST(I) = I
00231 
00232         IF(I.EQ. 1) GAMPRT(I) = 1.0000
00233         IF(I.EQ. 2) GAMPRT(I) = 1.0000
00234         IF(I.EQ. 3) GAMPRT(I) = 1.0000
00235         IF(I.EQ. 4) GAMPRT(I) = 1.0000
00236         IF(I.EQ. 5) GAMPRT(I) = 1.0000
00237         IF(I.EQ. 6) GAMPRT(I) = 1.0000
00238         IF(I.EQ. 7) GAMPRT(I) = 1.0000
00239         IF(I.EQ. 8) GAMPRT(I) = 1.0000
00240         IF(I.EQ. 9) GAMPRT(I) = 1.0000
00241         IF(I.EQ.10) GAMPRT(I) = 1.0000
00242         IF(I.EQ.11) GAMPRT(I) = 1.0000
00243         IF(I.EQ.12) GAMPRT(I) = 1.0000
00244         IF(I.EQ.13) GAMPRT(I) = 1.0000
00245         IF(I.EQ.14) GAMPRT(I) = 1.0000
00246         IF(I.EQ.15) GAMPRT(I) = 1.0000
00247         IF(I.EQ.16) GAMPRT(I) = 1.0000
00248         IF(I.EQ.17) GAMPRT(I) = 1.0000
00249         IF(I.EQ.18) GAMPRT(I) = 1.0000
00250         IF(I.EQ.19) GAMPRT(I) = 1.0000
00251         IF(I.EQ.20) GAMPRT(I) = 1.0000
00252         IF(I.EQ.21) GAMPRT(I) = 1.0000
00253         IF(I.EQ.22) GAMPRT(I) = 1.0000
00254         IF(I.GT.22.AND.I.LE.93)  GAMPRT(I) = 1.0000
00255 C second default
00256         IF(I.GT.0.AND.I.LE.93)  GAMPRT(I) = 0.0000
00257         IF(I.EQ. 1) GAMPRT(I) =0.1800 
00258         IF(I.EQ. 2) GAMPRT(I) =0.1751 
00259         IF(I.EQ. 3) GAMPRT(I) =0.1110 
00260         IF(I.EQ. 4) GAMPRT(I) =0.2515 
00261         IF(I.EQ. 5) GAMPRT(I) =0.1790 /2
00262         IF(I.EQ. 6) GAMPRT(I) =0.0071 
00263         IF(I.EQ. 7) GAMPRT(I) =0.0134
00264         IF(I.EQ. 8) GAMPRT(I) =0.0450
00265         IF(I.EQ. 9) GAMPRT(I) =0.0100
00266 
00267         IF(I.EQ.30) GAMPRT(I) =0.0009
00268         IF(I.EQ.33) GAMPRT(I) =0.004
00269         IF(I.EQ.34) GAMPRT(I) =0.002
00270         IF(I.EQ.35) GAMPRT(I) =0.001
00271 
00272         IF(I.EQ.51) GAMPRT(I) =0.0004 
00273         IF(I.EQ.52) GAMPRT(I) =0.0003 
00274         IF(I.EQ.53) GAMPRT(I) =0.0005 
00275 
00276         IF(I.EQ.64) GAMPRT(I) =0.0015 
00277         IF(I.EQ.65) GAMPRT(I) =0.0015 
00278         IF(I.EQ.66) GAMPRT(I) =0.0015 
00279         IF(I.EQ.67) GAMPRT(I) =0.0005
00280         IF(I.EQ.68) GAMPRT(I) =0.0050
00281         IF(I.EQ.69) GAMPRT(I) =0.0055
00282         IF(I.EQ.70) GAMPRT(I) =0.0017 
00283         IF(I.EQ.71) GAMPRT(I) =0.0013
00284         IF(I.EQ.72) GAMPRT(I) =0.1790 /2  
00285 
00286         IF(I.EQ.83) GAMPRT(I) =0.0010 
00287 
00288         IF(I.EQ. 1) OLDNAMES(I)='  TAU-  -->   E-               '
00289         IF(I.EQ. 2) OLDNAMES(I)='  TAU-  -->  MU-               '
00290         IF(I.EQ. 3) OLDNAMES(I)='  TAU-  -->  PI-               '
00291         IF(I.EQ. 4) OLDNAMES(I)='  TAU-  -->  PI-, PI0          '
00292         IF(I.EQ. 5) OLDNAMES(I)='  TAU-  -->  PI-, PI-,  PI+    '
00293         IF(I.EQ. 6) OLDNAMES(I)='  TAU-  -->   K-               '
00294         IF(I.EQ. 7) OLDNAMES(I)='  TAU-  -->  K*- (two subch)   '
00295         IF(I.EQ. 8) NAMES(I-7)='  TAU-  --> 2PI-,  PI0,  PI+   '
00296         IF(I.EQ. 9) NAMES(I-7)='  TAU-  --> 3PI0,        PI-   '
00297 
00298         IF(I.EQ.10) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00299         IF(I.EQ.11) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00300         IF(I.EQ.12) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00301         IF(I.EQ.13) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00302         IF(I.EQ.14) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00303         IF(I.EQ.15) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00304         IF(I.EQ.16) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00305         IF(I.EQ.17) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00306         IF(I.EQ.18) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)  
00307         IF(I.EQ.19) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00308         IF(I.EQ.20) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00309         IF(I.EQ.21) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00310         IF(I.EQ.22) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00311         IF(I.EQ.23) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00312         IF(I.EQ.24) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00313         IF(I.EQ.25) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00314         IF(I.EQ.26) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00315         IF(I.EQ.27) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00316         IF(I.EQ.28) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)  
00317         IF(I.EQ.29) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00318 
00319 
00320         IF(I.EQ.30) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 2PI0   '
00321 
00322         IF(I.EQ.31) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00323         IF(I.EQ.32) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00324         IF(I.EQ.33) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00325         IF(I.EQ.34) NAMES(I-7)='  TAU-  --> PI- 4PI0           '  !  (may 2004)
00326         IF(I.EQ.35) NAMES(I-7)='  TAU-  --> 3PI- 2PI+          '  !  (may 2004)
00327         IF(I.EQ.36) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00328         IF(I.EQ.37) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00329         IF(I.EQ.38) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00330         IF(I.EQ.39) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00331         IF(I.EQ.40) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00332 
00333         IF(I.EQ.41) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00334         IF(I.EQ.42) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00335         IF(I.EQ.43) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00336         IF(I.EQ.44) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00337         IF(I.EQ.45) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00338         IF(I.EQ.46) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00339         IF(I.EQ.47) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00340         IF(I.EQ.48) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00341         IF(I.EQ.49) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00342         IF(I.EQ.50) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00343 
00344         IF(I.EQ.51) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,        '
00345         IF(I.EQ.52) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,  PI0   '
00346         IF(I.EQ.53) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 3PI0   '
00347         IF(I.EQ.54) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00348         IF(I.EQ.55) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00349         IF(I.EQ.56) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00350         IF(I.EQ.57) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00351         IF(I.EQ.58) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00352         IF(I.EQ.59) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00353         IF(I.EQ.60) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00354         IF(I.EQ.61) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00355         IF(I.EQ.62) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00356         IF(I.EQ.63) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00357 
00358         IF(I.EQ.64) NAMES(I-7)='  TAU-  -->  K-, PI-,  K+      '
00359         IF(I.EQ.65) NAMES(I-7)='  TAU-  -->  K0, PI-, K0B      '
00360 
00361         IF(I.EQ.66) NAMES(I-7)='  TAU-  -->  K-,  K0, PI0      '
00362 
00363         IF(I.EQ.67) NAMES(I-7)='  TAU-  --> PI0  PI0   K-      '
00364         IF(I.EQ.68) NAMES(I-7)='  TAU-  -->  K-  PI-  PI+      '
00365         IF(I.EQ.69) NAMES(I-7)='  TAU-  --> PI-  K0B  PI0      '
00366         IF(I.EQ.70) NAMES(I-7)='  TAU-  --> ETA  PI-  PI0      '
00367         IF(I.EQ.71) NAMES(I-7)='  TAU-  --> PI-  PI0  GAM      '
00368         IF(I.EQ.72) NAMES(I-7)='  TAU-  --> PI-  PI0  PI0      '
00369         IF(I.EQ.73) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00370         IF(I.EQ.74) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00371         IF(I.EQ.75) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00372         IF(I.EQ.76) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00373         IF(I.EQ.77) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00374         IF(I.EQ.78) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00375         IF(I.EQ.79) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00376         IF(I.EQ.80) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00377         IF(I.EQ.81) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00378         IF(I.EQ.82) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00379  
00380 
00381         IF(I.EQ.83) NAMES(I-7)='  TAU-  -->  K-  K0            '
00382         IF(I.EQ.84) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00383         IF(I.EQ.85) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00384         IF(I.EQ.86) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00385         IF(I.EQ.87) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00386         IF(I.EQ.88) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00387         IF(I.EQ.89) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00388         IF(I.EQ.90) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00389         IF(I.EQ.91) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00390         IF(I.EQ.92) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00391         IF(I.EQ.93) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00392  
00393       ELSE
00394         JLIST(I) = 0
00395         GAMPRT(I) = 0.
00396       ENDIF
00397    1  CONTINUE
00398       DO I=1,NMODE
00399         MULPIK(I)=NPIK(I)
00400         DO J=1,MULPIK(I)
00401          IDFFIN(J,I)=NOPIK(J,I)
00402         ENDDO
00403       ENDDO
00404 *
00405 *
00406 * --- COEFFICIENTS TO FIX RATIO OF:
00407 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00408 * --- PROBABILITY OF K0 TO BE KS
00409 * --- PROBABILITY OF K0B TO BE KS
00410 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00411 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00412 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00413 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00414       BRA1=1d0   ! 0.5
00415       BRK0=0.5
00416       BRK0B=0.5
00417       BRKS=0.6667
00418 *
00419 
00420       GFERMI = 1.16637E-5
00421       CCABIB = 0.975
00422       GV     = 1.0
00423       GA     =-1.0
00424 
00425 
00426 
00427       GFERMI = xpar(32)
00428       IF (XPAR(ITAUXPAR+100+1).GT.-1D0) THEN
00429 C initialization form KK
00430         CCABIB = XPAR(ITAUXPAR+7)
00431         GV     = XPAR(ITAUXPAR+8)
00432         GA     = XPAR(ITAUXPAR+9)
00433 
00434         BRA1   = 1D0 ! XPAR(ITAUXPAR+10)   ! input is overruled; must be 1d0 now
00435         BRKS   = XPAR(ITAUXPAR+11)
00436         BRK0   = XPAR(ITAUXPAR+12)
00437         BRK0B  = XPAR(ITAUXPAR+13)
00438         DO K=1,NCHAN
00439 C         GAMPRT(K)=XPAR(ITAUXPAR+100+K)
00440 
00441         IF(K.EQ. 1) GAMPRT(K) =XPAR(ITAUXPAR+100+K)
00442         IF(K.EQ. 2) GAMPRT(K) =XPAR(ITAUXPAR+100+K)
00443         IF(K.EQ. 3) GAMPRT(K) =XPAR(ITAUXPAR+100+K)
00444         IF(K.EQ. 4) GAMPRT(K) =XPAR(ITAUXPAR+100+K)
00445         IF(K.EQ. 5) GAMPRT(K) =XPAR(ITAUXPAR+100+K) /2
00446         IF(K.EQ. 6) GAMPRT(K) =XPAR(ITAUXPAR+100+K)
00447         IF(K.EQ. 7) GAMPRT(K) =XPAR(ITAUXPAR+100+K)
00448         IF(K.EQ. 8) GAMPRT(K) =XPAR(ITAUXPAR+100+K)
00449         IF(K.EQ. 9) GAMPRT(K) =XPAR(ITAUXPAR+100+K)
00450 
00451         IF(K.EQ.30) GAMPRT(K) =XPAR(ITAUXPAR+100+10)
00452 
00453         IF(K.EQ.51) GAMPRT(K) =XPAR(ITAUXPAR+100+11)
00454         IF(K.EQ.52) GAMPRT(K) =XPAR(ITAUXPAR+100+12)
00455         IF(K.EQ.53) GAMPRT(K) =XPAR(ITAUXPAR+100+13)
00456 
00457         IF(K.EQ.64) GAMPRT(K) =XPAR(ITAUXPAR+100+14)
00458         IF(K.EQ.65) GAMPRT(K) =XPAR(ITAUXPAR+100+15)
00459         IF(K.EQ.66) GAMPRT(K) =XPAR(ITAUXPAR+100+16)
00460         IF(K.EQ.67) GAMPRT(K) =XPAR(ITAUXPAR+100+17)
00461         IF(K.EQ.68) GAMPRT(K) =XPAR(ITAUXPAR+100+18)
00462         IF(K.EQ.69) GAMPRT(K) =XPAR(ITAUXPAR+100+19)
00463         IF(K.EQ.70) GAMPRT(K) =XPAR(ITAUXPAR+100+20)
00464         IF(K.EQ.71) GAMPRT(K) =XPAR(ITAUXPAR+100+21)
00465         IF(K.EQ.72) GAMPRT(K) =XPAR(ITAUXPAR+100+5) /2  
00466 
00467         IF(K.EQ.83) GAMPRT(K) =XPAR(ITAUXPAR+100+22)
00468 
00469         IF(K.EQ.33) GAMPRT(I) =XPAR(ITAUXPAR+100+23)
00470         IF(K.EQ.34) GAMPRT(I) =XPAR(ITAUXPAR+100+24)
00471         IF(K.EQ.35) GAMPRT(I) =XPAR(ITAUXPAR+100+25)
00472 
00473         ENDDO
00474       ENDIF
00475 * ZW 13.04.89 HERE WAS AN ERROR
00476       SCABIB = SQRT(1.-CCABIB**2)
00477       PI =4.*ATAN(1.)
00478       GAMEL  = GFERMI**2*AMTAU**5/(192*PI**3)
00479 *
00480 *      CALL DEXAY(-1,pol1)
00481 *
00482 * PRINTOUTS FOR KK version
00483 
00484       SUM=0
00485       DO K=1,NCHAN
00486        SUM=SUM+GAMPRT(K)
00487       ENDDO
00488 
00489       
00490       WRITE(iout,bxope)
00491       WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INITDK:    '
00492       WRITE(iout,bxtxt) ' Adopted to read from KK                     '
00493       WRITE(iout,bxtxt) '                      '
00494       WRITE(iout,bxtxt) ' Choice Probability      --     Decay Channel'
00495       DO K=1,7      
00496       WRITE(iout,bxINIT) GAMPRT(K)/SUM,    OLDNAMES(K),'****','***'
00497       ENDDO
00498       DO K=8,7+NMODE      
00499       WRITE(iout,bxINIT) GAMPRT(K)/SUM,     NAMES(K-7),'****','***'
00500       ENDDO
00501       WRITE(iout,bxtxt) ' In addition:'
00502       WRITE(iout,bxINIT) GV,    'Vector W-tau-nu coupl.     ','****','***'
00503       WRITE(iout,bxINIT) GA,    'Axial  W-tau-nu coupl.     ','****','***'
00504       WRITE(iout,bxINIT) GFERMI,'Fermi Coupling             ','****','***'
00505       WRITE(iout,bxINIT) CCABIB,'cabibo angle               ','****','***'
00506       WRITE(iout,bxINIT) BRA1,  'a1 br ratio (massless)     ','****','***'
00507       WRITE(iout,bxINIT) BRKS,  'K* br ratio (massless)     ','****','***'
00508       WRITE(iout,bxclo)
00509             
00510       RETURN
00511       END
00512 
00513       SUBROUTINE INIPHY(XK00)
00514 * ----------------------------------------------------------------------
00515 *     INITIALISATION OF PARAMETERS
00516 *     USED IN QED and/or GSW ROUTINES
00517 * ----------------------------------------------------------------------
00518       COMMON / QEDPRM /ALFINV,ALFPI,XK0
00519       REAL*8           ALFINV,ALFPI,XK0
00520       REAL*8 PI8,XK00
00521 *
00522       PI8    = 4.D0*DATAN(1.D0)
00523       ALFINV = 137.03604D0
00524       ALFPI  = 1D0/(ALFINV*PI8)
00525       XK0=XK00
00526       END
00527 
00528       SUBROUTINE INIMAS(ITAUXPAR,xpar)
00529 * ----------------------------------------------------------------------
00530 *     INITIALISATION OF MASSES
00531 *
00532 *     called by : KORALZ
00533 * ----------------------------------------------------------------------
00534       INCLUDE "BXformat.h"
00535       INTEGER   INUT,IOUT
00536       COMMON /INOUT/  
00537      $     INUT,         ! Input  unit  number (not used)
00538      $     IOUT          ! Ounput unit  number
00539       REAL*8 xpar(*)
00540       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00541      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00542      *                 ,AMK,AMKZ,AMKST,GAMKST
00543 *
00544       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00545      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00546      *                 ,AMK,AMKZ,AMKST,GAMKST
00547       CHARACTER*80 bxINIT
00548       PARAMETER (
00549      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00550      $ )
00551 *
00552 * IN-COMING / OUT-GOING  FERMION MASSES
00553       AMTAU  = xpar(656)
00554       AMNUTA = 0.010
00555       AMEL   = xpar(616)
00556       AMNUE  = 0.0
00557       AMMU   = xpar(636)
00558       AMNUMU = 0.0
00559 *
00560 * MASSES USED IN TAU DECAYS
00561 
00562       AMPIZ  = 0.134964
00563       AMPI   = 0.139568
00564       AMRO   = 0.773
00565       GAMRO  = 0.145
00566 *C    GAMRO  = 0.666
00567       AMA1   = 1.251
00568       GAMA1  = 0.599
00569       AMK    = 0.493667
00570       AMKZ   = 0.49772
00571       AMKST  = 0.8921
00572       GAMKST = 0.0513
00573 
00574 
00575       WRITE(iout,bxope)
00576       WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INIMAS:    '
00577       WRITE(iout,bxtxt) ' Adopted to read from KK                     '
00578       WRITE(iout,bxINIT) amtau, 'AMTAU tau-mass             ','****','***'
00579       WRITE(iout,bxINIT) amel , 'AMEL  electron-mass        ','****','***'
00580       WRITE(iout,bxINIT) ammu , 'AMMU  muon-mass            ','****','***'
00581       WRITE(iout,bxclo)
00582 
00583       END
00584       SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
00585      $            AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
00586       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00587      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00588      *                 ,AMK,AMKZ,AMKST,GAMKST
00589 C
00590       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00591      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00592      *                 ,AMK,AMKZ,AMKST,GAMKST
00593 C
00594       AMROP=1.1
00595       GAMROP=0.36
00596       AMOM=.782
00597       GAMOM=0.0084
00598 C     XXXXA CORRESPOND TO S2 CHANNEL !
00599       IF(MNUM.EQ.0) THEN
00600        PROB1=0.5
00601        PROB2=0.5
00602        AMRX =AMA1
00603        GAMRX=GAMA1
00604        AMRA =AMRO
00605        GAMRA=GAMRO
00606        AMRB =AMRO
00607        GAMRB=GAMRO
00608       ELSEIF(MNUM.EQ.1) THEN
00609        PROB1=0.5
00610        PROB2=0.5
00611        AMRX =1.57
00612        GAMRX=0.9
00613        AMRB =AMKST
00614        GAMRB=GAMKST
00615        AMRA =AMRO
00616        GAMRA=GAMRO
00617       ELSEIF(MNUM.EQ.2) THEN
00618        PROB1=0.5
00619        PROB2=0.5
00620        AMRX =1.57
00621        GAMRX=0.9
00622        AMRB =AMKST
00623        GAMRB=GAMKST
00624        AMRA =AMRO
00625        GAMRA=GAMRO
00626       ELSEIF(MNUM.EQ.3) THEN
00627        PROB1=0.5
00628        PROB2=0.5
00629        AMRX =1.27
00630        GAMRX=0.3
00631        AMRA =AMKST
00632        GAMRA=GAMKST
00633        AMRB =AMKST
00634        GAMRB=GAMKST
00635       ELSEIF(MNUM.EQ.4) THEN
00636        PROB1=0.5
00637        PROB2=0.5
00638        AMRX =1.27
00639        GAMRX=0.3
00640        AMRA =AMKST
00641        GAMRA=GAMKST
00642        AMRB =AMKST
00643        GAMRB=GAMKST
00644       ELSEIF(MNUM.EQ.5) THEN
00645        PROB1=0.5
00646        PROB2=0.5
00647        AMRX =1.27
00648        GAMRX=0.3
00649        AMRA =AMKST
00650        GAMRA=GAMKST
00651        AMRB =AMRO
00652        GAMRB=GAMRO
00653       ELSEIF(MNUM.EQ.6) THEN
00654        PROB1=0.4
00655        PROB2=0.4
00656        AMRX =1.27
00657        GAMRX=0.3
00658        AMRA =AMRO
00659        GAMRA=GAMRO
00660        AMRB =AMKST
00661        GAMRB=GAMKST
00662       ELSEIF(MNUM.EQ.7) THEN
00663        PROB1=0.0
00664        PROB2=1.0
00665        AMRX =1.27
00666        GAMRX=0.9
00667        AMRA =AMRO
00668        GAMRA=GAMRO
00669        AMRB =AMRO
00670        GAMRB=GAMRO
00671       ELSEIF(MNUM.EQ.8) THEN
00672        PROB1=0.0
00673        PROB2=1.0
00674        AMRX =AMROP
00675        GAMRX=GAMROP
00676        AMRB =AMOM
00677        GAMRB=GAMOM
00678        AMRA =AMRO
00679        GAMRA=GAMRO
00680       ELSEIF(MNUM.EQ.9) THEN
00681        PROB1=0.5
00682        PROB2=0.5
00683        AMRX =AMA1
00684        GAMRX=GAMA1
00685        AMRA =AMRO
00686        GAMRA=GAMRO
00687        AMRB =AMRO
00688        GAMRB=GAMRO
00689       ELSEIF(MNUM.EQ.101) THEN
00690        PROB1=.35
00691        PROB2=.35
00692        AMRX =1.2
00693        GAMRX=.46
00694        AMRB =AMOM
00695        GAMRB=GAMOM
00696        AMRA =AMOM
00697        GAMRA=GAMOM
00698       ELSEIF(MNUM.EQ.102) THEN
00699        PROB1=0.0
00700        PROB2=0.0
00701        AMRX =1.4
00702        GAMRX=.6
00703        AMRB =AMOM
00704        GAMRB=GAMOM
00705        AMRA =AMOM
00706        GAMRA=GAMOM
00707       ELSEIF(MNUM.GE.103.AND.MNUM.LE.112) THEN
00708        PROB1=0.0
00709        PROB2=0.0
00710        AMRX =1.4
00711        GAMRX=.6
00712        AMRB =AMOM
00713        GAMRB=GAMOM
00714        AMRA =AMOM
00715        GAMRA=GAMOM
00716 
00717 
00718       ELSE
00719        PROB1=0.0
00720        PROB2=0.0
00721        AMRX =AMA1
00722        GAMRX=GAMA1
00723        AMRA =AMRO
00724        GAMRA=GAMRO
00725        AMRB =AMRO
00726        GAMRB=GAMRO
00727       ENDIF
00728 C
00729       IF    (RR.LE.PROB1) THEN
00730        ICHAN=1
00731       ELSEIF(RR.LE.(PROB1+PROB2)) THEN
00732        ICHAN=2
00733         AX   =AMRA
00734         GX   =GAMRA
00735         AMRA =AMRB
00736         GAMRA=GAMRB
00737         AMRB =AX
00738         GAMRB=GX
00739         PX   =PROB1
00740         PROB1=PROB2
00741         PROB2=PX
00742       ELSE
00743        ICHAN=3
00744       ENDIF
00745 C
00746       PROB3=1.0-PROB1-PROB2
00747       END
00748       FUNCTION DCDMAS(IDENT)
00749       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00750      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00751      *                 ,AMK,AMKZ,AMKST,GAMKST
00752 *
00753       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00754      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00755      *                 ,AMK,AMKZ,AMKST,GAMKST
00756       IF      (IDENT.EQ. 1) THEN
00757         APKMAS=AMPI
00758       ELSEIF  (IDENT.EQ.-1) THEN
00759         APKMAS=AMPI
00760       ELSEIF  (IDENT.EQ. 2) THEN
00761         APKMAS=AMPIZ
00762       ELSEIF  (IDENT.EQ.-2) THEN
00763         APKMAS=AMPIZ
00764       ELSEIF  (IDENT.EQ. 3) THEN
00765         APKMAS=AMK
00766       ELSEIF  (IDENT.EQ.-3) THEN
00767         APKMAS=AMK
00768       ELSEIF  (IDENT.EQ. 4) THEN
00769         APKMAS=AMKZ
00770       ELSEIF  (IDENT.EQ.-4) THEN
00771         APKMAS=AMKZ
00772       ELSEIF  (IDENT.EQ. 8) THEN
00773         APKMAS=0.0001
00774       ELSEIF  (IDENT.EQ.-8) THEN
00775         APKMAS=0.0001
00776       ELSEIF  (IDENT.EQ. 9) THEN
00777         APKMAS=0.5488
00778       ELSEIF  (IDENT.EQ.-9) THEN
00779         APKMAS=0.5488
00780       ELSE
00781         PRINT *, 'STOP IN APKMAS, WRONG IDENT=',IDENT
00782         STOP
00783       ENDIF
00784       DCDMAS=APKMAS
00785       END
00786       FUNCTION LUNPIK(ID,ISGN)
00787       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00788       REAL*4            BRA1,BRK0,BRK0B,BRKS
00789       REAL*4 XIO(1)
00790       IDENT=ID*ISGN
00791 
00792       IF      (IDENT.EQ. 1) THEN
00793         IPKDEF=-211
00794       ELSEIF  (IDENT.EQ.-1) THEN
00795         IPKDEF= 211
00796       ELSEIF  (IDENT.EQ. 2) THEN
00797         IPKDEF=111
00798       ELSEIF  (IDENT.EQ.-2) THEN
00799         IPKDEF=111
00800       ELSEIF  (IDENT.EQ. 3) THEN
00801         IPKDEF=-321
00802       ELSEIF  (IDENT.EQ.-3) THEN
00803         IPKDEF= 321
00804 
00805       ELSEIF  (IDENT.EQ. 4) THEN
00806 *
00807 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00808         CALL RANMAR(XIO,1)
00809         IF (XIO(1).GT.BRK0) THEN
00810           IPKDEF= 130
00811         ELSE
00812           IPKDEF= 310
00813         ENDIF
00814       ELSEIF  (IDENT.EQ.-4) THEN
00815 *
00816 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00817         CALL RANMAR(XIO,1)
00818         IF (XIO(1).GT.BRK0B) THEN
00819           IPKDEF= 130
00820         ELSE
00821           IPKDEF= 310
00822         ENDIF
00823       ELSEIF  (IDENT.EQ. 8) THEN
00824         IPKDEF= 22
00825       ELSEIF  (IDENT.EQ.-8) THEN
00826         IPKDEF= 22
00827       ELSEIF  (IDENT.EQ. 9) THEN
00828         IPKDEF= 221
00829       ELSEIF  (IDENT.EQ.-9) THEN
00830         IPKDEF= 221
00831       ELSE
00832         PRINT *, 'STOP IN IPKDEF, WRONG IDENT=',IDENT
00833         STOP
00834       ENDIF
00835       LUNPIK=IPKDEF
00836       END
00837 
00838 
00839 
00840 
00841       SUBROUTINE TAURDF(KTO)
00842 * THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
00843 * IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
00844 * CONTENTS
00845       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00846       REAL*4            BRA1,BRK0,BRK0B,BRKS
00847       COMMON / TAUBRA / GAMPRT(500),JLIST(500),NCHAN
00848       RETURN  ! this routine is called somewhere and is now deactivated, one has to fill it in properly  for  use.
00849       IF (KTO.EQ.1) THEN
00850 *     ==================
00851 * LIST OF BRANCHING RATIOS
00852       NCHAN = 19
00853       DO 1 I = 1,500
00854       IF (I.LE.NCHAN) THEN
00855         JLIST(I) = I
00856         IF(I.EQ. 1) GAMPRT(I) = .0000
00857         IF(I.EQ. 2) GAMPRT(I) = .0000
00858         IF(I.EQ. 3) GAMPRT(I) = .0000
00859         IF(I.EQ. 4) GAMPRT(I) = .0000
00860         IF(I.EQ. 5) GAMPRT(I) = .0000
00861         IF(I.EQ. 6) GAMPRT(I) = .0000
00862         IF(I.EQ. 7) GAMPRT(I) = .0000
00863         IF(I.EQ. 8) GAMPRT(I) = 1.0000
00864         IF(I.EQ. 9) GAMPRT(I) = 1.0000
00865         IF(I.EQ.10) GAMPRT(I) = 1.0000
00866         IF(I.EQ.11) GAMPRT(I) = 1.0000
00867         IF(I.EQ.12) GAMPRT(I) = 1.0000
00868         IF(I.EQ.13) GAMPRT(I) = 1.0000
00869         IF(I.EQ.14) GAMPRT(I) = 1.0000
00870         IF(I.EQ.15) GAMPRT(I) = 1.0000
00871         IF(I.EQ.16) GAMPRT(I) = 1.0000
00872         IF(I.EQ.17) GAMPRT(I) = 1.0000
00873         IF(I.EQ.18) GAMPRT(I) = 1.0000
00874         IF(I.EQ.19) GAMPRT(I) = 1.0000
00875       ELSE
00876         JLIST(I) = 0
00877         GAMPRT(I) = 0.
00878       ENDIF
00879    1  CONTINUE
00880 * --- COEFFICIENTS TO FIX RATIO OF:
00881 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00882 * --- PROBABILITY OF K0 TO BE KS
00883 * --- PROBABILITY OF K0B TO BE KS
00884 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00885 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00886 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00887 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00888       BRA1=0.5
00889       BRK0=0.5
00890       BRK0B=0.5
00891       BRKS=0.6667
00892       ELSE
00893 *     ====
00894 * LIST OF BRANCHING RATIOS
00895       NCHAN = 19
00896       DO 2 I = 1,500
00897       IF (I.LE.NCHAN) THEN
00898         JLIST(I) = I
00899         IF(I.EQ. 1) GAMPRT(I) = .0000
00900         IF(I.EQ. 2) GAMPRT(I) = .0000
00901         IF(I.EQ. 3) GAMPRT(I) = .0000
00902         IF(I.EQ. 4) GAMPRT(I) = .0000
00903         IF(I.EQ. 5) GAMPRT(I) = .0000
00904         IF(I.EQ. 6) GAMPRT(I) = .0000
00905         IF(I.EQ. 7) GAMPRT(I) = .0000
00906         IF(I.EQ. 8) GAMPRT(I) = 1.0000
00907         IF(I.EQ. 9) GAMPRT(I) = 1.0000
00908         IF(I.EQ.10) GAMPRT(I) = 1.0000
00909         IF(I.EQ.11) GAMPRT(I) = 1.0000
00910         IF(I.EQ.12) GAMPRT(I) = 1.0000
00911         IF(I.EQ.13) GAMPRT(I) = 1.0000
00912         IF(I.EQ.14) GAMPRT(I) = 1.0000
00913         IF(I.EQ.15) GAMPRT(I) = 1.0000
00914         IF(I.EQ.16) GAMPRT(I) = 1.0000
00915         IF(I.EQ.17) GAMPRT(I) = 1.0000
00916         IF(I.EQ.18) GAMPRT(I) = 1.0000
00917         IF(I.EQ.19) GAMPRT(I) = 1.0000
00918       ELSE
00919         JLIST(I) = 0
00920         GAMPRT(I) = 0.
00921       ENDIF
00922    2  CONTINUE
00923 * --- COEFFICIENTS TO FIX RATIO OF:
00924 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00925 * --- PROBABILITY OF K0 TO BE KS
00926 * --- PROBABILITY OF K0B TO BE KS
00927 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00928 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00929 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00930 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00931       BRA1=0.5
00932       BRK0=0.5
00933       BRK0B=0.5
00934       BRKS=0.6667
00935       ENDIF
00936 *     =====
00937       END
00938