Module ThreeBodyPhaseSpaceS
! comments
!-----------------------------------------------------------
! contains the phase space function needed for 3-body decays
! involving fermions and bosons in intial and/or final state
! 16.08.2012: adding contributions by Lukas Mitzka
!-----------------------------------------------------------

! load modules
Use Control
Use Mathematics, Only: Kappa, DGaussInt
! load modules

Real(dp), Private ::  rmt2, rjt2, rat2, rbt2, rkt2, Rsquared

Contains

!!!!!
!Integration Routine for the Slepton charge chaning channel
 Subroutine ChiChiInterfIntegrands(s, erg)
 Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(8)

  Integer :: i1

  Real(dp) :: x, x2, yplus, yminus, fOnexrarb, fTwoxrarb, l1abbr, kabbr

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   yplus = 1._dp / ( 2._dp * ( 1 - x + rkt2 ) )                               &
      &    * ( (2._dp-x) * (Rsquared - x) + Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )
   yminus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                          &
      &    * ( (2._dp-x) * (Rsquared - x) - Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )

   l1abbr =      Log( Abs(  ( yplus  + rbt2 - 1._dp - rmt2 )         &
            &             / ( yminus + rbt2 - 1._dp - rmt2 )   ) )

   kabbr = (   yplus - yminus  ) / ( 1._dp - x + rkt2 -rat2 )

   fOnexrarb = - l1abbr / ( 1._dp - x + rkt2 - rat2  )

   fTwoxrarb = ( 1._dp + rmt2 -rbt2 )*fOnexrarb - kabbr

   erg(1) = erg(1) + (-rjt2 + rkt2 + rmt2 - 1._dp)*fOnexrarb

   erg(2) = erg(2) + (-rkt2 + x - 1._dp )*fTwoxrarb                           &
                &  + (-rjt2 + rkt2*(2._dp*rmt2 + 1._dp)                       &
                &  -  (rmt2 + 1._dp)*(x - 1._dp)    )*fOnexrarb

   erg(3) = erg(3) + (-rjt2 + rkt2 + rmt2 + 1._dp - x)*fOnexrarb

   erg(4) = erg(4) + (2._dp*rkt2 - x )*fOnexrarb

   erg(5) = erg(5) + fTwoxrarb + (rjt2 - rkt2 - rmt2 - 1._dp)*fOnexrarb

   erg(6) = erg(6) + fTwoxrarb - 2._dp*rmt2*fOnexrarb

   erg(7) = erg(7) + ( rjt2 - rkt2 - rmt2 - 1._dp + x)*fOnexrarb + fTwoxrarb

   erg(8) = erg(8) + fOnexrarb

  End Do

 End Subroutine ChiChiInterfIntegrands

 Subroutine IntegrateChiChiInterference(mass,m_in,r_out,coup,smin,smax,eps,gam)
 Implicit None

  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_ChiaChibInterf(8)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = ( mass(1) / m_in )**2
  rbt2 = ( mass(2) / m_in )**2
  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DGaussInt(ChiChiInterfIntegrands,8,smin,smax,I_ChiaChibInterf(:),eps)
  I_ChiaChibInterf(1) = Sqrt(rkt2*rmt2)*I_ChiaChibInterf(1)
  I_ChiaChibInterf(3) = Sqrt(rkt2*rbt2)*I_ChiaChibInterf(3)
  I_ChiaChibInterf(4) = Sqrt(rmt2*rbt2)*I_ChiaChibInterf(4)
  I_ChiaChibInterf(5) = Sqrt(rmt2*rat2)*I_ChiaChibInterf(5)
  I_ChiaChibInterf(6) = Sqrt(rkt2*rat2)*I_ChiaChibInterf(6)
  I_ChiaChibInterf(7) = Sqrt(rat2*rbt2)*I_ChiaChibInterf(7)
  I_ChiaChibInterf(8) = - 2._dp*Sqrt(rat2*rbt2*rkt2*rmt2)*I_ChiaChibInterf(8)

  gam = ( coup(1) * coup(4) * Conjg(coup(7) * coup(6))                         &
    &   + coup(2) * coup(3) * Conjg(coup(8) * coup(5)) ) * I_ChiaChibInterf(1) &
    & + ( coup(1) * coup(4) * Conjg(coup(8) * coup(5))                         &
    &   + coup(2) * coup(3) * Conjg(coup(7) * coup(6)) ) * I_ChiaChibInterf(2) &
    & + ( coup(1) * coup(4) * Conjg(coup(8) * coup(6))                         &
    &   + coup(2) * coup(3) * Conjg(coup(7) * coup(5)) ) * I_ChiaChibInterf(3) &
    & + ( coup(1) * coup(4) * Conjg(coup(7) * coup(5))                         &
    &   + coup(2) * coup(3) * Conjg(coup(8) * coup(6)) ) * I_ChiaChibInterf(4) &
    & + ( coup(1) * coup(3) * Conjg(coup(8) * coup(5))                         &
    &   + coup(2) * coup(4) * Conjg(coup(7) * coup(6)) ) * I_ChiaChibInterf(5) &
    & + ( coup(1) * coup(3) * Conjg(coup(7) * coup(6))                         &
    &   + coup(2) * coup(4) * Conjg(coup(8) * coup(5)) ) * I_ChiaChibInterf(6) &
    & + ( coup(1) * coup(3) * Conjg(coup(7) * coup(5))                         &
    &   + coup(2) * coup(4) * Conjg(coup(8) * coup(6)) ) * I_ChiaChibInterf(7) &
    & + ( coup(1) * coup(3) * Conjg(coup(8) * coup(6))                         &
    &   + coup(2) * coup(4) * Conjg(coup(7) * coup(5)) ) * I_ChiaChibInterf(8)

  gam = 2._dp  *  oo512pi3  *  m_in  *  gam

 End Subroutine IntegrateChiChiInterference

 Subroutine FFIntegrands(s, erg)
 Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(6)

  Integer :: i1
  Real(dp) :: x, x2, fxrarb

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   fxrarb = Sqrt(x2-4._dp*rkt2) * kappa(1._dp-x+rkt2,rmt2,rjt2)               &
     & / ( (1._dp - x + rkt2 - rat2)                                          &
     &   * (1._dp - x + rkt2 - rbt2) * (1._dp - x + rkt2)**2  )

   erg(2) = erg(2) + (x - 2._dp * rkt2) * (Rsquared - x ) * fxrarb
   fxrarb = (1._dp - x + rkt2) * fxrarb
   erg(1) = erg(1) + (x - 2._dp * rkt2) * (Rsquared - x ) * fxrarb
   erg(3) = erg(3) + (x - 2._dp * rkt2) * fxrarb
   erg(4) = erg(4) + (Rsquared - x) * fxrarb
   erg(5) = erg(5) + fxrarb
   erg(6) = erg(6) + (1._dp - x + rkt2) * fxrarb
                          !^^the square gets lost in the redefinition of fxrarb
  End Do

 End Subroutine FFIntegrands

 Subroutine IntegrateFF(mass , m_in, r_out, coup, smin, smax, eps, gam)
 Implicit None
  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_FaFb(6),I_FaFbm(6)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = (mass(1) / m_in )**2
  rbt2 = (mass(2) / m_in )**2

  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DgaussInt(FFIntegrands,6,smin,smax,I_FaFb(:),eps)

  I_FaFbm(1) = I_FaFb(1)
  I_FaFbm(2) = Sqrt(rat2 * rbt2) * I_FaFb(2)
  I_FaFbm(3) = 4._dp * Sqrt(rmt2 * rbt2) * I_FaFb(3)
  I_FaFbm(4) = 4._dp * Sqrt(rkt2 * rbt2) * I_FaFb(4)
  I_FaFbm(5) = 8._dp * Sqrt(rkt2 * rmt2 * rat2 * rbt2) * I_FaFb(5)
  I_FaFbm(6) = 8._dp * Sqrt(rkt2 * rmt2) * I_FaFb(6)

  gam = ( Conjg( coup(1) * coup(2) ) * coup(3) * coup(4)                    &
    &   + Conjg( coup(5) * coup(6) ) * coup(7) * coup(8) ) * I_FaFbm(1)     &
    & + ( Conjg( coup(1) * coup(6) ) * coup(7) * coup(4)                    &
    &   + Conjg( coup(5) * coup(2) ) * coup(3) * coup(8) ) * I_FaFbm(2)     &
    & + Real( Conjg( coup(1) * coup(6) ) * coup(3) * coup(4)                &
    &       + Conjg( coup(5) * coup(2) ) * coup(7) * coup(8) ) * I_FaFbm(3) &
    & - Real( Conjg( coup(1) * coup(2) ) * coup(3) * coup(8)                &
    &       + Conjg( coup(5) * coup(6) ) * coup(7) * coup(4) ) * I_FaFbm(4) &
    & - Real( Conjg( coup(1) * coup(2) ) * coup(7) * coup(8) )* I_FaFbm(5)  &
    & - Real( Conjg( coup(1) * coup(6) ) * coup(3) * coup(8) )* I_FaFbm(6)

  gam = oo512pi3 * m_in * gam

 End Subroutine IntegrateFF

 Subroutine FFIntegrandsLM(s, erg)
 Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(6)

  Integer :: i1
  Real(dp) :: x, x2, fxrarb, gxrarb, yplus, yminus

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   yplus = ( (2-x) * (Rsquared - x)                            &
       &   + Sqrt(x2-4._dp*rkt2) * kappa(1-x+rkt2,rmt2,rjt2) ) &
       & / ( 2._dp * ( 1._dp - x + rkt2 ) )

   yminus = ( (2-x) * (Rsquared - x)                            &
        &   - Sqrt(x2-4._dp*rkt2) * kappa(1-x+rkt2,rmt2,rjt2) ) &
        & / ( 2._dp * ( 1._dp - x + rkt2 ) )

   fxrarb =      (yplus - yminus)   &
      &     /  ( (1._dp - x + rkt2 - rat2) * (1._dp - x + rkt2 - rbt2)   )

   gxrarb =       (yplus**2 - yminus**2)   &
      &      /( 2._dp * (1._dp - x + rkt2 - rat2) * (1._dp - x + rkt2 - rbt2) )

   erg(1) = erg(1) + (rkt2 - 1._dp)*(rjt2- rkt2 -rmt2 + x - 1._dp)*fxrarb &
        & + (x-rkt2-1._dp)*gxrarb
   erg(2) = erg(2) + (rjt2 - rkt2 - rmt2 + x - 1._dp) * fxrarb + gxrarb
   erg(3) = erg(3) + (x - 2._dp*rkt2)*fxrarb
   erg(4) = erg(4) + (rjt2-rkt2-rmt2+x-1)*fxrarb
   erg(5) = erg(5) + fxrarb
   erg(6) = erg(6) + (rkt2 - x + 1._dp)*fxrarb

  End Do

 End Subroutine FFIntegrandsLM

 Subroutine IntegrateFFLM( mass , m_in, r_out, coup, smin,smax,eps,gam)
  Implicit None
  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_FaFbs(8), I_FaFb(6)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = (mass(1) / m_in )**2
  rbt2 = (mass(2) / m_in )**2
  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DgaussInt(FFIntegrandsLM,6,smin,smax,I_FaFb(:),eps)
   I_FaFbs(1) = I_FaFb(1)
   I_FaFbs(2) = Sqrt(rat2 * rbt2) * I_FaFb(2)
   I_FaFbs(3) = Sqrt(rat2 * rmt2) * I_FaFb(3)
   I_FaFbs(4) = Sqrt(rbt2 * rmt2) * I_FaFb(3)
   I_FaFbs(5) = Sqrt(rat2 * rkt2) * I_FaFb(4)
   I_FaFbs(6) = Sqrt(rbt2 * rkt2) * I_FaFb(4)
   I_FaFbs(7) = - 2._dp * Sqrt(rkt2 * rmt2 * rat2 * rbt2) * I_FaFb(5)
   I_FaFbs(8) = - 2._dp * Sqrt(rkt2 * rmt2) * I_FaFb(6)

  gam = ( coup(1) * coup(4) * Conjg(coup(8) * coup(5))                 &
    &   + coup(2) * coup(3) * Conjg(coup(7) * coup(6)) ) * I_FaFbs(1)  &
    & + ( coup(1) * coup(3) * Conjg(coup(7) * coup(5))                 &
    &   + coup(2) * coup(4) * Conjg(coup(8) * coup(6)) ) * I_FaFbs(2)  &
    & + ( coup(1) * coup(3) * Conjg(coup(8) * coup(5))                 &
    &   + coup(2) * coup(4) * Conjg(coup(7) * coup(6)) ) * I_FaFbs(3)  &
    & + ( coup(1) * coup(4) * Conjg(coup(7) * coup(5))                 &
    &   + coup(2) * coup(3) * Conjg(coup(8) * coup(6)) ) * I_FaFbs(4)  &
    & + ( coup(1) * coup(3) * Conjg(coup(7) * coup(6))                 &
    &   + coup(2) * coup(4) * Conjg(coup(8) * coup(5)) ) * I_FaFbs(5)  &
    & + ( coup(1) * coup(4) * Conjg(coup(8) * coup(6))                 &
    &   + coup(2) * coup(3) * Conjg(coup(7) * coup(5)) ) * I_FaFbs(6)  &
    & + ( coup(1) * coup(3) * Conjg(coup(8) * coup(6))                 &
    &   + coup(2) * coup(4) * Conjg(coup(7) * coup(5)) ) * I_FaFbs(7)  &
    & + ( coup(1) * coup(4) * Conjg(coup(7) * coup(6))                 &
    &   + coup(2) * coup(3) * Conjg(coup(8) * coup(5)) ) * I_FaFbs(8)

  gam = 2._dp*oo512pi3 * m_in * gam

 End Subroutine IntegrateFFLM

 Subroutine SaSaIntegrands(s,erg)
  Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(2)

  Integer :: i1

  Real(dp) :: x, x2, yplus, yminus, iOnexra, iTwoxra, l1abbr

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   yplus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                           &
      &    * ( (2._dp-x) * (Rsquared - x) + Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp -x+rkt2,rmt2,rjt2))
   yminus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                          &
      &    * ( (2._dp-x) * (Rsquared - x) - Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp -x+rkt2,rmt2,rjt2))

   l1abbr =  Log( Abs( ( yplus  + x - 1._dp + rjt2 - rat2 )         &
          &            / ( yminus + x - 1._dp + rjt2 - rat2 )   ) )

   iOnexra =  (yplus - yminus)                            &
           & / ( (yplus + x - 1._dp + rjt2 - rat2 )       &
           &   * (yminus + x - 1._dp + rjt2 - rat2 ) )

   iTwoxra = l1abbr + (1._dp - x - rjt2 + rat2)* iOnexra

   erg(1) = erg(1) + iTwoxra + (x - 1._dp +rjt2 - rmt2 - rkt2)*iOnexra
   erg(2) = erg(2) + iOnexra

  End Do

 End Subroutine SaSaIntegrands

 Subroutine IntegrateSaSa(mass,m_in, r_out, coup,smin,smax,eps,gam)
  Implicit None
  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_SaSa(2)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = (mass(1) / m_in)**2
  rbt2 = (mass(2) / m_in)**2

  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DgaussInt(SaSaIntegrands,2,smin,smax,I_SaSa(:),eps)

  gam = (coup(2)*Conjg(coup(5)) + coup(3)*Conjg(coup(6))) * I_SaSa(1)  &
    & - (coup(2)*Conjg(coup(6)) + coup(3)*Conjg(coup(5)))               &
    &   * 2._dp * Sqrt(rmt2*rkt2) * I_SaSa(2)

  gam = 2._dp * oo512pi3 / m_in * coup(1)*Conjg(coup(4))*  gam

 End Subroutine IntegrateSaSa

 Subroutine SaSbIntegrands (s,erg)
  Implicit None

   Real(dp), Intent(in) :: s(2)
   Real(dp), Intent(out) :: erg(2)

   Integer :: i1

   Real(dp) :: x, x2, yplus, yminus, hOnexrarb, hTwoxrarb, l1abbr, l2abbr

   erg = 0._dp

   Do i1=1,2
    x = s(i1)
    x2 = x**2

    yplus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                         &
    &    * ( (2._dp-x) * (Rsquared - x) + Sqrt(x2-4._dp*rkt2)                &
    &                                 * kappa(1._dp-x+rkt2,rmt2,rjt2) )
   yminus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                         &
    &    * ( (2._dp-x) * (Rsquared - x) - Sqrt(x2-4._dp*rkt2)                &
    &                                 * kappa(1._dp-x+rkt2,rmt2,rjt2) )

   l1abbr = Log( Abs( ( yplus  + x - 1._dp + rjt2 - rat2 )         &
          &           / ( yminus + x - 1._dp + rjt2 - rat2 )   ) )

   l2abbr = Log( Abs( ( yplus  + x - 1._dp + rjt2 - rbt2 )         &
           &          / ( yminus + x - 1._dp + rjt2 - rbt2 )   ) )

   hOnexrarb =  ( l1abbr - l2abbr  ) / (rat2 - rbt2)

   hTwoxrarb =   l2abbr + (1._dp - x -rjt2 + rat2 )*hOnexrarb

   erg(1) = erg(1) +  hTwoxrarb + (x - 1._dp +rjt2 - rmt2 - rkt2)*hOnexrarb
   erg(2) = erg(2) +  hOnexrarb

  End Do

 End Subroutine SaSbIntegrands

 Subroutine IntegrateSaSb(mass,m_in, r_out, coup,smin,smax,eps,gam)
  Implicit None
  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_SaSb(2)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = (mass(1) / m_in)**2
  rbt2 = (mass(2) / m_in)**2

  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DgaussInt(SaSbIntegrands,2,smin,smax,I_SaSb(:),eps)

  gam = (coup(2)*Conjg(coup(5)) + coup(3)*Conjg(coup(6))) * I_SaSb(1)  &
    & - (coup(2)*Conjg(coup(6)) + coup(3)*Conjg(coup(5)))              &
    &   * 2._dp * Sqrt(rmt2*rkt2) * I_SaSb(2)

  gam = 2._dp * oo512pi3 / m_in * coup(1) * Conjg(coup(4)) * gam

 End Subroutine IntegrateSaSb

 Subroutine SFIntegrands(s,erg)
 Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(4)

  Integer :: i1

  Real(dp) :: x, x2, yplus, yminus, gOnexrarb, gTwoxrarb, l1abbr, kabbr

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   yplus = 1._dp / ( 2._dp * ( 1 - x + rkt2 ) )                               &
      &    * ( (2._dp-x) * (Rsquared - x) + Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )
   yminus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                          &
      &    * ( (2._dp-x) * (Rsquared - x) - Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )

   l1abbr =      Log( Abs(  ( yplus  + x - 1._dp + rjt2 - rbt2 )         &
            &             / ( yminus + x - 1._dp + rjt2 - rbt2 )   ) )

   kabbr = (   yplus - yminus  ) / ( 1._dp - x + rkt2 -rat2 )

   gOnexrarb =  l1abbr / ( 1._dp - x + rkt2 - rat2  )

   gTwoxrarb =  kabbr + ( 1._dp - x -rjt2 + rbt2 )*gOnexrarb

   erg(1) = erg(1) + (-rjt2 + rkt2 + rmt2 - x + 1._dp)*gOnexrarb
   erg(2) = erg(2) + (-x + 2._dp*rkt2)*gOnexrarb
   erg(3) = erg(3) + gOnexrarb
   erg(4) = erg(4) + gTwoxrarb + (rjt2 - rkt2 - rmt2 + x - 1._dp)*gOnexrarb

  End Do

 End Subroutine SFIntegrands

 Subroutine IntegrateSF(mass,m_in, r_out, coup,smin,smax,eps,gam)
 Implicit None

  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_SF(4)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = ( mass(1) / m_in )**2
  rbt2 = ( mass(2) / m_in )**2
  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DGaussInt(SFIntegrands,4,smin,smax,I_SF(:),eps)

  I_SF(1) = I_SF(1)
  I_SF(2) = I_SF(2)
  I_SF(3) = - I_SF(3)
  I_SF(4) = I_SF(4)

  gam = ( coup(1) * coup(4) * Conjg(coup(7))                          &
    &   + coup(2) * coup(3) * Conjg(coup(6)) ) * Sqrt(rkt2) * I_SF(1) &
    & + ( coup(1) * coup(4) * Conjg(coup(6))                          &
    &   + coup(2) * coup(3) * Conjg(coup(7)) ) * Sqrt(rmt2) * I_SF(2) &
    & - ( coup(1) * coup(3) * Conjg(coup(7))                          &
    &   + coup(2) * coup(4) * Conjg(coup(6)) )                        &
    &                        * 2._dp * Sqrt(rkt2*rmt2*rat2) * I_SF(3) &
    & + ( coup(1) * coup(3) * Conjg(coup(6))                          &
    &   + coup(2) * coup(4) * Conjg(coup(7)) ) * Sqrt(rat2) * I_SF(4)

  gam = 2._dp * oo512pi3 * Conjg(coup(5)) * gam

 End Subroutine IntegrateSF

 Subroutine VFIntegrands(s,erg)
 Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(4)

  Integer :: i1

  Real(dp) :: x, x2, yplus, yminus, gOnexrarb, gTwoxrarb, l1abbr, kabbr

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   yplus = 1._dp / ( 2._dp * ( 1 - x + rkt2 ) )                               &
      &    * ( (2._dp-x) * (Rsquared - x) + Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )
   yminus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) ) &
      &    * ( (2._dp-x) * (Rsquared - x) - Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )

   l1abbr =      Log( Abs(  ( yplus  + x - 1._dp + rjt2 - rbt2 )         &
            &             / ( yminus + x - 1._dp + rjt2 - rbt2 )   ) )

   kabbr = (   yplus - yminus  ) / ( 1._dp - x + rkt2 -rat2  )

   gOnexrarb =  l1abbr / ( 1._dp - x + rkt2 - rat2  )

   gTwoxrarb =  kabbr + ( 1._dp - x -rjt2 + rbt2 )*gOnexrarb

   erg(1) = erg(1) -   2._dp*(rkt2 - x + 1._dp)*gTwoxrarb                   &
         &         + ( rjt2 *(rkt2 - 2._dp ) -  rkt2 *rkt2                  &
         &         +   rkt2 *(rmt2 + x + 1._dp)                             &
         &         -   rmt2*(x - 2._dp) -2._dp*x  +2._dp   )*gOnexrarb
   erg(2) = erg(2) + gTwoxrarb + (rjt2 + rkt2 - rmt2 - x - 1._dp)*gOnexrarb
   erg(3) = erg(3) + (rjt2 + rkt2 - rmt2 -2._dp*x + 3._dp)*gOnexrarb
   erg(4) = erg(4) + gTwoxrarb + (1._dp - rjt2 + rkt2 - rmt2 - x)*gOnexrarb

  End Do

 End Subroutine VFIntegrands

 Subroutine IntegrateVF(mass,m_in, r_out, coup,smin,smax,eps,gam)
 Implicit None

  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_VF(4)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = ( mass(1) / m_in )**2
  rbt2 = ( mass(2) / m_in )**2
  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DGaussInt(VFIntegrands,4,smin,smax,I_VF(:),eps)

  I_VF(2)=I_VF(2)
  I_VF(3)=-I_VF(3)
  I_VF(4)=I_VF(4)

  gam = ( coup(1) * coup(4) * Conjg(coup(7))                               &
    &   + coup(2) * coup(3) * Conjg(coup(6)) ) * I_VF(1)                   &
    & + ( coup(1) * coup(3) * Conjg(coup(7))                               &
    &   + coup(2) * coup(4) * Conjg(coup(6)) ) * Sqrt(rat2*rmt2) * I_VF(2) &
    & - ( coup(1) * coup(4) * Conjg(coup(6))                               &
    &   + coup(2) * coup(3) * Conjg(coup(7)) ) * Sqrt(rkt2*rmt2) * I_VF(3) &
    & + ( coup(1) * coup(3) * Conjg(coup(6))                               &
        + coup(2) * coup(4) * Conjg(coup(7)) ) * Sqrt(rkt2*rat2) * I_VF(4)

  gam = - 2._dp * oo512pi3 * Conjg(coup(5)) * m_in * gam

 End Subroutine IntegrateVF

 Subroutine VSIntegrands(s,erg)
  Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(2)

  Integer :: i1

  Real(dp) :: x, x2, yplus, yminus, hOnexrarb, hTwoxrarb, l1abbr, l2abbr

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   yplus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                           &
      &    * ( (2._dp-x) * (Rsquared - x) + Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )
   yminus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                          &
      &    * ( (2._dp-x) * (Rsquared - x) - Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )

   l1abbr =      Log( Abs(  ( yplus  + x - 1._dp + rjt2 - rat2 )         &
            &             / ( yminus + x - 1._dp + rjt2 - rat2 )   ) )

   l2abbr =      Log( Abs(  ( yplus  + x - 1._dp + rjt2 - rbt2 )         &
            &             / ( yminus + x - 1._dp + rjt2 - rbt2 )   ) )

   hOnexrarb = ( l1abbr - l2abbr )  / (rat2 - rbt2)

   hTwoxrarb = l2abbr + (1._dp - x -rjt2 + rat2 )*hOnexrarb

   erg(1) = erg(1) + hTwoxrarb + (rkt2 - rjt2 - rmt2 - x +1._dp)*hOnexrarb
   erg(2) = erg(2) + hTwoxrarb + (rjt2 - rmt2 - x - 1._dp +rkt2)*hOnexrarb

  End Do

 End Subroutine VSIntegrands

 Subroutine IntegrateVS(mass,m_in, r_out, coup,smin,smax,eps,gam)
 Implicit None
  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_VS(2)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = ( mass(1) / m_in )**2
  rbt2 = ( mass(2) / m_in)**2
  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DGaussInt(VSIntegrands,2,smin,smax,I_VS(:),eps)

  gam = (coup(2)*Conjg(coup(5)) + coup(3)*Conjg(coup(6)))*Sqrt(rkt2)*I_VS(1) &
    & + (coup(2)*Conjg(coup(6)) + coup(3)*Conjg(coup(5)))*Sqrt(rmt2)*I_VS(2)

  gam = 2._dp * oo512pi3 * coup(1) * Conjg(coup(4)) * gam

 End Subroutine IntegrateVS

 Subroutine VSIntegrandsGoldstone(s,erg)
 Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(2)

  Integer :: i1

  Real(dp) :: x, x2, yplus, yminus, iOnexra, iTwoxra, l1abbr

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   yplus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                           &
      &    * ( (2._dp-x) * (Rsquared - x) + Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )
   yminus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                          &
      &    * ( (2._dp-x) * (Rsquared - x) - Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )

   l1abbr =      Log( Abs(  ( yplus  + x - 1._dp + rjt2 - rat2 )         &
            &             / ( yminus + x - 1._dp + rjt2 - rat2 )   ) )

   iOnexra =                           (yplus - yminus)                       &
    & / ((yplus + x - 1._dp + rjt2 - rat2)*(yminus + x - 1._dp + rjt2 - rat2))

   iTwoxra = l1abbr + (1._dp - x - rjt2 + rat2)* iOnexra

   erg(1) = erg(1) + iTwoxra + (rkt2 - rjt2 - rmt2 - x +1._dp)*iOnexra
   erg(2) = erg(2) + iTwoxra + (rjt2 - rmt2 - x - 1._dp +rkt2)*iOnexra

  End Do

 End Subroutine VSIntegrandsGoldstone

 Subroutine IntegrateVSGoldstone(mass,m_in, r_out, coup,smin,smax,eps,gam)
 Implicit None

  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_VS(2)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = ( mass(1) / m_in )**2
  rbt2 = ( mass(2) / m_in)**2
  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DGaussInt(VSIntegrandsGoldstone,2,smin,smax,I_VS(:),eps)

  gam = (coup(2)*Conjg(coup(5)) + coup(3)*Conjg(coup(6)))*Sqrt(rkt2)*I_VS(1) &
    & + (coup(2)*Conjg(coup(6)) + coup(3)*Conjg(coup(5)))*Sqrt(rmt2)*I_VS(2)

  gam = 2._dp * oo512pi3 * coup(1) * Conjg(coup(4)) * gam

 End Subroutine IntegrateVSGoldstone

 Subroutine VVIntegrands (s,erg)
  Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(2)

  Integer :: i1
  Real(dp) :: x, x2, yplus, yminus, iOnexra, iTwoxra, l1abbr

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   yplus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                           &
      &    * ( (2._dp-x) * (Rsquared - x) + Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )
   yminus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                          &
      &    * ( (2._dp-x) * (Rsquared - x) - Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )

   l1abbr = Log( Abs( ( yplus  + x - 1._dp + rjt2 - rat2 )         &
          &         / ( yminus + x - 1._dp + rjt2 - rat2 )   ) )

   iOnexra = (yplus - yminus)                                 &
           & / ( (yplus  + x - 1._dp + rjt2 - rat2 )          &
           &   *  (yminus + x - 1._dp + rjt2 - rat2 ) )

   iTwoxra = l1abbr + (1._dp - x - rjt2 + rat2)* iOnexra

   erg(1) = erg(1) +   ( -3._dp * rkt2 + rmt2 + 4._dp * x - 4._dp) *iTwoxra   &
                &  +   (  rjt2 * (rkt2 + rmt2 - 4._dp)                        &
                &  -         rkt2*rkt2                                        &
                &  +      rkt2 * (2._dp * rmt2 + x + 3._dp)                   &
                &  -      rmt2 * (rmt2 + 3._dp * x - 3._dp)                   &
                &  -       4._dp * x + 4._dp                      )*iOnexra

   erg(2) = erg(2) + iTwoxra + (x - rjt2 - 3._dp)*iOnexra

  End Do

 End Subroutine VVIntegrands

 Subroutine IntegrateVV(mass,m_in, r_out, coup,smin,smax,eps,gam)
 Implicit None

  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_VV(2)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = ( mass(1) / m_in )**2
  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DGaussInt(VVIntegrands,2,smin,smax,I_VV(:),eps)

  gam = (coup(2)*Conjg(coup(2)) + coup(3)*Conjg(coup(3)) ) * I_VV(1)  &
    & + Real(coup(2)*coup(3))  * 4._dp*Sqrt( rmt2 * rkt2 )*I_VV(2)

  gam = 2._dp * oo512pi3 * m_in * coup(1) *Conjg(coup(1)) *gam

 End Subroutine IntegrateVV

 Complex(dp) Function I2dsmg1tmg2(s, tmin, tmax, m12, g1, m22, g2)
 !--------------------------------------------------------------------
 ! Computes the following integral:
 !
 !   ( tmax                                        )
 !   (   (                     1                   )
 ! Re(   | dt -----------------------------------  )
 !   (   )     (s - m12 + I g1) (t - m22 - I g2)   )
 !   ( tmin                                        )
 !
 ! written by Werner Porod, 9.1.1996
 !--------------------------------------------------------------------
  Implicit None

  Real(dp), Intent(in) :: s, tmin, tmax, m12, m22, g1, g2
  Real(dp) :: fa(3), ReS, ImS, ReT, ImT

  I2dsmg1tmg2 = ZeroC

  If (g1.Eq.0._dp) Then
   ReS = 1._dp / (s-m12)
   ImS = 0._dp
  Else
   ReS = (s-m12) / ( (s-m12)**2 + g1**2)
   ImS = - g1 / ( (s-m12)**2 + g1**2)
  End If

  If (g2.Eq.0) Then
   ReT = Log(Abs(tmax - m22) / Abs(tmin - m22) )
   ImT = 0._dp
  Else
   ReT = 0.5_dp * Log(( g2**2 + (tmax - m22)**2) / ( g2**2 + (tmin - m22)**2))
   fa(1) = (tmin - m22) / g2
   fa(2) = (tmax - m22) / g2
   fa(3) = fa(1) * fa(2)
   If (fa(3).Gt.-1._dp) Then
    ImT = Atan( (fa(1) - fa(2)) / (1+fa(3)) )
   Else If (fa(1).Gt.0._dp) Then
    ImT = Pi + Atan( (fa(1) - fa(2)) / (1+fa(3)) )
   Else
    ImT = -Pi + Atan( (fa(1) - fa(2)) / (1+fa(3)) )
   End If
  End If

  I2dsmg1tmg2 = Cmplx(ReS * ReT - ImS * ImT , ReT * ImS + ReS * ImT,dp)

  End Function I2dsmg1tmg2

 Complex(dp) Function I2dtm12g12(tmin,tmax,m12,g1,m22,g2)
 !--------------------------------------------------------------------
 ! Computes the following integral:
 !
 !   ( tmax                                        )
 !   (   (                     1                   )
 ! Re(   | dt -----------------------------------  )
 !   (   )     (t - m12 + I g1) (t - m22 - I g2)   )
 !   ( tmin                                        )
 !
 ! written by Werner Porod, 9.1.1996
 !--------------------------------------------------------------------
 Implicit None
  Real(dp), Intent(in) :: tmin,tmax,m12,m22,g1,g2
  Real(dp) :: fa(3),g12,g22, x1, x2, y1, y2

  I2dtm12g12 = ZeroC

  If ((g1.Eq.0._dp).Or.(g2.Eq.0._dp)) Then
   I2dtm12g12 = ( Log(Abs( (tmax-m12) / (tmin-m12) ) )          &
              & - Log(Abs( (tmax-m22) / (tmin-m22) ) ) ) / (m12 - m22)
  Else
   g12 = g1 * g1
   g22 = g2 * g2
   fa(1) = (m12-m22)**2 + (g1+g2)**2
   fa(2) = 0.5_dp * (m12-m22)
   fa(3) = (g1+g2)
   x1 = g1 / (tmax-m12)
   x2 = g1 / (tmin-m12)
   y1 = Atan((x1-x2)/(1._dp + x1 * x2))
   If ((x1.Gt.0._dp).And.(x1*x2.Lt.-1._dp)) y1 = y1 + pi
   If ((x1.Lt.0._dp).And.(x1*x2.Lt.-1._dp)) y1 = y1 - pi
   x1 = g2 / (tmax-m22)
   x2 = g2 / (tmin-m22)
   y2 = Atan((x1-x2)/(1._dp + x1 * x2))
   If ((x1.Gt.0._dp).And.(x1*x2.Lt.-1._dp)) y2 = y2 + pi
   If ((x1.Lt.0._dp).And.(x1*x2.Lt.-1._dp)) y2 = y2 - pi

   I2dtm12g12 =                                                            &
     &   fa(2) * ( Log( ((tmax-m12)**2 + g12) / ((tmin-m12)**2 + g12) )    &
     &          - Log( ((tmax-m22)**2 + g22) / ((tmin-m22)**2 + g22) )  )  &
     & - fa(3) * ( y1 + y2  )
   I2dtm12g12 = I2dtm12g12 / fa(1)

  End If

 End Function I2dtm12g12

 Real(dp) Function I2dtm1g1(tmin, tmax, m12, g12)
 !--------------------------------------------------------------------
 ! Computes the following integral:
 !
 !   tmax
 !     (            1
 !     | dt -----------------
 !     )     (t-m12)^2 + g12
 !   tmin
 !
 ! written by Werner Porod, 9.1.1996
 !--------------------------------------------------------------------
 Implicit None

  Real(dp), Intent(in) :: tmin, tmax, m12, g12
  Real(dp) :: g1, x1, x2

  If (g12.Le.0._dp) Then
   I2dtm1g1 = 1._dp / (tmin-m12) - 1._dp / (tmax-m12)
  Else
   g1 = Sqrt(g12)
   x1 = (tmax-m12)/g1
   x2 = (tmin-m12)/g1
   I2dtm1g1 = Atan((x1-x2)/(1._dp + x1 * x2))
   If ((x1.Gt.0._dp).And.(x1*x2.Lt.-1._dp)) I2dtm1g1 = I2dtm1g1 + pi
   If ((x1.Lt.0._dp).And.(x1*x2.Lt.-1._dp)) I2dtm1g1 = I2dtm1g1 - pi
   I2dtm1g1 = I2dtm1g1 / g1
  End If

  End Function I2dtm1g1

 Complex(dp) Function I2t2dsmg1tmg2(s,tmin,tmax,m12,g1,m22,g2)
 !--------------------------------------------------------------------
 ! Computes the following integral:
 !
 !   ( tmax                                        )
 !   (   (                     t^2                 )
 ! Re(   | dt -----------------------------------  )
 !   (   )     (s - m12 + I g1) (t - m22 - I g2)   )
 !   ( tmin                                        )
 !
 ! written by Werner Porod, 9.1.1996
 !--------------------------------------------------------------------
 Implicit None
  Real(dp), Intent(in) :: s,tmin,tmax,m12,m22,g1,g2
  Real(dp) :: fa(3), ReS, ImS, ReT, ImT

  I2t2dsmg1tmg2 = ZeroC

  If (g1.Eq.0._dp) Then
   ReS = 1._dp / (s-m12)
   ImS = 0._dp
  Else
   ReS = (s-m12) / ( (s-m12)**2 + g1**2)
   ImS = - g1 / ( (s-m12)**2 + g1**2)
  End If

  If (g2.Eq.0._dp) Then
   ReT = 0.5_dp * ( tmax*(2._dp*m22+tmax) - tmin*(2._dp*m22+tmin)) &
     & + m22**2 * Log(Abs(tmax - m22) / Abs(tmin - m22) )
   ImT = 0._dp
  Else
   fa(1) = Log((g2**2 + (tmax - m22)**2) / ( g2**2 + (tmin - m22)**2))
   ReT = 0.5_dp * ( tmax*(2._dp*m22+tmax) - tmin*(2._dp*m22+tmin)) &
     & + 0.5_dp * (m22**2 - g2**2) * fa(1)
   ImT = -g2 * (tmax - tmin + m22 * fa(1))
   fa(1) = (tmin - m22) / g2
   fa(2) = (tmax - m22) / g2
   fa(3) = fa(1) * fa(2)
   If (fa(3).Gt.-1._dp) Then
    fa(2) = Atan( (fa(1) - fa(2)) / (1+fa(3)) )
   Else If (fa(1).Gt.0._dp) Then
    fa(2) = Pi + Atan( (fa(1) - fa(2)) / (1+fa(3)) )
   Else
    fa(2) = -Pi + Atan( (fa(1) - fa(2)) / (1+fa(3)) )
   End If
   ReT = ReT + 2._dp * g2 * m22 * fa(2)
   ImT = ImT + (m22**2 - g2**2) * fa(2)
  End If

  I2t2dsmg1tmg2 = Cmplx(ReS * ReT - ImS * ImT , ReT * ImS + ReS * ImT,dp)

 End Function I2t2dsmg1tmg2

 Complex(dp) Function I2tdtm12g12(tmin,tmax,m12,g1,m22,g2)
 !--------------------------------------------------------------------
 ! Computes the following integral:
 !
 !   ( tmax                                        )
 !   (   (                     t                   )
 ! Re(   | dt -----------------------------------  )
 !   (   )     (t - m12 + I g1) (t - m22 - I g2)   )
 !   ( tmin                                        )
 !
 ! written by Werner Porod, 9.1.1996
 !--------------------------------------------------------------------
 Implicit None

  Real(dp), Intent(in) :: tmin,tmax,m12,m22,g1,g2
  Real(dp) :: fa(4),g12,g22, x1, x2, y1, y2

  I2tdtm12g12 = ZeroC

  If ((g1.Eq.0._dp).Or.(g2.Eq.0._dp)) Then
   I2tdtm12g12 = ( m12 * Log(Abs( (tmax-m12) / (tmin-m12) ) )      &
               & - m22 * Log(Abs( (tmax-m22) / (tmin-m22) ) ) ) / (m12 - m22)
  Else
   g12 = g1 * g1
   g22 = g2 * g2
   fa(1) = (m12-m22)**2 + (g1+g2)**2
   fa(2) = 0.5_dp * (m12 * (m12-m22) + g1 *(g1+g2) )
   fa(3) = 0.5_dp * (m22 * (m22-m12) + g2 *(g1+g2) )
   fa(4) = (g1*m22+g2*m12)
   x1 = g1 / (tmax-m12)
   x2 = g1 / (tmin-m12)
   y1 = Atan((x1-x2)/(1._dp + x1 * x2))
   If ((x1.Gt.0._dp).And.(x1*x2.Lt.-1._dp)) y1 = y1 + pi
   If ((x1.Lt.0._dp).And.(x1*x2.Lt.-1._dp)) y1 = y1 - pi
   x1 = g2 / (tmax-m22)
   x2 = g2 / (tmin-m22)
   y2 = Atan((x1-x2)/(1._dp + x1 * x2))
   If ((x1.Gt.0._dp).And.(x1*x2.Lt.-1._dp)) y2 = y2 + pi
   If ((x1.Lt.0._dp).And.(x1*x2.Lt.-1._dp)) y2 = y2 - pi

   I2tdtm12g12 = fa(2) * Log( ((tmax-m12)**2 + g12) / ((tmin-m12)**2 + g12) ) &
             & + fa(3) * Log( ((tmax-m22)**2 + g22) / ((tmin-m22)**2 + g22) ) &
             & - fa(4) * ( y1 + y2  )
   I2tdtm12g12 = I2tdtm12g12 / fa(1)
  End If

 End Function I2tdtm12g12

 Complex(dp) Function I2t2dtm12g12(tmin,tmax,m12,g1,m22,g2)
 !--------------------------------------------------------------------
 ! Computes the following integral:
 !
 !   ( tmax                                        )
 !   (   (                    t^2                  )
 ! Re(   | dt -----------------------------------  )
 !   (   )     (t - m12 + I g1) (t - m22 - I g2)   )
 !   ( tmin                                        )
 !
 ! written by Werner Porod, 9.1.1996
 !--------------------------------------------------------------------
 Implicit None

  Real(dp), Intent(in) :: tmin,tmax,m12,m22,g1,g2
  Real(dp) :: m14,m24,fa(5),g12,g22, x1, x2, y1, y2

  I2t2dtm12g12 = ZeroC

  If ((g1.Eq.0._dp).Or.(g2.Eq.0._dp)) Then
   I2t2dtm12g12 = tmax - tmin                                           &
              & + ( m12**2 * Log(Abs( (tmax-m12) / (tmin-m12) ) )       &
              &   - m22**2 * Log(Abs( (tmax-m22) / (tmin-m22) ))) / (m12 - m22)
  Else
   m14 = m12 * m12
   m24 = m22 * m22
   g12 = g1 * g1
   g22 = g2 * g2

   fa(1) = (m12-m22)**2 + (g1+g2)**2
   fa(2) = 0.5_dp * ( (m14-g12)*(m12-m22) + 2._dp* m12* g1* (g1+g2) )
   fa(3) = -( (m14-g12)*(g1+g2) - 2._dp* m12* g1* (m12-m22) )
   fa(4) = 0.5_dp * ( (m24-g22)*(m22-m12) + 2._dp* m22* g2* (g1+g2) )
   fa(5) = -( (m24-g22)*(g1+g2) + 2._dp* m22* g2* (m12-m22) )
   x1 = g1 / (tmax-m12)
   x2 = g1 / (tmin-m12)
   y1 = Atan((x1-x2)/(1._dp + x1 * x2))
   If ((x1.Gt.0._dp).And.(x1*x2.Lt.-1._dp)) y1 = y1 + pi
   If ((x1.Lt.0._dp).And.(x1*x2.Lt.-1._dp)) y1 = y1 - pi
   x1 = g2 / (tmax-m22)
   x2 = g2 / (tmin-m22)
   y2 = Atan((x1-x2)/(1._dp + x1 * x2))
   If ((x1.Gt.0._dp).And.(x1*x2.Lt.-1._dp)) y2 = y2 + pi
   If ((x1.Lt.0._dp).And.(x1*x2.Lt.-1._dp)) y2 = y2 - pi

   I2t2dtm12g12 = tmax - tmin                                                 &
              & + fa(2) * Log( ((tmax-m12)**2 + g12) / ((tmin-m12)**2 + g12)) &
              & + fa(3) * y1                                                  &
              & + fa(4) * Log( ((tmax-m22)**2 + g22) / ((tmin-m22)**2 + g22)) &
              & + fa(5) * y2
   I2t2dtm12g12 = I2t2dtm12g12 / fa(1)
  End If

 End Function I2t2dtm12g12

 Real(dp) Function I2t2dtm1g1(tmin, tmax, m12, g12)
 !--------------------------------------------------------------------
 ! Computes the following integral:
 !
 !   tmax
 !     (           t^2
 !     | dt -----------------
 !     )     (t-m12)^2 + g12
 !   tmin
 !
 ! written by Werner Porod, 9.1.1996
 !--------------------------------------------------------------------
 Implicit None
  Real(dp),Intent(in) :: tmin, tmax, m12, g12
  Real(dp) :: g1, x1, x2, y

  If (g12.Le.0._dp) Then
   I2t2dtm1g1 = m12**2 * ( 1._dp/(tmin-m12) - 1._dp/(tmax-m12) )    &
            & + 2._dp * m12 * Log(Abs( (tmax-m12) / (tmin-m12) ) )  &
            & + tmax - tmin
  Else
   g1 = Sqrt(g12)
   x1 = (tmax-m12)/g1
   x2 = (tmin-m12)/g1
   y = Atan((x1-x2)/(1._dp + x1 * x2))
   If ((x1.Gt.0._dp).And.(x1*x2.Lt.-1._dp)) y = y + pi
   If ((x1.Lt.0._dp).And.(x1*x2.Lt.-1._dp)) y = y - pi

   I2t2dtm1g1 = (m12**2-g12) * y / g1 &
            & + m12 * Log( ((tmax-m12)**2 + g12) / ((tmin-m12)**2 + g12) )   &
            & + tmax - tmin
  End If

 End Function I2t2dtm1g1

 Complex(dp) Function I2tdsmg1tmg2(s,tmin,tmax,m12,g1,m22,g2)
 !--------------------------------------------------------------------
 ! Computes the following integral:
 !
 !   ( tmax                                        )
 !   (   (                     t                   )
 ! Re(   | dt -----------------------------------  )
 !   (   )     (s - m12 + I g1) (t - m22 - I g2)   )
 !   ( tmin                                        )
 !
 ! written by Werner Porod, 9.1.1996
 !--------------------------------------------------------------------
 Implicit None
  Real(dp), Intent(in) :: s,tmin,tmax,m12,m22,g1,g2
  Real(dp) :: fa(3), ReS, ImS, ReT, ImT

  I2tdsmg1tmg2 = ZeroC

  If (g1.Eq.0._dp) Then
   ReS = 1._dp / (s-m12)
   ImS = 0._dp
  Else
   ReS = (s-m12) / ( (s-m12)**2 + g1**2)
   ImS = - g1 / ( (s-m12)**2 + g1**2)
  End If

  If (g2.Eq.0._dp) Then
   ReT = tmax - tmin + m22 * Log(Abs(tmax - m22) / Abs(tmin - m22) )
   ImT = 0._dp
  Else
   fa(1) = 0.5_dp * Log((g2**2 + (tmax - m22)**2) / ( g2**2 + (tmin - m22)**2))
   ReT = tmax - tmin + m22 * fa(1)
   ImT = -g2 * fa(1)
   fa(1) = (tmin - m22) / g2
   fa(2) = (tmax - m22) / g2
   fa(3) = fa(1) * fa(2)
   If (fa(3).Gt.-1._dp) Then
    fa(2) = Atan( (fa(1) - fa(2)) / (1+fa(3)) )
   Else If (fa(1).Gt.0._dp) Then
    fa(2) = Pi + Atan( (fa(1) - fa(2)) / (1+fa(3)) )
   Else
    fa(2) = -Pi + Atan( (fa(1) - fa(2)) / (1+fa(3)) )
   End If
   ReT = ReT + g2 * fa(2)
   ImT = ImT + m22 * fa(2)
  End If

  I2tdsmg1tmg2 = Cmplx(ReS * ReT - ImS * ImT , ReT * ImS + ReS * ImT,dp)

 End Function I2tdsmg1tmg2

 Real(dp) Function I2tdtm1g1(tmin, tmax, m12, g12)
 !--------------------------------------------------------------------
 ! Computes the following integral:
 !
 !   tmax
 !     (            t
 !     | dt -----------------
 !     )     (t-m12)^2 + g12
 !   tmin
 !
 ! written by Werner Porod, 9.1.1996
 !--------------------------------------------------------------------
 Implicit None
  Real(dp), Intent(in) :: tmin,tmax,m12,g12
  Real(dp) :: g1, x1, x2, y

  If (g12.Le.0._dp) Then
   I2tdtm1g1 = m12 / (tmin-m12) - m12 / (tmax-m12)   &
           & + Log(Abs( (tmax-m12) / (tmin-m12) ) )
  Else
   g1 = Sqrt(g12)
   x1 = (tmax-m12)/g1
   x2 = (tmin-m12)/g1
   y = Atan((x1-x2)/(1._dp + x1 * x2))
   If ((x1.Gt.0._dp).And.(x1*x2.Lt.-1._dp)) y = y + pi
   If ((x1.Lt.0._dp).And.(x1*x2.Lt.-1._dp)) y = y - pi

   I2tdtm1g1 = m12 * y / g1          &
           & + 0.5_dp * Log( ((tmax-m12)**2 + g12) / ((tmin-m12)**2 + g12) )
  End If

 End Function I2tdtm1g1

!---------------------------------------------------------------------
! integrals for multiple vector bosons in 3-body decays of fermions
! provided by L. Mitzka, 04.03.2015
!---------------------------------------------------------------------
  Subroutine VaVbIntegrands (s,erg)
  Implicit None

  Real(dp), Intent(in) :: s(2)
  Real(dp), Intent(out) :: erg(2)

  Integer :: i1
  Real(dp) :: x, x2, yplus, yminus, hOnexrarb, hTwoxrarb, l1abbr, l2abbr

  erg = 0._dp

  Do i1=1,2
   x = s(i1)
   x2 = x**2

   yplus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                           &
      &    * ( (2._dp-x) * (Rsquared - x) + Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )
   yminus = 1._dp / ( 2._dp * ( 1._dp - x + rkt2 ) )                          &
      &    * ( (2._dp-x) * (Rsquared - x) - Sqrt(x2-4._dp*rkt2)               &
      &                                     * kappa(1._dp-x+rkt2,rmt2,rjt2) )

   l1abbr = Log( Abs( ( yplus  + x - 1._dp + rjt2 - rat2 )         &
          &           / ( yminus + x - 1._dp + rjt2 - rat2 )   ) )

   l2abbr = Log( Abs( ( yplus  + x - 1._dp + rjt2 - rbt2 )         &
           &          / ( yminus + x - 1._dp + rjt2 - rbt2 )   ) )

   hOnexrarb =  ( l1abbr - l2abbr  ) / (rat2 - rbt2)

   hTwoxrarb =   l2abbr + (1._dp - x -rjt2 + rat2 )*hOnexrarb

   erg(1) = erg(1) +   ( -3._dp * rkt2 + rmt2 + 4._dp * x - 4._dp) *hTwoxrarb &
                &  +   (  rjt2 * (rkt2 + rmt2 - 4._dp)                        &
                &  -         rkt2*rkt2                                        &
                &  +      rkt2 * (2._dp * rmt2 + x + 3._dp)                   &
                &  -      rmt2 * (rmt2 + 3._dp * x - 3._dp)                   &
                &  -       4._dp * x + 4._dp                      )*hOnexrarb

   erg(2) = erg(2) + hTwoxrarb + (x - rjt2 - 3._dp)*hOnexrarb

  End Do

 End Subroutine VaVbIntegrands

 Subroutine IntegrateVaVb(mass,m_in, r_out, coup,smin,smax,eps,gam)
 Implicit None

  Real(dp), Intent(in)    :: mass(:)
  Real(dp), Intent(in)    :: m_in
  Real(dp), Intent(in)    :: r_out(:)
  Complex(dp), Intent(in) :: coup(:)
  Real(dp), Intent(in)    :: smin
  Real(dp), Intent(in)    :: smax
  Real(dp), Intent(in)    :: eps
  Complex(dp), Intent(out)   :: gam

  Real(dp) :: I_VaVb(2)

  rjt2 = r_out(1)
  rkt2 = r_out(2)
  rmt2 = r_out(3)

  rat2 = ( mass(1) / m_in )**2
  rbt2 = ( mass(2) / m_in )**2
  Rsquared = 1._dp - rjt2 + rkt2 + rmt2

  Call DGaussInt(VaVbIntegrands,2,smin,smax,I_VaVb(:),eps)

  gam = (coup(2)*Conjg(coup(5)) + coup(3)*Conjg(coup(6)) )  * I_VaVb(1)  &
    & + (coup(2)*Conjg(coup(6)) + coup(3)*Conjg(coup(5)) )  * 2._dp      &
    &    *Sqrt( rmt2 * rkt2 )*I_VaVb(2)

  gam = 2._dp * oo512pi3 * m_in * coup(1) *Conjg(coup(4)) *gam

 End Subroutine IntegrateVaVb

End Module ThreeBodyPhaseSpaceS


      subroutine layer2z(a,p,az,z,flag,ii,jj,ib,it,jb,jt,kk,kz,itype)
      implicit none
c
      integer ii,jj,ib,it,jb,jt,kk,kz,itype
      real    a(ib:it,jb:jt,kk),p(ib:it,jb:jt,kk+1),az(ib:it,jb:jt,kz),
     &        z(kz),flag
c
c**********
c*
c  1) interpolate a layered field to fixed z depths
c
c  2) input arguments:
c       a     - scalar field in layer space
c       p     - layer interface depths (non-negative m)
c                 p(:,:,   1) is the surface
c                 p(:,:,kk+1) is the bathymetry
c       z     - target z-level  depths (non-negative m)
c       flag  - data void (land) marker
c       ii    - 1st dimension of a,p,az
c       jj    - 2nd dimension of a,p,az
c       kk    - 3rd dimension of a  (number of layers)
c       kz    - 3rd dimension of az (number of levels)
c       itype - interpolation type
c                 =-2; piecewise quadratic     across each layer
c                 =-1; piecewise linear        across each layer
c                 = 0; sample the layer        spaning each depth
c                 = 1; linear interpolation    between layer centers
c                 = 2; linear interpolation    between layer interfaces
c                 = 3; piecewise cubic hermite between layer centers
c
c  3) output arguments:
c       az    - scalar field in z-space
c
c  4) except at data voids, must have:
c           p(:,:,   1) == zero (surface)
c           p(:,:, l+1) >= p(:,:,l)
c           p(:,:,kk+1) == bathymetry
c           0 <= z(k) <= z(k+1)
c     note that z(k) > p(i,j,kk+1) implies that az(i,j,k)=flag,
c      since the z-level is then below the bathymetry.
c
c  5) Alan J. Wallcraft, Naval Research Laboratory, February 2002.
c*
c**********
c
      integer i,j,k,l,lf
      real    s,zk,z0,zm,zp
      real    si(kk,1),pi(kk+1),so(kz,1)
c
      do j= 1,jj
        do i= 1,ii
          if     (a(i,j,1).eq.flag) then
            do k= 1,kz
              az(i,j,k) = flag  ! land
            enddo
          elseif (itype.lt.0 .or. itype.eq.3) then
            do k= 1,kk
              si(k,1) = a(i,j,k)
              pi(k)   = p(i,j,k)
            enddo
            pi(kk+1) = p(i,j,kk+1)
            if     (itype.eq.-1) then
              call layer2z_plm(si,pi,kk,1,so,z,kz, flag)
           elseif (itype.eq.-2) then
              call layer2z_ppm(si,pi,kk,1,so,z,kz, flag)
            else   !itype.eq. 3
              call layer2z_pch(si,pi,kk,1,so,z,kz, flag)
            endif
            do k= 1,kz
              az(i,j,k) = so(k,1)
            enddo
          else !itype.ge.0
            lf=1
            do k= 1,kz
              zk=z(k)
              do l= lf,kk
                if     (p(i,j,l).le.zk .and. p(i,j,l+1).ge.zk) then
c
c                 z(k) is in layer l.
c
                  if     (itype.eq.0) then
c
c                   sample the layer
c
                    az(i,j,k) = a(i,j,l)
                  elseif (itype.eq.1) then
c
c                   linear interpolation between layer centers
c
                    z0 = 0.5*(p(i,j,l)+p(i,j,l+1))
                    if     (zk.le.z0) then
c
c                     z(k) is in the upper half of the layer
c
                      if     (l.eq.1) then
                        az(i,j,k) = a(i,j,1)
                      else
                        zm = 0.5*(p(i,j,l-1)+p(i,j,l))
                        s  = (z0 - zk)/(z0 - zm)
                        az(i,j,k) = s*a(i,j,l-1) + (1.0-s)*a(i,j,l)
                      endif
                    else
c
c                     z(k) is in the lower half of the layer
c
                      if     (p(i,j,l+1).eq.p(i,j,kk+1)) then
                        az(i,j,k) = a(i,j,kk)
                      else
                        zp = 0.5*(p(i,j,l+1)+p(i,j,l+2))
                        s  = (zk - z0)/(zp - z0)
                        az(i,j,k) = s*a(i,j,l+1) + (1.0-s)*a(i,j,l)
                      endif
                    endif
                  else !itype.eq.2
c
c                   linear interpolation between layer interfaces
c                   a is a vertical integral from the surface
c
                    if     (l.eq.1) then
                      s  = zk/p(i,j,2)
                      az(i,j,k) = s*a(i,j,1)
                    else
                      s  = (zk - p(i,j,l))/(p(i,j,l+1) - p(i,j,l))
                      az(i,j,k) = (1.0-s)*a(i,j,l-1) + s*a(i,j,l)
                    endif
                  endif
                  lf = l
                  exit
                elseif (l.eq.kk) then
                  az(i,j,k) = flag  ! below the bottom
                  lf = l
                  exit
                endif
              enddo !l
            enddo !k
          endif !land:itype<0:else
        enddo !i
      enddo !j
      return
      end

      subroutine layer2z_bot(a,p,az,zbot,flag,ii,jj,ib,it,jb,jt,kk,
     &                       itype)
      implicit none
c
      integer ii,jj,ib,it,jb,jt,kk,itype
      real    a(ib:it,jb:jt,kk),p(ib:it,jb:jt,kk+1),az(ib:it,jb:jt),zbot
     &        ,flag
c
c**********
c*
c  1) interpolate a layered field to a fixed z depth above the bottom
c
c  2) input arguments:
c       a     - scalar field in layer space
c       p     - layer interface depths (non-negative m)
c                 p(:,:,   1) is the surface
c                 p(:,:,kk+1) is the bathymetry
c       zbot  - target height above the bottom (positive m)
c       flag  - data void (land) marker
c       ii    - 1st dimension of a,p,az
c       jj    - 2nd dimension of a,p,az
c       kk    - 3rd dimension of a  (number of layers)
c       itype - interpolation type
c                 =-2; piecewise quadratic     across each layer
c                 =-1; piecewise linear        across each layer
c                 = 0; sample the layer        spaning each depth
c                 = 1; linear interpolation    between layer centers
c                 = 2; linear interpolation    between layer interfaces
c                 = 3; piecewise cubic hermite between layer centers
c
c  3) output arguments:
c       az    - scalar field
c
c  4) except at data voids, must have:
c           p(:,:,   1) == zero (surface)
c           p(:,:, l+1) >= p(:,:,l)
c           p(:,:,kk+1) == bathymetry
c
c  5) Alan J. Wallcraft, Naval Research Laboratory, February 2006.
c*
c**********
c
      integer i,j,k,l
      real    s,zk,z0,zm,zp
      real    si(kk,1),pi(kk+1),so(1,1),zo(1)
c
      do j= 1,jj
        do i= 1,ii
          if     (a(i,j,1).eq.flag) then
            az(i,j) = flag  ! land
          elseif (itype.lt.0 .or. itype.eq.3) then
            do k= 1,kk
              si(k,1) = a(i,j,k)
              pi(k)   = p(i,j,k)
            enddo
            pi(kk+1) = p(i,j,kk+1)
            zo(1)=max(0.0,p(i,j,kk+1)-zbot)
            if     (itype.eq.-1) then
              call layer2z_plm(si,pi,kk,1,so,zo,1, flag)
            elseif (itype.eq.-2) then
              call layer2z_ppm(si,pi,kk,1,so,zo,1, flag)
            else   !itype.eq. 3
              call layer2z_pch(si,pi,kk,1,so,zo,1, flag)
            endif
            az(i,j) = so(1,1)
          else
            zk=max(0.0,p(i,j,kk+1)-zbot)
            do l= 1,kk
              if     (p(i,j,l).le.zk .and. p(i,j,l+1).ge.zk) then
c
c               z(k) is in layer l.
c
                if     (itype.eq.0) then
c
c                 sample the layer
c
                  az(i,j) = a(i,j,l)
                elseif (itype.eq.1) then
c
c                 linear interpolation between layer centers
c
                  z0 = 0.5*(p(i,j,l)+p(i,j,l+1))
                  if     (zk.le.z0) then
c
c                   z(k) is in the upper half of the layer
c
                    if     (l.eq.1) then
                      az(i,j) = a(i,j,1)
                    else
                      zm = 0.5*(p(i,j,l-1)+p(i,j,l))
                      s  = (z0 - zk)/(z0 - zm)
                      az(i,j) = s*a(i,j,l-1) + (1.0-s)*a(i,j,l)
                    endif
                  else
c
c                   z(k) is in the lower half of the layer
c
                    if     (p(i,j,l+1).eq.p(i,j,kk+1)) then
                      az(i,j) = a(i,j,kk)
                    else
                      zp = 0.5*(p(i,j,l+1)+p(i,j,l+2))
                      s  = (zk - z0)/(zp - z0)
                      az(i,j) = s*a(i,j,l+1) + (1.0-s)*a(i,j,l)
                    endif
                  endif
                else !itype.eq.2
c
c                 linear interpolation between layer interfaces
c                 a is a vertical integral from the surface
c
                  if     (l.eq.1) then
                    s  = zk/p(i,j,2)
                    az(i,j) = s*a(i,j,1)
                  else
                    s  = (zk - p(i,j,l))/(p(i,j,l+1) - p(i,j,l))
                    az(i,j) = (1.0-s)*a(i,j,l-1) + s*a(i,j,l)
                  endif
                endif
                exit
              elseif (l.eq.kk) then
                az(i,j) = flag  ! below the bottom
                exit
              endif
            enddo !l
          endif
        enddo !i
      enddo !j
      return
      end

      subroutine layer2c(a,p,az,zi,flag,ii,jj,ib,it,jb,jt,kk,kz,itype)

      use mod_plot , ONLY :i0,j0,mnproc

      implicit none
c
      integer ii,jj,ib,it,jb,jt,kk,kz,itype
      real    a(ib:it,jb:jt,kk),p(ib:it,jb:jt,kk+1),az(ib:it,jb:jt,kz),
     &          zi(kz+1),flag
c
c**********
c*
c  1) interpolate a layered field to fixed z-cells.
c
c  2) input arguments:
c       a     - scalar field in layer space
c       p     - layer interface depths (non-negative m)
c                 p(:,:,   1) is the surface
c                 p(:,:,kk+1) is the bathymetry
c       zi    - target z-cell interface depths (non-negative m)
c       flag  - data void (land) marker
c       ii    - 1st dimension of a,p,az
c       jj    - 2nd dimension of a,p,az
c       kk    - 3rd dimension of a  (number of layers)
c       kz    - 3rd dimension of az (number of levels)
c       itype - interpolation type
c                 =0; piecewise constant  across each input cell
c                 =1; piecewise linear    across each input cell
c                 =2; piecewise parabolic across each input cell
c               result is the averaged input profile across each output cell
c
c  3) output arguments:
c       az    - scalar field in z-space
c
c  4) except at data voids, must have:
c           p(:,:,   1) == zero (surface)
c           p(:,:, l+1) >= p(:,:,l)
c           p(:,:,kk+1) == bathymetry
c           0 <= zi(k) <= zi(k+1)
c     note that zi(k) > p(i,j,kk+1) implies that az(i,j,k)=flag,
c      since the entire cell is then below the bathymetry.
c
c  5) Alan J. Wallcraft, Naval Research Laboratory, August 2005.
c*
c**********
c
      integer i,j,k
      real    si(kk,1),pi(kk+1),so(kz,1),po(kz+1)
c
      do j= 1,jj
        do i= 1,ii
          if     (a(i,j,1).eq.flag) then
            do k= 1,kz
              az(i,j,k) = flag  ! land
            enddo
          else
            do k= 1,kk
              si(k,1) = a(i,j,k)
              pi(k)   = p(i,j,k)
            enddo
            pi(kk+1) = p(i,j,kk+1)
            do k= 1,kz+1
              po(k) = zi(k)
            enddo
            if     (itype.eq.0) then
              call layer2c_pcm(si,pi,kk,1,so,po,kz, flag)
            elseif (itype.eq.1) then
              call layer2c_plm(si,pi,kk,1,so,po,kz, flag)
            else
              call layer2c_ppm(si,pi,kk,1,so,po,kz, flag)
            endif
            do k= 1,kz
              az(i,j,k) = so(k,1)
            enddo
          endif
        enddo !i
      enddo !j
      return
      end

      subroutine layer2c_bot(a,p,az,zbot,flag,ii,jj,ib,it,jb,jt,kk,
     &                       itype)
      implicit none
c
      integer ii,jj,ib,it,jb,jt,kk,itype
      real    a(ib:it,jb:jt,kk),p(ib:it,jb:jt,kk+1),az(ib:it,jb:jt),
     &        zbot,flag
c
c**********
c*
c  1) interpolate a layered field to a fixed z-cell above the bottom
c
c  2) input arguments:
c       a     - scalar field in layer space
c       p     - layer interface depths (non-negative m)
c                 p(:,:,   1) is the surface
c                 p(:,:,kk+1) is the bathymetry
c       zbot  - target interface height above the bottom (positive m)
c       flag  - data void (land) marker
c       ii    - 1st dimension of a,p,az
c       jj    - 2nd dimension of a,p,az
c       kk    - 3rd dimension of a  (number of layers)
c       itype - interpolation type
c                 =0; piecewise constant  across each input cell
c                 =1; piecewise linear    across each input cell
c                 =2; piecewise parabolic across each input cell
c               result is the averaged input profile across each output cell
c
c  3) output arguments:
c       az    - scalar field
c
c  4) except at data voids, must have:
c           p(:,:,   1) == zero (surface)
c           p(:,:, l+1) >= p(:,:,l)
c           p(:,:,kk+1) == bathymetry
c
c  5) Alan J. Wallcraft, Naval Research Laboratory, August 2005.
c*
c**********
c
      integer i,j,k
      real    si(kk,1),pi(kk+1),so(1,1),po(2)
c
      do j= 1,jj
        do i= 1,ii
          if     (a(i,j,1).eq.flag) then
            az(i,j) = flag  ! land
          else
            do k= 1,kk
              si(k,1) = a(i,j,k)
              pi(k)   = p(i,j,k)
            enddo
            pi(kk+1) = p(i,j,kk+1)
            po(1) = max( 0.0, p(i,j,kk+1) - zbot )
            po(2) =           p(i,j,kk+1)
            if     (itype.eq.0) then
              call layer2c_pcm(si,pi,kk,1,so,po,1, flag)
            elseif (itype.eq.1) then
              call layer2c_plm(si,pi,kk,1,so,po,1, flag)
            else
              call layer2c_ppm(si,pi,kk,1,so,po,1, flag)
            endif
            az(i,j) = so(1,1)
          endif
        enddo !i
      enddo !j
      return
      end

      subroutine layer2c_pcm(si,pi,ki,ks,
     &                       so,po,ko,   flag)
      implicit none
c
      integer ki,ks,ko
      real    si(ki,ks),pi(ki+1),
     &        so(ko,ks),po(ko+1),flag
c
c**********
c*
c  1) remap from one set of vertical cells to another.
c     method: piecewise constant across each input cell
c             the output is the average of the interpolation
c             profile across each output cell.
c
c  2) input arguments:
c       si    - scalar fields in pi-layer space
c       pi    - layer interface depths (non-negative m)
c                 pi(   1) is the surface
c                 pi(ki+1) is the bathymetry
c       ki    - 1st dimension of si     (number of  input layers)
c       ks    - 2nd dimension of si,so  (number of fields)
c       po    - target interface depths (non-negative m)
c                 po(k+1) >= po(k)
c       ko    - 1st dimension of so     (number of output layers)
c       flag  - data void (land) marker
c
c  3) output arguments:
c       so    - scalar fields in po-layer space
c
c  4) except at data voids, must have:
c           pi(   1) == zero (surface)
c           pi( l+1) >= pi(l)
c           pi(ki+1) == bathymetry
c           0 <= po(k) <= po(k+1)
c      output layers completely below the bathymetry are set to flag.
c
c  5) Alan J. Wallcraft,  Naval Research Laboratory,  Sep. 2002 (Aug. 2005).
c*
c**********
c
      real       thin
      parameter (thin=1.e-6)  ! minimum layer thickness (no division by 0.0)
c
      integer i,k,l,lf
      real    q,zb,zt,sok(ks)
c
      if     (si(1,1).eq.flag) then
        do k= 1,ko
          do i= 1,ks
            so(k,i) = flag  !land
          enddo !i
        enddo !k
      else
        lf=1
        zb=po(1)
        do k= 1,ko
          zt = zb
          zb = min( po(k+1), pi(ki+1) )  !limit for correct cell average
*         WRITE(6,*) 'k,zt,zb = ',k,zt,zb
          if     (zt.ge.pi(ki+1)) then
c
c ---       cell below the bottom, set to flag
c
            do i= 1,ks
              so(k,i) = flag
            enddo !i
          elseif (zb-zt.lt.thin) then
c
c ---       thin layer, values taken from layer above
c
            do i= 1,ks
              so(k,i) = so(k-1,i)
            enddo !i
          else
c
c           form layer averages.
c
            if     (pi(lf).gt.zt) then
              WRITE(6,*) 'bad lf = ',lf
              stop
            endif
            do i= 1,ks
              sok(i) = 0.0
            enddo !i
c           recalibrate lf, usualy exit loop immediately
            do l= lf,ki
              if     (pi(l+1).ge.zt) then
                exit
              elseif (k.eq.ki) then
                exit
              endif
            enddo !l
            lf=l
            do l= lf,ki
              if     (pi(l).gt.zb) then
*               WRITE(6,*) 'l,lf= ',l,lf,l-1
c               the input layer is below the output layer
                lf = l-1
                exit
              elseif (pi(l).ge.zt .and. pi(l+1).le.zb) then
c
c               the input layer is completely inside the output layer
c
                q   = max(pi(l+1)-pi(l),thin)/(zb-zt)
                do i= 1,ks
                  sok(i) = sok(i) + q*si(l,i)
                enddo !i
*               WRITE(6,*) 'L,q = ',l,q
              else
c
c               the input layer is partially inside the output layer
c
                q   = max(min(pi(l+1),zb)-max(pi(l),zt),thin)/(zb-zt)
                do i= 1,ks
                  sok(i) = sok(i) + q*si(l,i)
                enddo !i
*               WRITE(6,*) 'l,q = ',l,q
              endif
            enddo !l
            do i= 1,ks
              so(k,i) = sok(i)
            enddo !i
          endif
        enddo !k
      endif
      return
      end subroutine layer2c_pcm

      subroutine layer2z_plm(si,p,kk,ks,
     &                       sz,z,kz,   flag)
      implicit none
c
      integer kk,ks,kz
      real    si(kk,ks),p(kk+1),
     &        sz(kz,ks),z(kz),flag
c
c**********
c*
c  1) interpolate a set of layered field to fixed z depths.
c     method: piecewise linear across each cell
c
c  2) input arguments:
c       si    - scalar fields in layer space
c       p     - layer interface depths (non-negative m)
c                 p(   1) is the surface
c                 p(kk+1) is the bathymetry
c       kk    - dimension of si (number of layers)
c       ks    - dimension of si (number of fields)
c       z     - target z-level  depths (non-negative m)
c       flag  - data void (land) marker
c       kz    - dimension of sz (number of levels)
c
c  3) output arguments:
c       sz    - scalar fields in z-space
c
c  4) except at data voids, must have:
c           p(   1) == zero (surface)
c           p( l+1) >= p(:,:,l)
c           p(kk+1) == bathymetry
c           0 <= z(k) <= z(k+1)
c     note that z(k) > p(kk+1) implies that az(k)=flag,
c      since the z-level is then below the bathymetry.
c
c  5) Tim Campbell, Mississippi State University, October 2002.
c     Alan J. Wallcraft,  Naval Research Laboratory,  Aug. 2005.
c*
c**********
c
      real, parameter :: thin=1.e-6  !minimum layer thickness
c
      integer i,k,l,lf
      real    q,zk
      real    sis(kk,ks),pt(kk+1)
c
      if     (si(1,ks).eq.flag) then
        do k= 1,kz
          do i= 1,ks
            sz(k,i) = flag  !land
          enddo !i
        enddo
      else
c ---   compute PLM slopes for input layers
        do k=1,kk
          pt(k)=max(p(k+1)-p(k),thin)
        enddo
        call plm(pt,si,sis,kk,ks)
c
        lf=1
        do k= 1,kz
          zk=z(k)
          do l= lf,kk
            if     (p(l).le.zk .and. p(l+1).ge.zk) then
c
c             z(k) is in layer l, sample the linear profile at zk.
c
              q = (zk-p(l))/pt(l) - 0.5
              do i= 1,ks
                sz(k,i) = si(l,i) + q*sis(l,i)
              enddo !i
              lf = l  ! z monotonic increasing, so z(k+1) in layers l:kk
              exit
            elseif (l.eq.kk) then
              do i= 1,ks
                sz(k,i) = flag  ! below the bottom
              enddo !i
              lf = l
              exit
            endif
          enddo !l
        enddo !k
      endif
      return
      end

      subroutine layer2c_plm(si,pi,ki,ks,
     &                       so,po,ko,   flag)
      implicit none
c
      integer ki,ks,ko
      real    si(ki,ks),pi(ki+1),
     &        so(ko,ks),po(ko+1),flag
c
c**********
c*
c  1) remap from one set of vertical cells to another.
c     method: piecewise linear across each input cell
c             the output is the average of the interpolation
c             profile across each output cell.
c
c  2) input arguments:
c       si    - scalar fields in pi-layer space
c       pi    - layer interface depths (non-negative m)
c                 pi(   1) is the surface
c                 pi(ki+1) is the bathymetry
c       ki    - 1st dimension of si     (number of  input layers)
c       ks    - 2nd dimension of si,so  (number of fields)
c       po    - target interface depths (non-negative m)
c                 po(k+1) >= po(k)
c       ko    - 1st dimension of so     (number of output layers)
c       flag  - data void (land) marker
c
c  3) output arguments:
c       so    - scalar fields in po-layer space
c
c  4) except at data voids, must have:
c           pi(   1) == zero (surface)
c           pi( l+1) >= pi(l)
c           pi(ki+1) == bathymetry
c           0 <= po(k) <= po(k+1)
c      output layers completely below the bathymetry are set to flag.
c
c  5) Tim Campbell, Mississippi State University, October 2002.
c     Alan J. Wallcraft,  Naval Research Laboratory,  Aug. 2005.
c*
c**********
c
      real,parameter :: thin=1.e-6  !minimum layer thickness
c
      integer i,k,l,lf
      real    q,qc,zb,zc,zt,sok(ks)
      real    sis(ki,ks),pit(ki+1)
c
      if     (si(1,1).eq.flag) then
        do k= 1,ko
          do i= 1,ks
            so(k,i) = flag  !land
          enddo !i
        enddo
      else
c ---   compute PLM slopes for input layers
        do k=1,ki
          pit(k)=max(pi(k+1)-pi(k),thin)
        enddo
        call plm(pit,si,sis,ki,ks)
c ---   compute output layer averages
        lf=1
        zb=po(1)
        do k= 1,ko
          zt = zb
          zb = min( po(k+1), pi(ki+1) )  !limit for correct cell average
          if     (zt.ge.pi(ki+1)) then
c
c ---       cell below the bottom, set to flag
c
            do i= 1,ks
              so(k,i) = flag
            enddo !i
          elseif (zb-zt.lt.thin) then
c
c ---       thin layer, values taken from layer above
c
            do i= 1,ks
              so(k,i) = so(k-1,i)
            enddo !i
          else
c
c           form layer averages.
c
            if     (pi(lf).gt.zt) then
              WRITE(6,*) 'bad lf = ',lf
              stop
            endif
            do i= 1,ks
              sok(i) = 0.0
            enddo !i
c           recalibrate lf, usualy exit loop immediately
            do l= lf,ki
              if     (pi(l+1).ge.zt) then
                exit
              elseif (k.eq.ki) then
                exit
              endif
            enddo !l
            lf=l
            do l= lf,ki
              if     (pi(l).gt.zb) then
c               the input layer is below the output layer
                lf = l-1
                exit
              elseif (pi(l).ge.zt .and. pi(l+1).le.zb) then
c
c               the input layer is completely inside the output layer
c
                q   = max(pi(l+1)-pi(l),thin)/(zb-zt)
                do i= 1,ks
                  sok(i) = sok(i) + q*si(l,i)
                enddo !i
              else
c
c               the input layer is partially inside the output layer
c               average of linear profile is its center value
c
                q   = max( min(pi(l+1),zb)-max(pi(l),zt), thin )/(zb-zt)
                zc  = 0.5*(min(pi(l+1),zb)+max(pi(l),zt))
                qc  = (zc-pi(l))/pit(l) - 0.5
                do i= 1,ks
                  sok(i) = sok(i) + q*(si(l,i) + qc*sis(l,i))
                enddo !i
              endif
            enddo !l
            do i= 1,ks
              so(k,i) = sok(i)
            enddo !i
          endif
        enddo !k
      endif
      return
      end subroutine layer2c_plm

      subroutine plm(pt, s,ss,ki,ks)
      implicit none
c
      integer ki,ks
      real    pt(ki+1),s(ki,ks),ss(ki,ks)
c
c**********
c*
c  1) generate a monotonic PLM interpolation of a layered field
c
c  2) input arguments:
c       pt    - layer interface thicknesses (non-zero)
c       s     - scalar fields in layer space
c       ki    - 1st dimension of s (number of layers)
c       ks    - 2nd dimension of s (number of fields)
c
c  3) output arguments:
c       ss    - scalar field slopes for PLM interpolation
c
c  4) except at data voids, must have:
c           pi(   1) == zero (surface)
c           pi( l+1) >= pi(:,:,l)
c           pi(ki+1) == bathymetry
c
c  5) Tim Campbell, Mississippi State University, September 2002.
c*
c**********
c
      integer l
      real    ql(ki),qc(ki),qr(ki)
c
      !compute grid spacing ratios for slope computations
      ql(1)=0.0
      qc(1)=0.0
      qr(1)=0.0
      do l=2,ki-1
        ql(l)=2.0*pt(l)/(pt(l-1)+pt(l))
        qc(l)=2.0*pt(l)/(pt(l-1)+2.0*pt(l)+pt(l+1))
        qr(l)=2.0*pt(l)/(pt(l)+pt(l+1))
      enddo
      ql(ki)=0.0
      qc(ki)=0.0
      qr(ki)=0.0
      !compute normalized layer slopes
      do l=1,ks
        call slope(ql,qc,qr,s(1,l),ss(1,l),ki)
      enddo
      return
      end subroutine plm

      subroutine slope(rl,rc,rr,a,s,n)
      implicit none
c
      integer,intent(in)  :: n
      real,   intent(in)  :: rl(n),rc(n),rr(n),a(n)
      real,   intent(out) :: s(n)
c
c**********
c*
c  1) generate slopes for monotonic piecewise linear distribution
c
c  2) input arguments:
c       rl   - left grid spacing ratio
c       rc   - center grid spacing ratio
c       rr   - right grid spacing ratio
c       a    - scalar field zone averages
c       n    - number of zones
c
c  3) output arguments:
c       s    - zone slopes
c
c  4) Tim Campbell, Mississippi State University, September 2002.
c*
c**********
c
      integer,parameter :: ic=2, im=1, imax=100
      real,parameter :: fracmin=1e-6, dfac=0.5
c
      integer i,j
      real    sl,sc,sr
      real    dnp,dnn,dl,dr,ds,frac
c
c Compute zone slopes
c Campbell Eq(15) -- nonuniform grid
c
      s(1)=0.0
      do j=2,n-1
        sl=rl(j)*(a(j)-a(j-1))
        sr=rr(j)*(a(j+1)-a(j))
        if (sl*sr.gt.0.) then
          s(j)=sign(min(abs(sl),abs(sr)),sl)
        else
          s(j)=0.0
        endif
      enddo
      s(n)=0.0
c
c Minimize discontinuities between zones
c Apply single pass discontinuity minimization: Campbell Eq(19)
c
      do j=2,n-1
        if(s(j).ne.0.0) then
          dl=-0.5*(s(j)+s(j-1))+a(j)-a(j-1)
          dr=-0.5*(s(j+1)+s(j))+a(j+1)-a(j)
          ds=sign(min(abs(dl),abs(dr)),dl)
          s(j)=s(j)+2.0*ds
        endif
      enddo
      return
      end subroutine slope

      subroutine layer2z_ppm(si,p,kk,ks,
     &                       sz,z,kz,   flag)
      implicit none
c
      integer kk,ks,kz
      real    si(kk,ks),p(kk+1),
     &        sz(kz,ks),z(kz),flag
c
c**********
c*
c  1) interpolate a set of layered field to fixed z depths.
c     method: piecewise parabolic method across each cell
c
c  2) input arguments:
c       si    - scalar fields in layer space
c       p     - layer interface depths (non-negative m)
c                 p(   1) is the surface
c                 p(kk+1) is the bathymetry
c       kk    - dimension of si (number of layers)
c       ks    - dimension of si (number of fields)
c       z     - target z-level  depths (non-negative m)
c       flag  - data void (land) marker
c       kz    - dimension of az (number of levels)
c
c  3) output arguments:
c       sz    - scalar fields in z-space
c
c  4) except at data voids, must have:
c           p(   1) == zero (surface)
c           p( l+1) >= p(:,:,l)
c           p(kk+1) == bathymetry
c           0 <= z(k) <= z(k+1)
c     note that z(k) > p(kk+1) implies that az(k)=flag,
c      since the z-level is then below the bathymetry.
c
c  5) Tim Campbell, Mississippi State University, October 2002.
c     Alan J. Wallcraft,  Naval Research Laboratory,  Aug. 2005.
c*
c**********
c
      real, parameter :: thin=1.e-6  !minimum layer thickness
c
      integer i,k,l,lf
      real    q,zk
      real    sic(kk,ks,3),pt(kk+1)
c
      if     (si(1,ks).eq.flag) then
        do k= 1,kz
          do i= 1,ks
            sz(k,i) = flag  !land
          enddo !i
        enddo
      else
c ---   compute PPM coefficients for input layers
        do k=1,kk
          pt(k)=max(p(k+1)-p(k),thin)
        enddo
        call ppm(pt,si,sic,kk,ks)
c
        lf=1
        do k= 1,kz
          zk=z(k)
          do l= lf,kk
            if     (p(l).le.zk .and. p(l+1).ge.zk) then
c
c             z(k) is in layer l, sample the quadratic profile at zk.
c
              q = (zk-p(l))/pt(l)
              do i= 1,ks
                sz(k,i) =    sic(l,i,1) +
     &                    q*(sic(l,i,2) +
     &                       sic(l,i,3)*(1.0-q))
              enddo !i
              lf = l  ! z monotonic increasing, so z(k+1) in layers l:kk
              exit
            elseif (l.eq.kk) then
              do i= 1,ks
                sz(k,i) = flag  ! below the bottom
              enddo !i
              lf = l
              exit
            endif
          enddo !l
        enddo !k
      endif
      return
      end

      subroutine layer2c_ppm(si,pi,ki,ks,
     &                       so,po,ko,   flag)
      implicit none
c
      integer ki,ks,ko
      real    si(ki,ks),pi(ki+1),
     &        so(ko,ks),po(ko+1),flag
c
c**********
c*
c  1) remap from one set of vertical cells to another.
c     method: piecewise parabolic method across each input cell
c             the output is the average of the interpolation
c             profile across each output cell.
c
c  2) input arguments:
c       si    - scalar fields in pi-layer space
c       pi    - layer interface depths (non-negative m)
c                 pi(   1) is the surface
c                 pi(ki+1) is the bathymetry
c       ki    - 1st dimension of si     (number of  input layers)
c       ks    - 2nd dimension of si,so  (number of fields)
c       po    - target interface depths (non-negative m)
c                 po(k+1) >= po(k)
c       ko    - 1st dimension of so     (number of output layers)
c       flag  - data void (land) marker
c
c  3) output arguments:
c       so    - scalar fields in po-layer space
c
c  4) except at data voids, must have:
c           pi(   1) == zero (surface)
c           pi( l+1) >= pi(l)
c           pi(ki+1) == bathymetry
c           0 <= po(k) <= po(k+1)
c      output layers completely below the bathymetry are set to flag.
c
c  5) Tim Campbell, Mississippi State University, October 2002.
C     Alan J. Wallcraft,  Naval Research Laboratory,  Aug. 2005.
c*
c**********
c
      real,parameter :: thin=1.e-6  !minimum layer thickness
c
      integer i,k,l,lb,lt
      real    sz,xb,xt,zb,zt
      real    sic(ki,ks,3),pit(ki+1)
c
      if     (si(1,1).eq.flag) then
        do k= 1,ko
          do i= 1,ks
            so(k,i) = flag  !land
          enddo !i
        enddo
      else
c ---   compute PPM coefficients for input layers
        do k=1,ki
          pit(k)=max(pi(k+1)-pi(k),thin)
        enddo
        call ppm(pit,si,sic,ki,ks)
c ---   compute output layer averages
        lb=1
        zb=po(1)
        do k= 1,ko
          zt = zb
          zb = min( po(k+1), pi(ki+1) )  !limit for correct cell average
          if     (zt.ge.pi(ki+1)) then
c
c ---       cell below the bottom, set to flag
c
            do i= 1,ks
              so(k,i) = flag
            enddo !i
          elseif (zb-zt.lt.thin) then
c
c ---       thin layer, values taken from layer above
c
            do i= 1,ks
              so(k,i) = so(k-1,i)
            enddo !i
          else
c
c           form layer averages.
c
            if     (pi(lb).gt.zt) then
              WRITE(6,*) 'bad lb = ',lb
              stop
            endif
            lt=lb !top will always correspond to bottom of previous
            lb=lt !find input layer containing bottom output interface
            do while (pi(lb+1).lt.zb.and.lb.lt.ki)
              lb=lb+1
            enddo
            xt=(zt-pi(lt))/pit(lt)
            xb=(zb-pi(lb))/pit(lb)
            do i= 1,ks
              if     (lt.ne.lb) then
                sz=   pit(lt)*(      sic(lt,i,1)  *(1.-xt)
     &                         +0.5*(sic(lt,i,2)+
     &                               sic(lt,i,3) )*(1.-xt**2)
     &                              -sic(lt,i,3)  *(1.-xt**3)/3.0)
                do l=lt+1,lb-1
                  sz=sz+pit(l)*si(l,i)
                enddo !l
                sz=sz+pit(lb)*(      sic(lb,i,1)  *    xb
     &                         +0.5*(sic(lb,i,2)+
     &                               sic(lb,i,3) )*    xb**2
     &                              -sic(lb,i,3)  *    xb**3 /3.0)
              else
                sz=pit(lt)*(      sic(lt,i,1)  *(xb-xt)
     &                      +0.5*(sic(lt,i,2)+
     &                            sic(lt,i,3) )*(xb**2-xt**2)
     &                           -sic(lt,i,3)  *(xb**3-xt**3)/3.0)
              endif
              so(k,i) = sz/(zb-zt)
            enddo !i
          endif !thin:std layer
        enddo !k
      endif
      return
      end subroutine layer2c_ppm

      subroutine ppm(pt, s,sc,ki,ks)
      implicit none
c
      integer ki,ks
      real    pt(ki+1),s(ki,ks),sc(ki,ks,3)
c
c**********
c*
c  1) generate a monotonic PPM interpolation of a layered field:
c     Colella, P. & P.R. Woodward, 1984, J. Comp. Phys., 54, 174-201.
c
c  2) input arguments:
c       pt    - layer interface thicknesses (non-zero)
c       s     - scalar fields in layer space
c       ki    - 1st dimension of s (number of layers)
c       ks    - 2nd dimension of s (number of fields)
c
c  3) output arguments:
c       sc    - scalar field coefficients for PPM interpolation
c
c  4) except at data voids, must have:
c           pi(   1) == zero (surface)
c           pi( l+1) >= pi(:,:,l)
c           pi(ki+1) == bathymetry
c
c  5) Tim Campbell, Mississippi State University, September 2002;
C     Alan J. Wallcraft,  Naval Research Laboratory,  August 2007.
c*
c**********
c
      integer j,k,l
      real    da,a6,slj,scj,srj
      real    as(ki),al(ki),ar(ki)
      real     ptjp(ki), pt2jp(ki), ptj2p(ki),
     &        qptjp(ki),qpt2jp(ki),qptj2p(ki),ptq3(ki),qpt4(ki)
c
      !compute grid metrics
      do j=1,ki
         ptjp( j) = pt(j)   + pt(j+1)
         pt2jp(j) = pt(j)   + ptjp(j)
         ptj2p(j) = ptjp(j) + pt(j+1)
        qptjp( j) = 1.0/ptjp( j)
        qpt2jp(j) = 1.0/pt2jp(j)
        qptj2p(j) = 1.0/ptj2p(j)
      enddo !j
         ptq3(1) = 0.0
         ptq3(2) = pt(2)/(pt(1)+ptjp(2))
      do j=3,ki-1
         ptq3(j) = pt(j)/(pt(j-1)+ptjp(j))  !pt(j)/      (pt(j-1)+pt(j)+pt(j+1))
         qpt4(j) = 1.0/(ptjp(j-2)+ptjp(j))  !1.0/(pt(j-2)+pt(j-1)+pt(j)+pt(j+1))
      enddo !j
c
      do l= 1,ks
        !Compute average slopes: Colella, Eq. (1.8)
        as(1)=0.
        do j=2,ki-1
          slj=s(j,  l)-s(j-1,l)
          srj=s(j+1,l)-s(j,  l)
          if (slj*srj.gt.0.) then
            scj=ptq3(j)*( pt2jp(j-1)*srj*qptjp(j)
     &                   +ptj2p(j)  *slj*qptjp(j-1) )
            as(j)=sign(min(abs(2.0*slj),abs(scj),abs(2.0*srj)),scj)
          else
            as(j)=0.
          endif
        enddo !j
        as(ki)=0.
        !Compute "first guess" edge values: Colella, Eq. (1.6)
        al(1)=s(1,l)  !1st layer PCM
        ar(1)=s(1,l)  !1st layer PCM
        al(2)=s(1,l)  !1st layer PCM
        do j=3,ki-1
          al(j)=s(j-1,l)+pt(j-1)*(s(j,l)-s(j-1,l))*qptjp(j-1)
     &         +qpt4(j)*(
     &            2.*pt(j)*pt(j-1)*qptjp(j-1)*(s(j,l)-s(j-1,l))*
     &            ( ptjp(j-2)*qpt2jp(j-1)
     &             -ptjp(j)  *qptj2p(j-1) )
     &            -pt(j-1)*as(j)  *ptjp(j-2)*qpt2jp(j-1)
     &            +pt(j)  *as(j-1)*ptjp(j)  *qptj2p(j-1)
     &              )
          ar(j-1)=al(j)
        enddo !j
        ar(ki-1)=s(ki,l)  !last layer PCM
        al(ki)  =s(ki,l)  !last layer PCM
        ar(ki)  =s(ki,l)  !last layer PCM
        !Impose monotonicity: Colella, Eq. (1.10)
        do j=2,ki-1
          if ((s(j+1,l)-s(j,l))*(s(j,l)-s(j-1,l)).le.0.) then !local extremum
            al(j)=s(j,l)
            ar(j)=s(j,l)
          else
            da=ar(j)-al(j)
            a6=6.0*s(j,l)-3.0*(al(j)+ar(j))
            if     (da*a6 .gt.  da*da) then !peak in right half of zone
              al(j)=3.0*s(j,l)-2.0*ar(j)
            elseif (da*a6 .lt. -da*da) then !peak in left half of zone
              ar(j)=3.0*s(j,l)-2.0*al(j)
            endif
          endif
        enddo !j
        !Set coefficients
        do j=1,ki
          sc(j,l,1)=al(j)
          sc(j,l,2)=ar(j)-al(j)
          sc(j,l,3)=6.0*s(j,l)-3.0*(al(j)+ar(j))
        enddo !j
      enddo !l
      return
      end subroutine ppm

      subroutine layer2z_pch(si,p,kk,ks,
     &                       sz,z,kz,   flag)
      implicit none
c
      integer kk,ks,kz
      real    si(kk,ks),p(kk+1),
     &        sz(kz,ks),z(kz),flag
c
c**********
c*
c  1) interpolate a set of layered fields to fixed z depths.
c     method: piecewise cubic hermite interpolation (PCHIP) between cell centers
c
c  2) input arguments:
c       si    - scalar fields in layer space
c       p     - layer interface depths (non-negative m)
c                 p(   1) is the surface
c                 p(kk+1) is the bathymetry
c       kk    - dimension of si (number of layers)
c       ks    - dimension of si (number of fields)
c       z     - target z-level  depths (non-negative m)
c       flag  - data void (land) marker
c       kz    - dimension of sz (number of levels)
c
c  3) output arguments:
c       sz    - scalar fields in z-space
c
c  4) except at data voids, must have:
c           p(   1) == zero (surface)
c           p( l+1) >= p(:,:,l)
c           p(kk+1) == bathymetry
c           0 <= z(k) <= z(k+1)
c     note that z(k) > p(kk+1) implies that az(k)=flag,
c      since the z-level is then below the bathymetry.
c
c  5) Alan J. Wallcraft, COAPS, January 2018.
c*
c**********
c
      integer i,k,l,lf,ngood
      real    oldz(kk+1),olds(kk+1)
c
      if     (si(1,ks).eq.flag) then
        do k= 1,kz
          do i= 1,ks
            sz(k,i) = flag  !land
          enddo !i
        enddo !k
      else
        do k= 1,kk
          oldz(k) = 0.5*(p(k+1)+p(k))
          if     (p(k+1).eq.p(kk+1)) then  !.true. for k==kk
            ngood = k
            exit
          endif
        enddo !k
        oldz(ngood+1) = p(kk+1)
c
c ---   loop through scalar fields
        do i= 1,ks
          do k= 1,ngood
            olds(k) = si(k,i)
          enddo !k
          olds(ngood+1) = olds(ngood)
          call pchip(ngood+1,oldz,olds, flag, kz,z,sz(1,i))
        enddo !i
      endif
      return
      end

      subroutine pchip(nin,xin,yin, flag, nout,xout,yout)
! 20040924 Rowley, C.
!   modified somewhat from pchiptest.f from Mike Carnes Sep 2004
!   AJW: removed gapsiz added flag
      implicit none
c
      integer, intent(in)  :: nin
      real,    intent(in)  :: xin(nin),yin(nin)
      real,    intent(in)  :: flag
      integer, intent(in)  :: nout
      real,    intent(in)  :: xout(nout)
      real,    intent(out) :: yout(nout)
c
      integer :: k,kk
      real    :: del(nin),b(nin),c(nin),d(nin)
      logical :: keepgoing
      real    :: hh,s
!
! PCHIP  Piecewise Cubic Hermite Interpolating Polynomial.
! X is a row or column vector.  Y is a row or column vector of the same
! length as X, or a matrix with length(X) columns.
! YI = PCHIP(X,Y,XI) evaluates an interpolant at the elements of XI.
! PP = PCHIP(X,Y) returns a piecewise polynomial structure for use by PPVAL.
!
! The PCHIP interpolating function, P(x), satisfies:
!   On each subinterval,  x(k) <= x <= x(k+1),  P(x) is the cubic Hermite
!     interpolant to the given values and certain slopes at the two endpoints.
!   Therefore, P(x) interpolates y, i.e., P(x(j)) = y(j), and the first
!     derivative, P(x), is continuous, but P''(x) is probably not continuous;
!     there may be jumps at the x(j).
!   The slopes at the x(j) are chosen in such a way that P(x) is
!     "shape preserving" and "respects monotonicity". This means that,
!     on intervals where the data are monotonic, so is P(x);
!     at points where the data have a local extremum, so does P(x).
!
! References:
!   F. N. Fritsch and R. E. Carlson, "Monotone Piecewise Cubic
!   Interpolation", SIAM J. Numerical Analysis 17, 1980, 238-246.
!   David Kahaner, Cleve Moler and Stephen Nash, Numerical Methods
!   and Software, Prentice Hall, 1988.
!
! Find indices of subintervals, x(k) <= u < x(k+1).
! there must be at least two x values
!
c      kk=1
c      keepgoing=.true.
c      do k=1,nout
c        if(u(k).lt.x(1)) then
c          kk=1
c        else
c          dowhile((x(kk+1).lt.u(k)).and.keepgoing) then
c            if(kk.lt.nin-1) then
c              kk=kk+1
c            else
c              keepgoing=.false.
c            endif
c          enddo
c        endif
c        ku(k)=kk
c        s(k) = u(k) - x(ku(k));
c      enddo

! Compute slopes and other coefficients.
!
c      write(10,'(a)') 'k,del(k)'
      do k=1,nin-1
        del(k)=(yin(k+1)-yin(k))/(xin(k+1)-xin(k));  ! write(10,*) k,del(k)
      enddo
c
      call pchipslopes(nin,xin,yin,del,d);           ! write(10,'(a)') 'k,c,b,d'
c
      do k=1,nin-1
        hh=xin(k+1)-xin(k)
        c(k)=(3.*del(k)-2.*d(k)-d(k+1))/hh
        b(k)=(d(k)-2.*del(k)+d(k+1))/(hh*hh);        ! write(10,*) k,c(k),b(k),d(k)
      enddo

! Evaluate interpolant.
c     write(10,'(a)') 'evaluate interpolant'
c
      kk=1
      do k=1,nout
        if(xout(k).lt.xin(1)) then
          yout(k)=yin(1)
        elseif(xout(k).ge.xin(1).and.xout(k).le.xin(nin)) then
          if(xout(k).eq.xin(nin)) then
            yout(k)=yin(nin)
          else
            do while(xin(kk+1).lt.xout(k))
              kk=kk+1
            enddo
            if(abs(xout(k)-xin(kk)).lt.0.001) then
              yout(k)=yin(kk)
            else
              s=xout(k)-xin(kk)
              yout(k)=yin(kk)+s*(d(kk)+s*(c(kk)+s*b(kk)));
              ! write(10,*) k,kk,s,y(kk),d(kk),c(kk),b(kk)
            endif
          endif
        else
          yout(k)=flag
        endif
      enddo
c
      return
      end subroutine pchip

      subroutine pchipslopes(n,x,y,del,d)
      implicit none
c
      integer, intent(in)    :: n
      real,    intent(in)    :: x(n),y(n),del(n)
      real,    intent(inout) :: d(n)
c
      real    :: h(n)
      real    :: hs,w1,w2,dmax,dmin
      integer :: k
      integer :: isign1,isign2
!
! PCHIPSLOPES  Derivative values for Piecewise Hermite Cubic Interpolation.
! d = pchipslopes(x,y,del) computes the first derivatives, d(k) = P'(x(k))'.
!
      real, parameter :: thin=1.e-6  !minimum layer thickness
!
      do k=1,n
        d(k)=0.
      enddo
!
!     Special case n=2, use linear interpolation.
      if(n.eq.2) then
        d(1) = del(1);
        d(2) = del(1);
        return
      endif
!
!  Slopes at interior points.
!  d(k) = weighted average of del(k-1) and del(k) when they have the same sign.
!  d(k) = 0 when del(k-1) and del(k) have opposites signs or either is zero.
!
      do k=1,n
        d(k)=0.
      enddo
c
      do k=1,n-1
        h(k)=max(x(k+1)-x(k),thin)
      enddo
c
      do k=1,n-2
        if ((del(k).gt.0..and.del(k+1).gt.0.).or.
     &      (del(k).lt.0..and.del(k+1).lt.0.)    ) then
          hs=h(k)+h(k+1)
          w1=(h(k)+hs)/(3.*hs)
          w2=(hs+h(k+1))/(3.*hs)
          dmax=max(abs(del(k)),abs(del(k+1)))
          dmin=min(abs(del(k)),abs(del(k+1)))
          d(k+1)=dmin/(w1*(del(k)/dmax)+w2*(del(k+1)/dmax))
        endif
      enddo
!
!  Slopes at end points.
!  Set d(1) and d(n) via non-centered, shape-preserving three-point formulae.
      d(1)=((2.*h(1)+h(2))*del(1)-h(1)*del(2))/(h(1)+h(2))
c
      isign1=0
      if(d(1).gt.0..and.del(1).gt.0.) then
        isign1=1
      elseif(d(1).lt.0..and.del(1).lt.0.) then
        isign1=1
      elseif(d(1).eq.0..and.del(1).eq.0.) then
        isign1=1
      endif
c
      isign2=0
      if(del(1).gt.0..and.del(2).gt.0.) then
        isign2=1
      elseif(del(1).lt.0..and.del(2).lt.0.) then
        isign2=1
      elseif(del(1).eq.0..and.del(2).eq.0.) then
        isign2=1
      endif
c
      if(isign1.eq.0) then
        d(1)=0.
      elseif((isign2.eq.0).and.(abs(d(1)).gt.abs(3.*del(1)))) then
        d(1)=3.*del(1)
      endif
c
      d(n)=((2.*h(n-1)+h(n-2))*del(n-1)-h(n-1)*del(n-2))/(h(n-1)+h(n-2))
c
      isign1=0
      if(d(n).gt.0..and.del(n-1).gt.0.) then
        isign1=1
      elseif(d(n).lt.0..and.del(n-1).lt.0.) then
        isign1=1
      elseif(d(n).eq.0..and.del(n-1).eq.0.) then
        isign1=1
      endif
c
      isign2=0
      if(del(n-1).gt.0..and.del(n-2).gt.0.) then
        isign2=1
      elseif(del(n-1).lt.0..and.del(n-2).lt.0.) then
        isign2=1
      elseif(del(n-1).eq.0..and.del(n-2).eq.0.) then
        isign2=1
      endif
c
      if(isign1.eq.0) then
        d(n)=0.
      elseif((isign2.eq.0).and.(abs(d(n)).gt.abs(3.*del(n-1)))) then
        d(n)=3.*del(n-1)
      endif
c
      return
      end subroutine pchipslopes


module isotherm

  !---------------------------------------------------------------------------
  !
  !  These functions compute the equilibrium isotherms.
  !
  !---------------------------------------------------------------------------

  implicit none
  public
  integer, parameter :: dp = kind(1.d0)

contains

  !---------------------------------------------------------------------------
  !
  !  Langmuir isotherm
  !
  !  Computes psi(z) as function of background concentration psi_b,
  !  the free energy parameters, and position z.
  !
  !  Assumes an equilibrium compositional order parameter profile
  !  phi(z) = tanh ((z - z0)/xi0)
  !
  !---------------------------------------------------------------------------

  function psi_langmuir(psi_b, epsilon, w, kt, z, z0, xi0)

    real (dp)             :: psi_langmuir
    real (dp), intent(in) :: psi_b
    real (dp), intent(in) :: epsilon, w, kt
    real (dp), intent(in) :: z, z0, xi0

    real (dp) :: phi, dphi, psi_c

    phi = tanh((z - z0)/xi0)
    dphi = 1.0/(xi0*xi0*cosh((z-z0)/xi0)**4)

    psi_c = exp((1.0/kt)*(-0.5*epsilon*dphi + 0.5*w*(phi*phi - 1)))
    psi_langmuir = psi_b / (psi_b + psi_c)

  end function psi_langmuir

  !--------------------------------------------------------------------------
  !
  !  Frumkin isotherm
  !
  !  Use a bisection method to find a value of psi on [0,1]
  !  which satisfies psi = psi_b / (psi_b + exp(-a - b psi)/kT)
  !  using the equilibrium profile of phi.
  !
  !  The bisection method is from Press et al. chapter 9.
  !
  !--------------------------------------------------------------------------

  function psi_frumkin(psi_b, beta, epsilon, w, kt, z, z0, xi0)

    real (dp)             :: psi_frumkin
    real (dp), intent(in) :: psi_b               ! background concentration
    real (dp), intent(in) :: beta, epsilon, w, kt! free energy parameters
    real (dp), intent(in) :: z, z0, xi0          ! phi = tanh((z-z0)/xi0)

    integer :: nmax = 100
    integer :: n

    real (dp) :: x, dx, xmid, fmid
    real (dp) :: a, b

    a = 0.5*epsilon/(xi0*xi0*cosh((z-z0)/xi0)**4) &
         - 0.5*w*(tanh((z-z0)/xi0)**2 - 1.0)
    b = beta/(xi0*xi0*cosh((z-z0)/xi0)**4)

    ! We know f(x = 1.0) > f(x = 0.0)
    x = 0.0
    dx = 1.0

    do n = 1, nmax
       dx = dx*0.5
       xmid = x + dx
       fmid = xmid*(psi_b + exp(-(a + b*xmid)/kt)) - psi_b
       if (fmid <= 0.0) x = xmid
       if (fmid == 0.0) continue
    end do

    psi_frumkin = xmid
    return

  end function psi_frumkin

  !---------------------------------------------------------------------------
  !
  !  psi_0_diamant
  !
  !  This is again essentially the Frumkin isotherm as used by
  !  Diamant and Andelman J. Phys. Chem 100, 13732 (1996).
  !
  !---------------------------------------------------------------------------

  function psi_0_diamant(psi_b, alpha, beta, kT)

    real (dp)             :: psi_0_diamant
    real (dp), intent(in) :: psi_b               ! background concentration
    real (dp), intent(in) :: alpha, beta, kt     ! free energy parameters

    integer :: nmax = 100
    integer :: n

    real (dp) :: x, dx, xmid, fmid

    ! We know f(x = 1.0) > f(x = 0.0)
    x = 0.0
    dx = 1.0

    do n = 1, nmax
       dx = dx*0.5
       xmid = x + dx
       fmid = xmid*(psi_b + exp(-(alpha + beta*xmid)/kt)) - psi_b
       if (fmid <= 0.0) x = xmid
       if (fmid == 0.0) continue
    end do

    psi_0_diamant = xmid
    return

  end function psi_0_diamant

end module isotherm


      double precision function  fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc
      integer blockno

      integer example
      common /example_comm/ example

      integer*8 cont, get_context
      logical fclaw2d_map_is_used

      double precision xp, yp, zp

      double precision r, r0

      cont = get_context()

      if (fclaw2d_map_is_used(cont)) then
         call fclaw2d_map_c2m(cont,
     &         blockno,xc,yc,xp,yp,zp)
      else
         xp = xc
         yp = yc
      endif

      r0 = 0.2
      r = sqrt((xp-0.5)**2 + (yp-0.5)**2)
      fdisc = r - r0

      end