!# This source file is distributed with code Pégase.3.0.1 (2019-02-21).
!# Copyright: Michel Fioc (Michel.Fioc@iap.fr), Sorbonne université, 
!# Institut d'astrophysique de Paris/CNRS, France.
!# 
!# Pégase.3.0.1 is governed by the CeCILL license under French law and abides 
!# by the rules of distribution of free software. You can use, modify and/or 
!# redistribute this software under the terms of the CeCILL license as circulated 
!# by CEA, CNRS and INRIA at "http://www.cecill.info". The text of this license
!# is also available in French and in English in directory "doc_dir/" of this
!# code.
!# 
!# As a counterpart to the access to the source code and to the rights to copy,
!# modify and redistribute it granted by the license, users are provided only
!# with a limited warranty, and the software's author, the holder of the
!# economic rights, and the successive licensors have only limited
!# liability. 
!# 
!# The fact that you are presently reading this means that you have had
!# knowledge of the CeCILL license and that you accept its terms.
!#====================================================================== 

module mod_interp

  use mod_types

  implicit none
  private

  interface bracket
     module procedure bracket_SPR, bracket_DPR
  end interface bracket

  interface Steffen
     module procedure Steffen_SPR, Steffen_DPR
  end interface Steffen

  interface Steffen3
     module procedure Steffen3_SPR, Steffen3_DPR
  end interface Steffen3

  interface Steffen4
     module procedure Steffen4_SPR, Steffen4_DPR
  end interface Steffen4

  interface interp_lin_lin
     module procedure interp_lin_lin_SPR, interp_lin_lin_DPR
  end interface interp_lin_lin

  interface interp_lin_log
     module procedure interp_lin_log_SPR, interp_lin_log_DPR
  end interface interp_lin_log

  interface interp_log_lin
     module procedure interp_log_lin_SPR, interp_log_lin_DPR
  end interface interp_log_lin

  interface interp_log_log
     module procedure interp_log_log_SPR, interp_log_log_DPR
  end interface interp_log_log

  interface compute_weights
     module procedure compute_weights_SPR, compute_weights_DPR
  end interface compute_weights

  public :: bracket, Steffen, Steffen3, Steffen4, interp_lin_lin, &
       interp_lin_log, interp_log_lin, interp_log_log, &
       compute_weights

contains

!#======================================================================

  subroutine bracket_SPR(n, x, t, i, extrap)

!# ??? Add case where `x` is in reverse order.
!# ??? Add check that `x` is monotonous.

!# Given an array `x(1) <= ... <= x(n)`, `bracket` finds the integer `i`
!# such that `x(i) <= t <= x(i+1)`.
!# If `t <= x(1)`, `i = 1`; if `t >= x(n)`, `i = n-1`.
!# If `i = 0` in input, `bracket` finds `i` by dichotomy between 1 and
!# `n`; otherwise, the input `i` is used as an initial guess.

    implicit none
    integer, intent(in) :: n
    real(SPR), dimension(:), intent(in) :: x
    real(kind(x)), intent(in) :: t
    integer, intent(inout) :: i
    character(len=max(len("down"), len("up"), len("none"))), intent(out), optional :: extrap
!#......................................................................
    integer :: i_inf, i_sup, i_med, d_i
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (t < x(1)) then !# Downward extrapolation.
       i_inf = 1
       if (present(extrap)) extrap = "down"
    else if (t > x(n)) then !# Upward extrapolation.
       if (present(extrap)) extrap = "up"
       i_inf = n-1
    else !# Interpolation.
       if (present(extrap)) extrap = "none"
       i_inf = 1
       i_sup = n
       if (i >= 1 .and. i <= n) then !# Valid initial guess provided; \
!#                                      search first in the vicinity of `x(i)`.
          d_i = 1
          if (t >= x(i)) then
             i_inf = i
             i_sup = min(n, i+d_i)
             do while(t > x(i_sup))
                i_inf = i_sup
                d_i = 2*d_i
                i_sup = min(n, i+d_i)
             enddo
          else
             i_sup = i
             i_inf = max(1, i-d_i)
             do while(t < x(i_inf))
                i_sup = i_inf
                d_i = 2*d_i
                i_inf = max(1, i-d_i)
             enddo
          endif
       endif
!# Search by dichotomy:
       do while (i_inf+1 < i_sup)
          i_med = (i_inf+i_sup)/2
          if (t <= x(i_med)) then
             i_sup = i_med
          else
             i_inf = i_med
          end if
       end do
    endif

    i = i_inf

  end subroutine bracket_SPR

!#======================================================================

  subroutine Steffen_SPR(n, x, y, t, z, i, null_deriv_at_0)

!# Steffen M. (1990), A&A 239, 443.
!# Interpolation (or extrapolation) routine. Advantages are
!# that the interpolation is smooth, local (contrary to splines),
!# fast, without oscillations and that extrema happen only at the
!# tabulated values (or outside the interval if is an extrapolation).
!# Given:
!# 1. a function `y(x)`, tabulated for `n` values such as
!#    `x(1) <= ... <= x(n)`; and
!# 2. an integer `i` found by subroutine `bracket`, such as
!#    x(i) <= t <= x(i+1)` (`i = 1` if `t <= x(1)`; `i = n`
!#    if `t >= x(n)`),
!# `Steffen` finds `z = y(t)`.
!# Optional variable `null_deriv_at_0` is usually false. It is true only when
!# one wants to force `dy/dx` to 0 at `x = 0`.


    implicit none
    integer, intent(in) :: n, i
    real(SPR), dimension(:), intent(in) :: x, y
    real(SPR), intent(in) :: t
    real(SPR), intent(out) :: z
    logical, intent(in), optional :: null_deriv_at_0
!#......................................................................
    real(SPR) :: a, b, c, d
    real(SPR) :: h_i, h_im1, h_ip1
    real(SPR) :: s_i, s_im1, s_ip1
    real(SPR) :: p_i, p_ip1, y1_i, y1_ip1
    real(SPR) :: tmx_i
    logical :: null_deriv_at_0_eff
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(null_deriv_at_0)) then
       null_deriv_at_0_eff = null_deriv_at_0
    else
       null_deriv_at_0_eff = .false.
    endif

    if (i == 1) then
       h_i = x(i+1)-x(i)
       s_i = (y(i+1)-y(i))/h_i
       h_ip1 = x(i+2)-x(i+1)
       s_ip1 = (y(i+2)-y(i+1))/h_ip1
       p_ip1 = (s_i*h_ip1+s_ip1*h_i)/(h_i+h_ip1)
       y1_ip1 = (sign(1._SPR, s_i)+sign(1._SPR, s_ip1))*min(abs(s_i), abs(s_ip1), &
            0.5_SPR*abs(p_ip1))
       if (null_deriv_at_0_eff) then !# 1st derivative forced to 0 at `x` = 0.
          y1_i = (6._SPR*s_i*x(1)*(x(1)+h_i)-y1_ip1*x(1)*(3._SPR*x(1)+2._SPR*h_i))/ &
               (3._SPR*x(1)**2+4._SPR*x(1)*h_i+h_i**2)
       else
          y1_i = 1.5_SPR*s_i-0.5_SPR*y1_ip1
       end if
    else
       if (i == n-1) then
          h_i = x(i+1)-x(i)
          s_i = (y(i+1)-y(i))/h_i
          h_im1 = x(i)-x(i-1)
          s_im1 = (y(i)-y(i-1))/h_im1
          p_i = (s_im1*h_i+s_i*h_im1)/(h_im1+h_i)
          y1_i = (sign(1._SPR, s_im1)+sign(1._SPR, s_i))*min(abs(s_im1), abs(s_i), &
               0.5_SPR*abs(p_i))
          y1_ip1 = 1.5_SPR*s_i-0.5_SPR*y1_i
       else
          h_i = x(i+1)-x(i)
          s_i = (y(i+1)-y(i))/h_i
          h_im1 = x(i)-x(i-1)
          s_im1 = (y(i)-y(i-1))/h_im1
          h_ip1 = x(i+2)-x(i+1)
          s_ip1 = (y(i+2)-y(i+1))/h_ip1
          p_i = (s_im1*h_i+s_i*h_im1)/(h_im1+h_i)
          p_ip1 = (s_i*h_ip1+s_ip1*h_i)/(h_i+h_ip1)
          y1_i = (sign(1._SPR, s_im1)+sign(1._SPR, s_i))*min(abs(s_im1), abs(s_i), &
               0.5_SPR*abs(p_i))
          y1_ip1 = (sign(1._SPR, s_i)+sign(1._SPR, s_ip1))*min(abs(s_i), abs(s_ip1), &
               0.5_SPR*abs(p_ip1))
       end if
    end if
    if (t > x(n)) then
       z = y(n)+y1_ip1*(t-x(n))
    else
       tmx_i = t-x(i)
       a = (y1_i+y1_ip1-2._SPR*s_i)/h_i**2
       b = (3._SPR*s_i-2._SPR*y1_i-y1_ip1)/h_i
       c = y1_i
       d = y(i)
       z = ((a*tmx_i+b)*tmx_i+c)*tmx_i+d
    endif

  end subroutine Steffen_SPR

!#======================================================================

  subroutine Steffen3_SPR(x1, x2, x3, y, n1, n2, n3, t1, t2, t3, z, i01, i02, &
       i03)

!# 3-dimensional version of subroutine `Steffen`.
!# Given `y(x1, x2, x3)`, where `x1(1) <= ... <= x1(n1)` (the same for `x2`
!# and `x3`), `Steffen3` computes `z(t1, t2, t3)`.
!# `i01`, etc., are the starting indices used by `bracket`.

    implicit none
    integer, intent(in) :: n1, n2, n3
    real(SPR), dimension(:), intent(in) :: x1
    real(SPR), dimension(:), intent(in) :: x2
    real(SPR), dimension(:), intent(in) :: x3
    real(SPR), dimension(:, :, :), intent(in) :: y
    real(SPR), intent(in) :: t1, t2, t3
    integer, intent(inout) :: i01, i02, i03
    real(SPR), intent(out) :: z
!#......................................................................
    integer :: i1, i2, i3
    real(SPR), dimension(n1) :: y1
    real(SPR), dimension(n2) :: y2
    real(SPR), dimension(n3) :: y3
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    call bracket(n1, x1, t1, i01)
    call bracket(n2, x2, t2, i02)
    call bracket(n3, x3, t3, i03)
!# N.B.: In the following loops, one could cycle from 1 to `n1`
!# (`n2`, `n3`), but since `Steffen` is a local interpolation routine,
!# there is no need to compute all the values of `y1`, `y2`, `y3`.
    do i1 = max(1, i01-1), min(n1, i01+2)
       do i2 = max(1, i02-1), min(n2, i02+2)
          do i3 = max(1, i03-1), min(n3, i03+2)
             y3(i3) = y(i1, i2, i3)
          end do
          call Steffen(n3, x3, y3, t3, y2(i2), i03)
       end do
       call Steffen(n2, x2, y2, t2, y1(i1), i02)
    end do
    call Steffen(n1, x1, y1, t1, z, i01)

  end subroutine Steffen3_SPR

!#======================================================================

  subroutine Steffen4_SPR(x1, x2, x3, x4, y, n1, n2, n3, n4, t1, t2, t3, t4, z, &
       i01, i02, i03, i04, null_deriv_at_0)

!# 4-dimensional version of subroutine `Steffen`.
!# See `Steffen3` for the details.

    implicit none
    integer, intent(in) :: n1, n2, n3, n4
    real(SPR), dimension(:), intent(in) :: x1
    real(SPR), dimension(:), intent(in) :: x2
    real(SPR), dimension(:), intent(in) :: x3
    real(SPR), dimension(:), intent(in) :: x4
    real(SPR), dimension(:, :, :, :), intent(in) :: y
    real(SPR), intent(in) :: t1, t2, t3, t4
    integer, intent(inout) :: i01, i02, i03, i04
    real(SPR), intent(out) :: z
    logical, intent(in), optional :: null_deriv_at_0 !# For the interpolation on `x4` only.
!#......................................................................
    integer :: i1, i2, i3, i4
    real(SPR), dimension(n1) :: y1
    real(SPR), dimension(n2) :: y2
    real(SPR), dimension(n3) :: y3
    real(SPR), dimension(n4) :: y4
    logical :: null_deriv_at_0_eff
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(null_deriv_at_0)) then
       null_deriv_at_0_eff = null_deriv_at_0
    else
       null_deriv_at_0_eff = .false.
    endif

    call bracket(n1, x1, t1, i01)
    call bracket(n2, x2, t2, i02)
    call bracket(n3, x3, t3, i03)
    call bracket(n4, x4, t4, i04)
    do i1 = max(1, i01-1), min(n1, i01+2)
       do i2 = max(1, i02-1), min(n2, i02+2)
          do i3 = max(1, i03-1), min(n3, i03+2)
             do i4 = max(1, i04-1), min(n4, i04+2)
                y4(i4) = y(i1, i2, i3, i4)
             end do
             call Steffen(n4, x4, y4, t4, y3(i3), i04, null_deriv_at_0=null_deriv_at_0_eff)
          end do
          call Steffen(n3, x3, y3, t3, y2(i2), i03)
       end do
       call Steffen(n2, x2, y2, t2, y1(i1), i02)
    end do
    call Steffen(n1, x1, y1, t1, z, i01)

  end subroutine Steffen4_SPR

!#======================================================================

  function interp_lin_lin_SPR(x1, x2, y1, y2, x) result(interp)

    implicit none
    real(SPR), intent(in) :: x1, x2, y1, y2, x
    real(SPR) :: interp
!#......................................................................
    real(kind(x)) :: alpha
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (x1 /= x2) then
       alpha = (x2 - x)/(x2 - x1)
       interp = alpha*y1 + (1-alpha)*y2
    else
       interp = (y1+y2)/2
    endif

  end function interp_lin_lin_SPR

!#======================================================================

  recursive function interp_lin_log_SPR(x1, x2, y1, y2, x) result(interp)

!# Linear interpolation in `log(y)`.

    implicit none
    real(SPR), intent(in) :: x1, x2, y1, y2, x
    real(SPR) :: interp
!#......................................................................
    real(kind(x)) :: alpha
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (y1 <= 0 .or. y2 <= 0) then
       if (y1 < 0 .and. y2 < 0) then
          interp = -interp_lin_log_SPR(x1, x2, -y1, -y2, x)
       else !# `y1` = 0 or `y2` = 0 or {sgn(`y1`) /= sgn(`y2`) and `y1` /= 0 and `y2` /= 0}.
          if (y1 == 0) then
             if ((x1 <= x2 .and. x <= x1) .or. (x1 >= x2 .and. x >= x1)) then !# Extrapolation.
                interp = 0
                return
             endif
          else if (y2 == 0) then
             if ((x1 <= x2 .and. x >= x2) .or. (x1 >= x2 .and. x <= x2)) then !# Extrapolation.
                interp = 0
                return
             endif
          endif
!# {{`y1` = 0 or `y2` = 0} and no extrapolation} or {sgn(`y1`) /= sgn(`y2`) and `y1` /= 0 and `y2` /= 0}.
          interp = interp_lin_lin_SPR(x1, x2, y1, y2, x)
       endif
       return
    endif

    if (x1 /= x2) then
       alpha = (x2 - x)/(x2 - x1)
       interp = exp(alpha*log(y1) + (1-alpha)*log(y2))
    else
       interp = sqrt(real(y1, DPR)*real(y2, DPR)) !# `real(., DPR)` \
!# to avoid over- and underflows.
    endif

  end function interp_lin_log_SPR

!#======================================================================

  recursive function interp_log_lin_SPR(x1, x2, y1, y2, x) result(interp)

    implicit none
    real(SPR), intent(in) :: x1, x2, y1, y2, x
    real(SPR) :: interp
!#......................................................................
    real(kind(x)) :: alpha, ln_x2
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (x1 <= 0 .or. x2 <= 0 .or. x <= 0) then
       if (x1 < 0 .and. x2 < 0 .and. x < 0) then
          interp = interp_log_lin_SPR(-x1, -x2, y1, y2, -x)
       else
          interp = interp_lin_lin_SPR(x1, x2, y1, y2, x)
       endif
       return
    endif

    if (x1 /= x2) then
       ln_x2 = log(x2)
       alpha = (ln_x2 - log(x))/(ln_x2 - log(x1))
       interp = alpha*y1 + (1-alpha)*y2
    else
       interp = (y1+y2)/2
    endif

  end function interp_log_lin_SPR

!#======================================================================

  recursive function interp_log_log_SPR(x1, x2, y1, y2, x) result(interp)

    implicit none
    real(SPR), intent(in) :: x1, x2, y1, y2, x
    real(SPR) :: interp
!#......................................................................
    real(kind(x)) :: alpha, ln_x2
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (y1 <= 0 .or. y2 <= 0) then
       if (y1 < 0 .and. y2 < 0) then
          interp = -interp_log_log_SPR(x1, x2, -y1, -y2, x)
       else !# `y1` = 0 or `y2` = 0 or {sgn(`y1`) /= sgn(`y2`) and `y1` /= 0 and `y2` /= 0}.
          if (y1 == 0) then
             if ((x1 <= x2 .and. x <= x1) .or. (x1 >= x2 .and. x >= x1)) then !# Extrapolation.
                interp = 0
                return
             endif
          else if (y2 == 0) then
             if ((x1 <= x2 .and. x >= x2) .or. (x1 >= x2 .and. x <= x2)) then !# Extrapolation.
                interp = 0
                return
             endif
          endif
!# {{`y1` = 0 or `y2` = 0} and no extrapolation} or {sgn(`y1`) /= sgn(`y2`) and `y1` /= 0 and `y2` /= 0}.
          interp = interp_log_lin_SPR(x1, x2, y1, y2, x)
       endif
       return
    endif

    if (x1 <= 0 .or. x2 <= 0 .or. x <= 0) then
       if (x1 < 0 .and. x2 < 0 .and. x < 0) then
          interp = interp_log_log_SPR(-x1, -x2, y1, y2, -x)
       else
          interp = interp_lin_log_SPR(x1, x2, y1, y2, x)
       endif
       return
    endif

    if (x1 /= x2) then
       ln_x2 = log(x2)
       alpha = (ln_x2 - log(x))/(ln_x2 - log(x1))
       interp = exp(alpha*log(y1) + (1-alpha)*log(y2))
    else
       interp = sqrt(real(y1, DPR)*real(y2, DPR)) !# `real(., DPR)` \
!# to avoid over- and underflows.
    endif

  end function interp_log_log_SPR

!#======================================================================

  subroutine bracket_DPR(n, x, t, i, extrap)

!# Given an array `x(1) <= ... <= x(n)`, `bracket` finds the integer `i`
!# such that `x(i) <= t <= x(i+1)`.
!# If `t <= x(1)`, `i = 1`; if `t >= x(n)`, `i = n-1`.
!# If `i = 0` in input, `bracket` finds `i` by dichotomy between 1 and
!# `n`; otherwise, the input `i` is used as an initial guess.

    implicit none
    integer, intent(in) :: n
    real(DPR), dimension(:), intent(in) :: x
    real(kind(x)), intent(in) :: t
    integer, intent(inout) :: i
    character(len=max(len("down"), len("up"), len("none"))), intent(out), optional :: extrap
!#......................................................................
    integer :: i_inf, i_sup, i_med, d_i
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (t < x(1)) then !# Downward extrapolation.
       i_inf = 1
       if (present(extrap)) extrap = "down"
    else if (t > x(n)) then !# Upward extrapolation.
       if (present(extrap)) extrap = "up"
       i_inf = n-1
    else !# Interpolation.
       if (present(extrap)) extrap = "none"
       i_inf = 1
       i_sup = n
       if (i >= 1 .and. i <= n) then !# Valid initial guess provided; \
!#                                      search first in the vicinity of `x(i)`.
          d_i = 1
          if (t >= x(i)) then
             i_inf = i
             i_sup = min(n, i+d_i)
             do while(t > x(i_sup))
                i_inf = i_sup
                d_i = 2*d_i
                i_sup = min(n, i+d_i)
             enddo
          else
             i_sup = i
             i_inf = max(1, i-d_i)
             do while(t < x(i_inf))
                i_sup = i_inf
                d_i = 2*d_i
                i_inf = max(1, i-d_i)
             enddo
          endif
       endif
!# Search by dichotomy:
       do while (i_inf+1 < i_sup)
          i_med = (i_inf+i_sup)/2
          if (t <= x(i_med)) then
             i_sup = i_med
          else
             i_inf = i_med
          end if
       end do
    endif

    i = i_inf

  end subroutine bracket_DPR

!#======================================================================

  subroutine Steffen_DPR(n, x, y, t, z, i, null_deriv_at_0)

!# Steffen M. (1990), A&A 443, 450.
!# Interpolation (or extrapolation) routine. Advantages are
!# that the interpolation is smooth, local (contrary to splines),
!# fast, without oscillations and that extrema happen only at the
!# tabulated values (or outside the interval if is an extrapolation).
!# Given:
!# 1. a function `y(x)`, tabulated for `n` values such as
!#    `x(1) <= ... <= x(n)`; and
!# 2. an integer `i` found by subroutine `bracket`, such as
!#    x(i) <= t <= x(i+1)` (`i = 1` if `t <= x(1)`; `i = n`
!#    if `t >= x(n)`),
!# `Steffen` finds `z = y(t)`.
!# Optional variable `null_deriv_at_0` is usually false. It is true only when
!# one wants to force `dy/dx` to 0 at `x = 0`.

    implicit none
    integer, intent(in) :: n, i
    real(DPR), dimension(:), intent(in) :: x, y
    real(DPR), intent(in) :: t
    real(DPR), intent(out) :: z
    logical, intent(in), optional :: null_deriv_at_0
!#......................................................................
    real(DPR) :: a, b, c, d
    real(DPR) :: h_i, h_im1, h_ip1
    real(DPR) :: s_i, s_im1, s_ip1
    real(DPR) :: p_i, p_ip1, y1_i, y1_ip1
    real(DPR) :: tmx_i
    logical :: null_deriv_at_0_eff
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(null_deriv_at_0)) then
       null_deriv_at_0_eff = null_deriv_at_0
    else
       null_deriv_at_0_eff = .false.
    endif

    if (i == 1) then
       h_i = x(i+1)-x(i)
       s_i = (y(i+1)-y(i))/h_i
       h_ip1 = x(i+2)-x(i+1)
       s_ip1 = (y(i+2)-y(i+1))/h_ip1
       p_ip1 = (s_i*h_ip1+s_ip1*h_i)/(h_i+h_ip1)
       y1_ip1 = (sign(1._DPR, s_i)+sign(1._DPR, s_ip1))*min(abs(s_i), abs(s_ip1), &
            0.5_DPR*abs(p_ip1))
       if (null_deriv_at_0_eff) then !# 1st derivative forced to 0 at `x` = 0.
          y1_i = (6._DPR*s_i*x(1)*(x(1)+h_i)-y1_ip1*x(1)*(3._DPR*x(1)+2._DPR*h_i))/ &
               (3._DPR*x(1)**2+4._DPR*x(1)*h_i+h_i**2)
       else
          y1_i = 1.5_DPR*s_i-0.5_DPR*y1_ip1
       end if
    else
       if (i == n-1) then
          h_i = x(i+1)-x(i)
          s_i = (y(i+1)-y(i))/h_i
          h_im1 = x(i)-x(i-1)
          s_im1 = (y(i)-y(i-1))/h_im1
          p_i = (s_im1*h_i+s_i*h_im1)/(h_im1+h_i)
          y1_i = (sign(1._DPR, s_im1)+sign(1._DPR, s_i))*min(abs(s_im1), &
               abs(s_i), 0.5_DPR*abs(p_i))
          y1_ip1 = 1.5_DPR*s_i-0.5_DPR*y1_i
       else
          h_i = x(i+1)-x(i)
          s_i = (y(i+1)-y(i))/h_i
          h_im1 = x(i)-x(i-1)
          s_im1 = (y(i)-y(i-1))/h_im1
          h_ip1 = x(i+2)-x(i+1)
          s_ip1 = (y(i+2)-y(i+1))/h_ip1
          p_i = (s_im1*h_i+s_i*h_im1)/(h_im1+h_i)
          p_ip1 = (s_i*h_ip1+s_ip1*h_i)/(h_i+h_ip1)
          y1_i = (sign(1._DPR, s_im1)+sign(1._DPR, s_i))*min(abs(s_im1), &
               abs(s_i), 0.5_DPR*abs(p_i))
          y1_ip1 = (sign(1._DPR, s_i)+sign(1._DPR, s_ip1))*min(abs(s_i), &
               abs(s_ip1), 0.5_DPR*abs(p_ip1))
       end if
    end if
    if (t > x(n)) then
       z = y(n)+y1_ip1*(t-x(n))
    else
       tmx_i = t-x(i)
       a = (y1_i+y1_ip1-2._DPR*s_i)/h_i**2
       b = (3._DPR*s_i-2._DPR*y1_i-y1_ip1)/h_i
       c = y1_i
       d = y(i)
       z = ((a*tmx_i+b)*tmx_i+c)*tmx_i+d
    endif

  end subroutine Steffen_DPR

!#======================================================================

  subroutine Steffen3_DPR(x1, x2, x3, y, n1, n2, n3, t1, t2, t3, z, i01, i02, &
       i03)

!# 3-dimensional version of subroutine `Steffen`.
!# Given `y(x1, x2, x3)`, where `x1(1) <= ... <= x1(n1)` (the same for `x2`
!# and `x3`), `Steffen3` computes `z(t1, t2, t3)`.
!# `i01`, etc., are the starting indices used by `bracket`.

    implicit none
    integer, intent(in) :: n1, n2, n3
    real(DPR), dimension(:), intent(in) :: x1
    real(DPR), dimension(:), intent(in) :: x2
    real(DPR), dimension(:), intent(in) :: x3
    real(DPR), dimension(:, :, :), intent(in) :: y
    real(DPR), intent(in) :: t1, t2, t3
    integer, intent(inout) :: i01, i02, i03
    real(DPR), intent(out) :: z
!#......................................................................
    integer :: i1, i2, i3
    real(DPR), dimension(n1) :: y1
    real(DPR), dimension(n2) :: y2
    real(DPR), dimension(n3) :: y3
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    call bracket(n1, x1, t1, i01)
    call bracket(n2, x2, t2, i02)
    call bracket(n3, x3, t3, i03)
!# N.B.: In the following loops, one could cycle from 1 to `n1`
!# (`n2`, `n3`), but since `Steffen` is a local interpolation routine,
!# there is no need to compute all the values of `y1`, `y2`, `y3`.
    do i1 = max(1, i01-1), min(n1, i01+2)
       do i2 = max(1, i02-1), min(n2, i02+2)
          do i3 = max(1, i03-1), min(n3, i03+2)
             y3(i3) = y(i1, i2, i3)
          end do
          call Steffen(n3, x3, y3, t3, y2(i2), i03)
       end do
       call Steffen(n2, x2, y2, t2, y1(i1), i02)
    end do
    call Steffen(n1, x1, y1, t1, z, i01)

  end subroutine Steffen3_DPR

!#======================================================================

  subroutine Steffen4_DPR(x1, x2, x3, x4, y, n1, n2, n3, n4, t1, t2, t3, t4, &
       z, i01, i02, i03, i04, null_deriv_at_0)

!# 4-dimensional version of subroutine `Steffen`.
!# See `Steffen3` for the details.

    implicit none
    integer, intent(in) :: n1, n2, n3, n4
    real(DPR), dimension(:), intent(in) :: x1
    real(DPR), dimension(:), intent(in) :: x2
    real(DPR), dimension(:), intent(in) :: x3
    real(DPR), dimension(:), intent(in) :: x4
    real(DPR), dimension(:, :, :, :), intent(in) :: y
    real(DPR), intent(in) :: t1, t2, t3, t4
    integer, intent(inout) :: i01, i02, i03, i04
    real(DPR), intent(out) :: z
    logical, intent(in), optional :: null_deriv_at_0 !# For the interpolation on `x4` only.
!#......................................................................
    integer :: i1, i2, i3, i4
    real(DPR), dimension(n1) :: y1
    real(DPR), dimension(n2) :: y2
    real(DPR), dimension(n3) :: y3
    real(DPR), dimension(n4) :: y4
    logical :: null_deriv_at_0_eff
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(null_deriv_at_0)) then
       null_deriv_at_0_eff = null_deriv_at_0
    else
       null_deriv_at_0_eff = .false.
    endif

    call bracket(n1, x1, t1, i01)
    call bracket(n2, x2, t2, i02)
    call bracket(n3, x3, t3, i03)
    call bracket(n4, x4, t4, i04)
    do i1 = max(1, i01-1), min(n1, i01+2)
       do i2 = max(1, i02-1), min(n2, i02+2)
          do i3 = max(1, i03-1), min(n3, i03+2)
             do i4 = max(1, i04-1), min(n4, i04+2)
                y4(i4) = y(i1, i2, i3, i4)
             end do
             call Steffen(n4, x4, y4, t4, y3(i3), i04, null_deriv_at_0=null_deriv_at_0_eff)
          end do
          call Steffen(n3, x3, y3, t3, y2(i2), i03)
       end do
       call Steffen(n2, x2, y2, t2, y1(i1), i02)
    end do
    call Steffen(n1, x1, y1, t1, z, i01)

  end subroutine Steffen4_DPR

!#======================================================================

  function interp_lin_lin_DPR(x1, x2, y1, y2, x) result(interp)

    implicit none
    real(DPR), intent(in) :: x1, x2, y1, y2, x
    real(DPR) :: interp
!#......................................................................
    real(kind(x)) :: alpha
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (x1 /= x2) then
       alpha = (x2 - x)/(x2 - x1)
       interp = alpha*y1 + (1-alpha)*y2
    else
       interp = (y1+y2)/2
    endif

  end function interp_lin_lin_DPR

!#======================================================================

  recursive function interp_lin_log_DPR(x1, x2, y1, y2, x) result(interp)

!# Linear interpolation in `log(y)`.

    implicit none
    real(DPR), intent(in) :: x1, x2, y1, y2, x
    real(DPR) :: interp
!#......................................................................
    real(kind(x)) :: alpha
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (y1 <= 0 .or. y2 <= 0) then
       if (y1 < 0 .and. y2 < 0) then
          interp = -interp_lin_log_DPR(x1, x2, -y1, -y2, x)
       else !# `y1` = 0 or `y2` = 0 or {sgn(`y1`) /= sgn(`y2`) and `y1` /= 0 and `y2` /= 0}.
          if (y1 == 0) then
             if ((x1 <= x2 .and. x <= x1) .or. (x1 >= x2 .and. x >= x1)) then !# Extrapolation.
                interp = 0
                return
             endif
          else if (y2 == 0) then
             if ((x1 <= x2 .and. x >= x2) .or. (x1 >= x2 .and. x <= x2)) then !# Extrapolation.
                interp = 0
                return
             endif
          endif
!# {{`y1` = 0 or `y2` = 0} and no extrapolation} or {sgn(`y1`) /= sgn(`y2`) and `y1` /= 0 and `y2` /= 0}.
          interp = interp_lin_lin_DPR(x1, x2, y1, y2, x)
       endif
       return
    endif

    if (x1 /= x2) then
       alpha = (x2 - x)/(x2 - x1)
       interp = exp(alpha*log(y1) + (1-alpha)*log(y2))
    else
       interp = sqrt(y1*y2)
    endif

  end function interp_lin_log_DPR

!#======================================================================

  recursive function interp_log_lin_DPR(x1, x2, y1, y2, x) result(interp)

    implicit none
    real(DPR), intent(in) :: x1, x2, y1, y2, x
    real(DPR) :: interp
!#......................................................................
    real(kind(x)) :: alpha, ln_x2
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (x1 <= 0 .or. x2 <= 0 .or. x <= 0) then
       if (x1 < 0 .and. x2 < 0 .and. x < 0) then
          interp = interp_log_lin_DPR(-x1, -x2, y1, y2, -x)
       else
          interp = interp_lin_lin_DPR(x1, x2, y1, y2, x)
       endif
       return
    endif

    if (x1 /= x2) then
       ln_x2 = log(x2)
       alpha = (ln_x2 - log(x))/(ln_x2 - log(x1))
       interp = alpha*y1 + (1-alpha)*y2
    else
       interp = (y1+y2)/2
    endif

  end function interp_log_lin_DPR

!#======================================================================

  recursive function interp_log_log_DPR(x1, x2, y1, y2, x) result(interp)

    implicit none
    real(DPR), intent(in) :: x1, x2, y1, y2, x
    real(DPR) :: interp
!#......................................................................
    real(kind(x)) :: alpha, ln_x2
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (y1 <= 0 .or. y2 <= 0) then
       if (y1 < 0 .and. y2 < 0) then
          interp = -interp_log_log_DPR(x1, x2, -y1, -y2, x)
       else !# `y1` = 0 or `y2` = 0 or {sgn(`y1`) /= sgn(`y2`) and `y1` /= 0 and `y2` /= 0}.
          if (y1 == 0) then
             if ((x1 <= x2 .and. x <= x1) .or. (x1 >= x2 .and. x >= x1)) then !# Extrapolation.
                interp = 0
                return
             endif
          else if (y2 == 0) then
             if ((x1 <= x2 .and. x >= x2) .or. (x1 >= x2 .and. x <= x2)) then !# Extrapolation.
                interp = 0
                return
             endif
          endif
!# {{`y1` = 0 or `y2` = 0} and no extrapolation} or {sgn(`y1`) /= sgn(`y2`) and `y1` /= 0 and `y2` /= 0}.
          interp = interp_log_lin_DPR(x1, x2, y1, y2, x)
       endif
       return
    endif

    if (x1 <= 0 .or. x2 <= 0 .or. x <= 0) then
       if (x1 < 0 .and. x2 < 0 .and. x < 0) then
          interp = interp_log_log_DPR(-x1, -x2, y1, y2, -x)
       else
          interp = interp_lin_log_DPR(x1, x2, y1, y2, x)
       endif
       return
    endif

    if (x1 /= x2) then
       ln_x2 = log(x2)
       alpha = (ln_x2 - log(x))/(ln_x2 - log(x1))
       interp = exp(alpha*log(y1) + (1-alpha)*log(y2))
    else
       interp = sqrt(y1*y2)
    endif

  end function interp_log_log_DPR

!#======================================================================

  subroutine compute_weights_SPR(x_arr, x, weight, interp_proc)

    implicit none
    real(SPR), dimension(:), intent(in) :: x_arr
    real(SPR), intent(in) :: x
    real(SPR), dimension(:), intent(out) :: weight
    character(len=*), optional :: interp_proc
!#......................................................................
    integer :: i, n
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    n = size(x_arr)
    if (n > 1) then
       weight(:) = 0
       if (x_arr(1) <= x_arr(n)) then
          if (x <= x_arr(1)) then
             weight(1) = 1
             return
          else if (x >= x_arr(n)) then
             weight(n) = 1
             return
          else
             i = 0
             call bracket_SPR(n, x_arr, x, i)
          endif
       else
          if (x >= x_arr(1)) then
             weight(1) = 1
             return
          else if (x <= x_arr(n)) then
             weight(n) = 1
             return
          else
             i = 0
             call bracket_SPR(n, -x_arr, -x, i)
          endif
       endif
       if (present(interp_proc)) then
          if (interp_proc == "interp_log_lin") then
             weight(i) =  interp_log_lin(x_arr(i), x_arr(i+1), 1._SPR, 0._SPR, x)
          else if (interp_proc == "interp_lin_log") then
             weight(i) =  interp_lin_log(x_arr(i), x_arr(i+1), 1._SPR, 0._SPR, x)
          else if (interp_proc == "interp_log_log") then
             weight(i) =  interp_log_log(x_arr(i), x_arr(i+1), 1._SPR, 0._SPR, x)
          else if (interp_proc == "interp_lin_lin") then
             weight(i) =  interp_lin_lin(x_arr(i), x_arr(i+1), 1._SPR, 0._SPR, x)
          else
             write(*,"(a)") "In procedure `compute_weights_SPR` of file &
                  &""utilities_dir/mod_interp.f90"", the value of &
                  &`interp_proc` cannot be """ // trim(interp_proc) // """."
          endif
       else
          weight(i) =  interp_lin_lin(x_arr(i), x_arr(i+1), 1._SPR, 0._SPR, x)
       endif
       weight(i+1) = 1-weight(i)
    else
       weight(1) = 1
    endif

  end subroutine compute_weights_SPR

!#======================================================================

  subroutine compute_weights_DPR(x_arr, x, weight, interp_proc)

    implicit none
    real(DPR), dimension(:), intent(in) :: x_arr
    real(DPR), intent(in) :: x
    real(DPR), dimension(:), intent(out) :: weight
    character(len=*), optional :: interp_proc
!#......................................................................
    integer :: i, n
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    n = size(x_arr)
    if (n > 1) then
       weight(:) = 0
       if (x_arr(1) <= x_arr(n)) then
          if (x <= x_arr(1)) then
             weight(1) = 1
             return
          else if (x >= x_arr(n)) then
             weight(n) = 1
             return
          else
             i = 0
             call bracket_DPR(n, x_arr, x, i)
          endif
       else
          if (x >= x_arr(1)) then
             weight(1) = 1
             return
          else if (x <= x_arr(n)) then
             weight(n) = 1
             return
          else
             i = 0
             call bracket_DPR(n, -x_arr, -x, i)
          endif
       endif
       if (present(interp_proc)) then
          if (interp_proc == "interp_log_lin") then
             weight(i) =  interp_log_lin(x_arr(i), x_arr(i+1), 1._DPR, 0._DPR, x)
          else if (interp_proc == "interp_lin_log") then
             weight(i) =  interp_lin_log(x_arr(i), x_arr(i+1), 1._DPR, 0._DPR, x)
          else if (interp_proc == "interp_log_log") then
             weight(i) =  interp_log_log(x_arr(i), x_arr(i+1), 1._DPR, 0._DPR, x)
          else if (interp_proc == "interp_lin_lin") then
             weight(i) =  interp_lin_lin(x_arr(i), x_arr(i+1), 1._DPR, 0._DPR, x)
          else
             write(*,"(a)") "In procedure `compute_weights_DPR` of file &
                  &""utilities_dir/mod_interp.f90"", the value of &
                  &`interp_proc` cannot be """ // trim(interp_proc) // """."
          endif
       else
          weight(i) =  interp_lin_lin(x_arr(i), x_arr(i+1), 1._DPR, 0._DPR, x)
       endif
       weight(i+1) = 1-weight(i)
    else
       weight(1) = 1
    endif

  end subroutine compute_weights_DPR

end module mod_interp
