tauola-F/formf.F

00001       FUNCTION FORMOM(XMAA,XMOM)
00002 C     ==================================================================
00003 C     formfactorfor pi-pi0 gamma final state
00004 C      R. Decker, Z. Phys C36 (1987) 487.
00005 C     ==================================================================
00006       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00007      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00008      *                 ,AMK,AMKZ,AMKST,GAMKST
00009 C
00010       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00011      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00012      *                 ,AMK,AMKZ,AMKST,GAMKST
00013       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00014       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00015       COMMON /TESTA1/ KEYA1
00016       COMPLEX BWIGN,FORMOM
00017       DATA ICONT /1/
00018 * THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
00019       BWIGN(XM,AM,GAMMA)=1./CMPLX(XM**2-AM**2,GAMMA*AM)
00020 * HADRON CURRENT
00021       FRO  =0.266*AMRO**2
00022       ELPHA=- 0.1
00023       AMROP = 1.7
00024       GAMROP= 0.26
00025       AMOM  =0.782
00026       GAMOM =0.0085
00027       AROMEG= 1.0
00028       GCOUP=12.924
00029       GCOUP=GCOUP*AROMEG
00030       FQED  =SQRT(4.0*3.1415926535/137.03604)
00031       FORMOM=FQED*FRO**2/SQRT(2.0)*GCOUP**2*BWIGN(XMOM,AMOM,GAMOM)
00032      $     *(BWIGN(XMAA,AMRO,GAMRO)+ELPHA*BWIGN(XMAA,AMROP,GAMROP))
00033      $     *(BWIGN( 0.0,AMRO,GAMRO)+ELPHA*BWIGN( 0.0,AMROP,GAMROP))
00034       END
00035 #if defined (CePeCe)
00036 #elif defined(ALEPH)
00037 #else
00038 C=======================================================================
00039       COMPLEX FUNCTION FK1AB(XMSQ,INDX)
00040 C     ==================================================================
00041 C     complex form-factor for a1+a1prime.                       AJW 1/98
00042 C     ==================================================================
00043 
00044       COMPLEX F1,F2,AMPA,AMPB
00045       INTEGER IFIRST,INDX
00046       DATA IFIRST/0/
00047 
00048       IF (IFIRST.EQ.0) THEN
00049         IFIRST = 1
00050         XM1 = PKORB(1,19)
00051         XG1 = PKORB(2,19)
00052         XM2 = PKORB(1,20)
00053         XG2 = PKORB(2,20)
00054 
00055         XM1SQ = XM1*XM1
00056         GF1 = GFUN(XM1SQ)
00057         GG1 = XM1*XG1/GF1
00058         XM2SQ = XM2*XM2
00059         GF2 = GFUN(XM2SQ)
00060         GG2 = XM2*XG2/GF2
00061       END IF
00062 
00063       IF (INDX.EQ.1) THEN
00064         AMPA = CMPLX(PKORB(3,81),0.)
00065         AMPB = CMPLX(PKORB(3,82),0.)
00066       ELSE IF (INDX.EQ.2) THEN
00067         AMPA = CMPLX(PKORB(3,83),0.)
00068         AMPB = CMPLX(PKORB(3,84),0.)
00069       ELSEIF (INDX.EQ.3) THEN
00070         AMPA = CMPLX(PKORB(3,85),0.)
00071         AMPB = CMPLX(PKORB(3,86),0.)
00072       ELSEIF (INDX.EQ.4) THEN
00073         AMPA = CMPLX(PKORB(3,87),0.)
00074         AMPB = CMPLX(PKORB(3,88),0.)
00075       END IF
00076 
00077       GF = GFUN(XMSQ)
00078       FG1 = GG1*GF
00079       FG2 = GG2*GF
00080       F1 = CMPLX(-XM1SQ,0.0)/CMPLX(XMSQ-XM1SQ,FG1)
00081       F2 = CMPLX(-XM2SQ,0.0)/CMPLX(XMSQ-XM2SQ,FG2)
00082       FK1AB = AMPA*F1+AMPB*F2
00083 
00084       RETURN
00085       END
00086 #endif
00087       FUNCTION FORM1(MNUM,QQ,S1,SDWA)
00088 C     ==================================================================
00089 C     formfactorfor F1 for 3 scalar final state
00090 C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
00091 C     H. Georgi, Weak interactions and modern particle theory,
00092 C     The Benjamin/Cummings Pub. Co., Inc. 1984.
00093 C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
00094 C     and erratum !!!!!!
00095 C     ==================================================================
00096 C
00097       COMPLEX FORM1,WIGNER,WIGFOR,FPIKM,BWIGM
00098       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00099      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00100      *                 ,AMK,AMKZ,AMKST,GAMKST
00101 C
00102       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00103      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00104      *                 ,AMK,AMKZ,AMKST,GAMKST
00105 #if defined (CLEO)
00106       COMPLEX FORMA1,FORMK1,FORMRO,FORMKS
00107       COMPLEX FA1A1P,FK1AB,F3PI
00108 C
00109       IF     (MNUM.EQ.0) THEN
00110 C ------------  3 pi hadronic state (a1)
00111 C       FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
00112 C       FORMRO = F3PI(1,QQ,S1,SDWA)
00113 C       FORMA1 = FA1A1P(QQ)
00114 C       FORM1 = FORMA1*FORMRO
00115        FORM1 = F3PI(1,QQ,S1,SDWA)
00116 
00117       ELSEIF (MNUM.EQ.1) THEN
00118 C ------------ K- pi- K+ (K*0 K-)
00119        FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
00120        FORMA1 = FA1A1P(QQ)
00121        FORM1 = FORMA1*FORMKS
00122 
00123       ELSEIF (MNUM.EQ.2) THEN
00124 C ------------ K0 pi- K0B (K*- K0)
00125        FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
00126        FORMA1 = FA1A1P(QQ)
00127        FORM1 = FORMA1*FORMKS
00128 
00129       ELSEIF (MNUM.EQ.3) THEN
00130 C ------------ K- pi0 K0 (K*0 K-)
00131        FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
00132        FORMA1 = FA1A1P(QQ)
00133        FORM1 = FORMA1*FORMKS
00134 
00135       ELSEIF (MNUM.EQ.4) THEN
00136 C ------------ pi0 pi0 K-  (K*-pi0)
00137        FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
00138        FORMK1 = FK1AB(QQ,3)
00139        FORM1 = FORMK1*FORMKS
00140 
00141       ELSEIF (MNUM.EQ.5) THEN
00142 C ------------ K- pi- pi+ (rho0 K-)
00143        FORMK1 = FK1AB(QQ,4)
00144        FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
00145        FORM1 = FORMK1*FORMRO
00146 
00147       ELSEIF (MNUM.EQ.6) THEN
00148 C ------------ pi- K0B pi0 (pi- K*0B)
00149        FORMK1 = FK1AB(QQ,1)
00150        FORMKS = BWIGM(S1,AMKST,GAMKST,AMK,AMPI)
00151        FORM1 = FORMK1*FORMKS
00152 
00153       ELSEIF (MNUM.EQ.7) THEN
00154 C -------------- eta pi- pi0 final state
00155        FORM1=0.0
00156       ENDIF
00157 #else
00158       WIGNER(A,B,C)= CMPLX(1.0,0.0)/CMPLX(A-B**2,B*C)
00159       IF     (MNUM.EQ.0) THEN
00160 C ------------  3 pi hadronic state (a1)
00161        GAMAX=GAMA1*GFUN(QQ)/GFUN(AMA1**2)
00162        FORM1=AMA1**2*WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
00163       ELSEIF (MNUM.EQ.1) THEN
00164 C ------------ K- pi- K+
00165 #if defined (ALEPH)
00166        FORM1=BWIGM(S1,AMKST,GAMKST,AMPI,AMKZ)
00167 #else
00168        FORM1=BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
00169 #endif
00170          GAMAX=GAMA1*GFUN(QQ)/GFUN(AMA1**2)
00171        FORM1=AMA1**2*WIGNER(QQ,AMA1,GAMAX)*FORM1
00172       ELSEIF (MNUM.EQ.2) THEN
00173 C ------------ K0 pi- K0B
00174 #if defined (ALEPH)
00175        FORM1=BWIGM(S1,AMKST,GAMKST,AMPI,AMKZ)
00176 #else
00177        FORM1=BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
00178 #endif
00179          GAMAX=GAMA1*GFUN(QQ)/GFUN(AMA1**2)
00180        FORM1=AMA1**2*WIGNER(QQ,AMA1,GAMAX)*FORM1
00181       ELSEIF (MNUM.EQ.3) THEN
00182 C ------------ K- K0 pi0
00183        FORM1=0.0
00184          GAMAX=GAMA1*GFUN(QQ)/GFUN(AMA1**2)
00185        FORM1=AMA1**2*WIGNER(QQ,AMA1,GAMAX)*FORM1
00186       ELSEIF (MNUM.EQ.4) THEN
00187 C ------------ pi0 pi0 K-
00188        XM2=1.402
00189        GAM2=0.174
00190 #if defined (ALEPH)
00191        FORM1=BWIGM(S1,AMKST,GAMKST,AMK,AMPIZ)
00192 #else
00193        FORM1=BWIGM(S1,AMKST,GAMKST,AMK,AMPI)
00194 #endif
00195        FORM1=WIGFOR(QQ,XM2,GAM2)*FORM1
00196       ELSEIF (MNUM.EQ.5) THEN
00197 C ------------ K- pi- pi+
00198        XM2=1.402
00199        GAM2=0.174
00200        FORM1=WIGFOR(QQ,XM2,GAM2)*FPIKM(SQRT(S1),AMPI,AMPI)
00201       ELSEIF (MNUM.EQ.6) THEN
00202        FORM1=0.0
00203       ELSEIF (MNUM.EQ.7) THEN
00204 C -------------- eta pi- pi0 final state
00205        FORM1=0.0
00206       ENDIF
00207 #endif
00208       END
00209       FUNCTION FORM2(MNUM,QQ,S1,SDWA)
00210 C     ==================================================================
00211 C     formfactorfor F2 for 3 scalar final state
00212 C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
00213 C     H. Georgi, Weak interactions and modern particle theory,
00214 C     The Benjamin/Cummings Pub. Co., Inc. 1984.
00215 C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
00216 C     and erratum !!!!!!
00217 C     ==================================================================
00218 C
00219       COMPLEX FORM2,WIGNER,WIGFOR,FPIKM,BWIGM
00220       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00221      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00222      *                 ,AMK,AMKZ,AMKST,GAMKST
00223 C
00224       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00225      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00226      *                 ,AMK,AMKZ,AMKST,GAMKST
00227 #if defined (CLEO)
00228       COMPLEX FORMA1,FORMK1,FORMRO,FORMKS
00229       COMPLEX FA1A1P,FK1AB,F3PI
00230 
00231       IF     (MNUM.EQ.0) THEN
00232 C ------------  3 pi hadronic state (a1)
00233 C       FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
00234 C       FORMRO = F3PI(2,QQ,S1,SDWA)
00235 C       FORMA1 = FA1A1P(QQ)
00236 C       FORM2 = FORMA1*FORMRO
00237        FORM2 = F3PI(2,QQ,S1,SDWA)
00238 
00239       ELSEIF (MNUM.EQ.1) THEN
00240 C ------------ K- pi- K+ (rho0 pi-)
00241        FORMRO = FPIKM(SQRT(S1),AMK,AMK)
00242        FORMA1 = FA1A1P(QQ)
00243        FORM2 = FORMA1*FORMRO
00244 
00245       ELSEIF (MNUM.EQ.2) THEN
00246 C ------------ K0 pi- K0B (rho0 pi-)
00247        FORMRO = FPIKM(SQRT(S1),AMK,AMK)
00248        FORMA1 = FA1A1P(QQ)
00249        FORM2 = FORMA1*FORMRO
00250 
00251       ELSEIF (MNUM.EQ.3) THEN
00252 C ------------ K- pi0 K0 (rho- pi0)
00253        FORMRO = FPIKM(SQRT(S1),AMK,AMK)
00254        FORMA1 = FA1A1P(QQ)
00255        FORM2 = FORMA1*FORMRO
00256 
00257       ELSEIF (MNUM.EQ.4) THEN
00258 C ------------ pi0 pi0 K-  (K*-pi0)
00259        FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
00260        FORMK1 = FK1AB(QQ,3)
00261        FORM2 = FORMK1*FORMKS
00262 
00263       ELSEIF (MNUM.EQ.5) THEN
00264 C ------------ K- pi- pi+  (K*0B pi-)
00265        FORMKS = BWIGM(S1,AMKST,GAMKST,AMPI,AMK)
00266        FORMK1 = FK1AB(QQ,1)
00267        FORM2 = FORMK1*FORMKS
00268 C
00269       ELSEIF (MNUM.EQ.6) THEN
00270 C ------------ pi- K0B pi0 (rho- K0B)
00271        FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
00272        FORMK1 = FK1AB(QQ,2)
00273        FORM2 = FORMK1*FORMRO
00274 C
00275       ELSEIF (MNUM.EQ.7) THEN
00276 C -------------- eta pi- pi0 final state
00277        FORM2=0.0
00278       ENDIF
00279 C
00280 #else
00281       WIGNER(A,B,C)= CMPLX(1.0,0.0)/CMPLX(A-B**2,B*C)
00282       IF     (MNUM.EQ.0) THEN
00283 C ------------  3 pi hadronic state (a1)
00284        GAMAX=GAMA1*GFUN(QQ)/GFUN(AMA1**2)
00285        FORM2=AMA1**2*WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
00286       ELSEIF (MNUM.EQ.1) THEN
00287 C ------------ K- pi- K+
00288          GAMAX=GAMA1*GFUN(QQ)/GFUN(AMA1**2)
00289        FORM2=AMA1**2*WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
00290       ELSEIF (MNUM.EQ.2) THEN
00291 C ------------ K0 pi- K0B
00292          GAMAX=GAMA1*GFUN(QQ)/GFUN(AMA1**2)
00293        FORM2=AMA1**2*WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
00294       ELSEIF (MNUM.EQ.3) THEN
00295 C ------------ K- K0 pi0
00296          GAMAX=GAMA1*GFUN(QQ)/GFUN(AMA1**2)
00297        FORM2=AMA1**2*WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
00298       ELSEIF (MNUM.EQ.4) THEN
00299 C ------------ pi0 pi0 K-
00300        XM2=1.402
00301        GAM2=0.174
00302 #if defined (ALEPH)
00303        FORM2=BWIGM(S1,AMKST,GAMKST,AMK,AMPIZ)
00304 #else
00305        FORM2=BWIGM(S1,AMKST,GAMKST,AMK,AMPI)
00306 #endif
00307        FORM2=WIGFOR(QQ,XM2,GAM2)*FORM2
00308       ELSEIF (MNUM.EQ.5) THEN
00309 C ------------ K- pi- pi+
00310        XM2=1.402
00311        GAM2=0.174
00312 #if defined (ALEPH)
00313        FORM2=BWIGM(S1,AMKST,GAMKST,AMK,AMPIZ)
00314 #else
00315        FORM2=BWIGM(S1,AMKST,GAMKST,AMK,AMPI)
00316 #endif
00317        FORM2=WIGFOR(QQ,XM2,GAM2)*FORM2
00318 C
00319       ELSEIF (MNUM.EQ.6) THEN
00320        XM2=1.402
00321        GAM2=0.174
00322        FORM2=WIGFOR(QQ,XM2,GAM2)*FPIKM(SQRT(S1),AMPI,AMPI)
00323 C
00324       ELSEIF (MNUM.EQ.7) THEN
00325 C -------------- eta pi- pi0 final state
00326        FORM2=0.0
00327       ENDIF
00328 C
00329 #endif
00330       END
00331       COMPLEX FUNCTION BWIGM(S,M,G,XM1,XM2)
00332 C **********************************************************
00333 C     P-WAVE BREIT-WIGNER  FOR RHO
00334 C **********************************************************
00335       REAL S,M,G,XM1,XM2
00336       REAL PI,QS,QM,W,GS
00337       DATA INIT /0/
00338 C ------------ PARAMETERS --------------------
00339       IF (INIT.EQ.0) THEN
00340       INIT=1
00341       PI=3.141592654
00342 C -------  BREIT-WIGNER -----------------------
00343          ENDIF
00344        IF (S.GT.(XM1+XM2)**2) THEN
00345          QS=SQRT(ABS((S   -(XM1+XM2)**2)*(S   -(XM1-XM2)**2)))/SQRT(S)
00346          QM=SQRT(ABS((M**2-(XM1+XM2)**2)*(M**2-(XM1-XM2)**2)))/M
00347          W=SQRT(S)
00348          GS=G*(M/W)**2*(QS/QM)**3
00349        ELSE
00350          GS=0.0
00351        ENDIF
00352          BWIGM=M**2/CMPLX(M**2-S,-SQRT(S)*GS)
00353       RETURN
00354       END
00355       COMPLEX FUNCTION FPIKM(W,XM1,XM2)
00356 C **********************************************************
00357 C     PION FORM FACTOR
00358 C **********************************************************
00359       COMPLEX BWIGM
00360       REAL ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
00361       EXTERNAL BWIG
00362       DATA  INIT /0/
00363 C
00364 C ------------ PARAMETERS --------------------
00365       IF (INIT.EQ.0 ) THEN
00366       INIT=1
00367       PI=3.141592654
00368       PIM=.140
00369       ROM=0.773
00370       ROG=0.145
00371       ROM1=1.370
00372       ROG1=0.510
00373       BETA1=-0.145
00374       ENDIF
00375 C -----------------------------------------------
00376       S=W**2
00377       FPIKM=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2))
00378      & /(1+BETA1)
00379       RETURN
00380       END
00381       COMPLEX FUNCTION FPIKMD(W,XM1,XM2)
00382 C **********************************************************
00383 C     PION FORM FACTOR
00384 C **********************************************************
00385       COMPLEX BWIGM
00386       REAL ROM,ROG,ROM1,ROG1,PI,PIM,S,W
00387       EXTERNAL BWIG
00388       DATA  INIT /0/
00389 C
00390 C ------------ PARAMETERS --------------------
00391       IF (INIT.EQ.0 ) THEN
00392       INIT=1
00393       PI=3.141592654
00394       PIM=.140
00395       ROM=0.773
00396       ROG=0.145
00397       ROM1=1.500
00398       ROG1=0.220
00399       ROM2=1.750
00400       ROG2=0.120
00401       BETA=6.5
00402       DELTA=-26.0
00403       ENDIF
00404 C -----------------------------------------------
00405       S=W**2
00406       FPIKMD=(DELTA*BWIGM(S,ROM,ROG,XM1,XM2)
00407      $      +BETA*BWIGM(S,ROM1,ROG1,XM1,XM2)
00408      $      +     BWIGM(S,ROM2,ROG2,XM1,XM2))
00409      & /(1+BETA+DELTA)
00410       RETURN
00411       END
00412  
00413       FUNCTION FORM3(MNUM,QQ,S1,SDWA)
00414 C     ==================================================================
00415 C     formfactorfor F3 for 3 scalar final state
00416 C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
00417 C     H. Georgi, Weak interactions and modern particle theory,
00418 C     The Benjamin/Cummings Pub. Co., Inc. 1984.
00419 C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
00420 C     and erratum !!!!!!
00421 C     ==================================================================
00422 C
00423       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00424      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00425      *                 ,AMK,AMKZ,AMKST,GAMKST
00426 C
00427       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00428      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00429      *                 ,AMK,AMKZ,AMKST,GAMKST
00430 #if defined (CLEO)
00431       COMPLEX FORM3,BWIGM
00432       COMPLEX FORMA1,FORMK1,FORMRO,FORMKS
00433       COMPLEX FA1A1P,FK1AB,F3PI
00434 C
00435       IF (MNUM.EQ.0) THEN
00436 C ------------  3 pi hadronic state (a1)
00437 C       FORMRO = FPIKM(SQRT(S1),AMPI,AMPI)
00438 C       FORMRO = F3PI(3,QQ,S1,SDWA)
00439 C       FORMA1 = FA1A1P(QQ)
00440 C       FORM3 = FORMA1*FORMRO
00441        FORM3 = F3PI(3,QQ,S1,SDWA)
00442 
00443       ELSEIF (MNUM.EQ.3) THEN
00444 C ------------ K- pi0 K0  (K*- K0)
00445        FORMKS = BWIGM(S1,AMKST,GAMKST,AMPIZ,AMK)
00446        FORMA1 = FA1A1P(QQ)
00447        FORM3 = FORMA1*FORMKS
00448 
00449       ELSEIF (MNUM.EQ.6) THEN
00450 C ------------ pi- K0B pi0 (K*- pi0)
00451        FORMKS = BWIGM(S1,AMKST,GAMKST,AMK,AMPI)
00452        FORMK1 = FK1AB(QQ,3)
00453        FORM3 = FORMK1*FORMKS
00454 
00455       ELSE
00456        FORM3=CMPLX(0.,0.)
00457       ENDIF
00458 #else
00459       COMPLEX FORM3
00460       IF (MNUM.EQ.6) THEN
00461        FORM3=CMPLX(0.0)
00462       ELSE
00463        FORM3=CMPLX(0.0)
00464       ENDIF
00465         FORM3=0
00466 
00467 #endif
00468       END
00469       FUNCTION FORM4(MNUM,QQ,S1,S2,S3)
00470 C     ==================================================================
00471 C     formfactorfor F4 for 3 scalar final state
00472 C     R. Decker, in preparation
00473 C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
00474 C     and erratum !!!!!!
00475 C     ==================================================================
00476 C
00477       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00478      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00479      *                 ,AMK,AMKZ,AMKST,GAMKST
00480 C
00481       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00482      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00483      *                 ,AMK,AMKZ,AMKST,GAMKST
00484       COMPLEX FORM4,WIGNER,FPIKM
00485       REAL*4 M
00486 #if defined (CLEO)
00487 #else
00488       WIGNER(A,B,C)=CMPLX(1.0,0.0) /CMPLX(A-B**2,B*C)
00489       IF (MNUM.EQ.0) THEN
00490 C ------------  3 pi hadronic state (a1)
00491         G1=5.8
00492         G2=6.08
00493         FPIP=0.02
00494         AMPIP=1.3
00495         GAMPIP=0.3
00496         S=QQ
00497         G=GAMPIP
00498         XM1=AMPIZ
00499         XM2=AMRO
00500         M  =AMPIP
00501          IF (S.GT.(XM1+XM2)**2) THEN
00502            QS=SQRT(ABS((S   -(XM1+XM2)**2)*(S   -(XM1-XM2)**2)))/SQRT(S)
00503            QM=SQRT(ABS((M**2-(XM1+XM2)**2)*(M**2-(XM1-XM2)**2)))/M
00504            W=SQRT(S)
00505            GS=G*(M/W)**2*(QS/QM)**5
00506          ELSE
00507            GS=0.0
00508          ENDIF
00509         GAMX=GS*W/M
00510         FORM4=G1*G2*FPIP/AMRO**4/AMPIP**2
00511      $       *AMPIP**2*WIGNER(QQ,AMPIP,GAMX)
00512      $       *( S1*(S2-S3)*FPIKM(SQRT(S1),AMPIZ,AMPIZ)
00513      $         +S2*(S1-S3)*FPIKM(SQRT(S2),AMPIZ,AMPIZ) )
00514       ELSEIF (MNUM.EQ.1) THEN
00515 C ------------ K- pi- K+
00516         G1=5.8
00517         G2=6.08
00518         FPIP=0.02
00519         AMPIP=1.3
00520         GAMPIP=0.3
00521         S=QQ
00522         G=GAMPIP
00523         XM1=AMPIZ
00524         XM2=AMRO
00525         M  =AMPIP
00526          IF (S.GT.(XM1+XM2)**2) THEN
00527            QS=SQRT(ABS((S   -(XM1+XM2)**2)*(S   -(XM1-XM2)**2)))/SQRT(S)
00528            QM=SQRT(ABS((M**2-(XM1+XM2)**2)*(M**2-(XM1-XM2)**2)))/M
00529            W=SQRT(S)
00530            GS=G*(M/W)**2*(QS/QM)**5
00531          ELSE
00532            GS=0.0
00533          ENDIF
00534         GAMX=GS*W/M
00535         FORM4=G1*G2*FPIP/AMRO**4/AMPIP**2
00536      $       *AMPIP**2*WIGNER(QQ,AMPIP,GAMX)
00537      $       *( S1*(S2-S3)*FPIKM(SQRT(S1),AMPIZ,AMPIZ)
00538      $         +S2*(S1-S3)*FPIKM(SQRT(S2),AMPIZ,AMPIZ) )
00539       ELSE
00540         FORM4=CMPLX(0.0,0.0)
00541       ENDIF
00542 #endif
00543 #if defined (ALEPH)
00544 C ---- this formfactor is switched off .. .
00545 cam    FORM4=CMPLX(0.0,0.0)
00546 #else
00547 C ---- this formfactor is switched off .. .
00548        FORM4=CMPLX(0.0,0.0)
00549 #endif
00550       END
00551       FUNCTION FORM5(MNUM,QQ,S1,S2)
00552 C     ==================================================================
00553 C     formfactorfor F5 for 3 scalar final state
00554 C     G. Kramer, W. Palmer, S. Pinsky, Phys. Rev. D30 (1984) 89.
00555 C     G. Kramer, W. Palmer             Z. Phys. C25 (1984) 195.
00556 C     R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
00557 C     and erratum !!!!!!
00558 C     ==================================================================
00559 C
00560       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00561      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00562      *                 ,AMK,AMKZ,AMKST,GAMKST
00563 C
00564       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00565      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00566      *                 ,AMK,AMKZ,AMKST,GAMKST
00567       COMPLEX FORM5,WIGNER,FPIKM,FPIKMD,BWIGM
00568 #if defined (CePeCe)
00569 C to satisfy compiler (since it isn-t actually used here)
00570       WIGNER(A,B,C)=CMPLX(1.0,0.0)/CMPLX(A-B**2,B*C)
00571 #elif defined (ALEPH)
00572       WIGNER(A,B,C)=CMPLX(1.0,0.0)/CMPLX(A-B**2,B*C)
00573 #endif
00574       IF     (MNUM.EQ.0) THEN
00575 C ------------  3 pi hadronic state (a1)
00576         FORM5=0.0
00577       ELSEIF (MNUM.EQ.1) THEN
00578 C ------------ K- pi- K+
00579          ELPHA=-0.2
00580          FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)/(1+ELPHA)
00581      $        *(       FPIKM(SQRT(S2),AMPI,AMPI)
00582      $          +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
00583       ELSEIF (MNUM.EQ.2) THEN
00584 C ------------ K0 pi- K0B
00585          ELPHA=-0.2
00586          FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)/(1+ELPHA)
00587      $        *(       FPIKM(SQRT(S2),AMPI,AMPI)
00588      $          +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
00589       ELSEIF (MNUM.EQ.3) THEN
00590 C ------------ K- K0 pi0
00591         FORM5=0.0
00592       ELSEIF (MNUM.EQ.4) THEN
00593 C ------------ pi0 pi0 K-
00594         FORM5=0.0
00595       ELSEIF (MNUM.EQ.5) THEN
00596 C ------------ K- pi- pi+
00597         ELPHA=-0.2
00598         FORM5=BWIGM(QQ,AMKST,GAMKST,AMPI,AMK)/(1+ELPHA)
00599      $       *(       FPIKM(SQRT(S1),AMPI,AMPI)
00600      $         +ELPHA*BWIGM(S2,AMKST,GAMKST,AMPI,AMK))
00601       ELSEIF (MNUM.EQ.6) THEN
00602 C ------------ pi- K0B pi0
00603         ELPHA=-0.2
00604         FORM5=BWIGM(QQ,AMKST,GAMKST,AMPI,AMKZ)/(1+ELPHA)
00605      $       *(       FPIKM(SQRT(S2),AMPI,AMPI)
00606      $         +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
00607       ELSEIF (MNUM.EQ.7) THEN
00608 C -------------- eta pi- pi0 final state
00609        FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)*FPIKM(SQRT(S1),AMPI,AMPI)
00610       ENDIF
00611 C
00612       END
00613 #if defined (ALEPH)
00614       SUBROUTINE CURR(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
00615 #else
00616       SUBROUTINE CURRX(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
00617 #endif
00618 C     ==================================================================
00619 C     hadronic current for 4 pi final state
00620 C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
00621 C     R. Decker Z. Phys C36 (1987) 487.
00622 C     M. Gell-Mann, D. Sharp, W. Wagner Phys. Rev. Lett 8 (1962) 261.
00623 C     ==================================================================
00624  
00625       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00626      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00627      *                 ,AMK,AMKZ,AMKST,GAMKST
00628 C
00629       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00630      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00631      *                 ,AMK,AMKZ,AMKST,GAMKST
00632       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00633       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00634 #if defined (ALEPH)
00635 #else
00636 C ARBITRARY FIXING OF THE FOUR PI X-SECTION NORMALIZATION
00637       COMMON /ARBIT/ ARFLAT,AROMEG
00638 #endif
00639       REAL  PIM1(4),PIM2(4),PIM3(4),PIM4(4),PAA(4)
00640 #if defined (ALEPH)
00641 cam   COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FPIKM
00642       COMPLEX HADCUR(4),FORM1,FORM2,FORM3,WIGFOR
00643 #else
00644       COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FPIKM
00645 #endif
00646       COMPLEX BWIGN
00647       REAL PA(4),PB(4)
00648       REAL AA(4,4),PP(4,4)
00649       DATA PI /3.141592653589793238462643/
00650       DATA  FPI /93.3E-3/
00651       BWIGN(A,XM,XG)=1.0/CMPLX(A-XM**2,XM*XG)
00652 C
00653 C --- masses and constants
00654 #if defined (ALEPH)
00655 cam   rho-prim taken as in Dolinsky et al (PhysLett B174 (1986) 453)
00656 cam   (best fit to Argus data)
00657 #endif
00658       G1=12.924
00659       G2=1475.98
00660       G =G1*G2
00661 #if defined (ALEPH)
00662 cam   ELPHA=-.1
00663 cam   AMROP=1.7
00664 cam   GAMROP=0.26
00665       ELPHA= .02
00666       AMROP=1.250
00667       GAMROP=0.125
00668 #else
00669       ELPHA=-.1
00670       AMROP=1.7
00671       GAMROP=0.26
00672 #endif
00673       AMOM=.782
00674       GAMOM=0.0085
00675 #if defined (ALEPH)
00676 cam   ARFLAT=1.0
00677 cam   AROMEG=1.0
00678       ARFLAT=1.3
00679       AROMEG=2.0
00680 #else
00681       ARFLAT=1.0
00682       AROMEG=1.0
00683 #endif
00684 C
00685       FRO=0.266*AMRO**2
00686       COEF1=2.0*SQRT(3.0)/FPI**2*ARFLAT
00687       COEF2=FRO*G*AROMEG
00688 C --- initialization of four vectors
00689       DO 7 K=1,4
00690       DO 8 L=1,4
00691  8    AA(K,L)=0.0
00692       HADCUR(K)=CMPLX(0.0)
00693       PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)
00694       PP(1,K)=PIM1(K)
00695       PP(2,K)=PIM2(K)
00696       PP(3,K)=PIM3(K)
00697  7    PP(4,K)=PIM4(K)
00698 C
00699       IF (MNUM.EQ.1) THEN
00700 C ===================================================================
00701 C pi- pi- p0 pi+ case                                            ====
00702 C ===================================================================
00703        QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2
00704 C --- loop over thre contribution of the non-omega current
00705        DO 201 K=1,3
00706         SK=(PP(K,4)+PIM4(4))**2-(PP(K,3)+PIM4(3))**2
00707      $    -(PP(K,2)+PIM4(2))**2-(PP(K,1)+PIM4(1))**2
00708 C -- definition of AA matrix
00709 C -- cronecker delta
00710         DO 202 I=1,4
00711          DO 203 J=1,4
00712  203     AA(I,J)=0.0
00713  202    AA(I,I)=1.0
00714 C ... and the rest ...
00715         DO 204 L=1,3
00716          IF (L.NE.K) THEN
00717           DENOM=(PAA(4)-PP(L,4))**2-(PAA(3)-PP(L,3))**2
00718      $         -(PAA(2)-PP(L,2))**2-(PAA(1)-PP(L,1))**2
00719           DO 205 I=1,4
00720           DO 205 J=1,4
00721                       SIG= 1.0
00722            IF(J.NE.4) SIG=-SIG
00723            AA(I,J)=AA(I,J)
00724      $            -SIG*(PAA(I)-2.0*PP(L,I))*(PAA(J)-PP(L,J))/DENOM
00725  205      CONTINUE
00726          ENDIF
00727  204    CONTINUE
00728 C --- lets add something to HADCURR
00729 #if defined (ALEPH)
00730 cam     FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
00731 C       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
00732         FORM1=WIGFOR(SK,AMRO,GAMRO)
00733 #else
00734        FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
00735 C       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
00736 CCCCCCCCCCCCCCCCC       FORM1=WIGFOR(SK,AMRO,GAMRO)      (tests)
00737 #endif
00738 C
00739        FIX=1.0
00740        IF (K.EQ.3) FIX=-2.0
00741        DO 206 I=1,4
00742        DO 206 J=1,4
00743         HADCUR(I)=
00744      $  HADCUR(I)+CMPLX(FIX*COEF1)*FORM1*AA(I,J)*(PP(K,J)-PP(4,J))
00745  206   CONTINUE
00746 C --- end of the non omega current (3 possibilities)
00747  201   CONTINUE
00748 C
00749 C
00750 C --- there are two possibilities for omega current
00751 C --- PA PB are corresponding first and second pi-s
00752        DO 301 KK=1,2
00753         DO 302 I=1,4
00754          PA(I)=PP(KK,I)
00755          PB(I)=PP(3-KK,I)
00756  302    CONTINUE
00757 C --- lorentz invariants
00758          QQA=0.0
00759          SS23=0.0
00760          SS24=0.0
00761          SS34=0.0
00762          QP1P2=0.0
00763          QP1P3=0.0
00764          QP1P4=0.0
00765          P1P2 =0.0
00766          P1P3 =0.0
00767          P1P4 =0.0
00768         DO 303 K=1,4
00769                      SIGN=-1.0
00770          IF (K.EQ.4) SIGN= 1.0
00771          QQA=QQA+SIGN*(PAA(K)-PA(K))**2
00772          SS23=SS23+SIGN*(PB(K)  +PIM3(K))**2
00773          SS24=SS24+SIGN*(PB(K)  +PIM4(K))**2
00774          SS34=SS34+SIGN*(PIM3(K)+PIM4(K))**2
00775          QP1P2=QP1P2+SIGN*(PAA(K)-PA(K))*PB(K)
00776          QP1P3=QP1P3+SIGN*(PAA(K)-PA(K))*PIM3(K)
00777          QP1P4=QP1P4+SIGN*(PAA(K)-PA(K))*PIM4(K)
00778          P1P2=P1P2+SIGN*PA(K)*PB(K)
00779          P1P3=P1P3+SIGN*PA(K)*PIM3(K)
00780          P1P4=P1P4+SIGN*PA(K)*PIM4(K)
00781  303    CONTINUE
00782 C
00783         FORM2=COEF2*(BWIGN(QQ,AMRO,GAMRO)+ELPHA*BWIGN(QQ,AMROP,GAMROP))
00784 C        FORM3=BWIGN(QQA,AMOM,GAMOM)*(BWIGN(SS23,AMRO,GAMRO)+
00785 C     $        BWIGN(SS24,AMRO,GAMRO)+BWIGN(SS34,AMRO,GAMRO))
00786         FORM3=BWIGN(QQA,AMOM,GAMOM)
00787 C
00788         DO 304 K=1,4
00789          HADCUR(K)=HADCUR(K)+FORM2*FORM3*(
00790      $             PB  (K)*(QP1P3*P1P4-QP1P4*P1P3)
00791      $            +PIM3(K)*(QP1P4*P1P2-QP1P2*P1P4)
00792      $            +PIM4(K)*(QP1P2*P1P3-QP1P3*P1P2) )
00793  304    CONTINUE
00794  301   CONTINUE
00795 C
00796       ELSE
00797 C ===================================================================
00798 C pi0 pi0 p0 pi- case                                            ====
00799 C ===================================================================
00800        QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2
00801        DO 101 K=1,3
00802 C --- loop over thre contribution of the non-omega current
00803         SK=(PP(K,4)+PIM4(4))**2-(PP(K,3)+PIM4(3))**2
00804      $    -(PP(K,2)+PIM4(2))**2-(PP(K,1)+PIM4(1))**2
00805 C -- definition of AA matrix
00806 C -- cronecker delta
00807         DO 102 I=1,4
00808          DO 103 J=1,4
00809  103     AA(I,J)=0.0
00810  102    AA(I,I)=1.0
00811 C
00812 C ... and the rest ...
00813         DO 104 L=1,3
00814          IF (L.NE.K) THEN
00815           DENOM=(PAA(4)-PP(L,4))**2-(PAA(3)-PP(L,3))**2
00816      $         -(PAA(2)-PP(L,2))**2-(PAA(1)-PP(L,1))**2
00817           DO 105 I=1,4
00818           DO 105 J=1,4
00819                       SIG=1.0
00820            IF(J.NE.4) SIG=-SIG
00821            AA(I,J)=AA(I,J)
00822      $            -SIG*(PAA(I)-2.0*PP(L,I))*(PAA(J)-PP(L,J))/DENOM
00823  105      CONTINUE
00824          ENDIF
00825  104    CONTINUE
00826 C --- lets add something to HADCURR
00827 #if defined (ALEPH)
00828 cam     FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
00829 C       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
00830         FORM1=WIGFOR(SK,AMRO,GAMRO)
00831 #else
00832        FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
00833 C       FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
00834 CCCCCCCCCCCCC       FORM1=WIGFOR(SK,AMRO,GAMRO)        (tests)
00835 #endif
00836         DO 106 I=1,4
00837         DO 106 J=1,4
00838          HADCUR(I)=
00839      $   HADCUR(I)+CMPLX(COEF1)*FORM1*AA(I,J)*(PP(K,J)-PP(4,J))
00840  106    CONTINUE
00841 C --- end of the non omega current (3 possibilities)
00842  101   CONTINUE
00843       ENDIF
00844       END
00845       FUNCTION WIGFOR(S,XM,XGAM)
00846       COMPLEX WIGFOR,WIGNOR
00847       WIGNOR=CMPLX(-XM**2,XM*XGAM)
00848       WIGFOR=WIGNOR/CMPLX(S-XM**2,XM*XGAM)
00849       END
00850 #if defined (ALEPH)
00851 #else
00852       SUBROUTINE CURINF
00853 C HERE the form factors of M. Finkemeier et al. start
00854 C it ends with the string:  M. Finkemeier et al. END
00855       COMMON /INOUT/ INUT, IOUT
00856       WRITE (UNIT = IOUT,FMT = 99)
00857       WRITE (UNIT = IOUT,FMT = 98)
00858 c                    print *, 'here is curinf'
00859  99   FORMAT(
00860      . /,   ' *************************************************** ',
00861      . /,   '   YOU ARE USING THE 4 PION DECAY MODE FORM FACTORS    ',
00862      . /,   '   WHICH HAVE BEEN DESCRIBED IN:',
00863      . /,   '   R. DECKER, M. FINKEMEIER, P. HEILIGER AND H.H. JONSSON',
00864      . /,   '   "TAU DECAYS INTO FOUR PIONS" ',
00865      . /,   '   UNIVERSITAET KARLSRUHE PREPRINT TTP 94-13 (1994);',
00866      . /,   '                    LNF-94/066(IR); HEP-PH/9410260  ',
00867      . /,   '  ',
00868      . /,   ' PLEASE NOTE THAT THIS ROUTINE IS USING PARAMETERS',
00869      . /,   ' RELATED TO THE 3 PION DECAY MODE (A1 MODE), SUCH AS',
00870      . /,   ' THE A1 MASS AND WIDTH (TAKEN FROM THE COMMON /PARMAS/)',
00871      . /,   ' AND THE 2 PION VECTOR RESONANCE FORM FACTOR (BY USING',
00872      . /,   ' THE ROUTINE FPIKM)'                                   ,
00873      . /,   ' THUS IF YOU DECIDE TO CHANGE ANY OF THESE, YOU WILL'  ,
00874      . /,   ' HAVE TO REFIT THE 4 PION PARAMETERS IN THE COMMON'    )
00875    98   FORMAT(
00876      .      ' BLOCK /TAU4PI/, OR YOU MIGHT GET A BAD DISCRIPTION'   ,
00877      . /,   ' OF TAU -> 4 PIONS'       ,
00878      . /,   ' for these formfactors set in routine CHOICE for',
00879      . /,  ' mnum.eq.102 -- AMRX=1.42 and GAMRX=.21',
00880      . /,  ' mnum.eq.101 -- AMRX=1.3 and GAMRX=.46 PROB1,PROB2=0.2',
00881      . /,  ' to optimize phase space parametrization',
00882      . /,   ' *************************************************** ',
00883      . /,   ' coded by M. Finkemeier and P. Heiliger, 29. sept. 1994',
00884      . /,   ' incorporated to TAUOLA by Z. Was      17. jan. 1995',
00885 c     . /,   ' fitted on (day/month/year) by ...  ',
00886 c     . /,   ' to .... data ',
00887      . /,   ' changed by: Z. Was on 17.01.95',
00888      . /,   ' changes by: M. Finkemeier on 30.01.95' )
00889       END
00890 C
00891       SUBROUTINE CURINI
00892       COMMON /TAU4PI/ GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
00893      .                ROM2,ROG2,BETA2
00894       REAL*4          GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
00895      .                ROM2,ROG2,BETA2
00896       GOMEGA = 1.4
00897       GAMMA1 = 0.38
00898       GAMMA2 = 0.38
00899       ROM1   = 1.35
00900       ROG1   = 0.3
00901       BETA1  = 0.08
00902       ROM2   = 1.70
00903       ROG2   = 0.235
00904       BETA2  = -0.0075                          
00905       END                                               
00906       COMPLEX FUNCTION BWIGA1(QA)
00907 C     ================================================================
00908 C     breit-wigner enhancement of a1
00909 C     ================================================================
00910       COMPLEX WIGNER
00911       COMMON / PARMAS/ AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU,
00912      %                 AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1,
00913      %                 AMK,AMKZ,AMKST,GAMKST
00914  
00915 C
00916       REAL*4           AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU,
00917      %                 AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1,
00918      %                 AMK,AMKZ,AMKST,GAMKST
00919  
00920       WIGNER(A,B,C)=CMPLX(1.0,0.0)/CMPLX(A-B**2,B*C)
00921       GAMAX=GAMA1*GFUN(QA)/GFUN(AMA1**2)
00922       BWIGA1=-AMA1**2*WIGNER(QA,AMA1,GAMAX)
00923       RETURN
00924       END
00925       COMPLEX FUNCTION BWIGEPS(QEPS)
00926 C     =============================================================
00927 C     breit-wigner enhancement of epsilon
00928 C     =============================================================
00929       REAL QEPS,MEPS,GEPS
00930       MEPS=1.300
00931       GEPS=.600
00932       BWIGEPS=CMPLX(MEPS**2,-MEPS*GEPS)/
00933      %        CMPLX(MEPS**2-QEPS,-MEPS*GEPS)
00934       RETURN
00935       END
00936       COMPLEX FUNCTION FRHO4(W,XM1,XM2)
00937 C     ===========================================================
00938 C     rho-type resonance factor with higher radials, to be used
00939 C     by CURR for the four pion mode
00940 C     ===========================================================
00941       COMPLEX BWIGM
00942       COMMON /TAU4PI/ GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
00943      .                ROM2,ROG2,BETA2
00944       REAL*4          GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
00945      .                ROM2,ROG2,BETA2
00946       REAL ROM,ROG,PI,PIM,S,W
00947       EXTERNAL BWIG
00948       DATA  INIT /0/
00949 C
00950 C ------------ PARAMETERS --------------------
00951       IF (INIT.EQ.0 ) THEN
00952       INIT=1
00953       PI=3.141592654
00954       PIM=.140
00955       ROM=0.773
00956       ROG=0.145
00957       ENDIF
00958 C -----------------------------------------------
00959       S=W**2
00960 c              print *,'rom2,rog2 =',rom2,rog2
00961       FRHO4=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2)
00962      & +BETA2*BWIGM(S,ROM2,ROG2,XM1,XM2))
00963      & /(1+BETA1+BETA2)
00964       RETURN
00965       END
00966       SUBROUTINE CURR(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
00967 C     ==================================================================
00968 C     Hadronic current for 4 pi final state, according to:
00969 C     R. Decker, M. Finkemeier, P. Heiliger, H.H.Jonsson, TTP94-13
00970 C
00971 C     See also:
00972 C     R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
00973 C     R. Decker Z. Phys C36 (1987) 487.
00974 C     M. Gell-Mann, D. Sharp, W. Wagner Phys. Rev. Lett 8 (1962) 261.
00975 C     ==================================================================
00976  
00977       COMMON /TAU4PI/ GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
00978      .                ROM2,ROG2,BETA2
00979       REAL*4          GOMEGA,GAMMA1,GAMMA2,ROM1,ROG1,BETA1,
00980      .                ROM2,ROG2,BETA2
00981       COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00982      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00983      *                 ,AMK,AMKZ,AMKST,GAMKST
00984 C
00985       REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
00986      *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
00987      *                 ,AMK,AMKZ,AMKST,GAMKST
00988       COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00989       REAL*4            GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
00990       REAL  PIM1(4),PIM2(4),PIM3(4),PIM4(4),PAA(4)
00991       COMPLEX HADCUR(4),FORM1,FORM2,FORM3,FPIKM
00992       COMPLEX BWIGN,FRHO4
00993       COMPLEX BWIGEPS,BWIGA1
00994       COMPLEX HCOMP1(4),HCOMP2(4),HCOMP3(4),HCOMP4(4)
00995  
00996       COMPLEX T243,T213,T143,T123,T341,T342
00997       COMPLEX T124,T134,T214,T234,T314,T324
00998       COMPLEX S2413,S2314,S1423,S1324,S34
00999       COMPLEX S2431,S3421
01000       COMPLEX BRACK1,BRACK2,BRACK3,BRACK4A,BRACK4B,BRACK4
01001  
01002       REAL QMP1,QMP2,QMP3,QMP4
01003       REAL PS43,PS41,PS42,PS34,PS14,PS13,PS24,PS23
01004       REAL PS21,PS31
01005  
01006       REAL PD243,PD241,PD213,PD143,PD142
01007       REAL PD123,PD341,PD342,PD413,PD423
01008       REAL PD124,PD134,PD214,PD234,PD314,PD324
01009       REAL QP1,QP2,QP3,QP4
01010  
01011       REAL PA(4),PB(4)
01012       REAL AA(4,4),PP(4,4)
01013       DATA PI /3.141592653589793238462643/
01014       DATA  FPI /93.3E-3/
01015       DATA INIT /0/     
01016       BWIGN(A,XM,XG)=1.0/CMPLX(A-XM**2,XM*XG)
01017 C
01018       IF (INIT.EQ.0) THEN
01019         CALL CURINI
01020         CALL CURINF
01021         INIT = 1
01022       ENDIF                     
01023 C
01024 C --- MASSES AND CONSTANTS
01025       G1=12.924
01026       G2=1475.98 * GOMEGA
01027       G =G1*G2
01028       ELPHA=-.1
01029       AMROP=1.7
01030       GAMROP=0.26
01031       AMOM=.782
01032       GAMOM=0.0085
01033       ARFLAT=1.0
01034       AROMEG=1.0
01035 C
01036       FRO=0.266*AMRO**2
01037       COEF1=2.0*SQRT(3.0)/FPI**2*ARFLAT
01038       COEF2=FRO*G*AROMEG
01039 C --- INITIALIZATION OF FOUR VECTORS
01040       DO 7 K=1,4
01041       DO 8 L=1,4
01042  8    AA(K,L)=0.0
01043       HADCUR(K)=CMPLX(0.0)
01044       PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)
01045       PP(1,K)=PIM1(K)
01046       PP(2,K)=PIM2(K)
01047       PP(3,K)=PIM3(K)
01048  7    PP(4,K)=PIM4(K)
01049 C
01050       IF (MNUM.EQ.1) THEN
01051 C ===================================================================
01052 C PI- PI- P0 PI+ CASE                                            ====
01053 C ===================================================================
01054        QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2
01055  
01056 C FIRST DEFINITION OF SCALAR PRODUCTS OF MOMENTUM VECTORS
01057  
01058 C DEFINE (Q-PI)**2 AS QPI:
01059  
01060       QMP1=(PIM2(4)+PIM3(4)+PIM4(4))**2-(PIM2(3)+PIM3(3)+PIM4(3))**2
01061      %   -(PIM2(2)+PIM3(2)+PIM4(2))**2-(PIM2(1)+PIM3(1)+PIM4(1))**2
01062  
01063       QMP2=(PIM1(4)+PIM3(4)+PIM4(4))**2-(PIM1(3)+PIM3(3)+PIM4(3))**2
01064      %   -(PIM1(2)+PIM3(2)+PIM4(2))**2-(PIM1(1)+PIM3(1)+PIM4(1))**2
01065  
01066       QMP3=(PIM1(4)+PIM2(4)+PIM4(4))**2-(PIM1(3)+PIM2(3)+PIM4(3))**2
01067      %   -(PIM1(2)+PIM2(2)+PIM4(2))**2-(PIM1(1)+PIM2(1)+PIM4(1))**2
01068  
01069       QMP4=(PIM1(4)+PIM2(4)+PIM3(4))**2-(PIM1(3)+PIM2(3)+PIM3(3))**2
01070      %   -(PIM1(2)+PIM2(2)+PIM3(2))**2-(PIM1(1)+PIM2(1)+PIM3(1))**2
01071  
01072  
01073 C DEFINE (PI+PK)**2 AS PSIK:
01074  
01075       PS43=(PIM4(4)+PIM3(4))**2-(PIM4(3)+PIM3(3))**2
01076      %    -(PIM4(2)+PIM3(2))**2-(PIM4(1)+PIM3(1))**2
01077  
01078       PS41=(PIM4(4)+PIM1(4))**2-(PIM4(3)+PIM1(3))**2
01079      %    -(PIM4(2)+PIM1(2))**2-(PIM4(1)+PIM1(1))**2
01080  
01081       PS42=(PIM4(4)+PIM2(4))**2-(PIM4(3)+PIM2(3))**2
01082      %    -(PIM4(2)+PIM2(2))**2-(PIM4(1)+PIM2(1))**2
01083  
01084       PS34=PS43
01085  
01086       PS14=PS41
01087  
01088       PS13=(PIM1(4)+PIM3(4))**2-(PIM1(3)+PIM3(3))**2
01089      %    -(PIM1(2)+PIM3(2))**2-(PIM1(1)+PIM3(1))**2
01090  
01091       PS24=PS42
01092  
01093       PS23=(PIM2(4)+PIM3(4))**2-(PIM2(3)+PIM3(3))**2
01094      %    -(PIM2(2)+PIM3(2))**2-(PIM2(1)+PIM3(1))**2
01095  
01096       PD243=PIM2(4)*(PIM4(4)-PIM3(4))-PIM2(3)*(PIM4(3)-PIM3(3))
01097      %     -PIM2(2)*(PIM4(2)-PIM3(2))-PIM2(1)*(PIM4(1)-PIM3(1))
01098  
01099       PD241=PIM2(4)*(PIM4(4)-PIM1(4))-PIM2(3)*(PIM4(3)-PIM1(3))
01100      %     -PIM2(2)*(PIM4(2)-PIM1(2))-PIM2(1)*(PIM4(1)-PIM1(1))
01101  
01102       PD213=PIM2(4)*(PIM1(4)-PIM3(4))-PIM2(3)*(PIM1(3)-PIM3(3))
01103      %     -PIM2(2)*(PIM1(2)-PIM3(2))-PIM2(1)*(PIM1(1)-PIM3(1))
01104  
01105       PD143=PIM1(4)*(PIM4(4)-PIM3(4))-PIM1(3)*(PIM4(3)-PIM3(3))
01106      %     -PIM1(2)*(PIM4(2)-PIM3(2))-PIM1(1)*(PIM4(1)-PIM3(1))
01107  
01108       PD142=PIM1(4)*(PIM4(4)-PIM2(4))-PIM1(3)*(PIM4(3)-PIM2(3))
01109      %     -PIM1(2)*(PIM4(2)-PIM2(2))-PIM1(1)*(PIM4(1)-PIM2(1))
01110  
01111       PD123=PIM1(4)*(PIM2(4)-PIM3(4))-PIM1(3)*(PIM2(3)-PIM3(3))
01112      %     -PIM1(2)*(PIM2(2)-PIM3(2))-PIM1(1)*(PIM2(1)-PIM3(1))
01113  
01114       PD341=PIM3(4)*(PIM4(4)-PIM1(4))-PIM3(3)*(PIM4(3)-PIM1(3))
01115      %     -PIM3(2)*(PIM4(2)-PIM1(2))-PIM3(1)*(PIM4(1)-PIM1(1))
01116  
01117       PD342=PIM3(4)*(PIM4(4)-PIM2(4))-PIM3(3)*(PIM4(3)-PIM2(3))
01118      %     -PIM3(2)*(PIM4(2)-PIM2(2))-PIM3(1)*(PIM4(1)-PIM2(1))
01119  
01120       PD413=PIM4(4)*(PIM1(4)-PIM3(4))-PIM4(3)*(PIM1(3)-PIM3(3))
01121      %     -PIM4(2)*(PIM1(2)-PIM3(2))-PIM4(1)*(PIM1(1)-PIM3(1))
01122  
01123       PD423=PIM4(4)*(PIM2(4)-PIM3(4))-PIM4(3)*(PIM2(3)-PIM3(3))
01124      %     -PIM4(2)*(PIM2(2)-PIM3(2))-PIM4(1)*(PIM2(1)-PIM3(1))
01125  
01126 C DEFINE Q*PI = QPI:
01127  
01128       QP1=PIM1(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
01129      %   -PIM1(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
01130      %   -PIM1(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
01131      %   -PIM1(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))
01132  
01133       QP2=PIM2(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
01134      %   -PIM2(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
01135      %   -PIM2(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
01136      %   -PIM2(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))
01137  
01138       QP3=PIM3(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
01139      %   -PIM3(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
01140      %   -PIM3(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
01141      %   -PIM3(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))
01142  
01143       QP4=PIM4(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
01144      %   -PIM4(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
01145      %   -PIM4(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
01146      %   -PIM4(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))
01147  
01148  
01149  
01150 C DEFINE T(PI;PJ,PK)= TIJK:
01151  
01152       T243=BWIGA1(QMP2)*FPIKM(SQRT(PS43),AMPI,AMPI)*GAMMA1
01153       T213=BWIGA1(QMP2)*FPIKM(SQRT(PS13),AMPI,AMPI)*GAMMA1
01154       T143=BWIGA1(QMP1)*FPIKM(SQRT(PS43),AMPI,AMPI)*GAMMA1
01155       T123=BWIGA1(QMP1)*FPIKM(SQRT(PS23),AMPI,AMPI)*GAMMA1
01156       T341=BWIGA1(QMP3)*FPIKM(SQRT(PS41),AMPI,AMPI)*GAMMA1
01157       T342=BWIGA1(QMP3)*FPIKM(SQRT(PS42),AMPI,AMPI)*GAMMA1
01158  
01159 C DEFINE S(I,J;K,L)= SIJKL:
01160  
01161       S2413=FRHO4(SQRT(PS24),AMPI,AMPI)*GAMMA2
01162       S2314=FRHO4(SQRT(PS23),AMPI,AMPI)*BWIGEPS(PS14)*GAMMA2
01163       S1423=FRHO4(SQRT(PS14),AMPI,AMPI)*GAMMA2
01164       S1324=FRHO4(SQRT(PS13),AMPI,AMPI)*BWIGEPS(PS24)*GAMMA2
01165       S34=FRHO4(SQRT(PS34),AMPI,AMPI)*GAMMA2
01166  
01167 C DEFINITION OF AMPLITUDE, FIRST THE [] BRACKETS:
01168  
01169       BRACK1=2.*T143+2.*T243+T123+T213
01170      %    +T341*(PD241/QMP3-1.)+T342*(PD142/QMP3-1.)
01171      %    +3./4.*(S1423+S2413-S2314-S1324)-3.*S34
01172  
01173       BRACK2=2.*T143*PD243/QMP1+3.*T213
01174      %    +T123*(2.*PD423/QMP1+1.)+T341*(PD241/QMP3+3.)
01175      %    +T342*(PD142/QMP3+1.)
01176      %    -3./4.*(S2314+3.*S1324+3.*S1423+S2413)
01177  
01178       BRACK3=2.*T243*PD143/QMP2+3.*T123
01179      %    +T213*(2.*PD413/QMP2+1.)+T341*(PD241/QMP3+1.)
01180      %    +T342*(PD142/QMP3+3.)
01181      %    -3./4.*(3.*S2314+S1324+S1423+3.*S2413)
01182  
01183       BRACK4A=2.*T143*(PD243/QQ*(QP1/QMP1+1.)+PD143/QQ)
01184      %     +2.*T243*(PD143/QQ*(QP2/QMP2+1.)+PD243/QQ)
01185      %     +T123+T213
01186      %     +2.*T123*(PD423/QQ*(QP1/QMP1+1.)+PD123/QQ)
01187      %     +2.*T213*(PD413/QQ*(QP2/QMP2+1.)+PD213/QQ)
01188      %     +T341*(PD241/QMP3+1.-2.*PD241/QQ*(QP3/QMP3+1.)
01189      %           -2.*PD341/QQ)
01190      %     +T342*(PD142/QMP3+1.-2.*PD142/QQ*(QP3/QMP3+1.)
01191      %           -2.*PD342/QQ)
01192  
01193       BRACK4B=-3./4.*(S2314*(2.*(QP2-QP3)/QQ+1.)
01194      %             +S1324*(2.*(QP1-QP3)/QQ+1.)
01195      %             +S1423*(2.*(QP1-QP4)/QQ+1.)
01196      %             +S2413*(2.*(QP2-QP4)/QQ+1.)
01197      %             +4.*S34*(QP4-QP3)/QQ)
01198  
01199       BRACK4=BRACK4A+BRACK4B
01200  
01201       DO 208 K=1,4
01202  
01203       HCOMP1(K)=(PIM3(K)-PIM4(K))*BRACK1
01204       HCOMP2(K)=PIM1(K)*BRACK2
01205       HCOMP3(K)=PIM2(K)*BRACK3
01206       HCOMP4(K)=(PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K))*BRACK4
01207  
01208  208  CONTINUE
01209  
01210       DO 209 I=1,4
01211  
01212       HADCUR(I)=HCOMP1(I)-HCOMP2(I)-HCOMP3(I)+HCOMP4(I)
01213       HADCUR(I)=-COEF1*FRHO4(SQRT(QQ),AMPI,AMPI)*HADCUR(I)
01214  
01215  209  CONTINUE
01216  
01217  
01218 C --- END OF THE NON OMEGA CURRENT (3 POSSIBILITIES)
01219  201   CONTINUE
01220 C
01221 C
01222 C --- THERE ARE TWO POSSIBILITIES FOR OMEGA CURRENT
01223 C --- PA PB ARE CORRESPONDING FIRST AND SECOND PI-S
01224        DO 301 KK=1,2
01225         DO 302 I=1,4
01226          PA(I)=PP(KK,I)
01227          PB(I)=PP(3-KK,I)
01228  302    CONTINUE
01229 C --- LORENTZ INVARIANTS
01230          QQA=0.0
01231          SS23=0.0
01232          SS24=0.0
01233          SS34=0.0
01234          QP1P2=0.0
01235          QP1P3=0.0
01236          QP1P4=0.0
01237          P1P2 =0.0
01238          P1P3 =0.0
01239          P1P4 =0.0
01240         DO 303 K=1,4
01241                      SIGN=-1.0
01242          IF (K.EQ.4) SIGN= 1.0
01243          QQA=QQA+SIGN*(PAA(K)-PA(K))**2
01244          SS23=SS23+SIGN*(PB(K)  +PIM3(K))**2
01245          SS24=SS24+SIGN*(PB(K)  +PIM4(K))**2
01246          SS34=SS34+SIGN*(PIM3(K)+PIM4(K))**2
01247          QP1P2=QP1P2+SIGN*(PAA(K)-PA(K))*PB(K)
01248          QP1P3=QP1P3+SIGN*(PAA(K)-PA(K))*PIM3(K)
01249          QP1P4=QP1P4+SIGN*(PAA(K)-PA(K))*PIM4(K)
01250          P1P2=P1P2+SIGN*PA(K)*PB(K)
01251          P1P3=P1P3+SIGN*PA(K)*PIM3(K)
01252          P1P4=P1P4+SIGN*PA(K)*PIM4(K)
01253  303    CONTINUE
01254 C
01255         FORM2=COEF2*(BWIGN(QQ,AMRO,GAMRO)+ELPHA*BWIGN(QQ,AMROP,GAMROP))
01256 C        FORM3=BWIGN(QQA,AMOM,GAMOM)*(BWIGN(SS23,AMRO,GAMRO)+
01257 C     $        BWIGN(SS24,AMRO,GAMRO)+BWIGN(SS34,AMRO,GAMRO))
01258         FORM3=BWIGN(QQA,AMOM,GAMOM)
01259 C
01260         DO 304 K=1,4
01261           HADCUR(K)=HADCUR(K)+FORM2*FORM3*(
01262      $              PB  (K)*(QP1P3*P1P4-QP1P4*P1P3)
01263      $             +PIM3(K)*(QP1P4*P1P2-QP1P2*P1P4)
01264      $             +PIM4(K)*(QP1P2*P1P3-QP1P3*P1P2) )
01265  304    CONTINUE
01266  301   CONTINUE
01267 C
01268       ELSE
01269 C ===================================================================
01270 C PI0 PI0 P0 PI- CASE                                            ====
01271 C ===================================================================
01272        QQ=PAA(4)**2-PAA(3)**2-PAA(2)**2-PAA(1)**2
01273  
01274  
01275 C FIRST DEFINITION OF SCALAR PRODUCTS OF MOMENTUM VECTORS
01276  
01277 C DEFINE (Q-PI)**2 AS QPI:
01278  
01279       QMP1=(PIM2(4)+PIM3(4)+PIM4(4))**2-(PIM2(3)+PIM3(3)+PIM4(3))**2
01280      %   -(PIM2(2)+PIM3(2)+PIM4(2))**2-(PIM2(1)+PIM3(1)+PIM4(1))**2
01281  
01282       QMP2=(PIM1(4)+PIM3(4)+PIM4(4))**2-(PIM1(3)+PIM3(3)+PIM4(3))**2
01283      %   -(PIM1(2)+PIM3(2)+PIM4(2))**2-(PIM1(1)+PIM3(1)+PIM4(1))**2
01284  
01285       QMP3=(PIM1(4)+PIM2(4)+PIM4(4))**2-(PIM1(3)+PIM2(3)+PIM4(3))**2
01286      %   -(PIM1(2)+PIM2(2)+PIM4(2))**2-(PIM1(1)+PIM2(1)+PIM4(1))**2
01287  
01288       QMP4=(PIM1(4)+PIM2(4)+PIM3(4))**2-(PIM1(3)+PIM2(3)+PIM3(3))**2
01289      %   -(PIM1(2)+PIM2(2)+PIM3(2))**2-(PIM1(1)+PIM2(1)+PIM3(1))**2
01290  
01291  
01292 C DEFINE (PI+PK)**2 AS PSIK:
01293  
01294       PS14=(PIM1(4)+PIM4(4))**2-(PIM1(3)+PIM4(3))**2
01295      %    -(PIM1(2)+PIM4(2))**2-(PIM1(1)+PIM4(1))**2
01296  
01297       PS21=(PIM2(4)+PIM1(4))**2-(PIM2(3)+PIM1(3))**2
01298      %    -(PIM2(2)+PIM1(2))**2-(PIM2(1)+PIM1(1))**2
01299  
01300       PS23=(PIM2(4)+PIM3(4))**2-(PIM2(3)+PIM3(3))**2
01301      %    -(PIM2(2)+PIM3(2))**2-(PIM2(1)+PIM3(1))**2
01302  
01303       PS24=(PIM2(4)+PIM4(4))**2-(PIM2(3)+PIM4(3))**2
01304      %    -(PIM2(2)+PIM4(2))**2-(PIM2(1)+PIM4(1))**2
01305  
01306       PS31=(PIM3(4)+PIM1(4))**2-(PIM3(3)+PIM1(3))**2
01307      %    -(PIM3(2)+PIM1(2))**2-(PIM3(1)+PIM1(1))**2
01308  
01309       PS34=(PIM3(4)+PIM4(4))**2-(PIM3(3)+PIM4(3))**2
01310      %    -(PIM3(2)+PIM4(2))**2-(PIM3(1)+PIM4(1))**2
01311  
01312  
01313  
01314       PD324=PIM3(4)*(PIM2(4)-PIM4(4))-PIM3(3)*(PIM2(3)-PIM4(3))
01315      %     -PIM3(2)*(PIM2(2)-PIM4(2))-PIM3(1)*(PIM2(1)-PIM4(1))
01316  
01317       PD314=PIM3(4)*(PIM1(4)-PIM4(4))-PIM3(3)*(PIM1(3)-PIM4(3))
01318      %     -PIM3(2)*(PIM1(2)-PIM4(2))-PIM3(1)*(PIM1(1)-PIM4(1))
01319  
01320       PD234=PIM2(4)*(PIM3(4)-PIM4(4))-PIM2(3)*(PIM3(3)-PIM4(3))
01321      %     -PIM2(2)*(PIM3(2)-PIM4(2))-PIM2(1)*(PIM3(1)-PIM4(1))
01322  
01323       PD214=PIM2(4)*(PIM1(4)-PIM4(4))-PIM2(3)*(PIM1(3)-PIM4(3))
01324      %     -PIM2(2)*(PIM1(2)-PIM4(2))-PIM2(1)*(PIM1(1)-PIM4(1))
01325  
01326       PD134=PIM1(4)*(PIM3(4)-PIM4(4))-PIM1(3)*(PIM3(3)-PIM4(3))
01327      %     -PIM1(2)*(PIM3(2)-PIM4(2))-PIM1(1)*(PIM3(1)-PIM4(1))
01328  
01329       PD124=PIM1(4)*(PIM2(4)-PIM4(4))-PIM1(3)*(PIM2(3)-PIM4(3))
01330      %     -PIM1(2)*(PIM2(2)-PIM4(2))-PIM1(1)*(PIM2(1)-PIM4(1))
01331  
01332 C DEFINE Q*PI = QPI:
01333  
01334       QP1=PIM1(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
01335      %   -PIM1(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
01336      %   -PIM1(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
01337      %   -PIM1(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))
01338  
01339       QP2=PIM2(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
01340      %   -PIM2(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
01341      %   -PIM2(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
01342      %   -PIM2(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))
01343  
01344       QP3=PIM3(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
01345      %   -PIM3(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
01346      %   -PIM3(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
01347      %   -PIM3(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))
01348  
01349       QP4=PIM4(4)*(PIM1(4)+PIM2(4)+PIM3(4)+PIM4(4))
01350      %   -PIM4(3)*(PIM1(3)+PIM2(3)+PIM3(3)+PIM4(3))
01351      %   -PIM4(2)*(PIM1(2)+PIM2(2)+PIM3(2)+PIM4(2))
01352      %   -PIM4(1)*(PIM1(1)+PIM2(1)+PIM3(1)+PIM4(1))
01353  
01354  
01355 C DEFINE T(PI;PJ,PK)= TIJK:
01356  
01357       T324=BWIGA1(QMP3)*FPIKM(SQRT(PS24),AMPI,AMPI)*GAMMA1
01358       T314=BWIGA1(QMP3)*FPIKM(SQRT(PS14),AMPI,AMPI)*GAMMA1
01359       T234=BWIGA1(QMP2)*FPIKM(SQRT(PS34),AMPI,AMPI)*GAMMA1
01360       T214=BWIGA1(QMP2)*FPIKM(SQRT(PS14),AMPI,AMPI)*GAMMA1
01361       T134=BWIGA1(QMP1)*FPIKM(SQRT(PS34),AMPI,AMPI)*GAMMA1
01362       T124=BWIGA1(QMP1)*FPIKM(SQRT(PS24),AMPI,AMPI)*GAMMA1
01363  
01364 C DEFINE S(I,J;K,L)= SIJKL:
01365  
01366       S1423=FRHO4(SQRT(PS14),AMPI,AMPI)*BWIGEPS(PS23)*GAMMA2
01367       S2431=FRHO4(SQRT(PS24),AMPI,AMPI)*BWIGEPS(PS31)*GAMMA2
01368       S3421=FRHO4(SQRT(PS34),AMPI,AMPI)*BWIGEPS(PS21)*GAMMA2
01369  
01370  
01371 C DEFINITION OF AMPLITUDE, FIRST THE [] BRACKETS:
01372  
01373       BRACK1=T234+T324+2.*T314+T134+2.*T214+T124
01374      %    +T134*PD234/QMP1+T124*PD324/QMP1
01375      %    -3./2.*(S3421+S2431+2.*S1423)
01376  
01377  
01378       BRACK2=T234*(1.+2.*PD134/QMP2)+3.*T324+3.*T124
01379      %    +T134*(1.-PD234/QMP1)+2.*T214*PD314/QMP2
01380      %    -T124*PD324/QMP1
01381      %    -3./2.*(S3421+3.*S2431)
01382  
01383       BRACK3=T324*(1.+2.*PD124/QMP3)+3.*T234+3.*T134
01384      %    +T124*(1.-PD324/QMP1)+2.*T314*PD214/QMP3
01385      %    -T134*PD234/QMP1
01386      %    -3./2.*(3.*S3421+S2431)
01387  
01388       BRACK4A=2.*T234*(1./2.+PD134/QQ*(QP2/QMP2+1.)+PD234/QQ)
01389      %     +2.*T324*(1./2.+PD124/QQ*(QP3/QMP3+1.)+PD324/QQ)
01390      %     +2.*T134*(1./2.+PD234/QQ*(QP1/QMP1+1.)
01391      %              -1./2.*PD234/QMP1+PD134/QQ)
01392      %     +2.*T124*(1./2.+PD324/QQ*(QP1/QMP1+1.)
01393      %              -1./2.*PD324/QMP1+PD124/QQ)
01394      %     +2.*T214*(PD314/QQ*(QP2/QMP2+1.)+PD214/QQ)
01395      %     +2.*T314*(PD214/QQ*(QP3/QMP3+1.)+PD314/QQ)
01396  
01397       BRACK4B=-3./2.*(S3421*(2.*(QP3-QP4)/QQ+1.)
01398      %             +S2431*(2.*(QP2-QP4)/QQ+1.)
01399      %             +S1423*2.*(QP1-QP4)/QQ)
01400  
01401  
01402       BRACK4=BRACK4A+BRACK4B
01403  
01404       DO 308 K=1,4
01405  
01406       HCOMP1(K)=(PIM1(K)-PIM4(K))*BRACK1
01407       HCOMP2(K)=PIM2(K)*BRACK2
01408       HCOMP3(K)=PIM3(K)*BRACK3
01409       HCOMP4(K)=(PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K))*BRACK4
01410  
01411  308  CONTINUE
01412  
01413       DO 309 I=1,4
01414  
01415       HADCUR(I)=HCOMP1(I)+HCOMP2(I)+HCOMP3(I)-HCOMP4(I)
01416       HADCUR(I)=COEF1*FRHO4(SQRT(QQ),AMPI,AMPI)*HADCUR(I)
01417  
01418  309  CONTINUE
01419  
01420  101   CONTINUE
01421       ENDIF
01422 C M. Finkemeier et al. END
01423       END
01424 #endif