tauola-BBB/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 C      CALL testresu ! fine tune inputs: masses etc. 
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         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 
00133 
00134       CALL TAUFIL
00135 C DECAY....
00136       IF (KTORY.EQ.1) THEN
00137          CALL DEXAY(KTO,POL)
00138       ELSE
00139          CALL DEKAY(KTO,HH)
00140          CALL DEKAY(KTO+10,HH)
00141       ENDIF
00142       CALL LUHEPC(2)
00143       IF(IEV.LE.44) THEN
00144        WRITE(IOUT,7002) IEV
00145        IF (KTORY.NE.1) THEN
00146          WRITE(IOUT,7003) HH
00147        ENDIF
00148 C      CALL LULIST(11)
00149       CALL LULIST(2)
00150       ENDIF
00151       IPRI=MOD(NEV,1000)
00152 
00153       IF(IPRI.EQ.1) write(*,*) ' event no: ',NEV,' NEVTES: ',NEVTES
00154   300 CONTINUE
00155   301 CONTINUE
00156 C-----------------------------------------------------------------------
00157 C                     POSTGENERATION
00158 C-----------------------------------------------------------------------
00159       IF (KTORY.EQ.1) THEN
00160          CALL DEXAY(100,POL)
00161       ELSE
00162          CALL DEKAY(100,HH)
00163       ENDIF
00164       RETURN
00165  7001 FORMAT(//4(/1X,15(5H=====))
00166      $ /,' ',     19X,'  NON INITIALIZED BBB-VERSION OF TAUOLA ',9X,1H ,
00167      $ /,' ',     19X,'    TESTS OF TAU DECAY ROUTINES         ',9X,1H ,
00168      $ /,' ',     19X,'    INTERFACE OF THE KORAL-Z TYPE       ',9X,1H ,
00169      $  2(/,1X,15(5H=====)),
00170      $ /,5X ,'JAK   =',I7  ,'  KEY DEFINING DECAY TYPE         ',9X,1H ,
00171      $ /,5X ,'IDFF  =',I7  ,'  LUND IDENTIFIER FOR FIRST TAU   ',9X,1H ,
00172      $ /,5X ,'POL(3)=',F7.2,'  THIRD COMPONENT OF TAU POLARIZ. ',9X,1H ,
00173      $ /,5X ,'PTAU  =',F7.2,'  THIRD COMPONENT OF TAU MOM. GEV ',9X,1H ,
00174      $  2(/,1X,15(5H=====))/)
00175  7002 FORMAT(///1X, '===== EVENT NO.',I4,1X,5H=====)
00176  7003 FORMAT(5X,'POLARIMETRIC VECTOR: ',
00177      $       7X,'HH(1)',7X,'HH(2)',7X,'HH(3)',7X,'HH(4)',
00178      $ /,    5X,'                     ', 4(1X,F11.8)   )
00179  7004 FORMAT(//4(/1X,15(5H=====))
00180      $ /,'  ',     19X,' NON INITIALIZED BBB-VERSION OF TAUOLA ',9X,1H ,
00181      $ /,'  ',     19X,'    TESTS OF TAU DECAY ROUTINES        ',9X,1H ,
00182      $ /,'  ',     19X,'    INTERFACE OF THE KORAL-B TYPE      ',9X,1H ,
00183      $  2(/,1X,15(5H=====)),
00184      $ /,5X ,'JAK   =',I7  ,'  KEY DEFINING DECAY TYPE         ',9X,1H ,
00185      $ /,5X ,'IDFF  =',I7  ,'  LUND IDENTIFIER FOR FIRST TAU   ',9X,1H ,
00186      $ /,5X ,'POL(3)=',F7.2,'  THIRD COMPONENT OF TAU POLARIZ. ',9X,1H ,
00187      $ /,5X ,'PTAU  =',F7.2,'  THIRD COMPONENT OF TAU MOM. GEV ',9X,1H ,
00188      $  2(/,1X,15(5H=====))/)
00189  7011 FORMAT(///1X, '===== TYPE OF CURRENT',I4,1X,5H=====)
00190       END
00191       SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
00192      $            AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
00193       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00194      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00195      *                 ,AMK,AMKZ,AMKST,GAMKST
00196 C
00197       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00198      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00199      *                 ,AMK,AMKZ,AMKST,GAMKST
00200 C
00201       AMROP=1.1
00202       GAMROP=0.36
00203       AMOM=.782
00204       GAMOM=0.0084
00205 C     XXXXA CORRESPOND TO S2 CHANNEL !
00206       IF(MNUM.EQ.0) THEN
00207        PROB1=0.5
00208        PROB2=0.5
00209        AMRX =AMA1
00210        GAMRX=GAMA1
00211        AMRA =AMRO
00212        GAMRA=GAMRO
00213        AMRB =AMRO
00214        GAMRB=GAMRO
00215       ELSEIF(MNUM.EQ.1) THEN
00216        PROB1=0.5
00217        PROB2=0.5
00218        AMRX =1.57
00219        GAMRX=0.9
00220        AMRB =AMKST
00221        GAMRB=GAMKST
00222        AMRA =AMRO
00223        GAMRA=GAMRO
00224       ELSEIF(MNUM.EQ.2) THEN
00225        PROB1=0.5
00226        PROB2=0.5
00227        AMRX =1.57
00228        GAMRX=0.9
00229        AMRB =AMKST
00230        GAMRB=GAMKST
00231        AMRA =AMRO
00232        GAMRA=GAMRO
00233       ELSEIF(MNUM.EQ.3) THEN
00234        PROB1=0.5
00235        PROB2=0.5
00236        AMRX =1.27
00237        GAMRX=0.3
00238        AMRA =AMKST
00239        GAMRA=GAMKST
00240        AMRB =AMKST
00241        GAMRB=GAMKST
00242       ELSEIF(MNUM.EQ.4) THEN
00243        PROB1=0.5
00244        PROB2=0.5
00245        AMRX =1.27
00246        GAMRX=0.3
00247        AMRA =AMKST
00248        GAMRA=GAMKST
00249        AMRB =AMKST
00250        GAMRB=GAMKST
00251       ELSEIF(MNUM.EQ.5) THEN
00252        PROB1=0.5
00253        PROB2=0.5
00254        AMRX =1.27
00255        GAMRX=0.3
00256        AMRA =AMKST
00257        GAMRA=GAMKST
00258        AMRB =AMRO
00259        GAMRB=GAMRO
00260       ELSEIF(MNUM.EQ.6) THEN
00261        PROB1=0.4
00262        PROB2=0.4
00263        AMRX =1.27
00264        GAMRX=0.3
00265        AMRA =AMRO
00266        GAMRA=GAMRO
00267        AMRB =AMKST
00268        GAMRB=GAMKST
00269       ELSEIF(MNUM.EQ.7) THEN
00270        PROB1=0.0
00271        PROB2=1.0
00272        AMRX =1.27
00273        GAMRX=0.9
00274        AMRA =AMRO
00275        GAMRA=GAMRO
00276        AMRB =AMRO
00277        GAMRB=GAMRO
00278       ELSEIF(MNUM.EQ.8) THEN
00279        PROB1=0.0
00280        PROB2=1.0
00281        AMRX =AMROP
00282        GAMRX=GAMROP
00283        AMRB =AMOM
00284        GAMRB=GAMOM
00285        AMRA =AMRO
00286        GAMRA=GAMRO
00287       ELSEIF(MNUM.EQ.9) THEN
00288        PROB1=0.5
00289        PROB2=0.5
00290        AMRX =AMA1
00291        GAMRX=GAMA1
00292        AMRA =AMRO
00293        GAMRA=GAMRO
00294        AMRB =AMRO
00295        GAMRB=GAMRO
00296       ELSEIF(MNUM.EQ.101) THEN
00297        PROB1=.35
00298        PROB2=.35
00299        AMRX =1.2
00300        GAMRX=.46
00301        AMRB =AMOM
00302        GAMRB=GAMOM
00303        AMRA =AMOM
00304        GAMRA=GAMOM
00305       ELSEIF(MNUM.EQ.102) THEN
00306        PROB1=0.0
00307        PROB2=0.0
00308        AMRX =1.4
00309        GAMRX=.6
00310        AMRB =AMOM
00311        GAMRB=GAMOM
00312        AMRA =AMOM
00313        GAMRA=GAMOM
00314       ELSEIF(MNUM.GE.103.AND.MNUM.LE.112) THEN
00315        PROB1=0.0
00316        PROB2=0.0
00317        AMRX =1.4
00318        GAMRX=.6
00319        AMRB =AMOM
00320        GAMRB=GAMOM
00321        AMRA =AMOM
00322        GAMRA=GAMOM
00323 
00324 
00325       ELSE
00326        PROB1=0.0
00327        PROB2=0.0
00328        AMRX =AMA1
00329        GAMRX=GAMA1
00330        AMRA =AMRO
00331        GAMRA=GAMRO
00332        AMRB =AMRO
00333        GAMRB=GAMRO
00334       ENDIF
00335 C
00336       IF    (RR.LE.PROB1) THEN
00337        ICHAN=1
00338       ELSEIF(RR.LE.(PROB1+PROB2)) THEN
00339        ICHAN=2
00340         AX   =AMRA
00341         GX   =GAMRA
00342         AMRA =AMRB
00343         GAMRA=GAMRB
00344         AMRB =AX
00345         GAMRB=GX
00346         PX   =PROB1
00347         PROB1=PROB2
00348         PROB2=PX
00349       ELSE
00350        ICHAN=3
00351       ENDIF
00352 C
00353       PROB3=1.0-PROB1-PROB2
00354       END
00355       SUBROUTINE INITDK
00356 * ----------------------------------------------------------------------
00357 *     INITIALISATION OF TAU DECAY PARAMETERS  and routines
00358 *
00359 *     called by : KORALZ
00360 * ----------------------------------------------------------------------
00361 
00362       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00363       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00364       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00365      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00366      *                 ,AMK,AMKZ,AMKST,GAMKST
00367 *
00368       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00369      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00370      *                 ,AMK,AMKZ,AMKST,GAMKST
00371       COMMON / TAUBRA / GAMPRT(500),JLIST(500),NCHAN
00372       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00373       REAL*4            BRA1,BRK0,BRK0B,BRKS
00374 
00375       PARAMETER (NMODE=86,NM1=0,NM2=11,NM3=19,NM4=22,NM5=21,NM6=13)
00376       COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00377      &                ,NAMES
00378       CHARACTER NAMES(NMODE)*31
00379 
00380       CHARACTER OLDNAMES(7)*31
00381       CHARACTER*80 bxINIT
00382       PARAMETER (
00383      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00384      $ )
00385       REAL*4 PI,POL1(4)
00386 *
00387 *
00388 * LIST OF BRANCHING RATIOS
00389 CAM normalised to e nu nutau channel
00390 CAM                  enu   munu   pinu  rhonu   A1nu   Knu    K*nu   pi
00391 CAM   DATA JLIST  /    1,     2,     3,     4,     5,     6,     7,
00392 
00393 *AM   DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
00394 *AM
00395 *AM  multipion decays
00396 *
00397 *    conventions of particles names
00398 *                 K-,P-,K+,  K0,P-,KB,  K-,P0,K0
00399 *                  3, 1,-3  , 4, 1,-4  , 3, 2, 4  ,
00400 *                 P0,P0,K-,  K-,P-,P+,  P-,KB,P0
00401 *                  2, 2, 3  , 3, 1,-1  , 1,-4, 2  ,
00402 *                 ET,P-,P0 , P-,P0,GM  , P-,P0,P0
00403 *                  9, 1, 2  , 1, 2, 8  ,  1, 2, 2
00404 *
00405 
00406 C
00407       DIMENSION NOPIK(9,NMODE),NPIK(NMODE)
00408 *AM   outgoing multiplicity and flavors of multi-pion /multi-K modes    
00409       DATA   NPIK  /                4,                    4,    ! old 4scalar
00410      a                              4,                    4,    ! new (may 2004)
00411      b                              4,                    4,
00412      c                              4,                    4,
00413      d                              4,                    4,
00414      e                              4,                    4,    ! new (may 2004)
00415      e                              4,                    4,    ! new (sep 2004)
00416      e                              4,                    4,    
00417      e                              4,                    4,    
00418      e                              4,                    4,    
00419      e                              4,                    4,    ! new (sep 2004)
00420      1                              5,       
00421      a                              5,                    5,    ! new (may 2004)
00422      b                              5,                    5,
00423      c                              5,                    5,
00424      d                              5,                    5,
00425      e                              5,                    5,    ! new (may 2004)
00426      a                              5,                    5,    ! new (sep 2004)
00427      b                              5,                    5,
00428      c                              5,                    5,
00429      d                              5,                    5,
00430      e                              5,                    5,    ! new (sep 2004)
00431      x                                                    5,    ! old npi starts here
00432      2                              6,                    6,
00433      a                              6,                    6,    ! new (may 2004)
00434      b                              6,                    6,    ! new (may 2004)
00435      c                              6,                    6,    ! new (may 2004)
00436      d                              6,                    6,    ! new (may 2004)
00437      e                              6,                    6,    ! new (may 2004)
00438      3                              3,                    3,            
00439      4                              3,                    3,            
00440      5                              3,                    3,            
00441      6                              3,                    3,  
00442      7                              3,                          ! new (may 2004) and useful
00443      a                              3,                    3,    ! new (may 2004)
00444      a                              3,                    3,    ! new (may 2004)
00445      a                              3,                    3,    ! new (may 2004)
00446      a                              3,                    3,    ! new (may 2004)
00447      a                              3,                    3,    ! new (may 2004)
00448      8                                                    2, 
00449      9                              2,                    2,    ! new (may 2004)
00450      9                              2,                    2,    ! new (may 2004)
00451      9                              2,                    2,    ! new (may 2004)
00452      9                              2,                    2,    ! new (may 2004)
00453      9                              2,                    2/    ! new (may 2004)          
00454 
00455       DATA  NOPIK / -1,-1, 1, 2, 0, 0,3*0,     2, 2, 2,-1, 0, 0,3*0,  
00456      a               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00457      b               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00458      c               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00459      d               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00460      e               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00461      a               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00462      b               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00463      c               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00464      d               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00465      e               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00466      1              -1,-1, 1, 2, 2, 0,3*0,  
00467      a              -1,-1, 1, 2, 2, 0,3*0,     2, 2, 2, 2, 2, 0,3*0,     ! new (may 2004)
00468      a               1,-1,-1, 2, 2, 0,3*0,    -1, 2, 2, 2, 2, 0,3*0,     ! new (may 2004)
00469      a              -1, 1, 1,-1,-1, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00470      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00471      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00472      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00473      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00474      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00475      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00476      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00477      x                                        -1,-1,-1, 1, 1, 0,3*0,     ! old npi starts here
00478      2              -1,-1,-1, 1, 1, 2,3*0,    -1,-1, 1, 2, 2, 2,3*0, 
00479      a              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00480      b              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00481      c              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00482      d              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00483      e              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00484      3              -3,-1, 3, 0, 0, 0,3*0,    -4,-1, 4, 0, 0, 0,3*0,  
00485      4              -3, 2,-4, 0, 0, 0,3*0,     2, 2,-3, 0, 0, 0,3*0,  
00486      5              -3,-1, 1, 0, 0, 0,3*0,    -1, 4, 2, 0, 0, 0,3*0,  
00487      6               9,-1, 2, 0, 0, 0,3*0,    -1, 2, 8, 0, 0, 0,3*0,
00488 
00489 
00490 C AJWMOD fix sign bug, 2/22/99
00491      7               2, 2,-1, 0, 0, 0,3*0,                           ! new (may 2004) but useful
00492      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00493      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00494      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00495      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00496      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00497 
00498      8                                        -3,-4, 0, 0, 0, 0,3*0,
00499      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00500      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00501      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00502      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00503      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0 /! new (may 2004)
00504 
00505 
00506 * LIST OF BRANCHING RATIOS
00507       NCHAN = NMODE + 7
00508       DO 1 I = 1,500
00509       IF (I.LE.NCHAN) THEN
00510         JLIST(I) = I
00511 
00512         IF(I.EQ. 1) GAMPRT(I) =0.1800 
00513         IF(I.EQ. 2) GAMPRT(I) =0.1751 
00514         IF(I.EQ. 3) GAMPRT(I) =0.1110 
00515         IF(I.EQ. 4) GAMPRT(I) =0.2515 
00516         IF(I.EQ. 5) GAMPRT(I) =0.1790 /2
00517         IF(I.EQ. 6) GAMPRT(I) =0.0071 
00518         IF(I.EQ. 7) GAMPRT(I) =0.0134
00519         IF(I.EQ. 8) GAMPRT(I) =0.0450
00520         IF(I.EQ. 9) GAMPRT(I) =0.0100
00521 
00522         IF(I.EQ.30) GAMPRT(I) =0.0009
00523         IF(I.EQ.33) GAMPRT(I) =0.004
00524         IF(I.EQ.34) GAMPRT(I) =0.002
00525         IF(I.EQ.35) GAMPRT(I) =0.001
00526 
00527         IF(I.EQ.51) GAMPRT(I) =0.0004 
00528         IF(I.EQ.52) GAMPRT(I) =0.0003 
00529         IF(I.EQ.53) GAMPRT(I) =0.0005 
00530 
00531         IF(I.EQ.64) GAMPRT(I) =0.0015 
00532         IF(I.EQ.65) GAMPRT(I) =0.0015 
00533         IF(I.EQ.66) GAMPRT(I) =0.0015 
00534         IF(I.EQ.67) GAMPRT(I) =0.0005
00535         IF(I.EQ.68) GAMPRT(I) =0.0050
00536         IF(I.EQ.69) GAMPRT(I) =0.0055
00537         IF(I.EQ.70) GAMPRT(I) =0.0017 
00538         IF(I.EQ.71) GAMPRT(I) =0.0013
00539         IF(I.EQ.72) GAMPRT(I) =0.1790 /2  
00540 
00541         IF(I.EQ.83) GAMPRT(I) =0.0010 
00542 
00543         IF(I.EQ. 1) OLDNAMES(I)='  TAU-  -->   E-               '
00544         IF(I.EQ. 2) OLDNAMES(I)='  TAU-  -->  MU-               '
00545         IF(I.EQ. 3) OLDNAMES(I)='  TAU-  -->  PI-               '
00546         IF(I.EQ. 4) OLDNAMES(I)='  TAU-  -->  PI-, PI0          '
00547         IF(I.EQ. 5) OLDNAMES(I)='  TAU-  -->  PI-, PI-,  PI+    '
00548         IF(I.EQ. 6) OLDNAMES(I)='  TAU-  -->   K-               '
00549         IF(I.EQ. 7) OLDNAMES(I)='  TAU-  -->  K*- (two subch)   '
00550         IF(I.EQ. 8) NAMES(I-7)='  TAU-  --> 2PI-,  PI0,  PI+   '
00551         IF(I.EQ. 9) NAMES(I-7)='  TAU-  --> 3PI0,        PI-   '
00552 
00553         IF(I.EQ.10) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00554         IF(I.EQ.11) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00555         IF(I.EQ.12) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00556         IF(I.EQ.13) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00557         IF(I.EQ.14) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00558         IF(I.EQ.15) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00559         IF(I.EQ.16) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00560         IF(I.EQ.17) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00561         IF(I.EQ.18) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)  
00562         IF(I.EQ.19) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00563         IF(I.EQ.20) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00564         IF(I.EQ.21) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00565         IF(I.EQ.22) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00566         IF(I.EQ.23) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00567         IF(I.EQ.24) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00568         IF(I.EQ.25) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00569         IF(I.EQ.26) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00570         IF(I.EQ.27) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00571         IF(I.EQ.28) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)  
00572         IF(I.EQ.29) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00573 
00574 
00575         IF(I.EQ.30) NAMES(I-7)='  TAU-  --> 2PI-, PI+, 2PI0 old'
00576 
00577         IF(I.EQ.31) NAMES(I-7)='  TAU-  --> a1 --> rho omega   '  !  (may 2004)
00578         IF(I.EQ.32) NAMES(I-7)='  TAU-  --> benchmark curr     '  !  (may 2004)
00579         IF(I.EQ.33) NAMES(I-7)='  TAU-  --> 2PI0, 2PI-,  PI+   '  !  (may 2004)
00580         IF(I.EQ.34) NAMES(I-7)='  TAU-  --> PI- 4PI0           '  !  (may 2004)
00581         IF(I.EQ.35) NAMES(I-7)='  TAU-  --> 3PI- 2PI+          '  !  (may 2004)
00582         IF(I.EQ.36) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00583         IF(I.EQ.37) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00584         IF(I.EQ.38) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00585         IF(I.EQ.39) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00586         IF(I.EQ.40) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00587 
00588         IF(I.EQ.41) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00589         IF(I.EQ.42) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00590         IF(I.EQ.43) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00591         IF(I.EQ.44) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00592         IF(I.EQ.45) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00593         IF(I.EQ.46) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00594         IF(I.EQ.47) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00595         IF(I.EQ.48) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00596         IF(I.EQ.49) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00597         IF(I.EQ.50) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00598 
00599         IF(I.EQ.51) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,        '
00600         IF(I.EQ.52) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,  PI0   '
00601         IF(I.EQ.53) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 3PI0   '
00602         IF(I.EQ.54) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00603         IF(I.EQ.55) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00604         IF(I.EQ.56) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00605         IF(I.EQ.57) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00606         IF(I.EQ.58) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00607         IF(I.EQ.59) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00608         IF(I.EQ.60) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00609         IF(I.EQ.61) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00610         IF(I.EQ.62) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00611         IF(I.EQ.63) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00612 
00613         IF(I.EQ.64) NAMES(I-7)='  TAU-  -->  K-, PI-,  K+      '
00614         IF(I.EQ.65) NAMES(I-7)='  TAU-  -->  K0, PI-, K0B      '
00615 
00616         IF(I.EQ.66) NAMES(I-7)='  TAU-  -->  K-,  K0, PI0      '
00617 
00618         IF(I.EQ.67) NAMES(I-7)='  TAU-  --> PI0  PI0   K-      '
00619         IF(I.EQ.68) NAMES(I-7)='  TAU-  -->  K-  PI-  PI+      '
00620         IF(I.EQ.69) NAMES(I-7)='  TAU-  --> PI-  K0B  PI0      '
00621         IF(I.EQ.70) NAMES(I-7)='  TAU-  --> ETA  PI-  PI0      '
00622         IF(I.EQ.71) NAMES(I-7)='  TAU-  --> PI-  PI0  GAM      '
00623         IF(I.EQ.72) NAMES(I-7)='  TAU-  --> PI-  PI0  PI0      '
00624         IF(I.EQ.73) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00625         IF(I.EQ.74) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00626         IF(I.EQ.75) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00627         IF(I.EQ.76) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00628         IF(I.EQ.77) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00629         IF(I.EQ.78) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00630         IF(I.EQ.79) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00631         IF(I.EQ.80) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00632         IF(I.EQ.81) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00633         IF(I.EQ.82) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00634  
00635 
00636         IF(I.EQ.83) NAMES(I-7)='  TAU-  -->  K-  K0            '
00637         IF(I.EQ.84) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00638         IF(I.EQ.85) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00639         IF(I.EQ.86) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00640         IF(I.EQ.87) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00641         IF(I.EQ.88) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00642         IF(I.EQ.89) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00643         IF(I.EQ.90) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00644         IF(I.EQ.91) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00645         IF(I.EQ.92) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00646         IF(I.EQ.93) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00647 
00648       ELSE
00649         JLIST(I) = 0
00650         GAMPRT(I) = 0.
00651       ENDIF
00652    1  CONTINUE
00653       DO I=1,NMODE
00654         MULPIK(I)=NPIK(I)
00655         DO J=1,MULPIK(I)
00656          IDFFIN(J,I)=NOPIK(J,I)
00657         ENDDO
00658       ENDDO
00659         DO I=1,NCHAN
00660          GAMPRT(I) = 1D0/NCHAN
00661         ENDDO
00662           gamprt(31)=gamprt(31)*0.001
00663           gamprt(32)=gamprt(32)*0.001
00664         do k=1,10  ! these are brs for empty slots prepared for new channels 
00665           gamprt(36+k)=gamprt(36+k)*0.001
00666           gamprt(30-k)=gamprt(30-k)*0.001
00667           gamprt(30+10+k)=gamprt(30+10+k)*0.001
00668           gamprt(30-10-k)=gamprt(30-10-k)*0.001
00669 
00670           gamprt(53+k)=gamprt(53+k)*0.001
00671           gamprt(72+k)=gamprt(72+k)*0.001
00672           gamprt(83+k)=gamprt(83+k)*0.001
00673         enddo
00674          GAMPRT(72)=GAMPRT(72)/2
00675          GAMPRT(5)=GAMPRT(5)/2
00676 
00677 *
00678 *
00679 * --- COEFFICIENTS TO FIX RATIO OF:
00680 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00681 * --- PROBABILITY OF K0 TO BE KS
00682 * --- PROBABILITY OF K0B TO BE KS
00683 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00684 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00685 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00686 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00687       BRA1=1D0 ! 0.5
00688       BRK0=0.5
00689       BRK0B=0.5
00690       BRKS=0.6667
00691 *
00692 
00693       GFERMI = 1.16637E-5
00694       CCABIB = 0.975
00695       GV     = 1.0
00696       GA     =-1.0
00697 
00698 
00699 
00700 * ZW 13.04.89 HERE WAS AN ERROR
00701       SCABIB = SQRT(1.-CCABIB**2)
00702       PI =4.*ATAN(1.)
00703       GAMEL  = GFERMI**2*AMTAU**5/(192*PI**3)
00704 *
00705 *      CALL DEXAY(-1,pol1)
00706 *
00707       RETURN
00708       END
00709       FUNCTION DCDMAS(IDENT)
00710       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00711      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00712      *                 ,AMK,AMKZ,AMKST,GAMKST
00713 *
00714       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00715      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00716      *                 ,AMK,AMKZ,AMKST,GAMKST
00717       IF      (IDENT.EQ. 1) THEN
00718         APKMAS=AMPI
00719       ELSEIF  (IDENT.EQ.-1) THEN
00720         APKMAS=AMPI
00721       ELSEIF  (IDENT.EQ. 2) THEN
00722         APKMAS=AMPIZ
00723       ELSEIF  (IDENT.EQ.-2) THEN
00724         APKMAS=AMPIZ
00725       ELSEIF  (IDENT.EQ. 3) THEN
00726         APKMAS=AMK
00727       ELSEIF  (IDENT.EQ.-3) THEN
00728         APKMAS=AMK
00729       ELSEIF  (IDENT.EQ. 4) THEN
00730         APKMAS=AMKZ
00731       ELSEIF  (IDENT.EQ.-4) THEN
00732         APKMAS=AMKZ
00733       ELSEIF  (IDENT.EQ. 8) THEN
00734         APKMAS=0.0001
00735       ELSEIF  (IDENT.EQ.-8) THEN
00736         APKMAS=0.0001
00737       ELSEIF  (IDENT.EQ. 9) THEN
00738         APKMAS=0.5488
00739       ELSEIF  (IDENT.EQ.-9) THEN
00740         APKMAS=0.5488
00741       ELSE
00742         PRINT *, 'STOP IN APKMAS, WRONG IDENT=',IDENT
00743         STOP
00744       ENDIF
00745       DCDMAS=APKMAS
00746       END
00747       FUNCTION LUNPIK(ID,ISGN)
00748       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00749       REAL*4            BRA1,BRK0,BRK0B,BRKS
00750       REAL*4 XIO(1)
00751       IDENT=ID*ISGN
00752 
00753       IF      (IDENT.EQ. 1) THEN
00754         IPKDEF=-211
00755       ELSEIF  (IDENT.EQ.-1) THEN
00756         IPKDEF= 211
00757       ELSEIF  (IDENT.EQ. 2) THEN
00758         IPKDEF=111
00759       ELSEIF  (IDENT.EQ.-2) THEN
00760         IPKDEF=111
00761       ELSEIF  (IDENT.EQ. 3) THEN
00762         IPKDEF=-321
00763       ELSEIF  (IDENT.EQ.-3) THEN
00764         IPKDEF= 321
00765 
00766       ELSEIF  (IDENT.EQ. 4) THEN
00767 *
00768 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00769         CALL RANMAR(XIO,1)
00770         IF (XIO(1).GT.BRK0) THEN
00771           IPKDEF= 130
00772         ELSE
00773           IPKDEF= 310
00774         ENDIF
00775       ELSEIF  (IDENT.EQ.-4) THEN
00776 *
00777 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00778         CALL RANMAR(XIO,1)
00779         IF (XIO(1).GT.BRK0B) THEN
00780           IPKDEF= 130
00781         ELSE
00782           IPKDEF= 310
00783         ENDIF
00784       ELSEIF  (IDENT.EQ. 8) THEN
00785         IPKDEF= 22
00786       ELSEIF  (IDENT.EQ.-8) THEN
00787         IPKDEF= 22
00788       ELSEIF  (IDENT.EQ. 9) THEN
00789         IPKDEF= 221
00790       ELSEIF  (IDENT.EQ.-9) THEN
00791         IPKDEF= 221
00792       ELSE
00793         PRINT *, 'STOP IN IPKDEF, WRONG IDENT=',IDENT
00794         STOP
00795       ENDIF
00796       LUNPIK=IPKDEF
00797       END
00798 
00799 
00800 
00801 
00802       SUBROUTINE TAURDF(KTO)
00803 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
00804 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
00805 C CONTENTS
00806       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00807       REAL*4            BRA1,BRK0,BRK0B,BRKS
00808       COMMON / TAUBRA / GAMPRT(500),JLIST(500),NCHAN
00809       IF (KTO.EQ.1) THEN
00810 C     ==================
00811 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00812       BRA1 = PKORB(4,1)
00813       BRKS = PKORB(4,3)
00814       BRK0  = PKORB(4,5)
00815       BRK0B  = PKORB(4,6)
00816       ELSE
00817 C     ====
00818 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00819       BRA1 = PKORB(4,2)
00820       BRKS = PKORB(4,4)
00821       BRK0  = PKORB(4,5)
00822       BRK0B  = PKORB(4,6)
00823       ENDIF
00824 C     =====
00825       END
00826 
00827 
00828       SUBROUTINE INIPHY(XK00)
00829 * ----------------------------------------------------------------------
00830 *     INITIALISATION OF PARAMETERS
00831 *     USED IN QED and/or GSW ROUTINES
00832 * ----------------------------------------------------------------------
00833       COMMON / QEDPRM /ALFINV,ALFPI,XK0
00834       REAL*8           ALFINV,ALFPI,XK0
00835       REAL*8 PI8,XK00
00836 *
00837       PI8    = 4.D0*DATAN(1.D0)
00838       ALFINV = 137.03604D0
00839       ALFPI  = 1D0/(ALFINV*PI8)
00840       XK0=XK00
00841       END
00842 
00843       SUBROUTINE INIMAS
00844 C ----------------------------------------------------------------------
00845 C     INITIALISATION OF MASSES
00846 C
00847 C     called by : KORALZ
00848 C ----------------------------------------------------------------------
00849       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00850      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00851      *                 ,AMK,AMKZ,AMKST,GAMKST
00852 *
00853       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00854      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00855      *                 ,AMK,AMKZ,AMKST,GAMKST
00856 C
00857 C IN-COMING / OUT-GOING  FERMION MASSES
00858       AMTAU  = 1.7842
00859 C --- let us update tau mass ...
00860       AMTAU  = 1.777
00861       AMNUTA = 0.010
00862       AMEL   = 0.0005111
00863       AMNUE  = 0.0
00864       AMMU   = 0.105659 
00865       AMNUMU = 0.0
00866 *
00867 * MASSES USED IN TAU DECAYS
00868 
00869       AMPIZ  = 0.134964
00870       AMPI   = 0.139568
00871       AMRO   = 0.773
00872       GAMRO  = 0.145
00873 *C    GAMRO  = 0.666
00874       AMA1   = 1.251
00875       GAMA1  = 0.599
00876       AMK    = 0.493667
00877       AMKZ   = 0.49772
00878       AMKST  = 0.8921
00879       GAMKST = 0.0513
00880 C
00881 C
00882 C IN-COMING / OUT-GOING  FERMION MASSES
00883 !!      AMNUTA = PKORB(1,2)
00884 !!      AMNUE  = PKORB(1,4)
00885 !!      AMNUMU = PKORB(1,6)
00886 C
00887 C MASSES USED IN TAU DECAYS  Cleo settings
00888 !!      AMPIZ  = PKORB(1,7)
00889 !!      AMPI   = PKORB(1,8)
00890 !!      AMRO   = PKORB(1,9)
00891 !!      GAMRO  = PKORB(2,9)
00892       AMA1   = 1.275   !! PKORB(1,10)
00893       GAMA1  = 0.615   !! PKORB(2,10)
00894 !!      AMK    = PKORB(1,11)
00895 !!      AMKZ   = PKORB(1,12)
00896 !!      AMKST  = PKORB(1,13)
00897 !!      GAMKST = PKORB(2,13)
00898 C
00899 
00900 
00901       RETURN
00902       END
00903       SUBROUTINE TAUFIL
00904 C     *****************
00905 C SUBSITUTE OF tau PRODUCTION GENERATOR
00906 C
00907       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00908      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00909      *                 ,AMK,AMKZ,AMKST,GAMKST
00910 C
00911       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00912      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00913      *                 ,AMK,AMKZ,AMKST,GAMKST
00914       COMMON / IDFC  / IDFF
00915 C positions of taus in the LUND common block
00916 C it will be used by TAUOLA output routines.
00917       COMMON /TAUPOS / NPA,NPB
00918       DIMENSION XPB1(4),XPB2(4),AQF1(4),AQF2(4)
00919 C
00920 C --- DEFINING DUMMY EVENTS MOMENTA
00921       DO 4 K=1,3
00922         XPB1(K)=0.0
00923         XPB2(K)=0.0
00924         AQF1(K)=0.0
00925         AQF2(K)=0.0
00926   4   CONTINUE
00927         AQF1(4)=AMTAU
00928         AQF2(4)=AMTAU
00929 C --- TAU MOMENTA
00930       CALL TRALO4(1,AQF1,AQF1,AM)
00931       CALL TRALO4(2,AQF2,AQF2,AM)
00932 C --- BEAMS MOMENTA AND IDENTIFIERS
00933         KFB1= 11*IDFF/IABS(IDFF)
00934         KFB2=-11*IDFF/IABS(IDFF)
00935         XPB1(4)= AQF1(4)
00936         XPB1(3)= AQF1(4)
00937         IF(AQF1(3).NE.0.0)
00938      $  XPB1(3)= AQF1(4)*AQF1(3)/ABS(AQF1(3))
00939         XPB2(4)= AQF2(4)
00940         XPB2(3)=-AQF2(4)
00941         IF(AQF2(3).NE.0.0)
00942      $  XPB2(3)= AQF2(4)*AQF2(3)/ABS(AQF2(3))
00943 C --- Position of first and second tau in LUND common
00944       NPA=3
00945       NPB=4
00946 C --- FILL TO LUND COMMON
00947       CALL FILHEP(  1,3, KFB1,0,0,0,0,XPB1, AMEL,.TRUE.)
00948       CALL FILHEP(  2,3, KFB2,0,0,0,0,XPB2, AMEL,.TRUE.)
00949       CALL FILHEP(NPA,1, IDFF,1,2,0,0,AQF1,AMTAU,.TRUE.)
00950       CALL FILHEP(NPB,1,-IDFF,1,2,0,0,AQF2,AMTAU,.TRUE.)
00951       END
00952       SUBROUTINE TRALO4(KTO,P,Q,AM)
00953 C     **************************
00954 C SUBSITUTE OF TRALO4
00955       REAL  P(4),Q(4)
00956 C
00957       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00958      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00959      *                 ,AMK,AMKZ,AMKST,GAMKST
00960 C
00961       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00962      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00963      *                 ,AMK,AMKZ,AMKST,GAMKST
00964       COMMON /PTAU/ PTAU
00965       AM=AMAS4(P)
00966       ETAU=SQRT(PTAU**2+AMTAU**2)
00967       EXE=(ETAU+PTAU)/AMTAU
00968       IF(KTO.EQ.2) EXE=(ETAU-PTAU)/AMTAU
00969       CALL BOSTR3(EXE,P,Q)
00970 C ======================================================================
00971 C         END OF THE TEST JOB
00972 C ======================================================================
00973       END
00974       SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
00975 C ----------------------------------------------------------------------
00976 C this subroutine fills one entry into the HEPEVT common
00977 C and updates the information for affected mother entries
00978 C
00979 C written by Martin W. Gruenewald (91/01/28)
00980 C
00981 C     called by : ZTOHEP,BTOHEP,DWLUxy
00982 C ----------------------------------------------------------------------
00983 C
00984 C this is the hepevt class in old style. No d_h_ class pre-name
00985       INTEGER NMXHEP
00986       PARAMETER (NMXHEP=4000)
00987       REAL*8  phep,  vhep ! to be real*4/ *8  depending on host
00988       INTEGER nevhep,nhep,isthep,idhep,jmohep,
00989      $        jdahep
00990       COMMON /hepevt/
00991      $      nevhep,               ! serial number
00992      $      nhep,                 ! number of particles
00993      $      isthep(nmxhep),   ! status code
00994      $      idhep(nmxhep),    ! particle ident KF
00995      $      jmohep(2,nmxhep), ! parent particles
00996      $      jdahep(2,nmxhep), ! childreen particles
00997      $      phep(5,nmxhep),   ! four-momentum, mass [GeV]
00998      $      vhep(4,nmxhep)    ! vertex [mm]
00999 * ----------------------------------------------------------------------
01000       LOGICAL qedrad
01001       COMMON /phoqed/ 
01002      $     qedrad(nmxhep)    ! Photos flag
01003 * ----------------------------------------------------------------------
01004       SAVE hepevt,phoqed
01005 
01006 
01007 C      PARAMETER (NMXHEP=2000)
01008 C      COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
01009 C     &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
01010 C      SAVE  /HEPEVT/
01011 C      COMMON/PHOQED/QEDRAD(NMXHEP)
01012 C      LOGICAL QEDRAD
01013 C      SAVE /PHOQED/
01014       LOGICAL PHFLAG
01015 C
01016       REAL*4  P4(4)
01017 C
01018 C check address mode
01019       IF (N.EQ.0) THEN
01020 C
01021 C append mode
01022         IHEP=NHEP+1
01023       ELSE IF (N.GT.0) THEN
01024 C
01025 C absolute position
01026         IHEP=N
01027       ELSE
01028 C
01029 C relative position
01030         IHEP=NHEP+N
01031       END IF
01032 C
01033 C check on IHEP
01034       IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
01035 C
01036 C add entry
01037       NHEP=IHEP
01038       ISTHEP(IHEP)=IST
01039       IDHEP(IHEP)=ID
01040       JMOHEP(1,IHEP)=JMO1
01041       IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
01042       JMOHEP(2,IHEP)=JMO2
01043       IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
01044       JDAHEP(1,IHEP)=JDA1
01045       JDAHEP(2,IHEP)=JDA2
01046 C
01047       DO I=1,4
01048         PHEP(I,IHEP)=P4(I)
01049 C
01050 C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
01051         VHEP(I,IHEP)=0.0
01052       END DO
01053       PHEP(5,IHEP)=PINV
01054 C FLAG FOR PHOTOS...
01055       QEDRAD(IHEP)=PHFLAG
01056 C
01057 C update process:
01058       DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
01059         IF(IP.GT.0)THEN
01060 C
01061 C if there is a daughter at IHEP, mother entry at IP has decayed
01062           IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
01063 C
01064 C and daughter pointers of mother entry must be updated
01065           IF(JDAHEP(1,IP).EQ.0)THEN
01066             JDAHEP(1,IP)=IHEP
01067             JDAHEP(2,IP)=IHEP
01068           ELSE
01069             JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
01070           END IF
01071         END IF
01072       END DO
01073 C
01074       RETURN
01075       END