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