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