/***************************************************************************
**
**  This file is part of QGpCoreWave.
**
**  This library is free software; you can redistribute it and/or
**  modify it under the terms of the GNU Lesser General Public
**  License as published by the Free Software Foundation; either
**  version 2.1 of the License, or (at your option) any later version.
**
**  This file is distributed in the hope that it will be useful, but WITHOUT
**  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
**  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
**  License for more details.
**
**  You should have received a copy of the GNU Lesser General Public
**  License along with this library; if not, write to the Free Software
**  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
**
**  See http://www.geopsy.org for more information.
**
**  Created: 2004-04-28
**  Copyright: 2004-2019
**    Marc Wathelet
**    Marc Wathelet (ULg, Liège, Belgium)
**    Marc Wathelet (LGIT, Grenoble, France)
**
***************************************************************************/

#include <math.h>
#include <stdlib.h>

#include <QGpCoreTools.h>
#include "Rayleigh.h"

namespace QGpCoreWave {

#define twopi (2*M_PI)

/*!
  \class RayleighTemplate
  \brief Implementation of Rayleigh surface waves

  It is a layered model able to calculate the roots corresponding
  to the theoretical Rayleigh dispersion curve.
*/

/*!
  \fn double RayleighTemplate::ellipticity(double)
  Return the ellipticity for current frequency (omega).
  Once y(slowness) has been run through a solve() call, you can call this
  function to get the ellipticity, ratio of eigenfunctions for vertical and
  horizontal components.\n
*/

/*!
  \fn double RayleighTemplate::y(double)
  Calculates the Rayleigh surface wave equation.
  This function is automatically called by the Neville Solver.
  Implementation of Dunkin's method (BSSA 1965), almost the same as Herrmann.
  Modification of the formulation by the author of this C++ class to optimize
  the CPU time needed.

  Normally called only by the root solver.\n
*/

//#define RAYLEIGH_EXPERIMENTAL_Ys
#ifdef RAYLEIGH_EXPERIMENTAL_Ys
/*
  Compute the ellipticity from the full matrix form
*/
double RayleighTemplate::aki_y(double slowness)
{
  TRACE;
  //#define y_debug
  /*
      w(n+1)=F(n+1)^(-1)*P(z(n),z(0))*r(z(0))=B*r(z(0))
      Only the lines 3 and 4 are necessary to solve the modal condition:
      B(3,1)*B(4,2)-B(4,1)*B(3,2)=0
  */
  double k=_omega*slowness;
  double k2=k*k;
  double inv_omega2=1.0/(_omega*_omega);
  int i=_n-1;
  // The search algorithm will never produce a kb*kb>k2
  // B matrix for the bottom half-space (i=_n-1)
  // Eq 7.56, without the constant factor and diagonal matrix
  double ka=_omega*_slowP[i];
  double kb=_omega*_slowS[i];
  double gam=sqrt(fabs(k2-ka*ka));
  double nu=sqrt(fabs(k2-kb*kb));
  double gamnu=gam*nu;
  double k2nu2=k2+nu*nu;
  double beta=1.0/_slowS[i];
  double alpha=1.0/_slowP[i];
  double inv_mu=1.0/_mu[i];
  double B31=2.0*beta*k*gamnu;
  double B32=beta*nu*k2nu2;
  double B33=beta*k*nu*inv_mu;
  double B34=beta*gamnu*inv_mu;
  double B41=-alpha*gam*k2nu2;
  double B42=-2.0*alpha*k*gamnu;
  double B43=-alpha*gamnu*inv_mu;
  double B44=-alpha*k*gam*inv_mu;
  // Compute the propagator matrix for each layer and multiply it with B
  for(i--;i>=0;i--) {
    ka=_omega*_slowP[i];
    kb=_omega*_slowS[i];
    // The search algorithm will never produce a kb*kb>k2
    gam=sqrt(fabs(k2-ka*ka));
    nu=sqrt(fabs(k2-kb*kb));
    k2nu2=k2+nu*nu;
    double gamDz=gam*_h[i];
    double nuDz=nu*_h[i];
    // Compute the sinh (...)
    // For alpha alias gamma
    double expGam;
    double sinhGam2, sinhGamDivGam,sinhGamMulGam;
    if(k<ka) {
      expGam=1;
      double sinhGam=sin(gamDz);
      double tmp=sin(0.5*gamDz);
      sinhGam2=-tmp*tmp;
      sinhGamDivGam=sinhGam/gam;
      sinhGamMulGam=-gam*sinhGam;
    }
    else if(k==ka) {
      expGam=1;
      sinhGam2=0;
      sinhGamDivGam=_h[i];
      sinhGamMulGam=0;
    }
    else {
      double sinhGam;
      if(gamDz<16) {
        expGam=exp(-gamDz);
        sinhGam=0.5*(1-expGam*expGam);
        double tmp=1-expGam;
        sinhGam2=0.25*tmp*tmp;
      }
      else {
        expGam=0;
        sinhGam=0.5;
        sinhGam2=0.25;
      }
      sinhGamDivGam=sinhGam/gam;
      sinhGamMulGam=gam*sinhGam;
    }
    // For b�ta alias nu
    double sinhNu2,sinhNuDivNu,sinhNuMulNu;
    if(k<kb) {
      double sinhNu=expGam*sin(nuDz);
      double tmp=sin(0.5*nuDz);
      sinhNu2=-expGam*tmp*tmp;
      sinhNuDivNu=sinhNu/nu;
      sinhNuMulNu=-nu*sinhNu;
    }
    else if(k==kb) {
      sinhNu2=0;
      sinhNuDivNu=_h[i];
      sinhNuMulNu=0;
    }
    else {
      double sinhNu;
      double nuDzPos=nuDz-gamDz; 
      if(nuDzPos>-16) {
        double expNuPos=exp(0.5*nuDzPos);
        double nuDzNeg=-nuDz-gamDz; 
        if(nuDzNeg>-16) {
          double expNuNeg=exp(0.5*nuDzNeg);
          sinhNu=0.5*(expNuPos*expNuPos-expNuNeg*expNuNeg);
          double tmp=expNuPos-expNuNeg;
          sinhNu2=0.25*tmp*tmp;
        }
        else {
          sinhNu=0.5*expNuPos*expNuPos;
          sinhNu2=0.5*sinhNu;  
        }
      }
      else {
        sinhNu=0;
        sinhNu2=0;
      }
      sinhNuDivNu=sinhNu/nu; 
      sinhNuMulNu=nu*sinhNu;
    }

    double mu=_mu[i];
    double mu2=mu*mu;
    double c=inv_omega2/_rho[i];
    double muc=mu*c;
    double mu2c=mu2*c;
    double kmuc=k*muc;
    double k2nu2sq=k2nu2*k2nu2;
    // Compute propagator matrix
    double P11=expGam+2*muc*(2*k2*sinhGam2-k2nu2*sinhNu2);
    double P12=kmuc*(k2nu2*sinhGamDivGam-2*sinhNuMulNu);
    double P13=c*(k2*sinhGamDivGam-sinhNuMulNu);
    double P14=2*k*c*(sinhGam2-sinhNu2);
    double P21=kmuc*(k2nu2*sinhNuDivNu-2*sinhGamMulGam);
    double P22=expGam+2*muc*(2*k2*sinhNu2-k2nu2*sinhGam2);
    // P23=-P14
    double P24=c*(k2*sinhNuDivNu-sinhGamMulGam);
    double P31=mu2c*(4*k2*sinhGamMulGam-k2nu2sq*sinhNuDivNu);
    double P32=2*mu2*k2nu2*P14;
    // P33=P11
    // P34=-P21
    // P41=-P32
    double P42=mu2c*(4*k2*sinhNuMulNu-k2nu2sq*sinhGamDivGam);
    // P43=-P12
    // P44=P22
    double R31=B31*P11+B32*P21+B33*P31-B34*P32;
    double R32=B31*P12+B32*P22+B33*P32+B34*P42;
    double R33=B31*P13-B32*P14+B33*P11-B34*P12;
    double R34=B31*P14+B32*P24-B33*P21+B34*P22;
    double R41=B41*P11+B42*P21+B43*P31-B44*P32;
    double R42=B41*P12+B42*P22+B43*P32+B44*P42;
    double R43=B41*P13-B42*P14+B43*P11-B44*P12;
    double R44=B41*P14+B42*P24-B43*P21+B44*P22;
    //  Normalize R before copying to B
    double maxR=0;
    if(R31>maxR) maxR=R31;
    if(R32>maxR) maxR=R32;
    if(R33>maxR) maxR=R33;
    if(R34>maxR) maxR=R34;
    if(R41>maxR) maxR=R41;
    if(R42>maxR) maxR=R42;
    if(R43>maxR) maxR=R43;
    if(R44>maxR) maxR=R44;
    maxR=1.0/maxR;
    B31=R31*maxR;
    B32=R32*maxR;
    B33=R33*maxR;
    B34=R34*maxR;
    B41=R41*maxR;
    B42=R42*maxR;
    B43=R43*maxR;
    B44=R44*maxR;
  }
  //return -B32/B31;
  return B31*B42-B41*B32;
}

double RayleighSlowness::herrmann_y(double slowness)
{
  TRACE;
  // Haskell-Thompson rayleigh wave formulation from halfspace to surface
  // We keep the notations of the Herrmann's code
  // These element must be initialized by:
  double inv_omega=1/_omega;
  // Herrmann checks that omega > 1.0e-4, in our case it is useless since period and slowness are always bounded when this program runs normally.
  double wvno=_omega*slowness;
  double wvno2=wvno*wvno;
  int i=_n-1;
  // E matrix for the bottom half-space (i=_n-1)
  double xka=_omega*_slowP[i];
  double xkb=_omega*_slowS[i];
  double ra=sqrt(fabs(wvno2-xka*xka));
  double rb=sqrt(fabs(wvno2-xkb*xkb));
  // ra corresponds to gamma in Aki, rb to nu
  double t=inv_omega/_slowS[i];
  double gammk=2.0*t*t;
  double gam=gammk*wvno2;
  double gamm1=gam - 1.0;
  double rho1=_rho[i];
  double ee[5], _e[5];
  _e[0]=rho1*rho1*(gamm1*gamm1-gam*gammk*ra*rb);
  _e[1]=-rho1*ra;
  _e[2]=rho1*(gamm1-gammk*ra*rb);
  _e[3]=rho1*rb;
  _e[4]=wvno2-ra*rb;
  // matrix multiplication from bottom layer upwards
  for(i--;i>=0;i--)
    {
      double slowS=_slowS[i];
      xka=_omega*_slowP[i];
      xkb=_omega*slowS;
      t=inv_omega/slowS;
      gammk=2.0*t*t;
      gam= gammk*wvno2;
      ra=sqrt(fabs(wvno2-xka*xka));
      rb=sqrt(fabs(wvno2-xkb*xkb));
      double dpth=_h[i];
      rho1=_rho[i];
      double p=ra*dpth;
      double q=rb*dpth;
      // evaluate cosP, cosQ,.... in var.

      // ___________________________________________________________
      //
      // FUNCTION VAR
      //

      // find variables cosP, cosQ, sinP, sinQ, etc.
      // as well as cross products required for compound matrix

      // To handle the hyperbolic functions correctly for large
      // arguments, we use an extended precision procedure,
      // keeping in mind that the maximum precision in double
      // precision is on the order of 16 decimal places.
      //
      // So  cosp=0.5 (exp(+p) + exp(-p))
      //         =exp(p) * 0.5 * (1.0 + exp(-2p))
      // becomes
      //     cosp=0.5 * (1.0 + exp(-2p)) with an exponent p
      // In performing matrix multiplication, we multiply the modified
      // cosp terms and add the exponents. At the last step
      // when it is necessary to obtain a true amplitude,
      // we then form exp(p). For normalized amplitudes at any depth,
      // we carry an exponent for the numerator and the denominator, and
      // scale the resulting ratio by exp(NUMexp - DENexp)
      //
      // The propagator matrices have three basic terms
      //
      // HSKA        cosp  cosq
      // DUNKIN      cosp*cosq     1.0
      //
      // When the extended floating point is used, we use the
      // largest exponent for each, which is  the following:
      //
      // Let pex=p exponent > 0 for evanescent waves=0 otherwise
      // Let sex=s exponent > 0 for evanescent waves=0 otherwise
      // Let exa=pex + sex
      //
      // Then the modified matrix elements are as follow:
      //
      // Haskell:  cosp -> 0.5 (1 + exp(-2p)) exponent=pex
      //           cosq -> 0.5 (1 + exp(-2q)) * exp(q-p)
      //                                        exponent=pex
      //        (this is because we are normalizing all elements in the
      //         Haskell matrix)
      // Compound:
      //          cosp * cosq -> normalized cosp * cosq exponent=pex + qex
      //           1.0  ->    exp(-exa)

      // examine P-wave eigenfunctions
      // checking whether c>vp, c=vp or c<vp

      double pex=0.0;
      double sex=0.0;
      double sinp, cosp,w,x;
      double sinq, cosq,y,z;
      double fac;
      double a0,cpcq,cpy,cpz,cqw,cqx,xy,xz,wy,wz;
      {
 if(wvno<xka)
   {
     sinp=sin(p);
     w=sinp/ra;
     x=-ra*sinp;
     cosp=cos(p);
   }
 else if(wvno==xka)
   {
     cosp=1.0;
     w=dpth;
     x=0.0;
   }
 else
   {
     pex=p;
     double fac=0.0;
     if(p<16) fac=exp(-2.0*p);
     cosp=(1.0 + fac) * 0.5;
     sinp=(1.0 - fac) * 0.5;
     w=sinp/ra;
     x=ra*sinp;
   }

 // examine S-wave eigenfunctions
 // checking whether c>vs, c=vs or c<vs

 if(wvno<xkb)
   {
     sinq=sin(q);
     y=sinq/rb;
     z=-rb*sinq;
     cosq=cos(q);
   }
 else if(wvno==xkb)
   {
     cosq=1.0;
     y=dpth;
     z=0.0;
   }
 else
   {
     sex=q;
     fac=0.0;
     if(q<16) fac=exp(-2.0*q);
     cosq=(1.0 + fac) * 0.5;
     sinq=(1.0 - fac) * 0.5;
     y=sinq/rb;
     z=rb*sinq;
   }

 // form eigenfunction products for use with compound matrices

 double exa=pex + sex;
 a0=0.0;
 if(exa<60.0) a0=exp(-exa);
 cpcq=cosp*cosq;
 cpy=cosp*y;
 cpz=cosp*z;
 cqw=cosq*w;
 cqx=cosq*x;
 xy=x*y;
 xz=x*z;
 wy=w*y;
 wz=w*z;
 double qmp=sex - pex;
 fac=0.0;
 if(qmp>-40.0) fac=exp(qmp);
 cosq=cosq*fac;
 y=fac*y;
 z=fac*z;
      }
      //
      //END of function VAR
      // ___________________________________________________________

      // evaluate Dunkin's matrix in dnka.
      // ___________________________________________________________
      //
      // FUNCTION DNKA
      //
      double ca[5][5];
      {
 double gamm1=gam-1.0;
 double twgm1=gam+gamm1;
 double gmgmk=gam*gammk;
 double gmgm1=gam*gamm1;
 double gm1sq=gamm1*gamm1;
 double rho2=rho1*rho1;
 double a0pq=a0-cpcq;
 ca[0][0]=cpcq-2.0*gmgm1*a0pq-gmgmk*xz-wvno2*gm1sq*wy;
 ca[0][1]=(wvno2*cpy-cqx)/rho1;
 ca[0][2]=-(twgm1*a0pq+gammk*xz+wvno2*gamm1*wy)/rho1;
 ca[0][3]=(cpz-wvno2*cqw)/rho1;
 ca[0][4]=-(2.0*wvno2*a0pq+xz+wvno2*wvno2*wy)/rho2;
 ca[1][0]=(gmgmk*cpz-gm1sq*cqw)*rho1;
 ca[1][1]=cpcq;
 ca[1][2]=gammk*cpz-gamm1*cqw;
 ca[1][3]=-wz;
 ca[1][4]=ca[0][3];
 ca[3][0]=(gm1sq*cpy-gmgmk*cqx)*rho1;
 ca[3][1]=-xy;
 ca[3][2]=gamm1*cpy-gammk*cqx;
 ca[3][3]=ca[1][1];
 ca[3][4]=ca[0][1];
 ca[4][0]=-(2.0*gmgmk*gm1sq*a0pq+gmgmk*gmgmk*xz+ gm1sq*gm1sq*wy)*rho2;
 ca[4][1]=ca[3][0];
 ca[4][2]=-(gammk*gamm1*twgm1*a0pq+gam*gammk*gammk*xz+gamm1*gm1sq*wy)*rho1;
 ca[4][3]=ca[1][0];
 ca[4][4]=ca[0][0];
 t=-2.0*wvno2;
 ca[2][0]=t*ca[4][2];
 ca[2][1]=t*ca[3][2];
 ca[2][2]=a0+2.0*(cpcq-ca[0][0]);
 ca[2][3]=t*ca[1][2];
 ca[2][4]=t*ca[0][2];
      }      
      //
      //END of function DNKA
      // ___________________________________________________________

  int ii;
  for(ii=0;ii<5;ii++) {
      double cr=0.0;
      for(int j=0;j<5;j++)
   cr=cr+_e[j]*ca[j][ii];
      ee[ii]=cr;
  }

      // ___________________________________________________________
      //
      // FUNCTION NORMC
      //
      {
 double t1=0.0;
  int i;
 for(i=0;i<5;i++)
   if(fabs(ee[i])>t1) t1=fabs(ee[i]);
   
 if(t1<1.0e-40) t1=1.0;
 double t2=1/t1;
 for(i=0;i<5;i++)
     ee[i]*=t2;
      }
      //
      //END of function NORMC
      // ___________________________________________________________

      for(ii=0;ii<5;ii++)
 _e[ii]=ee[ii];
    }
  return _e[0];
}

// Dunkin method (BSSA 1965) - anelastic case
double RayleighSlowness::y_Q(double slowness)
{
  TRACE;
  // se=slowness elastic case
  // s =slowness in anelastic case (real value)
  // se is replaced by s*(1+i/(2*M_PI*Q)
  double valueQ=25; // set here in constant for experimental purposes
  double w2=_omega*_omega;
  Complex k(slowness,slowness/(2*M_PI*valueQ));
  k*=(_omega);
  Complex k2(k);
  k2*=k;
  Complex inv_k2(k2);
  inv_k2.inverse();
  double inv_w2=1.0/w2;
  // Half space
  int i=_n-1;
  double ka=_omega*_slowP[i];
  Complex hn2(k2);
  hn2-=ka*ka;
  Complex hn(hn2.sqrt());
  double kb=_omega*_slowS[i];
  Complex kn2(k2);
  kn2-=kb*kb;
  Complex kn(kn2.sqrt());
  Complex ln(k2+kn2);
  double mu=_mu[i];
  Complex c1(hn*kn);
  Complex F1212((ln*ln-k2*c1*4)*(mu*inv_w2));
  Complex F1213((ln-k2*2)*hn);
  Complex iF1214((ln-c1*2)*k);
  Complex iF1223(iF1214);
  Complex F1224(kn*(k2*2-ln));
  Complex F1234((k2-c1)/mu);
  for(i--;i>=0;i--) {
    ka=_omega*_slowP[i];
    hn2=k2-ka*ka;
    hn=hn2.sqrt();
    hn2*=inv_k2;
    kb=_omega*_slowS[i];
    kn2=k2-kb*kb;
    kn=kn2.sqrt();
    kn2*=inv_k2;
    /* STILL WORK TO DO TO TRANSFORM ALL IN COMPLEX
    // Compute the hyperbolic sin and cos
    double SH, CH,he;
    double dn=_h[i];
    Complex exphn(hn*dn);
    if(hn2>0) {
      he=exphn;
      double exp2;
      if(exphn<16) {
        exphn=exp(-exphn);
        exp2=exphn*exphn;
      }
      else {
        exphn=0;
        exp2=0;
      }
      SH=0.5*k/hn*(1-exp2);
      CH=0.5*(1+exp2);
    }
    else if(hn2<0) {
      he=0;
      // sinh is imaginary but hn as well, thus SH is real
      SH=k/hn*sin(exphn);
      CH=cos(exphn);
      exphn=1;
    }
    else {
      he=0;
      SH=0;
      CH=1;
      exphn=1;
    }
    double SK, CK, ke;
    double expkn=kn*dn;
    if(kn2>0) {
      ke=expkn;
      double exp2;
      if(expkn<16) {
        expkn=exp(-expkn);
        exp2=expkn*expkn;
      }
      else {
        expkn=0;
        exp2=0;
      }
      SK=0.5*k/kn*(1-exp2);
      CK=0.5*(1+exp2);
    }
    else if(kn2<0) {
      ke=0;
      // sinh is imaginary but kn as well, thus SK is real
      SK=k/kn*sin(expkn);
      CK=cos(expkn);
      expkn=1;
    }
    else {
      ke=0;
      SK=0;
      CK=1;
      expkn=1;
    }
    // In G, all terms that does not contains either CHCK,... we must multiply by expCorr
    double expCorr=exphn*expkn;
    // Each cosh or sinh has to be multiplied by either exp(he) or exp(ke)
    // he is always > ke, thus exp(he)>exp(ke).
    // In each term, CHCK, CHSK, ... there is a factor exp(he+ke)
    double CHCK=CH*CK;
    double SHSK=SH*SK;
    double CHSK=CH*SK;
    double SHCK=SH*CK;
    // CHCK is always real
    // Other may be imaginary or complex
    // Intermediate variable, avoid dupplicate operations
    double gn=2*k2/(kb*kb);
    double gn2=gn*gn;
    double adim1=gn2-2*gn+1;
    double adim2=hn2*kn2;
    double adim3=gn2+adim1;
    double adim4=1-gn;
    double adim5=gn2*adim2;
    double CHCK1=expCorr-CHCK;
    double CHCK2=CHCK1+CHCK1;
    double SHCK1=gn*hn2*SHCK;
    c1= _rho[i]*w2/k;
    double c2=1.0/c1;

    // Second order subdeterminants of propagator matrix
    // i means that the subdeterminant is imaginary
    double G1212=adim3*CHCK-(adim1+adim5)*SHSK-(adim3-1)*expCorr;
    double G1213=c2*(CHSK-hn2*SHCK);
    double iG1214=c2*((adim1-gn2)*CHCK1+(adim4-gn*adim2)*SHSK);
    // iG1223=iG1214
    double G1224=c2*(kn2*CHSK-SHCK);
    double G1234=c2*c2*(CHCK2+(1+adim2)*SHSK);
    double G1312=c1*(gn2*kn2*CHSK-adim1*SHCK);
    // G1313=CHCK
    double iG1314=adim4*SHCK+gn*kn2*CHSK;
    // iG1323=iG1314
    double G1324=kn2*SHSK;
    // G1334=G1224
    double iG1412=c1*((adim1-adim4)*(adim4-gn)*CHCK1+(adim4*adim1-gn*adim5)*SHSK);
    double iG1413=SHCK1+adim4*CHSK;
    // G1414 defined after G1423
    double G1423=CHCK-G1212;
    // G1414=expCorr+G1423;
    // iG1424=iG1314
    // iG1434=iG1214
    // iG2312=iG1412
    // iG2313=iG1413
    // G2314=G1423
    // G2323=G1414
    // iG2324=iG1314
    // iG2334=iG1214
    double G2412= c1*(adim1*CHSK-gn*SHCK1);
    double G2413=hn2*SHSK;
    // iG2414=iG1413
    // iG2423=iG1413
    // G2424=G1313
    // G2434=G1213
    double G3412=c1*c1*(gn2*adim1*CHCK2+(adim1*adim1+gn2*adim5)*SHSK);
    // G3413=G2412
    // iG3414=iG1412
    // iG3423=iG1412
    // G3424=G1312
    // G3434=G1212

    // Multiplication R=Current F*G
    // Temp variable for complex terms
    double comp12=iF1214*iG1412;
    double comp13=iF1214*iG1413;
    double comp24=iF1214*iG1314;
    double comp34=iF1214*iG1214;

    // double R12cd=F1212*G12cd+F1213*G13cd+F1214*G14cd+F1223*G23cd+F1224*G24cd+F1234*G34cd;

    // double R1212=F1212*G1212                +F1213*G1312+F1214*G1412+F1223*G2312+F1224*G2412+F1234*G3412;
    double R1212=   F1212*G1212+inv_w2*(F1213*G1312-comp12             -comp12           +F1224*G2412-F1234*G3412);

    // double R1213=       F1212*G1213+F1213*G1313+F1214*G1413+F1223*G2313+F1224*G2413+F1234*G3413;
    double R1213=   w2*F1212*G1213+F1213*CHCK +comp13            +comp13            -F1224*G2413+F1234*G2412;

    // double R1214=       F1212*G1214 +F1213*G1314 +F1214*G1414+F1223*G2314       +F1224*G2414 +F1234*G3414;
    double iR1214=  w2*F1212*iG1214+F1213*iG1314+iF1214*(G1423+G1423+expCorr)-F1224*iG1413+F1234*iG1412;

    // double R1223=R1214;

    // double R1224=       F1212*G1224+F1213*G1324+F1214*G1424+F1223*G2324+F1224*G2424+F1234*G3424;
    double R1224=   w2*F1212*G1224 -F1213*G1324-comp24            -comp24            +F1224*CHCK +F1234*G1312;

    // double R1234=F1212*G1234      +F1213*G1334+F1214*G1434+F1223*G2334+F1224*G2434+F1234*G3434;
    double R1234=   F1213*G1224-w2*F1212*G1234  -comp34            -comp34           +F1224*G1213+F1234*G1212;

    //  Normalize R before copying to F
    double maxR=0;
    if(fabs(R1212)>maxR) maxR=fabs(R1212);
    if(fabs(R1213)>maxR) maxR=fabs(R1213);
    if(fabs(iR1214)>maxR) maxR=fabs(iR1214);
    if(fabs(R1224)>maxR) maxR=fabs(R1224);
    if(fabs(R1234)>maxR) maxR=fabs(R1234);
    if(maxR>1.0e-40) {
      maxR=1.0/maxR;
      F1212=R1212*maxR;
      F1213=R1213*maxR;
      iF1214=iR1214*maxR;
      F1224=R1224*maxR;
      F1234=R1234*maxR;
    }
    else {
      F1212=R1212;
      F1213=R1213;
      iF1214=iR1214;
      F1224=R1224;
      F1234=R1234;
    }
    */
  }
  return F1212.abs();
}
#endif // RAYLEIGH_EXPERIMENTAL_Ys

} // namespace QGpCoreWave
