tauola-F/standalone-F/taumain.F

00001       PROGRAM TAUDEM
00002 C     **************
00003 C NOTE THAT THE ROUTINES ARE NOT LIKE IN CPC DECK THIS IS HISTORICAL !!
00004 C=======================================================================
00005 C====================== DECTES    : TEST OF TAU DECAY LIBRARY===========
00006 C====================== KTORY = 1 : INTERFACE OF KORAL-Z TYPE ==========
00007 C====================== KTORY = 2 : INTERFACE OF KORAL-B TYPE =========
00008 C=======================================================================
00009 C     COMMON  /PAWC/ BLAN(10000)
00010       COMMON  / / BLAN(10000)
00011       CHARACTER*7 DNAME
00012       COMMON / INOUT / INUT,IOUT
00013       DNAME='KKPI'
00014 !      CALL GLIMIT(20000)
00015 !      CALL GOUTPU(16)
00016       INUT=5
00017       IOUT=6
00018       OPEN(IOUT,FILE="./tauola.output")
00019        OPEN(INUT,FILE="./dane.dat")
00020       KTORY=1
00021       CALL DECTES(KTORY)
00022       KTORY=2
00023       CALL DECTES(KTORY)
00024       END
00025       SUBROUTINE DECTES(KTORY)
00026 C     ************************
00027       REAL POL(4)
00028       DOUBLE PRECISION HH(4)
00029 C SWITCHES FOR TAUOLA;
00030       COMMON / JAKI   /  JAK1,JAK2,JAKP,JAKM,KTOM
00031       COMMON / IDFC  / IDFF
00032 C I/O UNITS  NUMBERS
00033       COMMON / INOUT /  INUT,IOUT
00034 C LUND TYPE IDENTIFIER FOR A1
00035       COMMON / IDPART / IA1
00036 C /PTAU/ IS USED IN ROUTINE TRALO4
00037       COMMON /PTAU/ PTAU
00038       COMMON / TAURAD / XK0DEC,ITDKRC
00039       REAL*8            XK0DEC
00040       COMMON /TESTA1/ KEYA1
00041 C special switch for tests of dGamma/dQ**2 in a1 decay
00042 C KEYA1=1 constant width of a1 and rho
00043 C KEYA1=2 free choice of rho propagator (defined in function FPIK)
00044 C         and free choice of a1 mass and width. function g(Q**2)
00045 C         (see formula 3.48 in Comp. Phys. Comm. 64 (1991) 275)
00046 C         hard coded both in Monte Carlo and in testing distribution.
00047 C KEYA1=3 function g(Q**2) hardcoded in the Monte Carlo
00048 C         (it is timy to calculate!), but appropriately adjusted in
00049 C         testing distribution.
00050 C-----------------------------------------------------------------------
00051 C          INITIALIZATION
00052 C-----------------------------------------------------------------------
00053 C======================================
00054       NINP=INUT
00055       NOUT=IOUT
00056  3000 FORMAT(A80)
00057  3001 FORMAT(8I2)
00058  3002 FORMAT(I10)
00059  3003 FORMAT(F10.0)
00060       IF (KTORY.EQ.1) THEN
00061       READ( NINP,3000) TESTIT
00062       WRITE(NOUT,3000) TESTIT
00063       READ( NINP,3001) KAT1,KAT2,KAT3,KAT4,KAT5,KAT6
00064       READ( NINP,3002) NEVT,JAK1,JAK2,ITDKRC
00065       READ( NINP,3003) PTAU,XK0DEC
00066       ENDIF
00067 C======================================
00068 C control output
00069       WRITE(NOUT,'(6A6/6I6)')
00070      $ 'KAT1','KAT2','KAT3','KAT4','KAT5','KAT6',
00071      $  KAT1 , KAT2 , KAT3 , KAT4 , KAT5 , KAT6
00072       WRITE(NOUT,'(4A12/4I12)')
00073      $  'NEVT','JAK1','JAK2','ITDKRC',
00074      $   NEVT,  JAK1 , JAK2 , ITDKRC
00075       WRITE(NOUT,'(2A12/2F12.6)')
00076      $ 'PTAU','XK0DEC',
00077      $  PTAU , XK0DEC
00078 C======================================
00079       JAK=0
00080 C      JAK1=5
00081 C      JAK2=5
00082 C LUND IDENTIFIER (FOR TAU+) -15
00083       IF (KTORY.EQ.1) THEN
00084         IDFF=-15
00085       ELSE
00086         IDFF= 15
00087       ENDIF
00088 C KTO=1 DENOTES TAU DEFINED BY IDFF (I.E. TAU+)
00089 C KTO=2 DENOTES THE OPPOSITE        (I.E. TAU-)
00090       KTO=2
00091       IF (KTO.NE.2) THEN
00092         PRINT *, 'for the sake of these tests KTO has to be 2'
00093         PRINT *, 'to change tau- to tau+ change IDFF from -15 to 15'
00094         STOP
00095       ENDIF
00096 C TAU POLARIZATION IN ITS RESTFRAME;
00097       POL(1)=0.
00098       POL(2)=0.
00099       POL(3)=.9
00100 C TAU MOMENTUM IN GEV;
00101 C      PTAU=CMSENE/2.D0
00102 C NUMBER OF EVENTS TO BE GENERATED;
00103       NEVTES=10
00104       NEVTES=NEVT
00105       PRINT *, 'NEVTES= ',NEVTES
00106       WRITE(IOUT,7011) KEYA1
00107 C
00108       IF (KTORY.EQ.1) THEN
00109          WRITE(IOUT,7001) JAK,IDFF,POL(3),PTAU
00110       ELSE
00111          WRITE(IOUT,7004) JAK,IDFF,POL(3),PTAU
00112       ENDIF
00113 C INITIALISATION OF TAU DECAY PACKAGE TAUOLA
00114 C ******************************************
00115         CALL INIMAS
00116         CALL INITDK
00117 
00118 
00119         CALL INIPHY(0.1D0)
00120       IF (KTORY.EQ.1) THEN
00121          CALL DEXAY(-1,POL)
00122       ELSE
00123          CALL DEKAY(-1,HH)
00124       ENDIF
00125 C-----------------------------------------------------------------------
00126 C          GENERATION
00127 C-----------------------------------------------------------------------
00128       NEV=0
00129       DO 300 IEV=1,NEVTES
00130       NEV=NEV+1
00131 C RESLU INITIALISE THE LUND RECORD
00132 #if defined (history)
00133       CALL RESLU
00134 #else
00135 #endif
00136       CALL TAUFIL
00137 C DECAY....
00138       IF (KTORY.EQ.1) THEN
00139          CALL DEXAY(KTO,POL)
00140       ELSE
00141          CALL DEKAY(KTO,HH)
00142          CALL DEKAY(KTO+10,HH)
00143       ENDIF
00144       CALL LUHEPC(2)
00145       IF(IEV.LE.44) THEN
00146        WRITE(IOUT,7002) IEV
00147        IF (KTORY.NE.1) THEN
00148          WRITE(IOUT,7003) HH
00149        ENDIF
00150 C      CALL LULIST(11)
00151       CALL LULIST(2)
00152       ENDIF
00153       IPRI=MOD(NEV,1000)
00154       IF(IPRI.EQ.1) PRINT *, ' event no: ',NEV,' NEVTES: ',NEVTES
00155   300 CONTINUE
00156   301 CONTINUE
00157 C-----------------------------------------------------------------------
00158 C                     POSTGENERATION
00159 C-----------------------------------------------------------------------
00160       IF (KTORY.EQ.1) THEN
00161          CALL DEXAY(100,POL)
00162       ELSE
00163          CALL DEKAY(100,HH)
00164       ENDIF
00165       RETURN
00166  7001 FORMAT(//4(/1X,15(5H=====))
00167      $ /,' ',     19X,'  TEST OF RAD. CORR IN ELECTRON DECAY   ',9X,1H ,
00168      $ /,' ',     19X,'    TESTS OF TAU DECAY ROUTINES         ',9X,1H ,
00169      $ /,' ',     19X,'    INTERFACE OF THE KORAL-Z TYPE       ',9X,1H ,
00170      $  2(/,1X,15(5H=====)),
00171      $ /,5X ,'JAK   =',I7  ,'  KEY DEFINING DECAY TYPE         ',9X,1H ,
00172      $ /,5X ,'IDFF  =',I7  ,'  LUND IDENTIFIER FOR FIRST TAU   ',9X,1H ,
00173      $ /,5X ,'POL(3)=',F7.2,'  THIRD COMPONENT OF TAU POLARIZ. ',9X,1H ,
00174      $ /,5X ,'PTAU  =',F7.2,'  THIRD COMPONENT OF TAU MOM. GEV ',9X,1H ,
00175      $  2(/,1X,15(5H=====))/)
00176  7002 FORMAT(///1X, '===== EVENT NO.',I4,1X,5H=====)
00177  7003 FORMAT(5X,'POLARIMETRIC VECTOR: ',
00178      $       7X,'HH(1)',7X,'HH(2)',7X,'HH(3)',7X,'HH(4)',
00179      $ /,    5X,'                     ', 4(1X,F11.8)   )
00180  7004 FORMAT(//4(/1X,15(5H=====))
00181      $ /,'  ',     19X,'  TEST OF RAD. CORR IN ELECTRON DECAY  ',9X,1H ,
00182      $ /,'  ',     19X,'    TESTS OF TAU DECAY ROUTINES        ',9X,1H ,
00183      $ /,'  ',     19X,'    INTERFACE OF THE KORAL-B TYPE      ',9X,1H ,
00184      $  2(/,1X,15(5H=====)),
00185      $ /,5X ,'JAK   =',I7  ,'  KEY DEFINING DECAY TYPE         ',9X,1H ,
00186      $ /,5X ,'IDFF  =',I7  ,'  LUND IDENTIFIER FOR FIRST TAU   ',9X,1H ,
00187      $ /,5X ,'POL(3)=',F7.2,'  THIRD COMPONENT OF TAU POLARIZ. ',9X,1H ,
00188      $ /,5X ,'PTAU  =',F7.2,'  THIRD COMPONENT OF TAU MOM. GEV ',9X,1H ,
00189      $  2(/,1X,15(5H=====))/)
00190  7011 FORMAT(///1X, '===== TYPE OF CURRENT',I4,1X,5H=====)
00191       END
00192       SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
00193      $            AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
00194       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00195      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00196      *                 ,AMK,AMKZ,AMKST,GAMKST
00197 C
00198       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00199      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00200      *                 ,AMK,AMKZ,AMKST,GAMKST
00201 C
00202       AMROP=1.1
00203       GAMROP=0.36
00204       AMOM=.782
00205       GAMOM=0.0084
00206 C     XXXXA CORRESPOND TO S2 CHANNEL !
00207       IF(MNUM.EQ.0) THEN
00208        PROB1=0.5
00209        PROB2=0.5
00210        AMRX =AMA1
00211        GAMRX=GAMA1
00212        AMRA =AMRO
00213        GAMRA=GAMRO
00214        AMRB =AMRO
00215        GAMRB=GAMRO
00216       ELSEIF(MNUM.EQ.1) THEN
00217        PROB1=0.5
00218        PROB2=0.5
00219        AMRX =1.57
00220        GAMRX=0.9
00221        AMRB =AMKST
00222        GAMRB=GAMKST
00223        AMRA =AMRO
00224        GAMRA=GAMRO
00225       ELSEIF(MNUM.EQ.2) THEN
00226        PROB1=0.5
00227        PROB2=0.5
00228        AMRX =1.57
00229        GAMRX=0.9
00230        AMRB =AMKST
00231        GAMRB=GAMKST
00232        AMRA =AMRO
00233        GAMRA=GAMRO
00234       ELSEIF(MNUM.EQ.3) THEN
00235        PROB1=0.5
00236        PROB2=0.5
00237        AMRX =1.27
00238        GAMRX=0.3
00239        AMRA =AMKST
00240        GAMRA=GAMKST
00241        AMRB =AMKST
00242        GAMRB=GAMKST
00243       ELSEIF(MNUM.EQ.4) THEN
00244        PROB1=0.5
00245        PROB2=0.5
00246        AMRX =1.27
00247        GAMRX=0.3
00248        AMRA =AMKST
00249        GAMRA=GAMKST
00250        AMRB =AMKST
00251        GAMRB=GAMKST
00252       ELSEIF(MNUM.EQ.5) THEN
00253        PROB1=0.5
00254        PROB2=0.5
00255        AMRX =1.27
00256        GAMRX=0.3
00257        AMRA =AMKST
00258        GAMRA=GAMKST
00259        AMRB =AMRO
00260        GAMRB=GAMRO
00261       ELSEIF(MNUM.EQ.6) THEN
00262        PROB1=0.4
00263        PROB2=0.4
00264        AMRX =1.27
00265        GAMRX=0.3
00266        AMRA =AMRO
00267        GAMRA=GAMRO
00268        AMRB =AMKST
00269        GAMRB=GAMKST
00270       ELSEIF(MNUM.EQ.7) THEN
00271        PROB1=0.0
00272        PROB2=1.0
00273        AMRX =1.27
00274        GAMRX=0.9
00275        AMRA =AMRO
00276        GAMRA=GAMRO
00277        AMRB =AMRO
00278        GAMRB=GAMRO
00279       ELSEIF(MNUM.EQ.8) THEN
00280        PROB1=0.0
00281        PROB2=1.0
00282        AMRX =AMROP
00283        GAMRX=GAMROP
00284        AMRB =AMOM
00285        GAMRB=GAMOM
00286        AMRA =AMRO
00287        GAMRA=GAMRO
00288       ELSEIF(MNUM.EQ.101) THEN
00289        PROB1=.35
00290        PROB2=.35
00291        AMRX =1.2
00292        GAMRX=.46
00293        AMRB =AMOM
00294        GAMRB=GAMOM
00295        AMRA =AMOM
00296        GAMRA=GAMOM
00297       ELSEIF(MNUM.EQ.102) THEN
00298        PROB1=0.0
00299        PROB2=0.0
00300        AMRX =1.4
00301        GAMRX=.6
00302        AMRB =AMOM
00303        GAMRB=GAMOM
00304        AMRA =AMOM
00305        GAMRA=GAMOM
00306       ELSE
00307        PROB1=0.0
00308        PROB2=0.0
00309        AMRX =AMA1
00310        GAMRX=GAMA1
00311        AMRA =AMRO
00312        GAMRA=GAMRO
00313        AMRB =AMRO
00314        GAMRB=GAMRO
00315       ENDIF
00316 C
00317       IF    (RR.LE.PROB1) THEN
00318        ICHAN=1
00319       ELSEIF(RR.LE.(PROB1+PROB2)) THEN
00320        ICHAN=2
00321         AX   =AMRA
00322         GX   =GAMRA
00323         AMRA =AMRB
00324         GAMRA=GAMRB
00325         AMRB =AX
00326         GAMRB=GX
00327         PX   =PROB1
00328         PROB1=PROB2
00329         PROB2=PX
00330       ELSE
00331        ICHAN=3
00332       ENDIF
00333 C
00334       PROB3=1.0-PROB1-PROB2
00335       END
00336       SUBROUTINE INITDK
00337 * ----------------------------------------------------------------------
00338 *     INITIALISATION OF TAU DECAY PARAMETERS  and routines
00339 *
00340 *     called by : KORALZ
00341 * ----------------------------------------------------------------------
00342 
00343       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00344       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00345       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00346      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00347      *                 ,AMK,AMKZ,AMKST,GAMKST
00348 *
00349       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00350      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00351      *                 ,AMK,AMKZ,AMKST,GAMKST
00352       COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00353       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00354       REAL*4            BRA1,BRK0,BRK0B,BRKS
00355 #if defined (ALEPH)
00356       PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
00357       COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00358      &                ,NAMES
00359       CHARACTER NAMES(NMODE)*31
00360 #else
00361       PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
00362       COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00363      &                ,NAMES
00364       CHARACTER NAMES(NMODE)*31
00365 #endif
00366       CHARACTER OLDNAMES(7)*31
00367       CHARACTER*80 bxINIT
00368       PARAMETER (
00369      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00370      $ )
00371       REAL*4 PI,POL1(4)
00372 *
00373 *
00374 * LIST OF BRANCHING RATIOS
00375 CAM normalised to e nu nutau channel
00376 CAM                  enu   munu   pinu  rhonu   A1nu   Knu    K*nu   pi
00377 CAM   DATA JLIST  /    1,     2,     3,     4,     5,     6,     7,
00378 #if defined (ALEPH)
00379 CAM               /0.1779,0.1731,0.1106,0.2530,0.1811,0.0072,0.0139
00380 CAM   DATA GAMPRT / 1.000,0.9732,0.6217,1.4221,1.0180,0.0405,0.0781
00381 CAM   DATA GAMPRT /1.000,0.9676,0.6154,1.3503,1.0225,0.0368,O.O758
00382 CAM
00383 C
00384 C    conventions of particles names
00385 c
00386 cam  mode (JAK)                     8                     9
00387 CAM  channel          pi- pi- pi0 pi+              3pi0 pi-
00388 cam  particle code  -1,-1, 2, 1, 0, 0,     2, 2, 2,-1, 0, 0,
00389 CAM  BR relative to electron    .2414,                .0601,
00390 c
00391 *                                  10                    11
00392 *    1                     3pi+- 2pi0                 5pi+-
00393 *    1              -1,-1, 1, 2, 2, 0,    -1,-1,-1, 1, 1, 0,
00394 *    1                          .0281,                .0045,
00395 
00396 *                                  12                    13
00397 *    2                      5pi+- pi0            3pi+- 3pi0
00398 *    2              -1,-1,-1, 1, 1, 2,    -1,-1, 1, 2, 2, 2,
00399 *    2                          .0010,                .0062,
00400 
00401 *                                  14                    15
00402 *    3                      K- pi- K+             K0 pi- KB
00403 *    3              -3,-1, 3, 0, 0, 0,     4,-1,-4, 0, 0, 0,
00404 *    3                          .0096,                .0169,
00405 
00406 *                                  16                    17
00407 *    4                      K- pi0 K0               2pi0 K-
00408 *    4              -3, 2, 4, 0, 0, 0,     2, 2,-3, 0, 0, 0,
00409 *    4                          .0056,                .0045,
00410 
00411 *                                  18                    19
00412 *    5                     K- pi- pi+            pi- KB pi0
00413 *    5              -3,-1, 1, 0, 0, 0,    -1,-4, 2, 0, 0, 0,
00414 *    5                          .0219,                .0180,
00415 
00416 *                                  20                    21
00417 *    6                    eta pi- pi0         pi- pi0 gamma
00418 *    6               9,-1, 2, 0, 0, 0,    -1, 2, 8, 0, 0, 0,
00419 *    6                          .0096,                .0088,
00420 
00421 *                                  22   /
00422 *    7                          K- K0   /
00423 *    7                          -3, 4   /
00424 *    7                          .0146   /
00425 #else
00426 *AM   DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
00427 *AM
00428 *AM  multipion decays
00429 *
00430 *    conventions of particles names
00431 *                 K-,P-,K+,  K0,P-,KB,  K-,P0,K0
00432 *                  3, 1,-3  , 4, 1,-4  , 3, 2, 4  ,
00433 *                 P0,P0,K-,  K-,P-,P+,  P-,KB,P0
00434 *                  2, 2, 3  , 3, 1,-1  , 1,-4, 2  ,
00435 *                 ET,P-,P0   P-,P0,GM
00436 *                  9, 1, 2  , 1, 2, 8
00437 *
00438 #endif
00439 C
00440       DIMENSION NOPIK(6,NMODE),NPIK(NMODE)
00441 *AM   outgoing multiplicity and flavors of multi-pion /multi-K modes    
00442       DATA   NPIK  /                4,                    4,  
00443      1                              5,                    5,
00444      2                              6,                    6,
00445      3                              3,                    3,            
00446      4                              3,                    3,            
00447      5                              3,                    3,            
00448      6                              3,                    3,  
00449      7                              2                         /         
00450 #if defined (ALEPH)
00451       DATA  NOPIK / -1,-1, 2, 1, 0, 0,     2, 2, 2,-1, 0, 0,
00452      1              -1,-1, 1, 2, 2, 0,    -1,-1,-1, 1, 1, 0,
00453      2              -1,-1,-1, 1, 1, 2,    -1,-1, 1, 2, 2, 2,
00454      3              -3,-1, 3, 0, 0, 0,     4,-1,-4, 0, 0, 0,
00455      4              -3, 2, 4, 0, 0, 0,     2, 2,-3, 0, 0, 0,
00456      5              -3,-1, 1, 0, 0, 0,    -1,-4, 2, 0, 0, 0,
00457      6               9,-1, 2, 0, 0, 0,    -1, 2, 8, 0, 0, 0,
00458 #else
00459       DATA  NOPIK / -1,-1, 1, 2, 0, 0,     2, 2, 2,-1, 0, 0,  
00460      1              -1,-1, 1, 2, 2, 0,    -1,-1,-1, 1, 1, 0,  
00461      2              -1,-1,-1, 1, 1, 2,    -1,-1, 1, 2, 2, 2, 
00462      3              -3,-1, 3, 0, 0, 0,    -4,-1, 4, 0, 0, 0,  
00463      4              -3, 2,-4, 0, 0, 0,     2, 2,-3, 0, 0, 0,  
00464      5              -3,-1, 1, 0, 0, 0,    -1, 4, 2, 0, 0, 0,  
00465      6               9,-1, 2, 0, 0, 0,    -1, 2, 8, 0, 0, 0,
00466 #endif
00467 #if defined (CLEO)
00468 C AJWMOD fix sign bug, 2/22/99
00469      7              -3,-4, 0, 0, 0, 0                         /
00470 #else
00471      7              -3, 4, 0, 0, 0, 0                         /
00472 #endif
00473 * LIST OF BRANCHING RATIOS
00474       NCHAN = NMODE + 7
00475       DO 1 I = 1,30
00476       IF (I.LE.NCHAN) THEN
00477         JLIST(I) = I
00478 #if defined (CePeCe)
00479         IF(I.EQ. 1) GAMPRT(I) = 1.0000
00480         IF(I.EQ. 2) GAMPRT(I) = 1.0000
00481         IF(I.EQ. 3) GAMPRT(I) = 1.0000
00482         IF(I.EQ. 4) GAMPRT(I) = 1.0000
00483         IF(I.EQ. 5) GAMPRT(I) = 1.0000
00484         IF(I.EQ. 6) GAMPRT(I) = 1.0000
00485         IF(I.EQ. 7) GAMPRT(I) = 1.0000
00486         IF(I.EQ. 8) GAMPRT(I) = 1.0000
00487         IF(I.EQ. 9) GAMPRT(I) = 1.0000
00488         IF(I.EQ.10) GAMPRT(I) = 1.0000
00489         IF(I.EQ.11) GAMPRT(I) = 1.0000
00490         IF(I.EQ.12) GAMPRT(I) = 1.0000
00491         IF(I.EQ.13) GAMPRT(I) = 1.0000
00492         IF(I.EQ.14) GAMPRT(I) = 1.0000
00493         IF(I.EQ.15) GAMPRT(I) = 1.0000
00494         IF(I.EQ.16) GAMPRT(I) = 1.0000
00495         IF(I.EQ.17) GAMPRT(I) = 1.0000
00496         IF(I.EQ.18) GAMPRT(I) = 1.0000
00497         IF(I.EQ.19) GAMPRT(I) = 1.0000
00498         IF(I.EQ.20) GAMPRT(I) = 1.0000
00499         IF(I.EQ.21) GAMPRT(I) = 1.0000
00500         IF(I.EQ.22) GAMPRT(I) = 1.0000
00501 #elif defined (CLEO)
00502         IF(I.EQ. 1) GAMPRT(I) =0.1800 
00503         IF(I.EQ. 2) GAMPRT(I) =0.1751 
00504         IF(I.EQ. 3) GAMPRT(I) =0.1110 
00505         IF(I.EQ. 4) GAMPRT(I) =0.2515 
00506         IF(I.EQ. 5) GAMPRT(I) =0.1790 
00507         IF(I.EQ. 6) GAMPRT(I) =0.0071 
00508         IF(I.EQ. 7) GAMPRT(I) =0.0134
00509         IF(I.EQ. 8) GAMPRT(I) =0.0450
00510         IF(I.EQ. 9) GAMPRT(I) =0.0100
00511         IF(I.EQ.10) GAMPRT(I) =0.0009
00512         IF(I.EQ.11) GAMPRT(I) =0.0004 
00513         IF(I.EQ.12) GAMPRT(I) =0.0003 
00514         IF(I.EQ.13) GAMPRT(I) =0.0005 
00515         IF(I.EQ.14) GAMPRT(I) =0.0015 
00516         IF(I.EQ.15) GAMPRT(I) =0.0015 
00517         IF(I.EQ.16) GAMPRT(I) =0.0015 
00518         IF(I.EQ.17) GAMPRT(I) =0.0005
00519         IF(I.EQ.18) GAMPRT(I) =0.0050
00520         IF(I.EQ.19) GAMPRT(I) =0.0055
00521         IF(I.EQ.20) GAMPRT(I) =0.0017 
00522         IF(I.EQ.21) GAMPRT(I) =0.0013 
00523         IF(I.EQ.22) GAMPRT(I) =0.0010 
00524 #elif defined (ALEPH)
00525         IF(I.EQ. 1) GAMPRT(I) = 1.0000
00526         IF(I.EQ. 2) GAMPRT(I) =  .9732
00527         IF(I.EQ. 3) GAMPRT(I) =  .6217
00528         IF(I.EQ. 4) GAMPRT(I) = 1.4221
00529         IF(I.EQ. 5) GAMPRT(I) = 1.0180
00530         IF(I.EQ. 6) GAMPRT(I) =  .0405
00531         IF(I.EQ. 7) GAMPRT(I) =  .0781
00532         IF(I.EQ. 8) GAMPRT(I) =  .2414
00533         IF(I.EQ. 9) GAMPRT(I) =  .0601
00534         IF(I.EQ.10) GAMPRT(I) =  .0281
00535         IF(I.EQ.11) GAMPRT(I) =  .0045
00536         IF(I.EQ.12) GAMPRT(I) =  .0010
00537         IF(I.EQ.13) GAMPRT(I) =  .0062
00538         IF(I.EQ.14) GAMPRT(I) =  .0096
00539         IF(I.EQ.15) GAMPRT(I) =  .0169
00540         IF(I.EQ.16) GAMPRT(I) =  .0056
00541         IF(I.EQ.17) GAMPRT(I) =  .0045
00542         IF(I.EQ.18) GAMPRT(I) =  .0219
00543         IF(I.EQ.19) GAMPRT(I) =  .0180
00544         IF(I.EQ.20) GAMPRT(I) =  .0096
00545         IF(I.EQ.21) GAMPRT(I) =  .0088
00546         IF(I.EQ.22) GAMPRT(I) =  .0146
00547 #else
00548 #endif
00549         IF(I.EQ. 1) OLDNAMES(I)='  TAU-  -->   E-               '
00550         IF(I.EQ. 2) OLDNAMES(I)='  TAU-  -->  MU-               '
00551         IF(I.EQ. 3) OLDNAMES(I)='  TAU-  -->  PI-               '
00552         IF(I.EQ. 4) OLDNAMES(I)='  TAU-  -->  PI-, PI0          '
00553         IF(I.EQ. 5) OLDNAMES(I)='  TAU-  -->  A1- (two subch)   '
00554         IF(I.EQ. 6) OLDNAMES(I)='  TAU-  -->   K-               '
00555         IF(I.EQ. 7) OLDNAMES(I)='  TAU-  -->  K*- (two subch)   '
00556         IF(I.EQ. 8) NAMES(I-7)='  TAU-  --> 2PI-,  PI0,  PI+   '
00557         IF(I.EQ. 9) NAMES(I-7)='  TAU-  --> 3PI0,        PI-   '
00558         IF(I.EQ.10) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 2PI0   '
00559         IF(I.EQ.11) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,        '
00560         IF(I.EQ.12) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,  PI0   '
00561         IF(I.EQ.13) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 3PI0   '
00562         IF(I.EQ.14) NAMES(I-7)='  TAU-  -->  K-, PI-,  K+      '
00563         IF(I.EQ.15) NAMES(I-7)='  TAU-  -->  K0, PI-, K0B      '
00564 #if defined (ALEPH)
00565         IF(I.EQ.16) NAMES(I-7)='  TAU-  -->  K-  PI0   K0      '
00566 #else
00567         IF(I.EQ.16) NAMES(I-7)='  TAU-  -->  K-,  K0, PI0      '
00568 #endif
00569         IF(I.EQ.17) NAMES(I-7)='  TAU-  --> PI0  PI0   K-      '
00570         IF(I.EQ.18) NAMES(I-7)='  TAU-  -->  K-  PI-  PI+      '
00571         IF(I.EQ.19) NAMES(I-7)='  TAU-  --> PI-  K0B  PI0      '
00572         IF(I.EQ.20) NAMES(I-7)='  TAU-  --> ETA  PI-  PI0      '
00573         IF(I.EQ.21) NAMES(I-7)='  TAU-  --> PI-  PI0  GAM      '
00574         IF(I.EQ.22) NAMES(I-7)='  TAU-  -->  K-  K0            '
00575       ELSE
00576         JLIST(I) = 0
00577         GAMPRT(I) = 0.
00578       ENDIF
00579    1  CONTINUE
00580       DO I=1,NMODE
00581         MULPIK(I)=NPIK(I)
00582         DO J=1,MULPIK(I)
00583          IDFFIN(J,I)=NOPIK(J,I)
00584         ENDDO
00585       ENDDO
00586 *
00587 *
00588 * --- COEFFICIENTS TO FIX RATIO OF:
00589 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00590 * --- PROBABILITY OF K0 TO BE KS
00591 * --- PROBABILITY OF K0B TO BE KS
00592 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00593 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00594 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00595 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00596       BRA1=0.5
00597       BRK0=0.5
00598       BRK0B=0.5
00599       BRKS=0.6667
00600 *
00601 
00602       GFERMI = 1.16637E-5
00603       CCABIB = 0.975
00604       GV     = 1.0
00605       GA     =-1.0
00606 
00607 
00608 
00609 * ZW 13.04.89 HERE WAS AN ERROR
00610       SCABIB = SQRT(1.-CCABIB**2)
00611       PI =4.*ATAN(1.)
00612       GAMEL  = GFERMI**2*AMTAU**5/(192*PI**3)
00613 *
00614 *      CALL DEXAY(-1,pol1)
00615 *
00616       RETURN
00617       END
00618       FUNCTION DCDMAS(IDENT)
00619       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00620      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00621      *                 ,AMK,AMKZ,AMKST,GAMKST
00622 *
00623       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00624      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00625      *                 ,AMK,AMKZ,AMKST,GAMKST
00626       IF      (IDENT.EQ. 1) THEN
00627         APKMAS=AMPI
00628       ELSEIF  (IDENT.EQ.-1) THEN
00629         APKMAS=AMPI
00630       ELSEIF  (IDENT.EQ. 2) THEN
00631         APKMAS=AMPIZ
00632       ELSEIF  (IDENT.EQ.-2) THEN
00633         APKMAS=AMPIZ
00634       ELSEIF  (IDENT.EQ. 3) THEN
00635         APKMAS=AMK
00636       ELSEIF  (IDENT.EQ.-3) THEN
00637         APKMAS=AMK
00638       ELSEIF  (IDENT.EQ. 4) THEN
00639         APKMAS=AMKZ
00640       ELSEIF  (IDENT.EQ.-4) THEN
00641         APKMAS=AMKZ
00642       ELSEIF  (IDENT.EQ. 8) THEN
00643         APKMAS=0.0001
00644       ELSEIF  (IDENT.EQ.-8) THEN
00645         APKMAS=0.0001
00646       ELSEIF  (IDENT.EQ. 9) THEN
00647         APKMAS=0.5488
00648       ELSEIF  (IDENT.EQ.-9) THEN
00649         APKMAS=0.5488
00650       ELSE
00651         PRINT *, 'STOP IN APKMAS, WRONG IDENT=',IDENT
00652         STOP
00653       ENDIF
00654       DCDMAS=APKMAS
00655       END
00656       FUNCTION LUNPIK(ID,ISGN)
00657       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00658       REAL*4            BRA1,BRK0,BRK0B,BRKS
00659       REAL*4 XIO(1)
00660       IDENT=ID*ISGN
00661 #if defined (ALEPH)
00662       IF      (IDENT.EQ. 1) THEN
00663         IPKDEF= 211
00664       ELSEIF  (IDENT.EQ.-1) THEN
00665         IPKDEF=-211
00666       ELSEIF  (IDENT.EQ. 2) THEN
00667         IPKDEF= 111
00668       ELSEIF  (IDENT.EQ.-2) THEN
00669         IPKDEF= 111
00670       ELSEIF  (IDENT.EQ. 3) THEN
00671         IPKDEF= 321
00672       ELSEIF  (IDENT.EQ.-3) THEN
00673         IPKDEF=-321
00674 #else
00675       IF      (IDENT.EQ. 1) THEN
00676         IPKDEF=-211
00677       ELSEIF  (IDENT.EQ.-1) THEN
00678         IPKDEF= 211
00679       ELSEIF  (IDENT.EQ. 2) THEN
00680         IPKDEF=111
00681       ELSEIF  (IDENT.EQ.-2) THEN
00682         IPKDEF=111
00683       ELSEIF  (IDENT.EQ. 3) THEN
00684         IPKDEF=-321
00685       ELSEIF  (IDENT.EQ.-3) THEN
00686         IPKDEF= 321
00687 #endif
00688       ELSEIF  (IDENT.EQ. 4) THEN
00689 *
00690 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00691         CALL RANMAR(XIO,1)
00692         IF (XIO(1).GT.BRK0) THEN
00693           IPKDEF= 130
00694         ELSE
00695           IPKDEF= 310
00696         ENDIF
00697       ELSEIF  (IDENT.EQ.-4) THEN
00698 *
00699 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00700         CALL RANMAR(XIO,1)
00701         IF (XIO(1).GT.BRK0B) THEN
00702           IPKDEF= 130
00703         ELSE
00704           IPKDEF= 310
00705         ENDIF
00706       ELSEIF  (IDENT.EQ. 8) THEN
00707         IPKDEF= 22
00708       ELSEIF  (IDENT.EQ.-8) THEN
00709         IPKDEF= 22
00710       ELSEIF  (IDENT.EQ. 9) THEN
00711         IPKDEF= 221
00712       ELSEIF  (IDENT.EQ.-9) THEN
00713         IPKDEF= 221
00714       ELSE
00715         PRINT *, 'STOP IN IPKDEF, WRONG IDENT=',IDENT
00716         STOP
00717       ENDIF
00718       LUNPIK=IPKDEF
00719       END
00720 
00721 
00722 #if defined (CLEO)
00723 
00724       SUBROUTINE TAURDF(KTO)
00725 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
00726 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
00727 C CONTENTS
00728       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00729       REAL*4            BRA1,BRK0,BRK0B,BRKS
00730       COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00731       IF (KTO.EQ.1) THEN
00732 C     ==================
00733 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00734       BRA1 = PKORB(4,1)
00735       BRKS = PKORB(4,3)
00736       BRK0  = PKORB(4,5)
00737       BRK0B  = PKORB(4,6)
00738       ELSE
00739 C     ====
00740 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00741       BRA1 = PKORB(4,2)
00742       BRKS = PKORB(4,4)
00743       BRK0  = PKORB(4,5)
00744       BRK0B  = PKORB(4,6)
00745       ENDIF
00746 C     =====
00747       END
00748 #else
00749 
00750       SUBROUTINE TAURDF(KTO)
00751 * THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
00752 * IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
00753 * CONTENTS
00754       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00755       REAL*4            BRA1,BRK0,BRK0B,BRKS
00756       COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00757       IF (KTO.EQ.1) THEN
00758 *     ==================
00759 * LIST OF BRANCHING RATIOS
00760       NCHAN = 19
00761       DO 1 I = 1,30
00762       IF (I.LE.NCHAN) THEN
00763         JLIST(I) = I
00764         IF(I.EQ. 1) GAMPRT(I) = .0000
00765         IF(I.EQ. 2) GAMPRT(I) = .0000
00766         IF(I.EQ. 3) GAMPRT(I) = .0000
00767         IF(I.EQ. 4) GAMPRT(I) = .0000
00768         IF(I.EQ. 5) GAMPRT(I) = .0000
00769         IF(I.EQ. 6) GAMPRT(I) = .0000
00770         IF(I.EQ. 7) GAMPRT(I) = .0000
00771         IF(I.EQ. 8) GAMPRT(I) = 1.0000
00772         IF(I.EQ. 9) GAMPRT(I) = 1.0000
00773         IF(I.EQ.10) GAMPRT(I) = 1.0000
00774         IF(I.EQ.11) GAMPRT(I) = 1.0000
00775         IF(I.EQ.12) GAMPRT(I) = 1.0000
00776         IF(I.EQ.13) GAMPRT(I) = 1.0000
00777         IF(I.EQ.14) GAMPRT(I) = 1.0000
00778         IF(I.EQ.15) GAMPRT(I) = 1.0000
00779         IF(I.EQ.16) GAMPRT(I) = 1.0000
00780         IF(I.EQ.17) GAMPRT(I) = 1.0000
00781         IF(I.EQ.18) GAMPRT(I) = 1.0000
00782         IF(I.EQ.19) GAMPRT(I) = 1.0000
00783       ELSE
00784         JLIST(I) = 0
00785         GAMPRT(I) = 0.
00786       ENDIF
00787    1  CONTINUE
00788 * --- COEFFICIENTS TO FIX RATIO OF:
00789 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00790 * --- PROBABILITY OF K0 TO BE KS
00791 * --- PROBABILITY OF K0B TO BE KS
00792 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00793 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00794 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00795 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00796       BRA1=0.5
00797       BRK0=0.5
00798       BRK0B=0.5
00799       BRKS=0.6667
00800       ELSE
00801 *     ====
00802 * LIST OF BRANCHING RATIOS
00803       NCHAN = 19
00804       DO 2 I = 1,30
00805       IF (I.LE.NCHAN) THEN
00806         JLIST(I) = I
00807         IF(I.EQ. 1) GAMPRT(I) = .0000
00808         IF(I.EQ. 2) GAMPRT(I) = .0000
00809         IF(I.EQ. 3) GAMPRT(I) = .0000
00810         IF(I.EQ. 4) GAMPRT(I) = .0000
00811         IF(I.EQ. 5) GAMPRT(I) = .0000
00812         IF(I.EQ. 6) GAMPRT(I) = .0000
00813         IF(I.EQ. 7) GAMPRT(I) = .0000
00814         IF(I.EQ. 8) GAMPRT(I) = 1.0000
00815         IF(I.EQ. 9) GAMPRT(I) = 1.0000
00816         IF(I.EQ.10) GAMPRT(I) = 1.0000
00817         IF(I.EQ.11) GAMPRT(I) = 1.0000
00818         IF(I.EQ.12) GAMPRT(I) = 1.0000
00819         IF(I.EQ.13) GAMPRT(I) = 1.0000
00820         IF(I.EQ.14) GAMPRT(I) = 1.0000
00821         IF(I.EQ.15) GAMPRT(I) = 1.0000
00822         IF(I.EQ.16) GAMPRT(I) = 1.0000
00823         IF(I.EQ.17) GAMPRT(I) = 1.0000
00824         IF(I.EQ.18) GAMPRT(I) = 1.0000
00825         IF(I.EQ.19) GAMPRT(I) = 1.0000
00826       ELSE
00827         JLIST(I) = 0
00828         GAMPRT(I) = 0.
00829       ENDIF
00830    2  CONTINUE
00831 * --- COEFFICIENTS TO FIX RATIO OF:
00832 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00833 * --- PROBABILITY OF K0 TO BE KS
00834 * --- PROBABILITY OF K0B TO BE KS
00835 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00836 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00837 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00838 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00839       BRA1=0.5
00840       BRK0=0.5
00841       BRK0B=0.5
00842       BRKS=0.6667
00843       ENDIF
00844 *     =====
00845       END
00846 #endif
00847 
00848       SUBROUTINE INIPHY(XK00)
00849 * ----------------------------------------------------------------------
00850 *     INITIALISATION OF PARAMETERS
00851 *     USED IN QED and/or GSW ROUTINES
00852 * ----------------------------------------------------------------------
00853       COMMON / QEDPRM /ALFINV,ALFPI,XK0
00854       REAL*8           ALFINV,ALFPI,XK0
00855       REAL*8 PI8,XK00
00856 *
00857       PI8    = 4.D0*DATAN(1.D0)
00858       ALFINV = 137.03604D0
00859       ALFPI  = 1D0/(ALFINV*PI8)
00860       XK0=XK00
00861       END
00862 
00863       SUBROUTINE INIMAS
00864 C ----------------------------------------------------------------------
00865 C     INITIALISATION OF MASSES
00866 C
00867 C     called by : KORALZ
00868 C ----------------------------------------------------------------------
00869       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00870      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00871      *                 ,AMK,AMKZ,AMKST,GAMKST
00872 *
00873       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00874      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00875      *                 ,AMK,AMKZ,AMKST,GAMKST
00876 C
00877 C IN-COMING / OUT-GOING  FERMION MASSES
00878       AMTAU  = 1.7842
00879 C --- let us update tau mass ...
00880       AMTAU  = 1.777
00881       AMNUTA = 0.010
00882       AMEL   = 0.0005111
00883       AMNUE  = 0.0
00884       AMMU   = 0.105659 
00885       AMNUMU = 0.0
00886 *
00887 * MASSES USED IN TAU DECAYS
00888 #if defined (CePeCe)
00889       AMPIZ  = 0.134964
00890       AMPI   = 0.139568
00891       AMRO   = 0.773
00892       GAMRO  = 0.145
00893 *C    GAMRO  = 0.666
00894       AMA1   = 1.251
00895       GAMA1  = 0.599
00896       AMK    = 0.493667
00897       AMKZ   = 0.49772
00898       AMKST  = 0.8921
00899       GAMKST = 0.0513
00900 #elif defined (CLEO)
00901       AMPIZ  = 0.134964
00902       AMPI   = 0.139568
00903       AMRO   = 0.773
00904       GAMRO  = 0.145
00905 *C    GAMRO  = 0.666
00906       AMA1   = 1.251
00907       GAMA1  = 0.599
00908       AMK    = 0.493667
00909       AMKZ   = 0.49772
00910       AMKST  = 0.8921
00911       GAMKST = 0.0513
00912 C
00913 C
00914 C IN-COMING / OUT-GOING  FERMION MASSES
00915 !!      AMNUTA = PKORB(1,2)
00916 !!      AMNUE  = PKORB(1,4)
00917 !!      AMNUMU = PKORB(1,6)
00918 C
00919 C MASSES USED IN TAU DECAYS  Cleo settings
00920 !!      AMPIZ  = PKORB(1,7)
00921 !!      AMPI   = PKORB(1,8)
00922 !!      AMRO   = PKORB(1,9)
00923 !!      GAMRO  = PKORB(2,9)
00924       AMA1   = 1.275   !! PKORB(1,10)
00925       GAMA1  = 0.615   !! PKORB(2,10)
00926 !!      AMK    = PKORB(1,11)
00927 !!      AMKZ   = PKORB(1,12)
00928 !!      AMKST  = PKORB(1,13)
00929 !!      GAMKST = PKORB(2,13)
00930 C
00931 #elif defined (ALEPH)
00932       AMPIZ  = 0.134964
00933       AMPI   = 0.139568
00934       AMRO   = 0.7714
00935       GAMRO  = 0.153
00936 cam   AMRO   = 0.773
00937 cam   GAMRO  = 0.145
00938       AMA1   = 1.251! PMAS(LUCOMP(ia1),1)       ! AMA1   = 1.251
00939       GAMA1  = 0.599! PMAS(LUCOMP(ia1),2)       ! GAMA1  = 0.599
00940       print *,'INIMAS a1 mass= ',ama1,gama1
00941       AMK    = 0.493667
00942       AMKZ   = 0.49772
00943       AMKST  = 0.8921
00944       GAMKST = 0.0513
00945 #else
00946 #endif
00947 
00948       RETURN
00949       END
00950       SUBROUTINE TAUFIL
00951 C     *****************
00952 C SUBSITUTE OF tau PRODUCTION GENERATOR
00953 C
00954       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00955      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00956      *                 ,AMK,AMKZ,AMKST,GAMKST
00957 C
00958       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00959      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00960      *                 ,AMK,AMKZ,AMKST,GAMKST
00961       COMMON / IDFC  / IDFF
00962 C positions of taus in the LUND common block
00963 C it will be used by TAUOLA output routines.
00964       COMMON /TAUPOS / NPA,NPB
00965       DIMENSION XPB1(4),XPB2(4),AQF1(4),AQF2(4)
00966 C
00967 C --- DEFINING DUMMY EVENTS MOMENTA
00968       DO 4 K=1,3
00969         XPB1(K)=0.0
00970         XPB2(K)=0.0
00971         AQF1(K)=0.0
00972         AQF2(K)=0.0
00973   4   CONTINUE
00974         AQF1(4)=AMTAU
00975         AQF2(4)=AMTAU
00976 C --- TAU MOMENTA
00977       CALL TRALO4(1,AQF1,AQF1,AM)
00978       CALL TRALO4(2,AQF2,AQF2,AM)
00979 C --- BEAMS MOMENTA AND IDENTIFIERS
00980         KFB1= 11*IDFF/IABS(IDFF)
00981         KFB2=-11*IDFF/IABS(IDFF)
00982         XPB1(4)= AQF1(4)
00983         XPB1(3)= AQF1(4)
00984         IF(AQF1(3).NE.0.0)
00985      $  XPB1(3)= AQF1(4)*AQF1(3)/ABS(AQF1(3))
00986         XPB2(4)= AQF2(4)
00987         XPB2(3)=-AQF2(4)
00988         IF(AQF2(3).NE.0.0)
00989      $  XPB2(3)= AQF2(4)*AQF2(3)/ABS(AQF2(3))
00990 C --- Position of first and second tau in LUND common
00991       NPA=3
00992       NPB=4
00993 C --- FILL TO LUND COMMON
00994       CALL FILHEP(  1,3, KFB1,0,0,0,0,XPB1, AMEL,.TRUE.)
00995       CALL FILHEP(  2,3, KFB2,0,0,0,0,XPB2, AMEL,.TRUE.)
00996       CALL FILHEP(NPA,1, IDFF,1,2,0,0,AQF1,AMTAU,.TRUE.)
00997       CALL FILHEP(NPB,1,-IDFF,1,2,0,0,AQF2,AMTAU,.TRUE.)
00998       END
00999       SUBROUTINE TRALO4(KTO,P,Q,AM)
01000 C     **************************
01001 C SUBSITUTE OF TRALO4
01002       REAL  P(4),Q(4)
01003 C
01004       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01005      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01006      *                 ,AMK,AMKZ,AMKST,GAMKST
01007 C
01008       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01009      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01010      *                 ,AMK,AMKZ,AMKST,GAMKST
01011       COMMON /PTAU/ PTAU
01012       AM=AMAS4(P)
01013       ETAU=SQRT(PTAU**2+AMTAU**2)
01014       EXE=(ETAU+PTAU)/AMTAU
01015       IF(KTO.EQ.2) EXE=(ETAU-PTAU)/AMTAU
01016       CALL BOSTR3(EXE,P,Q)
01017 C ======================================================================
01018 C         END OF THE TEST JOB
01019 C ======================================================================
01020       END
01021       SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
01022 C ----------------------------------------------------------------------
01023 C this subroutine fills one entry into the HEPEVT common
01024 C and updates the information for affected mother entries
01025 C
01026 C written by Martin W. Gruenewald (91/01/28)
01027 C
01028 C     called by : ZTOHEP,BTOHEP,DWLUxy
01029 C ----------------------------------------------------------------------
01030 C
01031 #include "../../include/HEPEVT.h"
01032 C      PARAMETER (NMXHEP=2000)
01033 C      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
01034 C     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
01035 C      SAVE  /HEPEVT/
01036 C      COMMON/PHOQED/QEDRAD(NMXHEP)
01037 C      LOGICAL QEDRAD
01038 C      SAVE /PHOQED/
01039       LOGICAL PHFLAG
01040 C
01041       REAL*4  P4(4)
01042 C
01043 C check address mode
01044       IF (N.EQ.0) THEN
01045 C
01046 C append mode
01047         IHEP=NHEP+1
01048       ELSE IF (N.GT.0) THEN
01049 C
01050 C absolute position
01051         IHEP=N
01052       ELSE
01053 C
01054 C relative position
01055         IHEP=NHEP+N
01056       END IF
01057 C
01058 C check on IHEP
01059       IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
01060 C
01061 C add entry
01062       NHEP=IHEP
01063       ISTHEP(IHEP)=IST
01064       IDHEP(IHEP)=ID
01065       JMOHEP(1,IHEP)=JMO1
01066       IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
01067       JMOHEP(2,IHEP)=JMO2
01068       IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
01069       JDAHEP(1,IHEP)=JDA1
01070       JDAHEP(2,IHEP)=JDA2
01071 C
01072       DO I=1,4
01073         PHEP(I,IHEP)=P4(I)
01074 C
01075 C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
01076         VHEP(I,IHEP)=0.0
01077       END DO
01078       PHEP(5,IHEP)=PINV
01079 C FLAG FOR PHOTOS...
01080       QEDRAD(IHEP)=PHFLAG
01081 C
01082 C update process:
01083       DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
01084         IF(IP.GT.0)THEN
01085 C
01086 C if there is a daughter at IHEP, mother entry at IP has decayed
01087           IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
01088 C
01089 C and daughter pointers of mother entry must be updated
01090           IF(JDAHEP(1,IP).EQ.0)THEN
01091             JDAHEP(1,IP)=IHEP
01092             JDAHEP(2,IP)=IHEP
01093           ELSE
01094             JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
01095           END IF
01096         END IF
01097       END DO
01098 C
01099       RETURN
01100       END
01101 #if defined (ALEPH) 
01102       FUNCTION DILOGY(X)
01103 C     *****************
01104       IMPLICIT REAL*8(A-H,O-Z)
01105 CERN      C304      VERSION    29/07/71 DILOG        59                C
01106       Z=-1.64493406684822
01107       IF(X .LT.-1.0) GO TO 1
01108       IF(X .LE. 0.5) GO TO 2
01109       IF(X .EQ. 1.0) GO TO 3
01110       IF(X .LE. 2.0) GO TO 4
01111       Z=3.2898681336964
01112     1 T=1.0/X
01113       S=-0.5
01114       Z=Z-0.5* LOG(ABS(X))**2
01115       GO TO 5
01116     2 T=X
01117       S=0.5
01118       Z=0.
01119       GO TO 5
01120     3 DILOGY=1.64493406684822
01121       RETURN
01122     4 T=1.0-X
01123       S=-0.5
01124       Z=1.64493406684822 - LOG(X)* LOG(ABS(T))
01125     5 Y=2.66666666666666 *T+0.66666666666666
01126       B=      0.00000 00000 00001
01127       A=Y*B  +0.00000 00000 00004
01128       B=Y*A-B+0.00000 00000 00011
01129       A=Y*B-A+0.00000 00000 00037
01130       B=Y*A-B+0.00000 00000 00121
01131       A=Y*B-A+0.00000 00000 00398
01132       B=Y*A-B+0.00000 00000 01312
01133       A=Y*B-A+0.00000 00000 04342
01134       B=Y*A-B+0.00000 00000 14437
01135       A=Y*B-A+0.00000 00000 48274
01136       B=Y*A-B+0.00000 00001 62421
01137       A=Y*B-A+0.00000 00005 50291
01138       B=Y*A-B+0.00000 00018 79117
01139       A=Y*B-A+0.00000 00064 74338
01140       B=Y*A-B+0.00000 00225 36705
01141       A=Y*B-A+0.00000 00793 87055
01142       B=Y*A-B+0.00000 02835 75385
01143       A=Y*B-A+0.00000 10299 04264
01144       B=Y*A-B+0.00000 38163 29463
01145       A=Y*B-A+0.00001 44963 00557
01146       B=Y*A-B+0.00005 68178 22718
01147       A=Y*B-A+0.00023 20021 96094
01148       B=Y*A-B+0.00100 16274 96164
01149       A=Y*B-A+0.00468 63619 59447
01150       B=Y*A-B+0.02487 93229 24228
01151       A=Y*B-A+0.16607 30329 27855
01152       A=Y*A-B+1.93506 43008 6996
01153       DILOGY=S*T*(A-B)+Z
01154       RETURN
01155 C=======================================================================
01156 C===================END OF CPC PART ====================================
01157 C=======================================================================
01158       END
01159 #endif
Generated on Sun Oct 20 20:24:10 2013 for C++InterfacetoTauola by  doxygen 1.6.3