00001 #if defined (ALEPH)
00002 C=============================================================
00003 #endif
00004 SUBROUTINE JAKER(JAK)
00005 C *********************
00006 C
00007 C **********************************************************************
00008 C *
00009 #if defined (ALEPH)
00010 C *********TAUOLA LIBRARY: VERSION 2.7 ******** *
00011 C **************DECEMBER 1993****************** *
00012 #else
00013 C *********TAUOLA LIBRARY: VERSION 2.7 ******** *
00014 C **************August 1995****************** *
00015 #endif
00016 C ** AUTHORS: S.JADACH, Z.WAS ***** *
00017 C ** R. DECKER, M. JEZABEK, J.H.KUEHN, ***** *
00018 C ********AVAILABLE FROM: WASM AT CERNVM ****** *
00019 C *******PUBLISHED IN COMP. PHYS. COMM.******** *
00020 C *** PREPRINT CERN-TH-5856 SEPTEMBER 1990 **** *
00021 C *** PREPRINT CERN-TH-6195 OCTOBER 1991 **** *
00022 C *** PREPRINT CERN-TH-6793 NOVEMBER 1992 **** *
00023 C **********************************************************************
00024 C
00025 C ----------------------------------------------------------------------
00026 c SUBROUTINE JAKER,
00027 C CHOOSES DECAY MODE ACCORDING TO LIST OF BRANCHING RATIOS
00028 C JAK=1 ELECTRON MODE
00029 C JAK=2 MUON MODE
00030 C JAK=3 PION MODE
00031 C JAK=4 RHO MODE
00032 C JAK=5 A1 MODE
00033 C JAK=6 K MODE
00034 C JAK=7 K* MODE
00035 #if defined (ALEPH)
00036 C JAK=8-13 npi modes
00037 C JAK=14-19 KKpi & Kpipi modes
00038 C JAK=20-21 eta pi pi; gamma pi pi modes
00039 #else
00040 C JAK=8 nPI MODE
00041 #endif
00042 C
00043 C called by : DEXAY
00044 C ----------------------------------------------------------------------
00045 COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
00046 #if defined (ALEPH)
00047 #else
00048 C REAL CUMUL(20)
00049 #endif
00050 REAL CUMUL(30),RRR(1)
00051 C
00052 IF(NCHAN.LE.0.OR.NCHAN.GT.30) GOTO 902
00053 CALL RANMAR(RRR,1)
00054 SUM=0
00055 DO 20 I=1,NCHAN
00056 SUM=SUM+GAMPRT(I)
00057 20 CUMUL(I)=SUM
00058 DO 25 I=NCHAN,1,-1
00059 IF(RRR(1).LT.CUMUL(I)/CUMUL(NCHAN)) JI=I
00060 25 CONTINUE
00061 JAK=JLIST(JI)
00062 RETURN
00063 902 PRINT 9020
00064 9020 FORMAT(' ----- JAKER: WRONG NCHAN')
00065 STOP
00066 END
00067 SUBROUTINE DEKAY(KTO,HX)
00068 C ***********************
00069 C THIS DEKAY IS IN SPIRIT OF THE 'DECAY' WHICH
00070 C WAS INCLUDED IN KORAL-B PROGRAM, COMP. PHYS. COMMUN.
00071 C VOL. 36 (1985) 191, SEE COMMENTS ON GENERAL PHILOSOPHY THERE.
00072 C KTO=0 INITIALISATION (OBLIGATORY)
00073 C KTO=1,11 DENOTES TAU+ AND KTO=2,12 TAU-
00074 C DEKAY(1,H) AND DEKAY(2,H) IS CALLED INTERNALLY BY MC GENERATOR.
00075 C H DENOTES THE POLARIMETRIC VECTOR, USED BY THE HOST PROGRAM FOR
00076 C CALCULATION OF THE SPIN WEIGHT.
00077 C USER MAY OPTIONALLY CALL DEKAY(11,H) DEKAY(12,H) IN ORDER
00078 C TO TRANSFORM DECAY PRODUCTS TO CMS AND WRITE LUND RECORD IN /LUJETS/.
00079 C KTO=100, PRINT FINAL REPORT (OPTIONAL).
00080 C DECAY MODES:
00081 C JAK=1 ELECTRON DECAY
00082 C JAK=2 MU DECAY
00083 C JAK=3 PI DECAY
00084 C JAK=4 RHO DECAY
00085 C JAK=5 A1 DECAY
00086 C JAK=6 K DECAY
00087 C JAK=7 K* DECAY
00088 #if defined (ALEPH)
00089 C JAK= 8-13 npi modes
00090 C JAK=14-19 KKpi & Kpipi modes
00091 C JAK=20-21 eta pi pi; gamma pi pi modes
00092 C JAK=0 INCLUSIVE: JAK=1-21
00093 #else
00094 C JAK=8 NPI DECAY
00095 C JAK=0 INCLUSIVE: JAK=1,2,3,4,5,6,7,8
00096 #endif
00097 REAL H(4)
00098 REAL*8 HX(4)
00099 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
00100 #if defined (ALEPH)
00101 COMMON / IDFC / IDFF
00102 #else
00103 COMMON / IDFC / IDF
00104 #endif
00105 COMMON /TAUPOS/ NP1,NP2
00106 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
00107 REAL*4 GAMPMC ,GAMPER
00108 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
00109 #if defined (ALEPH)
00110 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00111 #else
00112 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00113 #endif
00114 & ,NAMES
00115 CHARACTER NAMES(NMODE)*31
00116 COMMON / INOUT / INUT,IOUT
00117 REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4),HDUM(4)
00118 REAL PDUMX(4,9)
00119 DATA IWARM/0/
00120 KTOM=KTO
00121 #if defined (ALEPH)
00122 IDF =IDFF
00123 #endif
00124 IF(KTO.EQ.-1) THEN
00125 C ==================
00126 C INITIALISATION OR REINITIALISATION
00127 C first or second tau positions in HEPEVT as in KORALB/Z
00128 NP1=3
00129 NP2=4
00130 KTOM=1
00131 IF (IWARM.EQ.1) X=5/(IWARM-1)
00132 IWARM=1
00133 WRITE(IOUT,7001) JAK1,JAK2
00134 NEVTOT=0
00135 NEV1=0
00136 NEV2=0
00137 IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
00138 CALL DADMEL(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00139 CALL DADMMU(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00140 CALL DADMPI(-1,IDUM,PDUM,PDUM1,PDUM2)
00141 CALL DADMRO(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4)
00142 CALL DADMAA(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JDUM)
00143 CALL DADMKK(-1,IDUM,PDUM,PDUM1,PDUM2)
00144 CALL DADMKS(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,JDUM)
00145 CALL DADNEW(-1,IDUM,HDUM,PDUM1,PDUM2,PDUMX,JDUM)
00146 ENDIF
00147 DO 21 I=1,30
00148 NEVDEC(I)=0
00149 GAMPMC(I)=0
00150 21 GAMPER(I)=0
00151 ELSEIF(KTO.EQ.1) THEN
00152 C =====================
00153 C DECAY OF TAU+ IN THE TAU REST FRAME
00154 NEVTOT=NEVTOT+1
00155 IF(IWARM.EQ.0) GOTO 902
00156 ISGN= IDF/IABS(IDF)
00157 #if defined (CePeCe)
00158 #elif defined (ALEPH)
00159 #else
00160 C AJWMOD to change BRs depending on sign:
00161 CALL TAURDF(KTO)
00162 #endif
00163 CALL DEKAY1(0,H,ISGN)
00164 ELSEIF(KTO.EQ.2) THEN
00165 C =================================
00166 C DECAY OF TAU- IN THE TAU REST FRAME
00167 NEVTOT=NEVTOT+1
00168 IF(IWARM.EQ.0) GOTO 902
00169 ISGN=-IDF/IABS(IDF)
00170 #if defined (CePeCe)
00171 #elif defined (ALEPH)
00172 #else
00173 C AJWMOD to change BRs depending on sign:
00174 CALL TAURDF(KTO)
00175 #endif
00176 CALL DEKAY2(0,H,ISGN)
00177 ELSEIF(KTO.EQ.11) THEN
00178 C ======================
00179 C REST OF DECAY PROCEDURE FOR ACCEPTED TAU+ DECAY
00180 NEV1=NEV1+1
00181 ISGN= IDF/IABS(IDF)
00182 CALL DEKAY1(1,H,ISGN)
00183 ELSEIF(KTO.EQ.12) THEN
00184 C ======================
00185 C REST OF DECAY PROCEDURE FOR ACCEPTED TAU- DECAY
00186 NEV2=NEV2+1
00187 ISGN=-IDF/IABS(IDF)
00188 CALL DEKAY2(1,H,ISGN)
00189 ELSEIF(KTO.EQ.100) THEN
00190 C =======================
00191 IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
00192 CALL DADMEL( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00193 CALL DADMMU( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00194 CALL DADMPI( 1,IDUM,PDUM,PDUM1,PDUM2)
00195 CALL DADMRO( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4)
00196 CALL DADMAA( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JDUM)
00197 CALL DADMKK( 1,IDUM,PDUM,PDUM1,PDUM2)
00198 CALL DADMKS( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,JDUM)
00199 CALL DADNEW( 1,IDUM,HDUM,PDUM1,PDUM2,PDUMX,JDUM)
00200 WRITE(IOUT,7010) NEV1,NEV2,NEVTOT
00201 WRITE(IOUT,7011) (NEVDEC(I),GAMPMC(I),GAMPER(I),I= 1,7)
00202 WRITE(IOUT,7012)
00203 $ (NEVDEC(I),GAMPMC(I),GAMPER(I),NAMES(I-7),I=8,7+NMODE)
00204 WRITE(IOUT,7013)
00205 ENDIF
00206 ELSE
00207 C ====
00208 GOTO 910
00209 ENDIF
00210 C =====
00211 DO 78 K=1,4
00212 78 HX(K)=H(K)
00213 RETURN
00214 7001 FORMAT(///1X,15(5H*****)
00215 #if defined (ALEPH)
00216 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00217 $ /,' *', 25X,'*DEC 1993; ALEPH fixes introd. dec 98 *',9X,1H*,
00218 $ /,' *', 25X,'**AUTHORS: S.JADACH, Z.WAS*************',9X,1H*,
00219 $ /,' *', 25X,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9X,1H*,
00220 $ /,' *', 25X,'***** PUBLISHED IN COMP. PHYS. COMM.***',9X,1H*,
00221 $ /,' *', 25X,'Physics initialization by ALEPH collab ',9X,1H*,
00222 $ /,' *', 25X,'it is suggested to use this version ',9X,1H*,
00223 $ /,' *', 25X,' with the help of the collab. advice ',9X,1H*,
00224 $ /,' *', 25X,'*******CERN TH-6793 NOVEMBER 1992*****',9X,1H*,
00225 $ /,' *', 25X,'**5 or more pi dec.: precision limited ',9X,1H*,
00226 #elif defined (CLEO)
00227 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00228 $ /,' *', 25X,'***********August 1995***************',9X,1H*,
00229 $ /,' *', 25X,'**AUTHORS: S.JADACH, Z.WAS*************',9X,1H*,
00230 $ /,' *', 25X,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9X,1H*,
00231 $ /,' *', 25X,'**AVAILABLE FROM: WASM AT CERNVM ******',9X,1H*,
00232 $ /,' *', 25X,'***** PUBLISHED IN COMP. PHYS. COMM.***',9X,1H*,
00233 $ /,' *', 25X,' Physics initialization by CLEO collab ',9X,1H*,
00234 $ /,' *', 25X,' see Alain Weinstein www home page: ',9X,1H*,
00235 $ /,' *', 25X,'http://www.cithep.caltech.edu/~ajw/ ',9X,1H*,
00236 $ /,' *', 25X,'/korb_doc.html#files ',9X,1H*,
00237 $ /,' *', 25X,'*******CERN TH-6793 NOVEMBER 1992*****',9X,1H*,
00238 $ /,' *', 25X,'**5 or more pi dec.: precision limited ',9X,1H*,
00239 #else
00240 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00241 $ /,' *', 25X,'***********August 1995***************',9X,1H*,
00242 $ /,' *', 25X,'**AUTHORS: S.JADACH, Z.WAS*************',9X,1H*,
00243 $ /,' *', 25X,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9X,1H*,
00244 $ /,' *', 25X,'**AVAILABLE FROM: WASM AT CERNVM ******',9X,1H*,
00245 $ /,' *', 25X,'***** PUBLISHED IN COMP. PHYS. COMM.***',9X,1H*,
00246 $ /,' *', 25X,'*******CERN-TH-5856 SEPTEMBER 1990*****',9X,1H*,
00247 $ /,' *', 25X,'*******CERN-TH-6195 SEPTEMBER 1991*****',9X,1H*,
00248 $ /,' *', 25X,'*******CERN TH-6793 NOVEMBER 1992*****',9X,1H*,
00249 $ /,' *', 25X,'**5 or more pi dec.: precision limited ',9X,1H*,
00250 #endif
00251 $ /,' *', 25X,'****DEKAY ROUTINE: INITIALIZATION******',9X,1H*,
00252 $ /,' *',I20 ,5X,'JAK1 = DECAY MODE TAU+ ',9X,1H*,
00253 $ /,' *',I20 ,5X,'JAK2 = DECAY MODE TAU- ',9X,1H*,
00254 $ /,1X,15(5H*****)/)
00255 7010 FORMAT(///1X,15(5H*****)
00256 #if defined (ALEPH)
00257 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00258 $ /,' *', 25X,'***********DECEMBER 1993***************',9X,1H*,
00259 #else
00260 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00261 $ /,' *', 25X,'***********August 1995***************',9X,1H*,
00262 #endif
00263 $ /,' *', 25X,'**AUTHORS: S.JADACH, Z.WAS*************',9X,1H*,
00264 $ /,' *', 25X,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9X,1H*,
00265 $ /,' *', 25X,'**AVAILABLE FROM: WASM AT CERNVM ******',9X,1H*,
00266 $ /,' *', 25X,'***** PUBLISHED IN COMP. PHYS. COMM.***',9X,1H*,
00267 $ /,' *', 25X,'*******CERN-TH-5856 SEPTEMBER 1990*****',9X,1H*,
00268 $ /,' *', 25X,'*******CERN-TH-6195 SEPTEMBER 1991*****',9X,1H*,
00269 $ /,' *', 25X,'*******CERN TH-6793 NOVEMBER 1992*****',9X,1H*,
00270 $ /,' *', 25X,'*****DEKAY ROUTINE: FINAL REPORT*******',9X,1H*,
00271 $ /,' *',I20 ,5X,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9X,1H*,
00272 $ /,' *',I20 ,5X,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9X,1H*,
00273 $ /,' *',I20 ,5X,'NEVTOT = SUM ',9X,1H*,
00274 $ /,' *',' NOEVTS ',
00275 $ ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9X,1H*)
00276 7011 FORMAT(1X,'*'
00277 $ ,I10,2F12.7 ,' DADMEL ELECTRON ',9X,1H*
00278 $ /,' *',I10,2F12.7 ,' DADMMU MUON ',9X,1H*
00279 $ /,' *',I10,2F12.7 ,' DADMPI PION ',9X,1H*
00280 $ /,' *',I10,2F12.7, ' DADMRO RHO (->2PI) ',9X,1H*
00281 $ /,' *',I10,2F12.7, ' DADMAA A1 (->3PI) ',9X,1H*
00282 $ /,' *',I10,2F12.7, ' DADMKK KAON ',9X,1H*
00283 $ /,' *',I10,2F12.7, ' DADMKS K* ',9X,1H*)
00284 7012 FORMAT(1X,'*'
00285 $ ,I10,2F12.7,A31 ,8X,1H*)
00286 7013 FORMAT(1X,'*'
00287 $ ,20X,'THE ERROR IS RELATIVE AND PART.WIDTH ',10X,1H*
00288 $ /,' *',20X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',10X,1H*
00289 $ /,1X,15(5H*****)/)
00290 902 PRINT 9020
00291 9020 FORMAT(' ----- DEKAY: LACK OF INITIALISATION')
00292 STOP
00293 910 PRINT 9100
00294 9100 FORMAT(' ----- DEKAY: WRONG VALUE OF KTO ')
00295 STOP
00296 END
00297 SUBROUTINE DEKAY1(IMOD,HH,ISGN)
00298 C *******************************
00299 C THIS ROUTINE SIMULATES TAU+ DECAY
00300 #if defined (ALEPH)
00301 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
00302 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
00303 REAL*4 GAMPMC ,GAMPER
00304 COMMON / DECP4 / PP1(4),PP2(4),KFF1,KFF2
00305 REAL*4 PP1 ,PP2
00306 INTEGER KFF1,KFF2
00307 #else
00308 COMMON / DECP4 / PP1(4),PP2(4),KF1,KF2
00309 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
00310 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
00311 REAL*4 GAMPMC ,GAMPER
00312 #endif
00313 REAL HH(4)
00314 REAL HV(4),PNU(4),PPI(4)
00315 REAL PWB(4),PMU(4),PNM(4)
00316 REAL PRHO(4),PIC(4),PIZ(4)
00317 REAL PAA(4),PIM1(4),PIM2(4),PIPL(4)
00318 REAL PKK(4),PKS(4)
00319 REAL PNPI(4,9)
00320 REAL PHOT(4)
00321 REAL PDUM(4)
00322 DATA NEV,NPRIN/0,10/
00323 KTO=1
00324 IF(JAK1.EQ.-1) RETURN
00325 IMD=IMOD
00326 IF(IMD.EQ.0) THEN
00327 C =================
00328 JAK=JAK1
00329 IF(JAK1.EQ.0) CALL JAKER(JAK)
00330 IF(JAK.EQ.1) THEN
00331 CALL DADMEL(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
00332 ELSEIF(JAK.EQ.2) THEN
00333 CALL DADMMU(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
00334 ELSEIF(JAK.EQ.3) THEN
00335 CALL DADMPI(0, ISGN,HV,PPI,PNU)
00336 ELSEIF(JAK.EQ.4) THEN
00337 CALL DADMRO(0, ISGN,HV,PNU,PRHO,PIC,PIZ)
00338 ELSEIF(JAK.EQ.5) THEN
00339 CALL DADMAA(0, ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
00340 ELSEIF(JAK.EQ.6) THEN
00341 CALL DADMKK(0, ISGN,HV,PKK,PNU)
00342 ELSEIF(JAK.EQ.7) THEN
00343 CALL DADMKS(0, ISGN,HV,PNU,PKS ,PKK,PPI,JKST)
00344 ELSE
00345 CALL DADNEW(0, ISGN,HV,PNU,PWB,PNPI,JAK-7)
00346 ENDIF
00347 DO 33 I=1,3
00348 33 HH(I)=HV(I)
00349 HH(4)=1.0
00350
00351 ELSEIF(IMD.EQ.1) THEN
00352 C =====================
00353 NEV=NEV+1
00354 IF (JAK.LT.31) THEN
00355 NEVDEC(JAK)=NEVDEC(JAK)+1
00356 ENDIF
00357 DO 34 I=1,4
00358 34 PDUM(I)=.0
00359 IF(JAK.EQ.1) THEN
00360 CALL DWLUEL(1,ISGN,PNU,PWB,PMU,PNM)
00361 CALL DWRPH(KTOM,PHOT)
00362 DO 10 I=1,4
00363 10 PP1(I)=PMU(I)
00364
00365 ELSEIF(JAK.EQ.2) THEN
00366 CALL DWLUMU(1,ISGN,PNU,PWB,PMU,PNM)
00367 CALL DWRPH(KTOM,PHOT)
00368 DO 20 I=1,4
00369 20 PP1(I)=PMU(I)
00370
00371 ELSEIF(JAK.EQ.3) THEN
00372 CALL DWLUPI(1,ISGN,PPI,PNU)
00373 DO 30 I=1,4
00374 30 PP1(I)=PPI(I)
00375
00376 ELSEIF(JAK.EQ.4) THEN
00377 CALL DWLURO(1,ISGN,PNU,PRHO,PIC,PIZ)
00378 DO 40 I=1,4
00379 40 PP1(I)=PRHO(I)
00380
00381 ELSEIF(JAK.EQ.5) THEN
00382 CALL DWLUAA(1,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
00383 DO 50 I=1,4
00384 50 PP1(I)=PAA(I)
00385 ELSEIF(JAK.EQ.6) THEN
00386 CALL DWLUKK(1,ISGN,PKK,PNU)
00387 DO 60 I=1,4
00388 60 PP1(I)=PKK(I)
00389 ELSEIF(JAK.EQ.7) THEN
00390 CALL DWLUKS(1,ISGN,PNU,PKS,PKK,PPI,JKST)
00391 DO 70 I=1,4
00392 70 PP1(I)=PKS(I)
00393 ELSE
00394 CAM MULTIPION DECAY
00395 CALL DWLNEW(1,ISGN,PNU,PWB,PNPI,JAK)
00396 DO 80 I=1,4
00397 80 PP1(I)=PWB(I)
00398 ENDIF
00399
00400 ENDIF
00401 C =====
00402 END
00403 SUBROUTINE DEKAY2(IMOD,HH,ISGN)
00404 C *******************************
00405 C THIS ROUTINE SIMULATES TAU- DECAY
00406 #if defined (ALEPH)
00407 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
00408 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
00409 REAL*4 GAMPMC ,GAMPER
00410 COMMON / DECP4 / PP1(4),PP2(4),KFF1,KFF2
00411 REAL*4 PP1 ,PP2
00412 INTEGER KFF1,KFF2
00413 #else
00414 COMMON / DECP4 / PP1(4),PP2(4),KF1,KF2
00415 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
00416 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
00417 REAL*4 GAMPMC ,GAMPER
00418 #endif
00419 REAL HH(4)
00420 REAL HV(4),PNU(4),PPI(4)
00421 REAL PWB(4),PMU(4),PNM(4)
00422 REAL PRHO(4),PIC(4),PIZ(4)
00423 REAL PAA(4),PIM1(4),PIM2(4),PIPL(4)
00424 REAL PKK(4),PKS(4)
00425 REAL PNPI(4,9)
00426 REAL PHOT(4)
00427 REAL PDUM(4)
00428 DATA NEV,NPRIN/0,10/
00429 KTO=2
00430 IF(JAK2.EQ.-1) RETURN
00431 IMD=IMOD
00432 IF(IMD.EQ.0) THEN
00433 C =================
00434 JAK=JAK2
00435 IF(JAK2.EQ.0) CALL JAKER(JAK)
00436 IF(JAK.EQ.1) THEN
00437 CALL DADMEL(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
00438 ELSEIF(JAK.EQ.2) THEN
00439 CALL DADMMU(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
00440 ELSEIF(JAK.EQ.3) THEN
00441 CALL DADMPI(0, ISGN,HV,PPI,PNU)
00442 ELSEIF(JAK.EQ.4) THEN
00443 CALL DADMRO(0, ISGN,HV,PNU,PRHO,PIC,PIZ)
00444 ELSEIF(JAK.EQ.5) THEN
00445 CALL DADMAA(0, ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
00446 ELSEIF(JAK.EQ.6) THEN
00447 CALL DADMKK(0, ISGN,HV,PKK,PNU)
00448 ELSEIF(JAK.EQ.7) THEN
00449 CALL DADMKS(0, ISGN,HV,PNU,PKS ,PKK,PPI,JKST)
00450 ELSE
00451 CALL DADNEW(0, ISGN,HV,PNU,PWB,PNPI,JAK-7)
00452 ENDIF
00453 DO 33 I=1,3
00454 33 HH(I)=HV(I)
00455 HH(4)=1.0
00456 ELSEIF(IMD.EQ.1) THEN
00457 C =====================
00458 NEV=NEV+1
00459 IF (JAK.LT.31) THEN
00460 NEVDEC(JAK)=NEVDEC(JAK)+1
00461 ENDIF
00462 DO 34 I=1,4
00463 34 PDUM(I)=.0
00464 IF(JAK.EQ.1) THEN
00465 CALL DWLUEL(2,ISGN,PNU,PWB,PMU,PNM)
00466 CALL DWRPH(KTOM,PHOT)
00467 DO 10 I=1,4
00468 10 PP2(I)=PMU(I)
00469
00470 ELSEIF(JAK.EQ.2) THEN
00471 CALL DWLUMU(2,ISGN,PNU,PWB,PMU,PNM)
00472 CALL DWRPH(KTOM,PHOT)
00473 DO 20 I=1,4
00474 20 PP2(I)=PMU(I)
00475
00476 ELSEIF(JAK.EQ.3) THEN
00477 CALL DWLUPI(2,ISGN,PPI,PNU)
00478 DO 30 I=1,4
00479 30 PP2(I)=PPI(I)
00480
00481 ELSEIF(JAK.EQ.4) THEN
00482 CALL DWLURO(2,ISGN,PNU,PRHO,PIC,PIZ)
00483 DO 40 I=1,4
00484 40 PP2(I)=PRHO(I)
00485
00486 ELSEIF(JAK.EQ.5) THEN
00487 CALL DWLUAA(2,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
00488 DO 50 I=1,4
00489 50 PP2(I)=PAA(I)
00490 ELSEIF(JAK.EQ.6) THEN
00491 CALL DWLUKK(2,ISGN,PKK,PNU)
00492 DO 60 I=1,4
00493 60 PP1(I)=PKK(I)
00494 ELSEIF(JAK.EQ.7) THEN
00495 CALL DWLUKS(2,ISGN,PNU,PKS,PKK,PPI,JKST)
00496 DO 70 I=1,4
00497 70 PP1(I)=PKS(I)
00498 ELSE
00499 CAM MULTIPION DECAY
00500 CALL DWLNEW(2,ISGN,PNU,PWB,PNPI,JAK)
00501 DO 80 I=1,4
00502 80 PP1(I)=PWB(I)
00503 ENDIF
00504 C
00505 ENDIF
00506 C =====
00507 END
00508 SUBROUTINE DEXAY(KTO,POL)
00509 C ----------------------------------------------------------------------
00510 C THIS 'DEXAY' IS A ROUTINE WHICH GENERATES DECAY OF THE SINGLE
00511 C POLARIZED TAU, POL IS A POLARIZATION VECTOR (NOT A POLARIMETER
00512 C VECTOR AS IN DEKAY) OF THE TAU AND IT IS AN INPUT PARAMETER.
00513 C KTO=0 INITIALISATION (OBLIGATORY)
00514 C KTO=1 DENOTES TAU+ AND KTO=2 TAU-
00515 C DEXAY(1,POL) AND DEXAY(2,POL) ARE CALLED INTERNALLY BY MC GENERATOR.
00516 C DECAY PRODUCTS ARE TRANSFORMED READILY
00517 C TO CMS AND WRITEN IN THE LUND RECORD IN /LUJETS/
00518 C KTO=100, PRINT FINAL REPORT (OPTIONAL).
00519 C
00520 C called by : KORALZ
00521 C ----------------------------------------------------------------------
00522 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
00523 REAL*4 GAMPMC ,GAMPER
00524 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
00525 COMMON / IDFC / IDFF
00526 COMMON /TAUPOS/ NP1,NP2
00527 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
00528 #if defined (ALEPH)
00529 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00530 #else
00531 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
00532 #endif
00533 & ,NAMES
00534 CHARACTER NAMES(NMODE)*31
00535 COMMON / INOUT / INUT,IOUT
00536 REAL POL(4)
00537 REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
00538 REAL PDUM(4)
00539 REAL PDUMI(4,9)
00540 DATA IWARM/0/
00541 KTOM=KTO
00542 C
00543 IF(KTO.EQ.-1) THEN
00544 C ==================
00545
00546 C INITIALISATION OR REINITIALISATION
00547 C first or second tau positions in HEPEVT as in KORALB/Z
00548 NP1=3
00549 NP2=4
00550 IWARM=1
00551 WRITE(IOUT, 7001) JAK1,JAK2
00552 NEVTOT=0
00553 NEV1=0
00554 NEV2=0
00555 IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
00556 CALL DEXEL(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00557 CALL DEXMU(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00558 CALL DEXPI(-1,IDUM,PDUM,PDUM1,PDUM2)
00559 CALL DEXRO(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4)
00560 CALL DEXAA(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,IDUM)
00561 CALL DEXKK(-1,IDUM,PDUM,PDUM1,PDUM2)
00562 CALL DEXKS(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,IDUM)
00563 CALL DEXNEW(-1,IDUM,PDUM,PDUM1,PDUM2,PDUMI,IDUM)
00564 ENDIF
00565 DO 21 I=1,30
00566 NEVDEC(I)=0
00567 GAMPMC(I)=0
00568 21 GAMPER(I)=0
00569 ELSEIF(KTO.EQ.1) THEN
00570 C =====================
00571 C DECAY OF TAU+ IN THE TAU REST FRAME
00572 NEVTOT=NEVTOT+1
00573 NEV1=NEV1+1
00574 IF(IWARM.EQ.0) GOTO 902
00575 ISGN=IDFF/IABS(IDFF)
00576 CAM CALL DEXAY1(POL,ISGN)
00577 CALL DEXAY1(KTO,JAK1,JAKP,POL,ISGN)
00578 ELSEIF(KTO.EQ.2) THEN
00579 C =================================
00580 C DECAY OF TAU- IN THE TAU REST FRAME
00581 NEVTOT=NEVTOT+1
00582 NEV2=NEV2+1
00583 IF(IWARM.EQ.0) GOTO 902
00584 ISGN=-IDFF/IABS(IDFF)
00585 CAM CALL DEXAY2(POL,ISGN)
00586 CALL DEXAY1(KTO,JAK2,JAKM,POL,ISGN)
00587 ELSEIF(KTO.EQ.100) THEN
00588 C =======================
00589 IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
00590 CALL DEXEL( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00591 CALL DEXMU( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00592 CALL DEXPI( 1,IDUM,PDUM,PDUM1,PDUM2)
00593 CALL DEXRO( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4)
00594 CALL DEXAA( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,IDUM)
00595 CALL DEXKK( 1,IDUM,PDUM,PDUM1,PDUM2)
00596 CALL DEXKS( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,IDUM)
00597 CALL DEXNEW( 1,IDUM,PDUM,PDUM1,PDUM2,PDUMI,IDUM)
00598 WRITE(IOUT,7010) NEV1,NEV2,NEVTOT
00599 WRITE(IOUT,7011) (NEVDEC(I),GAMPMC(I),GAMPER(I),I= 1,7)
00600 WRITE(IOUT,7012)
00601 $ (NEVDEC(I),GAMPMC(I),GAMPER(I),NAMES(I-7),I=8,7+NMODE)
00602 WRITE(IOUT,7013)
00603 ENDIF
00604 ELSE
00605 GOTO 910
00606 ENDIF
00607 RETURN
00608 7001 FORMAT(///1X,15(5H*****)
00609 #if defined (ALEPH)
00610 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00611 $ /,' *', 25X,'*DEC 1993; ALEPH fixes introd. dec 98 *',9X,1H*,
00612 $ /,' *', 25X,'**AUTHORS: S.JADACH, Z.WAS*************',9X,1H*,
00613 $ /,' *', 25X,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9X,1H*,
00614 $ /,' *', 25X,'Physics initialization by ALEPH collab ',9X,1H*,
00615 $ /,' *', 25X,'it is suggested to use this version ',9X,1H*,
00616 $ /,' *', 25X,' with the help of the collab. advice ',9X,1H*,
00617 $ /,' *', 25X,'**AVAILABLE FROM: WASM AT CERNVM ******',9X,1H*,
00618 $ /,' *', 25X,'***** PUBLISHED IN COMP. PHYS. COMM.***',9X,1H*,
00619 #elif defined (CLEO)
00620 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00621 $ /,' *', 25X,'***********August 1995***************',9X,1H*,
00622 $ /,' *', 25X,'**AUTHORS: S.JADACH, Z.WAS*************',9X,1H*,
00623 $ /,' *', 25X,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9X,1H*,
00624 $ /,' *', 25X,'**AVAILABLE FROM: WASM AT CERNVM ******',9X,1H*,
00625 $ /,' *', 25X,'***** PUBLISHED IN COMP. PHYS. COMM.***',9X,1H*,
00626 $ /,' *', 25X,' Physics initialization by CLEO collab ',9X,1H*,
00627 $ /,' *', 25X,' see Alain Weinstein www home page: ',9X,1H*,
00628 $ /,' *', 25X,'http://www.cithep.caltech.edu/~ajw/ ',9X,1H*,
00629 $ /,' *', 25X,'/korb_doc.html#files ',9X,1H*,
00630 $ /,' *', 25X,'*******CERN TH-6793 NOVEMBER 1992*****',9X,1H*,
00631 $ /,' *', 25X,'**5 or more pi dec.: precision limited ',9X,1H*,
00632 #else
00633 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00634 $ /,' *', 25X,'***********August 1995***************',9X,1H*,
00635 $ /,' *', 25X,'**AUTHORS: S.JADACH, Z.WAS*************',9X,1H*,
00636 $ /,' *', 25X,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9X,1H*,
00637 $ /,' *', 25X,'**AVAILABLE FROM: WASM AT CERNVM ******',9X,1H*,
00638 $ /,' *', 25X,'***** PUBLISHED IN COMP. PHYS. COMM.***',9X,1H*,
00639 $ /,' *', 25X,'*******CERN-TH-5856 SEPTEMBER 1990*****',9X,1H*,
00640 $ /,' *', 25X,'*******CERN-TH-6195 SEPTEMBER 1991*****',9X,1H*,
00641 #endif
00642 $ /,' *', 25X,'*******CERN-TH-6793 NOVEMBER 1992*****',9X,1H*,
00643 $ /,' *', 25X,'**5 or more pi dec.: precision limited ',9X,1H*,
00644 $ /,' *', 25X,'******DEXAY ROUTINE: INITIALIZATION****',9X,1H*
00645 $ /,' *',I20 ,5X,'JAK1 = DECAY MODE FERMION1 (TAU+) ',9X,1H*
00646 $ /,' *',I20 ,5X,'JAK2 = DECAY MODE FERMION2 (TAU-) ',9X,1H*
00647 $ /,1X,15(5H*****)/)
00648 CHBU format 7010 had more than 19 continuation lines
00649 CHBU split into two
00650 7010 FORMAT(///1X,15(5H*****)
00651 #if defined (ALEPH)
00652 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00653 $ /,' *', 25X,'***********DECEMBER 1993***************',9X,1H*,
00654 #else
00655 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.7 ******',9X,1H*,
00656 $ /,' *', 25X,'***********August 1995***************',9X,1H*,
00657 #endif
00658 $ /,' *', 25X,'**AUTHORS: S.JADACH, Z.WAS*************',9X,1H*,
00659 $ /,' *', 25X,'**R. DECKER, M. JEZABEK, J.H.KUEHN*****',9X,1H*,
00660 $ /,' *', 25X,'**AVAILABLE FROM: WASM AT CERNVM ******',9X,1H*,
00661 $ /,' *', 25X,'***** PUBLISHED IN COMP. PHYS. COMM.***',9X,1H*,
00662 $ /,' *', 25X,'*******CERN-TH-5856 SEPTEMBER 1990*****',9X,1H*,
00663 $ /,' *', 25X,'*******CERN-TH-6195 SEPTEMBER 1991*****',9X,1H*,
00664 $ /,' *', 25X,'*******CERN-TH-6793 NOVEMBER 1992*****',9X,1H*,
00665 $ /,' *', 25X,'******DEXAY ROUTINE: FINAL REPORT******',9X,1H*
00666 $ /,' *',I20 ,5X,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9X,1H*
00667 $ /,' *',I20 ,5X,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9X,1H*
00668 $ /,' *',I20 ,5X,'NEVTOT = SUM ',9X,1H*
00669 $ /,' *',' NOEVTS ',
00670 $ ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9X,1H*)
00671 7011 FORMAT(1X,'*'
00672 $ ,I10,2F12.7 ,' DADMEL ELECTRON ',9X,1H*
00673 $ /,' *',I10,2F12.7 ,' DADMMU MUON ',9X,1H*
00674 $ /,' *',I10,2F12.7 ,' DADMPI PION ',9X,1H*
00675 $ /,' *',I10,2F12.7, ' DADMRO RHO (->2PI) ',9X,1H*
00676 $ /,' *',I10,2F12.7, ' DADMAA A1 (->3PI) ',9X,1H*
00677 $ /,' *',I10,2F12.7, ' DADMKK KAON ',9X,1H*
00678 $ /,' *',I10,2F12.7, ' DADMKS K* ',9X,1H*)
00679 7012 FORMAT(1X,'*'
00680 $ ,I10,2F12.7,A31 ,8X,1H*)
00681 7013 FORMAT(1X,'*'
00682 $ ,20X,'THE ERROR IS RELATIVE AND PART.WIDTH ',10X,1H*
00683 $ /,' *',20X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',10X,1H*
00684 $ /,1X,15(5H*****)/)
00685 902 WRITE(IOUT, 9020)
00686 9020 FORMAT(' ----- DEXAY: LACK OF INITIALISATION')
00687 STOP
00688 910 WRITE(IOUT, 9100)
00689 9100 FORMAT(' ----- DEXAY: WRONG VALUE OF KTO ')
00690 STOP
00691 END
00692 SUBROUTINE DEXAY1(KTO,JAKIN,JAK,POL,ISGN)
00693 C ---------------------------------------------------------------------
00694 C THIS ROUTINE SIMULATES TAU+- DECAY
00695 C
00696 C called by : DEXAY
00697 C ---------------------------------------------------------------------
00698 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
00699 REAL*4 GAMPMC ,GAMPER
00700 COMMON / INOUT / INUT,IOUT
00701 REAL POL(4),POLAR(4)
00702 REAL PNU(4),PPI(4)
00703 REAL PRHO(4),PIC(4),PIZ(4)
00704 REAL PWB(4),PMU(4),PNM(4)
00705 REAL PAA(4),PIM1(4),PIM2(4),PIPL(4)
00706 REAL PKK(4),PKS(4)
00707 REAL PNPI(4,9)
00708 REAL PHOT(4)
00709 REAL PDUM(4)
00710 C
00711 IF(JAKIN.EQ.-1) RETURN
00712 DO 33 I=1,3
00713 33 POLAR(I)=POL(I)
00714 POLAR(4)=0.
00715 DO 34 I=1,4
00716 34 PDUM(I)=.0
00717 JAK=JAKIN
00718 IF(JAK.EQ.0) CALL JAKER(JAK)
00719 CAM
00720 IF(JAK.EQ.1) THEN
00721 CALL DEXEL(0, ISGN,POLAR,PNU,PWB,PMU,PNM,PHOT)
00722 CALL DWLUEL(KTO,ISGN,PNU,PWB,PMU,PNM)
00723 CALL DWRPH(KTO,PHOT )
00724 ELSEIF(JAK.EQ.2) THEN
00725 CALL DEXMU(0, ISGN,POLAR,PNU,PWB,PMU,PNM,PHOT)
00726 CALL DWLUMU(KTO,ISGN,PNU,PWB,PMU,PNM)
00727 CALL DWRPH(KTO,PHOT )
00728 ELSEIF(JAK.EQ.3) THEN
00729 CALL DEXPI(0, ISGN,POLAR,PPI,PNU)
00730 CALL DWLUPI(KTO,ISGN,PPI,PNU)
00731 ELSEIF(JAK.EQ.4) THEN
00732 CALL DEXRO(0, ISGN,POLAR,PNU,PRHO,PIC,PIZ)
00733 CALL DWLURO(KTO,ISGN,PNU,PRHO,PIC,PIZ)
00734 ELSEIF(JAK.EQ.5) THEN
00735 CALL DEXAA(0, ISGN,POLAR,PNU,PAA,PIM1,PIM2,PIPL,JAA)
00736 CALL DWLUAA(KTO,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
00737 ELSEIF(JAK.EQ.6) THEN
00738 CALL DEXKK(0, ISGN,POLAR,PKK,PNU)
00739 CALL DWLUKK(KTO,ISGN,PKK,PNU)
00740 ELSEIF(JAK.EQ.7) THEN
00741 CALL DEXKS(0, ISGN,POLAR,PNU,PKS,PKK,PPI,JKST)
00742 CALL DWLUKS(KTO,ISGN,PNU,PKS,PKK,PPI,JKST)
00743 ELSE
00744 JNPI=JAK-7
00745 CALL DEXNEW(0, ISGN,POLAR,PNU,PWB,PNPI,JNPI)
00746 CALL DWLNEW(KTO,ISGN,PNU,PWB,PNPI,JAK)
00747 ENDIF
00748 NEVDEC(JAK)=NEVDEC(JAK)+1
00749 END
00750 SUBROUTINE DEXEL(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
00751 C ----------------------------------------------------------------------
00752 C THIS SIMULATES TAU DECAY IN TAU REST FRAME
00753 C INTO ELECTRON AND TWO NEUTRINOS
00754 C
00755 C called by : DEXAY,DEXAY1
00756 C ----------------------------------------------------------------------
00757 REAL POL(4),HV(4),PWB(4),PNU(4),Q1(4),Q2(4),PH(4),RN(1)
00758 DATA IWARM/0/
00759 C
00760 IF(MODE.EQ.-1) THEN
00761 C ===================
00762 IWARM=1
00763 CALL DADMEL( -1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
00764 CC CALL HBOOK1(813,'WEIGHT DISTRIBUTION DEXEL $',100,0,2)
00765 C
00766 ELSEIF(MODE.EQ. 0) THEN
00767 C =======================
00768 300 CONTINUE
00769 IF(IWARM.EQ.0) GOTO 902
00770 CALL DADMEL( 0,ISGN,HV,PNU,PWB,Q1,Q2,PH)
00771 WT=(1+POL(1)*HV(1)+POL(2)*HV(2)+POL(3)*HV(3))/2.
00772 CC CALL HFILL(813,WT)
00773 CALL RANMAR(RN,1)
00774 IF(RN(1).GT.WT) GOTO 300
00775 C
00776 ELSEIF(MODE.EQ. 1) THEN
00777 C =======================
00778 CALL DADMEL( 1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
00779 CC CALL HPRINT(813)
00780 ENDIF
00781 C =====
00782 RETURN
00783 902 PRINT 9020
00784 9020 FORMAT(' ----- DEXEL: LACK OF INITIALISATION')
00785 STOP
00786 END
00787 SUBROUTINE DEXMU(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
00788 C ----------------------------------------------------------------------
00789 C THIS SIMULATES TAU DECAY IN ITS REST FRAME
00790 C INTO MUON AND TWO NEUTRINOS
00791 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
00792 C PWB W-BOSON
00793 C Q1 MUON
00794 C Q2 MUON-NEUTRINO
00795 C ----------------------------------------------------------------------
00796 COMMON / INOUT / INUT,IOUT
00797 REAL POL(4),HV(4),PWB(4),PNU(4),Q1(4),Q2(4),PH(4),RN(1)
00798 DATA IWARM/0/
00799 C
00800 IF(MODE.EQ.-1) THEN
00801 C ===================
00802 IWARM=1
00803 CALL DADMMU( -1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
00804 CC CALL HBOOK1(814,'WEIGHT DISTRIBUTION DEXMU $',100,0,2)
00805 C
00806 ELSEIF(MODE.EQ. 0) THEN
00807 C =======================
00808 300 CONTINUE
00809 IF(IWARM.EQ.0) GOTO 902
00810 CALL DADMMU( 0,ISGN,HV,PNU,PWB,Q1,Q2,PH)
00811 WT=(1+POL(1)*HV(1)+POL(2)*HV(2)+POL(3)*HV(3))/2.
00812 CC CALL HFILL(814,WT)
00813 CALL RANMAR(RN,1)
00814 IF(RN(1).GT.WT) GOTO 300
00815 C
00816 ELSEIF(MODE.EQ. 1) THEN
00817 C =======================
00818 CALL DADMMU( 1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
00819 CC CALL HPRINT(814)
00820 ENDIF
00821 C =====
00822 RETURN
00823 902 WRITE(IOUT, 9020)
00824 9020 FORMAT(' ----- DEXMU: LACK OF INITIALISATION')
00825 STOP
00826 END
00827 SUBROUTINE DADMEL(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
00828 C ----------------------------------------------------------------------
00829 C
00830 C called by : DEXEL,(DEKAY,DEKAY1)
00831 C ----------------------------------------------------------------------
00832 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00833 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00834 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00835 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00836 * ,AMK,AMKZ,AMKST,GAMKST
00837 C
00838 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00839 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00840 * ,AMK,AMKZ,AMKST,GAMKST
00841 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
00842 REAL*4 GAMPMC ,GAMPER
00843 #if defined (ALEPH)
00844 #else
00845 REAL*4 PHX(4)
00846 #endif
00847 COMMON / INOUT / INUT,IOUT
00848 #if defined (ALEPH)
00849 REAL*4 PHX(4)
00850 #else
00851 #endif
00852 REAL HHV(4),HV(4),PWB(4),PNU(4),Q1(4),Q2(4)
00853 REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
00854 REAL*4 RRR(3)
00855 REAL*8 SWT, SSWT
00856 DATA PI /3.141592653589793238462643/
00857 DATA IWARM/0/
00858 C
00859 IF(MODE.EQ.-1) THEN
00860 C ===================
00861 IWARM=1
00862 NEVRAW=0
00863 NEVACC=0
00864 NEVOVR=0
00865 SWT=0
00866 SSWT=0
00867 WTMAX=1E-20
00868 DO 15 I=1,500
00869 CALL DPHSEL(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00870 IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
00871 15 CONTINUE
00872 CC CALL HBOOK1(803,'WEIGHT DISTRIBUTION DADMEL $',100,0,2)
00873 C
00874 ELSEIF(MODE.EQ. 0) THEN
00875 C =======================
00876 300 CONTINUE
00877 IF(IWARM.EQ.0) GOTO 902
00878 NEVRAW=NEVRAW+1
00879 CALL DPHSEL(WT,HV,PNU,PWB,Q1,Q2,PHX)
00880 CC CALL HFILL(803,WT/WTMAX)
00881 SWT=SWT+WT
00882 SSWT=SSWT+WT**2
00883 CALL RANMAR(RRR,3)
00884 RN=RRR(1)
00885 IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
00886 IF(RN*WTMAX.GT.WT) GOTO 300
00887 C ROTATIONS TO BASIC TAU REST FRAME
00888 RR2=RRR(2)
00889 COSTHE=-1.+2.*RR2
00890 THET=ACOS(COSTHE)
00891 RR3=RRR(3)
00892 PHI =2*PI*RR3
00893 CALL ROTOR2(THET,PNU,PNU)
00894 CALL ROTOR3( PHI,PNU,PNU)
00895 CALL ROTOR2(THET,PWB,PWB)
00896 CALL ROTOR3( PHI,PWB,PWB)
00897 CALL ROTOR2(THET,Q1,Q1)
00898 CALL ROTOR3( PHI,Q1,Q1)
00899 CALL ROTOR2(THET,Q2,Q2)
00900 CALL ROTOR3( PHI,Q2,Q2)
00901 CALL ROTOR2(THET,HV,HV)
00902 CALL ROTOR3( PHI,HV,HV)
00903 CALL ROTOR2(THET,PHX,PHX)
00904 CALL ROTOR3( PHI,PHX,PHX)
00905 DO 44,I=1,3
00906 44 HHV(I)=-ISGN*HV(I)
00907 NEVACC=NEVACC+1
00908 C
00909 ELSEIF(MODE.EQ. 1) THEN
00910 C =======================
00911 IF(NEVRAW.EQ.0) RETURN
00912 PARGAM=SWT/FLOAT(NEVRAW+1)
00913 ERROR=0
00914 IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
00915 RAT=PARGAM/GAMEL
00916 WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
00917 CC CALL HPRINT(803)
00918 GAMPMC(1)=RAT
00919 GAMPER(1)=ERROR
00920 CAM NEVDEC(1)=NEVACC
00921 ENDIF
00922 C =====
00923 RETURN
00924 7010 FORMAT(///1X,15(5H*****)
00925 $ /,' *', 25X,'******** DADMEL FINAL REPORT ******** ',9X,1H*
00926 $ /,' *',I20 ,5X,'NEVRAW = NO. OF EL DECAYS TOTAL ',9X,1H*
00927 $ /,' *',I20 ,5X,'NEVACC = NO. OF EL DECS. ACCEPTED ',9X,1H*
00928 $ /,' *',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H*
00929 $ /,' *',E20.5,5X,'PARTIAL WTDTH ( ELECTRON) IN GEV UNITS ',9X,1H*
00930 $ /,' *',F20.9,5X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9X,1H*
00931 $ /,' *',F20.9,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H*
00932 $ /,' *',25X, 'COMPLETE QED CORRECTIONS INCLUDED ',9X,1H*
00933 $ /,' *',25X, 'BUT ONLY V-A CUPLINGS ',9X,1H*
00934 $ /,1X,15(5H*****)/)
00935 902 WRITE(IOUT, 9020)
00936 9020 FORMAT(' ----- DADMEL: LACK OF INITIALISATION')
00937 STOP
00938 END
00939 SUBROUTINE DADMMU(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
00940 C ----------------------------------------------------------------------
00941 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00942 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00943 * ,AMK,AMKZ,AMKST,GAMKST
00944 C
00945 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00946 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00947 * ,AMK,AMKZ,AMKST,GAMKST
00948 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00949 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00950 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
00951 REAL*4 GAMPMC ,GAMPER
00952 COMMON / INOUT / INUT,IOUT
00953 REAL*4 PHX(4)
00954 REAL HHV(4),HV(4),PNU(4),PWB(4),Q1(4),Q2(4)
00955 REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
00956 REAL*4 RRR(3)
00957 REAL*8 SWT, SSWT
00958 DATA PI /3.141592653589793238462643/
00959 DATA IWARM /0/
00960 C
00961 IF(MODE.EQ.-1) THEN
00962 C ===================
00963 IWARM=1
00964 NEVRAW=0
00965 NEVACC=0
00966 NEVOVR=0
00967 SWT=0
00968 SSWT=0
00969 WTMAX=1E-20
00970 DO 15 I=1,500
00971 CALL DPHSMU(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
00972 IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
00973 15 CONTINUE
00974 CC CALL HBOOK1(802,'WEIGHT DISTRIBUTION DADMMU $',100,0,2)
00975 C
00976 ELSEIF(MODE.EQ. 0) THEN
00977 C =======================
00978 300 CONTINUE
00979 IF(IWARM.EQ.0) GOTO 902
00980 NEVRAW=NEVRAW+1
00981 CALL DPHSMU(WT,HV,PNU,PWB,Q1,Q2,PHX)
00982 CC CALL HFILL(802,WT/WTMAX)
00983 SWT=SWT+WT
00984 SSWT=SSWT+WT**2
00985 CALL RANMAR(RRR,3)
00986 RN=RRR(1)
00987 IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
00988 IF(RN*WTMAX.GT.WT) GOTO 300
00989 C ROTATIONS TO BASIC TAU REST FRAME
00990 COSTHE=-1.+2.*RRR(2)
00991 THET=ACOS(COSTHE)
00992 PHI =2*PI*RRR(3)
00993 CALL ROTOR2(THET,PNU,PNU)
00994 CALL ROTOR3( PHI,PNU,PNU)
00995 CALL ROTOR2(THET,PWB,PWB)
00996 CALL ROTOR3( PHI,PWB,PWB)
00997 CALL ROTOR2(THET,Q1,Q1)
00998 CALL ROTOR3( PHI,Q1,Q1)
00999 CALL ROTOR2(THET,Q2,Q2)
01000 CALL ROTOR3( PHI,Q2,Q2)
01001 CALL ROTOR2(THET,HV,HV)
01002 CALL ROTOR3( PHI,HV,HV)
01003 CALL ROTOR2(THET,PHX,PHX)
01004 CALL ROTOR3( PHI,PHX,PHX)
01005 DO 44,I=1,3
01006 44 HHV(I)=-ISGN*HV(I)
01007 NEVACC=NEVACC+1
01008 C
01009 ELSEIF(MODE.EQ. 1) THEN
01010 C =======================
01011 IF(NEVRAW.EQ.0) RETURN
01012 PARGAM=SWT/FLOAT(NEVRAW+1)
01013 ERROR=0
01014 IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
01015 RAT=PARGAM/GAMEL
01016 WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
01017 CC CALL HPRINT(802)
01018 GAMPMC(2)=RAT
01019 GAMPER(2)=ERROR
01020 CAM NEVDEC(2)=NEVACC
01021 ENDIF
01022 C =====
01023 RETURN
01024 7010 FORMAT(///1X,15(5H*****)
01025 $ /,' *', 25X,'******** DADMMU FINAL REPORT ******** ',9X,1H*
01026 $ /,' *',I20 ,5X,'NEVRAW = NO. OF MU DECAYS TOTAL ',9X,1H*
01027 $ /,' *',I20 ,5X,'NEVACC = NO. OF MU DECS. ACCEPTED ',9X,1H*
01028 $ /,' *',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H*
01029 $ /,' *',E20.5,5X,'PARTIAL WTDTH (MU DECAY) IN GEV UNITS ',9X,1H*
01030 $ /,' *',F20.9,5X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9X,1H*
01031 $ /,' *',F20.9,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H*
01032 $ /,' *',25X, 'COMPLETE QED CORRECTIONS INCLUDED ',9X,1H*
01033 $ /,' *',25X, 'BUT ONLY V-A CUPLINGS ',9X,1H*
01034 $ /,1X,15(5H*****)/)
01035 902 WRITE(IOUT, 9020)
01036 9020 FORMAT(' ----- DADMMU: LACK OF INITIALISATION')
01037 STOP
01038 END
01039 SUBROUTINE DPHSEL(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
01040 C XNX,XNA was flipped in parameters of dphsel and dphsmu
01041 C *********************************************************************
01042 C * ELECTRON DECAY MODE *
01043 C *********************************************************************
01044 REAL*4 PHX(4)
01045 REAL*4 HVX(4),PAAX(4),XAX(4),QPX(4),XNX(4)
01046 REAL*8 HV(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
01047 REAL*8 DGAMT
01048 IELMU=1
01049 CALL DRCMU(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
01050 DO 7 K=1,4
01051 HVX(K)=HV(K)
01052 PHX(K)=PH(K)
01053 PAAX(K)=PAA(K)
01054 XAX(K)=XA(K)
01055 QPX(K)=QP(K)
01056 XNX(K)=XN(K)
01057 7 CONTINUE
01058 DGAMX=DGAMT
01059 END
01060 SUBROUTINE DPHSMU(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
01061 C XNX,XNA was flipped in parameters of dphsel and dphsmu
01062 C *********************************************************************
01063 C * MUON DECAY MODE *
01064 C *********************************************************************
01065 REAL*4 PHX(4)
01066 REAL*4 HVX(4),PAAX(4),XAX(4),QPX(4),XNX(4)
01067 REAL*8 HV(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
01068 REAL*8 DGAMT
01069 IELMU=2
01070 CALL DRCMU(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
01071 DO 7 K=1,4
01072 HVX(K)=HV(K)
01073 PHX(K)=PH(K)
01074 PAAX(K)=PAA(K)
01075 XAX(K)=XA(K)
01076 QPX(K)=QP(K)
01077 XNX(K)=XN(K)
01078 7 CONTINUE
01079 DGAMX=DGAMT
01080 END
01081 SUBROUTINE DRCMU(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
01082 IMPLICIT REAL*8 (A-H,O-Z)
01083 C ----------------------------------------------------------------------
01084 * IT SIMULATES E,MU CHANNELS OF TAU DECAY IN ITS REST FRAME WITH
01085 * QED ORDER ALPHA CORRECTIONS
01086 C ----------------------------------------------------------------------
01087 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01088 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01089 * ,AMK,AMKZ,AMKST,GAMKST
01090 C
01091 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01092 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01093 * ,AMK,AMKZ,AMKST,GAMKST
01094 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01095 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01096 #if defined (ALEPH)
01097 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
01098 REAL*4 GAMPMC ,GAMPER
01099 #endif
01100 COMMON / INOUT / INUT,IOUT
01101 COMMON / TAURAD / XK0DEC,ITDKRC
01102 REAL*8 XK0DEC
01103 REAL*8 HV(4),PT(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
01104 REAL*8 PR(4)
01105 REAL*4 RRR(6)
01106 LOGICAL IHARD
01107 DATA PI /3.141592653589793238462643D0/
01108 #if defined (CLEO)
01109 C AJWMOD to satisfy compiler, comment out this unused function.
01110 #else
01111 XLAM(X,Y,Z)=SQRT((X-Y-Z)**2-4.0*Y*Z)
01112 #endif
01113 C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
01114 C
01115 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
01116 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
01117 PHSPAC=1./2**17/PI**8
01118 AMTAX=AMTAU
01119 C TAU MOMENTUM
01120 PT(1)=0.D0
01121 PT(2)=0.D0
01122 PT(3)=0.D0
01123 PT(4)=AMTAX
01124 C
01125 CALL RANMAR(RRR,6)
01126 C
01127 IF (IELMU.EQ.1) THEN
01128 AMU=AMEL
01129 ELSE
01130 AMU=AMMU
01131 ENDIF
01132 C
01133 PRHARD=0.30D0
01134 IF ( ITDKRC.EQ.0) PRHARD=0D0
01135 PRSOFT=1.-PRHARD
01136 IF(PRSOFT.LT.0.1) THEN
01137 PRINT *, 'ERROR IN DRCMU; PRSOFT=',PRSOFT
01138 STOP
01139 ENDIF
01140 C
01141 RR5=RRR(5)
01142 IHARD=(RR5.GT.PRSOFT)
01143 IF (IHARD) THEN
01144 C TAU DECAY TO 'TAU+photon'
01145 RR1=RRR(1)
01146 AMS1=(AMU+AMNUTA)**2
01147 AMS2=(AMTAX)**2
01148 XK1=1-AMS1/AMS2
01149 XL1=LOG(XK1/2/XK0DEC)
01150 XL0=LOG(2*XK0DEC)
01151 XK=EXP(XL1*RR1+XL0)
01152 AM3SQ=(1-XK)*AMS2
01153 AM3 =SQRT(AM3SQ)
01154 PHSPAC=PHSPAC*AMS2*XL1*XK
01155 PHSPAC=PHSPAC/PRHARD
01156 ELSE
01157 AM3=AMTAX
01158 PHSPAC=PHSPAC*2**6*PI**3
01159 PHSPAC=PHSPAC/PRSOFT
01160 ENDIF
01161 C MASS OF NEUTRINA SYSTEM
01162 RR2=RRR(2)
01163 AMS1=(AMNUTA)**2
01164 AMS2=(AM3-AMU)**2
01165 CAM
01166 CAM
01167 * FLAT PHASE SPACE;
01168 AM2SQ=AMS1+ RR2*(AMS2-AMS1)
01169 AM2 =SQRT(AM2SQ)
01170 PHSPAC=PHSPAC*(AMS2-AMS1)
01171 * NEUTRINA REST FRAME, DEFINE XN AND XA
01172 ENQ1=(AM2SQ+AMNUTA**2)/(2*AM2)
01173 ENQ2=(AM2SQ-AMNUTA**2)/(2*AM2)
01174 PPI= ENQ1**2-AMNUTA**2
01175 PPPI=SQRT(ABS(ENQ1**2-AMNUTA**2))
01176 PHSPAC=PHSPAC*(4*PI)*(2*PPPI/AM2)
01177 * NU TAU IN NUNU REST FRAME
01178 CALL SPHERD(PPPI,XN)
01179 XN(4)=ENQ1
01180 * NU LIGHT IN NUNU REST FRAME
01181 DO 30 I=1,3
01182 30 XA(I)=-XN(I)
01183 XA(4)=ENQ2
01184 * TAU-prim REST FRAME, DEFINE QP (muon
01185 * NUNU MOMENTUM
01186 PR(1)=0
01187 PR(2)=0
01188 PR(4)=1.D0/(2*AM3)*(AM3**2+AM2**2-AMU**2)
01189 PR(3)= SQRT(ABS(PR(4)**2-AM2**2))
01190 PPI = PR(4)**2-AM2**2
01191 * MUON MOMENTUM
01192 QP(1)=0
01193 QP(2)=0
01194 QP(4)=1.D0/(2*AM3)*(AM3**2-AM2**2+AMU**2)
01195 QP(3)=-PR(3)
01196 PHSPAC=PHSPAC*(4*PI)*(2*PR(3)/AM3)
01197 * NEUTRINA BOOSTED FROM THEIR FRAME TO TAU-prim REST FRAME
01198 EXE=(PR(4)+PR(3))/AM2
01199 CALL BOSTD3(EXE,XN,XN)
01200 CALL BOSTD3(EXE,XA,XA)
01201 RR3=RRR(3)
01202 RR4=RRR(4)
01203 IF (IHARD) THEN
01204 EPS=4*(AMU/AMTAX)**2
01205 XL1=LOG((2+EPS)/EPS)
01206 XL0=LOG(EPS)
01207 ETA =EXP(XL1*RR3+XL0)
01208 CTHET=1+EPS-ETA
01209 THET =ACOS(CTHET)
01210 PHSPAC=PHSPAC*XL1/2*ETA
01211 PHI = 2*PI*RR4
01212 CALL ROTPOX(THET,PHI,XN)
01213 CALL ROTPOX(THET,PHI,XA)
01214 CALL ROTPOX(THET,PHI,QP)
01215 CALL ROTPOX(THET,PHI,PR)
01216 C
01217 * NOW TO THE TAU REST FRAME, DEFINE TAU-prim AND GAMMA MOMENTA
01218 * tau-prim MOMENTUM
01219 PAA(1)=0
01220 PAA(2)=0
01221 PAA(4)=1/(2*AMTAX)*(AMTAX**2+AM3**2)
01222 PAA(3)= SQRT(ABS(PAA(4)**2-AM3**2))
01223 PPI = PAA(4)**2-AM3**2
01224 PHSPAC=PHSPAC*(4*PI)*(2*PAA(3)/AMTAX)
01225 * GAMMA MOMENTUM
01226 PH(1)=0
01227 PH(2)=0
01228 PH(4)=PAA(3)
01229 PH(3)=-PAA(3)
01230 * ALL MOMENTA BOOSTED FROM TAU-prim REST FRAME TO TAU REST FRAME
01231 * Z-AXIS ANTIPARALLEL TO PHOTON MOMENTUM
01232 EXE=(PAA(4)+PAA(3))/AM3
01233 CALL BOSTD3(EXE,XN,XN)
01234 CALL BOSTD3(EXE,XA,XA)
01235 CALL BOSTD3(EXE,QP,QP)
01236 CALL BOSTD3(EXE,PR,PR)
01237 ELSE
01238 THET =ACOS(-1.+2*RR3)
01239 PHI = 2*PI*RR4
01240 CALL ROTPOX(THET,PHI,XN)
01241 CALL ROTPOX(THET,PHI,XA)
01242 CALL ROTPOX(THET,PHI,QP)
01243 CALL ROTPOX(THET,PHI,PR)
01244 C
01245 * NOW TO THE TAU REST FRAME, DEFINE TAU-prim AND GAMMA MOMENTA
01246 * tau-prim MOMENTUM
01247 PAA(1)=0
01248 PAA(2)=0
01249 PAA(4)=AMTAX
01250 PAA(3)=0
01251 * GAMMA MOMENTUM
01252 PH(1)=0
01253 PH(2)=0
01254 PH(4)=0
01255 PH(3)=0
01256 ENDIF
01257 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
01258 CALL DAMPRY(ITDKRC,XK0DEC,PH,XA,QP,XN,AMPLIT,HV)
01259 DGAMT=1/(2.*AMTAX)*AMPLIT*PHSPAC
01260 END
01261 SUBROUTINE DAMPRY(ITDKRC,XK0DEC,XK,XA,QP,XN,AMPLIT,HV)
01262 IMPLICIT REAL*8 (A-H,O-Z)
01263 C ----------------------------------------------------------------------
01264 C IT CALCULATES MATRIX ELEMENT FOR THE
01265 C TAU --> MU(E) NU NUBAR DECAY MODE
01266 C INCLUDING COMPLETE ORDER ALPHA QED CORRECTIONS.
01267 C ----------------------------------------------------------------------
01268 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01269 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01270 * ,AMK,AMKZ,AMKST,GAMKST
01271 C
01272 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01273 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01274 * ,AMK,AMKZ,AMKST,GAMKST
01275 REAL*8 HV(4),QP(4),XN(4),XA(4),XK(4)
01276 C
01277 HV(4)=1.D0
01278 AK0=XK0DEC*AMTAU
01279 IF(XK(4).LT.0.1D0*AK0) THEN
01280 AMPLIT=THB(ITDKRC,QP,XN,XA,AK0,HV)
01281 ELSE
01282 AMPLIT=SQM2(ITDKRC,QP,XN,XA,XK,AK0,HV)
01283 ENDIF
01284 RETURN
01285 END
01286 FUNCTION SQM2(ITDKRC,QP,XN,XA,XK,AK0,HV)
01287 C
01288 C **********************************************************************
01289 C REAL PHOTON MATRIX ELEMENT SQUARED *
01290 C PARAMETERS: *
01291 C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
01292 C QP,XN,XA,XK - 4-momenta of electron (muon), NU, NUBAR and PHOTON *
01293 C All four-vectors in TAU rest frame (in GeV) *
01294 C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS (GEV) *
01295 C SQM2 - value for S=0 *
01296 C see Eqs. (2.9)-(2.10) from CJK ( Nucl.Phys.B(1991) ) *
01297 C **********************************************************************
01298 C
01299 IMPLICIT REAL*8(A-H,O-Z)
01300 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01301 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01302 * ,AMK,AMKZ,AMKST,GAMKST
01303 C
01304 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01305 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01306 * ,AMK,AMKZ,AMKST,GAMKST
01307 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01308 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01309 COMMON / QEDPRM /ALFINV,ALFPI,XK0
01310 REAL*8 ALFINV,ALFPI,XK0
01311 REAL*8 QP(4),XN(4),XA(4),XK(4)
01312 REAL*8 R(4)
01313 REAL*8 HV(4)
01314 REAL*8 S0(3),RXA(3),RXK(3),RQP(3)
01315 DATA PI /3.141592653589793238462643D0/
01316 C
01317 TMASS=AMTAU
01318 GF=GFERMI
01319 ALPHAI=ALFINV
01320 TMASS2=TMASS**2
01321 EMASS2=QP(4)**2-QP(1)**2-QP(2)**2-QP(3)**2
01322 R(4)=TMASS
01323 C SCALAR PRODUCTS OF FOUR-MOMENTA
01324 DO 7 I=1,3
01325 R(1)=0.D0
01326 R(2)=0.D0
01327 R(3)=0.D0
01328 R(I)=TMASS
01329 RXA(I)=R(4)*XA(4)-R(1)*XA(1)-R(2)*XA(2)-R(3)*XA(3)
01330 C RXN(I)=R(4)*XN(4)-R(1)*XN(1)-R(2)*XN(2)-R(3)*XN(3)
01331 RXK(I)=R(4)*XK(4)-R(1)*XK(1)-R(2)*XK(2)-R(3)*XK(3)
01332 RQP(I)=R(4)*QP(4)-R(1)*QP(1)-R(2)*QP(2)-R(3)*QP(3)
01333 7 CONTINUE
01334 QPXN=QP(4)*XN(4)-QP(1)*XN(1)-QP(2)*XN(2)-QP(3)*XN(3)
01335 QPXA=QP(4)*XA(4)-QP(1)*XA(1)-QP(2)*XA(2)-QP(3)*XA(3)
01336 QPXK=QP(4)*XK(4)-QP(1)*XK(1)-QP(2)*XK(2)-QP(3)*XK(3)
01337 c XNXA=XN(4)*XA(4)-XN(1)*XA(1)-XN(2)*XA(2)-XN(3)*XA(3)
01338 XNXK=XN(4)*XK(4)-XN(1)*XK(1)-XN(2)*XK(2)-XN(3)*XK(3)
01339 XAXK=XA(4)*XK(4)-XA(1)*XK(1)-XA(2)*XK(2)-XA(3)*XK(3)
01340 TXN=TMASS*XN(4)
01341 TXA=TMASS*XA(4)
01342 TQP=TMASS*QP(4)
01343 TXK=TMASS*XK(4)
01344 C
01345 X= XNXK/QPXN
01346 Z= TXK/TQP
01347 A= 1+X
01348 B= 1+ X*(1+Z)/2+Z/2
01349 S1= QPXN*TXA*( -EMASS2/QPXK**2*A + 2*TQP/(QPXK*TXK)*B-
01350 $TMASS2/TXK**2) +
01351 $QPXN/TXK**2* ( TMASS2*XAXK - TXA*TXK+ XAXK*TXK) -
01352 $TXA*TXN/TXK - QPXN/(QPXK*TXK)* (TQP*XAXK-TXK*QPXA)
01353 CONST4=256*PI/ALPHAI*GF**2
01354 IF (ITDKRC.EQ.0) CONST4=0D0
01355 SQM2=S1*CONST4
01356 DO 5 I=1,3
01357 S0(I) = QPXN*RXA(I)*(-EMASS2/QPXK**2*A + 2*TQP/(QPXK*TXK)*B-
01358 $ TMASS2/TXK**2) +
01359 $ QPXN/TXK**2* (TMASS2*XAXK - TXA*RXK(I)+ XAXK*RXK(I))-
01360 $ RXA(I)*TXN/TXK - QPXN/(QPXK*TXK)*(RQP(I)*XAXK- RXK(I)*QPXA)
01361 5 HV(I)=S0(I)/S1-1.D0
01362 RETURN
01363 END
01364 FUNCTION THB(ITDKRC,QP,XN,XA,AK0,HV)
01365 C
01366 C **********************************************************************
01367 C BORN +VIRTUAL+SOFT PHOTON MATRIX ELEMENT**2 O(ALPHA) *
01368 C PARAMETERS: *
01369 C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
01370 C QP,XN,XA - FOUR-MOMENTA OF ELECTRON (MUON), NU AND NUBAR IN GEV *
01371 C ALL FOUR-VECTORS IN TAU REST FRAME *
01372 C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS *
01373 C THB - VALUE FOR S=0 *
01374 C SEE EQS. (2.2),(2.4)-(2.5) FROM CJK (NUCL.PHYS.B351(1991)70 *
01375 C AND (C.2) FROM JK (NUCL.PHYS.B320(1991)20 ) *
01376 C **********************************************************************
01377 C
01378 IMPLICIT REAL*8(A-H,O-Z)
01379 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01380 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01381 * ,AMK,AMKZ,AMKST,GAMKST
01382 C
01383 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01384 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01385 * ,AMK,AMKZ,AMKST,GAMKST
01386 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01387 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01388 COMMON / QEDPRM /ALFINV,ALFPI,XK0
01389 REAL*8 ALFINV,ALFPI,XK0
01390 DIMENSION QP(4),XN(4),XA(4)
01391 REAL*8 HV(4)
01392 DIMENSION R(4)
01393 REAL*8 RXA(3),RXN(3),RQP(3)
01394 REAL*8 BORNPL(3),AM3POL(3),XM3POL(3)
01395 DATA PI /3.141592653589793238462643D0/
01396 C
01397 TMASS=AMTAU
01398 GF=GFERMI
01399 ALPHAI=ALFINV
01400 C
01401 TMASS2=TMASS**2
01402 R(4)=TMASS
01403 DO 7 I=1,3
01404 R(1)=0.D0
01405 R(2)=0.D0
01406 R(3)=0.D0
01407 R(I)=TMASS
01408 RXA(I)=R(4)*XA(4)-R(1)*XA(1)-R(2)*XA(2)-R(3)*XA(3)
01409 RXN(I)=R(4)*XN(4)-R(1)*XN(1)-R(2)*XN(2)-R(3)*XN(3)
01410 C RXK(I)=R(4)*XK(4)-R(1)*XK(1)-R(2)*XK(2)-R(3)*XK(3)
01411 RQP(I)=R(4)*QP(4)-R(1)*QP(1)-R(2)*QP(2)-R(3)*QP(3)
01412 7 CONTINUE
01413 C QUASI TWO-BODY VARIABLES
01414 U0=QP(4)/TMASS
01415 U3=SQRT(QP(1)**2+QP(2)**2+QP(3)**2)/TMASS
01416 W3=U3
01417 W0=(XN(4)+XA(4))/TMASS
01418 UP=U0+U3
01419 UM=U0-U3
01420 WP=W0+W3
01421 WM=W0-W3
01422 YU=LOG(UP/UM)/2
01423 YW=LOG(WP/WM)/2
01424 EPS2=U0**2-U3**2
01425 EPS=SQRT(EPS2)
01426 Y=W0**2-W3**2
01427 AL=AK0/TMASS
01428 C FORMFACTORS
01429 F0=2*U0/U3*( DILOGT(1-(UM*WM/(UP*WP)))- DILOGT(1-WM/WP) +
01430 $DILOGT(1-UM/UP) -2*YU+ 2*LOG(UP)*(YW+YU) ) +
01431 $1/Y* ( 2*U3*YU + (1-EPS2- 2*Y)*LOG(EPS) ) +
01432 $ 2 - 4*(U0/U3*YU -1)* LOG(2*AL)
01433 FP= YU/(2*U3)*(1 + (1-EPS2)/Y ) + LOG(EPS)/Y
01434 FM= YU/(2*U3)*(1 - (1-EPS2)/Y ) - LOG(EPS)/Y
01435 F3= EPS2*(FP+FM)/2
01436 C SCALAR PRODUCTS OF FOUR-MOMENTA
01437 QPXN=QP(4)*XN(4)-QP(1)*XN(1)-QP(2)*XN(2)-QP(3)*XN(3)
01438 QPXA=QP(4)*XA(4)-QP(1)*XA(1)-QP(2)*XA(2)-QP(3)*XA(3)
01439 XNXA=XN(4)*XA(4)-XN(1)*XA(1)-XN(2)*XA(2)-XN(3)*XA(3)
01440 TXN=TMASS*XN(4)
01441 TXA=TMASS*XA(4)
01442 TQP=TMASS*QP(4)
01443 C DECAY DIFFERENTIAL WIDTH WITHOUT AND WITH POLARIZATION
01444 CONST3=1/(2*ALPHAI*PI)*64*GF**2
01445 IF (ITDKRC.EQ.0) CONST3=0D0
01446 XM3= -( F0* QPXN*TXA + FP*EPS2* TXN*TXA +
01447 $FM* QPXN*QPXA + F3* TMASS2*XNXA )
01448 AM3=XM3*CONST3
01449 C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
01450 BRAK= (GV+GA)**2*TQP*XNXA+(GV-GA)**2*TXA*QPXN
01451 & -(GV**2-GA**2)*TMASS*AMNUTA*QPXA
01452 BORN= 32*(GFERMI**2/2.)*BRAK
01453 DO 5 I=1,3
01454 XM3POL(I)= -( F0* QPXN*RXA(I) + FP*EPS2* TXN*RXA(I) +
01455 $ FM* QPXN* (QPXA + (RXA(I)*TQP-TXA*RQP(I))/TMASS2 ) +
01456 $ F3* (TMASS2*XNXA +TXN*RXA(I) -RXN(I)*TXA) )
01457 AM3POL(I)=XM3POL(I)*CONST3
01458 C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
01459 BORNPL(I)=BORN+(
01460 & (GV+GA)**2*TMASS*XNXA*QP(I)
01461 & -(GV-GA)**2*TMASS*QPXN*XA(I)
01462 & +(GV**2-GA**2)*AMNUTA*TXA*QP(I)
01463 & -(GV**2-GA**2)*AMNUTA*TQP*XA(I) )*
01464 & 32*(GFERMI**2/2.)
01465 5 HV(I)=(BORNPL(I)+AM3POL(I))/(BORN+AM3)-1.D0
01466 THB=BORN+AM3
01467 IF (THB/BORN.LT.0.1D0) THEN
01468 PRINT *, 'ERROR IN THB, THB/BORN=',THB/BORN
01469 #if defined (CLEO)
01470 THB=0.D0
01471 #else
01472 STOP
01473 #endif
01474 ENDIF
01475 RETURN
01476 END
01477 SUBROUTINE DEXPI(MODE,ISGN,POL,PPI,PNU)
01478 C ----------------------------------------------------------------------
01479 C TAU DECAY INTO PION AND TAU-NEUTRINO
01480 C IN TAU REST FRAME
01481 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
01482 C PPI PION CHARGED
01483 C ----------------------------------------------------------------------
01484 REAL POL(4),HV(4),PNU(4),PPI(4),RN(1)
01485 CC
01486 IF(MODE.EQ.-1) THEN
01487 C ===================
01488 CALL DADMPI(-1,ISGN,HV,PPI,PNU)
01489 CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
01490
01491 ELSEIF(MODE.EQ. 0) THEN
01492 C =======================
01493 300 CONTINUE
01494 CALL DADMPI( 0,ISGN,HV,PPI,PNU)
01495 WT=(1+POL(1)*HV(1)+POL(2)*HV(2)+POL(3)*HV(3))/2.
01496 CC CALL HFILL(815,WT)
01497 CALL RANMAR(RN,1)
01498 IF(RN(1).GT.WT) GOTO 300
01499 C
01500 ELSEIF(MODE.EQ. 1) THEN
01501 C =======================
01502 CALL DADMPI( 1,ISGN,HV,PPI,PNU)
01503 CC CALL HPRINT(815)
01504 ENDIF
01505 C =====
01506 RETURN
01507 END
01508 SUBROUTINE DADMPI(MODE,ISGN,HV,PPI,PNU)
01509 C ----------------------------------------------------------------------
01510 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01511 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01512 * ,AMK,AMKZ,AMKST,GAMKST
01513 C
01514 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01515 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01516 * ,AMK,AMKZ,AMKST,GAMKST
01517 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01518 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01519 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
01520 REAL*4 GAMPMC ,GAMPER
01521 COMMON / INOUT / INUT,IOUT
01522 REAL PPI(4),PNU(4),HV(4)
01523 DATA PI /3.141592653589793238462643/
01524 C
01525 IF(MODE.EQ.-1) THEN
01526 C ===================
01527 NEVTOT=0
01528 ELSEIF(MODE.EQ. 0) THEN
01529 C =======================
01530 NEVTOT=NEVTOT+1
01531 EPI= (AMTAU**2+AMPI**2-AMNUTA**2)/(2*AMTAU)
01532 ENU= (AMTAU**2-AMPI**2+AMNUTA**2)/(2*AMTAU)
01533 XPI= SQRT(EPI**2-AMPI**2)
01534 C PI MOMENTUM
01535 CALL SPHERA(XPI,PPI)
01536 PPI(4)=EPI
01537 C TAU-NEUTRINO MOMENTUM
01538 DO 30 I=1,3
01539 30 PNU(I)=-PPI(I)
01540 PNU(4)=ENU
01541 PXQ=AMTAU*EPI
01542 PXN=AMTAU*ENU
01543 QXN=PPI(4)*PNU(4)-PPI(1)*PNU(1)-PPI(2)*PNU(2)-PPI(3)*PNU(3)
01544 BRAK=(GV**2+GA**2)*(2*PXQ*QXN-AMPI**2*PXN)
01545 & +(GV**2-GA**2)*AMTAU*AMNUTA*AMPI**2
01546 DO 40 I=1,3
01547 40 HV(I)=-ISGN*2*GA*GV*AMTAU*(2*PPI(I)*QXN-PNU(I)*AMPI**2)/BRAK
01548 HV(4)=1
01549 C
01550 ELSEIF(MODE.EQ. 1) THEN
01551 C =======================
01552 IF(NEVTOT.EQ.0) RETURN
01553 FPI=0.1284
01554 C GAMM=(GFERMI*FPI)**2/(16.*PI)*AMTAU**3*
01555 C * (BRAK/AMTAU**4)**2
01556 CZW 7.02.93 here was an error affecting non standard model
01557 C configurations only
01558 GAMM=(GFERMI*FPI)**2/(16.*PI)*AMTAU**3*
01559 $ (BRAK/AMTAU**4)*
01560 $ SQRT((AMTAU**2-AMPI**2-AMNUTA**2)**2
01561 $ -4*AMPI**2*AMNUTA**2 )/AMTAU**2
01562 ERROR=0
01563 RAT=GAMM/GAMEL
01564 WRITE(IOUT, 7010) NEVTOT,GAMM,RAT,ERROR
01565 GAMPMC(3)=RAT
01566 GAMPER(3)=ERROR
01567 CAM NEVDEC(3)=NEVTOT
01568 ENDIF
01569 C =====
01570 RETURN
01571 7010 FORMAT(///1X,15(5H*****)
01572 $ /,' *', 25X,'******** DADMPI FINAL REPORT ******** ',9X,1H*
01573 $ /,' *',I20 ,5X,'NEVTOT = NO. OF PI DECAYS TOTAL ',9X,1H*
01574 $ /,' *',E20.5,5X,'PARTIAL WTDTH ( PI DECAY) IN GEV UNITS ',9X,1H*
01575 $ /,' *',F20.9,5X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9X,1H*
01576 $ /,' *',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9X,1H*
01577 $ /,1X,15(5H*****)/)
01578 END
01579 SUBROUTINE DEXRO(MODE,ISGN,POL,PNU,PRO,PIC,PIZ)
01580 C ----------------------------------------------------------------------
01581 C THIS SIMULATES TAU DECAY IN TAU REST FRAME
01582 C INTO NU RHO, NEXT RHO DECAYS INTO PION PAIR.
01583 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
01584 C PRO RHO
01585 C PIC PION CHARGED
01586 C PIZ PION ZERO
01587 C ----------------------------------------------------------------------
01588 COMMON / INOUT / INUT,IOUT
01589 REAL POL(4),HV(4),PRO(4),PNU(4),PIC(4),PIZ(4),RN(1)
01590 DATA IWARM/0/
01591 C
01592 IF(MODE.EQ.-1) THEN
01593 C ===================
01594 IWARM=1
01595 CALL DADMRO( -1,ISGN,HV,PNU,PRO,PIC,PIZ)
01596 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXRO $',100,0,2)
01597 CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXRO $',100,0,2)
01598 C
01599 ELSEIF(MODE.EQ. 0) THEN
01600 C =======================
01601 300 CONTINUE
01602 IF(IWARM.EQ.0) GOTO 902
01603 CALL DADMRO( 0,ISGN,HV,PNU,PRO,PIC,PIZ)
01604 WT=(1+POL(1)*HV(1)+POL(2)*HV(2)+POL(3)*HV(3))/2.
01605 CC CALL HFILL(816,WT)
01606 CC XHELP=HV(1)**2+HV(2)**2+HV(3)**2
01607 CC CALL HFILL(916,XHELP)
01608 CALL RANMAR(RN,1)
01609 IF(RN(1).GT.WT) GOTO 300
01610 C
01611 ELSEIF(MODE.EQ. 1) THEN
01612 C =======================
01613 CALL DADMRO( 1,ISGN,HV,PNU,PRO,PIC,PIZ)
01614 CC CALL HPRINT(816)
01615 CC CALL HPRINT(916)
01616 ENDIF
01617 C =====
01618 RETURN
01619 902 WRITE(IOUT, 9020)
01620 9020 FORMAT(' ----- DEXRO: LACK OF INITIALISATION')
01621 STOP
01622 END
01623 SUBROUTINE DADMRO(MODE,ISGN,HHV,PNU,PRO,PIC,PIZ)
01624 C ----------------------------------------------------------------------
01625 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01626 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01627 * ,AMK,AMKZ,AMKST,GAMKST
01628 C
01629 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01630 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01631 * ,AMK,AMKZ,AMKST,GAMKST
01632 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01633 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01634 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
01635 REAL*4 GAMPMC ,GAMPER
01636 COMMON / INOUT / INUT,IOUT
01637 REAL HHV(4)
01638 REAL HV(4),PRO(4),PNU(4),PIC(4),PIZ(4)
01639 REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4)
01640 REAL*4 RRR(3)
01641 REAL*8 SWT, SSWT
01642 DATA PI /3.141592653589793238462643/
01643 DATA IWARM/0/
01644 C
01645 IF(MODE.EQ.-1) THEN
01646 C ===================
01647 IWARM=1
01648 NEVRAW=0
01649 NEVACC=0
01650 NEVOVR=0
01651 SWT=0
01652 SSWT=0
01653 WTMAX=1E-20
01654 DO 15 I=1,500
01655 CALL DPHSRO(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4)
01656 IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
01657 15 CONTINUE
01658 CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMRO $',100,0,2)
01659 CC PRINT 7003,WTMAX
01660 C
01661 ELSEIF(MODE.EQ. 0) THEN
01662 C =======================
01663 300 CONTINUE
01664 IF(IWARM.EQ.0) GOTO 902
01665 CALL DPHSRO(WT,HV,PNU,PRO,PIC,PIZ)
01666 CC CALL HFILL(801,WT/WTMAX)
01667 NEVRAW=NEVRAW+1
01668 SWT=SWT+WT
01669 SSWT=SSWT+WT**2
01670 CALL RANMAR(RRR,3)
01671 RN=RRR(1)
01672 IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
01673 IF(RN*WTMAX.GT.WT) GOTO 300
01674 C ROTATIONS TO BASIC TAU REST FRAME
01675 COSTHE=-1.+2.*RRR(2)
01676 THET=ACOS(COSTHE)
01677 PHI =2*PI*RRR(3)
01678 CALL ROTOR2(THET,PNU,PNU)
01679 CALL ROTOR3( PHI,PNU,PNU)
01680 CALL ROTOR2(THET,PRO,PRO)
01681 CALL ROTOR3( PHI,PRO,PRO)
01682 CALL ROTOR2(THET,PIC,PIC)
01683 CALL ROTOR3( PHI,PIC,PIC)
01684 CALL ROTOR2(THET,PIZ,PIZ)
01685 CALL ROTOR3( PHI,PIZ,PIZ)
01686 CALL ROTOR2(THET,HV,HV)
01687 CALL ROTOR3( PHI,HV,HV)
01688 DO 44 I=1,3
01689 44 HHV(I)=-ISGN*HV(I)
01690 NEVACC=NEVACC+1
01691 C
01692 ELSEIF(MODE.EQ. 1) THEN
01693 C =======================
01694 IF(NEVRAW.EQ.0) RETURN
01695 PARGAM=SWT/FLOAT(NEVRAW+1)
01696 ERROR=0
01697 IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
01698 RAT=PARGAM/GAMEL
01699 WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
01700 CC CALL HPRINT(801)
01701 GAMPMC(4)=RAT
01702 GAMPER(4)=ERROR
01703 CAM NEVDEC(4)=NEVACC
01704 ENDIF
01705 C =====
01706 RETURN
01707 7003 FORMAT(///1X,15(5H*****)
01708 $ /,' *', 25X,'******** DADMRO INITIALISATION ********',9X,1H*
01709 $ /,' *',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H*
01710 $ /,1X,15(5H*****)/)
01711 7010 FORMAT(///1X,15(5H*****)
01712 $ /,' *', 25X,'******** DADMRO FINAL REPORT ******** ',9X,1H*
01713 $ /,' *',I20 ,5X,'NEVRAW = NO. OF RHO DECAYS TOTAL ',9X,1H*
01714 $ /,' *',I20 ,5X,'NEVACC = NO. OF RHO DECS. ACCEPTED ',9X,1H*
01715 $ /,' *',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H*
01716 $ /,' *',E20.5,5X,'PARTIAL WTDTH (RHO DECAY) IN GEV UNITS ',9X,1H*
01717 $ /,' *',F20.9,5X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9X,1H*
01718 $ /,' *',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H*
01719 $ /,1X,15(5H*****)/)
01720 902 WRITE(IOUT, 9020)
01721 9020 FORMAT(' ----- DADMRO: LACK OF INITIALISATION')
01722 STOP
01723 END
01724 SUBROUTINE DPHSRO(DGAMT,HV,PN,PR,PIC,PIZ)
01725 C ----------------------------------------------------------------------
01726 C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
01727 C Z-AXIS ALONG RHO MOMENTUM
01728 C ----------------------------------------------------------------------
01729 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01730 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01731 * ,AMK,AMKZ,AMKST,GAMKST
01732 C
01733 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01734 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01735 * ,AMK,AMKZ,AMKST,GAMKST
01736 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01737 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01738 REAL HV(4),PT(4),PN(4),PR(4),PIC(4),PIZ(4),QQ(4),RR1(1)
01739 DATA PI /3.141592653589793238462643/
01740 DATA ICONT /0/
01741 C
01742 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
01743 PHSPAC=1./2**11/PI**5
01744 C TAU MOMENTUM
01745 PT(1)=0.
01746 PT(2)=0.
01747 PT(3)=0.
01748 PT(4)=AMTAU
01749 C MASS OF (REAL/VIRTUAL) RHO
01750 AMS1=(AMPI+AMPIZ)**2
01751 AMS2=(AMTAU-AMNUTA)**2
01752 C FLAT PHASE SPACE
01753 #if defined (ALEPH)
01754 C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
01755 #else
01756 C AMX2=AMS1+ RR1*(AMS2-AMS1)
01757 #endif
01758 C AMX=SQRT(AMX2)
01759 C PHSPAC=PHSPAC*(AMS2-AMS1)
01760 C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
01761 ALP1=ATAN((AMS1-AMRO**2)/AMRO/GAMRO)
01762 ALP2=ATAN((AMS2-AMRO**2)/AMRO/GAMRO)
01763 CAM
01764 100 CONTINUE
01765 CALL RANMAR(RR1,1)
01766 ALP=ALP1+RR1(1)*(ALP2-ALP1)
01767 AMX2=AMRO**2+AMRO*GAMRO*TAN(ALP)
01768 AMX=SQRT(AMX2)
01769 IF(AMX.LT.2.*AMPI) GO TO 100
01770 CAM
01771 PHSPAC=PHSPAC*((AMX2-AMRO**2)**2+(AMRO*GAMRO)**2)/(AMRO*GAMRO)
01772 PHSPAC=PHSPAC*(ALP2-ALP1)
01773 C
01774 C TAU-NEUTRINO MOMENTUM
01775 PN(1)=0
01776 PN(2)=0
01777 PN(4)=1./(2*AMTAU)*(AMTAU**2+AMNUTA**2-AMX**2)
01778 PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
01779 C RHO MOMENTUM
01780 PR(1)=0
01781 PR(2)=0
01782 PR(4)=1./(2*AMTAU)*(AMTAU**2-AMNUTA**2+AMX**2)
01783 PR(3)=-PN(3)
01784 PHSPAC=PHSPAC*(4*PI)*(2*PR(3)/AMTAU)
01785 C
01786 CAM
01787 ENQ1=(AMX2+AMPI**2-AMPIZ**2)/(2.*AMX)
01788 ENQ2=(AMX2-AMPI**2+AMPIZ**2)/(2.*AMX)
01789 PPPI=SQRT((ENQ1-AMPI)*(ENQ1+AMPI))
01790 PHSPAC=PHSPAC*(4*PI)*(2*PPPI/AMX)
01791 C CHARGED PI MOMENTUM IN RHO REST FRAME
01792 CALL SPHERA(PPPI,PIC)
01793 PIC(4)=ENQ1
01794 C NEUTRAL PI MOMENTUM IN RHO REST FRAME
01795 DO 20 I=1,3
01796 20 PIZ(I)=-PIC(I)
01797 PIZ(4)=ENQ2
01798 EXE=(PR(4)+PR(3))/AMX
01799 C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
01800 CALL BOSTR3(EXE,PIC,PIC)
01801 CALL BOSTR3(EXE,PIZ,PIZ)
01802 DO 30 I=1,4
01803 30 QQ(I)=PIC(I)-PIZ(I)
01804 C AMPLITUDE
01805 PRODPQ=PT(4)*QQ(4)
01806 PRODNQ=PN(4)*QQ(4)-PN(1)*QQ(1)-PN(2)*QQ(2)-PN(3)*QQ(3)
01807 PRODPN=PT(4)*PN(4)
01808 QQ2= QQ(4)**2-QQ(1)**2-QQ(2)**2-QQ(3)**2
01809 BRAK=(GV**2+GA**2)*(2*PRODPQ*PRODNQ-PRODPN*QQ2)
01810 & +(GV**2-GA**2)*AMTAU*AMNUTA*QQ2
01811 AMPLIT=(GFERMI*CCABIB)**2*BRAK*2*FPIRHO(AMX)
01812 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
01813 DO 40 I=1,3
01814 40 HV(I)=2*GV*GA*AMTAU*(2*PRODNQ*QQ(I)-QQ2*PN(I))/BRAK
01815 RETURN
01816 END
01817 SUBROUTINE DEXAA(MODE,ISGN,POL,PNU,PAA,PIM1,PIM2,PIPL,JAA)
01818 C ----------------------------------------------------------------------
01819 * THIS SIMULATES TAU DECAY IN TAU REST FRAME
01820 * INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
01821 * OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
01822 * PAA A1
01823 * PIM1 PION MINUS (OR PI0) 1 (FOR TAU MINUS)
01824 * PIM2 PION MINUS (OR PI0) 2
01825 * PIPL PION PLUS (OR PI-)
01826 * (PIPL,PIM1) FORM A RHO
01827 C ----------------------------------------------------------------------
01828 COMMON / INOUT / INUT,IOUT
01829 REAL POL(4),HV(4),PAA(4),PNU(4),PIM1(4),PIM2(4),PIPL(4),RN(1)
01830 DATA IWARM/0/
01831 C
01832 IF(MODE.EQ.-1) THEN
01833 C ===================
01834 IWARM=1
01835 CALL DADMAA( -1,ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
01836 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXAA $',100,-2.,2.)
01837 C
01838 ELSEIF(MODE.EQ. 0) THEN
01839 * =======================
01840 300 CONTINUE
01841 IF(IWARM.EQ.0) GOTO 902
01842 CALL DADMAA( 0,ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
01843 WT=(1+POL(1)*HV(1)+POL(2)*HV(2)+POL(3)*HV(3))/2.
01844 CC CALL HFILL(816,WT)
01845 CALL RANMAR(RN,1)
01846 IF(RN(1).GT.WT) GOTO 300
01847 C
01848 ELSEIF(MODE.EQ. 1) THEN
01849 * =======================
01850 CALL DADMAA( 1,ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
01851 CC CALL HPRINT(816)
01852 ENDIF
01853 C =====
01854 RETURN
01855 902 WRITE(IOUT, 9020)
01856 9020 FORMAT(' ----- DEXAA: LACK OF INITIALISATION')
01857 STOP
01858 END
01859 SUBROUTINE DADMAA(MODE,ISGN,HHV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
01860 C ----------------------------------------------------------------------
01861 * A1 DECAY UNWEIGHTED EVENTS
01862 C ----------------------------------------------------------------------
01863 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01864 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01865 * ,AMK,AMKZ,AMKST,GAMKST
01866 C
01867 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01868 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01869 * ,AMK,AMKZ,AMKST,GAMKST
01870 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01871 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
01872 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
01873 REAL*4 GAMPMC ,GAMPER
01874 COMMON / INOUT / INUT,IOUT
01875 REAL HHV(4)
01876 REAL HV(4),PAA(4),PNU(4),PIM1(4),PIM2(4),PIPL(4)
01877 REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
01878 REAL*4 RRR(3)
01879 REAL*8 SWT, SSWT
01880 DATA PI /3.141592653589793238462643/
01881 DATA IWARM/0/
01882 C
01883 IF(MODE.EQ.-1) THEN
01884 C ===================
01885 IWARM=1
01886 NEVRAW=0
01887 NEVACC=0
01888 NEVOVR=0
01889 SWT=0
01890 SSWT=0
01891 WTMAX=1E-20
01892 DO 15 I=1,500
01893 CALL DPHSAA(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JAA)
01894 IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
01895 15 CONTINUE
01896 CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMAA $',100,0,2)
01897 C
01898 ELSEIF(MODE.EQ. 0) THEN
01899 C =======================
01900 300 CONTINUE
01901 IF(IWARM.EQ.0) GOTO 902
01902 CALL DPHSAA(WT,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
01903 CC CALL HFILL(801,WT/WTMAX)
01904 NEVRAW=NEVRAW+1
01905 SWT=SWT+WT
01906 #if defined (ALEPH)
01907 SSWT=SSWT+WT**2
01908 #else
01909 ccM.S.>>>>>>
01910 cc SSWT=SSWT+WT**2
01911 SSWT=SSWT+dble(WT)**2
01912 ccM.S.<<<<<<
01913 #endif
01914 CALL RANMAR(RRR,3)
01915 RN=RRR(1)
01916 IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
01917 IF(RN*WTMAX.GT.WT) GOTO 300
01918 C ROTATIONS TO BASIC TAU REST FRAME
01919 COSTHE=-1.+2.*RRR(2)
01920 THET=ACOS(COSTHE)
01921 PHI =2*PI*RRR(3)
01922 CALL ROTPOL(THET,PHI,PNU)
01923 CALL ROTPOL(THET,PHI,PAA)
01924 CALL ROTPOL(THET,PHI,PIM1)
01925 CALL ROTPOL(THET,PHI,PIM2)
01926 CALL ROTPOL(THET,PHI,PIPL)
01927 CALL ROTPOL(THET,PHI,HV)
01928 DO 44 I=1,3
01929 44 HHV(I)=-ISGN*HV(I)
01930 NEVACC=NEVACC+1
01931 C
01932 ELSEIF(MODE.EQ. 1) THEN
01933 C =======================
01934 IF(NEVRAW.EQ.0) RETURN
01935 PARGAM=SWT/FLOAT(NEVRAW+1)
01936 ERROR=0
01937 IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
01938 RAT=PARGAM/GAMEL
01939 WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
01940 CC CALL HPRINT(801)
01941 GAMPMC(5)=RAT
01942 GAMPER(5)=ERROR
01943 CAM NEVDEC(5)=NEVACC
01944 ENDIF
01945 C =====
01946 RETURN
01947 7003 FORMAT(///1X,15(5H*****)
01948 $ /,' *', 25X,'******** DADMAA INITIALISATION ********',9X,1H*
01949 $ /,' *',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H*
01950 $ /,1X,15(5H*****)/)
01951 7010 FORMAT(///1X,15(5H*****)
01952 $ /,' *', 25X,'******** DADMAA FINAL REPORT ******** ',9X,1H*
01953 $ /,' *',I20 ,5X,'NEVRAW = NO. OF A1 DECAYS TOTAL ',9X,1H*
01954 $ /,' *',I20 ,5X,'NEVACC = NO. OF A1 DECS. ACCEPTED ',9X,1H*
01955 $ /,' *',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H*
01956 $ /,' *',E20.5,5X,'PARTIAL WTDTH (A1 DECAY) IN GEV UNITS ',9X,1H*
01957 $ /,' *',F20.9,5X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9X,1H*
01958 $ /,' *',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H*
01959 $ /,1X,15(5H*****)/)
01960 902 WRITE(IOUT, 9020)
01961 9020 FORMAT(' ----- DADMAA: LACK OF INITIALISATION')
01962 STOP
01963 END
01964 SUBROUTINE DPHSAA(DGAMT,HV,PN,PAA,PIM1,PIM2,PIPL,JAA)
01965 C ----------------------------------------------------------------------
01966 * IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
01967 * Z-AXIS ALONG A1 MOMENTUM
01968 C ----------------------------------------------------------------------
01969 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01970 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01971 * ,AMK,AMKZ,AMKST,GAMKST
01972 C
01973 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
01974 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
01975 * ,AMK,AMKZ,AMKST,GAMKST
01976 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
01977 REAL*4 BRA1,BRK0,BRK0B,BRKS
01978 REAL HV(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
01979
01980
01981 REAL*4 RRR(1)
01982 C MATRIX ELEMENT NUMBER:
01983 MNUM=0
01984 C TYPE OF THE GENERATION:
01985 KEYT=1
01986 CALL RANMAR(RRR,1)
01987 RMOD=RRR(1)
01988 IF (RMOD.LT.BRA1) THEN
01989 JAA=1
01990 AMP1=AMPI
01991 AMP2=AMPI
01992 AMP3=AMPI
01993 ELSE
01994 JAA=2
01995 AMP1=AMPIZ
01996 AMP2=AMPIZ
01997 AMP3=AMPI
01998 ENDIF
01999 CALL
02000 $ DPHTRE(DGAMT,HV,PN,PAA,PIM1,AMP1,PIM2,AMP2,PIPL,AMP3,KEYT,MNUM)
02001 END
02002 SUBROUTINE DEXKK(MODE,ISGN,POL,PKK,PNU)
02003 C ----------------------------------------------------------------------
02004 C TAU DECAY INTO KAON AND TAU-NEUTRINO
02005 C IN TAU REST FRAME
02006 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
02007 C PKK KAON CHARGED
02008 C ----------------------------------------------------------------------
02009 REAL POL(4),HV(4),PNU(4),PKK(4),RN(1)
02010 C
02011 IF(MODE.EQ.-1) THEN
02012 C ===================
02013 CALL DADMKK(-1,ISGN,HV,PKK,PNU)
02014 CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
02015 C
02016 ELSEIF(MODE.EQ. 0) THEN
02017 C =======================
02018 300 CONTINUE
02019 CALL DADMKK( 0,ISGN,HV,PKK,PNU)
02020 WT=(1+POL(1)*HV(1)+POL(2)*HV(2)+POL(3)*HV(3))/2.
02021 CC CALL HFILL(815,WT)
02022 CALL RANMAR(RN,1)
02023 IF(RN(1).GT.WT) GOTO 300
02024 C
02025 ELSEIF(MODE.EQ. 1) THEN
02026 C =======================
02027 CALL DADMKK( 1,ISGN,HV,PKK,PNU)
02028 CC CALL HPRINT(815)
02029 ENDIF
02030 C =====
02031 RETURN
02032 END
02033 SUBROUTINE DADMKK(MODE,ISGN,HV,PKK,PNU)
02034 C ----------------------------------------------------------------------
02035 C FZ
02036 #if defined (ALEPH)
02037 #else
02038 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02039 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02040 #endif
02041 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02042 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02043 * ,AMK,AMKZ,AMKST,GAMKST
02044 C
02045 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02046 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02047 * ,AMK,AMKZ,AMKST,GAMKST
02048 #if defined (ALEPH)
02049 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02050 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02051 #else
02052 #endif
02053 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
02054 REAL*4 GAMPMC ,GAMPER
02055 COMMON / INOUT / INUT,IOUT
02056 REAL PKK(4),PNU(4),HV(4)
02057 DATA PI /3.141592653589793238462643/
02058 C
02059 IF(MODE.EQ.-1) THEN
02060 C ===================
02061 NEVTOT=0
02062 ELSEIF(MODE.EQ. 0) THEN
02063 C =======================
02064 NEVTOT=NEVTOT+1
02065 EKK= (AMTAU**2+AMK**2-AMNUTA**2)/(2*AMTAU)
02066 ENU= (AMTAU**2-AMK**2+AMNUTA**2)/(2*AMTAU)
02067 XKK= SQRT(EKK**2-AMK**2)
02068 C K MOMENTUM
02069 CALL SPHERA(XKK,PKK)
02070 PKK(4)=EKK
02071 C TAU-NEUTRINO MOMENTUM
02072 DO 30 I=1,3
02073 30 PNU(I)=-PKK(I)
02074 PNU(4)=ENU
02075 PXQ=AMTAU*EKK
02076 PXN=AMTAU*ENU
02077 QXN=PKK(4)*PNU(4)-PKK(1)*PNU(1)-PKK(2)*PNU(2)-PKK(3)*PNU(3)
02078 BRAK=(GV**2+GA**2)*(2*PXQ*QXN-AMK**2*PXN)
02079 & +(GV**2-GA**2)*AMTAU*AMNUTA*AMK**2
02080 DO 40 I=1,3
02081 40 HV(I)=-ISGN*2*GA*GV*AMTAU*(2*PKK(I)*QXN-PNU(I)*AMK**2)/BRAK
02082 HV(4)=1
02083 C
02084 ELSEIF(MODE.EQ. 1) THEN
02085 C =======================
02086 IF(NEVTOT.EQ.0) RETURN
02087 FKK=0.0354
02088 CFZ THERE WAS BRAK/AMTAU**4 BEFORE
02089 C GAMM=(GFERMI*FKK)**2/(16.*PI)*AMTAU**3*
02090 C * (BRAK/AMTAU**4)**2
02091 CZW 7.02.93 here was an error affecting non standard model
02092 C configurations only
02093 GAMM=(GFERMI*FKK)**2/(16.*PI)*AMTAU**3*
02094 $ (BRAK/AMTAU**4)*
02095 $ SQRT((AMTAU**2-AMK**2-AMNUTA**2)**2
02096 $ -4*AMK**2*AMNUTA**2 )/AMTAU**2
02097 ERROR=0
02098
02099 ERROR=0
02100 RAT=GAMM/GAMEL
02101 WRITE(IOUT, 7010) NEVTOT,GAMM,RAT,ERROR
02102 GAMPMC(6)=RAT
02103 GAMPER(6)=ERROR
02104 CAM NEVDEC(6)=NEVTOT
02105 ENDIF
02106 C =====
02107 RETURN
02108 7010 FORMAT(///1X,15(5H*****)
02109 $ /,' *', 25X,'******** DADMKK FINAL REPORT ********',9X,1H*
02110 $ /,' *',I20 ,5X,'NEVTOT = NO. OF K DECAYS TOTAL ',9X,1H*,
02111 $ /,' *',E20.5,5X,'PARTIAL WTDTH ( K DECAY) IN GEV UNITS ',9X,1H*,
02112 $ /,' *',F20.9,5X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9X,1H*
02113 $ /,' *',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9X,1H*
02114 $ /,1X,15(5H*****)/)
02115 END
02116 SUBROUTINE DEXKS(MODE,ISGN,POL,PNU,PKS,PKK,PPI,JKST)
02117 C ----------------------------------------------------------------------
02118 C THIS SIMULATES TAU DECAY IN TAU REST FRAME
02119 C INTO NU K*, THEN K* DECAYS INTO PI0,K+-(JKST=20)
02120 C OR PI+-,K0(JKST=10).
02121 C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
02122 C PKS K* CHARGED
02123 C PK0 K ZERO
02124 C PKC K CHARGED
02125 C PIC PION CHARGED
02126 C PIZ PION ZERO
02127 C ----------------------------------------------------------------------
02128 COMMON / INOUT / INUT,IOUT
02129 REAL POL(4),HV(4),PKS(4),PNU(4),PKK(4),PPI(4),RN(1)
02130 DATA IWARM/0/
02131 C
02132 IF(MODE.EQ.-1) THEN
02133 C ===================
02134 IWARM=1
02135 CFZ INITIALISATION DONE WITH THE GHARGED PION NEUTRAL KAON MODE(JKST=10
02136 CALL DADMKS( -1,ISGN,HV,PNU,PKS,PKK,PPI,JKST)
02137 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXKS $',100,0,2)
02138 CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXKS $',100,0,2)
02139 C
02140 ELSEIF(MODE.EQ. 0) THEN
02141 C =======================
02142 300 CONTINUE
02143 IF(IWARM.EQ.0) GOTO 902
02144 CALL DADMKS( 0,ISGN,HV,PNU,PKS,PKK,PPI,JKST)
02145 WT=(1+POL(1)*HV(1)+POL(2)*HV(2)+POL(3)*HV(3))/2.
02146 CC CALL HFILL(816,WT)
02147 CC XHELP=HV(1)**2+HV(2)**2+HV(3)**2
02148 CC CALL HFILL(916,XHELP)
02149 CALL RANMAR(RN,1)
02150 IF(RN(1).GT.WT) GOTO 300
02151 C
02152 ELSEIF(MODE.EQ. 1) THEN
02153 C ======================================
02154 CALL DADMKS( 1,ISGN,HV,PNU,PKS,PKK,PPI,JKST)
02155 CC CALL HPRINT(816)
02156 CC CALL HPRINT(916)
02157 ENDIF
02158 C =====
02159 RETURN
02160 902 WRITE(IOUT, 9020)
02161 9020 FORMAT(' ----- DEXKS: LACK OF INITIALISATION')
02162 STOP
02163 END
02164 SUBROUTINE DADMKS(MODE,ISGN,HHV,PNU,PKS,PKK,PPI,JKST)
02165 C ----------------------------------------------------------------------
02166 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02167 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02168 * ,AMK,AMKZ,AMKST,GAMKST
02169 C
02170 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02171 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02172 * ,AMK,AMKZ,AMKST,GAMKST
02173 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02174 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02175 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
02176 REAL*4 GAMPMC ,GAMPER
02177 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
02178 REAL*4 BRA1,BRK0,BRK0B,BRKS
02179 COMMON / INOUT / INUT,IOUT
02180 REAL HHV(4)
02181 REAL HV(4),PKS(4),PNU(4),PKK(4),PPI(4)
02182 REAL PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4)
02183 REAL*4 RRR(3),RMOD(1)
02184 REAL*8 SWT, SSWT
02185 DATA PI /3.141592653589793238462643/
02186 DATA IWARM/0/
02187 C
02188 IF(MODE.EQ.-1) THEN
02189 C ===================
02190 IWARM=1
02191 NEVRAW=0
02192 NEVACC=0
02193 NEVOVR=0
02194 SWT=0
02195 SSWT=0
02196 WTMAX=1E-20
02197 DO 15 I=1,500
02198 C THE INITIALISATION IS DONE WITH THE 66.7% MODE
02199 JKST=10
02200 CALL DPHSKS(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,JKST)
02201 IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
02202 15 CONTINUE
02203 CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMKS $',100,0,2)
02204 CC PRINT 7003,WTMAX
02205 CC CALL HBOOK1(112,'-------- K* MASS -------- $',100,0.,2.)
02206 ELSEIF(MODE.EQ. 0) THEN
02207 C =====================================
02208 IF(IWARM.EQ.0) GOTO 902
02209 C HERE WE CHOOSE RANDOMLY BETWEEN K0 PI+_ (66.7%)
02210 C AND K+_ PI0 (33.3%)
02211 DEC1=BRKS
02212 400 CONTINUE
02213 CALL RANMAR(RMOD,1)
02214 IF(RMOD(1).LT.DEC1) THEN
02215 JKST=10
02216 ELSE
02217 JKST=20
02218 ENDIF
02219 CALL DPHSKS(WT,HV,PNU,PKS,PKK,PPI,JKST)
02220 CALL RANMAR(RRR,3)
02221 RN=RRR(1)
02222 IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
02223 NEVRAW=NEVRAW+1
02224 SWT=SWT+WT
02225 SSWT=SSWT+WT**2
02226 IF(RN*WTMAX.GT.WT) GOTO 400
02227 C ROTATIONS TO BASIC TAU REST FRAME
02228 COSTHE=-1.+2.*RRR(2)
02229 THET=ACOS(COSTHE)
02230 PHI =2*PI*RRR(3)
02231 CALL ROTOR2(THET,PNU,PNU)
02232 CALL ROTOR3( PHI,PNU,PNU)
02233 CALL ROTOR2(THET,PKS,PKS)
02234 CALL ROTOR3( PHI,PKS,PKS)
02235 CALL ROTOR2(THET,PKK,PKK)
02236 CALL ROTOR3(PHI,PKK,PKK)
02237 CALL ROTOR2(THET,PPI,PPI)
02238 CALL ROTOR3( PHI,PPI,PPI)
02239 CALL ROTOR2(THET,HV,HV)
02240 CALL ROTOR3( PHI,HV,HV)
02241 DO 44 I=1,3
02242 44 HHV(I)=-ISGN*HV(I)
02243 NEVACC=NEVACC+1
02244 C
02245 ELSEIF(MODE.EQ. 1) THEN
02246 C =======================
02247 IF(NEVRAW.EQ.0) RETURN
02248 PARGAM=SWT/FLOAT(NEVRAW+1)
02249 ERROR=0
02250 IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
02251 RAT=PARGAM/GAMEL
02252 WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
02253 CC CALL HPRINT(801)
02254 GAMPMC(7)=RAT
02255 GAMPER(7)=ERROR
02256 CAM NEVDEC(7)=NEVACC
02257 ENDIF
02258 C =====
02259 RETURN
02260 7003 FORMAT(///1X,15(5H*****)
02261 $ /,' *', 25X,'******** DADMKS INITIALISATION ********',9X,1H*
02262 $ /,' *',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H*
02263 $ /,1X,15(5H*****)/)
02264 7010 FORMAT(///1X,15(5H*****)
02265 $ /,' *', 25X,'******** DADMKS FINAL REPORT ********',9X,1H*
02266 $ /,' *',I20 ,5X,'NEVRAW = NO. OF K* DECAYS TOTAL ',9X,1H*,
02267 $ /,' *',I20 ,5X,'NEVACC = NO. OF K* DECS. ACCEPTED ',9X,1H*,
02268 $ /,' *',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H*
02269 $ /,' *',E20.5,5X,'PARTIAL WTDTH (K* DECAY) IN GEV UNITS ',9X,1H*,
02270 $ /,' *',F20.9,5X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9X,1H*
02271 $ /,' *',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H*
02272 $ /,1X,15(5H*****)/)
02273 902 WRITE(IOUT, 9020)
02274 9020 FORMAT(' ----- DADMKS: LACK OF INITIALISATION')
02275 STOP
02276 END
02277 SUBROUTINE DPHSKS(DGAMT,HV,PN,PKS,PKK,PPI,JKST)
02278 C ----------------------------------------------------------------------
02279 C IT SIMULATES KAON* DECAY IN TAU REST FRAME WITH
02280 C Z-AXIS ALONG KAON* MOMENTUM
02281 C JKST=10 FOR K* --->K0 + PI+-
02282 C JKST=20 FOR K* --->K+- + PI0
02283 C ----------------------------------------------------------------------
02284 #if defined (ALEPH)
02285 #else
02286 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02287 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02288 #endif
02289 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02290 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02291 * ,AMK,AMKZ,AMKST,GAMKST
02292 C
02293 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02294 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02295 * ,AMK,AMKZ,AMKST,GAMKST
02296 #if defined (ALEPH)
02297 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02298 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02299 #else
02300 #endif
02301 REAL HV(4),PT(4),PN(4),PKS(4),PKK(4),PPI(4),QQ(4),RR1(1)
02302 #if defined (ALEPH)
02303 cam COMPLEX BWIGS
02304 COMPLEX BWIGM
02305 #else
02306 COMPLEX BWIGS
02307 #endif
02308 DATA PI /3.141592653589793238462643/
02309 C
02310 DATA ICONT /0/
02311 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
02312 PHSPAC=1./2**11/PI**5
02313 C TAU MOMENTUM
02314 PT(1)=0.
02315 PT(2)=0.
02316 PT(3)=0.
02317 PT(4)=AMTAU
02318 CALL RANMAR(RR1,1)
02319 C HERE BEGIN THE K0,PI+_ DECAY
02320 IF(JKST.EQ.10)THEN
02321 C ==================
02322 C MASS OF (REAL/VIRTUAL) K*
02323 AMS1=(AMPI+AMKZ)**2
02324 AMS2=(AMTAU-AMNUTA)**2
02325 C FLAT PHASE SPACE
02326 C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
02327 C AMX=SQRT(AMX2)
02328 C PHSPAC=PHSPAC*(AMS2-AMS1)
02329 C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
02330 ALP1=ATAN((AMS1-AMKST**2)/AMKST/GAMKST)
02331 ALP2=ATAN((AMS2-AMKST**2)/AMKST/GAMKST)
02332 ALP=ALP1+RR1(1)*(ALP2-ALP1)
02333 AMX2=AMKST**2+AMKST*GAMKST*TAN(ALP)
02334 AMX=SQRT(AMX2)
02335 PHSPAC=PHSPAC*((AMX2-AMKST**2)**2+(AMKST*GAMKST)**2)
02336 & /(AMKST*GAMKST)
02337 PHSPAC=PHSPAC*(ALP2-ALP1)
02338 C
02339 C TAU-NEUTRINO MOMENTUM
02340 PN(1)=0
02341 PN(2)=0
02342 PN(4)=1./(2*AMTAU)*(AMTAU**2+AMNUTA**2-AMX**2)
02343 PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
02344 C
02345 C K* MOMENTUM
02346 PKS(1)=0
02347 PKS(2)=0
02348 PKS(4)=1./(2*AMTAU)*(AMTAU**2-AMNUTA**2+AMX**2)
02349 PKS(3)=-PN(3)
02350 PHSPAC=PHSPAC*(4*PI)*(2*PKS(3)/AMTAU)
02351 C
02352 CAM
02353 ENPI=( AMX**2+AMPI**2-AMKZ**2 ) / ( 2*AMX )
02354 PPPI=SQRT((ENPI-AMPI)*(ENPI+AMPI))
02355 PHSPAC=PHSPAC*(4*PI)*(2*PPPI/AMX)
02356 C CHARGED PI MOMENTUM IN KAON* REST FRAME
02357 CALL SPHERA(PPPI,PPI)
02358 PPI(4)=ENPI
02359 C NEUTRAL KAON MOMENTUM IN K* REST FRAME
02360 DO 20 I=1,3
02361 20 PKK(I)=-PPI(I)
02362 PKK(4)=( AMX**2+AMKZ**2-AMPI**2 ) / ( 2*AMX )
02363 EXE=(PKS(4)+PKS(3))/AMX
02364 C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
02365 CALL BOSTR3(EXE,PPI,PPI)
02366 CALL BOSTR3(EXE,PKK,PKK)
02367 DO 30 I=1,4
02368 30 QQ(I)=PPI(I)-PKK(I)
02369 C QQ transverse to PKS
02370 PKSD =PKS(4)*PKS(4)-PKS(3)*PKS(3)-PKS(2)*PKS(2)-PKS(1)*PKS(1)
02371 QQPKS=PKS(4)* QQ(4)-PKS(3)* QQ(3)-PKS(2)* QQ(2)-PKS(1)* QQ(1)
02372 DO 31 I=1,4
02373 31 QQ(I)=QQ(I)-PKS(I)*QQPKS/PKSD
02374 C AMPLITUDE
02375 PRODPQ=PT(4)*QQ(4)
02376 PRODNQ=PN(4)*QQ(4)-PN(1)*QQ(1)-PN(2)*QQ(2)-PN(3)*QQ(3)
02377 PRODPN=PT(4)*PN(4)
02378 QQ2= QQ(4)**2-QQ(1)**2-QQ(2)**2-QQ(3)**2
02379 BRAK=(GV**2+GA**2)*(2*PRODPQ*PRODNQ-PRODPN*QQ2)
02380 & +(GV**2-GA**2)*AMTAU*AMNUTA*QQ2
02381 C A SIMPLE BREIT-WIGNER IS CHOSEN FOR K* RESONANCE
02382 #if defined (ALEPH)
02383 cam FKS=CABS(BWIGS(AMX2,AMKST,GAMKST))**2
02384 FKS=CABS(BWIGM(AMX2,AMKST,GAMKST,AMPI,AMKZ))**2
02385 #else
02386 FKS=CABS(BWIGS(AMX2,AMKST,GAMKST))**2
02387 #endif
02388 AMPLIT=(GFERMI*SCABIB)**2*BRAK*2*FKS
02389 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
02390 DO 40 I=1,3
02391 40 HV(I)=2*GV*GA*AMTAU*(2*PRODNQ*QQ(I)-QQ2*PN(I))/BRAK
02392 C
02393 C HERE BEGIN THE K+-,PI0 DECAY
02394 ELSEIF(JKST.EQ.20)THEN
02395 C ======================
02396 C MASS OF (REAL/VIRTUAL) K*
02397 AMS1=(AMPIZ+AMK)**2
02398 AMS2=(AMTAU-AMNUTA)**2
02399 C FLAT PHASE SPACE
02400 #if defined (ALEPH)
02401 C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
02402 #else
02403 C AMX2=AMS1+ RR1*(AMS2-AMS1)
02404 #endif
02405 C AMX=SQRT(AMX2)
02406 C PHSPAC=PHSPAC*(AMS2-AMS1)
02407 C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
02408 ALP1=ATAN((AMS1-AMKST**2)/AMKST/GAMKST)
02409 ALP2=ATAN((AMS2-AMKST**2)/AMKST/GAMKST)
02410 ALP=ALP1+RR1(1)*(ALP2-ALP1)
02411 AMX2=AMKST**2+AMKST*GAMKST*TAN(ALP)
02412 AMX=SQRT(AMX2)
02413 PHSPAC=PHSPAC*((AMX2-AMKST**2)**2+(AMKST*GAMKST)**2)
02414 & /(AMKST*GAMKST)
02415 PHSPAC=PHSPAC*(ALP2-ALP1)
02416 C
02417 C TAU-NEUTRINO MOMENTUM
02418 PN(1)=0
02419 PN(2)=0
02420 PN(4)=1./(2*AMTAU)*(AMTAU**2+AMNUTA**2-AMX**2)
02421 PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
02422 C KAON* MOMENTUM
02423 PKS(1)=0
02424 PKS(2)=0
02425 PKS(4)=1./(2*AMTAU)*(AMTAU**2-AMNUTA**2+AMX**2)
02426 PKS(3)=-PN(3)
02427 PHSPAC=PHSPAC*(4*PI)*(2*PKS(3)/AMTAU)
02428 C
02429 CAM
02430 ENPI=( AMX**2+AMPIZ**2-AMK**2 ) / ( 2*AMX )
02431 PPPI=SQRT((ENPI-AMPIZ)*(ENPI+AMPIZ))
02432 PHSPAC=PHSPAC*(4*PI)*(2*PPPI/AMX)
02433 C NEUTRAL PI MOMENTUM IN K* REST FRAME
02434 CALL SPHERA(PPPI,PPI)
02435 PPI(4)=ENPI
02436 C CHARGED KAON MOMENTUM IN K* REST FRAME
02437 DO 50 I=1,3
02438 50 PKK(I)=-PPI(I)
02439 PKK(4)=( AMX**2+AMK**2-AMPIZ**2 ) / ( 2*AMX )
02440 EXE=(PKS(4)+PKS(3))/AMX
02441 C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
02442 CALL BOSTR3(EXE,PPI,PPI)
02443 CALL BOSTR3(EXE,PKK,PKK)
02444 DO 60 I=1,4
02445 60 QQ(I)=PKK(I)-PPI(I)
02446 C QQ transverse to PKS
02447 PKSD =PKS(4)*PKS(4)-PKS(3)*PKS(3)-PKS(2)*PKS(2)-PKS(1)*PKS(1)
02448 QQPKS=PKS(4)* QQ(4)-PKS(3)* QQ(3)-PKS(2)* QQ(2)-PKS(1)* QQ(1)
02449 DO 61 I=1,4
02450 61 QQ(I)=QQ(I)-PKS(I)*QQPKS/PKSD
02451 C AMPLITUDE
02452 PRODPQ=PT(4)*QQ(4)
02453 PRODNQ=PN(4)*QQ(4)-PN(1)*QQ(1)-PN(2)*QQ(2)-PN(3)*QQ(3)
02454 PRODPN=PT(4)*PN(4)
02455 QQ2= QQ(4)**2-QQ(1)**2-QQ(2)**2-QQ(3)**2
02456 BRAK=(GV**2+GA**2)*(2*PRODPQ*PRODNQ-PRODPN*QQ2)
02457 & +(GV**2-GA**2)*AMTAU*AMNUTA*QQ2
02458 C A SIMPLE BREIT-WIGNER IS CHOSEN FOR THE K* RESONANCE
02459 #if defined (ALEPH)
02460 cam FKS=CABS(BWIGS(AMX2,AMKST,GAMKST))**2
02461 FKS=CABS(BWIGM(AMX2,AMKST,GAMKST,AMK,AMPIZ))**2
02462 #else
02463 FKS=CABS(BWIGS(AMX2,AMKST,GAMKST))**2
02464 #endif
02465 AMPLIT=(GFERMI*SCABIB)**2*BRAK*2*FKS
02466 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
02467 DO 70 I=1,3
02468 70 HV(I)=2*GV*GA*AMTAU*(2*PRODNQ*QQ(I)-QQ2*PN(I))/BRAK
02469 ENDIF
02470 RETURN
02471 END
02472
02473
02474
02475 #if defined (ALEPH)
02476 SUBROUTINE DPHNPI(DGAMT,HV,PN,PR,PPI,JNPI)
02477 #else
02478 SUBROUTINE DPHNPI(DGAMT,HVX,PNX,PRX,PPIX,JNPI)
02479 #endif
02480 C ----------------------------------------------------------------------
02481 C IT SIMULATES MULTIPI DECAY IN TAU REST FRAME WITH
02482 C Z-AXIS OPPOSITE TO NEUTRINO MOMENTUM
02483 C ----------------------------------------------------------------------
02484 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02485 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02486 * ,AMK,AMKZ,AMKST,GAMKST
02487 C
02488 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02489 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02490 * ,AMK,AMKZ,AMKST,GAMKST
02491 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02492 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
02493 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
02494 #if defined (ALEPH)
02495 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
02496 & ,NAMES
02497 CHARACTER NAMES(NMODE)*31
02498 C
02499 #else
02500 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
02501 & ,NAMES
02502 CHARACTER NAMES(NMODE)*31
02503 REAL*8 WETMAX(20)
02504 C
02505 #endif
02506 #if defined (ALEPH)
02507 REAL PN(4),PR(4),PPI(4,9),HV(4)
02508 REAL PV(5,9),PT(4),UE(3),BE(3)
02509 REAL*4 RRR(9),RORD(9),RR1(1)
02510 real dpar(8)
02511 C
02512 DATA PI /3.141592653589793238462643/
02513 DATA DPAR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5/
02514 C
02515 C PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
02516 PAWT(A,B,C)=SQRT(MAX(0.,(A**2-(B+C)**2)*(A**2-(B-C)**2)))/(2.*A)
02517 #else
02518 REAL*8 PN(4),PR(4),PPI(4,9),HV(4)
02519 REAL*4 PNX(4),PRX(4),PPIX(4,9),HVX(4)
02520 REAL*8 PV(5,9),PT(4),UE(3),BE(3)
02521 REAL*8 PAWT,AMX,AMS1,AMS2,PA,PHS,PHSMAX,PMIN,PMAX
02522
02523 REAL*8 PHSPAC
02524
02525 REAL*8 GAM,BEP,PHI,A,B,C
02526 REAL*8 AMPIK
02527 REAL*4 RRR(9),RRX(2),RN(1),RR2(1)
02528 C
02529 DATA PI /3.141592653589793238462643/
02530 DATA WETMAX /20*1D-15/
02531 C
02532 CC-- PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2.*A)
02533 C
02534 PAWT(A,B,C)=
02535 $ SQRT(MAX(0.D0,(A**2-(B+C)**2)*(A**2-(B-C)**2)))/(2.D0*A)
02536 #endif
02537 C
02538 AMPIK(I,J)=DCDMAS(IDFFIN(I,J))
02539 C
02540 C
02541 #if defined (ALEPH)
02542 #else
02543 IF ((JNPI.LE.0).OR.JNPI.GT.20) THEN
02544 WRITE(6,*) 'JNPI OUTSIDE RANGE DEFINED BY WETMAX; JNPI=',JNPI
02545 STOP
02546 ENDIF
02547
02548 #endif
02549 C TAU MOMENTUM
02550 PT(1)=0.
02551 PT(2)=0.
02552 PT(3)=0.
02553 PT(4)=AMTAU
02554 C
02555 #if defined (ALEPH)
02556 #else
02557 500 CONTINUE
02558 #endif
02559 C MASS OF VIRTUAL W
02560 ND=MULPIK(JNPI)
02561 PS=0.
02562 PHSPAC = 1./2.**5 /PI**2
02563 DO 4 I=1,ND
02564 4 PS =PS+AMPIK(I,JNPI)
02565 #if defined (ALEPH)
02566 CALL RANMAR(RR1,1)
02567 #else
02568 CALL RANMAR(RR2,1)
02569 #endif
02570 AMS1=PS**2
02571 AMS2=(AMTAU-AMNUTA)**2
02572 C
02573 C
02574 #if defined (ALEPH)
02575 AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
02576 #else
02577 AMX2=AMS1+ RR2(1)*(AMS2-AMS1)
02578 #endif
02579 AMX =SQRT(AMX2)
02580 AMW =AMX
02581 PHSPAC=PHSPAC * (AMS2-AMS1)
02582 C
02583 C TAU-NEUTRINO MOMENTUM
02584 PN(1)=0
02585 PN(2)=0
02586 PN(4)=1./(2*AMTAU)*(AMTAU**2+AMNUTA**2-AMX2)
02587 PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
02588 C W MOMENTUM
02589 PR(1)=0
02590 PR(2)=0
02591 PR(4)=1./(2*AMTAU)*(AMTAU**2-AMNUTA**2+AMX2)
02592 PR(3)=-PN(3)
02593 PHSPAC=PHSPAC * (4.*PI) * (2.*PR(3)/AMTAU)
02594 C
02595 C AMPLITUDE (cf YS.Tsai Phys.Rev.D4,2821(1971)
02596 C or F.Gilman SH.Rhie Phys.Rev.D31,1066(1985)
02597 C
02598 PXQ=AMTAU*PR(4)
02599 PXN=AMTAU*PN(4)
02600 QXN=PR(4)*PN(4)-PR(1)*PN(1)-PR(2)*PN(2)-PR(3)*PN(3)
02601 #if defined (ALEPH)
02602 #else
02603 C HERE WAS AN ERROR. 20.10.91 (ZW)
02604 C BRAK=2*(GV**2+GA**2)*(2*PXQ*PXN+AMX2*QXN)
02605 #endif
02606 BRAK=2*(GV**2+GA**2)*(2*PXQ*QXN+AMX2*PXN)
02607 & -6*(GV**2-GA**2)*AMTAU*AMNUTA*AMX2
02608 CAM Assume neutrino mass=0. and sum over final polarisation
02609 C BRAK= 2*(AMTAU**2-AMX2) * (AMTAU**2+2.*AMX2)
02610 AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK * AMX2*SIGEE(AMX2,JNPI)
02611 DGAMT=1./(2.*AMTAU)*AMPLIT*PHSPAC
02612 C
02613 C ISOTROPIC W DECAY IN W REST FRAME
02614 #if defined (ALEPH)
02615 PHSPAC = 1./2.**(6*ND-7) /PI**(3*ND-4)
02616 PHSMAX = 1./dpar(nd-2)
02617 #else
02618 PHSMAX = 1.
02619 #endif
02620 DO 200 I=1,4
02621 200 PV(I,1)=PR(I)
02622 PV(5,1)=AMW
02623 PV(5,ND)=AMPIK(ND,JNPI)
02624 C COMPUTE MAX. PHASE SPACE FACTOR
02625 PMAX=AMW-PS+AMPIK(ND,JNPI)
02626 PMIN=.0
02627 DO 220 IL=ND-1,1,-1
02628 PMAX=PMAX+AMPIK(IL,JNPI)
02629 PMIN=PMIN+AMPIK(IL+1,JNPI)
02630 #if defined (ALEPH)
02631 220 PHSMAX=PHSMAX*PAWT(PMAX,PMIN,AMPIK(IL,JNPI))
02632 CAM GENERATE ND-2 EFFECTIVE MASSES (cf LUDECY)
02633 PHSPAC = 1./2.**(6*ND-7) /PI**(3*ND-4)
02634 240 RORD(1)=1.
02635 CALL RANMAR(RRR,ND-1)
02636 DO 260 IL=2,ND-1
02637 RSAV=RRR(IL)
02638 DO 250 JL=IL-1,1,-1
02639 IF(RSAV.LE.RORD(JL)) GOTO 260
02640 250 RORD(JL+1)=RORD(JL)
02641 260 RORD(JL+1)=RSAV
02642 RORD(ND)=0.
02643 PHS=1.
02644 DO 270 IL=ND-1,1,-1
02645 PV(5,IL)=PV(5,IL+1)+AMPIK(IL,JNPI)
02646 & +(RORD(IL)-RORD(IL+1))*(PV(5,1)-PS)
02647 270 PHS=PHS*PAWT(PV(5,IL),PV(5,IL+1),AMPIK(IL,JNPI))
02648 RN = RRR(1)
02649 IF(PHS.LT.RN*PHSMAX) GOTO 240
02650 #else
02651 220 PHSMAX=PHSMAX*PAWT(PMAX,PMIN,AMPIK(IL,JNPI))/PMAX
02652
02653 C --- 2.02.94 ZW 9 lines
02654 AMX=AMW
02655 DO 222 IL=1,ND-2
02656 AMS1=.0
02657 DO 223 JL=IL+1,ND
02658 223 AMS1=AMS1+AMPIK(JL,JNPI)
02659 AMS1=AMS1**2
02660 AMX =(AMX-AMPIK(IL,JNPI))
02661 AMS2=(AMX)**2
02662 PHSMAX=PHSMAX * (AMS2-AMS1)
02663 222 CONTINUE
02664 NCONT=0
02665 100 CONTINUE
02666 NCONT=NCONT+1
02667 CAM GENERATE ND-2 EFFECTIVE MASSES
02668 PHS=1.D0
02669 PHSPAC = 1./2.**(6*ND-7) /PI**(3*ND-4)
02670 AMX=AMW
02671 CALL RANMAR(RRR,ND-2)
02672 DO 230 IL=1,ND-2
02673 AMS1=.0D0
02674 DO 231 JL=IL+1,ND
02675 231 AMS1=AMS1+AMPIK(JL,JNPI)
02676 AMS1=AMS1**2
02677 AMS2=(AMX-AMPIK(IL,JNPI))**2
02678 RR1=RRR(IL)
02679 AMX2=AMS1+ RR1*(AMS2-AMS1)
02680 AMX=SQRT(AMX2)
02681 PV(5,IL+1)=AMX
02682 PHSPAC=PHSPAC * (AMS2-AMS1)
02683 C --- 2.02.94 ZW 1 line
02684 PHS=PHS* (AMS2-AMS1)
02685 PA=PAWT(PV(5,IL),PV(5,IL+1),AMPIK(IL,JNPI))
02686 PHS =PHS *PA/PV(5,IL)
02687 230 CONTINUE
02688 PA=PAWT(PV(5,ND-1),AMPIK(ND-1,JNPI),AMPIK(ND,JNPI))
02689 PHS =PHS *PA/PV(5,ND-1)
02690 CALL RANMAR(RN,1)
02691 WETMAX(JNPI)=1.2D0*MAX(WETMAX(JNPI)/1.2D0,PHS/PHSMAX)
02692 IF (NCONT.EQ.500 000) THEN
02693 XNPI=0.0
02694 DO KK=1,ND
02695 XNPI=XNPI+AMPIK(KK,JNPI)
02696 ENDDO
02697 WRITE(6,*) 'ROUNDING INSTABILITY IN DPHNPI ?'
02698 WRITE(6,*) 'AMW=',AMW,'XNPI=',XNPI
02699 WRITE(6,*) 'IF =AMW= IS NEARLY EQUAL =XNPI= THAT IS IT'
02700 WRITE(6,*) 'PHS=',PHS,'PHSMAX=',PHSMAX
02701 GOTO 500
02702 ENDIF
02703 IF(RN(1)*PHSMAX*WETMAX(JNPI).GT.PHS) GO TO 100
02704 #endif
02705 C...PERFORM SUCCESSIVE TWO-PARTICLE DECAYS IN RESPECTIVE CM FRAME
02706 280 DO 300 IL=1,ND-1
02707 PA=PAWT(PV(5,IL),PV(5,IL+1),AMPIK(IL,JNPI))
02708 #if defined (ALEPH)
02709 CALL RANMAR(RRR,2)
02710 UE(3)=2.*RRR(1)-1.
02711 PHI=2.*PI*RRR(2)
02712 UE(1)=SQRT(1.-UE(3)**2)*COS(PHI)
02713 UE(2)=SQRT(1.-UE(3)**2)*SIN(PHI)
02714 #else
02715 CALL RANMAR(RRX,2)
02716 UE(3)=2.*RRX(1)-1.
02717 PHI=2.*PI*RRX(2)
02718 UE(1)=SQRT(1.D0-UE(3)**2)*COS(PHI)
02719 UE(2)=SQRT(1.D0-UE(3)**2)*SIN(PHI)
02720 #endif
02721 DO 290 J=1,3
02722 PPI(J,IL)=PA*UE(J)
02723 290 PV(J,IL+1)=-PA*UE(J)
02724 PPI(4,IL)=SQRT(PA**2+AMPIK(IL,JNPI)**2)
02725 PV(4,IL+1)=SQRT(PA**2+PV(5,IL+1)**2)
02726 PHSPAC=PHSPAC *(4.*PI)*(2.*PA/PV(5,IL))
02727 300 CONTINUE
02728 C...LORENTZ TRANSFORM DECAY PRODUCTS TO TAU FRAME
02729 DO 310 J=1,4
02730 310 PPI(J,ND)=PV(J,ND)
02731 DO 340 IL=ND-1,1,-1
02732 DO 320 J=1,3
02733 320 BE(J)=PV(J,IL)/PV(4,IL)
02734 GAM=PV(4,IL)/PV(5,IL)
02735 DO 340 I=IL,ND
02736 BEP=BE(1)*PPI(1,I)+BE(2)*PPI(2,I)+BE(3)*PPI(3,I)
02737 DO 330 J=1,3
02738 #if defined (ALEPH)
02739 330 PPI(J,I)=PPI(J,I)+GAM*(GAM*BEP/(1.+GAM)+PPI(4,I))*BE(J)
02740 #else
02741 330 PPI(J,I)=PPI(J,I)+GAM*(GAM*BEP/(1.D0+GAM)+PPI(4,I))*BE(J)
02742 #endif
02743 PPI(4,I)=GAM*(PPI(4,I)+BEP)
02744 340 CONTINUE
02745 C
02746 HV(4)=1.
02747 HV(3)=0.
02748 HV(2)=0.
02749 HV(1)=0.
02750 #if defined (ALEPH)
02751 #else
02752 DO K=1,4
02753 PNX(K)=PN(K)
02754 PRX(K)=PR(K)
02755 HVX(K)=HV(K)
02756 DO L=1,ND
02757 PPIX(K,L)=PPI(K,L)
02758 ENDDO
02759 ENDDO
02760 #endif
02761 RETURN
02762 END
02763 FUNCTION SIGEE(Q2,JNP)
02764 C ----------------------------------------------------------------------
02765 C e+e- cross section in the (1.GEV2,AMTAU**2) region
02766 C normalised to sig0 = 4/3 pi alfa2
02767 C used in matrix element for multipion tau decays
02768 C cf YS.Tsai Phys.Rev D4 ,2821(1971)
02769 C F.Gilman et al Phys.Rev D17,1846(1978)
02770 C C.Kiesling, to be pub. in High Energy e+e- Physics (1988)
02771 C DATSIG(*,1) = e+e- -> pi+pi-2pi0
02772 C DATSIG(*,2) = e+e- -> 2pi+2pi-
02773 C DATSIG(*,3) = 5-pion contribution (a la TN.Pham et al)
02774 C (Phys Lett 78B,623(1978)
02775 C DATSIG(*,5) = e+e- -> 6pi
02776 C
02777 C 4- and 6-pion cross sections from data
02778 C 5-pion contribution related to 4-pion cross section
02779 C
02780 C Called by DPHNPI
02781 C ----------------------------------------------------------------------
02782 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02783 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02784 * ,AMK,AMKZ,AMKST,GAMKST
02785 C
02786 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02787 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02788 * ,AMK,AMKZ,AMKST,GAMKST
02789 REAL*4 DATSIG(17,6)
02790 C
02791 DATA DATSIG/
02792 1 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
02793 2 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
02794 3 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
02795 4 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
02796 5 17*.0,
02797 6 17*.0,
02798 7 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25,
02799 8 17*.0/
02800 DATA SIG0 / 86.8 /
02801 DATA PI /3.141592653589793238462643/
02802 DATA INIT / 0 /
02803 C
02804 JNPI=JNP
02805 IF(JNP.EQ.4) JNPI=3
02806 IF(JNP.EQ.3) JNPI=4
02807 IF(INIT.EQ.0) THEN
02808 INIT=1
02809 #if defined (CLEO)
02810 C AJWMOD: initialize if called from outside QQ:
02811 IF (AMPI.LT.0.139) AMPI = 0.1395675
02812 #else
02813 #endif
02814 AMPI2=AMPI**2
02815 FPI = .943*AMPI
02816 DO 100 I=1,17
02817 DATSIG(I,2) = DATSIG(I,2)/2.
02818 DATSIG(I,1) = DATSIG(I,1) + DATSIG(I,2)
02819 S = 1.025+(I-1)*.05
02820 FACT=0.
02821 S2=S**2
02822 DO 200 J=1,17
02823 T= 1.025+(J-1)*.05
02824 IF(T . GT. S-AMPI ) GO TO 201
02825 T2=T**2
02826 FACT=(T2/S2)**2*SQRT((S2-T2-AMPI2)**2-4.*T2*AMPI2)/S2 *2.*T*.05
02827 FACT = FACT * (DATSIG(J,1)+DATSIG(J+1,1))
02828 200 DATSIG(I,3) = DATSIG(I,3) + FACT
02829 201 DATSIG(I,3) = DATSIG(I,3) /(2*PI*FPI)**2
02830 DATSIG(I,4) = DATSIG(I,3)
02831 DATSIG(I,6) = DATSIG(I,5)
02832 100 CONTINUE
02833 C WRITE(6,1000) DATSIG
02834 1000 FORMAT(///1X,' EE SIGMA USED IN MULTIPI DECAYS'/
02835 % (17F7.2/))
02836 ENDIF
02837 Q=SQRT(Q2)
02838 QMIN=1.
02839 IF(Q.LT.QMIN) THEN
02840 SIGEE=DATSIG(1,JNPI)+
02841 & (DATSIG(2,JNPI)-DATSIG(1,JNPI))*(Q-1.)/.05
02842 ELSEIF(Q.LT.1.8) THEN
02843 DO 1 I=1,16
02844 QMAX = QMIN + .05
02845 IF(Q.LT.QMAX) GO TO 2
02846 QMIN = QMIN + .05
02847 1 CONTINUE
02848 2 SIGEE=DATSIG(I,JNPI)+
02849 & (DATSIG(I+1,JNPI)-DATSIG(I,JNPI)) * (Q-QMIN)/.05
02850 ELSEIF(Q.GT.1.8) THEN
02851 SIGEE=DATSIG(17,JNPI)+
02852 & (DATSIG(17,JNPI)-DATSIG(16,JNPI)) * (Q-1.8)/.05
02853 ENDIF
02854 IF(SIGEE.LT..0) SIGEE=0.
02855 C
02856 SIGEE = SIGEE/(6.*PI**2*SIG0)
02857 C
02858 RETURN
02859 END
02860
02861 FUNCTION SIGOLD(Q2,JNPI)
02862 C ----------------------------------------------------------------------
02863 C e+e- cross section in the (1.GEV2,AMTAU**2) region
02864 C normalised to sig0 = 4/3 pi alfa2
02865 C used in matrix element for multipion tau decays
02866 C cf YS.Tsai Phys.Rev D4 ,2821(1971)
02867 C F.Gilman et al Phys.Rev D17,1846(1978)
02868 C C.Kiesling, to be pub. in High Energy e+e- Physics (1988)
02869 C DATSIG(*,1) = e+e- -> pi+pi-2pi0
02870 C DATSIG(*,2) = e+e- -> 2pi+2pi-
02871 C DATSIG(*,3) = 5-pion contribution (a la TN.Pham et al)
02872 C (Phys Lett 78B,623(1978)
02873 C DATSIG(*,4) = e+e- -> 6pi
02874 C
02875 C 4- and 6-pion cross sections from data
02876 C 5-pion contribution related to 4-pion cross section
02877 C
02878 C Called by DPHNPI
02879 C ----------------------------------------------------------------------
02880 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02881 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02882 * ,AMK,AMKZ,AMKST,GAMKST
02883 C
02884 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
02885 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
02886 * ,AMK,AMKZ,AMKST,GAMKST
02887 REAL*4 DATSIG(17,4)
02888 C
02889 DATA DATSIG/
02890 1 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
02891 2 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
02892 3 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
02893 4 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
02894 5 17*.0,
02895 6 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25/
02896 DATA SIG0 / 86.8 /
02897 DATA PI /3.141592653589793238462643/
02898 DATA INIT / 0 /
02899 C
02900 IF(INIT.EQ.0) THEN
02901 INIT=1
02902 AMPI2=AMPI**2
02903 FPI = .943*AMPI
02904 DO 100 I=1,17
02905 DATSIG(I,2) = DATSIG(I,2)/2.
02906 DATSIG(I,1) = DATSIG(I,1) + DATSIG(I,2)
02907 S = 1.025+(I-1)*.05
02908 FACT=0.
02909 S2=S**2
02910 DO 200 J=1,17
02911 T= 1.025+(J-1)*.05
02912 IF(T . GT. S-AMPI ) GO TO 201
02913 T2=T**2
02914 FACT=(T2/S2)**2*SQRT((S2-T2-AMPI2)**2-4.*T2*AMPI2)/S2 *2.*T*.05
02915 FACT = FACT * (DATSIG(J,1)+DATSIG(J+1,1))
02916 200 DATSIG(I,3) = DATSIG(I,3) + FACT
02917 201 DATSIG(I,3) = DATSIG(I,3) /(2*PI*FPI)**2
02918 100 CONTINUE
02919 C WRITE(6,1000) DATSIG
02920 1000 FORMAT(///1X,' EE SIGMA USED IN MULTIPI DECAYS'/
02921 % (17F7.2/))
02922 ENDIF
02923 Q=SQRT(Q2)
02924 QMIN=1.
02925 IF(Q.LT.QMIN) THEN
02926 SIGEE=DATSIG(1,JNPI)+
02927 & (DATSIG(2,JNPI)-DATSIG(1,JNPI))*(Q-1.)/.05
02928 ELSEIF(Q.LT.1.8) THEN
02929 DO 1 I=1,16
02930 QMAX = QMIN + .05
02931 IF(Q.LT.QMAX) GO TO 2
02932 QMIN = QMIN + .05
02933 1 CONTINUE
02934 2 SIGEE=DATSIG(I,JNPI)+
02935 & (DATSIG(I+1,JNPI)-DATSIG(I,JNPI)) * (Q-QMIN)/.05
02936 ELSEIF(Q.GT.1.8) THEN
02937 SIGEE=DATSIG(17,JNPI)+
02938 & (DATSIG(17,JNPI)-DATSIG(16,JNPI)) * (Q-1.8)/.05
02939 ENDIF
02940 IF(SIGEE.LT..0) SIGEE=0.
02941 C
02942 SIGEE = SIGEE/(6.*PI**2*SIG0)
02943 SIGOLD=SIGEE
02944 C
02945 RETURN
02946 END
02947 SUBROUTINE DPHSPK(DGAMT,HV,PN,PAA,PNPI,JAA)
02948 C ----------------------------------------------------------------------
02949 * IT SIMULATES THREE PI (K) DECAY IN THE TAU REST FRAME
02950 * Z-AXIS ALONG HADRONIC SYSTEM
02951 C ----------------------------------------------------------------------
02952 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
02953 #if defined (ALEPH)
02954 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
02955 #else
02956 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
02957 #endif
02958 & ,NAMES
02959 CHARACTER NAMES(NMODE)*31
02960
02961 REAL HV(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4),PNPI(4,9)
02962 C MATRIX ELEMENT NUMBER:
02963 MNUM=JAA
02964 C TYPE OF THE GENERATION:
02965 KEYT=4
02966 IF(JAA.EQ.7) KEYT=3
02967 C --- MASSES OF THE DECAY PRODUCTS
02968 AMP1=DCDMAS(IDFFIN(1,JAA+NM4+NM5+NM6))
02969 AMP2=DCDMAS(IDFFIN(2,JAA+NM4+NM5+NM6))
02970 AMP3=DCDMAS(IDFFIN(3,JAA+NM4+NM5+NM6))
02971 CALL
02972 $ DPHTRE(DGAMT,HV,PN,PAA,PIM1,AMP1,PIM2,AMP2,PIPL,AMP3,KEYT,MNUM)
02973 DO I=1,4
02974 PNPI(I,1)=PIM1(I)
02975 PNPI(I,2)=PIM2(I)
02976 PNPI(I,3)=PIPL(I)
02977 ENDDO
02978 END
02979
02980
02981
02982
02983 SUBROUTINE
02984 $ DPHTRE(DGAMT,HV,PN,PAA,PIM1,AMPA,PIM2,AMPB,PIPL,AMP3,KEYT,MNUM)
02985 C ----------------------------------------------------------------------
02986 * IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
02987 * Z-AXIS ALONG A1 MOMENTUM
02988 * it can be also used to generate K K pi and K pi pi tau decays.
02989 * INPUT PARAMETERS
02990 * KEYT - algorithm controlling switch
02991 * 2 - flat phase space PIM1 PIM2 symmetrized statistical factor 1/2
02992 * 1 - like 1 but peaked around a1 and rho (two channels) masses.
02993 * 3 - peaked around omega, all particles different
02994 * other- flat phase space, all particles different
02995 * AMP1 - mass of first pi, etc. (1-3)
02996 * MNUM - matrix element type
02997 * 0 - a1 matrix element
02998 * 1-6 - matrix element for K pi pi, K K pi decay modes
02999 * 7 - pi- pi0 gamma matrix element
03000 C ----------------------------------------------------------------------
03001 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03002 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03003 * ,AMK,AMKZ,AMKST,GAMKST
03004 C
03005 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03006 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03007 * ,AMK,AMKZ,AMKST,GAMKST
03008 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03009 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03010 REAL HV(4),PT(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
03011 REAL PR(4)
03012 REAL*4 RRR(5)
03013 DATA PI /3.141592653589793238462643/
03014 DATA ICONT /0/
03015 XLAM(X,Y,Z)=SQRT(ABS((X-Y-Z)**2-4.0*Y*Z))
03016 C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
03017 C
03018 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
03019 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
03020 PHSPAC=1./2**17/PI**8
03021 C TAU MOMENTUM
03022 PT(1)=0.
03023 PT(2)=0.
03024 PT(3)=0.
03025 PT(4)=AMTAU
03026 C
03027 CALL RANMAR(RRR,5)
03028 RR=RRR(5)
03029 C
03030 CALL CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
03031 $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
03032 IF (ICHAN.EQ.1) THEN
03033 AMP1=AMPB
03034 AMP2=AMPA
03035 ELSEIF (ICHAN.EQ.2) THEN
03036 AMP1=AMPA
03037 AMP2=AMPB
03038 ELSE
03039 AMP1=AMPB
03040 AMP2=AMPA
03041 ENDIF
03042 CAM
03043 RR1=RRR(1)
03044 AMS1=(AMP1+AMP2+AMP3)**2
03045 AMS2=(AMTAU-AMNUTA)**2
03046 #if defined (ALEPH)
03047 C phase space with sampling for a1 resonance
03048 #else
03049 * PHASE SPACE WITH SAMPLING FOR A1 RESONANCE
03050 #endif
03051 ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
03052 ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
03053 ALP=ALP1+RR1*(ALP2-ALP1)
03054 AM3SQ =AMRX**2+AMRX*GAMRX*TAN(ALP)
03055 AM3 =SQRT(AM3SQ)
03056 PHSPAC=PHSPAC*((AM3SQ-AMRX**2)**2+(AMRX*GAMRX)**2)/(AMRX*GAMRX)
03057 PHSPAC=PHSPAC*(ALP2-ALP1)
03058 C MASS OF (REAL/VIRTUAL) RHO -
03059 RR2=RRR(2)
03060 AMS1=(AMP2+AMP3)**2
03061 AMS2=(AM3-AMP1)**2
03062 IF (ICHAN.LE.2) THEN
03063 #if defined (ALEPH)
03064 C phase space with sampling for rho resonance,
03065 #else
03066 * PHASE SPACE WITH SAMPLING FOR RHO RESONANCE,
03067 #endif
03068 ALP1=ATAN((AMS1-AMRA**2)/AMRA/GAMRA)
03069 ALP2=ATAN((AMS2-AMRA**2)/AMRA/GAMRA)
03070 ALP=ALP1+RR2*(ALP2-ALP1)
03071 AM2SQ =AMRA**2+AMRA*GAMRA*TAN(ALP)
03072 AM2 =SQRT(AM2SQ)
03073 C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
03074 C PHSPAC=PHSPAC*(ALP2-ALP1)
03075 C PHSPAC=PHSPAC*((AM2SQ-AMRA**2)**2+(AMRA*GAMRA)**2)/(AMRA*GAMRA)
03076 C----------------------------------------------------------------------
03077 ELSE
03078 #if defined (ALEPH)
03079 C flat phase space;
03080 #else
03081 * FLAT PHASE SPACE;
03082 #endif
03083 AM2SQ=AMS1+ RR2*(AMS2-AMS1)
03084 AM2 =SQRT(AM2SQ)
03085 PHF0=(AMS2-AMS1)
03086 ENDIF
03087 #if defined (ALEPH)
03088 C rho restframe, define pipl and pim1
03089 #else
03090 * RHO RESTFRAME, DEFINE PIPL AND PIM1
03091 #endif
03092 ENQ1=(AM2SQ-AMP2**2+AMP3**2)/(2*AM2)
03093 ENQ2=(AM2SQ+AMP2**2-AMP3**2)/(2*AM2)
03094 PPI= ENQ1**2-AMP3**2
03095 PPPI=SQRT(ABS(ENQ1**2-AMP3**2))
03096 C --- this part of jacobian will be recovered later
03097 PHF1=(4*PI)*(2*PPPI/AM2)
03098 #if defined (ALEPH)
03099 C pi minus momentum in rho rest frame
03100 #else
03101 * PI MINUS MOMENTUM IN RHO REST FRAME
03102 #endif
03103 CALL SPHERA(PPPI,PIPL)
03104 PIPL(4)=ENQ1
03105 #if defined (ALEPH)
03106 C pi0 1 momentum in rho rest frame
03107 #else
03108 * PI0 1 MOMENTUM IN RHO REST FRAME
03109 #endif
03110 DO 30 I=1,3
03111 30 PIM1(I)=-PIPL(I)
03112 PIM1(4)=ENQ2
03113 #if defined (ALEPH)
03114 C a1 rest frame, define pim2
03115 #else
03116 * A1 REST FRAME, DEFINE PIM2
03117 #endif
03118 * RHO MOMENTUM
03119 PR(1)=0
03120 PR(2)=0
03121 PR(4)=1./(2*AM3)*(AM3**2+AM2**2-AMP1**2)
03122 PR(3)= SQRT(ABS(PR(4)**2-AM2**2))
03123 PPI = PR(4)**2-AM2**2
03124 * PI0 2 MOMENTUM
03125 PIM2(1)=0
03126 PIM2(2)=0
03127 PIM2(4)=1./(2*AM3)*(AM3**2-AM2**2+AMP1**2)
03128 PIM2(3)=-PR(3)
03129 PHF2=(4*PI)*(2*PR(3)/AM3)
03130 #if defined (ALEPH)
03131 C old pions boosted from rho rest frame to a1 rest frame
03132 #else
03133 * OLD PIONS BOOSTED FROM RHO REST FRAME TO A1 REST FRAME
03134 #endif
03135 EXE=(PR(4)+PR(3))/AM2
03136 CALL BOSTR3(EXE,PIPL,PIPL)
03137 CALL BOSTR3(EXE,PIM1,PIM1)
03138 RR3=RRR(3)
03139 RR4=RRR(4)
03140 #if defined (ALEPH)
03141 #else
03142 CAM THET =PI*RR3
03143 #endif
03144 THET =ACOS(-1.+2*RR3)
03145 PHI = 2*PI*RR4
03146 CALL ROTPOL(THET,PHI,PIPL)
03147 CALL ROTPOL(THET,PHI,PIM1)
03148 CALL ROTPOL(THET,PHI,PIM2)
03149 CALL ROTPOL(THET,PHI,PR)
03150 C
03151 * NOW TO THE TAU REST FRAME, DEFINE A1 AND NEUTRINO MOMENTA
03152 * A1 MOMENTUM
03153 PAA(1)=0
03154 PAA(2)=0
03155 PAA(4)=1./(2*AMTAU)*(AMTAU**2-AMNUTA**2+AM3**2)
03156 PAA(3)= SQRT(ABS(PAA(4)**2-AM3**2))
03157 PPI = PAA(4)**2-AM3**2
03158 PHSPAC=PHSPAC*(4*PI)*(2*PAA(3)/AMTAU)
03159 * TAU-NEUTRINO MOMENTUM
03160 PN(1)=0
03161 PN(2)=0
03162 PN(4)=1./(2*AMTAU)*(AMTAU**2+AMNUTA**2-AM3**2)
03163 PN(3)=-PAA(3)
03164 C HERE WE CORRECT FOR THE JACOBIANS OF THE TWO CHAINS
03165 C ---FIRST CHANNEL ------- PIM1+PIPL
03166 AMS1=(AMP2+AMP3)**2
03167 AMS2=(AM3-AMP1)**2
03168 ALP1=ATAN((AMS1-AMRA**2)/AMRA/GAMRA)
03169 ALP2=ATAN((AMS2-AMRA**2)/AMRA/GAMRA)
03170 XPRO = (PIM1(3)+PIPL(3))**2
03171 $ +(PIM1(2)+PIPL(2))**2+(PIM1(1)+PIPL(1))**2
03172 AM2SQ=-XPRO+(PIM1(4)+PIPL(4))**2
03173 C JACOBIAN OF SPEEDING
03174 FF1 = ((AM2SQ-AMRA**2)**2+(AMRA*GAMRA)**2)/(AMRA*GAMRA)
03175 FF1 =FF1 *(ALP2-ALP1)
03176 C LAMBDA OF RHO DECAY
03177 GG1 = (4*PI)*(XLAM(AM2SQ,AMP2**2,AMP3**2)/AM2SQ)
03178 C LAMBDA OF A1 DECAY
03179 GG1 =GG1 *(4*PI)*SQRT(4*XPRO/AM3SQ)
03180 XJAJE=GG1*(AMS2-AMS1)
03181 C ---SECOND CHANNEL ------ PIM2+PIPL
03182 AMS1=(AMP1+AMP3)**2
03183 AMS2=(AM3-AMP2)**2
03184 ALP1=ATAN((AMS1-AMRB**2)/AMRB/GAMRB)
03185 ALP2=ATAN((AMS2-AMRB**2)/AMRB/GAMRB)
03186 XPRO = (PIM2(3)+PIPL(3))**2
03187 $ +(PIM2(2)+PIPL(2))**2+(PIM2(1)+PIPL(1))**2
03188 AM2SQ=-XPRO+(PIM2(4)+PIPL(4))**2
03189 FF2 = ((AM2SQ-AMRB**2)**2+(AMRB*GAMRB)**2)/(AMRB*GAMRB)
03190 FF2 =FF2 *(ALP2-ALP1)
03191 GG2 = (4*PI)*(XLAM(AM2SQ,AMP1**2,AMP3**2)/AM2SQ)
03192 GG2 =GG2 *(4*PI)*SQRT(4*XPRO/AM3SQ)
03193 XJADW=GG2*(AMS2-AMS1)
03194 C
03195 A1=0.0
03196 A2=0.0
03197 A3=0.0
03198 XJAC1=FF1*GG1
03199 XJAC2=FF2*GG2
03200 IF (ICHAN.EQ.2) THEN
03201 XJAC3=XJADW
03202 ELSE
03203 XJAC3=XJAJE
03204 ENDIF
03205 IF (XJAC1.NE.0.0) A1=PROB1/XJAC1
03206 IF (XJAC2.NE.0.0) A2=PROB2/XJAC2
03207 IF (XJAC3.NE.0.0) A3=PROB3/XJAC3
03208 C
03209 IF (A1+A2+A3.NE.0.0) THEN
03210 PHSPAC=PHSPAC/(A1+A2+A3)
03211 ELSE
03212 PHSPAC=0.0
03213 ENDIF
03214 IF(ICHAN.EQ.2) THEN
03215 DO 70 I=1,4
03216 X=PIM1(I)
03217 PIM1(I)=PIM2(I)
03218 70 PIM2(I)=X
03219 ENDIF
03220 * ALL PIONS BOOSTED FROM A1 REST FRAME TO TAU REST FRAME
03221 * Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
03222 EXE=(PAA(4)+PAA(3))/AM3
03223 CALL BOSTR3(EXE,PIPL,PIPL)
03224 CALL BOSTR3(EXE,PIM1,PIM1)
03225 CALL BOSTR3(EXE,PIM2,PIM2)
03226 CALL BOSTR3(EXE,PR,PR)
03227 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
03228 IF (MNUM.EQ.8) THEN
03229 CALL DAMPOG(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
03230 C ELSEIF (MNUM.EQ.0) THEN
03231 C CALL DAMPAA(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
03232 ELSE
03233 CALL DAMPPK(MNUM,PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
03234 ENDIF
03235 IF (KEYT.EQ.1.OR.KEYT.EQ.2) THEN
03236 C THE STATISTICAL FACTOR FOR IDENTICAL PI-S IS CANCELLED WITH
03237 C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
03238 #if defined (ALEPH)
03239 Cam PHSPAC=PHSPAC*2.0
03240 Cam PHSPAC=PHSPAC/2.
03241 #else
03242 PHSPAC=PHSPAC*2.0
03243 PHSPAC=PHSPAC/2.
03244 #endif
03245 ENDIF
03246 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
03247 END
03248 SUBROUTINE DAMPAA(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
03249 C ----------------------------------------------------------------------
03250 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
03251 * FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
03252 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
03253 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
03254 * THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
03255 C
03256 C called by : DPHSAA
03257 C ----------------------------------------------------------------------
03258 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03259 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03260 * ,AMK,AMKZ,AMKST,GAMKST
03261 C
03262 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03263 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03264 * ,AMK,AMKZ,AMKST,GAMKST
03265 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03266 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03267 COMMON /TESTA1/ KEYA1
03268 REAL HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIPL(4)
03269 REAL PAA(4),VEC1(4),VEC2(4)
03270 REAL PIVEC(4),PIAKS(4),HVM(4)
03271 COMPLEX BWIGN,HADCUR(4),FPIK
03272 DATA ICONT /1/
03273 C
03274 * F CONSTANTS FOR A1, A1-RHO-PI, AND RHO-PI-PI
03275 *
03276 DATA FPI /93.3E-3/
03277 * THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
03278 BWIGN(XM,AM,GAMMA)=1./CMPLX(XM**2-AM**2,GAMMA*AM)
03279 C
03280 * FOUR MOMENTUM OF A1
03281 DO 10 I=1,4
03282 10 PAA(I)=PIM1(I)+PIM2(I)+PIPL(I)
03283 * MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
03284 XMAA =SQRT(ABS(PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2))
03285 XMRO1 =SQRT(ABS((PIPL(4)+PIM1(4))**2-(PIPL(1)+PIM1(1))**2
03286 $ -(PIPL(2)+PIM1(2))**2-(PIPL(3)+PIM1(3))**2))
03287 XMRO2 =SQRT(ABS((PIPL(4)+PIM2(4))**2-(PIPL(1)+PIM2(1))**2
03288 $ -(PIPL(2)+PIM2(2))**2-(PIPL(3)+PIM2(3))**2))
03289 * ELEMENTS OF HADRON CURRENT
03290 PROD1 =PAA(4)*(PIM1(4)-PIPL(4))-PAA(1)*(PIM1(1)-PIPL(1))
03291 $ -PAA(2)*(PIM1(2)-PIPL(2))-PAA(3)*(PIM1(3)-PIPL(3))
03292 PROD2 =PAA(4)*(PIM2(4)-PIPL(4))-PAA(1)*(PIM2(1)-PIPL(1))
03293 $ -PAA(2)*(PIM2(2)-PIPL(2))-PAA(3)*(PIM2(3)-PIPL(3))
03294 DO 40 I=1,4
03295 VEC1(I)= PIM1(I)-PIPL(I) -PAA(I)*PROD1/XMAA**2
03296 40 VEC2(I)= PIM2(I)-PIPL(I) -PAA(I)*PROD2/XMAA**2
03297 * HADRON CURRENT SATURATED WITH A1 AND RHO RESONANCES
03298 IF (KEYA1.EQ.1) THEN
03299 FA1=9.87
03300 FAROPI=1.0
03301 FRO2PI=1.0
03302 FNORM=FA1/SQRT(2.)*FAROPI*FRO2PI
03303 DO 45 I=1,4
03304 HADCUR(I)= CMPLX(FNORM) *AMA1**2*BWIGN(XMAA,AMA1,GAMA1)
03305 $ *(CMPLX(VEC1(I))*AMRO**2*BWIGN(XMRO1,AMRO,GAMRO)
03306 $ +CMPLX(VEC2(I))*AMRO**2*BWIGN(XMRO2,AMRO,GAMRO))
03307 45 CONTINUE
03308 ELSE
03309 FNORM=2.0*SQRT(2.)/3.0/FPI
03310 GAMAX=GAMA1*GFUN(XMAA**2)/GFUN(AMA1**2)
03311 DO 46 I=1,4
03312 HADCUR(I)= CMPLX(FNORM) *AMA1**2*BWIGN(XMAA,AMA1,GAMAX)
03313 $ *(CMPLX(VEC1(I))*FPIK(XMRO1)
03314 $ +CMPLX(VEC2(I))*FPIK(XMRO2))
03315 46 CONTINUE
03316 ENDIF
03317 C
03318 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
03319 CALL CLVEC(HADCUR,PN,PIVEC)
03320 CALL CLAXI(HADCUR,PN,PIAKS)
03321 CALL CLNUT(HADCUR,BRAKM,HVM)
03322 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
03323 BRAK= (GV**2+GA**2)*PT(4)*PIVEC(4) +2.*GV*GA*PT(4)*PIAKS(4)
03324 & +2.*(GV**2-GA**2)*AMNUTA*AMTAU*BRAKM
03325 AMPLIT=(GFERMI*CCABIB)**2*BRAK/2.
03326 C THE STATISTICAL FACTOR FOR IDENTICAL PI-S WAS CANCELLED WITH
03327 C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
03328 C POLARIMETER VECTOR IN TAU REST FRAME
03329 DO 90 I=1,3
03330 HV(I)=-(AMTAU*((GV**2+GA**2)*PIAKS(I)+2.*GV*GA*PIVEC(I)))
03331 & +(GV**2-GA**2)*AMNUTA*AMTAU*HVM(I)
03332 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
03333 HV(I)=-HV(I)/BRAK
03334 90 CONTINUE
03335 END
03336
03337 FUNCTION GFUN(QKWA)
03338 C ****************************************************************
03339 C G-FUNCTION USED TO INRODUCE ENERGY DEPENDENCE IN A1 WIDTH
03340 C ****************************************************************
03341 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03342 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03343 * ,AMK,AMKZ,AMKST,GAMKST
03344 C
03345 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03346 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03347 * ,AMK,AMKZ,AMKST,GAMKST
03348 C
03349 IF (QKWA.LT.(AMRO+AMPI)**2) THEN
03350 GFUN=4.1*(QKWA-9*AMPIZ**2)**3
03351 $ *(1.-3.3*(QKWA-9*AMPIZ**2)+5.8*(QKWA-9*AMPIZ**2)**2)
03352 ELSE
03353 GFUN=QKWA*(1.623+10.38/QKWA-9.32/QKWA**2+0.65/QKWA**3)
03354 ENDIF
03355 END
03356 COMPLEX FUNCTION BWIGS(S,M,G)
03357 C **********************************************************
03358 C P-WAVE BREIT-WIGNER FOR K*
03359 C **********************************************************
03360 REAL S,M,G
03361 REAL PI,PIM,QS,QM,W,GS,MK
03362 #if defined (CLEO)
03363 C AJW: add K*-prim possibility:
03364 REAL PM, PG, PBETA
03365 COMPLEX BW,BWP
03366 #else
03367 #endif
03368 DATA INIT /0/
03369 P(A,B,C)=SQRT(ABS(ABS(((A+B-C)**2-4.*A*B)/4./A)
03370 $ +(((A+B-C)**2-4.*A*B)/4./A))/2.0)
03371 C ------------ PARAMETERS --------------------
03372 IF (INIT.EQ.0) THEN
03373 INIT=1
03374 PI=3.141592654
03375 PIM=.139
03376 MK=.493667
03377 #if defined (CLEO)
03378 C AJW: add K*-prim possibility:
03379 PM = PKORB(1,16)
03380 PG = PKORB(2,16)
03381 PBETA = PKORB(3,16)
03382 #else
03383 #endif
03384 C ------- BREIT-WIGNER -----------------------
03385 ENDIF
03386 #if defined (ALEPH)
03387 IF (S.GT.(PIM+MK)**2) THEN
03388 #endif
03389 QS=P(S,PIM**2,MK**2)
03390 QM=P(M**2,PIM**2,MK**2)
03391 W=SQRT(S)
03392 GS=G*(M/W)*(QS/QM)**3
03393 #if defined (CLEO)
03394 BW=M**2/CMPLX(M**2-S,-M*GS)
03395 QPM=P(PM**2,PIM**2,MK**2)
03396 G1=PG*(PM/W)*(QS/QPM)**3
03397 BWP=PM**2/CMPLX(PM**2-S,-PM*G1)
03398 BWIGS= (BW+PBETA*BWP)/(1+PBETA)
03399 #elif defined (ALEPH)
03400 ELSE
03401 GS=0.0
03402 ENDIF
03403 BWIGS=M**2/CMPLX(M**2-S,-M*GS)
03404 #else
03405 BWIGS=M**2/CMPLX(M**2-S,-M*GS)
03406 #endif
03407 RETURN
03408 END
03409 COMPLEX FUNCTION BWIG(S,M,G)
03410 C **********************************************************
03411 C P-WAVE BREIT-WIGNER FOR RHO
03412 C **********************************************************
03413 REAL S,M,G
03414 REAL PI,PIM,QS,QM,W,GS
03415 DATA INIT /0/
03416 C ------------ PARAMETERS --------------------
03417 IF (INIT.EQ.0) THEN
03418 INIT=1
03419 PI=3.141592654
03420 PIM=.139
03421 C ------- BREIT-WIGNER -----------------------
03422 ENDIF
03423 IF (S.GT.4.*PIM**2) THEN
03424 QS=SQRT(ABS(ABS(S/4.-PIM**2)+(S/4.-PIM**2))/2.0)
03425 QM=SQRT(M**2/4.-PIM**2)
03426 W=SQRT(S)
03427 GS=G*(M/W)*(QS/QM)**3
03428 ELSE
03429 GS=0.0
03430 ENDIF
03431 BWIG=M**2/CMPLX(M**2-S,-M*GS)
03432 RETURN
03433 END
03434 COMPLEX FUNCTION FPIK(W)
03435 C **********************************************************
03436 C PION FORM FACTOR
03437 C **********************************************************
03438 COMPLEX BWIG
03439 REAL ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
03440 EXTERNAL BWIG
03441 DATA INIT /0/
03442 C
03443 C ------------ PARAMETERS --------------------
03444 IF (INIT.EQ.0 ) THEN
03445 INIT=1
03446 PI=3.141592654
03447 PIM=.140
03448 #if defined (CLEO)
03449 ROM=PKORB(1,9)
03450 ROG=PKORB(2,9)
03451 ROM1=PKORB(1,15)
03452 ROG1=PKORB(2,15)
03453 BETA1=PKORB(3,15)
03454 #else
03455 ROM=0.773
03456 ROG=0.145
03457 ROM1=1.370
03458 ROG1=0.510
03459 BETA1=-0.145
03460 #endif
03461 ENDIF
03462 C -----------------------------------------------
03463 S=W**2
03464 FPIK= (BWIG(S,ROM,ROG)+BETA1*BWIG(S,ROM1,ROG1))
03465 & /(1+BETA1)
03466 RETURN
03467 END
03468 FUNCTION FPIRHO(W)
03469 C **********************************************************
03470 C SQUARE OF PION FORM FACTOR
03471 C **********************************************************
03472 COMPLEX FPIK
03473 FPIRHO=CABS(FPIK(W))**2
03474 END
03475 SUBROUTINE CLVEC(HJ,PN,PIV)
03476 C ----------------------------------------------------------------------
03477 * CALCULATES THE "VECTOR TYPE" PI-VECTOR PIV
03478 * NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
03479 C
03480 C called by : DAMPAA
03481 C ----------------------------------------------------------------------
03482 REAL PIV(4),PN(4)
03483 COMPLEX HJ(4),HN
03484 C
03485 HN= HJ(4)*CMPLX(PN(4))-HJ(3)*CMPLX(PN(3))
03486 HH= REAL(HJ(4)*CONJG(HJ(4))-HJ(3)*CONJG(HJ(3))
03487 $ -HJ(2)*CONJG(HJ(2))-HJ(1)*CONJG(HJ(1)))
03488 DO 10 I=1,4
03489 10 PIV(I)=4.*REAL(HN*CONJG(HJ(I)))-2.*HH*PN(I)
03490 RETURN
03491 END
03492 SUBROUTINE CLAXI(HJ,PN,PIA)
03493 C ----------------------------------------------------------------------
03494 * CALCULATES THE "AXIAL TYPE" PI-VECTOR PIA
03495 * NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
03496 C SIGN is chosen +/- for decay of TAU +/- respectively
03497 C called by : DAMPAA, CLNUT
03498 C ----------------------------------------------------------------------
03499 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
03500 COMMON / IDFC / IDFF
03501 REAL PIA(4),PN(4)
03502 COMPLEX HJ(4),HJC(4)
03503 C DET2(I,J)=AIMAG(HJ(I)*HJC(J)-HJ(J)*HJC(I))
03504 C -- here was an error (ZW, 21.11.1991)
03505 DET2(I,J)=AIMAG(HJC(I)*HJ(J)-HJC(J)*HJ(I))
03506 C -- it was affecting sign of A_LR asymmetry in a1 decay.
03507 C -- note also collision of notation of gamma_va as defined in
03508 C -- TAUOLA paper and J.H. Kuhn and Santamaria Z. Phys C 48 (1990) 445
03509 * -----------------------------------
03510 IF (KTOM.EQ.1.OR.KTOM.EQ.-1) THEN
03511 SIGN= IDFF/ABS(IDFF)
03512 ELSEIF (KTOM.EQ.2) THEN
03513 SIGN=-IDFF/ABS(IDFF)
03514 ELSE
03515 PRINT *, 'STOP IN CLAXI: KTOM=',KTOM
03516 STOP
03517 ENDIF
03518 C
03519 DO 10 I=1,4
03520 10 HJC(I)=CONJG(HJ(I))
03521 PIA(1)= -2.*PN(3)*DET2(2,4)+2.*PN(4)*DET2(2,3)
03522 PIA(2)= -2.*PN(4)*DET2(1,3)+2.*PN(3)*DET2(1,4)
03523 PIA(3)= 2.*PN(4)*DET2(1,2)
03524 PIA(4)= 2.*PN(3)*DET2(1,2)
03525 C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
03526 DO 20 I=1,4
03527 20 PIA(I)=PIA(I)*SIGN
03528 END
03529 SUBROUTINE CLNUT(HJ,B,HV)
03530 C ----------------------------------------------------------------------
03531 * CALCULATES THE CONTRIBUTION BY NEUTRINO MASS
03532 * NOTE THE TAU IS ASSUMED TO BE AT REST
03533 C
03534 C called by : DAMPAA
03535 C ----------------------------------------------------------------------
03536 COMPLEX HJ(4)
03537 REAL HV(4),P(4)
03538 DATA P /3*0.,1.0/
03539 C
03540 CALL CLAXI(HJ,P,HV)
03541 B=REAL( HJ(4)*AIMAG(HJ(4)) - HJ(3)*AIMAG(HJ(3))
03542 & - HJ(2)*AIMAG(HJ(2)) - HJ(1)*AIMAG(HJ(1)) )
03543 RETURN
03544 END
03545 SUBROUTINE DAMPOG(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
03546 C ----------------------------------------------------------------------
03547 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
03548 * FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
03549 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
03550 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
03551 * THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
03552 C
03553 #if defined (ALEPH)
03554 C called by : DPHTRE
03555 #else
03556 C called by : DPHSAA
03557 #endif
03558 C ----------------------------------------------------------------------
03559 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03560 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03561 * ,AMK,AMKZ,AMKST,GAMKST
03562 C
03563 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03564 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03565 * ,AMK,AMKZ,AMKST,GAMKST
03566 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03567 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03568 COMMON /TESTA1/ KEYA1
03569 REAL HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIPL(4)
03570 REAL PAA(4),VEC1(4),VEC2(4)
03571 REAL PIVEC(4),PIAKS(4),HVM(4)
03572 COMPLEX BWIGN,HADCUR(4),FNORM,FORMOM
03573 DATA ICONT /1/
03574 * THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
03575 #if defined (CLEO)
03576 C AJWMOD to satisfy compiler, comment out this unused function.
03577 #else
03578 BWIGN(XM,AM,GAMMA)=1./CMPLX(XM**2-AM**2,GAMMA*AM)
03579 #endif
03580 C
03581 * FOUR MOMENTUM OF A1
03582 DO 10 I=1,4
03583 VEC1(I)=0.0
03584 VEC2(I)=0.0
03585 HV(I) =0.0
03586 10 PAA(I)=PIM1(I)+PIM2(I)+PIPL(I)
03587 VEC1(1)=1.0
03588 * MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
03589 XMAA =SQRT(ABS(PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2))
03590 XMOM =SQRT(ABS( (PIM2(4)+PIPL(4))**2-(PIM2(3)+PIPL(3))**2
03591 $ -(PIM2(2)+PIPL(2))**2-(PIM2(1)+PIPL(1))**2 ))
03592 XMRO2 =(PIPL(1))**2 +(PIPL(2))**2 +(PIPL(3))**2
03593 * ELEMENTS OF HADRON CURRENT
03594 PROD1 =VEC1(1)*PIPL(1)
03595 PROD2 =VEC2(2)*PIPL(2)
03596 P12 =PIM1(4)*PIM2(4)-PIM1(1)*PIM2(1)
03597 $ -PIM1(2)*PIM2(2)-PIM1(3)*PIM2(3)
03598 P1PL =PIM1(4)*PIPL(4)-PIM1(1)*PIPL(1)
03599 $ -PIM1(2)*PIPL(2)-PIM1(3)*PIPL(3)
03600 P2PL =PIPL(4)*PIM2(4)-PIPL(1)*PIM2(1)
03601 $ -PIPL(2)*PIM2(2)-PIPL(3)*PIM2(3)
03602 DO 40 I=1,3
03603 VEC1(I)= (VEC1(I)-PROD1/XMRO2*PIPL(I))
03604 40 CONTINUE
03605 GNORM=SQRT(VEC1(1)**2+VEC1(2)**2+VEC1(3)**2)
03606 DO 41 I=1,3
03607 VEC1(I)= VEC1(I)/GNORM
03608 41 CONTINUE
03609 VEC2(1)=(VEC1(2)*PIPL(3)-VEC1(3)*PIPL(2))/SQRT(XMRO2)
03610 VEC2(2)=(VEC1(3)*PIPL(1)-VEC1(1)*PIPL(3))/SQRT(XMRO2)
03611 VEC2(3)=(VEC1(1)*PIPL(2)-VEC1(2)*PIPL(1))/SQRT(XMRO2)
03612 P1VEC1 =PIM1(4)*VEC1(4)-PIM1(1)*VEC1(1)
03613 $ -PIM1(2)*VEC1(2)-PIM1(3)*VEC1(3)
03614 P2VEC1 =VEC1(4)*PIM2(4)-VEC1(1)*PIM2(1)
03615 $ -VEC1(2)*PIM2(2)-VEC1(3)*PIM2(3)
03616 P1VEC2 =PIM1(4)*VEC2(4)-PIM1(1)*VEC2(1)
03617 $ -PIM1(2)*VEC2(2)-PIM1(3)*VEC2(3)
03618 P2VEC2 =VEC2(4)*PIM2(4)-VEC2(1)*PIM2(1)
03619 $ -VEC2(2)*PIM2(2)-VEC2(3)*PIM2(3)
03620 * HADRON CURRENT
03621 FNORM=FORMOM(XMAA,XMOM)
03622 BRAK=0.0
03623 DO 120 JJ=1,2
03624 DO 45 I=1,4
03625 IF (JJ.EQ.1) THEN
03626 HADCUR(I) = FNORM *(
03627 $ VEC1(I)*(AMPI**2*P1PL-P2PL*(P12-P1PL))
03628 $ -PIM2(I)*(P2VEC1*P1PL-P1VEC1*P2PL)
03629 $ +PIPL(I)*(P2VEC1*P12 -P1VEC1*(AMPI**2+P2PL)) )
03630 ELSE
03631 HADCUR(I) = FNORM *(
03632 $ VEC2(I)*(AMPI**2*P1PL-P2PL*(P12-P1PL))
03633 $ -PIM2(I)*(P2VEC2*P1PL-P1VEC2*P2PL)
03634 $ +PIPL(I)*(P2VEC2*P12 -P1VEC2*(AMPI**2+P2PL)) )
03635 ENDIF
03636 45 CONTINUE
03637 C
03638 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
03639 CALL CLVEC(HADCUR,PN,PIVEC)
03640 CALL CLAXI(HADCUR,PN,PIAKS)
03641 CALL CLNUT(HADCUR,BRAKM,HVM)
03642 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
03643 BRAK=BRAK+(GV**2+GA**2)*PT(4)*PIVEC(4) +2.*GV*GA*PT(4)*PIAKS(4)
03644 & +2.*(GV**2-GA**2)*AMNUTA*AMTAU*BRAKM
03645 DO 90 I=1,3
03646 HV(I)=HV(I)-(AMTAU*((GV**2+GA**2)*PIAKS(I)+2.*GV*GA*PIVEC(I)))
03647 & +(GV**2-GA**2)*AMNUTA*AMTAU*HVM(I)
03648 90 CONTINUE
03649 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
03650 120 CONTINUE
03651 AMPLIT=(GFERMI*CCABIB)**2*BRAK/2.
03652 C THE STATISTICAL FACTOR FOR IDENTICAL PI-S WAS CANCELLED WITH
03653 C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
03654 C POLARIMETER VECTOR IN TAU REST FRAME
03655 DO 91 I=1,3
03656 HV(I)=-HV(I)/BRAK
03657 91 CONTINUE
03658
03659 END
03660 SUBROUTINE DAMPPK(MNUM,PT,PN,PIM1,PIM2,PIM3,AMPLIT,HV)
03661 C ----------------------------------------------------------------------
03662 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
03663 * FOR TAU DECAY INTO K K pi, K pi pi.
03664 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
03665 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
03666 C MNUM DECAY MODE IDENTIFIER.
03667 C
03668 #if defined (ALEPH)
03669 C called by : DPHTRE
03670 #else
03671 C called by : DPHSAA
03672 #endif
03673 C ----------------------------------------------------------------------
03674 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03675 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03676 * ,AMK,AMKZ,AMKST,GAMKST
03677 C
03678 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03679 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03680 * ,AMK,AMKZ,AMKST,GAMKST
03681 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03682 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03683 REAL HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIM3(4)
03684 REAL PAA(4),VEC1(4),VEC2(4),VEC3(4),VEC4(4),VEC5(4)
03685 REAL PIVEC(4),PIAKS(4),HVM(4)
03686 REAL FNORM(0:7),COEF(1:5,0:7)
03687 COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FORM4,FORM5,UROJ
03688 #if defined (CLEO)
03689 COMPLEX F1,F2,F3,F4,F5
03690 #endif
03691 EXTERNAL FORM1,FORM2,FORM3,FORM4,FORM5
03692 DATA PI /3.141592653589793238462643/
03693 DATA ICONT /0/
03694 C
03695 DATA FPI /93.3E-3/
03696 IF (ICONT.EQ.0) THEN
03697 ICONT=1
03698 UROJ=CMPLX(0.0,1.0)
03699 DWAPI0=SQRT(2.0)
03700 FNORM(0)=CCABIB/FPI
03701 FNORM(1)=CCABIB/FPI
03702 FNORM(2)=CCABIB/FPI
03703 FNORM(3)=CCABIB/FPI
03704 FNORM(4)=SCABIB/FPI/DWAPI0
03705 FNORM(5)=SCABIB/FPI
03706 FNORM(6)=SCABIB/FPI
03707 FNORM(7)=CCABIB/FPI
03708 C
03709 COEF(1,0)= 2.0*SQRT(2.)/3.0
03710 COEF(2,0)=-2.0*SQRT(2.)/3.0
03711 #if defined (CLEO)
03712 C AJW 2/98: Add in the D-wave and I=0 3pi substructure:
03713 COEF(3,0)= 2.0*SQRT(2.)/3.0
03714 #else
03715 COEF(3,0)= 0.0
03716 #endif
03717 COEF(4,0)= FPI
03718 COEF(5,0)= 0.0
03719 C
03720 COEF(1,1)=-SQRT(2.)/3.0
03721 COEF(2,1)= SQRT(2.)/3.0
03722 COEF(3,1)= 0.0
03723 COEF(4,1)= FPI
03724 COEF(5,1)= SQRT(2.)
03725 C
03726 COEF(1,2)=-SQRT(2.)/3.0
03727 COEF(2,2)= SQRT(2.)/3.0
03728 COEF(3,2)= 0.0
03729 COEF(4,2)= 0.0
03730 COEF(5,2)=-SQRT(2.)
03731 C
03732 #if defined (CLEO)
03733 C AJW 11/97: Add in the K*-prim-s, ala Finkemeier&Mirkes
03734 COEF(1,3)= 1./3.
03735 COEF(2,3)=-2./3.
03736 COEF(3,3)= 2./3.
03737 #else
03738 COEF(1,3)= 0.0
03739 COEF(2,3)=-1.0
03740 COEF(3,3)= 0.0
03741 #endif
03742 COEF(4,3)= 0.0
03743 COEF(5,3)= 0.0
03744 C
03745 COEF(1,4)= 1.0/SQRT(2.)/3.0
03746 COEF(2,4)=-1.0/SQRT(2.)/3.0
03747 COEF(3,4)= 0.0
03748 COEF(4,4)= 0.0
03749 COEF(5,4)= 0.0
03750 C
03751 COEF(1,5)=-SQRT(2.)/3.0
03752 COEF(2,5)= SQRT(2.)/3.0
03753 COEF(3,5)= 0.0
03754 COEF(4,5)= 0.0
03755 COEF(5,5)=-SQRT(2.)
03756 C
03757 #if defined (CLEO)
03758 C AJW 11/97: Add in the K*-prim-s, ala Finkemeier&Mirkes
03759 COEF(1,6)= 1./3.
03760 COEF(2,6)=-2./3.
03761 COEF(3,6)= 2./3.
03762 #else
03763 COEF(1,6)= 0.0
03764 COEF(2,6)=-1.0
03765 COEF(3,6)= 0.0
03766 #endif
03767 COEF(4,6)= 0.0
03768 COEF(5,6)=-2.0
03769 C
03770 COEF(1,7)= 0.0
03771 COEF(2,7)= 0.0
03772 COEF(3,7)= 0.0
03773 COEF(4,7)= 0.0
03774 COEF(5,7)=-SQRT(2.0/3.0)
03775 C
03776 ENDIF
03777 C
03778 DO 10 I=1,4
03779 10 PAA(I)=PIM1(I)+PIM2(I)+PIM3(I)
03780 XMAA =SQRT(ABS(PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2))
03781 XMRO1 =SQRT(ABS((PIM3(4)+PIM2(4))**2-(PIM3(1)+PIM2(1))**2
03782 $ -(PIM3(2)+PIM2(2))**2-(PIM3(3)+PIM2(3))**2))
03783 XMRO2 =SQRT(ABS((PIM3(4)+PIM1(4))**2-(PIM3(1)+PIM1(1))**2
03784 $ -(PIM3(2)+PIM1(2))**2-(PIM3(3)+PIM1(3))**2))
03785 XMRO3 =SQRT(ABS((PIM1(4)+PIM2(4))**2-(PIM1(1)+PIM2(1))**2
03786 $ -(PIM1(2)+PIM2(2))**2-(PIM1(3)+PIM2(3))**2))
03787 * ELEMENTS OF HADRON CURRENT
03788 PROD1 =PAA(4)*(PIM2(4)-PIM3(4))-PAA(1)*(PIM2(1)-PIM3(1))
03789 $ -PAA(2)*(PIM2(2)-PIM3(2))-PAA(3)*(PIM2(3)-PIM3(3))
03790 PROD2 =PAA(4)*(PIM3(4)-PIM1(4))-PAA(1)*(PIM3(1)-PIM1(1))
03791 $ -PAA(2)*(PIM3(2)-PIM1(2))-PAA(3)*(PIM3(3)-PIM1(3))
03792 PROD3 =PAA(4)*(PIM1(4)-PIM2(4))-PAA(1)*(PIM1(1)-PIM2(1))
03793 $ -PAA(2)*(PIM1(2)-PIM2(2))-PAA(3)*(PIM1(3)-PIM2(3))
03794 DO 40 I=1,4
03795 VEC1(I)= PIM2(I)-PIM3(I) -PAA(I)*PROD1/XMAA**2
03796 VEC2(I)= PIM3(I)-PIM1(I) -PAA(I)*PROD2/XMAA**2
03797 VEC3(I)= PIM1(I)-PIM2(I) -PAA(I)*PROD3/XMAA**2
03798 40 VEC4(I)= PIM1(I)+PIM2(I)+PIM3(I)
03799 CALL PROD5(PIM1,PIM2,PIM3,VEC5)
03800 * HADRON CURRENT
03801 C be aware that sign of vec2 is opposite to sign of vec1 in a1 case
03802 #if defined (CLEO)
03803 C Rationalize this code:
03804 F1 = CMPLX(COEF(1,MNUM))*FORM1(MNUM,XMAA**2,XMRO1**2,XMRO2**2)
03805 F2 = CMPLX(COEF(2,MNUM))*FORM2(MNUM,XMAA**2,XMRO2**2,XMRO1**2)
03806 F3 = CMPLX(COEF(3,MNUM))*FORM3(MNUM,XMAA**2,XMRO3**2,XMRO1**2)
03807 F4 = (-1.0*UROJ)*
03808 $CMPLX(COEF(4,MNUM))*FORM4(MNUM,XMAA**2,XMRO1**2,XMRO2**2,XMRO3**2)
03809 F5 = (-1.0)*UROJ/4.0/PI**2/FPI**2*
03810 $ CMPLX(COEF(5,MNUM))*FORM5(MNUM,XMAA**2,XMRO1**2,XMRO2**2)
03811
03812 DO 45 I=1,4
03813 HADCUR(I)= CMPLX(FNORM(MNUM)) * (
03814 $ CMPLX(VEC1(I))*F1+CMPLX(VEC2(I))*F2+CMPLX(VEC3(I))*F3+
03815 $ CMPLX(VEC4(I))*F4+CMPLX(VEC5(I))*F5)
03816 45 CONTINUE
03817 #else
03818 DO 45 I=1,4
03819 HADCUR(I)= CMPLX(FNORM(MNUM)) * (
03820 $CMPLX(VEC1(I)*COEF(1,MNUM))*FORM1(MNUM,XMAA**2,XMRO1**2,XMRO2**2)+
03821 $CMPLX(VEC2(I)*COEF(2,MNUM))*FORM2(MNUM,XMAA**2,XMRO2**2,XMRO1**2)+
03822 $CMPLX(VEC3(I)*COEF(3,MNUM))*FORM3(MNUM,XMAA**2,XMRO3**2,XMRO1**2)+
03823 *(-1.0*UROJ)*
03824 $CMPLX(VEC4(I)*COEF(4,MNUM))*FORM4(MNUM,XMAA**2,XMRO1**2,
03825 $ XMRO2**2,XMRO3**2) +
03826 $(-1.0)*UROJ/4.0/PI**2/FPI**2*
03827 $CMPLX(VEC5(I)*COEF(5,MNUM))*FORM5(MNUM,XMAA**2,XMRO1**2,XMRO2**2))
03828 45 CONTINUE
03829 #endif
03830 C
03831 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
03832 CALL CLVEC(HADCUR,PN,PIVEC)
03833 CALL CLAXI(HADCUR,PN,PIAKS)
03834 CALL CLNUT(HADCUR,BRAKM,HVM)
03835 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
03836 BRAK= (GV**2+GA**2)*PT(4)*PIVEC(4) +2.*GV*GA*PT(4)*PIAKS(4)
03837 & +2.*(GV**2-GA**2)*AMNUTA*AMTAU*BRAKM
03838 AMPLIT=(GFERMI)**2*BRAK/2.
03839 IF (MNUM.GE.9) THEN
03840 PRINT *, 'MNUM=',MNUM
03841 ZNAK=-1.0
03842 XM1=0.0
03843 XM2=0.0
03844 XM3=0.0
03845 DO 77 K=1,4
03846 IF (K.EQ.4) ZNAK=1.0
03847 XM1=ZNAK*PIM1(K)**2+XM1
03848 XM2=ZNAK*PIM2(K)**2+XM2
03849 XM3=ZNAK*PIM3(K)**2+XM3
03850 77 PRINT *, 'PIM1=',PIM1(K),'PIM2=',PIM2(K),'PIM3=',PIM3(K)
03851 PRINT *, 'XM1=',SQRT(XM1),'XM2=',SQRT(XM2),'XM3=',SQRT(XM3)
03852 PRINT *, '************************************************'
03853 ENDIF
03854 C POLARIMETER VECTOR IN TAU REST FRAME
03855 DO 90 I=1,3
03856 HV(I)=-(AMTAU*((GV**2+GA**2)*PIAKS(I)+2.*GV*GA*PIVEC(I)))
03857 & +(GV**2-GA**2)*AMNUTA*AMTAU*HVM(I)
03858 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
03859 HV(I)=-HV(I)/BRAK
03860 90 CONTINUE
03861 END
03862 SUBROUTINE PROD5(P1,P2,P3,PIA)
03863 C ----------------------------------------------------------------------
03864 C external product of P1, P2, P3 4-momenta.
03865 C SIGN is chosen +/- for decay of TAU +/- respectively
03866 C called by : DAMPAA, CLNUT
03867 C ----------------------------------------------------------------------
03868 COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
03869 COMMON / IDFC / IDFF
03870 REAL PIA(4),P1(4),P2(4),P3(4)
03871 DET2(I,J)=P1(I)*P2(J)-P2(I)*P1(J)
03872 * -----------------------------------
03873 IF (KTOM.EQ.1.OR.KTOM.EQ.-1) THEN
03874 SIGN= IDFF/ABS(IDFF)
03875 ELSEIF (KTOM.EQ.2) THEN
03876 SIGN=-IDFF/ABS(IDFF)
03877 ELSE
03878 PRINT *, 'STOP IN PROD5: KTOM=',KTOM
03879 STOP
03880 ENDIF
03881 C
03882 C EPSILON( p1(1), p2(2), p3(3), (4) ) = 1
03883 C
03884 PIA(1)= -P3(3)*DET2(2,4)+P3(4)*DET2(2,3)+P3(2)*DET2(3,4)
03885 PIA(2)= -P3(4)*DET2(1,3)+P3(3)*DET2(1,4)-P3(1)*DET2(3,4)
03886 PIA(3)= P3(4)*DET2(1,2)-P3(2)*DET2(1,4)+P3(1)*DET2(2,4)
03887 PIA(4)= P3(3)*DET2(1,2)-P3(2)*DET2(1,3)+P3(1)*DET2(2,3)
03888 C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
03889 DO 20 I=1,4
03890 20 PIA(I)=PIA(I)*SIGN
03891 END
03892
03893 SUBROUTINE DEXNEW(MODE,ISGN,POL,PNU,PAA,PNPI,JNPI)
03894 C ----------------------------------------------------------------------
03895 * THIS SIMULATES TAU DECAY IN TAU REST FRAME
03896 * INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
03897 * OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
03898 #if defined (ALEPH)
03899 * PAA hadron 4-vector
03900 * PNPI final state particles
03901 * JNPI decay type
03902 #else
03903 * PAA A1
03904 * PIM1 PION MINUS (OR PI0) 1 (FOR TAU MINUS)
03905 * PIM2 PION MINUS (OR PI0) 2
03906 * PIPL PION PLUS (OR PI-)
03907 * (PIPL,PIM1) FORM A RHO
03908 #endif
03909 C ----------------------------------------------------------------------
03910 COMMON / INOUT / INUT,IOUT
03911 REAL POL(4),HV(4),PAA(4),PNU(4),PNPI(4,9),RN(1)
03912 DATA IWARM/0/
03913 C
03914 IF(MODE.EQ.-1) THEN
03915 C ===================
03916 IWARM=1
03917 CALL DADNEW( -1,ISGN,HV,PNU,PAA,PNPI,JDUMM)
03918 #if defined (ALEPH)
03919 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXNEW $',100,-2.,2.)
03920 #else
03921 CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXAA $',100,-2.,2.)
03922 #endif
03923 C
03924 ELSEIF(MODE.EQ. 0) THEN
03925 * =======================
03926 300 CONTINUE
03927 IF(IWARM.EQ.0) GOTO 902
03928 CALL DADNEW( 0,ISGN,HV,PNU,PAA,PNPI,JNPI)
03929 WT=(1+POL(1)*HV(1)+POL(2)*HV(2)+POL(3)*HV(3))/2.
03930 CC CALL HFILL(816,WT)
03931 CALL RANMAR(RN,1)
03932 IF(RN(1).GT.WT) GOTO 300
03933 C
03934 ELSEIF(MODE.EQ. 1) THEN
03935 * =======================
03936 CALL DADNEW( 1,ISGN,HV,PNU,PAA,PNPI,JDUMM)
03937 CC CALL HPRINT(816)
03938 ENDIF
03939 C =====
03940 RETURN
03941 902 WRITE(IOUT, 9020)
03942 9020 FORMAT(' ----- DEXNEW: LACK OF INITIALISATION')
03943 STOP
03944 END
03945 SUBROUTINE DADNEW(MODE,ISGN,HV,PNU,PWB,PNPI,JNPI)
03946 C ----------------------------------------------------------------------
03947 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03948 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03949 * ,AMK,AMKZ,AMKST,GAMKST
03950 C
03951 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
03952 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
03953 * ,AMK,AMKZ,AMKST,GAMKST
03954 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03955 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
03956 COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
03957 REAL*4 GAMPMC ,GAMPER
03958 #if defined (ALEPH)
03959 #else
03960 COMMON / INOUT / INUT,IOUT
03961 #endif
03962 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
03963 #if defined (ALEPH)
03964 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
03965 #else
03966 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
03967 #endif
03968 & ,NAMES
03969 CHARACTER NAMES(NMODE)*31
03970 #if defined (ALEPH)
03971 COMMON / INOUT / INUT,IOUT
03972 #endif
03973
03974 REAL*4 PNU(4),PWB(4),PNPI(4,9),HV(4),HHV(4)
03975 REAL*4 PDUM1(4),PDUM2(4),PDUMI(4,9)
03976 REAL*4 RRR(3)
03977 REAL*4 WTMAX(NMODE)
03978 REAL*8 SWT(NMODE),SSWT(NMODE)
03979 DIMENSION NEVRAW(NMODE),NEVOVR(NMODE),NEVACC(NMODE)
03980 C
03981 DATA PI /3.141592653589793238462643/
03982 DATA IWARM/0/
03983 C
03984 IF(MODE.EQ.-1) THEN
03985 C ===================
03986 C -- AT THE MOMENT ONLY TWO DECAY MODES OF MULTIPIONS HAVE M. ELEM
03987 NMOD=NMODE
03988 IWARM=1
03989 C PRINT 7003
03990 DO 1 JNPI=1,NMOD
03991 NEVRAW(JNPI)=0
03992 NEVACC(JNPI)=0
03993 NEVOVR(JNPI)=0
03994 SWT(JNPI)=0
03995 SSWT(JNPI)=0
03996 WTMAX(JNPI)=-1.
03997 #if defined (CePeCe)
03998 DO I=1,500
03999 #elif defined (ALEPH)
04000 DO I=1,500
04001 #else
04002 C for 4pi phase space, need lots more trials at initialization,
04003 C or use the WTMAX determined with many trials for default model:
04004 NTRIALS = 500
04005 IF (JNPI.LE.NM4) THEN
04006 A = PKORB(3,37+JNPI)
04007 IF (A.LT.0.) THEN
04008 NTRIALS = 10000
04009 ELSE
04010 NTRIALS = 0
04011 WTMAX(JNPI)=A
04012 END IF
04013 END IF
04014 DO I=1,NTRIALS
04015 #endif
04016 IF (JNPI.LE.0) THEN
04017 GOTO 903
04018 ELSEIF(JNPI.LE.NM4) THEN
04019 CALL DPH4PI(WT,HV,PDUM1,PDUM2,PDUMI,JNPI)
04020 ELSEIF(JNPI.LE.NM4+NM5) THEN
04021 CALL DPH5PI(WT,HV,PDUM1,PDUM2,PDUMI,JNPI)
04022 ELSEIF(JNPI.LE.NM4+NM5+NM6) THEN
04023 CALL DPHNPI(WT,HV,PDUM1,PDUM2,PDUMI,JNPI)
04024 ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3) THEN
04025 INUM=JNPI-NM4-NM5-NM6
04026 CALL DPHSPK(WT,HV,PDUM1,PDUM2,PDUMI,INUM)
04027 ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3+NM2) THEN
04028 INUM=JNPI-NM4-NM5-NM6-NM3
04029 CALL DPHSRK(WT,HV,PDUM1,PDUM2,PDUMI,INUM)
04030 ELSE
04031 GOTO 903
04032 ENDIF
04033 IF(WT.GT.WTMAX(JNPI)/1.2) WTMAX(JNPI)=WT*1.2
04034 ENDDO
04035 #if defined (CePeCe)
04036 #elif defined (ALEPH)
04037 #else
04038 C PRINT *,' DADNEW JNPI,NTRIALS,WTMAX =',JNPI,NTRIALS,WTMAX(JNPI)
04039 #endif
04040 C CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADNPI $',100,0.,2.,.0)
04041 C PRINT 7004,WTMAX(JNPI)
04042 1 CONTINUE
04043 WRITE(IOUT,7005)
04044 C
04045 ELSEIF(MODE.EQ. 0) THEN
04046 C =======================
04047 IF(IWARM.EQ.0) GOTO 902
04048 C
04049 300 CONTINUE
04050 IF (JNPI.LE.0) THEN
04051 GOTO 903
04052 ELSEIF(JNPI.LE.NM4) THEN
04053 CALL DPH4PI(WT,HHV,PNU,PWB,PNPI,JNPI)
04054 ELSEIF(JNPI.LE.NM4+NM5) THEN
04055 CALL DPH5PI(WT,HHV,PNU,PWB,PNPI,JNPI)
04056 ELSEIF(JNPI.LE.NM4+NM5+NM6) THEN
04057 CALL DPHNPI(WT,HHV,PNU,PWB,PNPI,JNPI)
04058 ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3) THEN
04059 INUM=JNPI-NM4-NM5-NM6
04060 CALL DPHSPK(WT,HHV,PNU,PWB,PNPI,INUM)
04061 ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3+NM2) THEN
04062 INUM=JNPI-NM4-NM5-NM6-NM3
04063 CALL DPHSRK(WT,HHV,PNU,PWB,PNPI,INUM)
04064 ELSE
04065 GOTO 903
04066 ENDIF
04067 DO I=1,4
04068 HV(I)=-ISGN*HHV(I)
04069 ENDDO
04070 C CALL HFILL(801,WT/WTMAX(JNPI))
04071 NEVRAW(JNPI)=NEVRAW(JNPI)+1
04072 SWT(JNPI)=SWT(JNPI)+WT
04073 #if defined (ALEPH)
04074 SSWT(JNPI)=SSWT(JNPI)+WT**2
04075 #else
04076 cccM.S.>>>>>>
04077 cc SSWT(JNPI)=SSWT(JNPI)+WT**2
04078 SSWT(JNPI)=SSWT(JNPI)+dble(WT)**2
04079 cccM.S.<<<<<<
04080 #endif
04081 CALL RANMAR(RRR,3)
04082 RN=RRR(1)
04083 IF(WT.GT.WTMAX(JNPI)) NEVOVR(JNPI)=NEVOVR(JNPI)+1
04084 IF(RN*WTMAX(JNPI).GT.WT) GOTO 300
04085 C ROTATIONS TO BASIC TAU REST FRAME
04086 COSTHE=-1.+2.*RRR(2)
04087 THET=ACOS(COSTHE)
04088 PHI =2*PI*RRR(3)
04089 CALL ROTOR2(THET,PNU,PNU)
04090 CALL ROTOR3( PHI,PNU,PNU)
04091 CALL ROTOR2(THET,PWB,PWB)
04092 CALL ROTOR3( PHI,PWB,PWB)
04093 CALL ROTOR2(THET,HV,HV)
04094 CALL ROTOR3( PHI,HV,HV)
04095 ND=MULPIK(JNPI)
04096 DO 301 I=1,ND
04097 CALL ROTOR2(THET,PNPI(1,I),PNPI(1,I))
04098 CALL ROTOR3( PHI,PNPI(1,I),PNPI(1,I))
04099 301 CONTINUE
04100 NEVACC(JNPI)=NEVACC(JNPI)+1
04101 C
04102 ELSEIF(MODE.EQ. 1) THEN
04103 C =======================
04104 DO 500 JNPI=1,NMOD
04105 IF(NEVRAW(JNPI).EQ.0) GOTO 500
04106 PARGAM=SWT(JNPI)/FLOAT(NEVRAW(JNPI)+1)
04107 ERROR=0
04108 IF(NEVRAW(JNPI).NE.0)
04109 & ERROR=SQRT(SSWT(JNPI)/SWT(JNPI)**2-1./FLOAT(NEVRAW(JNPI)))
04110 RAT=PARGAM/GAMEL
04111 WRITE(IOUT, 7010) NAMES(JNPI),
04112 & NEVRAW(JNPI),NEVACC(JNPI),NEVOVR(JNPI),PARGAM,RAT,ERROR
04113 CC CALL HPRINT(801)
04114 GAMPMC(8+JNPI-1)=RAT
04115 GAMPER(8+JNPI-1)=ERROR
04116 CAM NEVDEC(8+JNPI-1)=NEVACC(JNPI)
04117 500 CONTINUE
04118 ENDIF
04119 C =====
04120 RETURN
04121 7003 FORMAT(///1X,15(5H*****)
04122 $ /,' *', 25X,'******** DADNEW INITIALISATION ********',9X,1H*
04123 $ )
04124 7004 FORMAT(' *',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H*/)
04125 7005 FORMAT(
04126 $ /,1X,15(5H*****)/)
04127 7010 FORMAT(///1X,15(5H*****)
04128 $ /,' *', 25X,'******** DADNEW FINAL REPORT ******** ',9X,1H*
04129 $ /,' *', 25X,'CHANNEL:',A31 ,9X,1H*
04130 $ /,' *',I20 ,5X,'NEVRAW = NO. OF DECAYS TOTAL ',9X,1H*
04131 $ /,' *',I20 ,5X,'NEVACC = NO. OF DECAYS ACCEPTED ',9X,1H*
04132 $ /,' *',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H*
04133 $ /,' *',E20.5,5X,'PARTIAL WTDTH IN GEV UNITS ',9X,1H*
04134 $ /,' *',F20.9,5X,'IN UNITS GFERMI**2*MASS**5/192/PI**3 ',9X,1H*
04135 $ /,' *',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H*
04136 $ /,1X,15(5H*****)/)
04137 902 WRITE(IOUT, 9020)
04138 9020 FORMAT(' ----- DADNEW: LACK OF INITIALISATION')
04139 STOP
04140 903 WRITE(IOUT, 9030) JNPI,MODE
04141 9030 FORMAT(' ----- DADNEW: WRONG JNPI',2I5)
04142 STOP
04143 END
04144
04145
04146 SUBROUTINE DPH4PI(DGAMT,HV,PN,PAA,PMULT,JNPI)
04147 C ----------------------------------------------------------------------
04148 #if defined (ALEPH)
04149 * IT SIMULATES 4pi DECAY IN TAU REST FRAME WITH
04150 * Z-AXIS ALONG 4pi MOMENTUM
04151 #else
04152 * IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
04153 * Z-AXIS ALONG A1 MOMENTUM
04154 #endif
04155 C ----------------------------------------------------------------------
04156 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04157 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04158 * ,AMK,AMKZ,AMKST,GAMKST
04159 C
04160 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04161 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04162 * ,AMK,AMKZ,AMKST,GAMKST
04163 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04164 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04165 #if defined (ALEPH)
04166 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
04167 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
04168 & ,NAMES
04169 CHARACTER NAMES(NMODE)*31
04170 #else
04171 #endif
04172 REAL HV(4),PT(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4),PMULT(4,9)
04173 REAL PR(4),PIZ(4)
04174 REAL*4 RRR(9)
04175 REAL*8 UU,FF,FF1,FF2,FF3,FF4,GG1,GG2,GG3,GG4,RR
04176 DATA PI /3.141592653589793238462643/
04177 DATA ICONT /0/
04178 XLAM(X,Y,Z)=SQRT(ABS((X-Y-Z)**2-4.0*Y*Z))
04179 C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
04180 C
04181 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
04182 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
04183 PHSPAC=1./2**23/PI**11
04184 PHSP=1./2**5/PI**2
04185 #if defined (ALEPH)
04186 C init decay mode JNPI
04187 AMP1=DCDMAS(IDFFIN(1,JNPI))
04188 AMP2=DCDMAS(IDFFIN(2,JNPI))
04189 AMP3=DCDMAS(IDFFIN(3,JNPI))
04190 AMP4=DCDMAS(IDFFIN(4,JNPI))
04191 #endif
04192 IF (JNPI.EQ.1) THEN
04193 PREZ=0.7
04194 #if defined (CePeCe)
04195 AMP1=AMPI
04196 AMP2=AMPI
04197 AMP3=AMPI
04198 AMP4=AMPIZ
04199 AMRX=0.782
04200 GAMRX=0.0084
04201 #elif defined (CLEO)
04202 AMP1=AMPI
04203 AMP2=AMPI
04204 AMP3=AMPI
04205 AMP4=AMPIZ
04206 AMRX=PKORB(1,14)
04207 GAMRX=PKORB(2,14)
04208 C AJW: cant simply change AMROP, etc, here
04209 C CHOICE is a by-hand tuning/optimization, no simple relationship
04210 C to actual resonance masses (accd to Z.Was).
04211 C What matters in the end is what you put in formf/curr .
04212 #else
04213 AMRX=0.782
04214 GAMRX=0.0084
04215 #endif
04216 AMROP =1.2
04217 GAMROP=.46
04218 ELSE
04219 PREZ=0.0
04220 #if defined (ALEPH)
04221 #else
04222 AMP1=AMPIZ
04223 AMP2=AMPIZ
04224 AMP3=AMPIZ
04225 AMP4=AMPI
04226 #endif
04227 AMRX=1.4
04228 GAMRX=.6
04229 AMROP =AMRX
04230 GAMROP=GAMRX
04231
04232 ENDIF
04233 #if defined (ALEPH)
04234
04235 RRDUM=0.3
04236 CALL CHOICE(100+JNPI,RRDUM,ICHAN,PROB1,PROB2,PROB3,
04237 #else
04238 RRB=0.3
04239 CALL CHOICE(100+JNPI,RRB,ICHAN,PROB1,PROB2,PROB3,
04240 #endif
04241 $ AMROP,GAMROP,AMRX,GAMRX,AMRB,GAMRB)
04242 PREZ=PROB1+PROB2
04243 C TAU MOMENTUM
04244 PT(1)=0.
04245 PT(2)=0.
04246 PT(3)=0.
04247 PT(4)=AMTAU
04248 C
04249 CALL RANMAR(RRR,9)
04250 C
04251 * MASSES OF 4, 3 AND 2 PI SYSTEMS
04252 C 3 PI WITH SAMPLING FOR RESONANCE
04253 CAM
04254 RR1=RRR(6)
04255 AMS1=(AMP1+AMP2+AMP3+AMP4)**2
04256 AMS2=(AMTAU-AMNUTA)**2
04257 ALP1=ATAN((AMS1-AMROP**2)/AMROP/GAMROP)
04258 ALP2=ATAN((AMS2-AMROP**2)/AMROP/GAMROP)
04259 ALP=ALP1+RR1*(ALP2-ALP1)
04260 AM4SQ =AMROP**2+AMROP*GAMROP*TAN(ALP)
04261 AM4 =SQRT(AM4SQ)
04262 PHSPAC=PHSPAC*
04263 $ ((AM4SQ-AMROP**2)**2+(AMROP*GAMROP)**2)/(AMROP*GAMROP)
04264 PHSPAC=PHSPAC*(ALP2-ALP1)
04265
04266 C
04267 RR1=RRR(1)
04268 AMS1=(AMP2+AMP3+AMP4)**2
04269 AMS2=(AM4-AMP1)**2
04270 IF (RRR(9).GT.PREZ) THEN
04271 AM3SQ=AMS1+ RR1*(AMS2-AMS1)
04272 AM3 =SQRT(AM3SQ)
04273 C --- this part of jacobian will be recovered later
04274 FF1=AMS2-AMS1
04275 ELSE
04276 * PHASE SPACE WITH SAMPLING FOR OMEGA RESONANCE,
04277 ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
04278 ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
04279 ALP=ALP1+RR1*(ALP2-ALP1)
04280 AM3SQ =AMRX**2+AMRX*GAMRX*TAN(ALP)
04281 AM3 =SQRT(AM3SQ)
04282 C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
04283 FF1=((AM3SQ-AMRX**2)**2+(AMRX*GAMRX)**2)/(AMRX*GAMRX)
04284 FF1=FF1*(ALP2-ALP1)
04285 ENDIF
04286 C MASS OF 2
04287 RR2=RRR(2)
04288 AMS1=(AMP3+AMP4)**2
04289 AMS2=(AM3-AMP2)**2
04290 * FLAT PHASE SPACE;
04291 AM2SQ=AMS1+ RR2*(AMS2-AMS1)
04292 AM2 =SQRT(AM2SQ)
04293 C --- this part of jacobian will be recovered later
04294 FF2=(AMS2-AMS1)
04295 * 2 RESTFRAME, DEFINE PIZ AND PIPL
04296 #if defined (ALEPH)
04297 ENQ1=(AM2SQ+AMP3**2-AMP4**2)/(2*AM2)
04298 ENQ2=(AM2SQ-AMP3**2+AMP4**2)/(2*AM2)
04299 PPI= ENQ1**2-AMP3**2
04300 PPPI=SQRT(ABS(ENQ1**2-AMP3**2))
04301 #else
04302 ENQ1=(AM2SQ-AMP3**2+AMP4**2)/(2*AM2)
04303 ENQ2=(AM2SQ+AMP3**2-AMP4**2)/(2*AM2)
04304 PPI= ENQ1**2-AMP4**2
04305 PPPI=SQRT(ABS(ENQ1**2-AMP4**2))
04306 #endif
04307 PHSPAC=PHSPAC*(4*PI)*(2*PPPI/AM2)
04308 #if defined (ALEPH)
04309 * PIZ momentum in 2 rest frame (PIZ is 3rd pi)
04310 #else
04311 * PIZ MOMENTUM IN 2 REST FRAME
04312 #endif
04313 CALL SPHERA(PPPI,PIZ)
04314 PIZ(4)=ENQ1
04315 #if defined (ALEPH)
04316 C PIPL momentum in 2 rest frame (PIPL is 4th pi)
04317 #else
04318 * PIPL MOMENTUM IN 2 REST FRAME
04319 #endif
04320 DO 30 I=1,3
04321 30 PIPL(I)=-PIZ(I)
04322 PIPL(4)=ENQ2
04323 * 3 REST FRAME, DEFINE PIM1
04324 #if defined (ALEPH)
04325 C PR momentum
04326 #else
04327 * PR MOMENTUM
04328 #endif
04329 PR(1)=0
04330 PR(2)=0
04331 PR(4)=1./(2*AM3)*(AM3**2+AM2**2-AMP2**2)
04332 PR(3)= SQRT(ABS(PR(4)**2-AM2**2))
04333 PPI = PR(4)**2-AM2**2
04334 #if defined (ALEPH)
04335 C PIM1 momentum
04336 #else
04337 * PIM1 MOMENTUM
04338 #endif
04339 PIM1(1)=0
04340 PIM1(2)=0
04341 PIM1(4)=1./(2*AM3)*(AM3**2-AM2**2+AMP2**2)
04342 PIM1(3)=-PR(3)
04343 C --- this part of jacobian will be recovered later
04344 FF3=(4*PI)*(2*PR(3)/AM3)
04345 * OLD PIONS BOOSTED FROM 2 REST FRAME TO 3 REST FRAME
04346 EXE=(PR(4)+PR(3))/AM2
04347 CALL BOSTR3(EXE,PIZ,PIZ)
04348 CALL BOSTR3(EXE,PIPL,PIPL)
04349 RR3=RRR(3)
04350 RR4=RRR(4)
04351 THET =ACOS(-1.+2*RR3)
04352 PHI = 2*PI*RR4
04353 CALL ROTPOL(THET,PHI,PIPL)
04354 CALL ROTPOL(THET,PHI,PIM1)
04355 CALL ROTPOL(THET,PHI,PIZ)
04356 CALL ROTPOL(THET,PHI,PR)
04357 #if defined (ALEPH)
04358 C 4 rest frame, define PIM2
04359 C PR momentum
04360 #else
04361 * 4 REST FRAME, DEFINE PIM2
04362 * PR MOMENTUM
04363 #endif
04364 PR(1)=0
04365 PR(2)=0
04366 PR(4)=1./(2*AM4)*(AM4**2+AM3**2-AMP1**2)
04367 PR(3)= SQRT(ABS(PR(4)**2-AM3**2))
04368 PPI = PR(4)**2-AM3**2
04369 #if defined (ALEPH)
04370 C PIM2 momentum
04371 #else
04372 * PIM2 MOMENTUM
04373 #endif
04374 PIM2(1)=0
04375 PIM2(2)=0
04376 PIM2(4)=1./(2*AM4)*(AM4**2-AM3**2+AMP1**2)
04377 PIM2(3)=-PR(3)
04378 C --- this part of jacobian will be recovered later
04379 FF4=(4*PI)*(2*PR(3)/AM4)
04380 * OLD PIONS BOOSTED FROM 3 REST FRAME TO 4 REST FRAME
04381 EXE=(PR(4)+PR(3))/AM3
04382 CALL BOSTR3(EXE,PIZ,PIZ)
04383 CALL BOSTR3(EXE,PIPL,PIPL)
04384 CALL BOSTR3(EXE,PIM1,PIM1)
04385 RR3=RRR(7)
04386 RR4=RRR(8)
04387 THET =ACOS(-1.+2*RR3)
04388 PHI = 2*PI*RR4
04389 CALL ROTPOL(THET,PHI,PIPL)
04390 CALL ROTPOL(THET,PHI,PIM1)
04391 CALL ROTPOL(THET,PHI,PIM2)
04392 CALL ROTPOL(THET,PHI,PIZ)
04393 CALL ROTPOL(THET,PHI,PR)
04394 C
04395 * NOW TO THE TAU REST FRAME, DEFINE PAA AND NEUTRINO MOMENTA
04396 * PAA MOMENTUM
04397 PAA(1)=0
04398 PAA(2)=0
04399 PAA(4)=1./(2*AMTAU)*(AMTAU**2-AMNUTA**2+AM4**2)
04400 PAA(3)= SQRT(ABS(PAA(4)**2-AM4**2))
04401 PPI = PAA(4)**2-AM4**2
04402 PHSPAC=PHSPAC*(4*PI)*(2*PAA(3)/AMTAU)
04403 PHSP=PHSP*(4*PI)*(2*PAA(3)/AMTAU)
04404 * TAU-NEUTRINO MOMENTUM
04405 PN(1)=0
04406 PN(2)=0
04407 PN(4)=1./(2*AMTAU)*(AMTAU**2+AMNUTA**2-AM4**2)
04408 PN(3)=-PAA(3)
04409 C ZBW 20.12.2002 bug fix
04410 IF(RRR(9).LE.0.5*PREZ) THEN
04411 DO 72 I=1,4
04412 X=PIM1(I)
04413 PIM1(I)=PIM2(I)
04414 72 PIM2(I)=X
04415 ENDIF
04416 C end of bug fix
04417 C WE INCLUDE REMAINING PART OF THE JACOBIAN
04418 C --- FLAT CHANNEL
04419 AM3SQ=(PIM1(4)+PIZ(4)+PIPL(4))**2-(PIM1(3)+PIZ(3)+PIPL(3))**2
04420 $ -(PIM1(2)+PIZ(2)+PIPL(2))**2-(PIM1(1)+PIZ(1)+PIPL(1))**2
04421 AMS2=(AM4-AMP2)**2
04422 AMS1=(AMP1+AMP3+AMP4)**2
04423 FF1=(AMS2-AMS1)
04424 AMS1=(AMP3+AMP4)**2
04425 AMS2=(SQRT(AM3SQ)-AMP1)**2
04426 FF2=AMS2-AMS1
04427 FF3=(4*PI)*(XLAM(AM2**2,AMP1**2,AM3SQ)/AM3SQ)
04428 FF4=(4*PI)*(XLAM(AM3SQ,AMP2**2,AM4**2)/AM4**2)
04429 UU=FF1*FF2*FF3*FF4
04430 C --- FIRST CHANNEL
04431 AM3SQ=(PIM1(4)+PIZ(4)+PIPL(4))**2-(PIM1(3)+PIZ(3)+PIPL(3))**2
04432 $ -(PIM1(2)+PIZ(2)+PIPL(2))**2-(PIM1(1)+PIZ(1)+PIPL(1))**2
04433 AMS2=(AM4-AMP2)**2
04434 AMS1=(AMP1+AMP3+AMP4)**2
04435 ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
04436 ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
04437 FF1=((AM3SQ-AMRX**2)**2+(AMRX*GAMRX)**2)/(AMRX*GAMRX)
04438 FF1=FF1*(ALP2-ALP1)
04439 AMS1=(AMP3+AMP4)**2
04440 AMS2=(SQRT(AM3SQ)-AMP1)**2
04441 FF2=AMS2-AMS1
04442 FF3=(4*PI)*(XLAM(AM2**2,AMP1**2,AM3SQ)/AM3SQ)
04443 FF4=(4*PI)*(XLAM(AM3SQ,AMP2**2,AM4**2)/AM4**2)
04444 FF=FF1*FF2*FF3*FF4
04445 C --- SECOND CHANNEL
04446 AM3SQ=(PIM2(4)+PIZ(4)+PIPL(4))**2-(PIM2(3)+PIZ(3)+PIPL(3))**2
04447 $ -(PIM2(2)+PIZ(2)+PIPL(2))**2-(PIM2(1)+PIZ(1)+PIPL(1))**2
04448 AMS2=(AM4-AMP1)**2
04449 AMS1=(AMP2+AMP3+AMP4)**2
04450 ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
04451 ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
04452 GG1=((AM3SQ-AMRX**2)**2+(AMRX*GAMRX)**2)/(AMRX*GAMRX)
04453 GG1=GG1*(ALP2-ALP1)
04454 AMS1=(AMP3+AMP4)**2
04455 AMS2=(SQRT(AM3SQ)-AMP2)**2
04456 GG2=AMS2-AMS1
04457 GG3=(4*PI)*(XLAM(AM2**2,AMP2**2,AM3SQ)/AM3SQ)
04458 GG4=(4*PI)*(XLAM(AM3SQ,AMP1**2,AM4**2)/AM4**2)
04459 GG=GG1*GG2*GG3*GG4
04460 C --- JACOBIAN AVERAGED OVER THE TWO
04461 IF ( ( (FF+GG)*UU+FF*GG ).GT.0.0D0) THEN
04462 RR=FF*GG*UU/(0.5*PREZ*(FF+GG)*UU+(1.0-PREZ)*FF*GG)
04463 PHSPAC=PHSPAC*RR
04464 ELSE
04465 PHSPAC=0.0
04466 ENDIF
04467 * MOMENTA OF THE TWO PI-MINUS ARE RANDOMLY SYMMETRISED
04468 IF (JNPI.EQ.1) THEN
04469 RR5= RRR(5)
04470 IF(RR5.LE.0.5) THEN
04471 DO 70 I=1,4
04472 X=PIM1(I)
04473 PIM1(I)=PIM2(I)
04474 70 PIM2(I)=X
04475 ENDIF
04476 PHSPAC=PHSPAC/2.
04477 ELSE
04478 C MOMENTA OF PI0-S ARE GENERATED UNIFORMLY ONLY IF PREZ=0.0
04479 RR5= RRR(5)
04480 IF(RR5.LE.0.5) THEN
04481 DO 71 I=1,4
04482 X=PIM1(I)
04483 PIM1(I)=PIM2(I)
04484 71 PIM2(I)=X
04485 ENDIF
04486 PHSPAC=PHSPAC/6.
04487 ENDIF
04488 * ALL PIONS BOOSTED FROM 4 REST FRAME TO TAU REST FRAME
04489 * Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
04490 EXE=(PAA(4)+PAA(3))/AM4
04491 CALL BOSTR3(EXE,PIZ,PIZ)
04492 CALL BOSTR3(EXE,PIPL,PIPL)
04493 CALL BOSTR3(EXE,PIM1,PIM1)
04494 CALL BOSTR3(EXE,PIM2,PIM2)
04495 CALL BOSTR3(EXE,PR,PR)
04496 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
04497 C CHECK ON CONSISTENCY WITH DADNPI, THEN, CODE BREAKES UNIFORM PION
04498 C DISTRIBUTION IN HADRONIC SYSTEM
04499 #if defined (ALEPH)
04500 CALL DAM4PI(JNPI,PT,PN,PIM1,PIM2,PIZ,PIPL,AMPLIT,HV)
04501 #else
04502 CAM Assume neutrino mass=0. and sum over final polarisation
04503 C AMX2=AM4**2
04504 C BRAK= 2*(AMTAU**2-AMX2) * (AMTAU**2+2.*AMX2)
04505 C AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK * AMX2*SIGEE(AMX2,1)
04506 IF (JNPI.EQ.1) THEN
04507 CALL DAM4PI(JNPI,PT,PN,PIM1,PIM2,PIZ,PIPL,AMPLIT,HV)
04508 ELSEIF (JNPI.EQ.2) THEN
04509 CALL DAM4PI(JNPI,PT,PN,PIM1,PIM2,PIPL,PIZ,AMPLIT,HV)
04510 ENDIF
04511 #endif
04512 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
04513 C PHASE SPACE CHECK
04514 C DGAMT=PHSPAC
04515 DO 77 K=1,4
04516 PMULT(K,1)=PIM1(K)
04517 PMULT(K,2)=PIM2(K)
04518 #if defined (ALEPH)
04519 PMULT(K,3)=PIZ (K)
04520 PMULT(K,4)=PIPL(K)
04521 #else
04522 PMULT(K,3)=PIPL(K)
04523 PMULT(K,4)=PIZ (K)
04524 #endif
04525 77 CONTINUE
04526 END
04527 SUBROUTINE DAM4PI(MNUM,PT,PN,PIM1,PIM2,PIM3,PIM4,AMPLIT,HV)
04528 C ----------------------------------------------------------------------
04529 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
04530 * FOR TAU DECAY INTO 4 PI MODES
04531 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
04532 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
04533 C MNUM DECAY MODE IDENTIFIER.
04534 C
04535 #if defined (ALEPH)
04536 C called by : DPH4PI
04537 #else
04538 C called by : DPHSAA
04539 #endif
04540 C ----------------------------------------------------------------------
04541 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04542 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04543 * ,AMK,AMKZ,AMKST,GAMKST
04544 C
04545 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04546 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04547 * ,AMK,AMKZ,AMKST,GAMKST
04548 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04549 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04550 REAL HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIM3(4),PIM4(4)
04551 REAL PIVEC(4),PIAKS(4),HVM(4)
04552 COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FORM4,FORM5
04553 EXTERNAL FORM1,FORM2,FORM3,FORM4,FORM5
04554 DATA PI /3.141592653589793238462643/
04555 DATA ICONT /0/
04556 C
04557 #if defined (CLEO)
04558 CALL CURR_CLEO(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
04559 #else
04560 CALL CURR(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
04561 #endif
04562 C
04563 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
04564 CALL CLVEC(HADCUR,PN,PIVEC)
04565 CALL CLAXI(HADCUR,PN,PIAKS)
04566 CALL CLNUT(HADCUR,BRAKM,HVM)
04567 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
04568 BRAK= (GV**2+GA**2)*PT(4)*PIVEC(4) +2.*GV*GA*PT(4)*PIAKS(4)
04569 & +2.*(GV**2-GA**2)*AMNUTA*AMTAU*BRAKM
04570 AMPLIT=(CCABIB*GFERMI)**2*BRAK/2.
04571 C POLARIMETER VECTOR IN TAU REST FRAME
04572 DO 90 I=1,3
04573 HV(I)=-(AMTAU*((GV**2+GA**2)*PIAKS(I)+2.*GV*GA*PIVEC(I)))
04574 & +(GV**2-GA**2)*AMNUTA*AMTAU*HVM(I)
04575 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
04576 IF (BRAK.NE.0.0)
04577 &HV(I)=-HV(I)/BRAK
04578 90 CONTINUE
04579 END
04580 SUBROUTINE DPH5PI(DGAMT,HV,PN,PAA,PMULT,JNPI)
04581 C ----------------------------------------------------------------------
04582 * IT SIMULATES 5pi DECAY IN TAU REST FRAME WITH
04583 * Z-AXIS ALONG 5pi MOMENTUM
04584 C ----------------------------------------------------------------------
04585 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04586 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04587 * ,AMK,AMKZ,AMKST,GAMKST
04588 C
04589 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04590 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04591
04592
04593 * ,AMK,AMKZ,AMKST,GAMKST
04594 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04595 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04596 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
04597 #if defined (ALEPH)
04598 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
04599 #else
04600 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
04601 #endif
04602 & ,NAMES
04603 CHARACTER NAMES(NMODE)*31
04604 REAL HV(4),PT(4),PN(4),PAA(4),PMULT(4,9)
04605 REAL*4 PR(4),PI1(4),PI2(4),PI3(4),PI4(4),PI5(4)
04606 REAL*8 AMP1,AMP2,AMP3,AMP4,AMP5,ams1,ams2,amom,gamom
04607 REAL*8 AM5SQ,AM4SQ,AM3SQ,AM2SQ,AM5,AM4,AM3
04608 REAL*4 RRR(10)
04609 REAL*8 gg1,gg2,gg3,ff1,ff2,ff3,ff4,alp,alp1,alp2
04610 #if defined (ALEPH)
04611 REAL*8 XM,AM,GAMMAB
04612 #else
04613 REAL*8 XM,AM,GAMMA
04614 ccM.S.>>>>>>
04615 real*8 phspac
04616 ccM.S.<<<<<<
04617 #endif
04618 DATA PI /3.141592653589793238462643/
04619 DATA ICONT /0/
04620 data fpi /93.3e-3/
04621 c
04622 COMPLEX BWIGN
04623 C
04624 #if defined (ALEPH)
04625 BWIGN(XM,AM,GAMMAB)=XM**2/CMPLX(XM**2-AM**2,GAMMAB*AM)
04626 #else
04627 BWIGN(XM,AM,GAMMA)=XM**2/CMPLX(XM**2-AM**2,GAMMA*AM)
04628 #endif
04629
04630 C
04631 AMOM=.782
04632 GAMOM=0.0085
04633 c
04634 C 6 BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
04635 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
04636 PHSPAC=1./2**29/PI**14
04637 c PHSPAC=1./2**5/PI**2
04638 C init 5pi decay mode (JNPI)
04639 AMP1=DCDMAS(IDFFIN(1,JNPI))
04640 AMP2=DCDMAS(IDFFIN(2,JNPI))
04641 AMP3=DCDMAS(IDFFIN(3,JNPI))
04642 AMP4=DCDMAS(IDFFIN(4,JNPI))
04643 AMP5=DCDMAS(IDFFIN(5,JNPI))
04644 c
04645 C TAU MOMENTUM
04646 PT(1)=0.
04647 PT(2)=0.
04648 PT(3)=0.
04649 PT(4)=AMTAU
04650 C
04651 CALL RANMAR(RRR,10)
04652 C
04653 c masses of 5, 4, 3 and 2 pi systems
04654 c 3 pi with sampling for omega resonance
04655 cam
04656 c mass of 5 (12345)
04657 rr1=rrr(10)
04658 ams1=(amp1+amp2+amp3+amp4+amp5)**2
04659 ams2=(amtau-amnuta)**2
04660 am5sq=ams1+ rr1*(ams2-ams1)
04661 am5 =sqrt(am5sq)
04662 phspac=phspac*(ams2-ams1)
04663 c
04664 c mass of 4 (2345)
04665 c flat phase space
04666 rr1=rrr(9)
04667 ams1=(amp2+amp3+amp4+amp5)**2
04668 ams2=(am5-amp1)**2
04669 am4sq=ams1+ rr1*(ams2-ams1)
04670 am4 =sqrt(am4sq)
04671 gg1=ams2-ams1
04672 c
04673 c mass of 3 (234)
04674 C phase space with sampling for omega resonance
04675 rr1=rrr(1)
04676 ams1=(amp2+amp3+amp4)**2
04677 ams2=(am4-amp5)**2
04678 alp1=atan((ams1-amom**2)/amom/gamom)
04679 alp2=atan((ams2-amom**2)/amom/gamom)
04680 alp=alp1+rr1*(alp2-alp1)
04681 am3sq =amom**2+amom*gamom*tan(alp)
04682 am3 =sqrt(am3sq)
04683 c --- this part of the jacobian will be recovered later ---------------
04684 gg2=((am3sq-amom**2)**2+(amom*gamom)**2)/(amom*gamom)
04685 gg2=gg2*(alp2-alp1)
04686 c flat phase space;
04687 C am3sq=ams1+ rr1*(ams2-ams1)
04688 C am3 =sqrt(am3sq)
04689 c --- this part of jacobian will be recovered later
04690 C gg2=ams2-ams1
04691 c
04692 C mass of 2 (34)
04693 rr2=rrr(2)
04694 ams1=(amp3+amp4)**2
04695 ams2=(am3-amp2)**2
04696 c flat phase space;
04697 am2sq=ams1+ rr2*(ams2-ams1)
04698 am2 =sqrt(am2sq)
04699 c --- this part of jacobian will be recovered later
04700 gg3=ams2-ams1
04701 c
04702 c (34) restframe, define pi3 and pi4
04703 enq1=(am2sq+amp3**2-amp4**2)/(2*am2)
04704 enq2=(am2sq-amp3**2+amp4**2)/(2*am2)
04705 ppi= enq1**2-amp3**2
04706 pppi=sqrt(abs(enq1**2-amp3**2))
04707 ff1=(4*pi)*(2*pppi/am2)
04708 c pi3 momentum in (34) rest frame
04709 call sphera(pppi,pi3)
04710 pi3(4)=enq1
04711 c pi4 momentum in (34) rest frame
04712 do 30 i=1,3
04713 30 pi4(i)=-pi3(i)
04714 pi4(4)=enq2
04715 c
04716 c (234) rest frame, define pi2
04717 c pr momentum
04718 pr(1)=0
04719 pr(2)=0
04720 pr(4)=1./(2*am3)*(am3**2+am2**2-amp2**2)
04721 pr(3)= sqrt(abs(pr(4)**2-am2**2))
04722 ppi = pr(4)**2-am2**2
04723 c pi2 momentum
04724 pi2(1)=0
04725 pi2(2)=0
04726 pi2(4)=1./(2*am3)*(am3**2-am2**2+amp2**2)
04727 pi2(3)=-pr(3)
04728 c --- this part of jacobian will be recovered later
04729 ff2=(4*pi)*(2*pr(3)/am3)
04730 c old pions boosted from 2 rest frame to 3 rest frame
04731 exe=(pr(4)+pr(3))/am2
04732 call bostr3(exe,pi3,pi3)
04733 call bostr3(exe,pi4,pi4)
04734 rr3=rrr(3)
04735 rr4=rrr(4)
04736 thet =acos(-1.+2*rr3)
04737 phi = 2*pi*rr4
04738 call rotpol(thet,phi,pi2)
04739 call rotpol(thet,phi,pi3)
04740 call rotpol(thet,phi,pi4)
04741 C
04742 C (2345) rest frame, define pi5
04743 c pr momentum
04744 pr(1)=0
04745 pr(2)=0
04746 pr(4)=1./(2*am4)*(am4**2+am3**2-amp5**2)
04747 pr(3)= sqrt(abs(pr(4)**2-am3**2))
04748 ppi = pr(4)**2-am3**2
04749 c pi5 momentum
04750 pi5(1)=0
04751 pi5(2)=0
04752 pi5(4)=1./(2*am4)*(am4**2-am3**2+amp5**2)
04753 pi5(3)=-pr(3)
04754 c --- this part of jacobian will be recovered later
04755 ff3=(4*pi)*(2*pr(3)/am4)
04756 c old pions boosted from 3 rest frame to 4 rest frame
04757 exe=(pr(4)+pr(3))/am3
04758 call bostr3(exe,pi2,pi2)
04759 call bostr3(exe,pi3,pi3)
04760 call bostr3(exe,pi4,pi4)
04761 rr3=rrr(5)
04762 rr4=rrr(6)
04763 thet =acos(-1.+2*rr3)
04764 phi = 2*pi*rr4
04765 call rotpol(thet,phi,pi2)
04766 call rotpol(thet,phi,pi3)
04767 call rotpol(thet,phi,pi4)
04768 call rotpol(thet,phi,pi5)
04769 C
04770 C (12345) rest frame, define pi1
04771 c pr momentum
04772 pr(1)=0
04773 pr(2)=0
04774 pr(4)=1./(2*am5)*(am5**2+am4**2-amp1**2)
04775 pr(3)= sqrt(abs(pr(4)**2-am4**2))
04776 ppi = pr(4)**2-am4**2
04777 c pi1 momentum
04778 pi1(1)=0
04779 pi1(2)=0
04780 pi1(4)=1./(2*am5)*(am5**2-am4**2+amp1**2)
04781 pi1(3)=-pr(3)
04782 c --- this part of jacobian will be recovered later
04783 ff4=(4*pi)*(2*pr(3)/am5)
04784 c old pions boosted from 4 rest frame to 5 rest frame
04785 exe=(pr(4)+pr(3))/am4
04786 call bostr3(exe,pi2,pi2)
04787 call bostr3(exe,pi3,pi3)
04788 call bostr3(exe,pi4,pi4)
04789 call bostr3(exe,pi5,pi5)
04790 rr3=rrr(7)
04791 rr4=rrr(8)
04792 thet =acos(-1.+2*rr3)
04793 phi = 2*pi*rr4
04794 call rotpol(thet,phi,pi1)
04795 call rotpol(thet,phi,pi2)
04796 call rotpol(thet,phi,pi3)
04797 call rotpol(thet,phi,pi4)
04798 call rotpol(thet,phi,pi5)
04799 c
04800 * now to the tau rest frame, define paa and neutrino momenta
04801 * paa momentum
04802 paa(1)=0
04803 paa(2)=0
04804 c paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am5**2)
04805 c paa(3)= sqrt(abs(paa(4)**2-am5**2))
04806 c ppi = paa(4)**2-am5**2
04807 paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am5sq)
04808 paa(3)= sqrt(abs(paa(4)**2-am5sq))
04809 ppi = paa(4)**2-am5sq
04810 phspac=phspac*(4*pi)*(2*paa(3)/amtau)
04811 * tau-neutrino momentum
04812 pn(1)=0
04813 pn(2)=0
04814 pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-am5**2)
04815 pn(3)=-paa(3)
04816 c
04817 phspac=phspac * gg1*gg2*gg3*ff1*ff2*ff3*ff4
04818 c
04819 C all pions boosted from 5 rest frame to tau rest frame
04820 C z-axis antiparallel to neutrino momentum
04821 exe=(paa(4)+paa(3))/am5
04822 call bostr3(exe,pi1,pi1)
04823 call bostr3(exe,pi2,pi2)
04824 call bostr3(exe,pi3,pi3)
04825 call bostr3(exe,pi4,pi4)
04826 call bostr3(exe,pi5,pi5)
04827 c
04828 C partial width consists of phase space and amplitude
04829 C AMPLITUDE (cf YS.Tsai Phys.Rev.D4,2821(1971)
04830 C or F.Gilman SH.Rhie Phys.Rev.D31,1066(1985)
04831 C
04832 PXQ=AMTAU*PAA(4)
04833 PXN=AMTAU*PN(4)
04834 QXN=PAA(4)*PN(4)-PAA(1)*PN(1)-PAA(2)*PN(2)-PAA(3)*PN(3)
04835 BRAK=2*(GV**2+GA**2)*(2*PXQ*QXN+AM5SQ*PXN)
04836 & -6*(GV**2-GA**2)*AMTAU*AMNUTA*AM5SQ
04837 fompp = cabs(bwign(am3,amom,gamom))**2
04838 c normalisation factor (to some numerical undimensioned factor;
04839 c cf R.Fischer et al ZPhys C3, 313 (1980))
04840 fnorm = 1/fpi**6
04841 c AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK * AM5SQ*SIGEE(AM5SQ,JNPI)
04842 AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK
04843 amplit = amplit * fompp * fnorm
04844 c phase space test
04845 c amplit = amplit * fnorm
04846 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
04847 c ignore spin terms
04848 DO 40 I=1,3
04849 40 HV(I)=0.
04850 c
04851 do 77 k=1,4
04852 pmult(k,1)=pi1(k)
04853 pmult(k,2)=pi2(k)
04854 pmult(k,3)=pi3(k)
04855 pmult(k,4)=pi4(k)
04856 pmult(k,5)=pi5(k)
04857 77 continue
04858 return
04859 #if defined (ALEPH)
04860 C missing: transposition of identical particles, statistical factors
04861 C for identical matrices, polarimetric vector. Matrix element rather nai
04862 #else
04863 C missing: transposition of identical particles, startistical factors
04864 C for identical matrices, polarimetric vector. Matrix element rather naive.
04865 #endif
04866 C flat phase space in pion system + with breit wigner for omega
04867 C anyway it is better than nothing, and code is improvable.
04868 end
04869 SUBROUTINE DPHSRK(DGAMT,HV,PN,PR,PMULT,INUM)
04870 C ----------------------------------------------------------------------
04871 C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
04872 C Z-AXIS ALONG RHO MOMENTUM
04873 C Rho decays to K Kbar
04874 C ----------------------------------------------------------------------
04875 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04876 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04877 * ,AMK,AMKZ,AMKST,GAMKST
04878 C
04879 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04880 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04881 * ,AMK,AMKZ,AMKST,GAMKST
04882 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04883 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04884 REAL HV(4),PT(4),PN(4),PR(4),PKC(4),PKZ(4),QQ(4),PMULT(4,9)
04885 #if defined (ALEPH)
04886 REAL*4 RR1(1)
04887 #else
04888 REAL RR1(1)
04889 #endif
04890 DATA PI /3.141592653589793238462643/
04891 DATA ICONT /0/
04892 C
04893 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
04894 PHSPAC=1./2**11/PI**5
04895 C TAU MOMENTUM
04896 PT(1)=0.
04897 PT(2)=0.
04898 PT(3)=0.
04899 PT(4)=AMTAU
04900 C MASS OF (REAL/VIRTUAL) RHO
04901 AMS1=(AMK+AMKZ)**2
04902 AMS2=(AMTAU-AMNUTA)**2
04903 C FLAT PHASE SPACE
04904 CALL RANMAR(RR1,1)
04905 AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
04906 AMX=SQRT(AMX2)
04907 PHSPAC=PHSPAC*(AMS2-AMS1)
04908 C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
04909 c ALP1=ATAN((AMS1-AMRO**2)/AMRO/GAMRO)
04910 c ALP2=ATAN((AMS2-AMRO**2)/AMRO/GAMRO)
04911 CAM
04912 100 CONTINUE
04913 c CALL RANMAR(RR1,1)
04914 c ALP=ALP1+RR1(1)*(ALP2-ALP1)
04915 c AMX2=AMRO**2+AMRO*GAMRO*TAN(ALP)
04916 c AMX=SQRT(AMX2)
04917 c IF(AMX.LT.(AMK+AMKZ)) GO TO 100
04918 CAM
04919 c PHSPAC=PHSPAC*((AMX2-AMRO**2)**2+(AMRO*GAMRO)**2)/(AMRO*GAMRO)
04920 c PHSPAC=PHSPAC*(ALP2-ALP1)
04921 C
04922 C TAU-NEUTRINO MOMENTUM
04923 PN(1)=0
04924 PN(2)=0
04925 PN(4)=1./(2*AMTAU)*(AMTAU**2+AMNUTA**2-AMX**2)
04926 PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
04927 C RHO MOMENTUM
04928 PR(1)=0
04929 PR(2)=0
04930 PR(4)=1./(2*AMTAU)*(AMTAU**2-AMNUTA**2+AMX**2)
04931 PR(3)=-PN(3)
04932 PHSPAC=PHSPAC*(4*PI)*(2*PR(3)/AMTAU)
04933 C
04934 CAM
04935 ENQ1=(AMX2+AMK**2-AMKZ**2)/(2.*AMX)
04936 ENQ2=(AMX2-AMK**2+AMKZ**2)/(2.*AMX)
04937 PPPI=SQRT((ENQ1-AMK)*(ENQ1+AMK))
04938 PHSPAC=PHSPAC*(4*PI)*(2*PPPI/AMX)
04939 C CHARGED PI MOMENTUM IN RHO REST FRAME
04940 CALL SPHERA(PPPI,PKC)
04941 PKC(4)=ENQ1
04942 C NEUTRAL PI MOMENTUM IN RHO REST FRAME
04943 DO 20 I=1,3
04944 20 PKZ(I)=-PKC(I)
04945 PKZ(4)=ENQ2
04946 EXE=(PR(4)+PR(3))/AMX
04947 C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
04948 CALL BOSTR3(EXE,PKC,PKC)
04949 CALL BOSTR3(EXE,PKZ,PKZ)
04950 DO 30 I=1,4
04951 30 QQ(I)=PKC(I)-PKZ(I)
04952 C QQ transverse to PR
04953 PKSD =PR(4)*PR(4)-PR(3)*PR(3)-PR(2)*PR(2)-PR(1)*PR(1)
04954 QQPKS=PR(4)* QQ(4)-PR(3)* QQ(3)-PR(2)* QQ(2)-PR(1)* QQ(1)
04955 DO 31 I=1,4
04956 31 QQ(I)=QQ(I)-PR(I)*QQPKS/PKSD
04957 C AMPLITUDE
04958 PRODPQ=PT(4)*QQ(4)
04959 PRODNQ=PN(4)*QQ(4)-PN(1)*QQ(1)-PN(2)*QQ(2)-PN(3)*QQ(3)
04960 PRODPN=PT(4)*PN(4)
04961 QQ2= QQ(4)**2-QQ(1)**2-QQ(2)**2-QQ(3)**2
04962 BRAK=(GV**2+GA**2)*(2*PRODPQ*PRODNQ-PRODPN*QQ2)
04963 & +(GV**2-GA**2)*AMTAU*AMNUTA*QQ2
04964 AMPLIT=(GFERMI*CCABIB)**2*BRAK*2*FPIRK(AMX)
04965 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
04966 DO 40 I=1,3
04967 40 HV(I)=2*GV*GA*AMTAU*(2*PRODNQ*QQ(I)-QQ2*PN(I))/BRAK
04968 do 77 k=1,4
04969 pmult(k,1)=pkc(k)
04970 pmult(k,2)=pkz(k)
04971 77 continue
04972 RETURN
04973 END
04974 FUNCTION FPIRK(W)
04975 C ----------------------------------------------------------
04976 c square of pion form factor
04977 C ----------------------------------------------------------
04978 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04979 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04980 * ,AMK,AMKZ,AMKST,GAMKST
04981 C
04982 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04983 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04984 * ,AMK,AMKZ,AMKST,GAMKST
04985 c COMPLEX FPIKMK
04986 COMPLEX FPIKM
04987 FPIRK=CABS(FPIKM(W,AMK,AMKZ))**2
04988 c FPIRK=CABS(FPIKMK(W,AMK,AMKZ))**2
04989 END
04990 COMPLEX FUNCTION FPIKMK(W,XM1,XM2)
04991 C **********************************************************
04992 C Kaon form factor
04993 C **********************************************************
04994 COMPLEX BWIGM
04995 REAL ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
04996 EXTERNAL BWIG
04997 DATA INIT /0/
04998 C
04999 C ------------ PARAMETERS --------------------
05000 IF (INIT.EQ.0 ) THEN
05001 INIT=1
05002 PI=3.141592654
05003 PIM=.140
05004 ROM=0.773
05005 ROG=0.145
05006 ROM1=1.570
05007 ROG1=0.510
05008 c BETA1=-0.111
05009 BETA1=-0.221
05010 ENDIF
05011 C -----------------------------------------------
05012 S=W**2
05013 FPIKMK=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2))
05014 & /(1+BETA1)
05015 RETURN
05016 END
05017 SUBROUTINE RESLUX
05018 C ****************
05019 C INITIALIZE LUND COMMON
05020 #if defined (CLEO)
05021 #else
05022 PARAMETER (NMXHEP=2000)
05023 COMMON/HEPEVTX/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
05024 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
05025 SAVE /HEPEVTx/
05026 #endif
05027 NHEP=0
05028 END
05029 SUBROUTINE DWRPH(KTO,PHX)
05030 C
05031 C -------------------------
05032 C
05033 IMPLICIT REAL*8 (A-H,O-Z)
05034 REAL*4 PHX(4)
05035 REAL*4 QHOT(4)
05036 C
05037 DO 9 K=1,4
05038 QHOT(K) =0.0
05039 9 CONTINUE
05040 C CASE OF TAU RADIATIVE DECAYS.
05041 C FILLING OF THE LUND COMMON BLOCK.
05042 DO 1002 I=1,4
05043 1002 QHOT(I)=PHX(I)
05044 IF (QHOT(4).GT.1.E-5) CALL DWLUPH(KTO,QHOT)
05045 RETURN
05046 END
05047 SUBROUTINE DWLUPH(KTO,PHOT)
05048 C---------------------------------------------------------------------
05049 C Lorentz transformation to CMsystem and
05050 C Updating of HEPEVT record
05051 C
05052 C called by : DEXAY1,(DEKAY1,DEKAY2)
05053 C
05054 C used when radiative corrections in decays are generated
05055 C---------------------------------------------------------------------
05056 C
05057 #if defined (ALEPH)
05058 COMMON /TAUPOS/ NP1,NP2
05059 #else
05060 #endif
05061 REAL PHOT(4)
05062 #if defined (ALEPH)
05063 #else
05064 COMMON /TAUPOS/ NP1,NP2
05065 #endif
05066 C
05067 C check energy
05068 IF (PHOT(4).LE.0.0) RETURN
05069 C
05070 C position of decaying particle:
05071 IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
05072 NPS=NP1
05073 ELSE
05074 NPS=NP2
05075 ENDIF
05076 C
05077 KTOS=KTO
05078 IF(KTOS.GT.10) KTOS=KTOS-10
05079 C boost and append photon (gamma is 22)
05080 CALL TRALO4(KTOS,PHOT,PHOT,AM)
05081 CALL FILHEP(0,1,22,NPS,NPS,0,0,PHOT,0.0,.TRUE.)
05082 C
05083 RETURN
05084 END
05085
05086 SUBROUTINE DWLUEL(KTO,ISGN,PNU,PWB,PEL,PNE)
05087 C ----------------------------------------------------------------------
05088 C Lorentz transformation to CMsystem and
05089 C Updating of HEPEVT record
05090 C
05091 C ISGN = 1/-1 for tau-/tau+
05092 C
05093 C called by : DEXAY,(DEKAY1,DEKAY2)
05094 C ----------------------------------------------------------------------
05095 C
05096 #if defined (ALEPH)
05097 COMMON /TAUPOS/ NP1,NP2
05098 #else
05099 #endif
05100 REAL PNU(4),PWB(4),PEL(4),PNE(4)
05101 #if defined (ALEPH)
05102 #else
05103 COMMON /TAUPOS/ NP1,NP2
05104 #endif
05105 C
05106 C position of decaying particle:
05107 IF(KTO.EQ. 1) THEN
05108 NPS=NP1
05109 ELSE
05110 NPS=NP2
05111 ENDIF
05112 C
05113 C tau neutrino (nu_tau is 16)
05114 CALL TRALO4(KTO,PNU,PNU,AM)
05115 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05116 C
05117 C W boson (W+ is 24)
05118 CALL TRALO4(KTO,PWB,PWB,AM)
05119 C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
05120 C
05121 C electron (e- is 11)
05122 CALL TRALO4(KTO,PEL,PEL,AM)
05123 CALL FILHEP(0,1,11*ISGN,NPS,NPS,0,0,PEL,AM,.FALSE.)
05124 C
05125 C anti electron neutrino (nu_e is 12)
05126 CALL TRALO4(KTO,PNE,PNE,AM)
05127 CALL FILHEP(0,1,-12*ISGN,NPS,NPS,0,0,PNE,AM,.TRUE.)
05128 C
05129 RETURN
05130 END
05131 SUBROUTINE DWLUMU(KTO,ISGN,PNU,PWB,PMU,PNM)
05132 C ----------------------------------------------------------------------
05133 C Lorentz transformation to CMsystem and
05134 C Updating of HEPEVT record
05135 C
05136 C ISGN = 1/-1 for tau-/tau+
05137 C
05138 C called by : DEXAY,(DEKAY1,DEKAY2)
05139 C ----------------------------------------------------------------------
05140 C
05141 #if defined (ALEPH)
05142 COMMON /TAUPOS/ NP1,NP2
05143 #else
05144 #endif
05145 REAL PNU(4),PWB(4),PMU(4),PNM(4)
05146 #if defined (ALEPH)
05147 #else
05148 COMMON /TAUPOS/ NP1,NP2
05149 #endif
05150 C
05151 C position of decaying particle:
05152 IF(KTO.EQ. 1) THEN
05153 NPS=NP1
05154 ELSE
05155 NPS=NP2
05156 ENDIF
05157 C
05158 C tau neutrino (nu_tau is 16)
05159 CALL TRALO4(KTO,PNU,PNU,AM)
05160 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05161 C
05162 C W boson (W+ is 24)
05163 CALL TRALO4(KTO,PWB,PWB,AM)
05164 C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
05165 C
05166 C muon (mu- is 13)
05167 CALL TRALO4(KTO,PMU,PMU,AM)
05168 CALL FILHEP(0,1,13*ISGN,NPS,NPS,0,0,PMU,AM,.FALSE.)
05169 C
05170 C anti muon neutrino (nu_mu is 14)
05171 CALL TRALO4(KTO,PNM,PNM,AM)
05172 CALL FILHEP(0,1,-14*ISGN,NPS,NPS,0,0,PNM,AM,.TRUE.)
05173 C
05174 RETURN
05175 END
05176 SUBROUTINE DWLUPI(KTO,ISGN,PPI,PNU)
05177 C ----------------------------------------------------------------------
05178 C Lorentz transformation to CMsystem and
05179 C Updating of HEPEVT record
05180 C
05181 C ISGN = 1/-1 for tau-/tau+
05182 C
05183 C called by : DEXAY,(DEKAY1,DEKAY2)
05184 C ----------------------------------------------------------------------
05185 C
05186 REAL PNU(4),PPI(4)
05187 COMMON /TAUPOS/ NP1,NP2
05188 C
05189 C position of decaying particle:
05190 IF(KTO.EQ. 1) THEN
05191 NPS=NP1
05192 ELSE
05193 NPS=NP2
05194 ENDIF
05195 C
05196 C tau neutrino (nu_tau is 16)
05197 CALL TRALO4(KTO,PNU,PNU,AM)
05198 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05199 C
05200 C charged pi meson (pi+ is 211)
05201 CALL TRALO4(KTO,PPI,PPI,AM)
05202 CALL FILHEP(0,1,-211*ISGN,NPS,NPS,0,0,PPI,AM,.TRUE.)
05203 C
05204 RETURN
05205 END
05206 SUBROUTINE DWLURO(KTO,ISGN,PNU,PRHO,PIC,PIZ)
05207 C ----------------------------------------------------------------------
05208 C Lorentz transformation to CMsystem and
05209 C Updating of HEPEVT record
05210 C
05211 C ISGN = 1/-1 for tau-/tau+
05212 C
05213 C called by : DEXAY,(DEKAY1,DEKAY2)
05214 C ----------------------------------------------------------------------
05215 C
05216 #if defined (ALEPH)
05217 COMMON /TAUPOS/ NP1,NP2
05218 #else
05219 #endif
05220 REAL PNU(4),PRHO(4),PIC(4),PIZ(4)
05221 #if defined (ALEPH)
05222 #else
05223 COMMON /TAUPOS/ NP1,NP2
05224 #endif
05225 C
05226 C position of decaying particle:
05227 IF(KTO.EQ. 1) THEN
05228 NPS=NP1
05229 ELSE
05230 NPS=NP2
05231 ENDIF
05232 C
05233 C tau neutrino (nu_tau is 16)
05234 CALL TRALO4(KTO,PNU,PNU,AM)
05235 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05236 C
05237 C charged rho meson (rho+ is 213)
05238 CALL TRALO4(KTO,PRHO,PRHO,AM)
05239 CALL FILHEP(0,2,-213*ISGN,NPS,NPS,0,0,PRHO,AM,.TRUE.)
05240 C
05241 C charged pi meson (pi+ is 211)
05242 CALL TRALO4(KTO,PIC,PIC,AM)
05243 CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PIC,AM,.TRUE.)
05244 C
05245 C pi0 meson (pi0 is 111)
05246 CALL TRALO4(KTO,PIZ,PIZ,AM)
05247 CALL FILHEP(0,1,111,-2,-2,0,0,PIZ,AM,.TRUE.)
05248 C
05249 RETURN
05250 END
05251 SUBROUTINE DWLUAA(KTO,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
05252 C ----------------------------------------------------------------------
05253 C Lorentz transformation to CMsystem and
05254 C Updating of HEPEVT record
05255 C
05256 C ISGN = 1/-1 for tau-/tau+
05257 C JAA = 1 (2) FOR A_1- DECAY TO PI+ 2PI- (PI- 2PI0)
05258 C
05259 C called by : DEXAY,(DEKAY1,DEKAY2)
05260 C ----------------------------------------------------------------------
05261 C
05262 #if defined (ALEPH)
05263 COMMON /TAUPOS/ NP1,NP2
05264 #else
05265 #endif
05266 REAL PNU(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
05267 #if defined (ALEPH)
05268 #else
05269 COMMON /TAUPOS/ NP1,NP2
05270 #endif
05271 C
05272 C position of decaying particle:
05273 IF(KTO.EQ. 1) THEN
05274 NPS=NP1
05275 ELSE
05276 NPS=NP2
05277 ENDIF
05278 C
05279 C tau neutrino (nu_tau is 16)
05280 CALL TRALO4(KTO,PNU,PNU,AM)
05281 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05282 C
05283 C charged a_1 meson (a_1+ is 20213)
05284 CALL TRALO4(KTO,PAA,PAA,AM)
05285 CALL FILHEP(0,1,-20213*ISGN,NPS,NPS,0,0,PAA,AM,.TRUE.)
05286 C
05287 C two possible decays of the charged a1 meson
05288 IF(JAA.EQ.1) THEN
05289 C
05290 C A1 --> PI+ PI- PI- (or charged conjugate)
05291 C
05292 C pi minus (or c.c.) (pi+ is 211)
05293 CALL TRALO4(KTO,PIM2,PIM2,AM)
05294 CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PIM2,AM,.TRUE.)
05295 C
05296 C pi minus (or c.c.) (pi+ is 211)
05297 CALL TRALO4(KTO,PIM1,PIM1,AM)
05298 CALL FILHEP(0,1,-211*ISGN,-2,-2,0,0,PIM1,AM,.TRUE.)
05299 C
05300 C pi plus (or c.c.) (pi+ is 211)
05301 CALL TRALO4(KTO,PIPL,PIPL,AM)
05302 CALL FILHEP(0,1, 211*ISGN,-3,-3,0,0,PIPL,AM,.TRUE.)
05303 C
05304 ELSE IF (JAA.EQ.2) THEN
05305 C
05306 C A1 --> PI- PI0 PI0 (or charged conjugate)
05307 C
05308 C pi zero (pi0 is 111)
05309 CALL TRALO4(KTO,PIM2,PIM2,AM)
05310 CALL FILHEP(0,1,111,-1,-1,0,0,PIM2,AM,.TRUE.)
05311 C
05312 C pi zero (pi0 is 111)
05313 CALL TRALO4(KTO,PIM1,PIM1,AM)
05314 CALL FILHEP(0,1,111,-2,-2,0,0,PIM1,AM,.TRUE.)
05315 C
05316 C pi minus (or c.c.) (pi+ is 211)
05317 CALL TRALO4(KTO,PIPL,PIPL,AM)
05318 CALL FILHEP(0,1,-211*ISGN,-3,-3,0,0,PIPL,AM,.TRUE.)
05319 C
05320 ENDIF
05321 C
05322 RETURN
05323 END
05324 SUBROUTINE DWLUKK (KTO,ISGN,PKK,PNU)
05325 C ----------------------------------------------------------------------
05326 C Lorentz transformation to CMsystem and
05327 C Updating of HEPEVT record
05328 C
05329 C ISGN = 1/-1 for tau-/tau+
05330 C
05331 C ----------------------------------------------------------------------
05332 C
05333 REAL PKK(4),PNU(4)
05334 COMMON /TAUPOS/ NP1,NP2
05335 C
05336 C position of decaying particle
05337 #if defined (ALEPH)
05338 IF(KTO.EQ. 1) THEN
05339 #else
05340 IF (KTO.EQ.1) THEN
05341 #endif
05342 NPS=NP1
05343 ELSE
05344 NPS=NP2
05345 ENDIF
05346 C
05347 C tau neutrino (nu_tau is 16)
05348 CALL TRALO4 (KTO,PNU,PNU,AM)
05349 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05350 C
05351 C K meson (K+ is 321)
05352 CALL TRALO4 (KTO,PKK,PKK,AM)
05353 CALL FILHEP(0,1,-321*ISGN,NPS,NPS,0,0,PKK,AM,.TRUE.)
05354 C
05355 RETURN
05356 END
05357 SUBROUTINE DWLUKS(KTO,ISGN,PNU,PKS,PKK,PPI,JKST)
05358 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
05359 REAL*4 BRA1,BRK0,BRK0B,BRKS
05360 #if defined (ALEPH)
05361 COMMON /TAUPOS/ NP1,NP2
05362 REAL*4 XIO(1)
05363 #endif
05364 C ----------------------------------------------------------------------
05365 C Lorentz transformation to CMsystem and
05366 C Updating of HEPEVT record
05367 C
05368 C ISGN = 1/-1 for tau-/tau+
05369 C JKST=10 (20) corresponds to K0B pi- (K- pi0) decay
05370 C
05371 C ----------------------------------------------------------------------
05372 C
05373 #if defined (ALEPH)
05374 REAL PNU(4),PKS(4),PKK(4),PPI(4)
05375 #else
05376 REAL PNU(4),PKS(4),PKK(4),PPI(4),XIO(1)
05377 COMMON /TAUPOS/ NP1,NP2
05378 #endif
05379 C
05380 C position of decaying particle
05381 IF(KTO.EQ. 1) THEN
05382 NPS=NP1
05383 ELSE
05384 NPS=NP2
05385 ENDIF
05386 C
05387 C tau neutrino (nu_tau is 16)
05388 CALL TRALO4(KTO,PNU,PNU,AM)
05389 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05390 C
05391 C charged K* meson (K*+ is 323)
05392 CALL TRALO4(KTO,PKS,PKS,AM)
05393 CALL FILHEP(0,1,-323*ISGN,NPS,NPS,0,0,PKS,AM,.TRUE.)
05394 C
05395 C two possible decay modes of charged K*
05396 IF(JKST.EQ.10) THEN
05397 C
05398 C K*- --> pi- K0B (or charged conjugate)
05399 C
05400 C charged pi meson (pi+ is 211)
05401 CALL TRALO4(KTO,PPI,PPI,AM)
05402 CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PPI,AM,.TRUE.)
05403 C
05404 BRAN=BRK0B
05405 IF (ISGN.EQ.-1) BRAN=BRK0
05406 C K0 --> K0_long (is 130) / K0_short (is 310) = 1/1
05407 CALL RANMAR(XIO,1)
05408 IF(XIO(1).GT.BRAN) THEN
05409 K0TYPE = 130
05410 ELSE
05411 K0TYPE = 310
05412 ENDIF
05413 C
05414 CALL TRALO4(KTO,PKK,PKK,AM)
05415 CALL FILHEP(0,1,K0TYPE,-2,-2,0,0,PKK,AM,.TRUE.)
05416 C
05417 ELSE IF(JKST.EQ.20) THEN
05418 C
05419 C K*- --> pi0 K-
05420 C
05421 C pi zero (pi0 is 111)
05422 CALL TRALO4(KTO,PPI,PPI,AM)
05423 CALL FILHEP(0,1,111,-1,-1,0,0,PPI,AM,.TRUE.)
05424 C
05425 C charged K meson (K+ is 321)
05426 CALL TRALO4(KTO,PKK,PKK,AM)
05427 CALL FILHEP(0,1,-321*ISGN,-2,-2,0,0,PKK,AM,.TRUE.)
05428 C
05429 ENDIF
05430 C
05431 RETURN
05432 END
05433 SUBROUTINE DWLNEW(KTO,ISGN,PNU,PWB,PNPI,MODE)
05434 C ----------------------------------------------------------------------
05435 C Lorentz transformation to CMsystem and
05436 C Updating of HEPEVT record
05437 C
05438 C ISGN = 1/-1 for tau-/tau+
05439 C
05440 C called by : DEXAY,(DEKAY1,DEKAY2)
05441 C ----------------------------------------------------------------------
05442 C
05443 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
05444 #if defined (ALEPH)
05445 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
05446 #else
05447 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
05448 #endif
05449 & ,NAMES
05450 COMMON /TAUPOS/ NP1,NP2
05451 CHARACTER NAMES(NMODE)*31
05452 REAL PNU(4),PWB(4),PNPI(4,9)
05453 REAL PPI(4)
05454 C
05455 JNPI=MODE-7
05456 C position of decaying particle
05457 IF(KTO.EQ. 1) THEN
05458 NPS=NP1
05459 ELSE
05460 NPS=NP2
05461 ENDIF
05462 C
05463 C tau neutrino (nu_tau is 16)
05464 CALL TRALO4(KTO,PNU,PNU,AM)
05465 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05466 C
05467 C W boson (W+ is 24)
05468 CALL TRALO4(KTO,PWB,PWB,AM)
05469 CALL FILHEP(0,1,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
05470 C
05471 C multi pi mode JNPI
05472 C
05473 C get multiplicity of mode JNPI
05474 ND=MULPIK(JNPI)
05475 DO I=1,ND
05476 #if defined (ALEPH)
05477 cam KFPI=LUNPIK(IDFFIN(I,JNPI),-ISGN)
05478 KFPI=LUNPIK(IDFFIN(I,JNPI), ISGN)
05479 #else
05480 KFPI=LUNPIK(IDFFIN(I,JNPI),-ISGN)
05481 #endif
05482 C for charged conjugate case, change charged pions only
05483 C IF(KFPI.NE.111)KFPI=KFPI*ISGN
05484 DO J=1,4
05485 PPI(J)=PNPI(J,I)
05486 END DO
05487 CALL TRALO4(KTO,PPI,PPI,AM)
05488 CALL FILHEP(0,1,KFPI,-I,-I,0,0,PPI,AM,.TRUE.)
05489 END DO
05490 C
05491 RETURN
05492 END
05493 #if defined (CePeCe)
05494 #else
05495 #endif
05496 FUNCTION AMAST(PP)
05497 C ----------------------------------------------------------------------
05498 C CALCULATES MASS OF PP (DOUBLE PRECISION)
05499 C
05500 C USED BY : RADKOR
05501 C ----------------------------------------------------------------------
05502 IMPLICIT REAL*8 (A-H,O-Z)
05503 REAL*8 PP(4)
05504 AAA=PP(4)**2-PP(3)**2-PP(2)**2-PP(1)**2
05505 C
05506 IF(AAA.NE.0.0) AAA=AAA/SQRT(ABS(AAA))
05507 AMAST=AAA
05508 RETURN
05509 END
05510 FUNCTION AMAS4(PP)
05511 C ******************
05512 C ----------------------------------------------------------------------
05513 C CALCULATES MASS OF PP
05514 C
05515 C USED BY :
05516 C ----------------------------------------------------------------------
05517 REAL PP(4)
05518 AAA=PP(4)**2-PP(3)**2-PP(2)**2-PP(1)**2
05519 IF(AAA.NE.0.0) AAA=AAA/SQRT(ABS(AAA))
05520 AMAS4=AAA
05521 RETURN
05522 END
05523 FUNCTION ANGXY(X,Y)
05524 C ----------------------------------------------------------------------
05525 C
05526 C USED BY : KORALZ RADKOR
05527 C ----------------------------------------------------------------------
05528 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05529 DATA PI /3.141592653589793238462643D0/
05530 C
05531 IF(ABS(Y).LT.ABS(X)) THEN
05532 THE=ATAN(ABS(Y/X))
05533 IF(X.LE.0D0) THE=PI-THE
05534 ELSE
05535 THE=ACOS(X/SQRT(X**2+Y**2))
05536 ENDIF
05537 ANGXY=THE
05538 RETURN
05539 END
05540 FUNCTION ANGFI(X,Y)
05541 C ----------------------------------------------------------------------
05542 * CALCULATES ANGLE IN (0,2*PI) RANGE OUT OF X-Y
05543 C
05544 C USED BY : KORALZ RADKOR
05545 C ----------------------------------------------------------------------
05546 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05547 DATA PI /3.141592653589793238462643D0/
05548 C
05549 IF(ABS(Y).LT.ABS(X)) THEN
05550 THE=ATAN(ABS(Y/X))
05551 IF(X.LE.0D0) THE=PI-THE
05552 ELSE
05553 THE=ACOS(X/SQRT(X**2+Y**2))
05554 ENDIF
05555 IF(Y.LT.0D0) THE=2D0*PI-THE
05556 ANGFI=THE
05557 END
05558 SUBROUTINE ROTOD1(PH1,PVEC,QVEC)
05559 C ----------------------------------------------------------------------
05560 C
05561 C USED BY : KORALZ
05562 C ----------------------------------------------------------------------
05563 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05564 DIMENSION PVEC(4),QVEC(4),RVEC(4)
05565 C
05566 PHI=PH1
05567 CS=COS(PHI)
05568 SN=SIN(PHI)
05569 DO 10 I=1,4
05570 10 RVEC(I)=PVEC(I)
05571 QVEC(1)=RVEC(1)
05572 QVEC(2)= CS*RVEC(2)-SN*RVEC(3)
05573 QVEC(3)= SN*RVEC(2)+CS*RVEC(3)
05574 QVEC(4)=RVEC(4)
05575 RETURN
05576 END
05577 SUBROUTINE ROTOD2(PH1,PVEC,QVEC)
05578 C ----------------------------------------------------------------------
05579 C
05580 C USED BY : KORALZ RADKOR
05581 C ----------------------------------------------------------------------
05582 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05583 DIMENSION PVEC(4),QVEC(4),RVEC(4)
05584 C
05585 PHI=PH1
05586 CS=COS(PHI)
05587 SN=SIN(PHI)
05588 DO 10 I=1,4
05589 10 RVEC(I)=PVEC(I)
05590 QVEC(1)= CS*RVEC(1)+SN*RVEC(3)
05591 QVEC(2)=RVEC(2)
05592 QVEC(3)=-SN*RVEC(1)+CS*RVEC(3)
05593 QVEC(4)=RVEC(4)
05594 RETURN
05595 END
05596 SUBROUTINE ROTOD3(PH1,PVEC,QVEC)
05597 C ----------------------------------------------------------------------
05598 C
05599 C USED BY : KORALZ RADKOR
05600 C ----------------------------------------------------------------------
05601 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05602 C
05603 DIMENSION PVEC(4),QVEC(4),RVEC(4)
05604 PHI=PH1
05605 CS=COS(PHI)
05606 SN=SIN(PHI)
05607 DO 10 I=1,4
05608 10 RVEC(I)=PVEC(I)
05609 QVEC(1)= CS*RVEC(1)-SN*RVEC(2)
05610 QVEC(2)= SN*RVEC(1)+CS*RVEC(2)
05611 QVEC(3)=RVEC(3)
05612 QVEC(4)=RVEC(4)
05613 END
05614 SUBROUTINE BOSTR3(EXE,PVEC,QVEC)
05615 C ----------------------------------------------------------------------
05616 C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
05617 C
05618 C USED BY : TAUOLA KORALZ (?)
05619 C ----------------------------------------------------------------------
05620 REAL*4 PVEC(4),QVEC(4),RVEC(4)
05621 C
05622 DO 10 I=1,4
05623 10 RVEC(I)=PVEC(I)
05624 RPL=RVEC(4)+RVEC(3)
05625 RMI=RVEC(4)-RVEC(3)
05626 QPL=RPL*EXE
05627 QMI=RMI/EXE
05628 QVEC(1)=RVEC(1)
05629 QVEC(2)=RVEC(2)
05630 QVEC(3)=(QPL-QMI)/2
05631 QVEC(4)=(QPL+QMI)/2
05632 END
05633 SUBROUTINE BOSTD3(EXE,PVEC,QVEC)
05634 C ----------------------------------------------------------------------
05635 C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
05636 C
05637 C USED BY : KORALZ RADKOR
05638 C ----------------------------------------------------------------------
05639 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05640 DIMENSION PVEC(4),QVEC(4),RVEC(4)
05641 C
05642 DO 10 I=1,4
05643 10 RVEC(I)=PVEC(I)
05644 RPL=RVEC(4)+RVEC(3)
05645 RMI=RVEC(4)-RVEC(3)
05646 QPL=RPL*EXE
05647 QMI=RMI/EXE
05648 QVEC(1)=RVEC(1)
05649 QVEC(2)=RVEC(2)
05650 QVEC(3)=(QPL-QMI)/2
05651 QVEC(4)=(QPL+QMI)/2
05652 RETURN
05653 END
05654 SUBROUTINE ROTOR1(PH1,PVEC,QVEC)
05655 C ----------------------------------------------------------------------
05656 C
05657 C called by :
05658 C ----------------------------------------------------------------------
05659 REAL*4 PVEC(4),QVEC(4),RVEC(4)
05660 C
05661 PHI=PH1
05662 CS=COS(PHI)
05663 SN=SIN(PHI)
05664 DO 10 I=1,4
05665 10 RVEC(I)=PVEC(I)
05666 QVEC(1)=RVEC(1)
05667 QVEC(2)= CS*RVEC(2)-SN*RVEC(3)
05668 QVEC(3)= SN*RVEC(2)+CS*RVEC(3)
05669 QVEC(4)=RVEC(4)
05670 END
05671 SUBROUTINE ROTOR2(PH1,PVEC,QVEC)
05672 C ----------------------------------------------------------------------
05673 C
05674 C USED BY : TAUOLA
05675 C ----------------------------------------------------------------------
05676 IMPLICIT REAL*4(A-H,O-Z)
05677 REAL*4 PVEC(4),QVEC(4),RVEC(4)
05678 C
05679 PHI=PH1
05680 CS=COS(PHI)
05681 SN=SIN(PHI)
05682 DO 10 I=1,4
05683 10 RVEC(I)=PVEC(I)
05684 QVEC(1)= CS*RVEC(1)+SN*RVEC(3)
05685 QVEC(2)=RVEC(2)
05686 QVEC(3)=-SN*RVEC(1)+CS*RVEC(3)
05687 QVEC(4)=RVEC(4)
05688 END
05689 SUBROUTINE ROTOR3(PHI,PVEC,QVEC)
05690 C ----------------------------------------------------------------------
05691 C
05692 C USED BY : TAUOLA
05693 C ----------------------------------------------------------------------
05694 REAL*4 PVEC(4),QVEC(4),RVEC(4)
05695 C
05696 CS=COS(PHI)
05697 SN=SIN(PHI)
05698 DO 10 I=1,4
05699 10 RVEC(I)=PVEC(I)
05700 QVEC(1)= CS*RVEC(1)-SN*RVEC(2)
05701 QVEC(2)= SN*RVEC(1)+CS*RVEC(2)
05702 QVEC(3)=RVEC(3)
05703 QVEC(4)=RVEC(4)
05704 END
05705 SUBROUTINE SPHERD(R,X)
05706 C ----------------------------------------------------------------------
05707 C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
05708 C DOUBLE PRECISON VERSION OF SPHERA
05709 C ----------------------------------------------------------------------
05710 REAL*8 R,X(4),PI,COSTH,SINTH
05711 REAL*4 RRR(2)
05712 DATA PI /3.141592653589793238462643D0/
05713 C
05714 CALL RANMAR(RRR,2)
05715 COSTH=-1+2*RRR(1)
05716 SINTH=SQRT(1 -COSTH**2)
05717 X(1)=R*SINTH*COS(2*PI*RRR(2))
05718 X(2)=R*SINTH*SIN(2*PI*RRR(2))
05719 X(3)=R*COSTH
05720 RETURN
05721 END
05722 SUBROUTINE ROTPOX(THET,PHI,PP)
05723 IMPLICIT REAL*8 (A-H,O-Z)
05724 C ----------------------------------------------------------------------
05725 #if defined (ALEPH)
05726 C double precison version of ROTPOL
05727 #else
05728 C
05729 #endif
05730 C ----------------------------------------------------------------------
05731 DIMENSION PP(4)
05732 C
05733 CALL ROTOD2(THET,PP,PP)
05734 CALL ROTOD3( PHI,PP,PP)
05735 RETURN
05736 END
05737 SUBROUTINE SPHERA(R,X)
05738 C ----------------------------------------------------------------------
05739 C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
05740 C
05741 C called by : DPHSxx,DADMPI,DADMKK
05742 C ----------------------------------------------------------------------
05743 REAL X(4)
05744 REAL*4 RRR(2)
05745 DATA PI /3.141592653589793238462643/
05746 C
05747 CALL RANMAR(RRR,2)
05748 COSTH=-1.+2.*RRR(1)
05749 SINTH=SQRT(1.-COSTH**2)
05750 X(1)=R*SINTH*COS(2*PI*RRR(2))
05751 X(2)=R*SINTH*SIN(2*PI*RRR(2))
05752 X(3)=R*COSTH
05753 RETURN
05754 END
05755 SUBROUTINE ROTPOL(THET,PHI,PP)
05756 C ----------------------------------------------------------------------
05757 C
05758 C called by : DADMAA,DPHSAA
05759 C ----------------------------------------------------------------------
05760 REAL PP(4)
05761 C
05762 CALL ROTOR2(THET,PP,PP)
05763 CALL ROTOR3( PHI,PP,PP)
05764 RETURN
05765 END
05766 #include "../randg/tauola-random.h"
05767 FUNCTION DILOGT(X)
05768 C *****************
05769 IMPLICIT REAL*8(A-H,O-Z)
05770 CERN C304 VERSION 29/07/71 DILOG 59 C
05771 Z=-1.64493406684822
05772 IF(X .LT.-1.0) GO TO 1
05773 IF(X .LE. 0.5) GO TO 2
05774 IF(X .EQ. 1.0) GO TO 3
05775 IF(X .LE. 2.0) GO TO 4
05776 Z=3.2898681336964
05777 1 T=1.0/X
05778 S=-0.5
05779 Z=Z-0.5* LOG(ABS(X))**2
05780 GO TO 5
05781 2 T=X
05782 S=0.5
05783 Z=0.
05784 GO TO 5
05785 3 DILOGT=1.64493406684822
05786 RETURN
05787 4 T=1.0-X
05788 S=-0.5
05789 Z=1.64493406684822 - LOG(X)* LOG(ABS(T))
05790 5 Y=2.66666666666666 *T+0.66666666666666
05791 B= 0.00000 00000 00001
05792 A=Y*B +0.00000 00000 00004
05793 B=Y*A-B+0.00000 00000 00011
05794 A=Y*B-A+0.00000 00000 00037
05795 B=Y*A-B+0.00000 00000 00121
05796 A=Y*B-A+0.00000 00000 00398
05797 B=Y*A-B+0.00000 00000 01312
05798 A=Y*B-A+0.00000 00000 04342
05799 B=Y*A-B+0.00000 00000 14437
05800 A=Y*B-A+0.00000 00000 48274
05801 B=Y*A-B+0.00000 00001 62421
05802 A=Y*B-A+0.00000 00005 50291
05803 B=Y*A-B+0.00000 00018 79117
05804 A=Y*B-A+0.00000 00064 74338
05805 B=Y*A-B+0.00000 00225 36705
05806 A=Y*B-A+0.00000 00793 87055
05807 B=Y*A-B+0.00000 02835 75385
05808 A=Y*B-A+0.00000 10299 04264
05809 B=Y*A-B+0.00000 38163 29463
05810 A=Y*B-A+0.00001 44963 00557
05811 B=Y*A-B+0.00005 68178 22718
05812 A=Y*B-A+0.00023 20021 96094
05813 B=Y*A-B+0.00100 16274 96164
05814 A=Y*B-A+0.00468 63619 59447
05815 B=Y*A-B+0.02487 93229 24228
05816 A=Y*B-A+0.16607 30329 27855
05817 A=Y*A-B+1.93506 43008 6996
05818 DILOGT=S*T*(A-B)+Z
05819 RETURN
05820 C=======================================================================
05821 C===================END OF CPC PART ====================================
05822 C=======================================================================
05823 END
05824
05825 C-----------------------------------------------------------------------
05826 C Initialize RChL Currents
05827 C Dummy routine for compatibility with new updates of TAUOLA
05828 C
05829 C Added 25.Jul.2012
05830 C-----------------------------------------------------------------------
05831 SUBROUTINE INIRCHL(FLAG)
05832 INTEGER FLAG
05833
05834 IF(FLAG.NE.0) THEN
05835 WRITE(*,25) FLAG
05836 25 FORMAT(1X, "TAUOLA IniRChL: Fatal error, FLAG=",I2," but RChL currents missing")
05837 WRITE(*,*) " in loaded version of TAUOLA-FORTRAN library."
05838 STOP
05839 ENDIF
05840
05841 RETURN
05842 END
