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.5 ******** *
00011 C **************DECEMBER 1993****************** *
00012 #else
00013 C *********TAUOLA LIBRARY: VERSION 2.6 ******** *
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.5 ******',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.6 ******',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.6 ******',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.5 ******',9X,1H*,
00258 $ /,' *', 25X,'***********DECEMBER 1993***************',9X,1H*,
00259 #else
00260 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.6 ******',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.5 ******',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.6 ******',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.6 ******',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.5 ******',9X,1H*,
00653 $ /,' *', 25X,'***********DECEMBER 1993***************',9X,1H*,
00654 #else
00655 $ /,' *', 25X,'*****TAUOLA LIBRARY: VERSION 2.6 ******',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 WE INCLUDE REMAINING PART OF THE JACOBIAN
04410 C --- FLAT CHANNEL
04411 AM3SQ=(PIM1(4)+PIZ(4)+PIPL(4))**2-(PIM1(3)+PIZ(3)+PIPL(3))**2
04412 $ -(PIM1(2)+PIZ(2)+PIPL(2))**2-(PIM1(1)+PIZ(1)+PIPL(1))**2
04413 AMS2=(AM4-AMP2)**2
04414 AMS1=(AMP1+AMP3+AMP4)**2
04415 FF1=(AMS2-AMS1)
04416 AMS1=(AMP3+AMP4)**2
04417 AMS2=(SQRT(AM3SQ)-AMP1)**2
04418 FF2=AMS2-AMS1
04419 FF3=(4*PI)*(XLAM(AM2**2,AMP1**2,AM3SQ)/AM3SQ)
04420 FF4=(4*PI)*(XLAM(AM3SQ,AMP2**2,AM4**2)/AM4**2)
04421 UU=FF1*FF2*FF3*FF4
04422 C --- FIRST CHANNEL
04423 AM3SQ=(PIM1(4)+PIZ(4)+PIPL(4))**2-(PIM1(3)+PIZ(3)+PIPL(3))**2
04424 $ -(PIM1(2)+PIZ(2)+PIPL(2))**2-(PIM1(1)+PIZ(1)+PIPL(1))**2
04425 AMS2=(AM4-AMP2)**2
04426 AMS1=(AMP1+AMP3+AMP4)**2
04427 ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
04428 ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
04429 FF1=((AM3SQ-AMRX**2)**2+(AMRX*GAMRX)**2)/(AMRX*GAMRX)
04430 FF1=FF1*(ALP2-ALP1)
04431 AMS1=(AMP3+AMP4)**2
04432 AMS2=(SQRT(AM3SQ)-AMP1)**2
04433 FF2=AMS2-AMS1
04434 FF3=(4*PI)*(XLAM(AM2**2,AMP1**2,AM3SQ)/AM3SQ)
04435 FF4=(4*PI)*(XLAM(AM3SQ,AMP2**2,AM4**2)/AM4**2)
04436 FF=FF1*FF2*FF3*FF4
04437 C --- SECOND CHANNEL
04438 AM3SQ=(PIM2(4)+PIZ(4)+PIPL(4))**2-(PIM2(3)+PIZ(3)+PIPL(3))**2
04439 $ -(PIM2(2)+PIZ(2)+PIPL(2))**2-(PIM2(1)+PIZ(1)+PIPL(1))**2
04440 AMS2=(AM4-AMP1)**2
04441 AMS1=(AMP2+AMP3+AMP4)**2
04442 ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
04443 ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
04444 GG1=((AM3SQ-AMRX**2)**2+(AMRX*GAMRX)**2)/(AMRX*GAMRX)
04445 GG1=GG1*(ALP2-ALP1)
04446 AMS1=(AMP3+AMP4)**2
04447 AMS2=(SQRT(AM3SQ)-AMP2)**2
04448 GG2=AMS2-AMS1
04449 GG3=(4*PI)*(XLAM(AM2**2,AMP2**2,AM3SQ)/AM3SQ)
04450 GG4=(4*PI)*(XLAM(AM3SQ,AMP1**2,AM4**2)/AM4**2)
04451 GG=GG1*GG2*GG3*GG4
04452 C --- JACOBIAN AVERAGED OVER THE TWO
04453 IF ( ( (FF+GG)*UU+FF*GG ).GT.0.0D0) THEN
04454 RR=FF*GG*UU/(0.5*PREZ*(FF+GG)*UU+(1.0-PREZ)*FF*GG)
04455 PHSPAC=PHSPAC*RR
04456 ELSE
04457 PHSPAC=0.0
04458 ENDIF
04459 * MOMENTA OF THE TWO PI-MINUS ARE RANDOMLY SYMMETRISED
04460 IF (JNPI.EQ.1) THEN
04461 RR5= RRR(5)
04462 IF(RR5.LE.0.5) THEN
04463 DO 70 I=1,4
04464 X=PIM1(I)
04465 PIM1(I)=PIM2(I)
04466 70 PIM2(I)=X
04467 ENDIF
04468 PHSPAC=PHSPAC/2.
04469 ELSE
04470 C MOMENTA OF PI0-S ARE GENERATED UNIFORMLY ONLY IF PREZ=0.0
04471 RR5= RRR(5)
04472 IF(RR5.LE.0.5) THEN
04473 DO 71 I=1,4
04474 X=PIM1(I)
04475 PIM1(I)=PIM2(I)
04476 71 PIM2(I)=X
04477 ENDIF
04478 PHSPAC=PHSPAC/6.
04479 ENDIF
04480 * ALL PIONS BOOSTED FROM 4 REST FRAME TO TAU REST FRAME
04481 * Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
04482 EXE=(PAA(4)+PAA(3))/AM4
04483 CALL BOSTR3(EXE,PIZ,PIZ)
04484 CALL BOSTR3(EXE,PIPL,PIPL)
04485 CALL BOSTR3(EXE,PIM1,PIM1)
04486 CALL BOSTR3(EXE,PIM2,PIM2)
04487 CALL BOSTR3(EXE,PR,PR)
04488 C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
04489 C CHECK ON CONSISTENCY WITH DADNPI, THEN, CODE BREAKES UNIFORM PION
04490 C DISTRIBUTION IN HADRONIC SYSTEM
04491 #if defined (ALEPH)
04492 CALL DAM4PI(JNPI,PT,PN,PIM1,PIM2,PIZ,PIPL,AMPLIT,HV)
04493 #else
04494 CAM Assume neutrino mass=0. and sum over final polarisation
04495 C AMX2=AM4**2
04496 C BRAK= 2*(AMTAU**2-AMX2) * (AMTAU**2+2.*AMX2)
04497 C AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK * AMX2*SIGEE(AMX2,1)
04498 IF (JNPI.EQ.1) THEN
04499 CALL DAM4PI(JNPI,PT,PN,PIM1,PIM2,PIZ,PIPL,AMPLIT,HV)
04500 ELSEIF (JNPI.EQ.2) THEN
04501 CALL DAM4PI(JNPI,PT,PN,PIM1,PIM2,PIPL,PIZ,AMPLIT,HV)
04502 ENDIF
04503 #endif
04504 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
04505 C PHASE SPACE CHECK
04506 C DGAMT=PHSPAC
04507 DO 77 K=1,4
04508 PMULT(K,1)=PIM1(K)
04509 PMULT(K,2)=PIM2(K)
04510 #if defined (ALEPH)
04511 PMULT(K,3)=PIZ (K)
04512 PMULT(K,4)=PIPL(K)
04513 #else
04514 PMULT(K,3)=PIPL(K)
04515 PMULT(K,4)=PIZ (K)
04516 #endif
04517 77 CONTINUE
04518 END
04519 SUBROUTINE DAM4PI(MNUM,PT,PN,PIM1,PIM2,PIM3,PIM4,AMPLIT,HV)
04520 C ----------------------------------------------------------------------
04521 * CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
04522 * FOR TAU DECAY INTO 4 PI MODES
04523 * ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
04524 * CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
04525 C MNUM DECAY MODE IDENTIFIER.
04526 C
04527 #if defined (ALEPH)
04528 C called by : DPH4PI
04529 #else
04530 C called by : DPHSAA
04531 #endif
04532 C ----------------------------------------------------------------------
04533 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04534 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04535 * ,AMK,AMKZ,AMKST,GAMKST
04536 C
04537 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04538 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04539 * ,AMK,AMKZ,AMKST,GAMKST
04540 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04541 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04542 REAL HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIM3(4),PIM4(4)
04543 REAL PIVEC(4),PIAKS(4),HVM(4)
04544 COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FORM4,FORM5
04545 EXTERNAL FORM1,FORM2,FORM3,FORM4,FORM5
04546 DATA PI /3.141592653589793238462643/
04547 DATA ICONT /0/
04548 C
04549 #if defined (CLEO)
04550 CALL CURR_CLEO(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
04551 #else
04552 CALL CURR(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
04553 #endif
04554 C
04555 * CALCULATE PI-VECTORS: VECTOR AND AXIAL
04556 CALL CLVEC(HADCUR,PN,PIVEC)
04557 CALL CLAXI(HADCUR,PN,PIAKS)
04558 CALL CLNUT(HADCUR,BRAKM,HVM)
04559 * SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
04560 BRAK= (GV**2+GA**2)*PT(4)*PIVEC(4) +2.*GV*GA*PT(4)*PIAKS(4)
04561 & +2.*(GV**2-GA**2)*AMNUTA*AMTAU*BRAKM
04562 AMPLIT=(CCABIB*GFERMI)**2*BRAK/2.
04563 C POLARIMETER VECTOR IN TAU REST FRAME
04564 DO 90 I=1,3
04565 HV(I)=-(AMTAU*((GV**2+GA**2)*PIAKS(I)+2.*GV*GA*PIVEC(I)))
04566 & +(GV**2-GA**2)*AMNUTA*AMTAU*HVM(I)
04567 C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
04568 IF (BRAK.NE.0.0)
04569 &HV(I)=-HV(I)/BRAK
04570 90 CONTINUE
04571 END
04572 SUBROUTINE DPH5PI(DGAMT,HV,PN,PAA,PMULT,JNPI)
04573 C ----------------------------------------------------------------------
04574 * IT SIMULATES 5pi DECAY IN TAU REST FRAME WITH
04575 * Z-AXIS ALONG 5pi MOMENTUM
04576 C ----------------------------------------------------------------------
04577 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04578 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04579 * ,AMK,AMKZ,AMKST,GAMKST
04580 C
04581 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04582 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04583
04584
04585 * ,AMK,AMKZ,AMKST,GAMKST
04586 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04587 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04588 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
04589 #if defined (ALEPH)
04590 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
04591 #else
04592 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
04593 #endif
04594 & ,NAMES
04595 CHARACTER NAMES(NMODE)*31
04596 REAL HV(4),PT(4),PN(4),PAA(4),PMULT(4,9)
04597 REAL*4 PR(4),PI1(4),PI2(4),PI3(4),PI4(4),PI5(4)
04598 REAL*8 AMP1,AMP2,AMP3,AMP4,AMP5,ams1,ams2,amom,gamom
04599 REAL*8 AM5SQ,AM4SQ,AM3SQ,AM2SQ,AM5,AM4,AM3
04600 REAL*4 RRR(10)
04601 REAL*8 gg1,gg2,gg3,ff1,ff2,ff3,ff4,alp,alp1,alp2
04602 #if defined (ALEPH)
04603 REAL*8 XM,AM,GAMMAB
04604 #else
04605 REAL*8 XM,AM,GAMMA
04606 ccM.S.>>>>>>
04607 real*8 phspac
04608 ccM.S.<<<<<<
04609 #endif
04610 DATA PI /3.141592653589793238462643/
04611 DATA ICONT /0/
04612 data fpi /93.3e-3/
04613 c
04614 COMPLEX BWIGN
04615 C
04616 #if defined (ALEPH)
04617 BWIGN(XM,AM,GAMMAB)=XM**2/CMPLX(XM**2-AM**2,GAMMAB*AM)
04618 #else
04619 BWIGN(XM,AM,GAMMA)=XM**2/CMPLX(XM**2-AM**2,GAMMA*AM)
04620 #endif
04621
04622 C
04623 AMOM=.782
04624 GAMOM=0.0085
04625 c
04626 C 6 BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
04627 C D**3 P /2E/(2PI)**3 (2PI)**4 DELTA4(SUM P)
04628 PHSPAC=1./2**29/PI**14
04629 c PHSPAC=1./2**5/PI**2
04630 C init 5pi decay mode (JNPI)
04631 AMP1=DCDMAS(IDFFIN(1,JNPI))
04632 AMP2=DCDMAS(IDFFIN(2,JNPI))
04633 AMP3=DCDMAS(IDFFIN(3,JNPI))
04634 AMP4=DCDMAS(IDFFIN(4,JNPI))
04635 AMP5=DCDMAS(IDFFIN(5,JNPI))
04636 c
04637 C TAU MOMENTUM
04638 PT(1)=0.
04639 PT(2)=0.
04640 PT(3)=0.
04641 PT(4)=AMTAU
04642 C
04643 CALL RANMAR(RRR,10)
04644 C
04645 c masses of 5, 4, 3 and 2 pi systems
04646 c 3 pi with sampling for omega resonance
04647 cam
04648 c mass of 5 (12345)
04649 rr1=rrr(10)
04650 ams1=(amp1+amp2+amp3+amp4+amp5)**2
04651 ams2=(amtau-amnuta)**2
04652 am5sq=ams1+ rr1*(ams2-ams1)
04653 am5 =sqrt(am5sq)
04654 phspac=phspac*(ams2-ams1)
04655 c
04656 c mass of 4 (2345)
04657 c flat phase space
04658 rr1=rrr(9)
04659 ams1=(amp2+amp3+amp4+amp5)**2
04660 ams2=(am5-amp1)**2
04661 am4sq=ams1+ rr1*(ams2-ams1)
04662 am4 =sqrt(am4sq)
04663 gg1=ams2-ams1
04664 c
04665 c mass of 3 (234)
04666 C phase space with sampling for omega resonance
04667 rr1=rrr(1)
04668 ams1=(amp2+amp3+amp4)**2
04669 ams2=(am4-amp5)**2
04670 alp1=atan((ams1-amom**2)/amom/gamom)
04671 alp2=atan((ams2-amom**2)/amom/gamom)
04672 alp=alp1+rr1*(alp2-alp1)
04673 am3sq =amom**2+amom*gamom*tan(alp)
04674 am3 =sqrt(am3sq)
04675 c --- this part of the jacobian will be recovered later ---------------
04676 gg2=((am3sq-amom**2)**2+(amom*gamom)**2)/(amom*gamom)
04677 gg2=gg2*(alp2-alp1)
04678 c flat phase space;
04679 C am3sq=ams1+ rr1*(ams2-ams1)
04680 C am3 =sqrt(am3sq)
04681 c --- this part of jacobian will be recovered later
04682 C gg2=ams2-ams1
04683 c
04684 C mass of 2 (34)
04685 rr2=rrr(2)
04686 ams1=(amp3+amp4)**2
04687 ams2=(am3-amp2)**2
04688 c flat phase space;
04689 am2sq=ams1+ rr2*(ams2-ams1)
04690 am2 =sqrt(am2sq)
04691 c --- this part of jacobian will be recovered later
04692 gg3=ams2-ams1
04693 c
04694 c (34) restframe, define pi3 and pi4
04695 enq1=(am2sq+amp3**2-amp4**2)/(2*am2)
04696 enq2=(am2sq-amp3**2+amp4**2)/(2*am2)
04697 ppi= enq1**2-amp3**2
04698 pppi=sqrt(abs(enq1**2-amp3**2))
04699 ff1=(4*pi)*(2*pppi/am2)
04700 c pi3 momentum in (34) rest frame
04701 call sphera(pppi,pi3)
04702 pi3(4)=enq1
04703 c pi4 momentum in (34) rest frame
04704 do 30 i=1,3
04705 30 pi4(i)=-pi3(i)
04706 pi4(4)=enq2
04707 c
04708 c (234) rest frame, define pi2
04709 c pr momentum
04710 pr(1)=0
04711 pr(2)=0
04712 pr(4)=1./(2*am3)*(am3**2+am2**2-amp2**2)
04713 pr(3)= sqrt(abs(pr(4)**2-am2**2))
04714 ppi = pr(4)**2-am2**2
04715 c pi2 momentum
04716 pi2(1)=0
04717 pi2(2)=0
04718 pi2(4)=1./(2*am3)*(am3**2-am2**2+amp2**2)
04719 pi2(3)=-pr(3)
04720 c --- this part of jacobian will be recovered later
04721 ff2=(4*pi)*(2*pr(3)/am3)
04722 c old pions boosted from 2 rest frame to 3 rest frame
04723 exe=(pr(4)+pr(3))/am2
04724 call bostr3(exe,pi3,pi3)
04725 call bostr3(exe,pi4,pi4)
04726 rr3=rrr(3)
04727 rr4=rrr(4)
04728 thet =acos(-1.+2*rr3)
04729 phi = 2*pi*rr4
04730 call rotpol(thet,phi,pi2)
04731 call rotpol(thet,phi,pi3)
04732 call rotpol(thet,phi,pi4)
04733 C
04734 C (2345) rest frame, define pi5
04735 c pr momentum
04736 pr(1)=0
04737 pr(2)=0
04738 pr(4)=1./(2*am4)*(am4**2+am3**2-amp5**2)
04739 pr(3)= sqrt(abs(pr(4)**2-am3**2))
04740 ppi = pr(4)**2-am3**2
04741 c pi5 momentum
04742 pi5(1)=0
04743 pi5(2)=0
04744 pi5(4)=1./(2*am4)*(am4**2-am3**2+amp5**2)
04745 pi5(3)=-pr(3)
04746 c --- this part of jacobian will be recovered later
04747 ff3=(4*pi)*(2*pr(3)/am4)
04748 c old pions boosted from 3 rest frame to 4 rest frame
04749 exe=(pr(4)+pr(3))/am3
04750 call bostr3(exe,pi2,pi2)
04751 call bostr3(exe,pi3,pi3)
04752 call bostr3(exe,pi4,pi4)
04753 rr3=rrr(5)
04754 rr4=rrr(6)
04755 thet =acos(-1.+2*rr3)
04756 phi = 2*pi*rr4
04757 call rotpol(thet,phi,pi2)
04758 call rotpol(thet,phi,pi3)
04759 call rotpol(thet,phi,pi4)
04760 call rotpol(thet,phi,pi5)
04761 C
04762 C (12345) rest frame, define pi1
04763 c pr momentum
04764 pr(1)=0
04765 pr(2)=0
04766 pr(4)=1./(2*am5)*(am5**2+am4**2-amp1**2)
04767 pr(3)= sqrt(abs(pr(4)**2-am4**2))
04768 ppi = pr(4)**2-am4**2
04769 c pi1 momentum
04770 pi1(1)=0
04771 pi1(2)=0
04772 pi1(4)=1./(2*am5)*(am5**2-am4**2+amp1**2)
04773 pi1(3)=-pr(3)
04774 c --- this part of jacobian will be recovered later
04775 ff4=(4*pi)*(2*pr(3)/am5)
04776 c old pions boosted from 4 rest frame to 5 rest frame
04777 exe=(pr(4)+pr(3))/am4
04778 call bostr3(exe,pi2,pi2)
04779 call bostr3(exe,pi3,pi3)
04780 call bostr3(exe,pi4,pi4)
04781 call bostr3(exe,pi5,pi5)
04782 rr3=rrr(7)
04783 rr4=rrr(8)
04784 thet =acos(-1.+2*rr3)
04785 phi = 2*pi*rr4
04786 call rotpol(thet,phi,pi1)
04787 call rotpol(thet,phi,pi2)
04788 call rotpol(thet,phi,pi3)
04789 call rotpol(thet,phi,pi4)
04790 call rotpol(thet,phi,pi5)
04791 c
04792 * now to the tau rest frame, define paa and neutrino momenta
04793 * paa momentum
04794 paa(1)=0
04795 paa(2)=0
04796 c paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am5**2)
04797 c paa(3)= sqrt(abs(paa(4)**2-am5**2))
04798 c ppi = paa(4)**2-am5**2
04799 paa(4)=1./(2*amtau)*(amtau**2-amnuta**2+am5sq)
04800 paa(3)= sqrt(abs(paa(4)**2-am5sq))
04801 ppi = paa(4)**2-am5sq
04802 phspac=phspac*(4*pi)*(2*paa(3)/amtau)
04803 * tau-neutrino momentum
04804 pn(1)=0
04805 pn(2)=0
04806 pn(4)=1./(2*amtau)*(amtau**2+amnuta**2-am5**2)
04807 pn(3)=-paa(3)
04808 c
04809 phspac=phspac * gg1*gg2*gg3*ff1*ff2*ff3*ff4
04810 c
04811 C all pions boosted from 5 rest frame to tau rest frame
04812 C z-axis antiparallel to neutrino momentum
04813 exe=(paa(4)+paa(3))/am5
04814 call bostr3(exe,pi1,pi1)
04815 call bostr3(exe,pi2,pi2)
04816 call bostr3(exe,pi3,pi3)
04817 call bostr3(exe,pi4,pi4)
04818 call bostr3(exe,pi5,pi5)
04819 c
04820 C partial width consists of phase space and amplitude
04821 C AMPLITUDE (cf YS.Tsai Phys.Rev.D4,2821(1971)
04822 C or F.Gilman SH.Rhie Phys.Rev.D31,1066(1985)
04823 C
04824 PXQ=AMTAU*PAA(4)
04825 PXN=AMTAU*PN(4)
04826 QXN=PAA(4)*PN(4)-PAA(1)*PN(1)-PAA(2)*PN(2)-PAA(3)*PN(3)
04827 BRAK=2*(GV**2+GA**2)*(2*PXQ*QXN+AM5SQ*PXN)
04828 & -6*(GV**2-GA**2)*AMTAU*AMNUTA*AM5SQ
04829 fompp = cabs(bwign(am3,amom,gamom))**2
04830 c normalisation factor (to some numerical undimensioned factor;
04831 c cf R.Fischer et al ZPhys C3, 313 (1980))
04832 fnorm = 1/fpi**6
04833 c AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK * AM5SQ*SIGEE(AM5SQ,JNPI)
04834 AMPLIT=CCABIB**2*GFERMI**2/2. * BRAK
04835 amplit = amplit * fompp * fnorm
04836 c phase space test
04837 c amplit = amplit * fnorm
04838 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
04839 c ignore spin terms
04840 DO 40 I=1,3
04841 40 HV(I)=0.
04842 c
04843 do 77 k=1,4
04844 pmult(k,1)=pi1(k)
04845 pmult(k,2)=pi2(k)
04846 pmult(k,3)=pi3(k)
04847 pmult(k,4)=pi4(k)
04848 pmult(k,5)=pi5(k)
04849 77 continue
04850 return
04851 #if defined (ALEPH)
04852 C missing: transposition of identical particles, statistical factors
04853 C for identical matrices, polarimetric vector. Matrix element rather nai
04854 #else
04855 C missing: transposition of identical particles, startistical factors
04856 C for identical matrices, polarimetric vector. Matrix element rather naive.
04857 #endif
04858 C flat phase space in pion system + with breit wigner for omega
04859 C anyway it is better than nothing, and code is improvable.
04860 end
04861 SUBROUTINE DPHSRK(DGAMT,HV,PN,PR,PMULT,INUM)
04862 C ----------------------------------------------------------------------
04863 C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
04864 C Z-AXIS ALONG RHO MOMENTUM
04865 C Rho decays to K Kbar
04866 C ----------------------------------------------------------------------
04867 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04868 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04869 * ,AMK,AMKZ,AMKST,GAMKST
04870 C
04871 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04872 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04873 * ,AMK,AMKZ,AMKST,GAMKST
04874 COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04875 REAL*4 GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
04876 REAL HV(4),PT(4),PN(4),PR(4),PKC(4),PKZ(4),QQ(4),PMULT(4,9)
04877 #if defined (ALEPH)
04878 REAL*4 RR1(1)
04879 #else
04880 REAL RR1(1)
04881 #endif
04882 DATA PI /3.141592653589793238462643/
04883 DATA ICONT /0/
04884 C
04885 C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
04886 PHSPAC=1./2**11/PI**5
04887 C TAU MOMENTUM
04888 PT(1)=0.
04889 PT(2)=0.
04890 PT(3)=0.
04891 PT(4)=AMTAU
04892 C MASS OF (REAL/VIRTUAL) RHO
04893 AMS1=(AMK+AMKZ)**2
04894 AMS2=(AMTAU-AMNUTA)**2
04895 C FLAT PHASE SPACE
04896 CALL RANMAR(RR1,1)
04897 AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
04898 AMX=SQRT(AMX2)
04899 PHSPAC=PHSPAC*(AMS2-AMS1)
04900 C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
04901 c ALP1=ATAN((AMS1-AMRO**2)/AMRO/GAMRO)
04902 c ALP2=ATAN((AMS2-AMRO**2)/AMRO/GAMRO)
04903 CAM
04904 100 CONTINUE
04905 c CALL RANMAR(RR1,1)
04906 c ALP=ALP1+RR1(1)*(ALP2-ALP1)
04907 c AMX2=AMRO**2+AMRO*GAMRO*TAN(ALP)
04908 c AMX=SQRT(AMX2)
04909 c IF(AMX.LT.(AMK+AMKZ)) GO TO 100
04910 CAM
04911 c PHSPAC=PHSPAC*((AMX2-AMRO**2)**2+(AMRO*GAMRO)**2)/(AMRO*GAMRO)
04912 c PHSPAC=PHSPAC*(ALP2-ALP1)
04913 C
04914 C TAU-NEUTRINO MOMENTUM
04915 PN(1)=0
04916 PN(2)=0
04917 PN(4)=1./(2*AMTAU)*(AMTAU**2+AMNUTA**2-AMX**2)
04918 PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
04919 C RHO MOMENTUM
04920 PR(1)=0
04921 PR(2)=0
04922 PR(4)=1./(2*AMTAU)*(AMTAU**2-AMNUTA**2+AMX**2)
04923 PR(3)=-PN(3)
04924 PHSPAC=PHSPAC*(4*PI)*(2*PR(3)/AMTAU)
04925 C
04926 CAM
04927 ENQ1=(AMX2+AMK**2-AMKZ**2)/(2.*AMX)
04928 ENQ2=(AMX2-AMK**2+AMKZ**2)/(2.*AMX)
04929 PPPI=SQRT((ENQ1-AMK)*(ENQ1+AMK))
04930 PHSPAC=PHSPAC*(4*PI)*(2*PPPI/AMX)
04931 C CHARGED PI MOMENTUM IN RHO REST FRAME
04932 CALL SPHERA(PPPI,PKC)
04933 PKC(4)=ENQ1
04934 C NEUTRAL PI MOMENTUM IN RHO REST FRAME
04935 DO 20 I=1,3
04936 20 PKZ(I)=-PKC(I)
04937 PKZ(4)=ENQ2
04938 EXE=(PR(4)+PR(3))/AMX
04939 C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
04940 CALL BOSTR3(EXE,PKC,PKC)
04941 CALL BOSTR3(EXE,PKZ,PKZ)
04942 DO 30 I=1,4
04943 30 QQ(I)=PKC(I)-PKZ(I)
04944 C QQ transverse to PR
04945 PKSD =PR(4)*PR(4)-PR(3)*PR(3)-PR(2)*PR(2)-PR(1)*PR(1)
04946 QQPKS=PR(4)* QQ(4)-PR(3)* QQ(3)-PR(2)* QQ(2)-PR(1)* QQ(1)
04947 DO 31 I=1,4
04948 31 QQ(I)=QQ(I)-PR(I)*QQPKS/PKSD
04949 C AMPLITUDE
04950 PRODPQ=PT(4)*QQ(4)
04951 PRODNQ=PN(4)*QQ(4)-PN(1)*QQ(1)-PN(2)*QQ(2)-PN(3)*QQ(3)
04952 PRODPN=PT(4)*PN(4)
04953 QQ2= QQ(4)**2-QQ(1)**2-QQ(2)**2-QQ(3)**2
04954 BRAK=(GV**2+GA**2)*(2*PRODPQ*PRODNQ-PRODPN*QQ2)
04955 & +(GV**2-GA**2)*AMTAU*AMNUTA*QQ2
04956 AMPLIT=(GFERMI*CCABIB)**2*BRAK*2*FPIRK(AMX)
04957 DGAMT=1/(2.*AMTAU)*AMPLIT*PHSPAC
04958 DO 40 I=1,3
04959 40 HV(I)=2*GV*GA*AMTAU*(2*PRODNQ*QQ(I)-QQ2*PN(I))/BRAK
04960 do 77 k=1,4
04961 pmult(k,1)=pkc(k)
04962 pmult(k,2)=pkz(k)
04963 77 continue
04964 RETURN
04965 END
04966 FUNCTION FPIRK(W)
04967 C ----------------------------------------------------------
04968 c square of pion form factor
04969 C ----------------------------------------------------------
04970 COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04971 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04972 * ,AMK,AMKZ,AMKST,GAMKST
04973 C
04974 REAL*4 AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
04975 * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
04976 * ,AMK,AMKZ,AMKST,GAMKST
04977 c COMPLEX FPIKMK
04978 COMPLEX FPIKM
04979 FPIRK=CABS(FPIKM(W,AMK,AMKZ))**2
04980 c FPIRK=CABS(FPIKMK(W,AMK,AMKZ))**2
04981 END
04982 COMPLEX FUNCTION FPIKMK(W,XM1,XM2)
04983 C **********************************************************
04984 C Kaon form factor
04985 C **********************************************************
04986 COMPLEX BWIGM
04987 REAL ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
04988 EXTERNAL BWIG
04989 DATA INIT /0/
04990 C
04991 C ------------ PARAMETERS --------------------
04992 IF (INIT.EQ.0 ) THEN
04993 INIT=1
04994 PI=3.141592654
04995 PIM=.140
04996 ROM=0.773
04997 ROG=0.145
04998 ROM1=1.570
04999 ROG1=0.510
05000 c BETA1=-0.111
05001 BETA1=-0.221
05002 ENDIF
05003 C -----------------------------------------------
05004 S=W**2
05005 FPIKMK=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2))
05006 & /(1+BETA1)
05007 RETURN
05008 END
05009 SUBROUTINE RESLUX
05010 C ****************
05011 C INITIALIZE LUND COMMON
05012 #if defined (CLEO)
05013 #else
05014 PARAMETER (NMXHEP=2000)
05015 COMMON/HEPEVTX/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
05016 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
05017 SAVE /HEPEVTx/
05018 #endif
05019 NHEP=0
05020 END
05021 SUBROUTINE DWRPH(KTO,PHX)
05022 C
05023 C -------------------------
05024 C
05025 IMPLICIT REAL*8 (A-H,O-Z)
05026 REAL*4 PHX(4)
05027 REAL*4 QHOT(4)
05028 C
05029 DO 9 K=1,4
05030 QHOT(K) =0.0
05031 9 CONTINUE
05032 C CASE OF TAU RADIATIVE DECAYS.
05033 C FILLING OF THE LUND COMMON BLOCK.
05034 DO 1002 I=1,4
05035 1002 QHOT(I)=PHX(I)
05036 IF (QHOT(4).GT.1.E-5) CALL DWLUPH(KTO,QHOT)
05037 RETURN
05038 END
05039 SUBROUTINE DWLUPH(KTO,PHOT)
05040 C---------------------------------------------------------------------
05041 C Lorentz transformation to CMsystem and
05042 C Updating of HEPEVT record
05043 C
05044 C called by : DEXAY1,(DEKAY1,DEKAY2)
05045 C
05046 C used when radiative corrections in decays are generated
05047 C---------------------------------------------------------------------
05048 C
05049 #if defined (ALEPH)
05050 COMMON /TAUPOS/ NP1,NP2
05051 #else
05052 #endif
05053 REAL PHOT(4)
05054 #if defined (ALEPH)
05055 #else
05056 COMMON /TAUPOS/ NP1,NP2
05057 #endif
05058 C
05059 C check energy
05060 IF (PHOT(4).LE.0.0) RETURN
05061 C
05062 C position of decaying particle:
05063 IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
05064 NPS=NP1
05065 ELSE
05066 NPS=NP2
05067 ENDIF
05068 C
05069 KTOS=KTO
05070 IF(KTOS.GT.10) KTOS=KTOS-10
05071 C boost and append photon (gamma is 22)
05072 CALL TRALO4(KTOS,PHOT,PHOT,AM)
05073 CALL FILHEP(0,1,22,NPS,NPS,0,0,PHOT,0.0,.TRUE.)
05074 C
05075 RETURN
05076 END
05077
05078 SUBROUTINE DWLUEL(KTO,ISGN,PNU,PWB,PEL,PNE)
05079 C ----------------------------------------------------------------------
05080 C Lorentz transformation to CMsystem and
05081 C Updating of HEPEVT record
05082 C
05083 C ISGN = 1/-1 for tau-/tau+
05084 C
05085 C called by : DEXAY,(DEKAY1,DEKAY2)
05086 C ----------------------------------------------------------------------
05087 C
05088 #if defined (ALEPH)
05089 COMMON /TAUPOS/ NP1,NP2
05090 #else
05091 #endif
05092 REAL PNU(4),PWB(4),PEL(4),PNE(4)
05093 #if defined (ALEPH)
05094 #else
05095 COMMON /TAUPOS/ NP1,NP2
05096 #endif
05097 C
05098 C position of decaying particle:
05099 IF(KTO.EQ. 1) THEN
05100 NPS=NP1
05101 ELSE
05102 NPS=NP2
05103 ENDIF
05104 C
05105 C tau neutrino (nu_tau is 16)
05106 CALL TRALO4(KTO,PNU,PNU,AM)
05107 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05108 C
05109 C W boson (W+ is 24)
05110 CALL TRALO4(KTO,PWB,PWB,AM)
05111 C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
05112 C
05113 C electron (e- is 11)
05114 CALL TRALO4(KTO,PEL,PEL,AM)
05115 CALL FILHEP(0,1,11*ISGN,NPS,NPS,0,0,PEL,AM,.FALSE.)
05116 C
05117 C anti electron neutrino (nu_e is 12)
05118 CALL TRALO4(KTO,PNE,PNE,AM)
05119 CALL FILHEP(0,1,-12*ISGN,NPS,NPS,0,0,PNE,AM,.TRUE.)
05120 C
05121 RETURN
05122 END
05123 SUBROUTINE DWLUMU(KTO,ISGN,PNU,PWB,PMU,PNM)
05124 C ----------------------------------------------------------------------
05125 C Lorentz transformation to CMsystem and
05126 C Updating of HEPEVT record
05127 C
05128 C ISGN = 1/-1 for tau-/tau+
05129 C
05130 C called by : DEXAY,(DEKAY1,DEKAY2)
05131 C ----------------------------------------------------------------------
05132 C
05133 #if defined (ALEPH)
05134 COMMON /TAUPOS/ NP1,NP2
05135 #else
05136 #endif
05137 REAL PNU(4),PWB(4),PMU(4),PNM(4)
05138 #if defined (ALEPH)
05139 #else
05140 COMMON /TAUPOS/ NP1,NP2
05141 #endif
05142 C
05143 C position of decaying particle:
05144 IF(KTO.EQ. 1) THEN
05145 NPS=NP1
05146 ELSE
05147 NPS=NP2
05148 ENDIF
05149 C
05150 C tau neutrino (nu_tau is 16)
05151 CALL TRALO4(KTO,PNU,PNU,AM)
05152 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05153 C
05154 C W boson (W+ is 24)
05155 CALL TRALO4(KTO,PWB,PWB,AM)
05156 C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
05157 C
05158 C muon (mu- is 13)
05159 CALL TRALO4(KTO,PMU,PMU,AM)
05160 CALL FILHEP(0,1,13*ISGN,NPS,NPS,0,0,PMU,AM,.FALSE.)
05161 C
05162 C anti muon neutrino (nu_mu is 14)
05163 CALL TRALO4(KTO,PNM,PNM,AM)
05164 CALL FILHEP(0,1,-14*ISGN,NPS,NPS,0,0,PNM,AM,.TRUE.)
05165 C
05166 RETURN
05167 END
05168 SUBROUTINE DWLUPI(KTO,ISGN,PPI,PNU)
05169 C ----------------------------------------------------------------------
05170 C Lorentz transformation to CMsystem and
05171 C Updating of HEPEVT record
05172 C
05173 C ISGN = 1/-1 for tau-/tau+
05174 C
05175 C called by : DEXAY,(DEKAY1,DEKAY2)
05176 C ----------------------------------------------------------------------
05177 C
05178 REAL PNU(4),PPI(4)
05179 COMMON /TAUPOS/ NP1,NP2
05180 C
05181 C position of decaying particle:
05182 IF(KTO.EQ. 1) THEN
05183 NPS=NP1
05184 ELSE
05185 NPS=NP2
05186 ENDIF
05187 C
05188 C tau neutrino (nu_tau is 16)
05189 CALL TRALO4(KTO,PNU,PNU,AM)
05190 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05191 C
05192 C charged pi meson (pi+ is 211)
05193 CALL TRALO4(KTO,PPI,PPI,AM)
05194 CALL FILHEP(0,1,-211*ISGN,NPS,NPS,0,0,PPI,AM,.TRUE.)
05195 C
05196 RETURN
05197 END
05198 SUBROUTINE DWLURO(KTO,ISGN,PNU,PRHO,PIC,PIZ)
05199 C ----------------------------------------------------------------------
05200 C Lorentz transformation to CMsystem and
05201 C Updating of HEPEVT record
05202 C
05203 C ISGN = 1/-1 for tau-/tau+
05204 C
05205 C called by : DEXAY,(DEKAY1,DEKAY2)
05206 C ----------------------------------------------------------------------
05207 C
05208 #if defined (ALEPH)
05209 COMMON /TAUPOS/ NP1,NP2
05210 #else
05211 #endif
05212 REAL PNU(4),PRHO(4),PIC(4),PIZ(4)
05213 #if defined (ALEPH)
05214 #else
05215 COMMON /TAUPOS/ NP1,NP2
05216 #endif
05217 C
05218 C position of decaying particle:
05219 IF(KTO.EQ. 1) THEN
05220 NPS=NP1
05221 ELSE
05222 NPS=NP2
05223 ENDIF
05224 C
05225 C tau neutrino (nu_tau is 16)
05226 CALL TRALO4(KTO,PNU,PNU,AM)
05227 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05228 C
05229 C charged rho meson (rho+ is 213)
05230 CALL TRALO4(KTO,PRHO,PRHO,AM)
05231 CALL FILHEP(0,2,-213*ISGN,NPS,NPS,0,0,PRHO,AM,.TRUE.)
05232 C
05233 C charged pi meson (pi+ is 211)
05234 CALL TRALO4(KTO,PIC,PIC,AM)
05235 CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PIC,AM,.TRUE.)
05236 C
05237 C pi0 meson (pi0 is 111)
05238 CALL TRALO4(KTO,PIZ,PIZ,AM)
05239 CALL FILHEP(0,1,111,-2,-2,0,0,PIZ,AM,.TRUE.)
05240 C
05241 RETURN
05242 END
05243 SUBROUTINE DWLUAA(KTO,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
05244 C ----------------------------------------------------------------------
05245 C Lorentz transformation to CMsystem and
05246 C Updating of HEPEVT record
05247 C
05248 C ISGN = 1/-1 for tau-/tau+
05249 C JAA = 1 (2) FOR A_1- DECAY TO PI+ 2PI- (PI- 2PI0)
05250 C
05251 C called by : DEXAY,(DEKAY1,DEKAY2)
05252 C ----------------------------------------------------------------------
05253 C
05254 #if defined (ALEPH)
05255 COMMON /TAUPOS/ NP1,NP2
05256 #else
05257 #endif
05258 REAL PNU(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
05259 #if defined (ALEPH)
05260 #else
05261 COMMON /TAUPOS/ NP1,NP2
05262 #endif
05263 C
05264 C position of decaying particle:
05265 IF(KTO.EQ. 1) THEN
05266 NPS=NP1
05267 ELSE
05268 NPS=NP2
05269 ENDIF
05270 C
05271 C tau neutrino (nu_tau is 16)
05272 CALL TRALO4(KTO,PNU,PNU,AM)
05273 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05274 C
05275 C charged a_1 meson (a_1+ is 20213)
05276 CALL TRALO4(KTO,PAA,PAA,AM)
05277 CALL FILHEP(0,1,-20213*ISGN,NPS,NPS,0,0,PAA,AM,.TRUE.)
05278 C
05279 C two possible decays of the charged a1 meson
05280 IF(JAA.EQ.1) THEN
05281 C
05282 C A1 --> PI+ PI- PI- (or charged conjugate)
05283 C
05284 C pi minus (or c.c.) (pi+ is 211)
05285 CALL TRALO4(KTO,PIM2,PIM2,AM)
05286 CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PIM2,AM,.TRUE.)
05287 C
05288 C pi minus (or c.c.) (pi+ is 211)
05289 CALL TRALO4(KTO,PIM1,PIM1,AM)
05290 CALL FILHEP(0,1,-211*ISGN,-2,-2,0,0,PIM1,AM,.TRUE.)
05291 C
05292 C pi plus (or c.c.) (pi+ is 211)
05293 CALL TRALO4(KTO,PIPL,PIPL,AM)
05294 CALL FILHEP(0,1, 211*ISGN,-3,-3,0,0,PIPL,AM,.TRUE.)
05295 C
05296 ELSE IF (JAA.EQ.2) THEN
05297 C
05298 C A1 --> PI- PI0 PI0 (or charged conjugate)
05299 C
05300 C pi zero (pi0 is 111)
05301 CALL TRALO4(KTO,PIM2,PIM2,AM)
05302 CALL FILHEP(0,1,111,-1,-1,0,0,PIM2,AM,.TRUE.)
05303 C
05304 C pi zero (pi0 is 111)
05305 CALL TRALO4(KTO,PIM1,PIM1,AM)
05306 CALL FILHEP(0,1,111,-2,-2,0,0,PIM1,AM,.TRUE.)
05307 C
05308 C pi minus (or c.c.) (pi+ is 211)
05309 CALL TRALO4(KTO,PIPL,PIPL,AM)
05310 CALL FILHEP(0,1,-211*ISGN,-3,-3,0,0,PIPL,AM,.TRUE.)
05311 C
05312 ENDIF
05313 C
05314 RETURN
05315 END
05316 SUBROUTINE DWLUKK (KTO,ISGN,PKK,PNU)
05317 C ----------------------------------------------------------------------
05318 C Lorentz transformation to CMsystem and
05319 C Updating of HEPEVT record
05320 C
05321 C ISGN = 1/-1 for tau-/tau+
05322 C
05323 C ----------------------------------------------------------------------
05324 C
05325 REAL PKK(4),PNU(4)
05326 COMMON /TAUPOS/ NP1,NP2
05327 C
05328 C position of decaying particle
05329 #if defined (ALEPH)
05330 IF(KTO.EQ. 1) THEN
05331 #else
05332 IF (KTO.EQ.1) THEN
05333 #endif
05334 NPS=NP1
05335 ELSE
05336 NPS=NP2
05337 ENDIF
05338 C
05339 C tau neutrino (nu_tau is 16)
05340 CALL TRALO4 (KTO,PNU,PNU,AM)
05341 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05342 C
05343 C K meson (K+ is 321)
05344 CALL TRALO4 (KTO,PKK,PKK,AM)
05345 CALL FILHEP(0,1,-321*ISGN,NPS,NPS,0,0,PKK,AM,.TRUE.)
05346 C
05347 RETURN
05348 END
05349 SUBROUTINE DWLUKS(KTO,ISGN,PNU,PKS,PKK,PPI,JKST)
05350 COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
05351 REAL*4 BRA1,BRK0,BRK0B,BRKS
05352 #if defined (ALEPH)
05353 COMMON /TAUPOS/ NP1,NP2
05354 REAL*4 XIO(1)
05355 #endif
05356 C ----------------------------------------------------------------------
05357 C Lorentz transformation to CMsystem and
05358 C Updating of HEPEVT record
05359 C
05360 C ISGN = 1/-1 for tau-/tau+
05361 C JKST=10 (20) corresponds to K0B pi- (K- pi0) decay
05362 C
05363 C ----------------------------------------------------------------------
05364 C
05365 #if defined (ALEPH)
05366 REAL PNU(4),PKS(4),PKK(4),PPI(4)
05367 #else
05368 REAL PNU(4),PKS(4),PKK(4),PPI(4),XIO(1)
05369 COMMON /TAUPOS/ NP1,NP2
05370 #endif
05371 C
05372 C position of decaying particle
05373 IF(KTO.EQ. 1) THEN
05374 NPS=NP1
05375 ELSE
05376 NPS=NP2
05377 ENDIF
05378 C
05379 C tau neutrino (nu_tau is 16)
05380 CALL TRALO4(KTO,PNU,PNU,AM)
05381 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05382 C
05383 C charged K* meson (K*+ is 323)
05384 CALL TRALO4(KTO,PKS,PKS,AM)
05385 CALL FILHEP(0,1,-323*ISGN,NPS,NPS,0,0,PKS,AM,.TRUE.)
05386 C
05387 C two possible decay modes of charged K*
05388 IF(JKST.EQ.10) THEN
05389 C
05390 C K*- --> pi- K0B (or charged conjugate)
05391 C
05392 C charged pi meson (pi+ is 211)
05393 CALL TRALO4(KTO,PPI,PPI,AM)
05394 CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PPI,AM,.TRUE.)
05395 C
05396 BRAN=BRK0B
05397 IF (ISGN.EQ.-1) BRAN=BRK0
05398 C K0 --> K0_long (is 130) / K0_short (is 310) = 1/1
05399 CALL RANMAR(XIO,1)
05400 IF(XIO(1).GT.BRAN) THEN
05401 K0TYPE = 130
05402 ELSE
05403 K0TYPE = 310
05404 ENDIF
05405 C
05406 CALL TRALO4(KTO,PKK,PKK,AM)
05407 CALL FILHEP(0,1,K0TYPE,-2,-2,0,0,PKK,AM,.TRUE.)
05408 C
05409 ELSE IF(JKST.EQ.20) THEN
05410 C
05411 C K*- --> pi0 K-
05412 C
05413 C pi zero (pi0 is 111)
05414 CALL TRALO4(KTO,PPI,PPI,AM)
05415 CALL FILHEP(0,1,111,-1,-1,0,0,PPI,AM,.TRUE.)
05416 C
05417 C charged K meson (K+ is 321)
05418 CALL TRALO4(KTO,PKK,PKK,AM)
05419 CALL FILHEP(0,1,-321*ISGN,-2,-2,0,0,PKK,AM,.TRUE.)
05420 C
05421 ENDIF
05422 C
05423 RETURN
05424 END
05425 SUBROUTINE DWLNEW(KTO,ISGN,PNU,PWB,PNPI,MODE)
05426 C ----------------------------------------------------------------------
05427 C Lorentz transformation to CMsystem and
05428 C Updating of HEPEVT record
05429 C
05430 C ISGN = 1/-1 for tau-/tau+
05431 C
05432 C called by : DEXAY,(DEKAY1,DEKAY2)
05433 C ----------------------------------------------------------------------
05434 C
05435 PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
05436 #if defined (ALEPH)
05437 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
05438 #else
05439 COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
05440 #endif
05441 & ,NAMES
05442 COMMON /TAUPOS/ NP1,NP2
05443 CHARACTER NAMES(NMODE)*31
05444 REAL PNU(4),PWB(4),PNPI(4,9)
05445 REAL PPI(4)
05446 C
05447 JNPI=MODE-7
05448 C position of decaying particle
05449 IF(KTO.EQ. 1) THEN
05450 NPS=NP1
05451 ELSE
05452 NPS=NP2
05453 ENDIF
05454 C
05455 C tau neutrino (nu_tau is 16)
05456 CALL TRALO4(KTO,PNU,PNU,AM)
05457 CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
05458 C
05459 C W boson (W+ is 24)
05460 CALL TRALO4(KTO,PWB,PWB,AM)
05461 CALL FILHEP(0,1,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
05462 C
05463 C multi pi mode JNPI
05464 C
05465 C get multiplicity of mode JNPI
05466 ND=MULPIK(JNPI)
05467 DO I=1,ND
05468 #if defined (ALEPH)
05469 cam KFPI=LUNPIK(IDFFIN(I,JNPI),-ISGN)
05470 KFPI=LUNPIK(IDFFIN(I,JNPI), ISGN)
05471 #else
05472 KFPI=LUNPIK(IDFFIN(I,JNPI),-ISGN)
05473 #endif
05474 C for charged conjugate case, change charged pions only
05475 C IF(KFPI.NE.111)KFPI=KFPI*ISGN
05476 DO J=1,4
05477 PPI(J)=PNPI(J,I)
05478 END DO
05479 CALL TRALO4(KTO,PPI,PPI,AM)
05480 CALL FILHEP(0,1,KFPI,-I,-I,0,0,PPI,AM,.TRUE.)
05481 END DO
05482 C
05483 RETURN
05484 END
05485 #if defined (CePeCe)
05486 #else
05487 #endif
05488 FUNCTION AMAST(PP)
05489 C ----------------------------------------------------------------------
05490 C CALCULATES MASS OF PP (DOUBLE PRECISION)
05491 C
05492 C USED BY : RADKOR
05493 C ----------------------------------------------------------------------
05494 IMPLICIT REAL*8 (A-H,O-Z)
05495 REAL*8 PP(4)
05496 AAA=PP(4)**2-PP(3)**2-PP(2)**2-PP(1)**2
05497 C
05498 IF(AAA.NE.0.0) AAA=AAA/SQRT(ABS(AAA))
05499 AMAST=AAA
05500 RETURN
05501 END
05502 FUNCTION AMAS4(PP)
05503 C ******************
05504 C ----------------------------------------------------------------------
05505 C CALCULATES MASS OF PP
05506 C
05507 C USED BY :
05508 C ----------------------------------------------------------------------
05509 REAL PP(4)
05510 AAA=PP(4)**2-PP(3)**2-PP(2)**2-PP(1)**2
05511 IF(AAA.NE.0.0) AAA=AAA/SQRT(ABS(AAA))
05512 AMAS4=AAA
05513 RETURN
05514 END
05515 FUNCTION ANGXY(X,Y)
05516 C ----------------------------------------------------------------------
05517 C
05518 C USED BY : KORALZ RADKOR
05519 C ----------------------------------------------------------------------
05520 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05521 DATA PI /3.141592653589793238462643D0/
05522 C
05523 IF(ABS(Y).LT.ABS(X)) THEN
05524 THE=ATAN(ABS(Y/X))
05525 IF(X.LE.0D0) THE=PI-THE
05526 ELSE
05527 THE=ACOS(X/SQRT(X**2+Y**2))
05528 ENDIF
05529 ANGXY=THE
05530 RETURN
05531 END
05532 FUNCTION ANGFI(X,Y)
05533 C ----------------------------------------------------------------------
05534 * CALCULATES ANGLE IN (0,2*PI) RANGE OUT OF X-Y
05535 C
05536 C USED BY : KORALZ RADKOR
05537 C ----------------------------------------------------------------------
05538 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05539 DATA PI /3.141592653589793238462643D0/
05540 C
05541 IF(ABS(Y).LT.ABS(X)) THEN
05542 THE=ATAN(ABS(Y/X))
05543 IF(X.LE.0D0) THE=PI-THE
05544 ELSE
05545 THE=ACOS(X/SQRT(X**2+Y**2))
05546 ENDIF
05547 IF(Y.LT.0D0) THE=2D0*PI-THE
05548 ANGFI=THE
05549 END
05550 SUBROUTINE ROTOD1(PH1,PVEC,QVEC)
05551 C ----------------------------------------------------------------------
05552 C
05553 C USED BY : KORALZ
05554 C ----------------------------------------------------------------------
05555 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05556 DIMENSION PVEC(4),QVEC(4),RVEC(4)
05557 C
05558 PHI=PH1
05559 CS=COS(PHI)
05560 SN=SIN(PHI)
05561 DO 10 I=1,4
05562 10 RVEC(I)=PVEC(I)
05563 QVEC(1)=RVEC(1)
05564 QVEC(2)= CS*RVEC(2)-SN*RVEC(3)
05565 QVEC(3)= SN*RVEC(2)+CS*RVEC(3)
05566 QVEC(4)=RVEC(4)
05567 RETURN
05568 END
05569 SUBROUTINE ROTOD2(PH1,PVEC,QVEC)
05570 C ----------------------------------------------------------------------
05571 C
05572 C USED BY : KORALZ RADKOR
05573 C ----------------------------------------------------------------------
05574 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05575 DIMENSION PVEC(4),QVEC(4),RVEC(4)
05576 C
05577 PHI=PH1
05578 CS=COS(PHI)
05579 SN=SIN(PHI)
05580 DO 10 I=1,4
05581 10 RVEC(I)=PVEC(I)
05582 QVEC(1)= CS*RVEC(1)+SN*RVEC(3)
05583 QVEC(2)=RVEC(2)
05584 QVEC(3)=-SN*RVEC(1)+CS*RVEC(3)
05585 QVEC(4)=RVEC(4)
05586 RETURN
05587 END
05588 SUBROUTINE ROTOD3(PH1,PVEC,QVEC)
05589 C ----------------------------------------------------------------------
05590 C
05591 C USED BY : KORALZ RADKOR
05592 C ----------------------------------------------------------------------
05593 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05594 C
05595 DIMENSION PVEC(4),QVEC(4),RVEC(4)
05596 PHI=PH1
05597 CS=COS(PHI)
05598 SN=SIN(PHI)
05599 DO 10 I=1,4
05600 10 RVEC(I)=PVEC(I)
05601 QVEC(1)= CS*RVEC(1)-SN*RVEC(2)
05602 QVEC(2)= SN*RVEC(1)+CS*RVEC(2)
05603 QVEC(3)=RVEC(3)
05604 QVEC(4)=RVEC(4)
05605 END
05606 SUBROUTINE BOSTR3(EXE,PVEC,QVEC)
05607 C ----------------------------------------------------------------------
05608 C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
05609 C
05610 C USED BY : TAUOLA KORALZ (?)
05611 C ----------------------------------------------------------------------
05612 REAL*4 PVEC(4),QVEC(4),RVEC(4)
05613 C
05614 DO 10 I=1,4
05615 10 RVEC(I)=PVEC(I)
05616 RPL=RVEC(4)+RVEC(3)
05617 RMI=RVEC(4)-RVEC(3)
05618 QPL=RPL*EXE
05619 QMI=RMI/EXE
05620 QVEC(1)=RVEC(1)
05621 QVEC(2)=RVEC(2)
05622 QVEC(3)=(QPL-QMI)/2
05623 QVEC(4)=(QPL+QMI)/2
05624 END
05625 SUBROUTINE BOSTD3(EXE,PVEC,QVEC)
05626 C ----------------------------------------------------------------------
05627 C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
05628 C
05629 C USED BY : KORALZ RADKOR
05630 C ----------------------------------------------------------------------
05631 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
05632 DIMENSION PVEC(4),QVEC(4),RVEC(4)
05633 C
05634 DO 10 I=1,4
05635 10 RVEC(I)=PVEC(I)
05636 RPL=RVEC(4)+RVEC(3)
05637 RMI=RVEC(4)-RVEC(3)
05638 QPL=RPL*EXE
05639 QMI=RMI/EXE
05640 QVEC(1)=RVEC(1)
05641 QVEC(2)=RVEC(2)
05642 QVEC(3)=(QPL-QMI)/2
05643 QVEC(4)=(QPL+QMI)/2
05644 RETURN
05645 END
05646 SUBROUTINE ROTOR1(PH1,PVEC,QVEC)
05647 C ----------------------------------------------------------------------
05648 C
05649 C called by :
05650 C ----------------------------------------------------------------------
05651 REAL*4 PVEC(4),QVEC(4),RVEC(4)
05652 C
05653 PHI=PH1
05654 CS=COS(PHI)
05655 SN=SIN(PHI)
05656 DO 10 I=1,4
05657 10 RVEC(I)=PVEC(I)
05658 QVEC(1)=RVEC(1)
05659 QVEC(2)= CS*RVEC(2)-SN*RVEC(3)
05660 QVEC(3)= SN*RVEC(2)+CS*RVEC(3)
05661 QVEC(4)=RVEC(4)
05662 END
05663 SUBROUTINE ROTOR2(PH1,PVEC,QVEC)
05664 C ----------------------------------------------------------------------
05665 C
05666 C USED BY : TAUOLA
05667 C ----------------------------------------------------------------------
05668 IMPLICIT REAL*4(A-H,O-Z)
05669 REAL*4 PVEC(4),QVEC(4),RVEC(4)
05670 C
05671 PHI=PH1
05672 CS=COS(PHI)
05673 SN=SIN(PHI)
05674 DO 10 I=1,4
05675 10 RVEC(I)=PVEC(I)
05676 QVEC(1)= CS*RVEC(1)+SN*RVEC(3)
05677 QVEC(2)=RVEC(2)
05678 QVEC(3)=-SN*RVEC(1)+CS*RVEC(3)
05679 QVEC(4)=RVEC(4)
05680 END
05681 SUBROUTINE ROTOR3(PHI,PVEC,QVEC)
05682 C ----------------------------------------------------------------------
05683 C
05684 C USED BY : TAUOLA
05685 C ----------------------------------------------------------------------
05686 REAL*4 PVEC(4),QVEC(4),RVEC(4)
05687 C
05688 CS=COS(PHI)
05689 SN=SIN(PHI)
05690 DO 10 I=1,4
05691 10 RVEC(I)=PVEC(I)
05692 QVEC(1)= CS*RVEC(1)-SN*RVEC(2)
05693 QVEC(2)= SN*RVEC(1)+CS*RVEC(2)
05694 QVEC(3)=RVEC(3)
05695 QVEC(4)=RVEC(4)
05696 END
05697 SUBROUTINE SPHERD(R,X)
05698 C ----------------------------------------------------------------------
05699 C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
05700 C DOUBLE PRECISON VERSION OF SPHERA
05701 C ----------------------------------------------------------------------
05702 REAL*8 R,X(4),PI,COSTH,SINTH
05703 REAL*4 RRR(2)
05704 DATA PI /3.141592653589793238462643D0/
05705 C
05706 CALL RANMAR(RRR,2)
05707 COSTH=-1+2*RRR(1)
05708 SINTH=SQRT(1 -COSTH**2)
05709 X(1)=R*SINTH*COS(2*PI*RRR(2))
05710 X(2)=R*SINTH*SIN(2*PI*RRR(2))
05711 X(3)=R*COSTH
05712 RETURN
05713 END
05714 SUBROUTINE ROTPOX(THET,PHI,PP)
05715 IMPLICIT REAL*8 (A-H,O-Z)
05716 C ----------------------------------------------------------------------
05717 #if defined (ALEPH)
05718 C double precison version of ROTPOL
05719 #else
05720 C
05721 #endif
05722 C ----------------------------------------------------------------------
05723 DIMENSION PP(4)
05724 C
05725 CALL ROTOD2(THET,PP,PP)
05726 CALL ROTOD3( PHI,PP,PP)
05727 RETURN
05728 END
05729 SUBROUTINE SPHERA(R,X)
05730 C ----------------------------------------------------------------------
05731 C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
05732 C
05733 C called by : DPHSxx,DADMPI,DADMKK
05734 C ----------------------------------------------------------------------
05735 REAL X(4)
05736 REAL*4 RRR(2)
05737 DATA PI /3.141592653589793238462643/
05738 C
05739 CALL RANMAR(RRR,2)
05740 COSTH=-1.+2.*RRR(1)
05741 SINTH=SQRT(1.-COSTH**2)
05742 X(1)=R*SINTH*COS(2*PI*RRR(2))
05743 X(2)=R*SINTH*SIN(2*PI*RRR(2))
05744 X(3)=R*COSTH
05745 RETURN
05746 END
05747 SUBROUTINE ROTPOL(THET,PHI,PP)
05748 C ----------------------------------------------------------------------
05749 C
05750 C called by : DADMAA,DPHSAA
05751 C ----------------------------------------------------------------------
05752 REAL PP(4)
05753 C
05754 CALL ROTOR2(THET,PP,PP)
05755 CALL ROTOR3( PHI,PP,PP)
05756 RETURN
05757 END
05758 #include "../randg/tauola-random.h"
05759 FUNCTION DILOGT(X)
05760 C *****************
05761 IMPLICIT REAL*8(A-H,O-Z)
05762 CERN C304 VERSION 29/07/71 DILOG 59 C
05763 Z=-1.64493406684822
05764 IF(X .LT.-1.0) GO TO 1
05765 IF(X .LE. 0.5) GO TO 2
05766 IF(X .EQ. 1.0) GO TO 3
05767 IF(X .LE. 2.0) GO TO 4
05768 Z=3.2898681336964
05769 1 T=1.0/X
05770 S=-0.5
05771 Z=Z-0.5* LOG(ABS(X))**2
05772 GO TO 5
05773 2 T=X
05774 S=0.5
05775 Z=0.
05776 GO TO 5
05777 3 DILOGT=1.64493406684822
05778 RETURN
05779 4 T=1.0-X
05780 S=-0.5
05781 Z=1.64493406684822 - LOG(X)* LOG(ABS(T))
05782 5 Y=2.66666666666666 *T+0.66666666666666
05783 B= 0.00000 00000 00001
05784 A=Y*B +0.00000 00000 00004
05785 B=Y*A-B+0.00000 00000 00011
05786 A=Y*B-A+0.00000 00000 00037
05787 B=Y*A-B+0.00000 00000 00121
05788 A=Y*B-A+0.00000 00000 00398
05789 B=Y*A-B+0.00000 00000 01312
05790 A=Y*B-A+0.00000 00000 04342
05791 B=Y*A-B+0.00000 00000 14437
05792 A=Y*B-A+0.00000 00000 48274
05793 B=Y*A-B+0.00000 00001 62421
05794 A=Y*B-A+0.00000 00005 50291
05795 B=Y*A-B+0.00000 00018 79117
05796 A=Y*B-A+0.00000 00064 74338
05797 B=Y*A-B+0.00000 00225 36705
05798 A=Y*B-A+0.00000 00793 87055
05799 B=Y*A-B+0.00000 02835 75385
05800 A=Y*B-A+0.00000 10299 04264
05801 B=Y*A-B+0.00000 38163 29463
05802 A=Y*B-A+0.00001 44963 00557
05803 B=Y*A-B+0.00005 68178 22718
05804 A=Y*B-A+0.00023 20021 96094
05805 B=Y*A-B+0.00100 16274 96164
05806 A=Y*B-A+0.00468 63619 59447
05807 B=Y*A-B+0.02487 93229 24228
05808 A=Y*B-A+0.16607 30329 27855
05809 A=Y*A-B+1.93506 43008 6996
05810 DILOGT=S*T*(A-B)+Z
05811 RETURN
05812 C=======================================================================
05813 C===================END OF CPC PART ====================================
05814 C=======================================================================
05815 END
