demo-factory/prod/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(30),JLIST(30),NCHAN
00092       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00093       REAL*4            BRA1,BRK0,BRK0B,BRKS
00094 #if defined (ALEPH)
00095       PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
00096       COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00097      &                ,NAMES
00098       CHARACTER NAMES(NMODE)*31
00099 #else
00100       PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
00101       COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00102      &                ,NAMES
00103       CHARACTER NAMES(NMODE)*31
00104 #endif
00105       CHARACTER OLDNAMES(7)*31
00106       CHARACTER*80 bxINIT
00107       PARAMETER (
00108      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00109      $ )
00110       REAL*4 PI,POL1(4)
00111 *
00112 *
00113 * LIST OF BRANCHING RATIOS
00114 CAM normalised to e nu nutau channel
00115 CAM                  enu   munu   pinu  rhonu   A1nu   Knu    K*nu   pi
00116 CAM   DATA JLIST  /    1,     2,     3,     4,     5,     6,     7,
00117 #if defined (ALEPH)
00118 CAM               /0.1779,0.1731,0.1106,0.2530,0.1811,0.0072,0.0139
00119 CAM   DATA GAMPRT / 1.000,0.9732,0.6217,1.4221,1.0180,0.0405,0.0781
00120 CAM   DATA GAMPRT /1.000,0.9676,0.6154,1.3503,1.0225,0.0368,O.O758
00121 CAM
00122 C
00123 C    conventions of particles names
00124 c
00125 cam  mode (JAK)                     8                     9
00126 CAM  channel          pi- pi- pi0 pi+              3pi0 pi-
00127 cam  particle code  -1,-1, 2, 1, 0, 0,     2, 2, 2,-1, 0, 0,
00128 CAM  BR relative to electron    .2414,                .0601,
00129 c
00130 *                                  10                    11
00131 *    1                     3pi+- 2pi0                 5pi+-
00132 *    1              -1,-1, 1, 2, 2, 0,    -1,-1,-1, 1, 1, 0,
00133 *    1                          .0281,                .0045,
00134 
00135 *                                  12                    13
00136 *    2                      5pi+- pi0            3pi+- 3pi0
00137 *    2              -1,-1,-1, 1, 1, 2,    -1,-1, 1, 2, 2, 2,
00138 *    2                          .0010,                .0062,
00139 
00140 *                                  14                    15
00141 *    3                      K- pi- K+             K0 pi- KB
00142 *    3              -3,-1, 3, 0, 0, 0,     4,-1,-4, 0, 0, 0,
00143 *    3                          .0096,                .0169,
00144 
00145 *                                  16                    17
00146 *    4                      K- pi0 K0               2pi0 K-
00147 *    4              -3, 2, 4, 0, 0, 0,     2, 2,-3, 0, 0, 0,
00148 *    4                          .0056,                .0045,
00149 
00150 *                                  18                    19
00151 *    5                     K- pi- pi+            pi- KB pi0
00152 *    5              -3,-1, 1, 0, 0, 0,    -1,-4, 2, 0, 0, 0,
00153 *    5                          .0219,                .0180,
00154 
00155 *                                  20                    21
00156 *    6                    eta pi- pi0         pi- pi0 gamma
00157 *    6               9,-1, 2, 0, 0, 0,    -1, 2, 8, 0, 0, 0,
00158 *    6                          .0096,                .0088,
00159 
00160 *                                  22   /
00161 *    7                          K- K0   /
00162 *    7                          -3, 4   /
00163 *    7                          .0146   /
00164 #else
00165 *AM   DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
00166 *AM
00167 *AM  multipion decays
00168 *
00169 *    conventions of particles names
00170 *                 K-,P-,K+,  K0,P-,KB,  K-,P0,K0
00171 *                  3, 1,-3  , 4, 1,-4  , 3, 2, 4  ,
00172 *                 P0,P0,K-,  K-,P-,P+,  P-,KB,P0
00173 *                  2, 2, 3  , 3, 1,-1  , 1,-4, 2  ,
00174 *                 ET,P-,P0   P-,P0,GM
00175 *                  9, 1, 2  , 1, 2, 8
00176 *
00177 #endif
00178 C
00179       DIMENSION NOPIK(6,NMODE),NPIK(NMODE)
00180 *AM   outgoing multiplicity and flavors of multi-pion /multi-K modes    
00181       DATA   NPIK  /                4,                    4,  
00182      1                              5,                    5,
00183      2                              6,                    6,
00184      3                              3,                    3,            
00185      4                              3,                    3,            
00186      5                              3,                    3,            
00187      6                              3,                    3,  
00188      7                              2                         /         
00189 #if defined (ALEPH)
00190       DATA  NOPIK / -1,-1, 2, 1, 0, 0,     2, 2, 2,-1, 0, 0,
00191      1              -1,-1, 1, 2, 2, 0,    -1,-1,-1, 1, 1, 0,
00192      2              -1,-1,-1, 1, 1, 2,    -1,-1, 1, 2, 2, 2,
00193      3              -3,-1, 3, 0, 0, 0,     4,-1,-4, 0, 0, 0,
00194      4              -3, 2, 4, 0, 0, 0,     2, 2,-3, 0, 0, 0,
00195      5              -3,-1, 1, 0, 0, 0,    -1,-4, 2, 0, 0, 0,
00196      6               9,-1, 2, 0, 0, 0,    -1, 2, 8, 0, 0, 0,
00197 #else
00198       DATA  NOPIK / -1,-1, 1, 2, 0, 0,     2, 2, 2,-1, 0, 0,  
00199      1              -1,-1, 1, 2, 2, 0,    -1,-1,-1, 1, 1, 0,  
00200      2              -1,-1,-1, 1, 1, 2,    -1,-1, 1, 2, 2, 2, 
00201      3              -3,-1, 3, 0, 0, 0,    -4,-1, 4, 0, 0, 0,  
00202      4              -3, 2,-4, 0, 0, 0,     2, 2,-3, 0, 0, 0,  
00203      5              -3,-1, 1, 0, 0, 0,    -1, 4, 2, 0, 0, 0,  
00204      6               9,-1, 2, 0, 0, 0,    -1, 2, 8, 0, 0, 0,
00205 #endif
00206 #if defined (CLEO)
00207 C AJWMOD fix sign bug, 2/22/99
00208      7              -3,-4, 0, 0, 0, 0                         /
00209 #else
00210      7              -3, 4, 0, 0, 0, 0                         /
00211 #endif
00212 * LIST OF BRANCHING RATIOS
00213       NCHAN = NMODE + 7
00214       DO 1 I = 1,30
00215       IF (I.LE.NCHAN) THEN
00216         JLIST(I) = I
00217 #if defined (CePeCe)
00218         IF(I.EQ. 1) GAMPRT(I) = 1.0000
00219         IF(I.EQ. 2) GAMPRT(I) = 1.0000
00220         IF(I.EQ. 3) GAMPRT(I) = 1.0000
00221         IF(I.EQ. 4) GAMPRT(I) = 1.0000
00222         IF(I.EQ. 5) GAMPRT(I) = 1.0000
00223         IF(I.EQ. 6) GAMPRT(I) = 1.0000
00224         IF(I.EQ. 7) GAMPRT(I) = 1.0000
00225         IF(I.EQ. 8) GAMPRT(I) = 1.0000
00226         IF(I.EQ. 9) GAMPRT(I) = 1.0000
00227         IF(I.EQ.10) GAMPRT(I) = 1.0000
00228         IF(I.EQ.11) GAMPRT(I) = 1.0000
00229         IF(I.EQ.12) GAMPRT(I) = 1.0000
00230         IF(I.EQ.13) GAMPRT(I) = 1.0000
00231         IF(I.EQ.14) GAMPRT(I) = 1.0000
00232         IF(I.EQ.15) GAMPRT(I) = 1.0000
00233         IF(I.EQ.16) GAMPRT(I) = 1.0000
00234         IF(I.EQ.17) GAMPRT(I) = 1.0000
00235         IF(I.EQ.18) GAMPRT(I) = 1.0000
00236         IF(I.EQ.19) GAMPRT(I) = 1.0000
00237         IF(I.EQ.20) GAMPRT(I) = 1.0000
00238         IF(I.EQ.21) GAMPRT(I) = 1.0000
00239         IF(I.EQ.22) GAMPRT(I) = 1.0000
00240 #elif defined (CLEO)
00241         IF(I.EQ. 1) GAMPRT(I) =0.1800 
00242         IF(I.EQ. 2) GAMPRT(I) =0.1751 
00243         IF(I.EQ. 3) GAMPRT(I) =0.1110 
00244         IF(I.EQ. 4) GAMPRT(I) =0.2515 
00245         IF(I.EQ. 5) GAMPRT(I) =0.1790 
00246         IF(I.EQ. 6) GAMPRT(I) =0.0071 
00247         IF(I.EQ. 7) GAMPRT(I) =0.0134
00248         IF(I.EQ. 8) GAMPRT(I) =0.0450
00249         IF(I.EQ. 9) GAMPRT(I) =0.0100
00250         IF(I.EQ.10) GAMPRT(I) =0.0009
00251         IF(I.EQ.11) GAMPRT(I) =0.0004 
00252         IF(I.EQ.12) GAMPRT(I) =0.0003 
00253         IF(I.EQ.13) GAMPRT(I) =0.0005 
00254         IF(I.EQ.14) GAMPRT(I) =0.0015 
00255         IF(I.EQ.15) GAMPRT(I) =0.0015 
00256         IF(I.EQ.16) GAMPRT(I) =0.0015 
00257         IF(I.EQ.17) GAMPRT(I) =0.0005
00258         IF(I.EQ.18) GAMPRT(I) =0.0050
00259         IF(I.EQ.19) GAMPRT(I) =0.0055
00260         IF(I.EQ.20) GAMPRT(I) =0.0017 
00261         IF(I.EQ.21) GAMPRT(I) =0.0013 
00262         IF(I.EQ.22) GAMPRT(I) =0.0010 
00263 #elif defined (ALEPH)
00264         IF(I.EQ. 1) GAMPRT(I) = 1.0000
00265         IF(I.EQ. 2) GAMPRT(I) =  .9732
00266         IF(I.EQ. 3) GAMPRT(I) =  .6217
00267         IF(I.EQ. 4) GAMPRT(I) = 1.4221
00268         IF(I.EQ. 5) GAMPRT(I) = 1.0180
00269         IF(I.EQ. 6) GAMPRT(I) =  .0405
00270         IF(I.EQ. 7) GAMPRT(I) =  .0781
00271         IF(I.EQ. 8) GAMPRT(I) =  .2414
00272         IF(I.EQ. 9) GAMPRT(I) =  .0601
00273         IF(I.EQ.10) GAMPRT(I) =  .0281
00274         IF(I.EQ.11) GAMPRT(I) =  .0045
00275         IF(I.EQ.12) GAMPRT(I) =  .0010
00276         IF(I.EQ.13) GAMPRT(I) =  .0062
00277         IF(I.EQ.14) GAMPRT(I) =  .0096
00278         IF(I.EQ.15) GAMPRT(I) =  .0169
00279         IF(I.EQ.16) GAMPRT(I) =  .0056
00280         IF(I.EQ.17) GAMPRT(I) =  .0045
00281         IF(I.EQ.18) GAMPRT(I) =  .0219
00282         IF(I.EQ.19) GAMPRT(I) =  .0180
00283         IF(I.EQ.20) GAMPRT(I) =  .0096
00284         IF(I.EQ.21) GAMPRT(I) =  .0088
00285         IF(I.EQ.22) GAMPRT(I) =  .0146
00286 #else
00287 #endif
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-  -->  A1- (two subch)   '
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         IF(I.EQ.10) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 2PI0   '
00298         IF(I.EQ.11) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,        '
00299         IF(I.EQ.12) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,  PI0   '
00300         IF(I.EQ.13) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 3PI0   '
00301         IF(I.EQ.14) NAMES(I-7)='  TAU-  -->  K-, PI-,  K+      '
00302         IF(I.EQ.15) NAMES(I-7)='  TAU-  -->  K0, PI-, K0B      '
00303 #if defined (ALEPH)
00304         IF(I.EQ.16) NAMES(I-7)='  TAU-  -->  K-  PI0   K0      '
00305 #else
00306         IF(I.EQ.16) NAMES(I-7)='  TAU-  -->  K-,  K0, PI0      '
00307 #endif
00308         IF(I.EQ.17) NAMES(I-7)='  TAU-  --> PI0  PI0   K-      '
00309         IF(I.EQ.18) NAMES(I-7)='  TAU-  -->  K-  PI-  PI+      '
00310         IF(I.EQ.19) NAMES(I-7)='  TAU-  --> PI-  K0B  PI0      '
00311         IF(I.EQ.20) NAMES(I-7)='  TAU-  --> ETA  PI-  PI0      '
00312         IF(I.EQ.21) NAMES(I-7)='  TAU-  --> PI-  PI0  GAM      '
00313         IF(I.EQ.22) NAMES(I-7)='  TAU-  -->  K-  K0            '
00314       ELSE
00315         JLIST(I) = 0
00316         GAMPRT(I) = 0.
00317       ENDIF
00318    1  CONTINUE
00319       DO I=1,NMODE
00320         MULPIK(I)=NPIK(I)
00321         DO J=1,MULPIK(I)
00322          IDFFIN(J,I)=NOPIK(J,I)
00323         ENDDO
00324       ENDDO
00325 *
00326 *
00327 * --- COEFFICIENTS TO FIX RATIO OF:
00328 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00329 * --- PROBABILITY OF K0 TO BE KS
00330 * --- PROBABILITY OF K0B TO BE KS
00331 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00332 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00333 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00334 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00335       BRA1=0.5
00336       BRK0=0.5
00337       BRK0B=0.5
00338       BRKS=0.6667
00339 *
00340 
00341       GFERMI = 1.16637E-5
00342       CCABIB = 0.975
00343       GV     = 1.0
00344       GA     =-1.0
00345 
00346 
00347 
00348       GFERMI = xpar(32)
00349       IF (XPAR(ITAUXPAR+100+1).GT.-1D0) THEN
00350 C initialization form KK
00351         CCABIB = XPAR(ITAUXPAR+7)
00352         GV     = XPAR(ITAUXPAR+8)
00353         GA     = XPAR(ITAUXPAR+9)
00354 
00355         BRA1   = XPAR(ITAUXPAR+10)
00356         BRKS   = XPAR(ITAUXPAR+11)
00357         BRK0   = XPAR(ITAUXPAR+12)
00358         BRK0B  = XPAR(ITAUXPAR+13)
00359         DO K=1,NCHAN
00360          GAMPRT(K)=XPAR(ITAUXPAR+100+K)
00361         ENDDO
00362       ENDIF
00363 * ZW 13.04.89 HERE WAS AN ERROR
00364       SCABIB = SQRT(1.-CCABIB**2)
00365       PI =4.*ATAN(1.)
00366       GAMEL  = GFERMI**2*AMTAU**5/(192*PI**3)
00367 *
00368 *      CALL DEXAY(-1,pol1)
00369 *
00370 * PRINTOUTS FOR KK version
00371 
00372       SUM=0
00373       DO K=1,NCHAN
00374        SUM=SUM+GAMPRT(K)
00375       ENDDO
00376 
00377       
00378       WRITE(iout,bxope)
00379       WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INITDK:    '
00380       WRITE(iout,bxtxt) ' Adopted to read from KK                     '
00381       WRITE(iout,bxtxt) '                      '
00382       WRITE(iout,bxtxt) ' Choice Probability      --     Decay Channel'
00383       DO K=1,7      
00384       WRITE(iout,bxINIT) GAMPRT(K)/SUM,    OLDNAMES(K),'****','***'
00385       ENDDO
00386       DO K=8,7+NMODE      
00387       WRITE(iout,bxINIT) GAMPRT(K)/SUM,     NAMES(K-7),'****','***'
00388       ENDDO
00389       WRITE(iout,bxtxt) ' In addition:'
00390       WRITE(iout,bxINIT) GV,    'Vector W-tau-nu coupl.     ','****','***'
00391       WRITE(iout,bxINIT) GA,    'Axial  W-tau-nu coupl.     ','****','***'
00392       WRITE(iout,bxINIT) GFERMI,'Fermi Coupling             ','****','***'
00393       WRITE(iout,bxINIT) CCABIB,'cabibo angle               ','****','***'
00394       WRITE(iout,bxINIT) BRA1,  'a1 br ratio (massless)     ','****','***'
00395       WRITE(iout,bxINIT) BRKS,  'K* br ratio (massless)     ','****','***'
00396       WRITE(iout,bxclo)
00397             
00398       RETURN
00399       END
00400 
00401       SUBROUTINE INIPHY(XK00)
00402 * ----------------------------------------------------------------------
00403 *     INITIALISATION OF PARAMETERS
00404 *     USED IN QED and/or GSW ROUTINES
00405 * ----------------------------------------------------------------------
00406       COMMON / QEDPRM /ALFINV,ALFPI,XK0
00407       REAL*8           ALFINV,ALFPI,XK0
00408       REAL*8 PI8,XK00
00409 *
00410       PI8    = 4.D0*DATAN(1.D0)
00411       ALFINV = 137.03604D0
00412       ALFPI  = 1D0/(ALFINV*PI8)
00413       XK0=XK00
00414       END
00415 
00416       SUBROUTINE INIMAS(ITAUXPAR,xpar)
00417 * ----------------------------------------------------------------------
00418 *     INITIALISATION OF MASSES
00419 *
00420 *     called by : KORALZ
00421 * ----------------------------------------------------------------------
00422       INCLUDE "BXformat.h"
00423       INTEGER   INUT,IOUT
00424       COMMON /INOUT/  
00425      $     INUT,         ! Input  unit  number (not used)
00426      $     IOUT          ! Ounput unit  number
00427       REAL*8 xpar(*)
00428       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00429      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00430      *                 ,AMK,AMKZ,AMKST,GAMKST
00431 *
00432       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00433      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00434      *                 ,AMK,AMKZ,AMKST,GAMKST
00435       CHARACTER*80 bxINIT
00436       PARAMETER (
00437      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00438      $ )
00439 *
00440 * IN-COMING / OUT-GOING  FERMION MASSES
00441       AMTAU  = xpar(656)
00442       AMNUTA = 0.010
00443       AMEL   = xpar(616)
00444       AMNUE  = 0.0
00445       AMMU   = xpar(636)
00446       AMNUMU = 0.0
00447 *
00448 * MASSES USED IN TAU DECAYS
00449 #if defined (CePeCe)
00450       AMPIZ  = 0.134964
00451       AMPI   = 0.139568
00452       AMRO   = 0.773
00453       GAMRO  = 0.145
00454 *C    GAMRO  = 0.666
00455       AMA1   = 1.251
00456       GAMA1  = 0.599
00457       AMK    = 0.493667
00458       AMKZ   = 0.49772
00459       AMKST  = 0.8921
00460       GAMKST = 0.0513
00461 #elif defined (CLEO)
00462       AMPIZ  = 0.134964
00463       AMPI   = 0.139568
00464       AMRO   = 0.773
00465       GAMRO  = 0.145
00466 *C    GAMRO  = 0.666
00467       AMA1   = 1.251
00468       GAMA1  = 0.599
00469       AMK    = 0.493667
00470       AMKZ   = 0.49772
00471       AMKST  = 0.8921
00472       GAMKST = 0.0513
00473 C
00474 C
00475 C IN-COMING / OUT-GOING  FERMION MASSES
00476 !!      AMNUTA = PKORB(1,2)
00477 !!      AMNUE  = PKORB(1,4)
00478 !!      AMNUMU = PKORB(1,6)
00479 C
00480 C MASSES USED IN TAU DECAYS  Cleo settings
00481 !!      AMPIZ  = PKORB(1,7)
00482 !!      AMPI   = PKORB(1,8)
00483 !!      AMRO   = PKORB(1,9)
00484 !!      GAMRO  = PKORB(2,9)
00485       AMA1   = 1.275   !! PKORB(1,10)
00486       GAMA1  = 0.615   !! PKORB(2,10)
00487 !!      AMK    = PKORB(1,11)
00488 !!      AMKZ   = PKORB(1,12)
00489 !!      AMKST  = PKORB(1,13)
00490 !!      GAMKST = PKORB(2,13)
00491 C
00492 #elif defined (ALEPH)
00493       AMPIZ  = 0.134964
00494       AMPI   = 0.139568
00495       AMRO   = 0.7714
00496       GAMRO  = 0.153
00497 cam   AMRO   = 0.773
00498 cam   GAMRO  = 0.145
00499       AMA1   = 1.251! PMAS(LUCOMP(ia1),1)       ! AMA1   = 1.251
00500       GAMA1  = 0.599! PMAS(LUCOMP(ia1),2)       ! GAMA1  = 0.599
00501       print *,'INIMAS a1 mass= ',ama1,gama1
00502       AMK    = 0.493667
00503       AMKZ   = 0.49772
00504       AMKST  = 0.8921
00505       GAMKST = 0.0513
00506 #else
00507 #endif
00508 
00509       WRITE(iout,bxope)
00510       WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INIMAS:    '
00511       WRITE(iout,bxtxt) ' Adopted to read from KK                     '
00512       WRITE(iout,bxINIT) amtau, 'AMTAU tau-mass             ','****','***'
00513       WRITE(iout,bxINIT) amel , 'AMEL  electron-mass        ','****','***'
00514       WRITE(iout,bxINIT) ammu , 'AMMU  muon-mass            ','****','***'
00515       WRITE(iout,bxclo)
00516 
00517       END
00518       SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
00519      $            AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
00520       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00521      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00522      *                 ,AMK,AMKZ,AMKST,GAMKST
00523 C
00524       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00525      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00526      *                 ,AMK,AMKZ,AMKST,GAMKST
00527 C
00528       AMROP=1.1
00529       GAMROP=0.36
00530       AMOM=.782
00531       GAMOM=0.0084
00532 C     XXXXA CORRESPOND TO S2 CHANNEL !
00533       IF(MNUM.EQ.0) THEN
00534        PROB1=0.5
00535        PROB2=0.5
00536        AMRX =AMA1
00537        GAMRX=GAMA1
00538        AMRA =AMRO
00539        GAMRA=GAMRO
00540        AMRB =AMRO
00541        GAMRB=GAMRO
00542       ELSEIF(MNUM.EQ.1) THEN
00543        PROB1=0.5
00544        PROB2=0.5
00545        AMRX =1.57
00546        GAMRX=0.9
00547        AMRB =AMKST
00548        GAMRB=GAMKST
00549        AMRA =AMRO
00550        GAMRA=GAMRO
00551       ELSEIF(MNUM.EQ.2) THEN
00552        PROB1=0.5
00553        PROB2=0.5
00554        AMRX =1.57
00555        GAMRX=0.9
00556        AMRB =AMKST
00557        GAMRB=GAMKST
00558        AMRA =AMRO
00559        GAMRA=GAMRO
00560       ELSEIF(MNUM.EQ.3) THEN
00561        PROB1=0.5
00562        PROB2=0.5
00563        AMRX =1.27
00564        GAMRX=0.3
00565        AMRA =AMKST
00566        GAMRA=GAMKST
00567        AMRB =AMKST
00568        GAMRB=GAMKST
00569       ELSEIF(MNUM.EQ.4) THEN
00570        PROB1=0.5
00571        PROB2=0.5
00572        AMRX =1.27
00573        GAMRX=0.3
00574        AMRA =AMKST
00575        GAMRA=GAMKST
00576        AMRB =AMKST
00577        GAMRB=GAMKST
00578       ELSEIF(MNUM.EQ.5) THEN
00579        PROB1=0.5
00580        PROB2=0.5
00581        AMRX =1.27
00582        GAMRX=0.3
00583        AMRA =AMKST
00584        GAMRA=GAMKST
00585        AMRB =AMRO
00586        GAMRB=GAMRO
00587       ELSEIF(MNUM.EQ.6) THEN
00588        PROB1=0.4
00589        PROB2=0.4
00590        AMRX =1.27
00591        GAMRX=0.3
00592        AMRA =AMRO
00593        GAMRA=GAMRO
00594        AMRB =AMKST
00595        GAMRB=GAMKST
00596       ELSEIF(MNUM.EQ.7) THEN
00597        PROB1=0.0
00598        PROB2=1.0
00599        AMRX =1.27
00600        GAMRX=0.9
00601        AMRA =AMRO
00602        GAMRA=GAMRO
00603        AMRB =AMRO
00604        GAMRB=GAMRO
00605       ELSEIF(MNUM.EQ.8) THEN
00606        PROB1=0.0
00607        PROB2=1.0
00608        AMRX =AMROP
00609        GAMRX=GAMROP
00610        AMRB =AMOM
00611        GAMRB=GAMOM
00612        AMRA =AMRO
00613        GAMRA=GAMRO
00614       ELSEIF(MNUM.EQ.101) THEN
00615        PROB1=.35
00616        PROB2=.35
00617        AMRX =1.2
00618        GAMRX=.46
00619        AMRB =AMOM
00620        GAMRB=GAMOM
00621        AMRA =AMOM
00622        GAMRA=GAMOM
00623       ELSEIF(MNUM.EQ.102) THEN
00624        PROB1=0.0
00625        PROB2=0.0
00626        AMRX =1.4
00627        GAMRX=.6
00628        AMRB =AMOM
00629        GAMRB=GAMOM
00630        AMRA =AMOM
00631        GAMRA=GAMOM
00632       ELSE
00633        PROB1=0.0
00634        PROB2=0.0
00635        AMRX =AMA1
00636        GAMRX=GAMA1
00637        AMRA =AMRO
00638        GAMRA=GAMRO
00639        AMRB =AMRO
00640        GAMRB=GAMRO
00641       ENDIF
00642 C
00643       IF    (RR.LE.PROB1) THEN
00644        ICHAN=1
00645       ELSEIF(RR.LE.(PROB1+PROB2)) THEN
00646        ICHAN=2
00647         AX   =AMRA
00648         GX   =GAMRA
00649         AMRA =AMRB
00650         GAMRA=GAMRB
00651         AMRB =AX
00652         GAMRB=GX
00653         PX   =PROB1
00654         PROB1=PROB2
00655         PROB2=PX
00656       ELSE
00657        ICHAN=3
00658       ENDIF
00659 C
00660       PROB3=1.0-PROB1-PROB2
00661       END
00662       FUNCTION DCDMAS(IDENT)
00663       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00664      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00665      *                 ,AMK,AMKZ,AMKST,GAMKST
00666 *
00667       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00668      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00669      *                 ,AMK,AMKZ,AMKST,GAMKST
00670       IF      (IDENT.EQ. 1) THEN
00671         APKMAS=AMPI
00672       ELSEIF  (IDENT.EQ.-1) THEN
00673         APKMAS=AMPI
00674       ELSEIF  (IDENT.EQ. 2) THEN
00675         APKMAS=AMPIZ
00676       ELSEIF  (IDENT.EQ.-2) THEN
00677         APKMAS=AMPIZ
00678       ELSEIF  (IDENT.EQ. 3) THEN
00679         APKMAS=AMK
00680       ELSEIF  (IDENT.EQ.-3) THEN
00681         APKMAS=AMK
00682       ELSEIF  (IDENT.EQ. 4) THEN
00683         APKMAS=AMKZ
00684       ELSEIF  (IDENT.EQ.-4) THEN
00685         APKMAS=AMKZ
00686       ELSEIF  (IDENT.EQ. 8) THEN
00687         APKMAS=0.0001
00688       ELSEIF  (IDENT.EQ.-8) THEN
00689         APKMAS=0.0001
00690       ELSEIF  (IDENT.EQ. 9) THEN
00691         APKMAS=0.5488
00692       ELSEIF  (IDENT.EQ.-9) THEN
00693         APKMAS=0.5488
00694       ELSE
00695         PRINT *, 'STOP IN APKMAS, WRONG IDENT=',IDENT
00696         STOP
00697       ENDIF
00698       DCDMAS=APKMAS
00699       END
00700       FUNCTION LUNPIK(ID,ISGN)
00701       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00702       REAL*4            BRA1,BRK0,BRK0B,BRKS
00703       REAL*4 XIO(1)
00704       IDENT=ID*ISGN
00705 #if defined (ALEPH)
00706       IF      (IDENT.EQ. 1) THEN
00707         IPKDEF= 211
00708       ELSEIF  (IDENT.EQ.-1) THEN
00709         IPKDEF=-211
00710       ELSEIF  (IDENT.EQ. 2) THEN
00711         IPKDEF= 111
00712       ELSEIF  (IDENT.EQ.-2) THEN
00713         IPKDEF= 111
00714       ELSEIF  (IDENT.EQ. 3) THEN
00715         IPKDEF= 321
00716       ELSEIF  (IDENT.EQ.-3) THEN
00717         IPKDEF=-321
00718 #else
00719       IF      (IDENT.EQ. 1) THEN
00720         IPKDEF=-211
00721       ELSEIF  (IDENT.EQ.-1) THEN
00722         IPKDEF= 211
00723       ELSEIF  (IDENT.EQ. 2) THEN
00724         IPKDEF=111
00725       ELSEIF  (IDENT.EQ.-2) THEN
00726         IPKDEF=111
00727       ELSEIF  (IDENT.EQ. 3) THEN
00728         IPKDEF=-321
00729       ELSEIF  (IDENT.EQ.-3) THEN
00730         IPKDEF= 321
00731 #endif
00732       ELSEIF  (IDENT.EQ. 4) THEN
00733 *
00734 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00735         CALL RANMAR(XIO,1)
00736         IF (XIO(1).GT.BRK0) THEN
00737           IPKDEF= 130
00738         ELSE
00739           IPKDEF= 310
00740         ENDIF
00741       ELSEIF  (IDENT.EQ.-4) THEN
00742 *
00743 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00744         CALL RANMAR(XIO,1)
00745         IF (XIO(1).GT.BRK0B) THEN
00746           IPKDEF= 130
00747         ELSE
00748           IPKDEF= 310
00749         ENDIF
00750       ELSEIF  (IDENT.EQ. 8) THEN
00751         IPKDEF= 22
00752       ELSEIF  (IDENT.EQ.-8) THEN
00753         IPKDEF= 22
00754       ELSEIF  (IDENT.EQ. 9) THEN
00755         IPKDEF= 221
00756       ELSEIF  (IDENT.EQ.-9) THEN
00757         IPKDEF= 221
00758       ELSE
00759         PRINT *, 'STOP IN IPKDEF, WRONG IDENT=',IDENT
00760         STOP
00761       ENDIF
00762       LUNPIK=IPKDEF
00763       END
00764 
00765 
00766 #if defined (CLEO)
00767 
00768       SUBROUTINE TAURDF(KTO)
00769 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
00770 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
00771 C CONTENTS
00772       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00773       REAL*4            BRA1,BRK0,BRK0B,BRKS
00774       COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00775       IF (KTO.EQ.1) THEN
00776 C     ==================
00777 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00778       BRA1 = PKORB(4,1)
00779       BRKS = PKORB(4,3)
00780       BRK0  = PKORB(4,5)
00781       BRK0B  = PKORB(4,6)
00782       ELSE
00783 C     ====
00784 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00785       BRA1 = PKORB(4,2)
00786       BRKS = PKORB(4,4)
00787       BRK0  = PKORB(4,5)
00788       BRK0B  = PKORB(4,6)
00789       ENDIF
00790 C     =====
00791       END
00792 #else
00793 
00794       SUBROUTINE TAURDF(KTO)
00795 * THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
00796 * IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
00797 * CONTENTS
00798       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00799       REAL*4            BRA1,BRK0,BRK0B,BRKS
00800       COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00801       IF (KTO.EQ.1) THEN
00802 *     ==================
00803 * LIST OF BRANCHING RATIOS
00804       NCHAN = 19
00805       DO 1 I = 1,30
00806       IF (I.LE.NCHAN) THEN
00807         JLIST(I) = I
00808         IF(I.EQ. 1) GAMPRT(I) = .0000
00809         IF(I.EQ. 2) GAMPRT(I) = .0000
00810         IF(I.EQ. 3) GAMPRT(I) = .0000
00811         IF(I.EQ. 4) GAMPRT(I) = .0000
00812         IF(I.EQ. 5) GAMPRT(I) = .0000
00813         IF(I.EQ. 6) GAMPRT(I) = .0000
00814         IF(I.EQ. 7) GAMPRT(I) = .0000
00815         IF(I.EQ. 8) GAMPRT(I) = 1.0000
00816         IF(I.EQ. 9) GAMPRT(I) = 1.0000
00817         IF(I.EQ.10) GAMPRT(I) = 1.0000
00818         IF(I.EQ.11) GAMPRT(I) = 1.0000
00819         IF(I.EQ.12) GAMPRT(I) = 1.0000
00820         IF(I.EQ.13) GAMPRT(I) = 1.0000
00821         IF(I.EQ.14) GAMPRT(I) = 1.0000
00822         IF(I.EQ.15) GAMPRT(I) = 1.0000
00823         IF(I.EQ.16) GAMPRT(I) = 1.0000
00824         IF(I.EQ.17) GAMPRT(I) = 1.0000
00825         IF(I.EQ.18) GAMPRT(I) = 1.0000
00826         IF(I.EQ.19) GAMPRT(I) = 1.0000
00827       ELSE
00828         JLIST(I) = 0
00829         GAMPRT(I) = 0.
00830       ENDIF
00831    1  CONTINUE
00832 * --- COEFFICIENTS TO FIX RATIO OF:
00833 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00834 * --- PROBABILITY OF K0 TO BE KS
00835 * --- PROBABILITY OF K0B TO BE KS
00836 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00837 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00838 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00839 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00840       BRA1=0.5
00841       BRK0=0.5
00842       BRK0B=0.5
00843       BRKS=0.6667
00844       ELSE
00845 *     ====
00846 * LIST OF BRANCHING RATIOS
00847       NCHAN = 19
00848       DO 2 I = 1,30
00849       IF (I.LE.NCHAN) THEN
00850         JLIST(I) = I
00851         IF(I.EQ. 1) GAMPRT(I) = .0000
00852         IF(I.EQ. 2) GAMPRT(I) = .0000
00853         IF(I.EQ. 3) GAMPRT(I) = .0000
00854         IF(I.EQ. 4) GAMPRT(I) = .0000
00855         IF(I.EQ. 5) GAMPRT(I) = .0000
00856         IF(I.EQ. 6) GAMPRT(I) = .0000
00857         IF(I.EQ. 7) GAMPRT(I) = .0000
00858         IF(I.EQ. 8) GAMPRT(I) = 1.0000
00859         IF(I.EQ. 9) GAMPRT(I) = 1.0000
00860         IF(I.EQ.10) GAMPRT(I) = 1.0000
00861         IF(I.EQ.11) GAMPRT(I) = 1.0000
00862         IF(I.EQ.12) GAMPRT(I) = 1.0000
00863         IF(I.EQ.13) GAMPRT(I) = 1.0000
00864         IF(I.EQ.14) GAMPRT(I) = 1.0000
00865         IF(I.EQ.15) GAMPRT(I) = 1.0000
00866         IF(I.EQ.16) GAMPRT(I) = 1.0000
00867         IF(I.EQ.17) GAMPRT(I) = 1.0000
00868         IF(I.EQ.18) GAMPRT(I) = 1.0000
00869         IF(I.EQ.19) GAMPRT(I) = 1.0000
00870       ELSE
00871         JLIST(I) = 0
00872         GAMPRT(I) = 0.
00873       ENDIF
00874    2  CONTINUE
00875 * --- COEFFICIENTS TO FIX RATIO OF:
00876 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00877 * --- PROBABILITY OF K0 TO BE KS
00878 * --- PROBABILITY OF K0B TO BE KS
00879 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00880 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00881 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00882 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00883       BRA1=0.5
00884       BRK0=0.5
00885       BRK0B=0.5
00886       BRKS=0.6667
00887       ENDIF
00888 *     =====
00889       END
00890 #endif