tauola-F/standalone-F/taumain.f

00001 
00002 
00003       PROGRAM TAUDEM
00004 C     **************
00005 C NOTE THAT THE ROUTINES ARE NOT LIKE IN CPC DECK THIS IS HISTORICAL !!
00006 C=======================================================================
00007 C====================== DECTES    : TEST OF TAU DECAY LIBRARY===========
00008 C====================== KTORY = 1 : INTERFACE OF KORAL-Z TYPE ==========
00009 C====================== KTORY = 2 : INTERFACE OF KORAL-B TYPE =========
00010 C=======================================================================
00011 C     COMMON  /PAWC/ BLAN(10000)
00012       COMMON  / / BLAN(10000)
00013       CHARACTER*7 DNAME
00014       COMMON / INOUT / INUT,IOUT
00015       DNAME='KKPI'
00016 !      CALL GLIMIT(20000)
00017 !      CALL GOUTPU(16)
00018       INUT=5
00019       IOUT=6
00020       OPEN(IOUT,FILE="./tauola.output")
00021        OPEN(INUT,FILE="./dane.dat")
00022       KTORY=1
00023       CALL DECTES(KTORY)
00024       KTORY=2
00025       CALL DECTES(KTORY)
00026       END
00027       SUBROUTINE DECTES(KTORY)
00028 C     ************************
00029       REAL POL(4)
00030       DOUBLE PRECISION HH(4)
00031 C SWITCHES FOR TAUOLA;
00032       COMMON / JAKI   /  JAK1,JAK2,JAKP,JAKM,KTOM
00033       COMMON / IDFC  / IDFF
00034 C I/O UNITS  NUMBERS
00035       COMMON / INOUT /  INUT,IOUT
00036 C LUND TYPE IDENTIFIER FOR A1
00037       COMMON / IDPART / IA1
00038 C /PTAU/ IS USED IN ROUTINE TRALO4
00039       COMMON /PTAU/ PTAU
00040       COMMON / TAURAD / XK0DEC,ITDKRC
00041       REAL*8            XK0DEC
00042       COMMON /TESTA1/ KEYA1
00043 C special switch for tests of dGamma/dQ**2 in a1 decay
00044 C KEYA1=1 constant width of a1 and rho
00045 C KEYA1=2 free choice of rho propagator (defined in function FPIK)
00046 C         and free choice of a1 mass and width. function g(Q**2)
00047 C         (see formula 3.48 in Comp. Phys. Comm. 64 (1991) 275)
00048 C         hard coded both in Monte Carlo and in testing distribution.
00049 C KEYA1=3 function g(Q**2) hardcoded in the Monte Carlo
00050 C         (it is timy to calculate!), but appropriately adjusted in
00051 C         testing distribution.
00052 C-----------------------------------------------------------------------
00053 C          INITIALIZATION
00054 C-----------------------------------------------------------------------
00055 C======================================
00056       NINP=INUT
00057       NOUT=IOUT
00058  3000 FORMAT(A80)
00059  3001 FORMAT(8I2)
00060  3002 FORMAT(I10)
00061  3003 FORMAT(F10.0)
00062       IF (KTORY.EQ.1) THEN
00063       READ( NINP,3000) TESTIT
00064       WRITE(NOUT,3000) TESTIT
00065       READ( NINP,3001) KAT1,KAT2,KAT3,KAT4,KAT5,KAT6
00066       READ( NINP,3002) NEVT,JAK1,JAK2,ITDKRC
00067       READ( NINP,3003) PTAU,XK0DEC
00068       ENDIF
00069 C======================================
00070 C control output
00071       WRITE(NOUT,'(6A6/6I6)')
00072      $ 'KAT1','KAT2','KAT3','KAT4','KAT5','KAT6',
00073      $  KAT1 , KAT2 , KAT3 , KAT4 , KAT5 , KAT6
00074       WRITE(NOUT,'(4A12/4I12)')
00075      $  'NEVT','JAK1','JAK2','ITDKRC',
00076      $   NEVT,  JAK1 , JAK2 , ITDKRC
00077       WRITE(NOUT,'(2A12/2F12.6)')
00078      $ 'PTAU','XK0DEC',
00079      $  PTAU , XK0DEC
00080 C======================================
00081       JAK=0
00082 C      JAK1=5
00083 C      JAK2=5
00084 C LUND IDENTIFIER (FOR TAU+) -15
00085       IF (KTORY.EQ.1) THEN
00086         IDFF=-15
00087       ELSE
00088         IDFF= 15
00089       ENDIF
00090 C KTO=1 DENOTES TAU DEFINED BY IDFF (I.E. TAU+)
00091 C KTO=2 DENOTES THE OPPOSITE        (I.E. TAU-)
00092       KTO=2
00093       IF (KTO.NE.2) THEN
00094         PRINT *, 'for the sake of these tests KTO has to be 2'
00095         PRINT *, 'to change tau- to tau+ change IDFF from -15 to 15'
00096         STOP
00097       ENDIF
00098 C TAU POLARIZATION IN ITS RESTFRAME;
00099       POL(1)=0.
00100       POL(2)=0.
00101       POL(3)=.9
00102 C TAU MOMENTUM IN GEV;
00103 C      PTAU=CMSENE/2.D0
00104 C NUMBER OF EVENTS TO BE GENERATED;
00105       NEVTES=10
00106       NEVTES=NEVT
00107       PRINT *, 'NEVTES= ',NEVTES
00108       WRITE(IOUT,7011) KEYA1
00109 C
00110       IF (KTORY.EQ.1) THEN
00111          WRITE(IOUT,7001) JAK,IDFF,POL(3),PTAU
00112       ELSE
00113          WRITE(IOUT,7004) JAK,IDFF,POL(3),PTAU
00114       ENDIF
00115 C INITIALISATION OF TAU DECAY PACKAGE TAUOLA
00116 C ******************************************
00117         CALL INIMAS
00118         CALL INITDK
00119 
00120 
00121         CALL INIPHY(0.1D0)
00122       IF (KTORY.EQ.1) THEN
00123          CALL DEXAY(-1,POL)
00124       ELSE
00125          CALL DEKAY(-1,HH)
00126       ENDIF
00127 C-----------------------------------------------------------------------
00128 C          GENERATION
00129 C-----------------------------------------------------------------------
00130       NEV=0
00131       DO 300 IEV=1,NEVTES
00132       NEV=NEV+1
00133 C RESLU INITIALISE THE LUND RECORD
00134 
00135 
00136 
00137 
00138       CALL TAUFIL
00139 C DECAY....
00140       IF (KTORY.EQ.1) THEN
00141          CALL DEXAY(KTO,POL)
00142       ELSE
00143          CALL DEKAY(KTO,HH)
00144          CALL DEKAY(KTO+10,HH)
00145       ENDIF
00146       CALL LUHEPC(2)
00147       IF(IEV.LE.44) THEN
00148        WRITE(IOUT,7002) IEV
00149        IF (KTORY.NE.1) THEN
00150          WRITE(IOUT,7003) HH
00151        ENDIF
00152 C      CALL LULIST(11)
00153       CALL LULIST(2)
00154       ENDIF
00155       IPRI=MOD(NEV,1000)
00156       IF(IPRI.EQ.1) PRINT *, ' event no: ',NEV,' NEVTES: ',NEVTES
00157   300 CONTINUE
00158   301 CONTINUE
00159 C-----------------------------------------------------------------------
00160 C                     POSTGENERATION
00161 C-----------------------------------------------------------------------
00162       IF (KTORY.EQ.1) THEN
00163          CALL DEXAY(100,POL)
00164       ELSE
00165          CALL DEKAY(100,HH)
00166       ENDIF
00167       RETURN
00168  7001 FORMAT(//4(/1X,15(5H=====))
00169      $ /,' ',     19X,'  TEST OF RAD. CORR IN ELECTRON DECAY   ',9X,1H ,
00170      $ /,' ',     19X,'    TESTS OF TAU DECAY ROUTINES         ',9X,1H ,
00171      $ /,' ',     19X,'    INTERFACE OF THE KORAL-Z TYPE       ',9X,1H ,
00172      $  2(/,1X,15(5H=====)),
00173      $ /,5X ,'JAK   =',I7  ,'  KEY DEFINING DECAY TYPE         ',9X,1H ,
00174      $ /,5X ,'IDFF  =',I7  ,'  LUND IDENTIFIER FOR FIRST TAU   ',9X,1H ,
00175      $ /,5X ,'POL(3)=',F7.2,'  THIRD COMPONENT OF TAU POLARIZ. ',9X,1H ,
00176      $ /,5X ,'PTAU  =',F7.2,'  THIRD COMPONENT OF TAU MOM. GEV ',9X,1H ,
00177      $  2(/,1X,15(5H=====))/)
00178  7002 FORMAT(///1X, '===== EVENT NO.',I4,1X,5H=====)
00179  7003 FORMAT(5X,'POLARIMETRIC VECTOR: ',
00180      $       7X,'HH(1)',7X,'HH(2)',7X,'HH(3)',7X,'HH(4)',
00181      $ /,    5X,'                     ', 4(1X,F11.8)   )
00182  7004 FORMAT(//4(/1X,15(5H=====))
00183      $ /,'  ',     19X,'  TEST OF RAD. CORR IN ELECTRON DECAY  ',9X,1H ,
00184      $ /,'  ',     19X,'    TESTS OF TAU DECAY ROUTINES        ',9X,1H ,
00185      $ /,'  ',     19X,'    INTERFACE OF THE KORAL-B TYPE      ',9X,1H ,
00186      $  2(/,1X,15(5H=====)),
00187      $ /,5X ,'JAK   =',I7  ,'  KEY DEFINING DECAY TYPE         ',9X,1H ,
00188      $ /,5X ,'IDFF  =',I7  ,'  LUND IDENTIFIER FOR FIRST TAU   ',9X,1H ,
00189      $ /,5X ,'POL(3)=',F7.2,'  THIRD COMPONENT OF TAU POLARIZ. ',9X,1H ,
00190      $ /,5X ,'PTAU  =',F7.2,'  THIRD COMPONENT OF TAU MOM. GEV ',9X,1H ,
00191      $  2(/,1X,15(5H=====))/)
00192  7011 FORMAT(///1X, '===== TYPE OF CURRENT',I4,1X,5H=====)
00193       END
00194       SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
00195      $            AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
00196       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00197      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00198      *                 ,AMK,AMKZ,AMKST,GAMKST
00199 C
00200       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00201      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00202      *                 ,AMK,AMKZ,AMKST,GAMKST
00203 C
00204       AMROP=1.1
00205       GAMROP=0.36
00206       AMOM=.782
00207       GAMOM=0.0084
00208 C     XXXXA CORRESPOND TO S2 CHANNEL !
00209       IF(MNUM.EQ.0) THEN
00210        PROB1=0.5
00211        PROB2=0.5
00212        AMRX =AMA1
00213        GAMRX=GAMA1
00214        AMRA =AMRO
00215        GAMRA=GAMRO
00216        AMRB =AMRO
00217        GAMRB=GAMRO
00218       ELSEIF(MNUM.EQ.1) THEN
00219        PROB1=0.5
00220        PROB2=0.5
00221        AMRX =1.57
00222        GAMRX=0.9
00223        AMRB =AMKST
00224        GAMRB=GAMKST
00225        AMRA =AMRO
00226        GAMRA=GAMRO
00227       ELSEIF(MNUM.EQ.2) THEN
00228        PROB1=0.5
00229        PROB2=0.5
00230        AMRX =1.57
00231        GAMRX=0.9
00232        AMRB =AMKST
00233        GAMRB=GAMKST
00234        AMRA =AMRO
00235        GAMRA=GAMRO
00236       ELSEIF(MNUM.EQ.3) THEN
00237        PROB1=0.5
00238        PROB2=0.5
00239        AMRX =1.27
00240        GAMRX=0.3
00241        AMRA =AMKST
00242        GAMRA=GAMKST
00243        AMRB =AMKST
00244        GAMRB=GAMKST
00245       ELSEIF(MNUM.EQ.4) THEN
00246        PROB1=0.5
00247        PROB2=0.5
00248        AMRX =1.27
00249        GAMRX=0.3
00250        AMRA =AMKST
00251        GAMRA=GAMKST
00252        AMRB =AMKST
00253        GAMRB=GAMKST
00254       ELSEIF(MNUM.EQ.5) THEN
00255        PROB1=0.5
00256        PROB2=0.5
00257        AMRX =1.27
00258        GAMRX=0.3
00259        AMRA =AMKST
00260        GAMRA=GAMKST
00261        AMRB =AMRO
00262        GAMRB=GAMRO
00263       ELSEIF(MNUM.EQ.6) THEN
00264        PROB1=0.4
00265        PROB2=0.4
00266        AMRX =1.27
00267        GAMRX=0.3
00268        AMRA =AMRO
00269        GAMRA=GAMRO
00270        AMRB =AMKST
00271        GAMRB=GAMKST
00272       ELSEIF(MNUM.EQ.7) THEN
00273        PROB1=0.0
00274        PROB2=1.0
00275        AMRX =1.27
00276        GAMRX=0.9
00277        AMRA =AMRO
00278        GAMRA=GAMRO
00279        AMRB =AMRO
00280        GAMRB=GAMRO
00281       ELSEIF(MNUM.EQ.8) THEN
00282        PROB1=0.0
00283        PROB2=1.0
00284        AMRX =AMROP
00285        GAMRX=GAMROP
00286        AMRB =AMOM
00287        GAMRB=GAMOM
00288        AMRA =AMRO
00289        GAMRA=GAMRO
00290       ELSEIF(MNUM.EQ.101) THEN
00291        PROB1=.35
00292        PROB2=.35
00293        AMRX =1.2
00294        GAMRX=.46
00295        AMRB =AMOM
00296        GAMRB=GAMOM
00297        AMRA =AMOM
00298        GAMRA=GAMOM
00299       ELSEIF(MNUM.EQ.102) THEN
00300        PROB1=0.0
00301        PROB2=0.0
00302        AMRX =1.4
00303        GAMRX=.6
00304        AMRB =AMOM
00305        GAMRB=GAMOM
00306        AMRA =AMOM
00307        GAMRA=GAMOM
00308       ELSE
00309        PROB1=0.0
00310        PROB2=0.0
00311        AMRX =AMA1
00312        GAMRX=GAMA1
00313        AMRA =AMRO
00314        GAMRA=GAMRO
00315        AMRB =AMRO
00316        GAMRB=GAMRO
00317       ENDIF
00318 C
00319       IF    (RR.LE.PROB1) THEN
00320        ICHAN=1
00321       ELSEIF(RR.LE.(PROB1+PROB2)) THEN
00322        ICHAN=2
00323         AX   =AMRA
00324         GX   =GAMRA
00325         AMRA =AMRB
00326         GAMRA=GAMRB
00327         AMRB =AX
00328         GAMRB=GX
00329         PX   =PROB1
00330         PROB1=PROB2
00331         PROB2=PX
00332       ELSE
00333        ICHAN=3
00334       ENDIF
00335 C
00336       PROB3=1.0-PROB1-PROB2
00337       END
00338       SUBROUTINE INITDK
00339 * ----------------------------------------------------------------------
00340 *     INITIALISATION OF TAU DECAY PARAMETERS  and routines
00341 *
00342 *     called by : KORALZ
00343 * ----------------------------------------------------------------------
00344 
00345       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00346       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00347       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00348      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00349      *                 ,AMK,AMKZ,AMKST,GAMKST
00350 *
00351       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00352      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00353      *                 ,AMK,AMKZ,AMKST,GAMKST
00354       COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00355       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00356       REAL*4            BRA1,BRK0,BRK0B,BRKS
00357 
00358 
00359 
00360 
00361 
00362 
00363       PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
00364       COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00365      &                ,NAMES
00366       CHARACTER NAMES(NMODE)*31
00367 
00368       CHARACTER OLDNAMES(7)*31
00369       CHARACTER*80 bxINIT
00370       PARAMETER (
00371      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00372      $ )
00373       REAL*4 PI,POL1(4)
00374 *
00375 *
00376 * LIST OF BRANCHING RATIOS
00377 CAM normalised to e nu nutau channel
00378 CAM                  enu   munu   pinu  rhonu   A1nu   Knu    K*nu   pi
00379 CAM   DATA JLIST  /    1,     2,     3,     4,     5,     6,     7,
00380 *AM   DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
00381 *AM
00382 *AM  multipion decays
00383 *
00384 *    conventions of particles names
00385 *                 K-,P-,K+,  K0,P-,KB,  K-,P0,K0
00386 *                  3, 1,-3  , 4, 1,-4  , 3, 2, 4  ,
00387 *                 P0,P0,K-,  K-,P-,P+,  P-,KB,P0
00388 *                  2, 2, 3  , 3, 1,-1  , 1,-4, 2  ,
00389 *                 ET,P-,P0   P-,P0,GM
00390 *                  9, 1, 2  , 1, 2, 8
00391 *
00392 C
00393       DIMENSION NOPIK(6,NMODE),NPIK(NMODE)
00394 *AM   outgoing multiplicity and flavors of multi-pion /multi-K modes    
00395       DATA   NPIK  /                4,                    4,  
00396      1                              5,                    5,
00397      2                              6,                    6,
00398      3                              3,                    3,            
00399      4                              3,                    3,            
00400      5                              3,                    3,            
00401      6                              3,                    3,  
00402      7                              2                         /         
00403       DATA  NOPIK / -1,-1, 1, 2, 0, 0,     2, 2, 2,-1, 0, 0,  
00404      1              -1,-1, 1, 2, 2, 0,    -1,-1,-1, 1, 1, 0,  
00405      2              -1,-1,-1, 1, 1, 2,    -1,-1, 1, 2, 2, 2, 
00406      3              -3,-1, 3, 0, 0, 0,    -4,-1, 4, 0, 0, 0,  
00407      4              -3, 2,-4, 0, 0, 0,     2, 2,-3, 0, 0, 0,  
00408      5              -3,-1, 1, 0, 0, 0,    -1, 4, 2, 0, 0, 0,  
00409      6               9,-1, 2, 0, 0, 0,    -1, 2, 8, 0, 0, 0,
00410 C AJWMOD fix sign bug, 2/22/99
00411      7              -3,-4, 0, 0, 0, 0                         /
00412 * LIST OF BRANCHING RATIOS
00413       NCHAN = NMODE + 7
00414       DO 1 I = 1,30
00415       IF (I.LE.NCHAN) THEN
00416         JLIST(I) = I
00417         IF(I.EQ. 1) GAMPRT(I) =0.1800 
00418         IF(I.EQ. 2) GAMPRT(I) =0.1751 
00419         IF(I.EQ. 3) GAMPRT(I) =0.1110 
00420         IF(I.EQ. 4) GAMPRT(I) =0.2515 
00421         IF(I.EQ. 5) GAMPRT(I) =0.1790 
00422         IF(I.EQ. 6) GAMPRT(I) =0.0071 
00423         IF(I.EQ. 7) GAMPRT(I) =0.0134
00424         IF(I.EQ. 8) GAMPRT(I) =0.0450
00425         IF(I.EQ. 9) GAMPRT(I) =0.0100
00426         IF(I.EQ.10) GAMPRT(I) =0.0009
00427         IF(I.EQ.11) GAMPRT(I) =0.0004 
00428         IF(I.EQ.12) GAMPRT(I) =0.0003 
00429         IF(I.EQ.13) GAMPRT(I) =0.0005 
00430         IF(I.EQ.14) GAMPRT(I) =0.0015 
00431         IF(I.EQ.15) GAMPRT(I) =0.0015 
00432         IF(I.EQ.16) GAMPRT(I) =0.0015 
00433         IF(I.EQ.17) GAMPRT(I) =0.0005
00434         IF(I.EQ.18) GAMPRT(I) =0.0050
00435         IF(I.EQ.19) GAMPRT(I) =0.0055
00436         IF(I.EQ.20) GAMPRT(I) =0.0017 
00437         IF(I.EQ.21) GAMPRT(I) =0.0013 
00438         IF(I.EQ.22) GAMPRT(I) =0.0010 
00439         IF(I.EQ. 1) OLDNAMES(I)='  TAU-  -->   E-               '
00440         IF(I.EQ. 2) OLDNAMES(I)='  TAU-  -->  MU-               '
00441         IF(I.EQ. 3) OLDNAMES(I)='  TAU-  -->  PI-               '
00442         IF(I.EQ. 4) OLDNAMES(I)='  TAU-  -->  PI-, PI0          '
00443         IF(I.EQ. 5) OLDNAMES(I)='  TAU-  -->  A1- (two subch)   '
00444         IF(I.EQ. 6) OLDNAMES(I)='  TAU-  -->   K-               '
00445         IF(I.EQ. 7) OLDNAMES(I)='  TAU-  -->  K*- (two subch)   '
00446         IF(I.EQ. 8) NAMES(I-7)='  TAU-  --> 2PI-,  PI0,  PI+   '
00447         IF(I.EQ. 9) NAMES(I-7)='  TAU-  --> 3PI0,        PI-   '
00448         IF(I.EQ.10) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 2PI0   '
00449         IF(I.EQ.11) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,        '
00450         IF(I.EQ.12) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,  PI0   '
00451         IF(I.EQ.13) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 3PI0   '
00452         IF(I.EQ.14) NAMES(I-7)='  TAU-  -->  K-, PI-,  K+      '
00453         IF(I.EQ.15) NAMES(I-7)='  TAU-  -->  K0, PI-, K0B      '
00454         IF(I.EQ.16) NAMES(I-7)='  TAU-  -->  K-,  K0, PI0      '
00455         IF(I.EQ.17) NAMES(I-7)='  TAU-  --> PI0  PI0   K-      '
00456         IF(I.EQ.18) NAMES(I-7)='  TAU-  -->  K-  PI-  PI+      '
00457         IF(I.EQ.19) NAMES(I-7)='  TAU-  --> PI-  K0B  PI0      '
00458         IF(I.EQ.20) NAMES(I-7)='  TAU-  --> ETA  PI-  PI0      '
00459         IF(I.EQ.21) NAMES(I-7)='  TAU-  --> PI-  PI0  GAM      '
00460         IF(I.EQ.22) NAMES(I-7)='  TAU-  -->  K-  K0            '
00461       ELSE
00462         JLIST(I) = 0
00463         GAMPRT(I) = 0.
00464       ENDIF
00465    1  CONTINUE
00466       DO I=1,NMODE
00467         MULPIK(I)=NPIK(I)
00468         DO J=1,MULPIK(I)
00469          IDFFIN(J,I)=NOPIK(J,I)
00470         ENDDO
00471       ENDDO
00472 *
00473 *
00474 * --- COEFFICIENTS TO FIX RATIO OF:
00475 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00476 * --- PROBABILITY OF K0 TO BE KS
00477 * --- PROBABILITY OF K0B TO BE KS
00478 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00479 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00480 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00481 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00482       BRA1=0.5
00483       BRK0=0.5
00484       BRK0B=0.5
00485       BRKS=0.6667
00486 *
00487 
00488       GFERMI = 1.16637E-5
00489       CCABIB = 0.975
00490       GV     = 1.0
00491       GA     =-1.0
00492 
00493 
00494 
00495 * ZW 13.04.89 HERE WAS AN ERROR
00496       SCABIB = SQRT(1.-CCABIB**2)
00497       PI =4.*ATAN(1.)
00498       GAMEL  = GFERMI**2*AMTAU**5/(192*PI**3)
00499 *
00500 *      CALL DEXAY(-1,pol1)
00501 *
00502       RETURN
00503       END
00504       FUNCTION DCDMAS(IDENT)
00505       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00506      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00507      *                 ,AMK,AMKZ,AMKST,GAMKST
00508 *
00509       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00510      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00511      *                 ,AMK,AMKZ,AMKST,GAMKST
00512       IF      (IDENT.EQ. 1) THEN
00513         APKMAS=AMPI
00514       ELSEIF  (IDENT.EQ.-1) THEN
00515         APKMAS=AMPI
00516       ELSEIF  (IDENT.EQ. 2) THEN
00517         APKMAS=AMPIZ
00518       ELSEIF  (IDENT.EQ.-2) THEN
00519         APKMAS=AMPIZ
00520       ELSEIF  (IDENT.EQ. 3) THEN
00521         APKMAS=AMK
00522       ELSEIF  (IDENT.EQ.-3) THEN
00523         APKMAS=AMK
00524       ELSEIF  (IDENT.EQ. 4) THEN
00525         APKMAS=AMKZ
00526       ELSEIF  (IDENT.EQ.-4) THEN
00527         APKMAS=AMKZ
00528       ELSEIF  (IDENT.EQ. 8) THEN
00529         APKMAS=0.0001
00530       ELSEIF  (IDENT.EQ.-8) THEN
00531         APKMAS=0.0001
00532       ELSEIF  (IDENT.EQ. 9) THEN
00533         APKMAS=0.5488
00534       ELSEIF  (IDENT.EQ.-9) THEN
00535         APKMAS=0.5488
00536       ELSE
00537         PRINT *, 'STOP IN APKMAS, WRONG IDENT=',IDENT
00538         STOP
00539       ENDIF
00540       DCDMAS=APKMAS
00541       END
00542       FUNCTION LUNPIK(ID,ISGN)
00543       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00544       REAL*4            BRA1,BRK0,BRK0B,BRKS
00545       REAL*4 XIO(1)
00546       IDENT=ID*ISGN
00547       IF      (IDENT.EQ. 1) THEN
00548         IPKDEF=-211
00549       ELSEIF  (IDENT.EQ.-1) THEN
00550         IPKDEF= 211
00551       ELSEIF  (IDENT.EQ. 2) THEN
00552         IPKDEF=111
00553       ELSEIF  (IDENT.EQ.-2) THEN
00554         IPKDEF=111
00555       ELSEIF  (IDENT.EQ. 3) THEN
00556         IPKDEF=-321
00557       ELSEIF  (IDENT.EQ.-3) THEN
00558         IPKDEF= 321
00559       ELSEIF  (IDENT.EQ. 4) THEN
00560 *
00561 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00562         CALL RANMAR(XIO,1)
00563         IF (XIO(1).GT.BRK0) THEN
00564           IPKDEF= 130
00565         ELSE
00566           IPKDEF= 310
00567         ENDIF
00568       ELSEIF  (IDENT.EQ.-4) THEN
00569 *
00570 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00571         CALL RANMAR(XIO,1)
00572         IF (XIO(1).GT.BRK0B) THEN
00573           IPKDEF= 130
00574         ELSE
00575           IPKDEF= 310
00576         ENDIF
00577       ELSEIF  (IDENT.EQ. 8) THEN
00578         IPKDEF= 22
00579       ELSEIF  (IDENT.EQ.-8) THEN
00580         IPKDEF= 22
00581       ELSEIF  (IDENT.EQ. 9) THEN
00582         IPKDEF= 221
00583       ELSEIF  (IDENT.EQ.-9) THEN
00584         IPKDEF= 221
00585       ELSE
00586         PRINT *, 'STOP IN IPKDEF, WRONG IDENT=',IDENT
00587         STOP
00588       ENDIF
00589       LUNPIK=IPKDEF
00590       END
00591 
00592 
00593 
00594       SUBROUTINE TAURDF(KTO)
00595 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
00596 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
00597 C CONTENTS
00598       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00599       REAL*4            BRA1,BRK0,BRK0B,BRKS
00600       COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00601       IF (KTO.EQ.1) THEN
00602 C     ==================
00603 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00604       BRA1 = PKORB(4,1)
00605       BRKS = PKORB(4,3)
00606       BRK0  = PKORB(4,5)
00607       BRK0B  = PKORB(4,6)
00608       ELSE
00609 C     ====
00610 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00611       BRA1 = PKORB(4,2)
00612       BRKS = PKORB(4,4)
00613       BRK0  = PKORB(4,5)
00614       BRK0B  = PKORB(4,6)
00615       ENDIF
00616 C     =====
00617       END
00618 
00619       SUBROUTINE INIPHY(XK00)
00620 * ----------------------------------------------------------------------
00621 *     INITIALISATION OF PARAMETERS
00622 *     USED IN QED and/or GSW ROUTINES
00623 * ----------------------------------------------------------------------
00624       COMMON / QEDPRM /ALFINV,ALFPI,XK0
00625       REAL*8           ALFINV,ALFPI,XK0
00626       REAL*8 PI8,XK00
00627 *
00628       PI8    = 4.D0*DATAN(1.D0)
00629       ALFINV = 137.03604D0
00630       ALFPI  = 1D0/(ALFINV*PI8)
00631       XK0=XK00
00632       END
00633 
00634       SUBROUTINE INIMAS
00635 C ----------------------------------------------------------------------
00636 C     INITIALISATION OF MASSES
00637 C
00638 C     called by : KORALZ
00639 C ----------------------------------------------------------------------
00640       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00641      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00642      *                 ,AMK,AMKZ,AMKST,GAMKST
00643 *
00644       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00645      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00646      *                 ,AMK,AMKZ,AMKST,GAMKST
00647 C
00648 C IN-COMING / OUT-GOING  FERMION MASSES
00649       AMTAU  = 1.7842
00650 C --- let us update tau mass ...
00651       AMTAU  = 1.777
00652       AMNUTA = 0.010
00653       AMEL   = 0.0005111
00654       AMNUE  = 0.0
00655       AMMU   = 0.105659 
00656       AMNUMU = 0.0
00657 *
00658 * MASSES USED IN TAU DECAYS
00659       AMPIZ  = 0.134964
00660       AMPI   = 0.139568
00661       AMRO   = 0.773
00662       GAMRO  = 0.145
00663 *C    GAMRO  = 0.666
00664       AMA1   = 1.251
00665       GAMA1  = 0.599
00666       AMK    = 0.493667
00667       AMKZ   = 0.49772
00668       AMKST  = 0.8921
00669       GAMKST = 0.0513
00670 C
00671 C
00672 C IN-COMING / OUT-GOING  FERMION MASSES
00673 !!      AMNUTA = PKORB(1,2)
00674 !!      AMNUE  = PKORB(1,4)
00675 !!      AMNUMU = PKORB(1,6)
00676 C
00677 C MASSES USED IN TAU DECAYS  Cleo settings
00678 !!      AMPIZ  = PKORB(1,7)
00679 !!      AMPI   = PKORB(1,8)
00680 !!      AMRO   = PKORB(1,9)
00681 !!      GAMRO  = PKORB(2,9)
00682       AMA1   = 1.275   !! PKORB(1,10)
00683       GAMA1  = 0.615   !! PKORB(2,10)
00684 !!      AMK    = PKORB(1,11)
00685 !!      AMKZ   = PKORB(1,12)
00686 !!      AMKST  = PKORB(1,13)
00687 !!      GAMKST = PKORB(2,13)
00688 C
00689 
00690       RETURN
00691       END
00692       SUBROUTINE TAUFIL
00693 C     *****************
00694 C SUBSITUTE OF tau PRODUCTION GENERATOR
00695 C
00696       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00697      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00698      *                 ,AMK,AMKZ,AMKST,GAMKST
00699 C
00700       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00701      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00702      *                 ,AMK,AMKZ,AMKST,GAMKST
00703       COMMON / IDFC  / IDFF
00704 C positions of taus in the LUND common block
00705 C it will be used by TAUOLA output routines.
00706       COMMON /TAUPOS / NPA,NPB
00707       DIMENSION XPB1(4),XPB2(4),AQF1(4),AQF2(4)
00708 C
00709 C --- DEFINING DUMMY EVENTS MOMENTA
00710       DO 4 K=1,3
00711         XPB1(K)=0.0
00712         XPB2(K)=0.0
00713         AQF1(K)=0.0
00714         AQF2(K)=0.0
00715   4   CONTINUE
00716         AQF1(4)=AMTAU
00717         AQF2(4)=AMTAU
00718 C --- TAU MOMENTA
00719       CALL TRALO4(1,AQF1,AQF1,AM)
00720       CALL TRALO4(2,AQF2,AQF2,AM)
00721 C --- BEAMS MOMENTA AND IDENTIFIERS
00722         KFB1= 11*IDFF/IABS(IDFF)
00723         KFB2=-11*IDFF/IABS(IDFF)
00724         XPB1(4)= AQF1(4)
00725         XPB1(3)= AQF1(4)
00726         IF(AQF1(3).NE.0.0)
00727      $  XPB1(3)= AQF1(4)*AQF1(3)/ABS(AQF1(3))
00728         XPB2(4)= AQF2(4)
00729         XPB2(3)=-AQF2(4)
00730         IF(AQF2(3).NE.0.0)
00731      $  XPB2(3)= AQF2(4)*AQF2(3)/ABS(AQF2(3))
00732 C --- Position of first and second tau in LUND common
00733       NPA=3
00734       NPB=4
00735 C --- FILL TO LUND COMMON
00736       CALL FILHEP(  1,3, KFB1,0,0,0,0,XPB1, AMEL,.TRUE.)
00737       CALL FILHEP(  2,3, KFB2,0,0,0,0,XPB2, AMEL,.TRUE.)
00738       CALL FILHEP(NPA,1, IDFF,1,2,0,0,AQF1,AMTAU,.TRUE.)
00739       CALL FILHEP(NPB,1,-IDFF,1,2,0,0,AQF2,AMTAU,.TRUE.)
00740       END
00741       SUBROUTINE TRALO4(KTO,P,Q,AM)
00742 C     **************************
00743 C SUBSITUTE OF TRALO4
00744       REAL  P(4),Q(4)
00745 C
00746       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00747      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00748      *                 ,AMK,AMKZ,AMKST,GAMKST
00749 C
00750       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00751      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00752      *                 ,AMK,AMKZ,AMKST,GAMKST
00753       COMMON /PTAU/ PTAU
00754       AM=AMAS4(P)
00755       ETAU=SQRT(PTAU**2+AMTAU**2)
00756       EXE=(ETAU+PTAU)/AMTAU
00757       IF(KTO.EQ.2) EXE=(ETAU-PTAU)/AMTAU
00758       CALL BOSTR3(EXE,P,Q)
00759 C ======================================================================
00760 C         END OF THE TEST JOB
00761 C ======================================================================
00762       END
00763       SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
00764 C ----------------------------------------------------------------------
00765 C this subroutine fills one entry into the HEPEVT common
00766 C and updates the information for affected mother entries
00767 C
00768 C written by Martin W. Gruenewald (91/01/28)
00769 C
00770 C     called by : ZTOHEP,BTOHEP,DWLUxy
00771 C ----------------------------------------------------------------------
00772 C
00773 C this is the hepevt class in old style. No d_h_ class pre-name
00774       INTEGER NMXHEP
00775       PARAMETER (NMXHEP=10000)
00776       REAL*8  phep,  vhep ! to be real*4/ *8  depending on host
00777       INTEGER nevhep,nhep,isthep,idhep,jmohep,
00778      $        jdahep
00779       COMMON /hepevt/
00780      $      nevhep,               ! serial number
00781      $      nhep,                 ! number of particles
00782      $      isthep(nmxhep),   ! status code
00783      $      idhep(nmxhep),    ! particle ident KF
00784      $      jmohep(2,nmxhep), ! parent particles
00785      $      jdahep(2,nmxhep), ! childreen particles
00786      $      phep(5,nmxhep),   ! four-momentum, mass [GeV]
00787      $      vhep(4,nmxhep)    ! vertex [mm]
00788 * ----------------------------------------------------------------------
00789       LOGICAL qedrad
00790       COMMON /phoqed/ 
00791      $     qedrad(nmxhep)    ! Photos flag
00792 * ----------------------------------------------------------------------
00793       SAVE hepevt,phoqed
00794 C      PARAMETER (NMXHEP=2000)
00795 C      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
00796 C     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
00797 C      SAVE  /HEPEVT/
00798 C      COMMON/PHOQED/QEDRAD(NMXHEP)
00799 C      LOGICAL QEDRAD
00800 C      SAVE /PHOQED/
00801       LOGICAL PHFLAG
00802 C
00803       REAL*4  P4(4)
00804 C
00805 C check address mode
00806       IF (N.EQ.0) THEN
00807 C
00808 C append mode
00809         IHEP=NHEP+1
00810       ELSE IF (N.GT.0) THEN
00811 C
00812 C absolute position
00813         IHEP=N
00814       ELSE
00815 C
00816 C relative position
00817         IHEP=NHEP+N
00818       END IF
00819 C
00820 C check on IHEP
00821       IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
00822 C
00823 C add entry
00824       NHEP=IHEP
00825       ISTHEP(IHEP)=IST
00826       IDHEP(IHEP)=ID
00827       JMOHEP(1,IHEP)=JMO1
00828       IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
00829       JMOHEP(2,IHEP)=JMO2
00830       IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
00831       JDAHEP(1,IHEP)=JDA1
00832       JDAHEP(2,IHEP)=JDA2
00833 C
00834       DO I=1,4
00835         PHEP(I,IHEP)=P4(I)
00836 C
00837 C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
00838         VHEP(I,IHEP)=0.0
00839       END DO
00840       PHEP(5,IHEP)=PINV
00841 C FLAG FOR PHOTOS...
00842       QEDRAD(IHEP)=PHFLAG
00843 C
00844 C update process:
00845       DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
00846         IF(IP.GT.0)THEN
00847 C
00848 C if there is a daughter at IHEP, mother entry at IP has decayed
00849           IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
00850 C
00851 C and daughter pointers of mother entry must be updated
00852           IF(JDAHEP(1,IP).EQ.0)THEN
00853             JDAHEP(1,IP)=IHEP
00854             JDAHEP(2,IP)=IHEP
00855           ELSE
00856             JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
00857           END IF
00858         END IF
00859       END DO
00860 C
00861       RETURN
00862       END
Generated on Sun Oct 20 20:24:10 2013 for C++InterfacetoTauola by  doxygen 1.6.3