tauola-BBB/jetset-F/tauola_photos_ini.f

00001 C this file is created by hand from taumain.F
00002 C actions: Remove routines: TAUDEM DECTES TAUFIL FILHEP
00003 C add:     INIETC will not necesarily work fine ... 
00004 C replace  TRALO4 
00005 C rename INIPHY to INIPHX
00006 
00007       SUBROUTINE INIETC(jakk1,jakk2,itd,ifpho)
00008       COMMON / IDFC  / IDFF
00009       COMMON / TAURAD / XK0DEC,ITDKRC
00010       DOUBLE PRECISION            XK0DEC
00011       COMMON / JAKI   /  JAK1,JAK2,JAKP,JAKM,KTOM
00012       COMMON /PHOACT/ IFPHOT
00013       SAVE
00014 C KTO=1 will denote tau+, thus :: IDFF=-15
00015           IDFF=-15
00016 C XK0 for tau decays.
00017           XK0DEC=0.01
00018 C radiative correction switch in tau --> e (mu) decays !
00019           ITDKRC=itd
00020 C switches of tau+ tau- decay modes !!
00021           JAK1=jakk1
00022           JAK2=jakk2
00023 C photos activation switch
00024           IFPHOT=IFPHO
00025       end
00026 
00027       SUBROUTINE TRALO4(KTOS,PHOI,PHOF,AM)
00028 !! Corrected 11.10.96 (ZW) tralor for KORALW.
00029 !! better treatment is to  cascade from tau rest-frame through W
00030 !! restframe down to LAB. 
00031       COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
00032       COMMON /TRALID/ idtra
00033       double precision Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4),P1QQ(4),P2QQ(4)
00034       double precision PIN(4),POUT(4),PBST(4),PBS1(4),QQ(4),PI
00035       double precision THET,PHI,EXE
00036       REAL*4 PHOI(4),PHOF(4)
00037       SAVE
00038       DATA PI /3.141592653589793238462643D0/
00039       AM=SQRT(ABS
00040      $   (PHOI(4)**2-PHOI(3)**2-PHOI(2)**2-PHOI(1)**2))
00041       idtra=KTOS
00042       DO K=1,4
00043        PIN(K)=PHOI(K)
00044        PHOF(K)=PHOI(K)
00045       ENDDO
00046 !      write(*,*) idtra
00047       IF    (idtra.EQ.1) THEN
00048         DO K=1,4
00049          PBST(K)=P1(K)
00050          QQ(K)=Q1(K)
00051         ENDDO
00052       ELSEIF(idtra.EQ.2) THEN
00053         DO K=1,4
00054          PBST(K)=P2(K)
00055          QQ(K)=Q1(K)
00056         ENDDO
00057       ELSEIF(idtra.EQ.3) THEN
00058         DO K=1,4
00059          PBST(K)=P3(K)
00060          QQ(K)=Q2(K)
00061         ENDDO
00062       ELSE
00063         DO K=1,4
00064          PBST(K)=P4(K)
00065          QQ(K)=Q2(K)
00066         ENDDO
00067       ENDIF
00068 
00069 
00070 
00071         CALL BOSTDQ(1,QQ,PBST,PBST)
00072         CALL BOSTDQ(1,QQ,P1,P1QQ)
00073         CALL BOSTDQ(1,QQ,P2,P2QQ)
00074         PBS1(4)=PBST(4)
00075         PBS1(3)=SQRT(PBST(3)**2+PBST(2)**2+PBST(1)**2)
00076         PBS1(2)=0D0
00077         PBS1(1)=0D0 
00078         EXE=(PBS1(4)+PBS1(3))/DSQRT(PBS1(4)**2-PBS1(3)**2)
00079 C for KTOS=1 boost is antiparallel to 4-momentum of P2. 
00080 C restframes of tau+ tau- and 'first' frame of 'higgs' are all connected
00081 C by boosts along z axis
00082        IF(KTOS.EQ.1)  EXE=(PBS1(4)-PBS1(3))/DSQRT(PBS1(4)**2-PBS1(3)**2)
00083         CALL BOSTD3(EXE,PIN,POUT)
00084 
00085 C once in Z/gamma/Higgs rest frame we control further kinematics by P2QQ for KTOS=1,2
00086         THET=ACOS(P2QQ(3)/SQRT(P2QQ(3)**2+P2QQ(2)**2+P2QQ(1)**2))
00087         PHI=0D0
00088         PHI=ACOS(P2QQ(1)/SQRT(P2QQ(2)**2+P2QQ(1)**2))
00089         IF(P2QQ(2).LT.0D0) PHI=2*PI-PHI
00090 
00091         CALL ROTPOX(THET,PHI,POUT)
00092         CALL BOSTDQ(-1,QQ,POUT,POUT)
00093       DO K=1,4
00094        PHOF(K)=POUT(K)
00095       ENDDO
00096       END
00097       SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
00098      $            AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
00099       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00100      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00101      *                 ,AMK,AMKZ,AMKST,GAMKST
00102 C
00103       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00104      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00105      *                 ,AMK,AMKZ,AMKST,GAMKST
00106 C
00107       AMROP=1.1
00108       GAMROP=0.36
00109       AMOM=.782
00110       GAMOM=0.0084
00111 C     XXXXA CORRESPOND TO S2 CHANNEL !
00112       IF(MNUM.EQ.0) THEN
00113        PROB1=0.5
00114        PROB2=0.5
00115        AMRX =AMA1
00116        GAMRX=GAMA1
00117        AMRA =AMRO
00118        GAMRA=GAMRO
00119        AMRB =AMRO
00120        GAMRB=GAMRO
00121       ELSEIF(MNUM.EQ.1) THEN
00122        PROB1=0.5
00123        PROB2=0.5
00124        AMRX =1.57
00125        GAMRX=0.9
00126        AMRB =AMKST
00127        GAMRB=GAMKST
00128        AMRA =AMRO
00129        GAMRA=GAMRO
00130       ELSEIF(MNUM.EQ.2) THEN
00131        PROB1=0.5
00132        PROB2=0.5
00133        AMRX =1.57
00134        GAMRX=0.9
00135        AMRB =AMKST
00136        GAMRB=GAMKST
00137        AMRA =AMRO
00138        GAMRA=GAMRO
00139       ELSEIF(MNUM.EQ.3) THEN
00140        PROB1=0.5
00141        PROB2=0.5
00142        AMRX =1.27
00143        GAMRX=0.3
00144        AMRA =AMKST
00145        GAMRA=GAMKST
00146        AMRB =AMKST
00147        GAMRB=GAMKST
00148       ELSEIF(MNUM.EQ.4) THEN
00149        PROB1=0.5
00150        PROB2=0.5
00151        AMRX =1.27
00152        GAMRX=0.3
00153        AMRA =AMKST
00154        GAMRA=GAMKST
00155        AMRB =AMKST
00156        GAMRB=GAMKST
00157       ELSEIF(MNUM.EQ.5) THEN
00158        PROB1=0.5
00159        PROB2=0.5
00160        AMRX =1.27
00161        GAMRX=0.3
00162        AMRA =AMKST
00163        GAMRA=GAMKST
00164        AMRB =AMRO
00165        GAMRB=GAMRO
00166       ELSEIF(MNUM.EQ.6) THEN
00167        PROB1=0.4
00168        PROB2=0.4
00169        AMRX =1.27
00170        GAMRX=0.3
00171        AMRA =AMRO
00172        GAMRA=GAMRO
00173        AMRB =AMKST
00174        GAMRB=GAMKST
00175       ELSEIF(MNUM.EQ.7) THEN
00176        PROB1=0.0
00177        PROB2=1.0
00178        AMRX =1.27
00179        GAMRX=0.9
00180        AMRA =AMRO
00181        GAMRA=GAMRO
00182        AMRB =AMRO
00183        GAMRB=GAMRO
00184       ELSEIF(MNUM.EQ.8) THEN
00185        PROB1=0.0
00186        PROB2=1.0
00187        AMRX =AMROP
00188        GAMRX=GAMROP
00189        AMRB =AMOM
00190        GAMRB=GAMOM
00191        AMRA =AMRO
00192        GAMRA=GAMRO
00193       ELSEIF(MNUM.EQ.9) THEN
00194        PROB1=0.5
00195        PROB2=0.5
00196        AMRX =AMA1
00197        GAMRX=GAMA1
00198        AMRA =AMRO
00199        GAMRA=GAMRO
00200        AMRB =AMRO
00201        GAMRB=GAMRO
00202       ELSEIF(MNUM.EQ.101) THEN
00203        PROB1=.35
00204        PROB2=.35
00205        AMRX =1.2
00206        GAMRX=.46
00207        AMRB =AMOM
00208        GAMRB=GAMOM
00209        AMRA =AMOM
00210        GAMRA=GAMOM
00211       ELSEIF(MNUM.EQ.102) THEN
00212        PROB1=0.0
00213        PROB2=0.0
00214        AMRX =1.4
00215        GAMRX=.6
00216        AMRB =AMOM
00217        GAMRB=GAMOM
00218        AMRA =AMOM
00219        GAMRA=GAMOM
00220       ELSEIF(MNUM.GE.103.AND.MNUM.LE.112) THEN
00221        PROB1=0.0
00222        PROB2=0.0
00223        AMRX =1.4
00224        GAMRX=.6
00225        AMRB =AMOM
00226        GAMRB=GAMOM
00227        AMRA =AMOM
00228        GAMRA=GAMOM
00229 
00230 
00231       ELSE
00232        PROB1=0.0
00233        PROB2=0.0
00234        AMRX =AMA1
00235        GAMRX=GAMA1
00236        AMRA =AMRO
00237        GAMRA=GAMRO
00238        AMRB =AMRO
00239        GAMRB=GAMRO
00240       ENDIF
00241 C
00242       IF    (RR.LE.PROB1) THEN
00243        ICHAN=1
00244       ELSEIF(RR.LE.(PROB1+PROB2)) THEN
00245        ICHAN=2
00246         AX   =AMRA
00247         GX   =GAMRA
00248         AMRA =AMRB
00249         GAMRA=GAMRB
00250         AMRB =AX
00251         GAMRB=GX
00252         PX   =PROB1
00253         PROB1=PROB2
00254         PROB2=PX
00255       ELSE
00256        ICHAN=3
00257       ENDIF
00258 C
00259       PROB3=1.0-PROB1-PROB2
00260       END
00261       SUBROUTINE INITDK
00262 * ----------------------------------------------------------------------
00263 *     INITIALISATION OF TAU DECAY PARAMETERS  and routines
00264 *
00265 *     called by : KORALZ
00266 * ----------------------------------------------------------------------
00267 
00268       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00269       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00270       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00271      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00272      *                 ,AMK,AMKZ,AMKST,GAMKST
00273 *
00274       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00275      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00276      *                 ,AMK,AMKZ,AMKST,GAMKST
00277       COMMON / TAUBRA / GAMPRT(500),JLIST(500),NCHAN
00278       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00279       REAL*4            BRA1,BRK0,BRK0B,BRKS
00280 
00281       PARAMETER (NMODE=86,NM1=0,NM2=11,NM3=19,NM4=22,NM5=21,NM6=13)
00282       COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00283      &                ,NAMES
00284       CHARACTER NAMES(NMODE)*31
00285 
00286       CHARACTER OLDNAMES(7)*31
00287       CHARACTER*80 bxINIT
00288       PARAMETER (
00289      $  bxINIT ='(1x,1h*,g17.8,            16x, a31,a4,a4, 1x,1h*)'
00290      $ )
00291       REAL*4 PI,POL1(4)
00292 *
00293 *
00294 * LIST OF BRANCHING RATIOS
00295 CAM normalised to e nu nutau channel
00296 CAM                  enu   munu   pinu  rhonu   A1nu   Knu    K*nu   pi
00297 CAM   DATA JLIST  /    1,     2,     3,     4,     5,     6,     7,
00298 
00299 *AM   DATA GAMPRT /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,O.O811,0.616
00300 *AM
00301 *AM  multipion decays
00302 *
00303 *    conventions of particles names
00304 *                 K-,P-,K+,  K0,P-,KB,  K-,P0,K0
00305 *                  3, 1,-3  , 4, 1,-4  , 3, 2, 4  ,
00306 *                 P0,P0,K-,  K-,P-,P+,  P-,KB,P0
00307 *                  2, 2, 3  , 3, 1,-1  , 1,-4, 2  ,
00308 *                 ET,P-,P0 , P-,P0,GM  , P-,P0,P0
00309 *                  9, 1, 2  , 1, 2, 8  ,  1, 2, 2
00310 *
00311 
00312 C
00313       DIMENSION NOPIK(9,NMODE),NPIK(NMODE)
00314 *AM   outgoing multiplicity and flavors of multi-pion /multi-K modes    
00315       DATA   NPIK  /                4,                    4,    ! old 4scalar
00316      a                              4,                    4,    ! new (may 2004)
00317      b                              4,                    4,
00318      c                              4,                    4,
00319      d                              4,                    4,
00320      e                              4,                    4,    ! new (may 2004)
00321      e                              4,                    4,    ! new (sep 2004)
00322      e                              4,                    4,    
00323      e                              4,                    4,    
00324      e                              4,                    4,    
00325      e                              4,                    4,    ! new (sep 2004)
00326      1                              5,       
00327      a                              5,                    5,    ! new (may 2004)
00328      b                              5,                    5,
00329      c                              5,                    5,
00330      d                              5,                    5,
00331      e                              5,                    5,    ! new (may 2004)
00332      a                              5,                    5,    ! new (sep 2004)
00333      b                              5,                    5,
00334      c                              5,                    5,
00335      d                              5,                    5,
00336      e                              5,                    5,    ! new (sep 2004)
00337      x                                                    5,    ! old npi starts here
00338      2                              6,                    6,
00339      a                              6,                    6,    ! new (may 2004)
00340      b                              6,                    6,    ! new (may 2004)
00341      c                              6,                    6,    ! new (may 2004)
00342      d                              6,                    6,    ! new (may 2004)
00343      e                              6,                    6,    ! new (may 2004)
00344      3                              3,                    3,            
00345      4                              3,                    3,            
00346      5                              3,                    3,            
00347      6                              3,                    3,  
00348      7                              3,                          ! new (may 2004) and useful
00349      a                              3,                    3,    ! new (may 2004)
00350      a                              3,                    3,    ! new (may 2004)
00351      a                              3,                    3,    ! new (may 2004)
00352      a                              3,                    3,    ! new (may 2004)
00353      a                              3,                    3,    ! new (may 2004)
00354      8                                                    2, 
00355      9                              2,                    2,    ! new (may 2004)
00356      9                              2,                    2,    ! new (may 2004)
00357      9                              2,                    2,    ! new (may 2004)
00358      9                              2,                    2,    ! new (may 2004)
00359      9                              2,                    2/    ! new (may 2004)          
00360 
00361       DATA  NOPIK / -1,-1, 1, 2, 0, 0,3*0,     2, 2, 2,-1, 0, 0,3*0,  
00362      a               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00363      b               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00364      c               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00365      d               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00366      e               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (may 2004)
00367      a               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00368      b               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00369      c               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00370      d               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00371      e               4, 2, 2,-1, 0, 0,3*0,     4, 2, 2,-1, 0, 0,3*0,     ! new (sep 2004)
00372      1              -1,-1, 1, 2, 2, 0,3*0,  
00373      a              -1,-1, 1, 2, 2, 0,3*0,     2, 2, 2, 2, 2, 0,3*0,     ! new (may 2004)
00374      a               1,-1,-1, 2, 2, 0,3*0,    -1, 2, 2, 2, 2, 0,3*0,     ! new (may 2004)
00375      a              -1, 1, 1,-1,-1, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00376      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00377      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (may 2004)
00378      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00379      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00380      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00381      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00382      a              -1,-1, 1, 2, 4, 0,3*0,    -1,-1, 1, 2, 4, 0,3*0,     ! new (sep 2004)
00383      x                                        -1,-1,-1, 1, 1, 0,3*0,     ! old npi starts here
00384      2              -1,-1,-1, 1, 1, 2,3*0,    -1,-1, 1, 2, 2, 2,3*0, 
00385      a              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00386      b              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00387      c              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00388      d              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00389      e              -1,-1,-1, 1, 1, 1,3*0,    -1,-1, 1, 2, 2, 1,3*0,     ! new (may 2004)
00390      3              -3,-1, 3, 0, 0, 0,3*0,    -4,-1, 4, 0, 0, 0,3*0,  
00391      4              -3, 2,-4, 0, 0, 0,3*0,     2, 2,-3, 0, 0, 0,3*0,  
00392      5              -3,-1, 1, 0, 0, 0,3*0,    -1, 4, 2, 0, 0, 0,3*0,  
00393      6               9,-1, 2, 0, 0, 0,3*0,    -1, 2, 8, 0, 0, 0,3*0,
00394 
00395 
00396 C AJWMOD fix sign bug, 2/22/99
00397      7               2, 2,-1, 0, 0, 0,3*0,                           ! new (may 2004) but useful
00398      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00399      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00400      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00401      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00402      7               2, 2, 2, 0, 0, 0,3*0,     2, 2, 2, 0, 0, 0,3*0, ! new (may 2004)
00403 
00404      8                                        -3,-4, 0, 0, 0, 0,3*0,
00405      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00406      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00407      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00408      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0, ! new (may 2004)
00409      8               -3,-3, 0, 0, 0, 0,3*0,   -3,-3, 0, 0, 0, 0,3*0 /! new (may 2004)
00410 
00411 
00412 * LIST OF BRANCHING RATIOS
00413       NCHAN = NMODE + 7
00414       DO 1 I = 1,500
00415       IF (I.LE.NCHAN) THEN
00416         JLIST(I) = I
00417 
00418         IF(I.EQ. 1) GAMPRT(I) =0.1800 
00419         IF(I.EQ. 2) GAMPRT(I) =0.1751 
00420         IF(I.EQ. 3) GAMPRT(I) =0.1110 
00421         IF(I.EQ. 4) GAMPRT(I) =0.2515 
00422         IF(I.EQ. 5) GAMPRT(I) =0.1790 /2
00423         IF(I.EQ. 6) GAMPRT(I) =0.0071 
00424         IF(I.EQ. 7) GAMPRT(I) =0.0134
00425         IF(I.EQ. 8) GAMPRT(I) =0.0450
00426         IF(I.EQ. 9) GAMPRT(I) =0.0100
00427 
00428         IF(I.EQ.30) GAMPRT(I) =0.0009
00429         IF(I.EQ.33) GAMPRT(I) =0.004
00430         IF(I.EQ.34) GAMPRT(I) =0.002
00431         IF(I.EQ.35) GAMPRT(I) =0.001
00432 
00433         IF(I.EQ.51) GAMPRT(I) =0.0004 
00434         IF(I.EQ.52) GAMPRT(I) =0.0003 
00435         IF(I.EQ.53) GAMPRT(I) =0.0005 
00436 
00437         IF(I.EQ.64) GAMPRT(I) =0.0015 
00438         IF(I.EQ.65) GAMPRT(I) =0.0015 
00439         IF(I.EQ.66) GAMPRT(I) =0.0015 
00440         IF(I.EQ.67) GAMPRT(I) =0.0005
00441         IF(I.EQ.68) GAMPRT(I) =0.0050
00442         IF(I.EQ.69) GAMPRT(I) =0.0055
00443         IF(I.EQ.70) GAMPRT(I) =0.0017 
00444         IF(I.EQ.71) GAMPRT(I) =0.0013
00445         IF(I.EQ.72) GAMPRT(I) =0.1790 /2  
00446 
00447         IF(I.EQ.83) GAMPRT(I) =0.0010 
00448 
00449         IF(I.EQ. 1) OLDNAMES(I)='  TAU-  -->   E-               '
00450         IF(I.EQ. 2) OLDNAMES(I)='  TAU-  -->  MU-               '
00451         IF(I.EQ. 3) OLDNAMES(I)='  TAU-  -->  PI-               '
00452         IF(I.EQ. 4) OLDNAMES(I)='  TAU-  -->  PI-, PI0          '
00453         IF(I.EQ. 5) OLDNAMES(I)='  TAU-  -->  PI-, PI-,  PI+    '
00454         IF(I.EQ. 6) OLDNAMES(I)='  TAU-  -->   K-               '
00455         IF(I.EQ. 7) OLDNAMES(I)='  TAU-  -->  K*- (two subch)   '
00456         IF(I.EQ. 8) NAMES(I-7)='  TAU-  --> 2PI-,  PI0,  PI+   '
00457         IF(I.EQ. 9) NAMES(I-7)='  TAU-  --> 3PI0,        PI-   '
00458 
00459         IF(I.EQ.10) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00460         IF(I.EQ.11) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00461         IF(I.EQ.12) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00462         IF(I.EQ.13) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00463         IF(I.EQ.14) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00464         IF(I.EQ.15) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00465         IF(I.EQ.16) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00466         IF(I.EQ.17) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00467         IF(I.EQ.18) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)  
00468         IF(I.EQ.19) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (may 2004)
00469         IF(I.EQ.20) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00470         IF(I.EQ.21) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00471         IF(I.EQ.22) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00472         IF(I.EQ.23) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00473         IF(I.EQ.24) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00474         IF(I.EQ.25) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00475         IF(I.EQ.26) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00476         IF(I.EQ.27) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00477         IF(I.EQ.28) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)  
00478         IF(I.EQ.29) NAMES(I-7)='  TAU-  --> xxxxxxx4xxxxxxxx   '  !  (sep 2004)
00479 
00480 
00481         IF(I.EQ.30) NAMES(I-7)='  TAU-  --> 2PI-, PI+, 2PI0 old'
00482         IF(I.EQ.31) NAMES(I-7)='  TAU-  --> a1 --> rho omega   '  !  (may 2004)
00483         IF(I.EQ.32) NAMES(I-7)='  TAU-  --> benchmark curr     '  !  (may 2004)
00484         IF(I.EQ.33) NAMES(I-7)='  TAU-  --> 2PI0, 2PI-,  PI+   '  !  (may 2004)
00485         IF(I.EQ.34) NAMES(I-7)='  TAU-  --> PI- 4PI0           '  !  (may 2004)
00486         IF(I.EQ.35) NAMES(I-7)='  TAU-  --> 3PI- 2PI+          '  !  (may 2004)
00487         IF(I.EQ.36) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00488         IF(I.EQ.37) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00489         IF(I.EQ.38) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00490         IF(I.EQ.39) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00491         IF(I.EQ.40) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (may 2004)
00492 
00493         IF(I.EQ.41) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00494         IF(I.EQ.42) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00495         IF(I.EQ.43) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00496         IF(I.EQ.44) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00497         IF(I.EQ.45) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00498         IF(I.EQ.46) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00499         IF(I.EQ.47) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00500         IF(I.EQ.48) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00501         IF(I.EQ.49) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00502         IF(I.EQ.50) NAMES(I-7)='  TAU-  --> xxxxxxxxx5xxxxxx   '  !  (sep 2004)
00503 
00504         IF(I.EQ.51) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,        '
00505         IF(I.EQ.52) NAMES(I-7)='  TAU-  --> 3PI-, 2PI+,  PI0   '
00506         IF(I.EQ.53) NAMES(I-7)='  TAU-  --> 2PI-,  PI+, 3PI0   '
00507         IF(I.EQ.54) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00508         IF(I.EQ.55) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00509         IF(I.EQ.56) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00510         IF(I.EQ.57) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00511         IF(I.EQ.58) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00512         IF(I.EQ.59) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00513         IF(I.EQ.60) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00514         IF(I.EQ.61) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00515         IF(I.EQ.62) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00516         IF(I.EQ.63) NAMES(I-7)='  TAU-  --> xxxxxxxxxnxxxxxx   '  !  (may 2004)
00517 
00518         IF(I.EQ.64) NAMES(I-7)='  TAU-  -->  K-, PI-,  K+      '
00519         IF(I.EQ.65) NAMES(I-7)='  TAU-  -->  K0, PI-, K0B      '
00520 
00521         IF(I.EQ.66) NAMES(I-7)='  TAU-  -->  K-,  K0, PI0      '
00522 
00523         IF(I.EQ.67) NAMES(I-7)='  TAU-  --> PI0  PI0   K-      '
00524         IF(I.EQ.68) NAMES(I-7)='  TAU-  -->  K-  PI-  PI+      '
00525         IF(I.EQ.69) NAMES(I-7)='  TAU-  --> PI-  K0B  PI0      '
00526         IF(I.EQ.70) NAMES(I-7)='  TAU-  --> ETA  PI-  PI0      '
00527         IF(I.EQ.71) NAMES(I-7)='  TAU-  --> PI-  PI0  GAM      '
00528         IF(I.EQ.72) NAMES(I-7)='  TAU-  --> PI-  PI0  PI0      '
00529         IF(I.EQ.73) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00530         IF(I.EQ.74) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00531         IF(I.EQ.75) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00532         IF(I.EQ.76) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00533         IF(I.EQ.77) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00534         IF(I.EQ.78) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00535         IF(I.EQ.79) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00536         IF(I.EQ.80) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00537         IF(I.EQ.81) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00538         IF(I.EQ.82) NAMES(I-7)='  TAU-  --> xxxxxxxxx3xxxxxx   '  !  (may 2004)
00539  
00540 
00541         IF(I.EQ.83) NAMES(I-7)='  TAU-  -->  K-  K0            '
00542         IF(I.EQ.84) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00543         IF(I.EQ.85) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00544         IF(I.EQ.86) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00545         IF(I.EQ.87) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00546         IF(I.EQ.88) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00547         IF(I.EQ.89) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00548         IF(I.EQ.90) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00549         IF(I.EQ.91) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00550         IF(I.EQ.92) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00551         IF(I.EQ.93) NAMES(I-7)='  TAU-  --> xxxxxxxxx2xxxxxx   '  !  (may 2004)
00552 
00553       ELSE
00554         JLIST(I) = 0
00555         GAMPRT(I) = 0.
00556       ENDIF
00557    1  CONTINUE
00558       DO I=1,NMODE
00559         MULPIK(I)=NPIK(I)
00560         DO J=1,MULPIK(I)
00561          IDFFIN(J,I)=NOPIK(J,I)
00562         ENDDO
00563       ENDDO
00564         DO I=1,NCHAN
00565          GAMPRT(I) = 1D0/NCHAN
00566         ENDDO
00567           gamprt(31)=gamprt(31)*0.001
00568           gamprt(32)=gamprt(32)*0.001
00569         do k=1,10  ! these are brs for empty slots prepared for new channels 
00570           gamprt(36+k)=gamprt(36+k)*0.001
00571           gamprt(30-k)=gamprt(30-k)*0.001
00572           gamprt(30+10+k)=gamprt(30+10+k)*0.001
00573           gamprt(30-10-k)=gamprt(30-10-k)*0.001
00574 
00575           gamprt(53+k)=gamprt(53+k)*0.001
00576           gamprt(72+k)=gamprt(72+k)*0.001
00577           gamprt(83+k)=gamprt(83+k)*0.001
00578         enddo
00579          GAMPRT(72)=GAMPRT(72)/2
00580          GAMPRT(5)=GAMPRT(5)/2
00581 
00582 *
00583 *
00584 * --- COEFFICIENTS TO FIX RATIO OF:
00585 * --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
00586 * --- PROBABILITY OF K0 TO BE KS
00587 * --- PROBABILITY OF K0B TO BE KS
00588 * --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
00589 * --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
00590 * --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
00591 * --- NEGLECTS MASS-PHASE SPACE EFFECTS
00592       BRA1=1D0 ! 0.5
00593       BRK0=0.5
00594       BRK0B=0.5
00595       BRKS=0.6667
00596 *
00597 
00598       GFERMI = 1.16637E-5
00599       CCABIB = 0.975
00600       GV     = 1.0
00601       GA     =-1.0
00602 
00603 
00604 
00605 * ZW 13.04.89 HERE WAS AN ERROR
00606       SCABIB = SQRT(1.-CCABIB**2)
00607       PI =4.*ATAN(1.)
00608       GAMEL  = GFERMI**2*AMTAU**5/(192*PI**3)
00609 *
00610       CALL DEXAY(-1,pol1)
00611 *
00612       RETURN
00613       END
00614       FUNCTION DCDMAS(IDENT)
00615       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00616      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00617      *                 ,AMK,AMKZ,AMKST,GAMKST
00618 *
00619       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00620      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00621      *                 ,AMK,AMKZ,AMKST,GAMKST
00622       IF      (IDENT.EQ. 1) THEN
00623         APKMAS=AMPI
00624       ELSEIF  (IDENT.EQ.-1) THEN
00625         APKMAS=AMPI
00626       ELSEIF  (IDENT.EQ. 2) THEN
00627         APKMAS=AMPIZ
00628       ELSEIF  (IDENT.EQ.-2) THEN
00629         APKMAS=AMPIZ
00630       ELSEIF  (IDENT.EQ. 3) THEN
00631         APKMAS=AMK
00632       ELSEIF  (IDENT.EQ.-3) THEN
00633         APKMAS=AMK
00634       ELSEIF  (IDENT.EQ. 4) THEN
00635         APKMAS=AMKZ
00636       ELSEIF  (IDENT.EQ.-4) THEN
00637         APKMAS=AMKZ
00638       ELSEIF  (IDENT.EQ. 8) THEN
00639         APKMAS=0.0001
00640       ELSEIF  (IDENT.EQ.-8) THEN
00641         APKMAS=0.0001
00642       ELSEIF  (IDENT.EQ. 9) THEN
00643         APKMAS=0.5488
00644       ELSEIF  (IDENT.EQ.-9) THEN
00645         APKMAS=0.5488
00646       ELSE
00647         PRINT *, 'STOP IN APKMAS, WRONG IDENT=',IDENT
00648         STOP
00649       ENDIF
00650       DCDMAS=APKMAS
00651       END
00652       FUNCTION LUNPIK(ID,ISGN)
00653       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00654       REAL*4            BRA1,BRK0,BRK0B,BRKS
00655       REAL*4 XIO(1)
00656       IDENT=ID*ISGN
00657 
00658       IF      (IDENT.EQ. 1) THEN
00659         IPKDEF=-211
00660       ELSEIF  (IDENT.EQ.-1) THEN
00661         IPKDEF= 211
00662       ELSEIF  (IDENT.EQ. 2) THEN
00663         IPKDEF=111
00664       ELSEIF  (IDENT.EQ.-2) THEN
00665         IPKDEF=111
00666       ELSEIF  (IDENT.EQ. 3) THEN
00667         IPKDEF=-321
00668       ELSEIF  (IDENT.EQ.-3) THEN
00669         IPKDEF= 321
00670 
00671       ELSEIF  (IDENT.EQ. 4) THEN
00672 *
00673 * K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00674         CALL RANMAR(XIO,1)
00675         IF (XIO(1).GT.BRK0) THEN
00676           IPKDEF= 130
00677         ELSE
00678           IPKDEF= 310
00679         ENDIF
00680       ELSEIF  (IDENT.EQ.-4) THEN
00681 *
00682 * K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
00683         CALL RANMAR(XIO,1)
00684         IF (XIO(1).GT.BRK0B) THEN
00685           IPKDEF= 130
00686         ELSE
00687           IPKDEF= 310
00688         ENDIF
00689       ELSEIF  (IDENT.EQ. 8) THEN
00690         IPKDEF= 22
00691       ELSEIF  (IDENT.EQ.-8) THEN
00692         IPKDEF= 22
00693       ELSEIF  (IDENT.EQ. 9) THEN
00694         IPKDEF= 221
00695       ELSEIF  (IDENT.EQ.-9) THEN
00696         IPKDEF= 221
00697       ELSE
00698         PRINT *, 'STOP IN IPKDEF, WRONG IDENT=',IDENT
00699         STOP
00700       ENDIF
00701       LUNPIK=IPKDEF
00702       END
00703 
00704 
00705 
00706 
00707       SUBROUTINE TAURDF(KTO)
00708 C THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
00709 C IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
00710 C CONTENTS
00711       COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
00712       REAL*4            BRA1,BRK0,BRK0B,BRKS
00713       COMMON / TAUBRA / GAMPRT(500),JLIST(500),NCHAN
00714       IF (KTO.EQ.1) THEN
00715 C     ==================
00716 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00717       BRA1 = PKORB(4,1)
00718       BRKS = PKORB(4,3)
00719       BRK0  = PKORB(4,5)
00720       BRK0B  = PKORB(4,6)
00721       ELSE
00722 C     ====
00723 C AJWMOD: Set the BRs for (A1+ -> rho+ pi0) and (K*+ -> K0 pi+)
00724       BRA1 = PKORB(4,2)
00725       BRKS = PKORB(4,4)
00726       BRK0  = PKORB(4,5)
00727       BRK0B  = PKORB(4,6)
00728       ENDIF
00729 C     =====
00730       END
00731 
00732 
00733       SUBROUTINE INIPHX(XK00)
00734 * ----------------------------------------------------------------------
00735 *     INITIALISATION OF PARAMETERS
00736 *     USED IN QED and/or GSW ROUTINES
00737 * ----------------------------------------------------------------------
00738       COMMON / QEDPRM /ALFINV,ALFPI,XK0
00739       REAL*8           ALFINV,ALFPI,XK0
00740       REAL*8 PI8,XK00
00741 *
00742       PI8    = 4.D0*DATAN(1.D0)
00743       ALFINV = 137.03604D0
00744       ALFPI  = 1D0/(ALFINV*PI8)
00745       XK0=XK00
00746       END
00747 
00748       SUBROUTINE INIMAS
00749 C ----------------------------------------------------------------------
00750 C     INITIALISATION OF MASSES
00751 C
00752 C     called by : KORALZ
00753 C ----------------------------------------------------------------------
00754       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00755      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00756      *                 ,AMK,AMKZ,AMKST,GAMKST
00757 *
00758       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00759      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00760      *                 ,AMK,AMKZ,AMKST,GAMKST
00761 C
00762 C IN-COMING / OUT-GOING  FERMION MASSES
00763       AMTAU  = 1.7842
00764 C --- tau mass must be the same as in the host program, what-so-ever
00765       AMTAU  = 1.777
00766       AMNUTA = 0.010
00767       AMEL   = 0.0005111
00768       AMNUE  = 0.0
00769       AMMU   = 0.105659 
00770       AMNUMU = 0.0
00771 *
00772 * MASSES USED IN TAU DECAYS
00773 
00774       AMPIZ  = 0.134964
00775       AMPI   = 0.139568
00776       AMRO   = 0.773
00777       GAMRO  = 0.145
00778 *C    GAMRO  = 0.666
00779       AMA1   = 1.251
00780       GAMA1  = 0.599
00781       AMK    = 0.493667
00782       AMKZ   = 0.49772
00783       AMKST  = 0.8921
00784       GAMKST = 0.0513
00785 C
00786 C
00787 C IN-COMING / OUT-GOING  FERMION MASSES
00788 !!      AMNUTA = PKORB(1,2)
00789 !!      AMNUE  = PKORB(1,4)
00790 !!      AMNUMU = PKORB(1,6)
00791 C
00792 C MASSES USED IN TAU DECAYS  Cleo settings
00793 !!      AMPIZ  = PKORB(1,7)
00794 !!      AMPI   = PKORB(1,8)
00795 !!      AMRO   = PKORB(1,9)
00796 !!      GAMRO  = PKORB(2,9)
00797       AMA1   = 1.275   !! PKORB(1,10)
00798       GAMA1  = 0.615   !! PKORB(2,10)
00799 !!      AMK    = PKORB(1,11)
00800 !!      AMKZ   = PKORB(1,12)
00801 !!      AMKST  = PKORB(1,13)
00802 !!      GAMKST = PKORB(2,13)
00803 C
00804 
00805 
00806       RETURN
00807       END
00808       subroutine bostdq(idir,vv,pp,q)
00809 *     *******************************
00810 c Boost along arbitrary vector v (see eg. J.D. Jacson, Classical 
00811 c Electrodynamics).
00812 c Four-vector pp is boosted from an actual frame to the rest frame 
00813 c of the four-vector v (for idir=1) or back (for idir=-1). 
00814 c q is a resulting four-vector.
00815 c Note: v must be time-like, pp may be arbitrary.
00816 c
00817 c Written by: Wieslaw Placzek            date: 22.07.1994
00818 c Last update: 3/29/95                     by: M.S.
00819 c 
00820       implicit DOUBLE PRECISION (a-h,o-z)
00821       parameter (nout=6)
00822       DOUBLE PRECISION v(4),p(4),q(4),pp(4),vv(4)  
00823       save
00824 !
00825       do 1 i=1,4
00826       v(i)=vv(i)
00827  1    p(i)=pp(i)
00828       amv=(v(4)**2-v(1)**2-v(2)**2-v(3)**2)
00829       if (amv.le.0d0) then
00830         write(6,*) 'bosstv: warning amv**2=',amv
00831       endif
00832       amv=sqrt(abs(amv))
00833       if (idir.eq.-1) then
00834         q(4)=( p(1)*v(1)+p(2)*v(2)+p(3)*v(3)+p(4)*v(4))/amv
00835         wsp =(q(4)+p(4))/(v(4)+amv)
00836       elseif (idir.eq.1) then
00837         q(4)=(-p(1)*v(1)-p(2)*v(2)-p(3)*v(3)+p(4)*v(4))/amv
00838         wsp =-(q(4)+p(4))/(v(4)+amv)
00839       else
00840         write(nout,*)' >>> boostv: wrong value of idir = ',idir
00841       endif
00842       q(1)=p(1)+wsp*v(1)
00843       q(2)=p(2)+wsp*v(2)
00844       q(3)=p(3)+wsp*v(3)
00845       end
00846         
00847 
00848 
00849 
00850 
00851 
00852 
00853 
00854 
00855