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

00001 
00002 
00003 */////////////////////////////////////////////////////////////////////////////////////
00004 *//                                                                                 //
00005 *//  !!!!!!! WARNING!!!!!   This source is agressive !!!!                           //
00006 *//                                                                                 //
00007 *//  Due to short common block names it  owerwrites variables in other parts        //
00008 *//  of the code.                                                                   //
00009 *//                                                                                 //
00010 *//  One should add suffix c_Taul_ to names of all commons as soon as possible!!!!  //
00011 *//                                                                                 //
00012 */////////////////////////////////////////////////////////////////////////////////////
00013 
00014 */////////////////////////////////////////////////////////////////////////////////////
00015 *//                                                                                 //
00016 *//   Standard Tauola interface/initialization routines of functionality exactly    //
00017 *//   as in Tauola CPC  but input is partially from xpar(*) matrix                  //
00018 *//   ITAUXPAR is for indirect adressing                                            //
00019 *//                                                                                 //
00020 */////////////////////////////////////////////////////////////////////////////////////
00021 
00022 
00023       SUBROUTINE INIETC(ITAUXPAR,xpar)
00024       INCLUDE "BXformat.h"
00025       REAL*8 xpar(*)
00026       INTEGER   INUT,IOUT
00027       COMMON /INOUT/  
00028      $     INUT,         ! Input  unit  number (not used)
00029      $     IOUT          ! Ounput unit  number
00030       COMMON / IDFC  / IDFF
00031       COMMON / TAURAD / XK0DEC,ITDKRC
00032       DOUBLE PRECISION            XK0DEC
00033       COMMON / JAKI   /  JAK1,JAK2,JAKP,JAKM,KTOM
00034 * Note: I dont see KeyA1=2,3 realy implemented in the code SJ. ??????
00035       INTEGER  KeyA1
00036       COMMON /TESTA1/
00037      $     KeyA1           ! Special switch for tests of dGamma/dQ**2 in a1 decay
00038 * KeyA1=1 constant width of a1 and rho
00039 * KeyA1=2 free choice of rho propagator (defined in function FPIK)
00040 *         and free choice of a1 mass and width. function g(Q**2)
00041 *         (see formula 3.48 in Comp. Phys. Comm. 64 (1991) 275)
00042 *         hard coded both in Monte Carlo and in testing distribution.
00043 * KeyA1=3 function g(Q**2) hardcoded in the Monte Carlo
00044 *         (it is timy to calculate!), but appropriately adjusted in testing distribution.
00045       SAVE
00046        idff    = xpar(ITAUXPAR+3)        ! Lund identifier for first tau (15 for  tau-)
00047 C XK0 for tau decays.
00048        xk0dec  = xpar(ITAUXPAR+5)        ! IR-cut for QED rad. in leptonic decays
00049 C radiative correction switch in tau --> e (mu) decays !
00050        itdkRC  = xpar(ITAUXPAR+4)        ! QED rad. in leptonic decays
00051 C switches of tau+ tau- decay modes !!
00052        Jak1            = xpar(ITAUXPAR+1)   ! Decay Mask for first tau
00053        Jak2            = xpar(ITAUXPAR+2)   ! Decay Mask for second tau
00054 C output file number for TAUOLA
00055        IOUT    = xpar(4)
00056 C  KeyA1 is used for formfactors actually not in use
00057       KeyA1   = xpar(ITAUXPAR+6)        ! Type of a1 current
00058 
00059         WRITE(iout,bxope)
00060         WRITE(iout,bxtxt) ' Parameters passed from KK  to Tauola:   '
00061         WRITE(iout,bxl1i) Jak1,      'dec. type 1-st tau  ','Jak1  ','t01'
00062         WRITE(iout,bxl1i) Jak2,      'dec. type 2-nd tau  ','Jak2  ','t02'
00063         WRITE(iout,bxl1i) KeyA1,     'current type a1 dec.','KeyA1 ','t03'
00064         WRITE(iout,bxl1i) idff,      'PDG id 1-st tau     ','idff  ','t04'
00065         WRITE(iout,bxl1i) itdkRC,    'R.c. switch lept dec','itdkRC','t05'
00066         WRITE(iout,bxl1g) xk0dec,    'IR-cut for lept r.c.','xk0dec','t06'
00067         WRITE(iout,bxclo)
00068 
00069       end
00070 
00071       SUBROUTINE INITDK(ITAUXPAR,xpar)
00072 * ----------------------------------------------------------------------
00073 *     INITIALISATION OF TAU DECAY PARAMETERS  and routines
00074 *
00075 *     called by : KORALZ
00076 * ----------------------------------------------------------------------
00077       INCLUDE "BXformat.h"
00078       INTEGER   INUT,IOUT
00079       COMMON /INOUT/  
00080      $     INUT,         ! Input  unit  number (not used)
00081      $     IOUT          ! Ounput unit  number
00082       REAL*8 xpar(*)
00083 
00084       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00085       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00086       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00087      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00088      *                 ,AMK,AMKZ,AMKST,GAMKST
00089 *
00090       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00091      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00092      *                 ,AMK,AMKZ,AMKST,GAMKST
00093       COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00094       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00095       REAL*4            BRA1,BRK0,BRK0B,BRKS
00096 
00097 
00098 
00099 
00100 
00101 
00102       PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
00103       COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00104      &                ,NAMES
00105       CHARACTER NAMES(NMODE)*31
00106 
00107       CHARACTER OLDNAMES(7)*31
00108       CHARACTER*80 bxINIT
00109       PARAMETER (
00110      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00111      $ )
00112       REAL*4 PI,POL1(4)
00113 *
00114 *
00115 * LIST OF BRANCHING RATIOS
00116 CAM normalised to e nu nutau channel
00117 CAM                  enu   munu   pinu  rhonu   A1nu   Knu    K*nu   pi
00118 CAM   DATA JLIST  /    1,     2,     3,     4,     5,     6,     7,
00119 *AM   DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
00120 *AM
00121 *AM  multipion decays
00122 *
00123 *    conventions of particles names
00124 *                 K-,P-,K+,  K0,P-,KB,  K-,P0,K0
00125 *                  3, 1,-3  , 4, 1,-4  , 3, 2, 4  ,
00126 *                 P0,P0,K-,  K-,P-,P+,  P-,KB,P0
00127 *                  2, 2, 3  , 3, 1,-1  , 1,-4, 2  ,
00128 *                 ET,P-,P0   P-,P0,GM
00129 *                  9, 1, 2  , 1, 2, 8
00130 *
00131 C
00132       DIMENSION NOPIK(6,NMODE),NPIK(NMODE)
00133 *AM   outgoing multiplicity and flavors of multi-pion /multi-K modes    
00134       DATA   NPIK  /                4,                    4,  
00135      1                              5,                    5,
00136      2                              6,                    6,
00137      3                              3,                    3,            
00138      4                              3,                    3,            
00139      5                              3,                    3,            
00140      6                              3,                    3,  
00141      7                              2                         /         
00142       DATA  NOPIK / -1,-1, 1, 2, 0, 0,     2, 2, 2,-1, 0, 0,  
00143      1              -1,-1, 1, 2, 2, 0,    -1,-1,-1, 1, 1, 0,  
00144      2              -1,-1,-1, 1, 1, 2,    -1,-1, 1, 2, 2, 2, 
00145      3              -3,-1, 3, 0, 0, 0,    -4,-1, 4, 0, 0, 0,  
00146      4              -3, 2,-4, 0, 0, 0,     2, 2,-3, 0, 0, 0,  
00147      5              -3,-1, 1, 0, 0, 0,    -1, 4, 2, 0, 0, 0,  
00148      6               9,-1, 2, 0, 0, 0,    -1, 2, 8, 0, 0, 0,
00149 C AJWMOD fix sign bug, 2/22/99
00150      7              -3,-4, 0, 0, 0, 0                         /
00151 * LIST OF BRANCHING RATIOS
00152       NCHAN = NMODE + 7
00153       DO 1 I = 1,30
00154       IF (I.LE.NCHAN) THEN
00155         JLIST(I) = I
00156         IF(I.EQ. 1) GAMPRT(I) =0.1800 
00157         IF(I.EQ. 2) GAMPRT(I) =0.1751 
00158         IF(I.EQ. 3) GAMPRT(I) =0.1110 
00159         IF(I.EQ. 4) GAMPRT(I) =0.2515 
00160         IF(I.EQ. 5) GAMPRT(I) =0.1790 
00161         IF(I.EQ. 6) GAMPRT(I) =0.0071 
00162         IF(I.EQ. 7) GAMPRT(I) =0.0134
00163         IF(I.EQ. 8) GAMPRT(I) =0.0450
00164         IF(I.EQ. 9) GAMPRT(I) =0.0100
00165         IF(I.EQ.10) GAMPRT(I) =0.0009
00166         IF(I.EQ.11) GAMPRT(I) =0.0004 
00167         IF(I.EQ.12) GAMPRT(I) =0.0003 
00168         IF(I.EQ.13) GAMPRT(I) =0.0005 
00169         IF(I.EQ.14) GAMPRT(I) =0.0015 
00170         IF(I.EQ.15) GAMPRT(I) =0.0015 
00171         IF(I.EQ.16) GAMPRT(I) =0.0015 
00172         IF(I.EQ.17) GAMPRT(I) =0.0005
00173         IF(I.EQ.18) GAMPRT(I) =0.0050
00174         IF(I.EQ.19) GAMPRT(I) =0.0055
00175         IF(I.EQ.20) GAMPRT(I) =0.0017 
00176         IF(I.EQ.21) GAMPRT(I) =0.0013 
00177         IF(I.EQ.22) GAMPRT(I) =0.0010 
00178         IF(I.EQ. 1) OLDNAMES(I)='  TAU-  -->   E-               '
00179         IF(I.EQ. 2) OLDNAMES(I)='  TAU-  -->  MU-               '
00180         IF(I.EQ. 3) OLDNAMES(I)='  TAU-  -->  PI-               '
00181         IF(I.EQ. 4) OLDNAMES(I)='  TAU-  -->  PI-, PI0          '
00182         IF(I.EQ. 5) OLDNAMES(I)='  TAU-  -->  A1- (two subch)   '
00183         IF(I.EQ. 6) OLDNAMES(I)='  TAU-  -->   K-               '
00184         IF(I.EQ. 7) OLDNAMES(I)='  TAU-  -->  K*- (two subch)   '
00185         IF(I.EQ. 8) NAMES(I-7)='  TAU-  --> 2PI-,  PI0,  PI+   '
00186         IF(I.EQ. 9) NAMES(I-7)='  TAU-  --> 3PI0,        PI-   '
00187         IF(I.EQ.10) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 2PI0   '
00188         IF(I.EQ.11) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,        '
00189         IF(I.EQ.12) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,  PI0   '
00190         IF(I.EQ.13) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 3PI0   '
00191         IF(I.EQ.14) NAMES(I-7)='  TAU-  -->  K-, PI-,  K+      '
00192         IF(I.EQ.15) NAMES(I-7)='  TAU-  -->  K0, PI-, K0B      '
00193         IF(I.EQ.16) NAMES(I-7)='  TAU-  -->  K-,  K0, PI0      '
00194         IF(I.EQ.17) NAMES(I-7)='  TAU-  --> PI0  PI0   K-      '
00195         IF(I.EQ.18) NAMES(I-7)='  TAU-  -->  K-  PI-  PI+      '
00196         IF(I.EQ.19) NAMES(I-7)='  TAU-  --> PI-  K0B  PI0      '
00197         IF(I.EQ.20) NAMES(I-7)='  TAU-  --> ETA  PI-  PI0      '
00198         IF(I.EQ.21) NAMES(I-7)='  TAU-  --> PI-  PI0  GAM      '
00199         IF(I.EQ.22) NAMES(I-7)='  TAU-  -->  K-  K0            '
00200       ELSE
00201         JLIST(I) = 0
00202         GAMPRT(I) = 0.
00203       ENDIF
00204    1  CONTINUE
00205       DO I=1,NMODE
00206         MULPIK(I)=NPIK(I)
00207         DO J=1,MULPIK(I)
00208          IDFFIN(J,I)=NOPIK(J,I)
00209         ENDDO
00210       ENDDO
00211 *
00212 *
00213 * --- COEFFICIENTS TO FIX RATIO OF:
00214 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00215 * --- PROBABILITY OF K0 TO BE KS
00216 * --- PROBABILITY OF K0B TO BE KS
00217 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00218 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00219 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00220 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00221       BRA1=0.5
00222       BRK0=0.5
00223       BRK0B=0.5
00224       BRKS=0.6667
00225 *
00226 
00227       GFERMI = 1.16637E-5
00228       CCABIB = 0.975
00229       GV     = 1.0
00230       GA     =-1.0
00231 
00232 
00233 
00234       GFERMI = xpar(32)
00235       IF (XPAR(ITAUXPAR+100+1).GT.-1D0) THEN
00236 C initialization form KK
00237         CCABIB = XPAR(ITAUXPAR+7)
00238         GV     = XPAR(ITAUXPAR+8)
00239         GA     = XPAR(ITAUXPAR+9)
00240 
00241         BRA1   = XPAR(ITAUXPAR+10)
00242         BRKS   = XPAR(ITAUXPAR+11)
00243         BRK0   = XPAR(ITAUXPAR+12)
00244         BRK0B  = XPAR(ITAUXPAR+13)
00245         DO K=1,NCHAN
00246          GAMPRT(K)=XPAR(ITAUXPAR+100+K)
00247         ENDDO
00248       ENDIF
00249 * ZW 13.04.89 HERE WAS AN ERROR
00250       SCABIB = SQRT(1.-CCABIB**2)
00251       PI =4.*ATAN(1.)
00252       GAMEL  = GFERMI**2*AMTAU**5/(192*PI**3)
00253 *
00254 *      CALL DEXAY(-1,pol1)
00255 *
00256 * PRINTOUTS FOR KK version
00257 
00258       SUM=0
00259       DO K=1,NCHAN
00260        SUM=SUM+GAMPRT(K)
00261       ENDDO
00262 
00263       
00264       WRITE(iout,bxope)
00265       WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INITDK:    '
00266       WRITE(iout,bxtxt) ' Adopted to read from KK                     '
00267       WRITE(iout,bxtxt) '                      '
00268       WRITE(iout,bxtxt) ' Choice Probability      --     Decay Channel'
00269       DO K=1,7      
00270       WRITE(iout,bxINIT) GAMPRT(K)/SUM,    OLDNAMES(K),'****','***'
00271       ENDDO
00272       DO K=8,7+NMODE      
00273       WRITE(iout,bxINIT) GAMPRT(K)/SUM,     NAMES(K-7),'****','***'
00274       ENDDO
00275       WRITE(iout,bxtxt) ' In addition:'
00276       WRITE(iout,bxINIT) GV,    'Vector W-tau-nu coupl.     ','****','***'
00277       WRITE(iout,bxINIT) GA,    'Axial  W-tau-nu coupl.     ','****','***'
00278       WRITE(iout,bxINIT) GFERMI,'Fermi Coupling             ','****','***'
00279       WRITE(iout,bxINIT) CCABIB,'cabibo angle               ','****','***'
00280       WRITE(iout,bxINIT) BRA1,  'a1 br ratio (massless)     ','****','***'
00281       WRITE(iout,bxINIT) BRKS,  'K* br ratio (massless)     ','****','***'
00282       WRITE(iout,bxclo)
00283             
00284       RETURN
00285       END
00286 
00287       SUBROUTINE INIPHY(XK00)
00288 * ----------------------------------------------------------------------
00289 *     INITIALISATION OF PARAMETERS
00290 *     USED IN QED and/or GSW ROUTINES
00291 * ----------------------------------------------------------------------
00292       COMMON / QEDPRM /ALFINV,ALFPI,XK0
00293       REAL*8           ALFINV,ALFPI,XK0
00294       REAL*8 PI8,XK00
00295 *
00296       PI8    = 4.D0*DATAN(1.D0)
00297       ALFINV = 137.03604D0
00298       ALFPI  = 1D0/(ALFINV*PI8)
00299       XK0=XK00
00300       END
00301 
00302       SUBROUTINE INIMAS(ITAUXPAR,xpar)
00303 * ----------------------------------------------------------------------
00304 *     INITIALISATION OF MASSES
00305 *
00306 *     called by : KORALZ
00307 * ----------------------------------------------------------------------
00308       INCLUDE "BXformat.h"
00309       INTEGER   INUT,IOUT
00310       COMMON /INOUT/  
00311      $     INUT,         ! Input  unit  number (not used)
00312      $     IOUT          ! Ounput unit  number
00313       REAL*8 xpar(*)
00314       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00315      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00316      *                 ,AMK,AMKZ,AMKST,GAMKST
00317 *
00318       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00319      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00320      *                 ,AMK,AMKZ,AMKST,GAMKST
00321       CHARACTER*80 bxINIT
00322       PARAMETER (
00323      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00324      $ )
00325 *
00326 * IN-COMING / OUT-GOING  FERMION MASSES
00327       AMTAU  = xpar(656)
00328       AMNUTA = 0.010
00329       AMEL   = xpar(616)
00330       AMNUE  = 0.0
00331       AMMU   = xpar(636)
00332       AMNUMU = 0.0
00333 *
00334 * MASSES USED IN TAU DECAYS
00335       AMPIZ  = 0.134964
00336       AMPI   = 0.139568
00337       AMRO   = 0.773
00338       GAMRO  = 0.145
00339 *C    GAMRO  = 0.666
00340       AMA1   = 1.251
00341       GAMA1  = 0.599
00342       AMK    = 0.493667
00343       AMKZ   = 0.49772
00344       AMKST  = 0.8921
00345       GAMKST = 0.0513
00346 C
00347 C
00348 C IN-COMING / OUT-GOING  FERMION MASSES
00349 !!      AMNUTA = PKORB(1,2)
00350 !!      AMNUE  = PKORB(1,4)
00351 !!      AMNUMU = PKORB(1,6)
00352 C
00353 C MASSES USED IN TAU DECAYS  Cleo settings
00354 !!      AMPIZ  = PKORB(1,7)
00355 !!      AMPI   = PKORB(1,8)
00356 !!      AMRO   = PKORB(1,9)
00357 !!      GAMRO  = PKORB(2,9)
00358       AMA1   = 1.275   !! PKORB(1,10)
00359       GAMA1  = 0.615   !! PKORB(2,10)
00360 !!      AMK    = PKORB(1,11)
00361 !!      AMKZ   = PKORB(1,12)
00362 !!      AMKST  = PKORB(1,13)
00363 !!      GAMKST = PKORB(2,13)
00364 C
00365 
00366       WRITE(iout,bxope)
00367       WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INIMAS:    '
00368       WRITE(iout,bxtxt) ' Adopted to read from KK                     '
00369       WRITE(iout,bxINIT) amtau, 'AMTAU tau-mass             ','****','***'
00370       WRITE(iout,bxINIT) amel , 'AMEL  electron-mass        ','****','***'
00371       WRITE(iout,bxINIT) ammu , 'AMMU  muon-mass            ','****','***'
00372       WRITE(iout,bxclo)
00373 
00374       END
00375       SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
00376      $            AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
00377       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00378      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00379      *                 ,AMK,AMKZ,AMKST,GAMKST
00380 C
00381       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00382      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00383      *                 ,AMK,AMKZ,AMKST,GAMKST
00384 C
00385       AMROP=1.1
00386       GAMROP=0.36
00387       AMOM=.782
00388       GAMOM=0.0084
00389 C     XXXXA CORRESPOND TO S2 CHANNEL !
00390       IF(MNUM.EQ.0) THEN
00391        PROB1=0.5
00392        PROB2=0.5
00393        AMRX =AMA1
00394        GAMRX=GAMA1
00395        AMRA =AMRO
00396        GAMRA=GAMRO
00397        AMRB =AMRO
00398        GAMRB=GAMRO
00399       ELSEIF(MNUM.EQ.1) THEN
00400        PROB1=0.5
00401        PROB2=0.5
00402        AMRX =1.57
00403        GAMRX=0.9
00404        AMRB =AMKST
00405        GAMRB=GAMKST
00406        AMRA =AMRO
00407        GAMRA=GAMRO
00408       ELSEIF(MNUM.EQ.2) THEN
00409        PROB1=0.5
00410        PROB2=0.5
00411        AMRX =1.57
00412        GAMRX=0.9
00413        AMRB =AMKST
00414        GAMRB=GAMKST
00415        AMRA =AMRO
00416        GAMRA=GAMRO
00417       ELSEIF(MNUM.EQ.3) THEN
00418        PROB1=0.5
00419        PROB2=0.5
00420        AMRX =1.27
00421        GAMRX=0.3
00422        AMRA =AMKST
00423        GAMRA=GAMKST
00424        AMRB =AMKST
00425        GAMRB=GAMKST
00426       ELSEIF(MNUM.EQ.4) THEN
00427        PROB1=0.5
00428        PROB2=0.5
00429        AMRX =1.27
00430        GAMRX=0.3
00431        AMRA =AMKST
00432        GAMRA=GAMKST
00433        AMRB =AMKST
00434        GAMRB=GAMKST
00435       ELSEIF(MNUM.EQ.5) THEN
00436        PROB1=0.5
00437        PROB2=0.5
00438        AMRX =1.27
00439        GAMRX=0.3
00440        AMRA =AMKST
00441        GAMRA=GAMKST
00442        AMRB =AMRO
00443        GAMRB=GAMRO
00444       ELSEIF(MNUM.EQ.6) THEN
00445        PROB1=0.4
00446        PROB2=0.4
00447        AMRX =1.27
00448        GAMRX=0.3
00449        AMRA =AMRO
00450        GAMRA=GAMRO
00451        AMRB =AMKST
00452        GAMRB=GAMKST
00453       ELSEIF(MNUM.EQ.7) THEN
00454        PROB1=0.0
00455        PROB2=1.0
00456        AMRX =1.27
00457        GAMRX=0.9
00458        AMRA =AMRO
00459        GAMRA=GAMRO
00460        AMRB =AMRO
00461        GAMRB=GAMRO
00462       ELSEIF(MNUM.EQ.8) THEN
00463        PROB1=0.0
00464        PROB2=1.0
00465        AMRX =AMROP
00466        GAMRX=GAMROP
00467        AMRB =AMOM
00468        GAMRB=GAMOM
00469        AMRA =AMRO
00470        GAMRA=GAMRO
00471       ELSEIF(MNUM.EQ.101) THEN
00472        PROB1=.35
00473        PROB2=.35
00474        AMRX =1.2
00475        GAMRX=.46
00476        AMRB =AMOM
00477        GAMRB=GAMOM
00478        AMRA =AMOM
00479        GAMRA=GAMOM
00480       ELSEIF(MNUM.EQ.102) THEN
00481        PROB1=0.0
00482        PROB2=0.0
00483        AMRX =1.4
00484        GAMRX=.6
00485        AMRB =AMOM
00486        GAMRB=GAMOM
00487        AMRA =AMOM
00488        GAMRA=GAMOM
00489       ELSE
00490        PROB1=0.0
00491        PROB2=0.0
00492        AMRX =AMA1
00493        GAMRX=GAMA1
00494        AMRA =AMRO
00495        GAMRA=GAMRO
00496        AMRB =AMRO
00497        GAMRB=GAMRO
00498       ENDIF
00499 C
00500       IF    (RR.LE.PROB1) THEN
00501        ICHAN=1
00502       ELSEIF(RR.LE.(PROB1+PROB2)) THEN
00503        ICHAN=2
00504         AX   =AMRA
00505         GX   =GAMRA
00506         AMRA =AMRB
00507         GAMRA=GAMRB
00508         AMRB =AX
00509         GAMRB=GX
00510         PX   =PROB1
00511         PROB1=PROB2
00512         PROB2=PX
00513       ELSE
00514        ICHAN=3
00515       ENDIF
00516 C
00517       PROB3=1.0-PROB1-PROB2
00518       END
00519       FUNCTION DCDMAS(IDENT)
00520       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00521      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00522      *                 ,AMK,AMKZ,AMKST,GAMKST
00523 *
00524       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00525      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00526      *                 ,AMK,AMKZ,AMKST,GAMKST
00527       IF      (IDENT.EQ. 1) THEN
00528         APKMAS=AMPI
00529       ELSEIF  (IDENT.EQ.-1) THEN
00530         APKMAS=AMPI
00531       ELSEIF  (IDENT.EQ. 2) THEN
00532         APKMAS=AMPIZ
00533       ELSEIF  (IDENT.EQ.-2) THEN
00534         APKMAS=AMPIZ
00535       ELSEIF  (IDENT.EQ. 3) THEN
00536         APKMAS=AMK
00537       ELSEIF  (IDENT.EQ.-3) THEN
00538         APKMAS=AMK
00539       ELSEIF  (IDENT.EQ. 4) THEN
00540         APKMAS=AMKZ
00541       ELSEIF  (IDENT.EQ.-4) THEN
00542         APKMAS=AMKZ
00543       ELSEIF  (IDENT.EQ. 8) THEN
00544         APKMAS=0.0001
00545       ELSEIF  (IDENT.EQ.-8) THEN
00546         APKMAS=0.0001
00547       ELSEIF  (IDENT.EQ. 9) THEN
00548         APKMAS=0.5488
00549       ELSEIF  (IDENT.EQ.-9) THEN
00550         APKMAS=0.5488
00551       ELSE
00552         PRINT *, 'STOP IN APKMAS, WRONG IDENT=',IDENT
00553         STOP
00554       ENDIF
00555       DCDMAS=APKMAS
00556       END
00557       FUNCTION LUNPIK(ID,ISGN)
00558       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00559       REAL*4            BRA1,BRK0,BRK0B,BRKS
00560       REAL*4 XIO(1)
00561       IDENT=ID*ISGN
00562       IF      (IDENT.EQ. 1) THEN
00563         IPKDEF=-211
00564       ELSEIF  (IDENT.EQ.-1) THEN
00565         IPKDEF= 211
00566       ELSEIF  (IDENT.EQ. 2) THEN
00567         IPKDEF=111
00568       ELSEIF  (IDENT.EQ.-2) THEN
00569         IPKDEF=111
00570       ELSEIF  (IDENT.EQ. 3) THEN
00571         IPKDEF=-321
00572       ELSEIF  (IDENT.EQ.-3) THEN
00573         IPKDEF= 321
00574       ELSEIF  (IDENT.EQ. 4) THEN
00575 *
00576 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00577         CALL RANMAR(XIO,1)
00578         IF (XIO(1).GT.BRK0) THEN
00579           IPKDEF= 130
00580         ELSE
00581           IPKDEF= 310
00582         ENDIF
00583       ELSEIF  (IDENT.EQ.-4) THEN
00584 *
00585 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00586         CALL RANMAR(XIO,1)
00587         IF (XIO(1).GT.BRK0B) THEN
00588           IPKDEF= 130
00589         ELSE
00590           IPKDEF= 310
00591         ENDIF
00592       ELSEIF  (IDENT.EQ. 8) THEN
00593         IPKDEF= 22
00594       ELSEIF  (IDENT.EQ.-8) THEN
00595         IPKDEF= 22
00596       ELSEIF  (IDENT.EQ. 9) THEN
00597         IPKDEF= 221
00598       ELSEIF  (IDENT.EQ.-9) THEN
00599         IPKDEF= 221
00600       ELSE
00601         PRINT *, 'STOP IN IPKDEF, WRONG IDENT=',IDENT
00602         STOP
00603       ENDIF
00604       LUNPIK=IPKDEF
00605       END
00606 
00607 
00608 
00609       SUBROUTINE TAURDF(KTO)
00610 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
00611 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
00612 C CONTENTS
00613       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00614       REAL*4            BRA1,BRK0,BRK0B,BRKS
00615       COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00616       IF (KTO.EQ.1) THEN
00617 C     ==================
00618 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00619       BRA1 = PKORB(4,1)
00620       BRKS = PKORB(4,3)
00621       BRK0  = PKORB(4,5)
00622       BRK0B  = PKORB(4,6)
00623       ELSE
00624 C     ====
00625 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00626       BRA1 = PKORB(4,2)
00627       BRKS = PKORB(4,4)
00628       BRK0  = PKORB(4,5)
00629       BRK0B  = PKORB(4,6)
00630       ENDIF
00631 C     =====
00632       END