tauola-BBB/prod/curr_cleo.f

00001 
00002       subroutine testresu
00003 C this routine calculates Gamma_X/Gamma_e for tau decay into five
00004 C masless pions via narrow a_2 and later omega +rho resonances
00005 C (also narrow). Karlsruhe 16 Feb 2005. Test worked down to 1 % level
00006 C to go beyond, rho presampler must be implemented in phase space.
00007 C otherwise one can not get rid off the tails of distribution tails
00008 C which remain with sizable effect, 
00009       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00010      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00011      *                 ,AMK,AMKZ,AMKST,GAMKST
00012 C
00013       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00014      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00015      *                 ,AMK,AMKZ,AMKST,GAMKST
00016 C
00017       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL                
00018       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL                
00019  
00020       XLAM(X,Y,Z)=SQRT(ABS((X-Y-Z)**2-4.0*Y*Z))
00021       DATA PI /3.141592653589793238462643/
00022       AMOM=.782                                                         
00023       GAMOM= 0.0085         
00024       ama2=1.260      ! for the test to work ama2> AMOM+ AMRO
00025       gama2=0.001 !0.400                                             
00026 
00027       
00028       CARB=3000
00029       Gropp=6
00030       FOMEGA=0.07
00031       wyni= 1.0D0/4.0D0/AMTAU**2*(1-ama2**2/AMTAU**2)**2
00032       wyni=wyni*(1+2*ama2**2/AMTAU**2)*CARB**2*AMA2**4/AMA2/GAMA2*PI
00033       dwpynd=XLAM(ama2**2,amro**2,amom**2)/ama2
00034       eff=dwpynd/ama2*(0.5*dwpynd**2*(1d0/amro**2+1d0/amom**2)+6)
00035       wyni=wyni*eff
00036       GAM3PI= 1D0/3.0D0/128D0/(2*PI)**3*AMOM**7*
00037      $        (fomega*gropp/amro**2)**2/120D0
00038       GAM2PI= gropp**2/48D0/PI*AMRO
00039       wyni=wyni* GAM3pi/GAMOM
00040       wyni=wyni* GAM2pi/GAMRO
00041       wyni=wyni*ccabib**2
00042       write(*,*) 'testresu=',wyni
00043       end
00044 
00045       SUBROUTINE CURR5(MNUM,PIM1,PIM2,PIM3,PIM4,PIM5,HADCUR)
00046       REAL  PIM1(4),PIM2(4),PIM3(4),PIM4(4),PIM5(4)
00047       COMPLEX HADCUR(4), HADCU(4)
00048       IF (MNUM.EQ.24) THEN  ! --+00
00049        CALL CURR5X(MNUM,PIM1,PIM2,PIM3,PIM4,PIM5,HADCU)
00050        DO K=1,4
00051         HADCUR(K)=HADCU(K)
00052        ENDDO
00053       ELSEIF (MNUM.EQ.26) THEN  ! +--00
00054        CALL CURR5X(MNUM,PIM2,PIM3,PIM1,PIM4,PIM5,HADCU)
00055        DO K=1,4
00056         HADCUR(K)=HADCU(K)
00057        ENDDO
00058        CALL CURR5X(MNUM,PIM4,PIM5,PIM2,PIM3,PIM1,HADCU)
00059        DO K=1,4
00060         HADCUR(K)=HADCUR(K)+HADCU(K)
00061        ENDDO
00062        CALL CURR5X(MNUM,PIM4,PIM5,PIM3,PIM2,PIM1,HADCU)
00063        DO K=1,4
00064         HADCUR(K)=HADCUR(K)+HADCU(K)
00065        ENDDO
00066 C --
00067        CALL CURR5X(24,PIM2,PIM3,PIM1,PIM4,PIM5,HADCU)
00068        DO K=1,4
00069         HADCUR(K)=HADCU(K)  +HADCUR(K)
00070        ENDDO
00071        CALL CURR5X(24,PIM2,PIM3,PIM1,PIM5,PIM4,HADCU)
00072        DO K=1,4
00073         HADCUR(K)=HADCUR(K)+HADCU(K)
00074        ENDDO
00075        CALL CURR5X(24,PIM3,PIM2,PIM1,PIM4,PIM5,HADCU)
00076        DO K=1,4
00077         HADCUR(K)=HADCUR(K)+HADCU(K)
00078        ENDDO
00079        CALL CURR5X(24,PIM3,PIM2,PIM1,PIM5,PIM4,HADCU)
00080        DO K=1,4
00081         HADCUR(K)=HADCUR(K)+HADCU(K)
00082        ENDDO
00083 C --
00084        DO K=1,4
00085         HADCUR(K)=HADCUR(K)*SQRT(0.25)  ! statistical factor
00086        ENDDO
00087       ELSEIF (MNUM.EQ.27) THEN   ! -0000
00088        CALL CURR5X(MNUM,PIM2,PIM3,PIM1,PIM4,PIM5,HADCU)
00089        DO K=1,4
00090         HADCUR(K)=HADCU(K)
00091        ENDDO
00092        CALL CURR5X(MNUM,PIM2,PIM4,PIM1,PIM3,PIM5,HADCU)
00093        DO K=1,4
00094         HADCUR(K)=HADCUR(K)+HADCU(K)
00095        ENDDO
00096        CALL CURR5X(MNUM,PIM2,PIM5,PIM1,PIM3,PIM4,HADCU)
00097        DO K=1,4
00098         HADCUR(K)=HADCUR(K)+HADCU(K)
00099        ENDDO
00100        CALL CURR5X(MNUM,PIM4,PIM3,PIM1,PIM2,PIM5,HADCU)
00101        DO K=1,4
00102         HADCUR(K)=HADCUR(K)+HADCU(K)
00103        ENDDO
00104        CALL CURR5X(MNUM,PIM5,PIM3,PIM1,PIM4,PIM2,HADCU)
00105        DO K=1,4
00106         HADCUR(K)=HADCUR(K)+HADCU(K)
00107        ENDDO
00108        CALL CURR5X(MNUM,PIM5,PIM4,PIM1,PIM3,PIM2,HADCU)
00109        DO K=1,4
00110         HADCUR(K)=HADCUR(K)+HADCU(K)
00111        ENDDO
00112        DO K=1,4
00113         HADCUR(K)=HADCUR(K)*SQRT(1.0/24.0)  ! statistical factor
00114        ENDDO
00115       ELSEIF (MNUM.EQ.28) THEN  ! -++--
00116        CALL CURR5X(MNUM,PIM4,PIM5,PIM2,PIM3,PIM1,HADCU)
00117        DO K=1,4
00118         HADCUR(K)=HADCU(K)
00119        ENDDO
00120        CALL CURR5X(MNUM,PIM1,PIM5,PIM2,PIM3,PIM4,HADCU)
00121        DO K=1,4
00122         HADCUR(K)=HADCUR(K)+HADCU(K)
00123        ENDDO
00124        CALL CURR5X(MNUM,PIM1,PIM4,PIM2,PIM3,PIM5,HADCU)
00125        DO K=1,4
00126         HADCUR(K)=HADCUR(K)+HADCU(K)
00127        ENDDO
00128        CALL CURR5X(MNUM,PIM4,PIM5,PIM3,PIM2,PIM1,HADCU)
00129        DO K=1,4
00130         HADCUR(K)=HADCUR(K)+HADCU(K)
00131        ENDDO
00132        CALL CURR5X(MNUM,PIM1,PIM5,PIM3,PIM2,PIM4,HADCU)
00133        DO K=1,4
00134         HADCUR(K)=HADCUR(K)+HADCU(K)
00135        ENDDO
00136        CALL CURR5X(MNUM,PIM1,PIM4,PIM3,PIM2,PIM5,HADCU)
00137        DO K=1,4
00138         HADCUR(K)=HADCUR(K)+HADCU(K)
00139        ENDDO
00140        DO K=1,4
00141         HADCUR(K)=HADCUR(K)*SQRT(1.0/12.0)  ! statistical factor
00142        ENDDO
00143 
00144       ELSE
00145        CALL CURR5X(MNUM,PIM1,PIM2,PIM3,PIM4,PIM5,HADCU)
00146        DO K=1,4
00147         HADCUR(K)=HADCU(K)
00148        ENDDO
00149       ENDIF
00150       END
00151 *AJW 1 version of CURR from KORALB.
00152       SUBROUTINE CURR5X(MNUM,PIM1,PIM2,PIM3,PIM4,PIM5,HADCUR)
00153 C     ==================================================================
00154 C ZBW, 02/2005 - prototype current for 5 pione, several options.
00155 C     ==================================================================
00156  
00157       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00158      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00159      *                 ,AMK,AMKZ,AMKST,GAMKST
00160 C
00161       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00162      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00163      *                 ,AMK,AMKZ,AMKST,GAMKST
00164 C
00165       REAL  PIM1(4),PIM2(4),PIM3(4),PIM4(4),PIM5(4)
00166       COMPLEX HADCUR(4)
00167 
00168       INTEGER K,L,MNUM,K1,K2,IRO,I,J,KK
00169       REAL PA(4),PB(4),PAA(4),PC(4),PD(4)
00170       REAL AA(4,4),PP(4,4)
00171       REAL A,XM,XG,G1,G2,G,AMRO2,GAMRO2,AMRO3,GAMRO3,AMOM,GAMOM
00172       REAL FRO,COEF1,FPI,COEF2,QQ,SK,DENOM,SIG,QQA,SS23,SS24,SS34,QP1P2
00173       REAL QP1P3,QP1P4,P1P2,P1P3,P1P4,SIGN
00174       REAL PKORB,AMPA
00175       COMPLEX ALF0,ALF1,ALF2,ALF3
00176       COMPLEX LAM0,LAM1,LAM2,LAM3
00177       COMPLEX BET1,BET2,BET3
00178       COMPLEX FORM1,FORM2,FORM3,FORM4,FORM2PI
00179       COMPLEX BWIGM,WIGFOR,FPIKM,FPIKMD
00180       COMPLEX AMPL(7),AMPR
00181       COMPLEX BWIGN
00182 C
00183       DATA PI /3.141592653589793238462643/
00184       BWIGN(A,XM,XG)=XM**2/CMPLX(A-XM**2,XM*XG)
00185 C*******************************************************************************
00186       sa1=(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4)+PIM5(4))**2
00187      $   -(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3)+PIM5(3))**2
00188      $   -(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2)+PIM5(2))**2
00189      $   -(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1)+PIM5(1))**2
00190 
00191 C                              
00192       IF (MNUM.EQ.24) THEN ! simple, semi realistic current for 
00193                            ! pi+pi+pi-pi0pi0, saturated with a2 --> rho omega
00194 
00195       somega=(PIM2(4)+PIM3(4)+PIM4(4))**2-(PIM2(3)+PIM3(3)+PIM4(3))**2
00196      $      -(PIM2(2)+PIM3(2)+PIM4(2))**2-(PIM2(1)+PIM3(1)+PIM4(1))**2
00197       sp=    (PIM2(4)+PIM4(4))**2-(PIM2(3)+PIM4(3))**2
00198      $      -(PIM2(2)+PIM4(2))**2-(PIM2(1)+PIM4(1))**2
00199       sm=    (PIM3(4)+PIM4(4))**2-(PIM3(3)+PIM4(3))**2
00200      $      -(PIM3(2)+PIM4(2))**2-(PIM3(1)+PIM4(1))**2
00201       s0=    (PIM2(4)+PIM3(4))**2-(PIM2(3)+PIM3(3))**2
00202      $      -(PIM2(2)+PIM3(2))**2-(PIM2(1)+PIM3(1))**2
00203  
00204  
00205 
00206       srho=(PIM1(4)+PIM5(4))**2-(PIM1(3)+PIM5(3))**2
00207      $    -(PIM1(2)+PIM5(2))**2-(PIM1(1)+PIM5(1))**2
00208 
00209       DO  K=1,4
00210        HADCUR(K)=CMPLX(0.0)
00211        PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)+PIM5(K)
00212        PA(K) =PIM2(K)+PIM3(K)+PIM4(K)
00213        PB(K)=PIM1(K)-PIM5(K)
00214       ENDDO
00215       CALL LEVICI(PC,PIM2,PIM3,PIM4)
00216       CALL LEVICI(PD,PB,PC,PAA)
00217 !      write(*,*) sqrt(somega),
00218 
00219       AMOM=.782                                                 
00220       GAMOM= 0.0085         
00221       ama2=1.260
00222       gama2=0.400                                          
00223 
00224       
00225       CARB=3000
00226       Gropp=6
00227       FOMEGA=0.07
00228       COEF1=CARB/amro**2/amom**2* Gropp*  (fomega*Gropp/AMRO**2)
00229       DO K=1,4
00230        HADCUR(K)=COEF1*PD(K)
00231        HADCUR(K)=HADCUR(K)*BWIGN(SOMEGA,AMOM,GAMOM)
00232      $          *BWIGN(SRHO,AMRO,GAMRO)*BWIGN(SA1,AMA2,GAMA2)
00233 !     $ *(BWIGN(SP,AMRO,GAMRO)+BWIGN(SM,AMRO,GAMRO)+BWIGN(S0,AMRO,GAMRO))
00234 !       write(*,*) sqrt(somega)-amom,amom
00235       ENDDO
00236       ELSEIF (MNUM.EQ.26.OR.MNUM.EQ.27.OR.MNUM.EQ.28) THEN ! simple, semi realistic current for 
00237                            ! pi-pi-pi+pi0pi0, saturated with a2 --> f0 a2
00238 
00239       DO  K=1,4
00240        HADCUR(K)=CMPLX(0.0)
00241       ENDDO
00242 
00243       sa2=(PIM2(4)+PIM3(4)+PIM1(4))**2-(PIM2(3)+PIM3(3)+PIM1(3))**2
00244      $      -(PIM2(2)+PIM3(2)+PIM1(2))**2-(PIM2(1)+PIM3(1)+PIM1(1))**2
00245       s2=    (PIM1(4)+PIM3(4))**2-(PIM1(3)+PIM3(3))**2
00246      $      -(PIM1(2)+PIM3(2))**2-(PIM1(1)+PIM3(1))**2
00247       s1=    (PIM2(4)+PIM3(4))**2-(PIM2(3)+PIM3(3))**2
00248      $      -(PIM2(2)+PIM3(2))**2-(PIM2(1)+PIM3(1))**2
00249       s2x13=PIM2(4)*(PIM1(4)-PIM3(4))-PIM2(3)*(PIM1(3)-PIM3(3))
00250      $     -PIM2(2)*(PIM1(2)-PIM3(2))-PIM2(1)*(PIM1(1)-PIM3(1))
00251       s1x23=PIM1(4)*(PIM2(4)-PIM3(4))-PIM1(3)*(PIM2(3)-PIM3(3))
00252      $     -PIM1(2)*(PIM2(2)-PIM3(2))-PIM1(1)*(PIM2(1)-PIM3(1))
00253  
00254  
00255 
00256       sf=(PIM4(4)+PIM5(4))**2-(PIM4(3)+PIM5(3))**2
00257      $  -(PIM4(2)+PIM5(2))**2-(PIM4(1)+PIM5(1))**2
00258 
00259       DO  K=1,4
00260        PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)+PIM5(K)
00261        PA(K) =PIM1(K)+PIM2(K)+PIM3(K)
00262        PB(K)=PA(K)*s2x13/sa2-(PIM1(K)-PIM3(K))
00263        PC(K)=PA(K)*s1x23/sa2-(PIM2(K)-PIM3(K))
00264       ENDDO
00265       PAPB=PAA(4)*PB(4)-PAA(3)*PB(3)-PAA(2)*PB(2)-PAA(1)*PB(1)
00266       PAPC=PAA(4)*PC(4)-PAA(3)*PC(3)-PAA(2)*PC(2)-PAA(1)*PC(1)
00267       DO  K=1,4
00268        HADCUR(K)=HADCUR(K)+(PAA(K)*PAPB/sa1-PB(K))*BWIGN(s2,amro,gamro)
00269        HADCUR(K)=HADCUR(K)+(PAA(K)*PAPC/sa1-PC(K))*BWIGN(s1,amro,gamro)
00270       ENDDO
00271 !      write(*,*) sqrt(somega),
00272 
00273       AMf2=.800                                    
00274       GAMF2=.600          
00275       ama2=1.260
00276       gama2=.400                                            
00277 
00278       
00279       CARB=4.
00280       faaf=4.
00281       fpp=5.
00282       Grorop=6.
00283       Gropp=6.
00284       COEF1=CARB/ama2**4/amf2**2/amro**2*faaf*fpp* Grorop* Gropp
00285       DO K=1,4
00286        HADCUR(K)=COEF1*HADCUR(K)
00287        HADCUR(K)=HADCUR(K)*BWIGN(SF,AMF2,GAMF2)
00288      $          *BWIGN(SA2,AMA2,GAMA2)*BWIGN(SA1,AMA2,GAMA2)
00289       ENDDO
00290 
00291       ELSE !MNUM! not realistic current, for tests only !
00292 
00293  !     write(*,*) coef1
00294       FPI=93.3E-3
00295       COEF1=2*2.0*SQRT(3.0)/FPI**3
00296       COEF1= 1D0/AMTAU**3 *(4*3*2*1)* (4*pi)**3* SQRT(20.0D0) ! this
00297       ! normalization gives Gamma/Gamma_e=ccabib**2 in masless limit
00298       ! Benchmark current !1
00299  !     write(*,*) coef1
00300  !     stop
00301       DO  K=1,4
00302        HADCUR(K)=CMPLX(0.0)
00303        PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)+PIM5(K)
00304        HADCUR(K)=COEF1*PAA(K)
00305       ENDDO
00306       ENDIF  !MNUM!
00307       END
00308       SUBROUTINE LEVICI(P,A,B,C)
00309       REAL P(4),A(4),B(4),C(4)
00310      
00311       P(1)=A(2)*B(3)*C(4)+A(3)*B(4)*C(2)+A(4)*B(2)*C(3)
00312      $    -A(2)*B(4)*C(3)-A(4)*B(3)*C(2)-A(3)*B(2)*C(4)
00313 
00314       P(2)=A(1)*B(4)*C(3)+A(3)*B(1)*C(4)+A(4)*B(3)*C(1)
00315      $    -A(1)*B(3)*C(4)-A(4)*B(1)*C(3)-A(3)*B(4)*C(1)
00316 
00317       P(3)=A(1)*B(2)*C(4)+A(4)*B(1)*C(2)+A(2)*B(4)*C(1)
00318      $    -A(1)*B(4)*C(2)-A(2)*B(1)*C(4)-A(4)*B(2)*C(1)
00319 
00320       P(4)=A(1)*B(3)*C(2)+A(2)*B(1)*C(3)+A(3)*B(2)*C(1)
00321      $    -A(1)*B(2)*C(3)-A(3)*B(1)*C(2)-A(2)*B(3)*C(1)
00322 
00323       P(1)=-P(1)
00324       P(2)=-P(2)
00325       P(3)=-P(3)
00326       END
00327 
00328 C*AJW 1 version of CURR from KORALB.
00329       SUBROUTINE CURR_CLEO(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
00330 C     ==================================================================
00331 C AJW, 11/97 - based on original CURR from TAUOLA:
00332 C     hadronic current for 4 pi final state
00333 C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
00334 C     R. Decker Z. Phys C36 (1987) 487.
00335 C     M. Gell-Mann, D. Sharp, W. Wagner Phys. Rev. Lett 8 (1962) 261.
00336 C BUT, rewritten to be more general and less "theoretical",
00337 C  using parameters tuned by Vasia and DSC.
00338 C     ==================================================================
00339  
00340       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00341      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00342      *                 ,AMK,AMKZ,AMKST,GAMKST
00343 C
00344       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00345      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00346      *                 ,AMK,AMKZ,AMKST,GAMKST
00347 C
00348       REAL  PIM1(4),PIM2(4),PIM3(4),PIM4(4)
00349       COMPLEX HADCUR(4)
00350 
00351       INTEGER K,L,MNUM,K1,K2,IRO,I,J,KK
00352       REAL PA(4),PB(4),PAA(4)
00353       REAL AA(4,4),PP(4,4)
00354       REAL A,XM,XG,G1,G2,G,AMRO2,GAMRO2,AMRO3,GAMRO3,AMOM,GAMOM
00355       REAL FRO,COEF1,FPI,COEF2,QQ,SK,DENOM,SIG,QQA,SS23,SS24,SS34,QP1P2
00356       REAL QP1P3,QP1P4,P1P2,P1P3,P1P4,SIGN
00357       REAL PKORB,AMPA
00358       COMPLEX ALF0,ALF1,ALF2,ALF3
00359       COMPLEX LAM0,LAM1,LAM2,LAM3
00360       COMPLEX BET1,BET2,BET3
00361       COMPLEX FORM1,FORM2,FORM3,FORM4,FORM2PI
00362       COMPLEX BWIGM,WIGFOR,FPIKM,FPIKMD
00363       COMPLEX AMPL(7),AMPR
00364       COMPLEX BWIGN
00365 C
00366       BWIGN(A,XM,XG)=1.0/CMPLX(A-XM**2,XM*XG)
00367 C*******************************************************************************
00368 C
00369 C --- masses and constants
00370       IF (G1.NE.12.924) THEN
00371       G1=12.924
00372       G2=1475.98
00373       FPI=93.3E-3
00374       G =G1*G2
00375       FRO=0.266*AMRO**2
00376       COEF1=2.0*SQRT(3.0)/FPI**2
00377       COEF2=FRO*G ! overall constant for the omega current
00378       COEF2= COEF2*0.56  ! factor 0.56 reduces contribution of omega from 68% to 40 %
00379 
00380 C masses and widths for for rho-prim and rho-bis:
00381       AMRO2 = 1.465
00382       GAMRO2= 0.310
00383       AMRO3=1.700
00384       GAMRO3=0.235
00385 C
00386       AMOM  = PKORB(1,14)
00387       GAMOM = PKORB(2,14)
00388       AMRO2 = PKORB(1,21)
00389       GAMRO2= PKORB(2,21)
00390       AMRO3 = PKORB(1,22)
00391       GAMRO3= PKORB(2,22)
00392 C
00393 C Amplitudes for (pi-pi-pi0pi+) -> PS, rho0, rho-, rho+, omega.
00394       AMPL(1) = CMPLX(PKORB(3,31)*COEF1,0.)
00395       AMPL(2) = CMPLX(PKORB(3,32)*COEF1,0.)*CEXP(CMPLX(0.,PKORB(3,42)))
00396       AMPL(3) = CMPLX(PKORB(3,33)*COEF1,0.)*CEXP(CMPLX(0.,PKORB(3,43)))
00397       AMPL(4) = CMPLX(PKORB(3,34)*COEF1,0.)*CEXP(CMPLX(0.,PKORB(3,44)))
00398       AMPL(5) = CMPLX(PKORB(3,35)*COEF2,0.)*CEXP(CMPLX(0.,PKORB(3,45)))
00399 C Amplitudes for (pi0pi0pi0pi-) -> PS, rho-.
00400       AMPL(6) = CMPLX(PKORB(3,36)*COEF1)
00401       AMPL(7) = CMPLX(PKORB(3,37)*COEF1)
00402 C
00403 C rho' contributions to rho' -> pi-omega:
00404       ALF0 = CMPLX(PKORB(3,51),0.0)
00405       ALF1 = CMPLX(PKORB(3,52)*AMRO**2,0.0)
00406       ALF2 = CMPLX(PKORB(3,53)*AMRO2**2,0.0)
00407       ALF3 = CMPLX(PKORB(3,54)*AMRO3**2,0.0)
00408 C rho' contribtions to rho' -> rhopipi:
00409       LAM0 = CMPLX(PKORB(3,55),0.0)
00410       LAM1 = CMPLX(PKORB(3,56)*AMRO**2,0.0)
00411       LAM2 = CMPLX(PKORB(3,57)*AMRO2**2,0.0)
00412       LAM3 = CMPLX(PKORB(3,58)*AMRO3**2,0.0)
00413 C rho contributions to rhopipi, rho -> 2pi:
00414       BET1 = CMPLX(PKORB(3,59)*AMRO**2,0.0)
00415       BET2 = CMPLX(PKORB(3,60)*AMRO2**2,0.0)
00416       BET3 = CMPLX(PKORB(3,61)*AMRO3**2,0.0)
00417 C
00418       END IF
00419 C**************************************************
00420 C
00421 C --- initialization of four vectors
00422       DO 7 K=1,4
00423       DO 8 L=1,4
00424  8    AA(K,L)=0.0
00425       HADCUR(K)=CMPLX(0.0)
00426       PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)
00427       PP(1,K)=PIM1(K)
00428       PP(2,K)=PIM2(K)
00429       PP(3,K)=PIM3(K)
00430  7    PP(4,K)=PIM4(K)
00431 C
00432 !      IF (mnum.gt.2) write(*,*) 'curr cleo mnum=',mnum
00433 !      IF (MNUM.gt.2) goto 389
00434       IF (MNUM.EQ.1) THEN
00435 C ===================================================================
00436 C pi- pi- p0 pi+ case                                            ====
00437 C ===================================================================
00438        QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2
00439 
00440 C  Add M(4pi)-dependence to rhopipi channels:
00441        FORM4= LAM0+LAM1*BWIGN(QQ,AMRO,GAMRO)
00442      *            +LAM2*BWIGN(QQ,AMRO2,GAMRO2)
00443      *            +LAM3*BWIGN(QQ,AMRO3,GAMRO3)
00444 
00445 C --- loop over five contributions of the rho-pi-pi
00446        DO 201 K1=1,3
00447        DO 201 K2=3,4
00448 C
00449          IF (K2.EQ.K1) THEN
00450            GOTO 201
00451          ELSEIF (K2.EQ.3) THEN
00452 C rho-
00453             AMPR = AMPL(3)
00454             AMPA = AMPIZ
00455          ELSEIF (K1.EQ.3) THEN
00456 C rho+
00457             AMPR = AMPL(4)
00458             AMPA = AMPIZ
00459          ELSE
00460 C rho0
00461             AMPR = AMPL(2)
00462             AMPA = AMPI
00463          END IF
00464 C
00465          SK=(PP(K1,4)+PP(K2,4))**2-(PP(K1,3)+PP(K2,3))**2
00466      $     -(PP(K1,2)+PP(K2,2))**2-(PP(K1,1)+PP(K2,1))**2
00467 
00468 C -- definition of AA matrix
00469 C -- cronecker delta
00470         DO 202 I=1,4
00471          DO 203 J=1,4
00472  203     AA(I,J)=0.0
00473  202    AA(I,I)=1.0
00474 C ... and the rest ...
00475         DO 204 L=1,4
00476          IF (L.NE.K1.AND.L.NE.K2) THEN
00477           DENOM=(PAA(4)-PP(L,4))**2-(PAA(3)-PP(L,3))**2
00478      $         -(PAA(2)-PP(L,2))**2-(PAA(1)-PP(L,1))**2
00479           DO 205 I=1,4
00480           DO 205 J=1,4
00481                       SIG= 1.0
00482            IF(J.NE.4) SIG=-SIG
00483            AA(I,J)=AA(I,J)
00484      $            -SIG*(PAA(I)-2.0*PP(L,I))*(PAA(J)-PP(L,J))/DENOM
00485  205      CONTINUE
00486          ENDIF
00487  204    CONTINUE
00488 C
00489 C --- lets add something to HADCURR
00490 C        FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
00491 C        FORM1= AMPL(1)+AMPR*FPIKM(SQRT(SK),AMPI,AMPI)
00492 
00493         FORM2PI= BET1*BWIGM(SK,AMRO,GAMRO,AMPA,AMPI)
00494      1          +BET2*BWIGM(SK,AMRO2,GAMRO2,AMPA,AMPI)
00495      2          +BET3*BWIGM(SK,AMRO3,GAMRO3,AMPA,AMPI)
00496         FORM1= AMPL(1)+AMPR*FORM2PI
00497 C
00498        DO 206 I=1,4
00499        DO 206 J=1,4
00500         HADCUR(I)=HADCUR(I)+FORM1*FORM4*AA(I,J)*(PP(K1,J)-PP(K2,J))
00501  206   CONTINUE
00502 C --- end of the rho-pi-pi current (5 possibilities)
00503  201   CONTINUE
00504 C
00505 C ===================================================================
00506 C Now modify the coefficient for the omega-pi current:              =
00507 C ===================================================================
00508        IF (AMPL(5).EQ.CMPLX(0.,0.)) GOTO 311
00509 
00510 C Overall rho+rhoprime for the 4pi system:
00511 C       FORM2=AMPL(5)*(BWIGN(QQ,AMRO,GAMRO)+ELPHA*BWIGN(QQ,AMROP,GAMROP))
00512 C Modified M(4pi)-dependence:
00513        FORM2=AMPL(5)*(ALF0+ALF1*BWIGN(QQ,AMRO,GAMRO)
00514      *                    +ALF2*BWIGN(QQ,AMRO2,GAMRO2)
00515      *                    +ALF3*BWIGN(QQ,AMRO3,GAMRO3))
00516 C
00517 C --- there are two possibilities for omega current
00518 C --- PA PB are corresponding first and second pi-s
00519        DO 301 KK=1,2
00520         DO 302 I=1,4
00521          PA(I)=PP(KK,I)
00522          PB(I)=PP(3-KK,I)
00523  302    CONTINUE
00524 C --- lorentz invariants
00525          QQA=0.0
00526          SS23=0.0
00527          SS24=0.0
00528          SS34=0.0
00529          QP1P2=0.0
00530          QP1P3=0.0
00531          QP1P4=0.0
00532          P1P2 =0.0
00533          P1P3 =0.0
00534          P1P4 =0.0
00535         DO 303 K=1,4
00536                      SIGN=-1.0
00537          IF (K.EQ.4) SIGN= 1.0
00538          QQA=QQA+SIGN*(PAA(K)-PA(K))**2
00539          SS23=SS23+SIGN*(PB(K)  +PIM3(K))**2
00540          SS24=SS24+SIGN*(PB(K)  +PIM4(K))**2
00541          SS34=SS34+SIGN*(PIM3(K)+PIM4(K))**2
00542          QP1P2=QP1P2+SIGN*(PAA(K)-PA(K))*PB(K)
00543          QP1P3=QP1P3+SIGN*(PAA(K)-PA(K))*PIM3(K)
00544          QP1P4=QP1P4+SIGN*(PAA(K)-PA(K))*PIM4(K)
00545          P1P2=P1P2+SIGN*PA(K)*PB(K)
00546          P1P3=P1P3+SIGN*PA(K)*PIM3(K)
00547          P1P4=P1P4+SIGN*PA(K)*PIM4(K)
00548  303    CONTINUE
00549 C
00550 C omega -> rho pi for the 3pi system:
00551 C       FORM3=BWIGN(QQA,AMOM,GAMOM)*(BWIGN(SS23,AMRO,GAMRO)+
00552 C     $        BWIGN(SS24,AMRO,GAMRO)+BWIGN(SS34,AMRO,GAMRO))
00553 C No omega -> rho pi; just straight omega:
00554         FORM3=BWIGN(QQA,AMOM,GAMOM)
00555 C
00556         DO 304 K=1,4
00557          HADCUR(K)=HADCUR(K)+FORM2*FORM3*(
00558      $             PB  (K)*(QP1P3*P1P4-QP1P4*P1P3)
00559      $            +PIM3(K)*(QP1P4*P1P2-QP1P2*P1P4)
00560      $            +PIM4(K)*(QP1P2*P1P3-QP1P3*P1P2) )
00561  304    CONTINUE
00562  301   CONTINUE
00563  311   CONTINUE
00564 C
00565       ELSE
00566 C ===================================================================
00567 C pi0 pi0 p0 pi- case                                            ====
00568 C ===================================================================
00569 ! 389     continue  ! temporary solution for `new' 4-pi modes as well.
00570        QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2
00571 
00572 C --- loop over three contribution of the non-omega current
00573        DO 101 K=1,3
00574         SK=(PP(K,4)+PIM4(4))**2-(PP(K,3)+PIM4(3))**2
00575      $    -(PP(K,2)+PIM4(2))**2-(PP(K,1)+PIM4(1))**2
00576 
00577 C -- definition of AA matrix
00578 C -- cronecker delta
00579         DO 102 I=1,4
00580          DO 103 J=1,4
00581  103     AA(I,J)=0.0
00582  102    AA(I,I)=1.0
00583 C
00584 C ... and the rest ...
00585         DO 104 L=1,3
00586          IF (L.NE.K) THEN
00587           DENOM=(PAA(4)-PP(L,4))**2-(PAA(3)-PP(L,3))**2
00588      $         -(PAA(2)-PP(L,2))**2-(PAA(1)-PP(L,1))**2
00589           DO 105 I=1,4
00590           DO 105 J=1,4
00591                       SIG=1.0
00592            IF(J.NE.4) SIG=-SIG
00593            AA(I,J)=AA(I,J)
00594      $            -SIG*(PAA(I)-2.0*PP(L,I))*(PAA(J)-PP(L,J))/DENOM
00595  105      CONTINUE
00596          ENDIF
00597  104    CONTINUE
00598 
00599 C --- lets add something to HADCURR
00600 C       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
00601 CCCCCCCCCCCCC       FORM1=WIGFOR(SK,AMRO,GAMRO)        (tests)
00602 C       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
00603        FORM1 = AMPL(6)+AMPL(7)*FPIKM(SQRT(SK),AMPI,AMPI)
00604 
00605         DO 106 I=1,4
00606         DO 106 J=1,4
00607          HADCUR(I)=HADCUR(I)+FORM1*AA(I,J)*(PP(K,J)-PP(4,J))
00608  106    CONTINUE
00609 C --- end of the non omega current (3 possibilities)
00610  101   CONTINUE
00611 
00612       ENDIF
00613       END
00614  
00615 
00616