! finterp: Modern Fortran Multidimensional Linear Interpolation
! https://github.com/jacobwilliams/finterp

! Copyright (c) 2016-2019, Jacob Williams
! All rights reserved.

! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:

! * Redistributions of source code must retain the above copyright notice, this
!   list of conditions and the following disclaimer.

! * Redistributions in binary form must reproduce the above copyright notice, this
!   list of conditions and the following disclaimer in the documentation and/or
!   other materials provided with the distribution.

! * The names of its contributors may not be used to endorse or promote products
!   derived from this software without specific prior written permission.

! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

!*****************************************************************************************
!< author: Jacob Williams
!  license: BSD
!
!  Multidimensional linear interpolation/extrapolation.
!
!  Uses repeated linear interpolation to evaluate
!  functions \(f(x), f(x,y), f(x,y,z), f(x,y,z,q), f(x,y,z,q,r), f(x,y,z,q,r,s) \)
!  which have been tabulated at the nodes of an n-dimensional rectangular grid.
!  If any coordinate \( (x_i, y_i, ...) \) lies outside the range of the corresponding
!  variable, then extrapolation is performed using the two nearest points.

module linear_interpolation_module

  use iso_fortran_env, only: wp => real64   ! working precision

  implicit none

  private

  real(wp), parameter, private :: zero = 0.0_wp  !< numeric constant
  real(wp), parameter, private :: one = 1.0_wp  !< numeric constant

  type, public, abstract :: linear_interp_class
    !< Base class for the linear interpolation types
    private
    logical :: initialized = .false. !< if the class was properly initialized
  contains
    private
    procedure(destroy_func), deferred, public :: destroy  !< destructor
    procedure :: check_inputs
  endtype linear_interp_class

  abstract interface
    pure elemental subroutine destroy_func(me)  !< interface for bspline destructor routines
      import :: linear_interp_class
      implicit none
      class(linear_interp_class), intent(inout) :: me
    endsubroutine destroy_func
  endinterface

  type, extends(linear_interp_class), public :: linear_interp_1d
    !< Class for 1d linear interpolation.
    private
    real(wp), dimension(:), allocatable :: f
    real(wp), dimension(:), allocatable :: x
    integer :: ilox = 1
  contains
    private
    procedure, public :: initialize => initialize_1d
    procedure, public :: evaluate => interp_1d
    procedure, public :: destroy => destroy_1d
    final :: finalize_1d
  endtype linear_interp_1d

  type, extends(linear_interp_class), public :: linear_interp_2d
    !< Class for 2d linear interpolation.
    private
    real(wp), dimension(:, :), allocatable :: f
    real(wp), dimension(:), allocatable :: x
    real(wp), dimension(:), allocatable :: y
    integer :: ilox = 1
    integer :: iloy = 1
  contains
    private
    procedure, public :: initialize => initialize_2d
    procedure, public :: evaluate => interp_2d
    procedure, public :: destroy => destroy_2d
    final :: finalize_2d
  endtype linear_interp_2d

  type, extends(linear_interp_class), public :: linear_interp_3d
    !< Class for 3d linear interpolation.
    private
    real(wp), dimension(:, :, :), allocatable :: f
    real(wp), dimension(:), allocatable :: x
    real(wp), dimension(:), allocatable :: y
    real(wp), dimension(:), allocatable :: z
    integer :: ilox = 1
    integer :: iloy = 1
    integer :: iloz = 1
  contains
    private
    procedure, public :: initialize => initialize_3d
    procedure, public :: evaluate => interp_3d
    procedure, public :: destroy => destroy_3d
    final :: finalize_3d
  endtype linear_interp_3d

  type, extends(linear_interp_class), public :: linear_interp_4d
    !< Class for 4d linear interpolation.
    private
    real(wp), dimension(:, :, :, :), allocatable :: f
    real(wp), dimension(:), allocatable :: x
    real(wp), dimension(:), allocatable :: y
    real(wp), dimension(:), allocatable :: z
    real(wp), dimension(:), allocatable :: q
    integer :: ilox = 1
    integer :: iloy = 1
    integer :: iloz = 1
    integer :: iloq = 1
  contains
    private
    procedure, public :: initialize => initialize_4d
    procedure, public :: evaluate => interp_4d
    procedure, public :: destroy => destroy_4d
    final :: finalize_4d
  endtype linear_interp_4d

  type, extends(linear_interp_class), public :: linear_interp_5d
    !< Class for 5d linear interpolation.
    private
    real(wp), dimension(:, :, :, :, :), allocatable :: f
    real(wp), dimension(:), allocatable :: x
    real(wp), dimension(:), allocatable :: y
    real(wp), dimension(:), allocatable :: z
    real(wp), dimension(:), allocatable :: q
    real(wp), dimension(:), allocatable :: r
    integer :: ilox = 1
    integer :: iloy = 1
    integer :: iloz = 1
    integer :: iloq = 1
    integer :: ilor = 1
  contains
    private
    procedure, public :: initialize => initialize_5d
    procedure, public :: evaluate => interp_5d
    procedure, public :: destroy => destroy_5d
    final :: finalize_5d
  endtype linear_interp_5d

  type, extends(linear_interp_class), public :: linear_interp_6d
    !< Class for 6d linear interpolation.
    private
    real(wp), dimension(:, :, :, :, :, :), allocatable :: f
    real(wp), dimension(:), allocatable :: x
    real(wp), dimension(:), allocatable :: y
    real(wp), dimension(:), allocatable :: z
    real(wp), dimension(:), allocatable :: q
    real(wp), dimension(:), allocatable :: r
    real(wp), dimension(:), allocatable :: s
    integer :: ilox = 1
    integer :: iloy = 1
    integer :: iloz = 1
    integer :: iloq = 1
    integer :: ilor = 1
    integer :: ilos = 1
  contains
    private
    procedure, public :: initialize => initialize_6d
    procedure, public :: evaluate => interp_6d
    procedure, public :: destroy => destroy_6d
    final :: finalize_6d
  endtype linear_interp_6d

  type, extends(linear_interp_1d), public :: nearest_interp_1d
    !< Class for 1d nearest neighbor interpolation.
  contains
    procedure, public :: evaluate => nearest_1d
  endtype nearest_interp_1d

  type, extends(linear_interp_2d), public :: nearest_interp_2d
    !< Class for 2d nearest neighbor interpolation.
  contains
    procedure, public :: evaluate => nearest_2d
  endtype nearest_interp_2d

  type, extends(linear_interp_3d), public :: nearest_interp_3d
    !< Class for 3d nearest neighbor interpolation.
  contains
    procedure, public :: evaluate => nearest_3d
  endtype nearest_interp_3d

  type, extends(linear_interp_4d), public :: nearest_interp_4d
    !< Class for 4d nearest neighbor interpolation.
  contains
    procedure, public :: evaluate => nearest_4d
  endtype nearest_interp_4d

  type, extends(linear_interp_5d), public :: nearest_interp_5d
    !< Class for 5d nearest neighbor interpolation.
  contains
    procedure, public :: evaluate => nearest_5d
  endtype nearest_interp_5d

  type, extends(linear_interp_6d), public :: nearest_interp_6d
    !< Class for 6d nearest neighbor interpolation.
  contains
    procedure, public :: evaluate => nearest_6d
  endtype nearest_interp_6d

contains
!*****************************************************************************************

!*****************************************************************************************
!<
!  Finalizer for a [[linear_interp_1d]] type.

  pure elemental subroutine finalize_1d(me)

    implicit none

    type(linear_interp_1d), intent(inout) :: me
    call me%destroy()

  endsubroutine finalize_1d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Finalizer for a [[linear_interp_2d]] type.

  pure elemental subroutine finalize_2d(me)

    implicit none

    type(linear_interp_2d), intent(inout) :: me
    call me%destroy()

  endsubroutine finalize_2d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Finalizer for a [[linear_interp_3d]] type.

  pure elemental subroutine finalize_3d(me)

    implicit none

    type(linear_interp_3d), intent(inout) :: me
    call me%destroy()

  endsubroutine finalize_3d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Finalizer for a [[linear_interp_4d]] type.

  pure elemental subroutine finalize_4d(me)

    implicit none

    type(linear_interp_4d), intent(inout) :: me
    call me%destroy()

  endsubroutine finalize_4d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Finalizer for a [[linear_interp_5d]] type.

  pure elemental subroutine finalize_5d(me)

    implicit none

    type(linear_interp_5d), intent(inout) :: me
    call me%destroy()

  endsubroutine finalize_5d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Finalizer for a [[linear_interp_6d]] type.

  pure elemental subroutine finalize_6d(me)

    implicit none

    type(linear_interp_6d), intent(inout) :: me
    call me%destroy()

  endsubroutine finalize_6d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Destructor for a [[linear_interp_1d]] class.

  pure elemental subroutine destroy_1d(me)

    implicit none

    class(linear_interp_1d), intent(inout) :: me

    if(allocated(me%f)) deallocate(me%f)
    if(allocated(me%x)) deallocate(me%x)
    me%ilox = 1
    me%initialized = .false.

  endsubroutine destroy_1d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Destructor for a [[linear_interp_2d]] class.

  pure elemental subroutine destroy_2d(me)

    implicit none

    class(linear_interp_2d), intent(inout) :: me

    if(allocated(me%f)) deallocate(me%f)
    if(allocated(me%x)) deallocate(me%x)
    if(allocated(me%y)) deallocate(me%y)
    me%ilox = 1
    me%iloy = 1
    me%initialized = .false.

  endsubroutine destroy_2d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Destructor for a [[linear_interp_3d]] class.

  pure elemental subroutine destroy_3d(me)

    implicit none

    class(linear_interp_3d), intent(inout) :: me

    if(allocated(me%f)) deallocate(me%f)
    if(allocated(me%x)) deallocate(me%x)
    if(allocated(me%y)) deallocate(me%y)
    if(allocated(me%z)) deallocate(me%z)
    me%ilox = 1
    me%iloy = 1
    me%iloz = 1
    me%initialized = .false.

  endsubroutine destroy_3d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Destructor for a [[linear_interp_4d]] class.

  pure elemental subroutine destroy_4d(me)

    implicit none

    class(linear_interp_4d), intent(inout) :: me

    if(allocated(me%f)) deallocate(me%f)
    if(allocated(me%x)) deallocate(me%x)
    if(allocated(me%y)) deallocate(me%y)
    if(allocated(me%z)) deallocate(me%z)
    if(allocated(me%q)) deallocate(me%q)
    me%ilox = 1
    me%iloy = 1
    me%iloz = 1
    me%iloq = 1
    me%initialized = .false.

  endsubroutine destroy_4d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Destructor for a [[linear_interp_5d]] class.

  pure elemental subroutine destroy_5d(me)

    implicit none

    class(linear_interp_5d), intent(inout) :: me

    if(allocated(me%f)) deallocate(me%f)
    if(allocated(me%x)) deallocate(me%x)
    if(allocated(me%y)) deallocate(me%y)
    if(allocated(me%z)) deallocate(me%z)
    if(allocated(me%q)) deallocate(me%q)
    if(allocated(me%r)) deallocate(me%r)
    me%ilox = 1
    me%iloy = 1
    me%iloz = 1
    me%iloq = 1
    me%ilor = 1
    me%initialized = .false.

  endsubroutine destroy_5d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Destructor for a [[linear_interp_6d]] class.

  pure elemental subroutine destroy_6d(me)

    implicit none

    class(linear_interp_6d), intent(inout) :: me

    if(allocated(me%f)) deallocate(me%f)
    if(allocated(me%x)) deallocate(me%x)
    if(allocated(me%y)) deallocate(me%y)
    if(allocated(me%z)) deallocate(me%z)
    if(allocated(me%q)) deallocate(me%q)
    if(allocated(me%r)) deallocate(me%r)
    if(allocated(me%s)) deallocate(me%s)
    me%ilox = 1
    me%iloy = 1
    me%iloz = 1
    me%iloq = 1
    me%ilor = 1
    me%ilos = 1
    me%initialized = .false.

  endsubroutine destroy_6d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Constructor for a [[linear_interp_1d]] class.

  pure subroutine initialize_1d(me, x, f, istat)

    implicit none

    class(linear_interp_1d), intent(inout) :: me
    real(wp), dimension(:), intent(in)      :: x
    real(wp), dimension(:), intent(in)      :: f
    integer, intent(out)                   :: istat  !< `0`   : no problems,
!< `1`   : `x` is not strictly increasing,
!< `10`  : `x` is not equal to size(f,1),
!< `100` : cannot use linear interpolation for only one point.

    call me%destroy()

    istat = 0

    if(istat == 0 .and. size(x) /= size(f, 1)) istat = 10

    if(istat == 0) then
      call me%check_inputs(x=x, ierr=istat)
      if(istat == 0) then
        allocate(me%f(size(x))); me%f = f
        allocate(me%x(size(x))); me%x = x
        me%initialized = .true.
      endif
    endif

  endsubroutine initialize_1d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Constructor for a [[linear_interp_2d]] class.

  pure subroutine initialize_2d(me, x, y, f, istat)

    implicit none

    class(linear_interp_2d), intent(inout) :: me
    real(wp), dimension(:), intent(in)      :: x
    real(wp), dimension(:), intent(in)      :: y
    real(wp), dimension(:, :), intent(in)    :: f
    integer, intent(out)                   :: istat  !< `0`   : no problems,
!< `1`   : `x` is not strictly increasing,
!< `2`   : `y` is not strictly increasing,
!< `10`  : `x` is not equal to size(f,1),
!< `20`  : `y` is not equal to size(f,2),
!< `100` : cannot use linear interpolation for only one point.

    call me%destroy()

    istat = 0

    if(istat == 0 .and. size(x) /= size(f, 1)) istat = 10
    if(istat == 0 .and. size(y) /= size(f, 2)) istat = 20

    if(istat == 0) then
      call me%check_inputs(x=x, y=y, ierr=istat)
      if(istat == 0) then
        allocate(me%f(size(x), size(y))); me%f = f
        allocate(me%x(size(x))); me%x = x
        allocate(me%y(size(y))); me%y = y
        me%initialized = .true.
      endif
    endif

  endsubroutine initialize_2d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Constructor for a [[linear_interp_3d]] class.

  pure subroutine initialize_3d(me, x, y, z, f, istat)

    implicit none

    class(linear_interp_3d), intent(inout) :: me
    real(wp), dimension(:), intent(in)      :: x
    real(wp), dimension(:), intent(in)      :: y
    real(wp), dimension(:), intent(in)      :: z
    real(wp), dimension(:, :, :), intent(in)  :: f
    integer, intent(out)                   :: istat  !< `0`   : no problems,
!< `1`   : `x` is not strictly increasing,
!< `2`   : `y` is not strictly increasing,
!< `3`   : `z` is not strictly increasing,
!< `10`  : `x` is not equal to size(f,1),
!< `20`  : `y` is not equal to size(f,2),
!< `30`  : `z` is not equal to size(f,3),
!< `100` : cannot use linear interpolation for only one point.

    call me%destroy()

    istat = 0

    if(istat == 0 .and. size(x) /= size(f, 1)) istat = 10
    if(istat == 0 .and. size(y) /= size(f, 2)) istat = 20
    if(istat == 0 .and. size(z) /= size(f, 3)) istat = 30

    if(istat == 0) then
      call me%check_inputs(x=x, y=y, z=z, ierr=istat)
      if(istat == 0) then
        allocate(me%f(size(x), size(y), size(z))); me%f = f
        allocate(me%x(size(x))); me%x = x
        allocate(me%y(size(y))); me%y = y
        allocate(me%z(size(z))); me%z = z
        me%initialized = .true.
      endif
    endif

  endsubroutine initialize_3d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Constructor for a [[linear_interp_4d]] class.

  pure subroutine initialize_4d(me, x, y, z, q, f, istat)

    implicit none

    class(linear_interp_4d), intent(inout)  :: me
    real(wp), dimension(:), intent(in)       :: x
    real(wp), dimension(:), intent(in)       :: y
    real(wp), dimension(:), intent(in)       :: z
    real(wp), dimension(:), intent(in)       :: q
    real(wp), dimension(:, :, :, :), intent(in) :: f
    integer, intent(out)                    :: istat !< `0`   : no problems,
!< `1`   : `x` is not strictly increasing,
!< `2`   : `y` is not strictly increasing,
!< `3`   : `z` is not strictly increasing,
!< `4`   : `q` is not strictly increasing,
!< `10`  : `x` is not equal to size(f,1),
!< `20`  : `y` is not equal to size(f,2),
!< `30`  : `z` is not equal to size(f,3),
!< `40`  : `q` is not equal to size(f,4),
!< `100` : cannot use linear interpolation for only one point.

    call me%destroy()

    istat = 0

    if(istat == 0 .and. size(x) /= size(f, 1)) istat = 10
    if(istat == 0 .and. size(y) /= size(f, 2)) istat = 20
    if(istat == 0 .and. size(z) /= size(f, 3)) istat = 30
    if(istat == 0 .and. size(q) /= size(f, 4)) istat = 40

    if(istat == 0) then
      call me%check_inputs(x=x, y=y, z=z, q=q, ierr=istat)
      if(istat == 0) then
        allocate(me%f(size(x), size(y), size(z), size(q))); me%f = f
        allocate(me%x(size(x))); me%x = x
        allocate(me%y(size(y))); me%y = y
        allocate(me%z(size(z))); me%z = z
        allocate(me%q(size(q))); me%q = q
        me%initialized = .true.
      endif
    endif

  endsubroutine initialize_4d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Constructor for a [[linear_interp_5d]] class.

  pure subroutine initialize_5d(me, x, y, z, q, r, f, istat)

    implicit none

    class(linear_interp_5d), intent(inout)    :: me
    real(wp), dimension(:), intent(in)         :: x
    real(wp), dimension(:), intent(in)         :: y
    real(wp), dimension(:), intent(in)         :: z
    real(wp), dimension(:), intent(in)         :: q
    real(wp), dimension(:), intent(in)         :: r
    real(wp), dimension(:, :, :, :, :), intent(in) :: f
    integer, intent(out)                      :: istat   !< `0`   : no problems,
!< `1`   : `x` is not strictly increasing,
!< `2`   : `y` is not strictly increasing,
!< `3`   : `z` is not strictly increasing,
!< `4`   : `q` is not strictly increasing,
!< `5`   : `r` is not strictly increasing,
!< `10`  : `x` is not equal to size(f,1),
!< `20`  : `y` is not equal to size(f,2),
!< `30`  : `z` is not equal to size(f,3),
!< `40`  : `q` is not equal to size(f,4),
!< `50`  : `r` is not equal to size(f,5),
!< `100` : cannot use linear interpolation for only one point.

    call me%destroy()

    istat = 0

    if(istat == 0 .and. size(x) /= size(f, 1)) istat = 10
    if(istat == 0 .and. size(y) /= size(f, 2)) istat = 20
    if(istat == 0 .and. size(z) /= size(f, 3)) istat = 30
    if(istat == 0 .and. size(q) /= size(f, 4)) istat = 40
    if(istat == 0 .and. size(r) /= size(f, 5)) istat = 50

    if(istat == 0) then
      call me%check_inputs(x=x, y=y, z=z, q=q, r=r, ierr=istat)
      if(istat == 0) then
        allocate(me%f(size(x), size(y), size(z), size(q), size(r))); me%f = f
        allocate(me%x(size(x))); me%x = x
        allocate(me%y(size(y))); me%y = y
        allocate(me%z(size(z))); me%z = z
        allocate(me%q(size(q))); me%q = q
        allocate(me%r(size(r))); me%r = r
        me%initialized = .true.
      endif
    endif

  endsubroutine initialize_5d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Constructor for a [[linear_interp_6d]] class.

  pure subroutine initialize_6d(me, x, y, z, q, r, s, f, istat)

    implicit none

    class(linear_interp_6d), intent(inout)      :: me
    real(wp), dimension(:), intent(in)           :: x
    real(wp), dimension(:), intent(in)           :: y
    real(wp), dimension(:), intent(in)           :: z
    real(wp), dimension(:), intent(in)           :: q
    real(wp), dimension(:), intent(in)           :: r
    real(wp), dimension(:), intent(in)           :: s
    real(wp), dimension(:, :, :, :, :, :), intent(in) :: f
    integer, intent(out)                        :: istat !< `0`   : no problems,
!< `1`   : `x` is not strictly increasing,
!< `2`   : `y` is not strictly increasing,
!< `3`   : `z` is not strictly increasing,
!< `4`   : `q` is not strictly increasing,
!< `5`   : `r` is not strictly increasing,
!< `6`   : `s` is not strictly increasing,
!< `10`  : `x` is not equal to size(f,1),
!< `20`  : `y` is not equal to size(f,2),
!< `30`  : `z` is not equal to size(f,3),
!< `40`  : `q` is not equal to size(f,4),
!< `50`  : `r` is not equal to size(f,5),
!< `60`  : `s` is not equal to size(f,6),
!< `100` : cannot use linear interpolation for only one point.

    call me%destroy()

    istat = 0

    if(istat == 0 .and. size(x) /= size(f, 1)) istat = 10
    if(istat == 0 .and. size(y) /= size(f, 2)) istat = 20
    if(istat == 0 .and. size(z) /= size(f, 3)) istat = 30
    if(istat == 0 .and. size(q) /= size(f, 4)) istat = 40
    if(istat == 0 .and. size(r) /= size(f, 5)) istat = 50
    if(istat == 0 .and. size(s) /= size(f, 6)) istat = 60

    if(istat == 0) then
      call me%check_inputs(x=x, y=y, z=z, q=q, r=r, s=s, ierr=istat)
      if(istat == 0) then
        allocate(me%f(size(x), size(y), size(z), size(q), size(r), size(s))); me%f = f
        allocate(me%x(size(x))); me%x = x
        allocate(me%y(size(y))); me%y = y
        allocate(me%z(size(z))); me%z = z
        allocate(me%q(size(q))); me%q = q
        allocate(me%r(size(r))); me%r = r
        allocate(me%s(size(s))); me%s = s
        me%initialized = .true.
      endif
    endif

  endsubroutine initialize_6d
!*****************************************************************************************

!*****************************************************************************************
!<
!  1D linear interpolation routine.

  pure subroutine interp_1d(me, x, f, istat)

    implicit none

    class(linear_interp_1d), intent(inout) :: me
    real(wp), intent(in)                   :: x
    real(wp), intent(out)                  :: f     !< Interpolated \( f(x) \)
    integer, intent(out), optional          :: istat !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer, dimension(2) :: ix
    real(wp) :: p1
    real(wp) :: q1
    integer :: mflag

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag)

      q1 = (x - me%x(ix(1))) / (me%x(ix(2)) - me%x(ix(1)))
      p1 = one - q1

      f = p1 * me%f(ix(1)) + q1 * me%f(ix(2))
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine interp_1d
!*****************************************************************************************

!*****************************************************************************************
!<
!  2D linear interpolation routine.

  pure subroutine interp_2d(me, x, y, f, istat)

    implicit none

    class(linear_interp_2d), intent(inout) :: me
    real(wp), intent(in)                   :: x
    real(wp), intent(in)                   :: y
    real(wp), intent(out)                  :: f     !< Interpolated \( f(x,y) \)
    integer, intent(out), optional          :: istat !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer, dimension(2) :: ix, iy
    real(wp) :: p1, p2
    real(wp) :: q1, q2
    integer :: mflag
    real(wp) :: fx1, fx2

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag)

      q1 = (x - me%x(ix(1))) / (me%x(ix(2)) - me%x(ix(1)))
      q2 = (y - me%y(iy(1))) / (me%y(iy(2)) - me%y(iy(1)))
      p1 = one - q1
      p2 = one - q2

      fx1 = p1 * me%f(ix(1), iy(1)) + q1 * me%f(ix(2), iy(1))
      fx2 = p1 * me%f(ix(1), iy(2)) + q1 * me%f(ix(2), iy(2))

      f = p2 * fx1 + q2 * fx2
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine interp_2d
!*****************************************************************************************

!*****************************************************************************************
!<
!  3D linear interpolation routine.

  pure subroutine interp_3d(me, x, y, z, f, istat)

    implicit none

    class(linear_interp_3d), intent(inout) :: me
    real(wp), intent(in)                   :: x
    real(wp), intent(in)                   :: y
    real(wp), intent(in)                   :: z
    real(wp), intent(out)                  :: f     !< Interpolated \( f(x,y,z) \)
    integer, intent(out), optional          :: istat !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer, dimension(2) :: ix, iy, iz
    real(wp) :: p1, p2, p3
    real(wp) :: q1, q2, q3
    integer :: mflag
    real(wp) :: fx11, fx21, fx12, fx22, fxy1, fxy2

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag)
      call dintrv(me%z, z, me%iloz, iz(1), iz(2), mflag)

      q1 = (x - me%x(ix(1))) / (me%x(ix(2)) - me%x(ix(1)))
      q2 = (y - me%y(iy(1))) / (me%y(iy(2)) - me%y(iy(1)))
      q3 = (z - me%z(iz(1))) / (me%z(iz(2)) - me%z(iz(1)))
      p1 = one - q1
      p2 = one - q2
      p3 = one - q3

      fx11 = p1 * me%f(ix(1), iy(1), iz(1)) + q1 * me%f(ix(2), iy(1), iz(1))
      fx21 = p1 * me%f(ix(1), iy(2), iz(1)) + q1 * me%f(ix(2), iy(2), iz(1))
      fx12 = p1 * me%f(ix(1), iy(1), iz(2)) + q1 * me%f(ix(2), iy(1), iz(2))
      fx22 = p1 * me%f(ix(1), iy(2), iz(2)) + q1 * me%f(ix(2), iy(2), iz(2))
      fxy1 = p2 * fx11 + q2 * fx21
      fxy2 = p2 * fx12 + q2 * fx22

      f = p3 * fxy1 + q3 * fxy2
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine interp_3d
!*****************************************************************************************

!*****************************************************************************************
!<
!  4D linear interpolation routine.

  pure subroutine interp_4d(me, x, y, z, q, f, istat)

    implicit none

    class(linear_interp_4d), intent(inout) :: me
    real(wp), intent(in)                   :: x
    real(wp), intent(in)                   :: y
    real(wp), intent(in)                   :: z
    real(wp), intent(in)                   :: q
    real(wp), intent(out)                  :: f     !< Interpolated \( f(x,y,z,q) \)
    integer, intent(out), optional          :: istat  !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer, dimension(2) :: ix, iy, iz, iq
    real(wp) :: p1, p2, p3, p4
    real(wp) :: q1, q2, q3, q4
    integer :: mflag
    real(wp) :: fx111, fx211, fx121, fx221, fxy11, fxy21, fxyz1, &
                fx112, fx212, fx122, fx222, fxy12, fxy22, fxyz2

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag)
      call dintrv(me%z, z, me%iloz, iz(1), iz(2), mflag)
      call dintrv(me%q, q, me%iloq, iq(1), iq(2), mflag)

      q1 = (x - me%x(ix(1))) / (me%x(ix(2)) - me%x(ix(1)))
      q2 = (y - me%y(iy(1))) / (me%y(iy(2)) - me%y(iy(1)))
      q3 = (z - me%z(iz(1))) / (me%z(iz(2)) - me%z(iz(1)))
      q4 = (q - me%q(iq(1))) / (me%q(iq(2)) - me%q(iq(1)))
      p1 = one - q1
      p2 = one - q2
      p3 = one - q3
      p4 = one - q4

      fx111 = p1 * me%f(ix(1), iy(1), iz(1), iq(1)) + q1 * me%f(ix(2), iy(1), iz(1), iq(1))
      fx211 = p1 * me%f(ix(1), iy(2), iz(1), iq(1)) + q1 * me%f(ix(2), iy(2), iz(1), iq(1))
      fx121 = p1 * me%f(ix(1), iy(1), iz(2), iq(1)) + q1 * me%f(ix(2), iy(1), iz(2), iq(1))
      fx221 = p1 * me%f(ix(1), iy(2), iz(2), iq(1)) + q1 * me%f(ix(2), iy(2), iz(2), iq(1))
      fx112 = p1 * me%f(ix(1), iy(1), iz(1), iq(2)) + q1 * me%f(ix(2), iy(1), iz(1), iq(2))
      fx212 = p1 * me%f(ix(1), iy(2), iz(1), iq(2)) + q1 * me%f(ix(2), iy(2), iz(1), iq(2))
      fx122 = p1 * me%f(ix(1), iy(1), iz(2), iq(2)) + q1 * me%f(ix(2), iy(1), iz(2), iq(2))
      fx222 = p1 * me%f(ix(1), iy(2), iz(2), iq(2)) + q1 * me%f(ix(2), iy(2), iz(2), iq(2))

      fxy11 = p2 * fx111 + q2 * fx211
      fxy21 = p2 * fx121 + q2 * fx221
      fxy12 = p2 * fx112 + q2 * fx212
      fxy22 = p2 * fx122 + q2 * fx222

      fxyz1 = p3 * fxy11 + q3 * fxy21
      fxyz2 = p3 * fxy12 + q3 * fxy22

      f = p4 * fxyz1 + q4 * fxyz2
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine interp_4d
!*****************************************************************************************

!*****************************************************************************************
!<
!  5D linear interpolation routine.

  pure subroutine interp_5d(me, x, y, z, q, r, f, istat)

    implicit none

    class(linear_interp_5d), intent(inout) :: me
    real(wp), intent(in)                   :: x
    real(wp), intent(in)                   :: y
    real(wp), intent(in)                   :: z
    real(wp), intent(in)                   :: q
    real(wp), intent(in)                   :: r
    real(wp), intent(out)                  :: f       !< Interpolated \( f(x,y,z,q,r) \)
    integer, intent(out), optional          :: istat   !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer, dimension(2) :: ix, iy, iz, iq, ir
    real(wp) :: p1, p2, p3, p4, p5
    real(wp) :: q1, q2, q3, q4, q5
    integer :: mflag
    real(wp) :: fx1111, fx2111, fx1211, fx2211, fx1121, fx2121, fx1221, fx2221, &
                fxy111, fxy211, fxy121, fxy221, fxyz11, fxyz21, fxyzq1, fx1112, &
                fx2112, fx1212, fx2212, fx1122, fx2122, fx1222, fx2222, fxy112, &
                fxy212, fxy122, fxy222, fxyz12, fxyz22, fxyzq2

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag)
      call dintrv(me%z, z, me%iloz, iz(1), iz(2), mflag)
      call dintrv(me%q, q, me%iloq, iq(1), iq(2), mflag)
      call dintrv(me%r, r, me%ilor, ir(1), ir(2), mflag)

      q1 = (x - me%x(ix(1))) / (me%x(ix(2)) - me%x(ix(1)))
      q2 = (y - me%y(iy(1))) / (me%y(iy(2)) - me%y(iy(1)))
      q3 = (z - me%z(iz(1))) / (me%z(iz(2)) - me%z(iz(1)))
      q4 = (q - me%q(iq(1))) / (me%q(iq(2)) - me%q(iq(1)))
      q5 = (r - me%r(ir(1))) / (me%r(ir(2)) - me%r(ir(1)))
      p1 = one - q1
      p2 = one - q2
      p3 = one - q3
      p4 = one - q4
      p5 = one - q5

      fx1111 = p1 * me%f(ix(1), iy(1), iz(1), iq(1), ir(1)) + q1 * me%f(ix(2), iy(1), iz(1), iq(1), ir(1))
      fx2111 = p1 * me%f(ix(1), iy(2), iz(1), iq(1), ir(1)) + q1 * me%f(ix(2), iy(2), iz(1), iq(1), ir(1))
      fx1211 = p1 * me%f(ix(1), iy(1), iz(2), iq(1), ir(1)) + q1 * me%f(ix(2), iy(1), iz(2), iq(1), ir(1))
      fx2211 = p1 * me%f(ix(1), iy(2), iz(2), iq(1), ir(1)) + q1 * me%f(ix(2), iy(2), iz(2), iq(1), ir(1))
      fx1121 = p1 * me%f(ix(1), iy(1), iz(1), iq(2), ir(1)) + q1 * me%f(ix(2), iy(1), iz(1), iq(2), ir(1))
      fx2121 = p1 * me%f(ix(1), iy(2), iz(1), iq(2), ir(1)) + q1 * me%f(ix(2), iy(2), iz(1), iq(2), ir(1))
      fx1221 = p1 * me%f(ix(1), iy(1), iz(2), iq(2), ir(1)) + q1 * me%f(ix(2), iy(1), iz(2), iq(2), ir(1))
      fx2221 = p1 * me%f(ix(1), iy(2), iz(2), iq(2), ir(1)) + q1 * me%f(ix(2), iy(2), iz(2), iq(2), ir(1))
      fx1112 = p1 * me%f(ix(1), iy(1), iz(1), iq(1), ir(2)) + q1 * me%f(ix(2), iy(1), iz(1), iq(1), ir(2))
      fx2112 = p1 * me%f(ix(1), iy(2), iz(1), iq(1), ir(2)) + q1 * me%f(ix(2), iy(2), iz(1), iq(1), ir(2))
      fx1212 = p1 * me%f(ix(1), iy(1), iz(2), iq(1), ir(2)) + q1 * me%f(ix(2), iy(1), iz(2), iq(1), ir(2))
      fx2212 = p1 * me%f(ix(1), iy(2), iz(2), iq(1), ir(2)) + q1 * me%f(ix(2), iy(2), iz(2), iq(1), ir(2))
      fx1122 = p1 * me%f(ix(1), iy(1), iz(1), iq(2), ir(2)) + q1 * me%f(ix(2), iy(1), iz(1), iq(2), ir(2))
      fx2122 = p1 * me%f(ix(1), iy(2), iz(1), iq(2), ir(2)) + q1 * me%f(ix(2), iy(2), iz(1), iq(2), ir(2))
      fx1222 = p1 * me%f(ix(1), iy(1), iz(2), iq(2), ir(2)) + q1 * me%f(ix(2), iy(1), iz(2), iq(2), ir(2))
      fx2222 = p1 * me%f(ix(1), iy(2), iz(2), iq(2), ir(2)) + q1 * me%f(ix(2), iy(2), iz(2), iq(2), ir(2))

      fxy111 = p2 * fx1111 + q2 * fx2111
      fxy211 = p2 * fx1211 + q2 * fx2211
      fxy121 = p2 * fx1121 + q2 * fx2121
      fxy221 = p2 * fx1221 + q2 * fx2221
      fxy112 = p2 * fx1112 + q2 * fx2112
      fxy212 = p2 * fx1212 + q2 * fx2212
      fxy122 = p2 * fx1122 + q2 * fx2122
      fxy222 = p2 * fx1222 + q2 * fx2222

      fxyz11 = p3 * fxy111 + q3 * fxy211
      fxyz21 = p3 * fxy121 + q3 * fxy221
      fxyz12 = p3 * fxy112 + q3 * fxy212
      fxyz22 = p3 * fxy122 + q3 * fxy222

      fxyzq1 = p4 * fxyz11 + q4 * fxyz21
      fxyzq2 = p4 * fxyz12 + q4 * fxyz22

      f = p5 * fxyzq1 + q5 * fxyzq2
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine interp_5d
!*****************************************************************************************

!*****************************************************************************************
!<
!  6D linear interpolation routine.

  pure subroutine interp_6d(me, x, y, z, q, r, s, f, istat)

    implicit none

    class(linear_interp_6d), intent(inout) :: me
    real(wp), intent(in)                   :: x
    real(wp), intent(in)                   :: y
    real(wp), intent(in)                   :: z
    real(wp), intent(in)                   :: q
    real(wp), intent(in)                   :: r
    real(wp), intent(in)                   :: s
    real(wp), intent(out)                  :: f        !< Interpolated \( f(x,y,z,q,r,s) \)
    integer, intent(out), optional          :: istat    !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer, dimension(2) :: ix, iy, iz, iq, ir, is
    real(wp) :: p1, p2, p3, p4, p5, p6
    real(wp) :: q1, q2, q3, q4, q5, q6
    integer :: mflag
    real(wp) :: fx11111, fx21111, fx12111, fx22111, fx11211, fx21211, fx12211, &
                fx22211, fxy1111, fxy2111, fxy1211, fxy2211, fxyz111, fxyz211, &
                fxyzq11, fx11121, fx21121, fx12121, fx22121, fx11221, fx21221, &
                fx12221, fx22221, fxy1121, fxy2121, fxy1221, fxy2221, fxyz121, &
                fxyz221, fxyzq21, fx11112, fx21112, fx12112, fx22112, fx11212, &
                fx21212, fx12212, fx22212, fxy1112, fxy2112, fxy1212, fxy2212, &
                fxyz112, fxyz212, fxyzq12, fx11122, fx21122, fx12122, fx22122, &
                fx11222, fx21222, fx12222, fx22222, fxy1122, fxy2122, fxy1222, &
                fxy2222, fxyz122, fxyz222, fxyzq22, fxyzqr1, fxyzqr2

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag)
      call dintrv(me%z, z, me%iloz, iz(1), iz(2), mflag)
      call dintrv(me%q, q, me%iloq, iq(1), iq(2), mflag)
      call dintrv(me%r, r, me%ilor, ir(1), ir(2), mflag)
      call dintrv(me%s, s, me%ilos, is(1), is(2), mflag)

      q1 = (x - me%x(ix(1))) / (me%x(ix(2)) - me%x(ix(1)))
      q2 = (y - me%y(iy(1))) / (me%y(iy(2)) - me%y(iy(1)))
      q3 = (z - me%z(iz(1))) / (me%z(iz(2)) - me%z(iz(1)))
      q4 = (q - me%q(iq(1))) / (me%q(iq(2)) - me%q(iq(1)))
      q5 = (r - me%r(ir(1))) / (me%r(ir(2)) - me%r(ir(1)))
      q6 = (s - me%s(is(1))) / (me%s(is(2)) - me%s(is(1)))
      p1 = one - q1
      p2 = one - q2
      p3 = one - q3
      p4 = one - q4
      p5 = one - q5
      p6 = one - q6

      fx11111 = p1 * me%f(ix(1), iy(1), iz(1), iq(1), ir(1), is(1)) + q1 * me%f(ix(2), iy(1), iz(1), iq(1), ir(1), is(1))
      fx21111 = p1 * me%f(ix(1), iy(2), iz(1), iq(1), ir(1), is(1)) + q1 * me%f(ix(2), iy(2), iz(1), iq(1), ir(1), is(1))
      fx12111 = p1 * me%f(ix(1), iy(1), iz(2), iq(1), ir(1), is(1)) + q1 * me%f(ix(2), iy(1), iz(2), iq(1), ir(1), is(1))
      fx22111 = p1 * me%f(ix(1), iy(2), iz(2), iq(1), ir(1), is(1)) + q1 * me%f(ix(2), iy(2), iz(2), iq(1), ir(1), is(1))
      fx11211 = p1 * me%f(ix(1), iy(1), iz(1), iq(2), ir(1), is(1)) + q1 * me%f(ix(2), iy(1), iz(1), iq(2), ir(1), is(1))
      fx21211 = p1 * me%f(ix(1), iy(2), iz(1), iq(2), ir(1), is(1)) + q1 * me%f(ix(2), iy(2), iz(1), iq(2), ir(1), is(1))
      fx12211 = p1 * me%f(ix(1), iy(1), iz(2), iq(2), ir(1), is(1)) + q1 * me%f(ix(2), iy(1), iz(2), iq(2), ir(1), is(1))
      fx22211 = p1 * me%f(ix(1), iy(2), iz(2), iq(2), ir(1), is(1)) + q1 * me%f(ix(2), iy(2), iz(2), iq(2), ir(1), is(1))
      fx11121 = p1 * me%f(ix(1), iy(1), iz(1), iq(1), ir(2), is(1)) + q1 * me%f(ix(2), iy(1), iz(1), iq(1), ir(2), is(1))
      fx21121 = p1 * me%f(ix(1), iy(2), iz(1), iq(1), ir(2), is(1)) + q1 * me%f(ix(2), iy(2), iz(1), iq(1), ir(2), is(1))
      fx12121 = p1 * me%f(ix(1), iy(1), iz(2), iq(1), ir(2), is(1)) + q1 * me%f(ix(2), iy(1), iz(2), iq(1), ir(2), is(1))
      fx22121 = p1 * me%f(ix(1), iy(2), iz(2), iq(1), ir(2), is(1)) + q1 * me%f(ix(2), iy(2), iz(2), iq(1), ir(2), is(1))
      fx11221 = p1 * me%f(ix(1), iy(1), iz(1), iq(2), ir(2), is(1)) + q1 * me%f(ix(2), iy(1), iz(1), iq(2), ir(2), is(1))
      fx21221 = p1 * me%f(ix(1), iy(2), iz(1), iq(2), ir(2), is(1)) + q1 * me%f(ix(2), iy(2), iz(1), iq(2), ir(2), is(1))
      fx12221 = p1 * me%f(ix(1), iy(1), iz(2), iq(2), ir(2), is(1)) + q1 * me%f(ix(2), iy(1), iz(2), iq(2), ir(2), is(1))
      fx22221 = p1 * me%f(ix(1), iy(2), iz(2), iq(2), ir(2), is(1)) + q1 * me%f(ix(2), iy(2), iz(2), iq(2), ir(2), is(1))
      fx11112 = p1 * me%f(ix(1), iy(1), iz(1), iq(1), ir(1), is(2)) + q1 * me%f(ix(2), iy(1), iz(1), iq(1), ir(1), is(2))
      fx21112 = p1 * me%f(ix(1), iy(2), iz(1), iq(1), ir(1), is(2)) + q1 * me%f(ix(2), iy(2), iz(1), iq(1), ir(1), is(2))
      fx12112 = p1 * me%f(ix(1), iy(1), iz(2), iq(1), ir(1), is(2)) + q1 * me%f(ix(2), iy(1), iz(2), iq(1), ir(1), is(2))
      fx22112 = p1 * me%f(ix(1), iy(2), iz(2), iq(1), ir(1), is(2)) + q1 * me%f(ix(2), iy(2), iz(2), iq(1), ir(1), is(2))
      fx11212 = p1 * me%f(ix(1), iy(1), iz(1), iq(2), ir(1), is(2)) + q1 * me%f(ix(2), iy(1), iz(1), iq(2), ir(1), is(2))
      fx21212 = p1 * me%f(ix(1), iy(2), iz(1), iq(2), ir(1), is(2)) + q1 * me%f(ix(2), iy(2), iz(1), iq(2), ir(1), is(2))
      fx12212 = p1 * me%f(ix(1), iy(1), iz(2), iq(2), ir(1), is(2)) + q1 * me%f(ix(2), iy(1), iz(2), iq(2), ir(1), is(2))
      fx22212 = p1 * me%f(ix(1), iy(2), iz(2), iq(2), ir(1), is(2)) + q1 * me%f(ix(2), iy(2), iz(2), iq(2), ir(1), is(2))
      fx11122 = p1 * me%f(ix(1), iy(1), iz(1), iq(1), ir(2), is(2)) + q1 * me%f(ix(2), iy(1), iz(1), iq(1), ir(2), is(2))
      fx21122 = p1 * me%f(ix(1), iy(2), iz(1), iq(1), ir(2), is(2)) + q1 * me%f(ix(2), iy(2), iz(1), iq(1), ir(2), is(2))
      fx12122 = p1 * me%f(ix(1), iy(1), iz(2), iq(1), ir(2), is(2)) + q1 * me%f(ix(2), iy(1), iz(2), iq(1), ir(2), is(2))
      fx22122 = p1 * me%f(ix(1), iy(2), iz(2), iq(1), ir(2), is(2)) + q1 * me%f(ix(2), iy(2), iz(2), iq(1), ir(2), is(2))
      fx11222 = p1 * me%f(ix(1), iy(1), iz(1), iq(2), ir(2), is(2)) + q1 * me%f(ix(2), iy(1), iz(1), iq(2), ir(2), is(2))
      fx21222 = p1 * me%f(ix(1), iy(2), iz(1), iq(2), ir(2), is(2)) + q1 * me%f(ix(2), iy(2), iz(1), iq(2), ir(2), is(2))
      fx12222 = p1 * me%f(ix(1), iy(1), iz(2), iq(2), ir(2), is(2)) + q1 * me%f(ix(2), iy(1), iz(2), iq(2), ir(2), is(2))
      fx22222 = p1 * me%f(ix(1), iy(2), iz(2), iq(2), ir(2), is(2)) + q1 * me%f(ix(2), iy(2), iz(2), iq(2), ir(2), is(2))

      fxy1111 = p2 * fx11111 + q2 * fx21111
      fxy2111 = p2 * fx12111 + q2 * fx22111
      fxy1211 = p2 * fx11211 + q2 * fx21211
      fxy2211 = p2 * fx12211 + q2 * fx22211
      fxy1121 = p2 * fx11121 + q2 * fx21121
      fxy2121 = p2 * fx12121 + q2 * fx22121
      fxy1221 = p2 * fx11221 + q2 * fx21221
      fxy2221 = p2 * fx12221 + q2 * fx22221
      fxy1112 = p2 * fx11112 + q2 * fx21112
      fxy2112 = p2 * fx12112 + q2 * fx22112
      fxy1212 = p2 * fx11212 + q2 * fx21212
      fxy2212 = p2 * fx12212 + q2 * fx22212
      fxy1122 = p2 * fx11122 + q2 * fx21122
      fxy2122 = p2 * fx12122 + q2 * fx22122
      fxy1222 = p2 * fx11222 + q2 * fx21222
      fxy2222 = p2 * fx12222 + q2 * fx22222

      fxyz111 = p3 * fxy1111 + q3 * fxy2111
      fxyz211 = p3 * fxy1211 + q3 * fxy2211
      fxyz121 = p3 * fxy1121 + q3 * fxy2121
      fxyz221 = p3 * fxy1221 + q3 * fxy2221
      fxyz112 = p3 * fxy1112 + q3 * fxy2112
      fxyz212 = p3 * fxy1212 + q3 * fxy2212
      fxyz122 = p3 * fxy1122 + q3 * fxy2122
      fxyz222 = p3 * fxy1222 + q3 * fxy2222

      fxyzq11 = p4 * fxyz111 + q4 * fxyz211
      fxyzq21 = p4 * fxyz121 + q4 * fxyz221
      fxyzq12 = p4 * fxyz112 + q4 * fxyz212
      fxyzq22 = p4 * fxyz122 + q4 * fxyz222

      fxyzqr1 = p5 * fxyzq11 + q5 * fxyzq21
      fxyzqr2 = p5 * fxyzq12 + q5 * fxyzq22

      f = p6 * fxyzqr1 + q6 * fxyzqr2
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine interp_6d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Returns the indices in `xt` that bound `x`, to use for interpolation.
!  If outside the range, then the indices are returned that can
!  be used for extrapolation.
!  Precisely,
!
!```fortran
!         if            x < xt(1)   then ileft=1,   iright=2,    mflag=-1
!         if   xt(i) <= x < xt(i+1) then ileft=i,   iright=i+1,  mflag=0
!         if   xt(n) <= x           then ileft=n-1, iright=n,    mflag=1
!```
!
!### History
!
!  * interv written by carl de boor [5]
!  * dintrv author: amos, d. e., (snla) : date written 800901
!  * revision date 820801
!  * Jacob Williams, 2/24/2015 : updated to free-form Fortran.
!  * Jacob Williams, 2/17/2016 : additional refactoring (eliminated GOTOs).
!  * Jacob Williams, 2/22/2016 : modified bspline-fortran `dintrv` routine for
!    linear interpolation/extrapolation use.
!  * Jacob Williams, 10/9/2019 : added optional `inearest` output.

  pure subroutine dintrv(xt, x, ilo, ileft, iright, mflag, inearest)

    implicit none

    real(wp), dimension(:), intent(in) :: xt       !< a knot or break point vector
    real(wp), intent(in)              :: x        !< argument
    integer, intent(inout)            :: ilo      !< an initialization parameter which must be set
!< to 1 the first time the array `xt` is
!< processed by dintrv. `ilo` contains information for
!< efficient processing after the initial call and `ilo`
!< must not be changed by the user.  each dimension
!< requires a distinct `ilo` parameter.
    integer, intent(out)              :: ileft    !< left index
    integer, intent(out)              :: iright   !< right index
    integer, intent(out)              :: mflag    !< signals when `x` lies out of bounds
    integer, intent(out), optional     :: inearest !< nearest index

    integer :: ihi, istep, imid, n

    n = size(xt)

    if(n == 1) then
! this is only allowed for nearest interpolation
      if(present(inearest)) then
        inearest = 1
        return
      endif
    endif

    ihi = ilo + 1
    if(ihi >= n) then
      if(x >= xt(n)) then
        mflag = 1
        ileft = n - 1
        iright = n
        if(present(inearest)) inearest = n
        return
      endif
      if(n <= 1) then
        mflag = -1
        ileft = 1
        iright = 2
        if(present(inearest)) inearest = 1
        return
      endif
      ilo = n - 1
      ihi = n
    endif

    if(x >= xt(ihi)) then

! now x >= xt(ilo). find upper bound
      istep = 1
      do
        ilo = ihi
        ihi = ilo + istep
        if(ihi >= n) then
          if(x >= xt(n)) then
            mflag = 1
            ileft = n - 1
            iright = n
            if(present(inearest)) inearest = n
            return
          endif
          ihi = n
        elseif(x >= xt(ihi)) then
          istep = istep * 2
          cycle
        endif
        exit
      enddo

    else

      if(x >= xt(ilo)) then
        mflag = 0
        ileft = ilo
        iright = ilo + 1
        if(present(inearest)) then
          if(abs(x - xt(ileft)) <= abs(x - xt(iright))) then
            inearest = ileft
          else
            inearest = iright
          endif
        endif
        return
      endif
! now x <= xt(ihi). find lower bound
      istep = 1
      do
        ihi = ilo
        ilo = ihi - istep
        if(ilo <= 1) then
          ilo = 1
          if(x < xt(1)) then
            mflag = -1
            ileft = 1
            iright = 2
            if(present(inearest)) inearest = 1
            return
          endif
        elseif(x < xt(ilo)) then
          istep = istep * 2
          cycle
        endif
        exit
      enddo

    endif

! now xt(ilo) <= x < xt(ihi). narrow the interval
    do
      imid = (ilo + ihi) / 2
      if(imid == ilo) then
        mflag = 0
        ileft = ilo
        iright = ilo + 1
        if(present(inearest)) then
          if(abs(x - xt(ileft)) <= abs(x - xt(iright))) then
            inearest = ileft
          else
            inearest = iright
          endif
        endif
        return
      endif
! note. it is assumed that imid = ilo in case ihi = ilo+1
      if(x < xt(imid)) then
        ihi = imid
      else
        ilo = imid
      endif
    enddo

  endsubroutine dintrv
!*****************************************************************************************

!*****************************************************************************************
!<
!  1D nearest neighbor interpolation routine.

  pure subroutine nearest_1d(me, x, f, istat)

    implicit none

    class(nearest_interp_1d), intent(inout) :: me
    real(wp), intent(in)                    :: x
    real(wp), intent(out)                   :: f     !< Nearest \( f(x) \)
    integer, intent(out), optional           :: istat !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer :: mflag
    integer, dimension(2) :: ix
    integer :: i

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag, i)

      f = me%f(i)
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine nearest_1d
!*****************************************************************************************

!*****************************************************************************************
!<
!  2D nearest neighbor interpolation routine.

  pure subroutine nearest_2d(me, x, y, f, istat)

    implicit none

    class(nearest_interp_2d), intent(inout) :: me
    real(wp), intent(in)                    :: x
    real(wp), intent(in)                    :: y
    real(wp), intent(out)                   :: f     !< Nearest \( f(x,y) \)
    integer, intent(out), optional           :: istat !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer :: mflag
    integer, dimension(2) :: ix, iy
    integer :: i, j

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag, i)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag, j)

      f = me%f(i, j)
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine nearest_2d
!*****************************************************************************************

!*****************************************************************************************
!<
!  3D nearest neighbor interpolation routine.

  pure subroutine nearest_3d(me, x, y, z, f, istat)

    implicit none

    class(nearest_interp_3d), intent(inout) :: me
    real(wp), intent(in)                    :: x
    real(wp), intent(in)                    :: y
    real(wp), intent(in)                    :: z
    real(wp), intent(out)                   :: f     !< Nearest \( f(x,y,z) \)
    integer, intent(out), optional           :: istat !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer :: mflag
    integer, dimension(2) :: ix, iy, iz
    integer :: i, j, k

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag, i)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag, j)
      call dintrv(me%z, z, me%iloz, iz(1), iz(2), mflag, k)

      f = me%f(i, j, k)
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine nearest_3d
!*****************************************************************************************

!*****************************************************************************************
!<
!  4D nearest neighbor interpolation routine.

  pure subroutine nearest_4d(me, x, y, z, q, f, istat)

    implicit none

    class(nearest_interp_4d), intent(inout) :: me
    real(wp), intent(in)                    :: x
    real(wp), intent(in)                    :: y
    real(wp), intent(in)                    :: z
    real(wp), intent(in)                    :: q
    real(wp), intent(out)                   :: f     !< Nearest \( f(x,y,z,q) \)
    integer, intent(out), optional           :: istat !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer :: mflag
    integer, dimension(2) :: ix, iy, iz, iq
    integer :: i, j, k, l

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag, i)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag, j)
      call dintrv(me%z, z, me%iloz, iz(1), iz(2), mflag, k)
      call dintrv(me%q, q, me%iloq, iq(1), iq(2), mflag, l)

      f = me%f(i, j, k, l)
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine nearest_4d
!*****************************************************************************************

!*****************************************************************************************
!<
!  5D nearest neighbor interpolation routine.

  pure subroutine nearest_5d(me, x, y, z, q, r, f, istat)

    implicit none

    class(nearest_interp_5d), intent(inout) :: me
    real(wp), intent(in)                    :: x
    real(wp), intent(in)                    :: y
    real(wp), intent(in)                    :: z
    real(wp), intent(in)                    :: q
    real(wp), intent(in)                    :: r
    real(wp), intent(out)                   :: f     !< Nearest \( f(x,y,z,q,r) \)
    integer, intent(out), optional           :: istat !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer :: mflag
    integer, dimension(2) :: ix, iy, iz, iq, ir
    integer :: i, j, k, l, m

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag, i)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag, j)
      call dintrv(me%z, z, me%iloz, iz(1), iz(2), mflag, k)
      call dintrv(me%q, q, me%iloq, iq(1), iq(2), mflag, l)
      call dintrv(me%r, r, me%ilor, ir(1), ir(2), mflag, m)

      f = me%f(i, j, k, l, m)
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine nearest_5d
!*****************************************************************************************

!*****************************************************************************************
!<
!  6D nearest neighbor interpolation routine.

  pure subroutine nearest_6d(me, x, y, z, q, r, s, f, istat)

    implicit none

    class(nearest_interp_6d), intent(inout) :: me
    real(wp), intent(in)                    :: x
    real(wp), intent(in)                    :: y
    real(wp), intent(in)                    :: z
    real(wp), intent(in)                    :: q
    real(wp), intent(in)                    :: r
    real(wp), intent(in)                    :: s
    real(wp), intent(out)                   :: f     !< Nearest \( f(x,y,z,q,r,s) \)
    integer, intent(out), optional           :: istat !< `0`  : no problems,
!< `-1` : class has not been initialized

    integer :: mflag
    integer, dimension(2) :: ix, iy, iz, iq, ir, is
    integer :: i, j, k, l, m, n

    if(me%initialized) then

      call dintrv(me%x, x, me%ilox, ix(1), ix(2), mflag, i)
      call dintrv(me%y, y, me%iloy, iy(1), iy(2), mflag, j)
      call dintrv(me%z, z, me%iloz, iz(1), iz(2), mflag, k)
      call dintrv(me%q, q, me%iloq, iq(1), iq(2), mflag, l)
      call dintrv(me%r, r, me%ilor, ir(1), ir(2), mflag, m)
      call dintrv(me%s, s, me%ilos, is(1), is(2), mflag, n)

      f = me%f(i, j, k, l, m, n)
      if(present(istat)) istat = 0

    else

      if(present(istat)) istat = -1
      f = zero

    endif

  endsubroutine nearest_6d
!*****************************************************************************************

!*****************************************************************************************
!<
!  Returns true if all the elements in the array `x` are unique.
!  Note: the array must be sorted.
!
!@note This routine is not currently used in the module.

  pure function check_if_unique(x) result(unique)

    implicit none

    real(wp), dimension(:), intent(in) :: x       !< a sorted array
    logical                          :: unique  !< true if all elements are unique

    integer :: i  !< counter

    unique = .true. ! initialize

    do i = 1, size(x) - 1
      if(x(i) == x(i + 1)) then
        unique = .false.
        exit
      endif
    enddo

  endfunction check_if_unique
!*****************************************************************************************

!*****************************************************************************************
!<
!  Sorts an array `dx` in increasing order,
!  carrying along an additional array `dy`.
!
!  Uses a non-recursive quicksort, reverting to insertion sort on arrays of
!  size <= 20. Dimension of `stack` limits array size to about \(2^32\).
!
!### License
!  * [Original LAPACK license](http://www.netlib.org/lapack/LICENSE.txt)
!
!### History
!  * Based on the LAPACK routine [DLASRT](http://www.netlib.org/lapack/explore-html/df/ddf/dlasrt_8f.html).
!  * Extensively modified by Jacob Williams, Feb. 2016. Converted to
!    modern Fortran and added the `dy` output. Removed the descending sort option.
!
!@note This routine is not currently used in the module.

  pure subroutine sort(dx, dy)

    implicit none

    real(wp), dimension(:), intent(inout) :: dx  !< on entry, the array to be sorted.
!< on exit, `dx` has been sorted into increasing order
!< (`dx(1) <= ... <= dx(n)`) or into decreasing order
!< (`dx(1) >= ... >= dx(n)`), depending on `id`.
    real(wp), dimension(:), intent(inout) :: dy  !< array carried along with `dx`.

    integer, parameter :: select = 20  !< max size for using insertion sort.

    integer :: endd, i, j, n, start, stkpnt
    real(wp) :: d1, d2, d3, dmnmx, dmnmy, tmp
    integer, dimension(2, 32) :: stack

! number of elements to sort:
    n = size(dx)

    if(n > 1) then

      stkpnt = 1
      stack(1, 1) = 1
      stack(2, 1) = n

      do

        start = stack(1, stkpnt)
        endd = stack(2, stkpnt)
        stkpnt = stkpnt - 1
        if(endd - start <= select .and. endd > start) then

! do insertion sort on dx( start:endd )
          insertion: do i = start + 1, endd
            do j = i, start + 1, -1
              if(dx(j) >= dx(j - 1)) cycle insertion
              dmnmx = dx(j)
              dx(j) = dx(j - 1)
              dx(j - 1) = dmnmx
              dmnmy = dy(j)
              dy(j) = dy(j - 1)
              dy(j - 1) = dmnmy
            enddo
          enddo insertion

        elseif(endd - start > select) then

! partition dx( start:endd ) and stack parts, largest one first
! choose partition entry as median of 3

          d1 = dx(start)
          d2 = dx(endd)
          i = (start + endd) / 2
          d3 = dx(i)
          if(d1 < d2) then
            if(d3 < d1) then
              dmnmx = d1
            elseif(d3 < d2) then
              dmnmx = d3
            else
              dmnmx = d2
            endif
          elseif(d3 < d2) then
            dmnmx = d2
          elseif(d3 < d1) then
            dmnmx = d3
          else
            dmnmx = d1
          endif

          i = start - 1
          j = endd + 1
          do
            do
              j = j - 1
              if(dx(j) <= dmnmx) exit
            enddo
            do
              i = i + 1
              if(dx(i) >= dmnmx) exit
            enddo
            if(i < j) then
              tmp = dx(i)
              dx(i) = dx(j)
              dx(j) = tmp
              tmp = dy(i)
              dy(i) = dy(j)
              dy(j) = tmp
            else
              exit
            endif
          enddo
          if(j - start > endd - j - 1) then
            stkpnt = stkpnt + 1
            stack(1, stkpnt) = start
            stack(2, stkpnt) = j
            stkpnt = stkpnt + 1
            stack(1, stkpnt) = j + 1
            stack(2, stkpnt) = endd
          else
            stkpnt = stkpnt + 1
            stack(1, stkpnt) = j + 1
            stack(2, stkpnt) = endd
            stkpnt = stkpnt + 1
            stack(1, stkpnt) = start
            stack(2, stkpnt) = j
          endif

        endif

        if(stkpnt <= 0) exit

      enddo

    endif

  endsubroutine sort
!*****************************************************************************************

!*****************************************************************************************
!<
!  Check the validity of the inputs to the initialize routines.
!  Prints warning message if there is an error,
!  and also sets `ierr` (/=0 if there were any errors).
!
!  Supports up to 6D: x,y,z,q,r,s
!
!# History
!  * Jacob Williams, 2/24/2015 : Created this routine.
!  * Jacob Williams, 2/23/2016 : modified for linear interp module.

  pure subroutine check_inputs(me, x, y, z, q, r, s, ierr)

    implicit none

    class(linear_interp_class), intent(in)      :: me
    real(wp), dimension(:), intent(in), optional  :: x     !< `x` abscissa vector
    real(wp), dimension(:), intent(in), optional  :: y     !< `y` abscissa vector
    real(wp), dimension(:), intent(in), optional  :: z     !< `z` abscissa vector
    real(wp), dimension(:), intent(in), optional  :: q     !< `q` abscissa vector
    real(wp), dimension(:), intent(in), optional  :: r     !< `r` abscissa vector
    real(wp), dimension(:), intent(in), optional  :: s     !< `s` abscissa vector
    integer, intent(out)                        :: ierr  !< `0`   : no problems,
!< `1`   : `x` is not strictly increasing,
!< `2`   : `y` is not strictly increasing,
!< `3`   : `z` is not strictly increasing,
!< `4`   : `q` is not strictly increasing,
!< `5`   : `r` is not strictly increasing,
!< `6`   : `s` is not strictly increasing,
!< `100` : cannot use linear interpolation for only one point.

    ierr = 0  ! initialize

    if(present(x)) call check(x, 1, ierr); if(ierr /= 0) return
    if(present(y)) call check(y, 2, ierr); if(ierr /= 0) return
    if(present(z)) call check(z, 3, ierr); if(ierr /= 0) return
    if(present(q)) call check(q, 4, ierr); if(ierr /= 0) return
    if(present(r)) call check(r, 5, ierr); if(ierr /= 0) return
    if(present(s)) call check(s, 6, ierr); if(ierr /= 0) return

    if(ierr == 0) then
      select type(me)
      class is(nearest_interp_1d)
      class is(nearest_interp_2d)
      class is(nearest_interp_3d)
      class is(nearest_interp_4d)
      class is(nearest_interp_5d)
      class is(nearest_interp_6d)
      class default
! need at least two points for linear interpolation:
        if(size(x) == 1) ierr = 100
      endselect
    endif

  contains
!*****************************************************************************************

    pure subroutine check(v, error_code, ierr)

      implicit none

      real(wp), dimension(:), intent(in) :: v          !< abcissae vector
      integer, intent(in)               :: error_code !< error code for check
      integer, intent(inout)            :: ierr       !< will be set to `error_code` if there is a problem

      integer :: i  !< counter
      integer :: n  !< size of the input `v` array

      n = size(v)
      do i = 2, n
        if(v(i) <= v(i - 1)) then
          ierr = error_code
          exit
        endif
      enddo

    endsubroutine check

  endsubroutine check_inputs
!*****************************************************************************************

!*****************************************************************************************
endmodule linear_interpolation_module
!*****************************************************************************************


program test_fftw
use iso_c_binding, only: c_ptr
use types, only: dp
use constants, only: i_
use fftw, only: fftw_plan_dft_1d, fftw_plan_dft_3d, FFTW_FORWARD, &
    FFTW_ESTIMATE, fftw_execute_dft, fftw_destroy_plan, &
    FFTW_MEASURE, alloc1d, alloc3d, free
implicit none

type(c_ptr) :: plan
complex(dp), dimension(4, 8, 16) :: y3, ydft3
integer :: n
complex(dp), pointer :: x(:), xdft(:), x3(:, :, :), xdft3(:, :, :)
real(dp) :: t1, t2, t3

! This works, but is slow due to y,ydft not being aligned to exploit SIMD
! The dimensions (4, 8, 16) must be reversed:
plan = fftw_plan_dft_3d(16, 8, 4, y3, ydft3, FFTW_FORWARD, FFTW_ESTIMATE)
y3 = 0
call fftw_execute_dft(plan, y3, ydft3)
call fftw_destroy_plan(plan)

n = 1024**2

! This is fast
print *, "1D FFT of size n=", n, "with FFTW allocation"
x => alloc1d(n)
xdft => alloc1d(n)
x = 0
call cpu_time(t1)
!plan = fftw_plan_dft_1d(n, x, xdft, FFTW_FORWARD, FFTW_ESTIMATE)
plan = fftw_plan_dft_1d(n, x, xdft, FFTW_FORWARD, FFTW_MEASURE)
call cpu_time(t2)
call fftw_execute_dft(plan, x, xdft)
call cpu_time(t3)
print *, "Total time:", (t3-t1)*1000, "ms"
print *, "init:      ", (t2-t1)*1000, "ms"
print *, "calc:      ", (t3-t2)*1000, "ms"
call fftw_destroy_plan(plan)
call free(x)
call free(xdft)

n = 256

! This is fast
print *, "1D FFT of size n=", n, "^3  with FFTW allocation"
x3 => alloc3d(n, n, n)
xdft3 => alloc3d(n, n, n)
x3 = 0
call cpu_time(t1)
plan = fftw_plan_dft_3d(n, n, n, x3, xdft3, FFTW_FORWARD, FFTW_MEASURE)
call cpu_time(t2)
call fftw_execute_dft(plan, x3, xdft3)
call cpu_time(t3)
print *, "Total time:", (t3-t1)*1000, "ms"
print *, "init:      ", (t2-t1)*1000, "ms"
print *, "calc:      ", (t3-t2)*1000, "ms"
call fftw_destroy_plan(plan)
call free(x3)
call free(xdft3)
end program


! ============================================================================
!  Sets aux arrays
!    aux(:,1) = Bathymetry
!    aux(:,2) = Wind field
!    aux(:,3) = Initial steady state, top layer depth, h_1 = eta_1 - eta_2
!    aux(:,4) = Initial steady state, bottom layer depth, h_2 = eta_2 - b
! ============================================================================
subroutine setaux(maxmx,mbc,mx,xlower,dx,maux,aux)

    use parameters_module

    implicit none

    ! Input parameters
    integer, intent(in) :: maxmx,mbc,mx,maux
    double precision, intent(in) :: xlower,dx

    ! Auxillary array
    double precision, intent(inout) :: aux(1-mbc:maxmx+mbc, maux)

    ! Local
    integer, parameter :: out_unit = 13
    integer :: i, ios
    double precision :: x

    do i=1-mbc,mx+mbc
        x = xlower+(i-0.5)*dx
        ! Jump in bathymetry
        if (bathy_type == 1) then
            if (x < bathy_location) then
                aux(i,1) = bathy_left
            else
                aux(i,1) = bathy_right
            endif
        ! Simple shelf
        else if (bathy_type == 2) then
            if (x < x0) then
                aux(i,1) = basin_depth
            else if (x0 <= x .and. x < x1) then
                aux(i,1) = shelf_slope * (x-x0) + basin_depth
            else if (x1 <= x) then
                aux(i,1) = shelf_depth
            endif
        endif

        ! Set initial states
        if (x < init_location) then
            if (eta_left(2) > aux(i,1)) then
                aux(i,3) = eta_left(1) - eta_left(2)
                aux(i,4) = eta_left(2) - aux(i,1)
            else
                aux(i,3) = eta_left(1) - aux(i,1)
            endif
        else
            if (eta_right(2) > aux(i,1)) then
                aux(i,3) = eta_right(1) - eta_right(2)
                aux(i,4) = eta_right(2) - aux(i,1)
            else
                aux(i,3) = eta_right(1) - aux(i,1)
            endif
        endif
    enddo

    ! Calculate initial wind field
    call set_wind(maxmx,mbc,mx,xlower,dx,0.d0,aux(:,2))

    ! Write out auxillary array
    print *,"Outputting bathymetry to 'fort.aux' file."
    open(unit=out_unit, file='fort.aux', iostat=ios, action="write")
    if ( ios /= 0 ) stop "Error opening file name"

    do i=1,mx
        write(unit=out_unit, fmt="(d16.8)") aux(i,1)
    enddo

    close(out_unit)

end subroutine setaux


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc              mnpade : parder test program                          cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real fac,facx
      integer i,ix,iy,ier,j,kx,kx1,ky,ky1,mx,my,m0,m1,m2,m3,nc,
     * nkx1,nky1,nux,nuy,nx,ny
      real tx(15),ty(15),c(100),x(6),y(6),z(36),wrk(200)
      integer iwrk(20)
c  we set up the grid points for evaluating the spline derivatives.
      mx = 6
      my = 6
      do 10 i=1,6
      x(i) = (i-1)*0.2
      y(i) = x(i)
  10  continue
c  loop for different spline degrees with respect to the x-variable
      do 300 kx=3,5,2
c  the knots in the x-direction
        tx(kx+2) = 0.4
        tx(kx+3) = 0.7
        tx(kx+4) = 0.9
        kx1 = kx+1
        nx = 3+2*kx1
        j = nx
        do 20 i=1,kx1
          tx(i) = 0.
          tx(j) = 1.
          j = j-1
  20    continue
c  loop for different spline degrees with respect to the y-variable
      do 200 ky=2,3
c  the knots in the y-direction
        ty(ky+2) = 0.3
        ty(ky+3) = 0.8
        ky1 = ky+1
        ny = 2+2*ky1
        j = ny
        do 30 i=1,ky1
          ty(i) = 0.
          ty(j) = 1.
          j = j-1
  30    continue
c  we generate the b-spline coefficients for the test function x*y
        nkx1 = nx-kx1
        nky1 = ny-ky1
        do 40 i=1,nky1
          c(i) = 0.
  40    continue
        do 50 i=2,nkx1
          c((i-1)*nky1+1) = 0.
  50    continue
        fac = kx*ky
        m0 = 1
        do 70 i=2,nkx1
          m1 = m0+nky1
          facx = (tx(i+kx)-tx(i))/fac
          do 60 j=2,nky1
            m2 = m0+1
            m3 = m1+1
            c(m3) = c(m1)+c(m2)-c(m0)+facx*(ty(j+ky)-ty(j))
            m0 = m0+1
            m1 = m1+1
  60      continue
          m0 = m0+1
  70    continue
c  printing of the results
        write(6,900) kx,ky
        write(6,910)
        write(6,920) (tx(i),i=1,nx)
        write(6,930)
        write(6,920) (ty(i),i=1,ny)
        nc = nkx1*nky1
        write(6,940)
        write(6,950) (c(i),i=1,nc)
c  loop for different orders of spline derivatives
        do 100 ix=1,2
        nux = ix-1
        do 100 iy=1,2
        nuy = iy-1
c  evaluation of the spline derivative
        call parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,
     *    wrk,200,iwrk,20,ier)
        write(6,960) nux,nuy
        write(6,970) (y(i),i=1,my)
        write(6,980)
        m2 = 0
        do 90 i=1,mx
          m1 = m2+1
          m2 = m2+my
          write(6,990) x(i),(z(j),j=m1,m2)
  90    continue
 100    continue
 200    continue
 300  continue
      stop
c  format statements.
 900  format(33h0tensor product spline of degrees,2i3)
 910  format(1x,40hposition of the knots in the x-direction)
 920  format(1x,15f5.1)
 930  format(1x,40hposition of the knots in the y-direction)
 940  format(23h b-spline coefficients )
 950  format(1x,8f9.4)
 960  format(1h0,26hspline derivative of order,2i4)
 970  format(1h0,8x,1hy,4x,6(4x,f4.1))
 980  format(1h ,7x,1hx)
 990  format(6x,f4.1,5x,6f8.2)
      end


      SUBROUTINE theta_f (icoil, th0, th1, th2)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE modular_coils
      USE Vwire
      USE coils
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: i, mu, icoil
      REAL(rprec) :: theta, th0, th1, th2, t0, t1, t2
      REAL(rprec) :: rs, rc, sk, ck
!-----------------------------------------------
!
!     Computes u(s) and u', u'', from Eq. 2 in Strickler, et al
!     u(s) = theta/2*pi + SUM(rhoc*cos(m*theta)+rhos*sin(m*theta))
!     where theta=2*pi*s
!
      i = icoil
      theta = th0
      t0 = theta
      t1 = 1
      t2 = 0
      DO mu = 0, nf_rho
         rs = modular(i)%rhos(mu)
         rc = modular(i)%rhoc(mu)
         sk = SIN(mu*theta)
         ck = COS(mu*theta)
         t0 = t0 + rs*sk + rc*ck
         t1 = t1 + mu*(rs*ck - rc*sk)       !1st derivative
         t2 = t2 - mu**2*(rs*sk + rc*ck)    !2nd derivative (for curvature)
      END DO
      th0 = t0
      th1 = t1
      th2 = t2

      END SUBROUTINE theta_f


module convolution
  use, intrinsic :: iso_c_binding
  use types

  implicit none

  include 'fftw3.f03'

  type :: CONV_T
     real(kind=8), allocatable    :: A(:,:,:), B(:,:,:), conv(:,:,:)
     complex(kind=8), allocatable :: dftA(:,:,:), dftB(:,:,:), dftConv(:,:,:)
   contains
     procedure :: init_A => conv_init_A
     procedure :: init_B => conv_init_B
     procedure :: execute => conv_execute
     procedure :: free => conv_free
  end type CONV_T

  real(kind=8), parameter :: pi = 3.14159265358979d0
  private :: pi

contains
  !> Generate a 3d gaussian kernel
  !! parameters:
  !! s: the number of elements in the kernel
  !! sigma: the sigma of the kernel
  !! kernel: a 3d array containing the kernel
  subroutine kernel_gaussian3d(s, sigma, kernel)
    integer, intent(in) :: s
    real(kind=8), intent(in) :: sigma
    real(kind=8), dimension(s, s, s), intent(out) :: kernel

    integer :: i, j, k
    real(kind=8) :: sizeo2, sq_sum

    sizeo2 = s/2.

    do k = 1, s
       do j = 1, s
          do i = 1, s
             sq_sum = (i - sizeo2)**2 + (j - sizeo2)**2 + (k - sizeo2)**2
             kernel(i,j,k) = 1/(sqrt(2*pi) * sigma)**3 * exp(-sq_sum / (2*sigma**2))
          end do
       end do
    end do

  end subroutine kernel_gaussian3d

  !> Compute the fft of in, putting the result in out
  subroutine fft(in, out)
    real(kind=8), intent(inout), dimension(:,:,:) :: in
    complex(kind=8), intent(out), dimension(size(in, 1), size(in, 2),&
         & size(in, 3)) :: out
    complex(kind=8), dimension(size(in, 1), size(in, 2),&
         & size(in, 3)) :: cplx_in

    type(C_PTR) :: plan

    integer :: L, N, M

    L = size(in, 1)
    M = size(in, 2)
    N = size(in, 3)

    cplx_in = cmplx(in, 0, 8)

    ! create plan
    plan = fftw_plan_dft_3d(N, M, L, cplx_in, out, FFTW_FORWARD, FFTW_ESTIMATE)

    ! execute it
    call fftw_execute_dft(plan, cplx_in, out)

    ! delete plan
    call fftw_destroy_plan(plan)

  end subroutine fft

  subroutine ifft(in, out)
    complex(kind=8), intent(inout), dimension(:,:,:) :: in

    real(kind=8), intent(out), dimension(size(in, 1), size(in, 2), size(in, 3)) :: out

    complex(kind=8), dimension(size(in, 1), size(in, 2), size(in, 3)) :: cplx_out

    type(C_PTR) :: plan

    integer :: L, N, M

    L = size(in, 1)
    M = size(in, 2)
    N = size(in, 3)

    ! create plan
    plan = fftw_plan_dft_3d(N, M, L, in, cplx_out, FFTW_BACKWARD, FFTW_ESTIMATE)

    ! execute it
    call fftw_execute_dft(plan, in, cplx_out)

    out = real(cplx_out, 8) / (L*M*N)

    ! delete plan
    call fftw_destroy_plan(plan)

  end subroutine ifft

  !> Prepare the convolution A*B by giving A
  subroutine conv_init_A (self, A)
    real(kind=8), intent(in)  :: A(:,:,:)
    class(CONV_T), intent(inout) :: self

    if (allocated(self%A)) deallocate(self%A)
    if (allocated(self%dftA)) deallocate(self%dftA)

    allocate(self%A(size(A, 1), size(A, 2), size(A, 3)))
    allocate(self%dftA(size(A, 1), size(A, 2), size(A, 3)))
    self%A = A

    call fft(self%A, self%dftA)
  end subroutine conv_init_A

  !> Prepare the convolution A*B by giving B
  subroutine conv_init_B (self, B)
    real(kind=8), intent(in)      :: B(:,:,:)
    class(CONV_T), intent(inout) :: self

    if (allocated(self%B)) deallocate(self%B)
    if (allocated(self%dftB)) deallocate(self%dftB)

    allocate(self%B(size(B, 1), size(B, 2), size(B, 3)))
    allocate(self%dftB(size(B, 1), size(B, 2), size(B, 3)))
    self%B = B

    call fft(self%B, self%dftB)
  end subroutine conv_init_B

  !> Execute the convolution
  subroutine conv_execute(self)
    class(CONV_T), intent(inout) :: self

    integer :: L, M, N
    L = size(self%dftA, 1)
    M = size(self%dftA, 2)
    N = size(self%dftA, 3)

    if (allocated(self%conv)) deallocate(self%conv)
    if (allocated(self%dftConv)) deallocate(self%dftConv)

    allocate(self%dftConv(L, M, N))
    allocate(self%conv(L, M, N))

    call conv_prod(self%dftA, self%dftB, self%dftConv)
    call ifft(self%dftConv, self%conv)
  end subroutine conv_execute

  !> Compute the convolution product of A, B in fourier space
  subroutine conv_prod(A, B, C)
    complex(kind=8), intent(in)  :: A(:,:,:), B(:,:,:)
    complex(kind=8), intent(out) :: C(size(A, 1), size(A, 2), size(A, 3))

    integer :: i,j,k
    do k = 1, size(A, 3)
       do j = 1, size(A, 2)
          do i = 1, size(A, 1)
             ! from
             ! http://www.fftw.org/faq/section3.html#centerorigin
             ! with special care with the fact that fortran starts
             ! indexing at 1, not 0!
             C(i,j,k) = A(i,j,k) * B(i,j,k) * (-1)**(i+j+k+1)
          end do
       end do
    end do

  end subroutine conv_prod

  !! Compute the 3d histogram of data, using nbin and weights and
  !! store it into bins
  subroutine conv_hist3d(data, nbin, weights, hist, edges)
    real(kind=8), dimension(:,:), intent(in) :: data !! data(ndim, nparts)
    real(kind=8), dimension(size(data, 2)), &
         intent(in), optional            :: weights ! weights(nparts)
    integer, intent(in)                  :: nbin

    real(kind=8), dimension(nbin, nbin, nbin), intent(out)    :: hist
    real(kind=8), dimension(3, nbin+1), intent(out), optional :: edges

    real(kind=8), dimension(3) :: maxis, minis, spans

    integer :: i, j, k, part_i, ndim, nparts

    ! get the dimensions
    ndim = size(data, 1)
    nparts = size(data, 2)
    ! compute the edges
    maxis = maxval(data, 2)
    minis = minval(data, 2)
    spans = maxis - minis

    do i = 1, nbin + 1
       edges(:, i) = minis + (maxis - minis) * (i-1) / nbin
    end do
    print*, minis, maxis

    print*, nparts
    ! project the data onto the edges
    do part_i = 1, nparts
       ! get the position in the grid
       i = floor((data(1, part_i) - minis(1)) * nbin / spans(1)) + 1
       j = floor((data(2, part_i) - minis(2)) * (nbin * 1d0) / spans(2)) + 1
       k = floor((data(3, part_i) - minis(3)) * nbin / spans(3)) + 1

       ! because of rounding errors, the maxima aren't well found,
       ! fix that
       if (data(1, part_i) == maxis(1)) i = nbin
       if (data(2, part_i) == maxis(2)) j = nbin
       if (data(3, part_i) == maxis(3)) k = nbin

       ! print*, i,j,k
       ! TODO: linear approximation of density
       ! increment the histogram
       if ((i <= 0) .or. (i > nbin) .or. (j <= 0) .or. (j > nbin) .or.&
            (k <= 0) .or. (k > nbin)) then
          print*, 'Dafuk ?!'
          print*, (data(:, part_i) - maxis) == 0
          print*, i, j, k
       end if

       if (present(weights)) then
          hist(i, j, k) = hist(i, j, k) + weights(part_i)
       else
          hist(i, j, k) = hist(i, j, k) + 1
       end if
    end do

    print*, nparts, ndim
  end subroutine conv_hist3d

  !! Estimate the density
  subroutine conv_density(data, nbin, dens, edges)
    real(kind=8), dimension(:,:), intent(in) :: data !! data(ndim, nparts)
    integer, intent(in)                      :: nbin

    real(kind=8), dimension(nbin, nbin, nbin), intent(out)   :: dens
    real(kind=8), dimension(3, nbin+1), intent(out), optional:: edges

    real(kind=8), dimension(3) :: maxis, minis, spans

    integer :: i, j, k, part_i, ndim, nparts, i0, j0, k0, imax, jmax, kmax, imin, jmin, kmin
    real(kind=8) :: ri, rj, rk

    ! get the dimensions
    ndim = size(data, 1)
    nparts = size(data, 2)
    ! compute the bins
    maxis = maxval(data, 2)
    minis = minval(data, 2)

    spans = (maxis - minis)

    do i = 1, nbin + 1
       edges(:, i) = minis + spans * (i-1) / nbin
    end do

    ! project the data onto the bins
    do part_i = 1, nparts
       ! get the position in the grid
       ri = (data(1, part_i) - minis(1)) * nbin / spans(1) + 0.5
       rj = (data(2, part_i) - minis(2)) * nbin / spans(2) + 0.5
       rk = (data(3, part_i) - minis(3)) * nbin / spans(3) + 0.5

       ! the max and min are actually only half in leftmost/rightmost bin
       ! so the min has ri =  0.5
       ! and the max has ri = nbin + 0.5

       i0 = floor(ri)
       j0 = floor(rj)
       k0 = floor(rk)

       imin = max(1, i0)
       jmin = max(1, j0)
       kmin = max(1, k0)

       imax = min(nbin, i0 + 1)
       jmax = min(nbin, j0 + 1)
       kmax = min(nbin, k0 + 1)

       do k = kmin, kmax
          do j = jmin, jmax
             do i = imin, imax
                ! add the proportion of the particle in the box
                dens(i, j, k) = dens(i, j, k) + abs((ri - i)*(rj - j)*(rk - k))
             end do
          end do
       end do
    end do

    ! Convert the number density into a mass density (assuming uniform mass)
    ! TODO: don't assume uniform mass
    dens = dens * nbin**3 / product(maxis-minis)

  end subroutine conv_density

  subroutine conv_free(self)
    class(CONV_T), intent(inout) :: self
    if (allocated(self%A))    deallocate(self%A)
    if (allocated(self%B))    deallocate(self%B)
    if (allocated(self%conv)) deallocate(self%conv)

    if (allocated(self%dftA))    deallocate(self%dftA)
    if (allocated(self%dftB))    deallocate(self%dftB)
    if (allocated(self%dftConv)) deallocate(self%dftConv)

  end subroutine conv_free

end module convolution


! BUCKLING_CPANEL_BARDELL program
!
! Buckling of cylindrical panels.
!
! The required inputs that should be given are described below.
!
! Run control
! -----------
! NUM : integer
!   Number of returned eigenvalues
!
! M : integer
!   Number of terms along x
!
! N : integer
!   Number of terms along x
!
! Geometry
! --------
! a : float
!   The panel length (dimension along x)
! b : float
!   The panel circumferential width (dimension along y)
! r : float
!   The panel radius. (Set a high value to simulate a plate)
! t : float, optional (used with ISOTROPIC flag)
!   Panel thickness
!
! Isotropic Material Properties
! -----------------------------
! ISOTROPIC : flag
!   If present in the input, matrix ABD will be calculated based on
!   E, nu and t.
! E : float
!   Elastic modulus
! nu : float
!   Poisson's ratio
!
! Applied Loads
! -------------
! Nxx : float
!   Nxx stress
! Nyy : float
!   Nyy stress
! Nxy : float
!   Nxy stress
!
! Laminate Constitutive Varibles (matrix ABD)
! -------------------------------------------
! ONLY used if ISOTROPIC = FALSE
!
! A11 : float
!   Membrane stiffness along x
! A12 : float
!   Membrane stiffness
! A16 : float
!   Shear-extension coupling
! A22 : float
!   Membrane stiffness along y
! A26 : float
!   Shear-extension coupling
! A66 : float
!   Membrane Shear stiffness
! B11 : float
!   Bending-extension coupling
! B12 : float
!   Bending-extension coupling
! B16 : float
!   Bending-extension coupling
! B22 : float
!   Bending-extension coupling
! B26 : float
!   Bending-extension coupling
! B66 : float
!   Bending-extension coupling
! D11 : float
!   Bending stiffness
! D12 : float
!   Bending stiffness
! D16 : float
!   Bending-twist stiffness
! D22 : float
!   Bending stiffness
! D26 : float
!   Bending-twist stiffness
! D66 : float
!   Twist (torsion) stiffness
!
! Boundary conditions
! -------------------
! u1tx : float
!   If 1. the edge at x=0 can translate along u
!   If 0. the edge at x=0 cannot translate along u
! u1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along u
! u2tx : float
!   If 1. the edge at x=a can translate along u
!   If 0. the edge at x=a cannot translate along u
! u2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along u
! u1ty : float
!   If 1. the edge at y=0 can translate along u
!   If 0. the edge at y=0 cannot translate along u
! u1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along u
! u2ty : float
!   If 1. the edge at y=b can translate along u
!   If 0. the edge at y=b cannot translate along u
! u2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along u
! v1tx : float
!   If 1. the edge at x=0 can translate along v
!   If 0. the edge at x=0 cannot translate along v
! v1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along v
! v2tx : float
!   If 1. the edge at x=a can translate along v
!   If 0. the edge at x=a cannot translate along v
! v2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along v
! v1ty : float
!   If 1. the edge at y=0 can translate along v
!   If 0. the edge at y=0 cannot translate along v
! v1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along v
! v2ty : float
!   If 1. the edge at y=b can translate along v
!   If 0. the edge at y=b cannot translate along v
! v2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along v
! w1tx : float
!   If 1. the edge at x=0 can translate along w
!   If 0. the edge at x=0 cannot translate along w
! w1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along w
! w2tx : float
!   If 1. the edge at x=a can translate along w
!   If 0. the edge at x=a cannot translate along w
! w2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along w
! w1ty : float
!   If 1. the edge at y=0 can translate along w
!   If 0. the edge at y=0 cannot translate along w
! w1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along w
! w2ty : float
!   If 1. the edge at y=b can translate along w
!   If 0. the edge at y=b cannot translate along w
! w2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along w

INCLUDE 'calc_matrices.f90'
INCLUDE '../bardell.f90'

PROGRAM BUCKLING_CPANEL_BARDELL
    IMPLICIT NONE
    INTERFACE
        SUBROUTINE integral_ff(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_ffxi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_ffxixi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxifxi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxifxixi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE integral_fxixifxixi(i, j, x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r, out)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: i, j
            REAL*8, INTENT(IN) :: x1t, x1r, x2t, x2r, y1t, y1r, y2t, y2r
            REAL*8, INTENT(OUT) :: out
        END SUBROUTINE
        SUBROUTINE CALC_K0(M, N, K, a, b, r, &
                           A11, A12, A16, A22, A26, A66, B11, B12, B16, B22, B26, B66, D11, D12, D16, D22, D26, D66, &
                           u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                           v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry, &
                           w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: M, N
            REAL*8, INTENT(IN) :: a, b, r
            REAL*8, INTENT(IN) :: A11, A12, A16, A22, A26, A66
            REAL*8, INTENT(IN) :: B11, B12, B16, B22, B26, B66
            REAL*8, INTENT(IN) :: D11, D12, D16, D22, D26, D66
            REAL*8, INTENT(IN) :: u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
            REAL*8, INTENT(IN) :: v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry
            REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
            REAL*8, INTENT(OUT) :: K(3*M*N, 3*M*N)
        END SUBROUTINE
        SUBROUTINE CALC_KG0(M, N, K, a, b, Nxx, Nyy, Nxy, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: M, N
            REAL*8, INTENT(IN) :: a, b, Nxx, Nyy, Nxy
            REAL*8, INTENT(IN) :: w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
            REAL*8, INTENT(OUT) :: K(3*M*N, 3*M*N)
        END SUBROUTINE
    END INTERFACE

    ! inputs
    CHARACTER BALANC, JOBVL, JOBVR, SENSE
    INTEGER NT, nulls, NUM, M, N
    REAL*8, ALLOCATABLE :: K0(:, :), KG0(:, :), K02(:, :), KG02(:, :)
    REAL*8 A11, A12, A16, A22, A26, A66
    REAL*8 B11, B12, B16, B22, B26, B66
    REAL*8 D11, D12, D16, D22, D26, D66
    REAL*8 u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
    REAL*8 v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry
    REAL*8 w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    REAL*8 a, b, r, Nxx, Nyy, Nxy
    INTEGER LDA, LDB, LDZ

    ! workspace
    CHARACTER (LEN=100) :: line
    CHARACTER (LEN=400) :: input_file, output_file
    INTEGER stat, i, j, id, jd
    INTEGER LWORK
    INTEGER, ALLOCATABLE :: IWORK(:)
    REAL*8, ALLOCATABLE :: WORK(:)
    REAL*8 E11, nu, G12, t, NULLTOL
    CHARACTER (LEN=5) :: ISOTROPIC
    INTEGER, ALLOCATABLE :: TMP(:)

    ! outputs
    INTEGER Mout, INFO
    INTEGER, ALLOCATABLE :: IFAIL(:)
    REAL*8, ALLOCATABLE :: EIGVALS(:), EIGVECS(:, :)

    BALANC = 'N'
    JOBVL = 'N'
    JOBVR = 'N'
    SENSE = 'N'

    NUM = 10
    M = 15
    N = 15

    ! Tolerance to consider a zero in K0 and KG0
    NULLTOL = 1.e-15

    ISOTROPIC = "FALSE"

    ! Default boundary conditions (simply supported)
    u1tx = 0.
    u1rx = 1.
    u2tx = 0.
    u2rx = 1.
    u1ty = 0.
    u1ry = 1.
    u2ty = 0.
    u2ry = 1.
    v1tx = 0.
    v1rx = 1.
    v2tx = 0.
    v2rx = 1.
    v1ty = 0.
    v1ry = 1.
    v2ty = 0.
    v2ry = 1.
    w1tx = 0.
    w1rx = 1.
    w2tx = 0.
    w2rx = 1.
    w1ty = 0.
    w1ry = 1.
    w2ty = 0.
    w2ry = 1.

    IF (COMMAND_ARGUMENT_COUNT() .NE. 2) THEN
        STOP "This program should be called as: 'buckling_cpanel_bardell input output'"
    ELSE
        CALL GET_COMMAND_ARGUMENT(1, VALUE=input_file, STATUS=stat)
        CALL GET_COMMAND_ARGUMENT(2, VALUE=output_file, STATUS=stat)
    END IF

    OPEN(10, FILE=input_file)
    DO
        READ(10, *) line
        IF (TRIM(line) == "NUM") READ(10, *) NUM
        IF (TRIM(line) == "M") READ(10, *) M
        IF (TRIM(line) == "N") READ(10, *) N
        IF (TRIM(line) == "a") READ(10, *) a
        IF (TRIM(line) == "b") READ(10, *) b
        IF (TRIM(line) == "r") READ(10, *) r
        IF (TRIM(line) == "Nxx") READ(10, *) Nxx
        IF (TRIM(line) == "Nyy") READ(10, *) Nyy
        IF (TRIM(line) == "Nxy") READ(10, *) Nxy

        IF (TRIM(line) == "ISOTROPIC") ISOTROPIC = "TRUE"
        IF (TRIM(line) == "E") READ(10, *) E11
        IF (TRIM(line) == "nu") READ(10, *) nu
        IF (TRIM(line) == "t") READ(10, *) t

        IF (TRIM(line) == "A11") READ(10, *) A11
        IF (TRIM(line) == "A12") READ(10, *) A12
        IF (TRIM(line) == "A16") READ(10, *) A16
        IF (TRIM(line) == "A22") READ(10, *) A22
        IF (TRIM(line) == "A26") READ(10, *) A26
        IF (TRIM(line) == "A66") READ(10, *) A66

        IF (TRIM(line) == "B11") READ(10, *) B11
        IF (TRIM(line) == "B12") READ(10, *) B12
        IF (TRIM(line) == "B16") READ(10, *) B16
        IF (TRIM(line) == "B22") READ(10, *) B22
        IF (TRIM(line) == "B26") READ(10, *) B26
        IF (TRIM(line) == "B66") READ(10, *) B66

        IF (TRIM(line) == "D11") READ(10, *) D11
        IF (TRIM(line) == "D12") READ(10, *) D12
        IF (TRIM(line) == "D16") READ(10, *) D16
        IF (TRIM(line) == "D22") READ(10, *) D22
        IF (TRIM(line) == "D26") READ(10, *) D26
        IF (TRIM(line) == "D66") READ(10, *) D66

        IF (TRIM(line) == "u1tx") READ(10, *) u1tx
        IF (TRIM(line) == "u1rx") READ(10, *) u1rx
        IF (TRIM(line) == "u2tx") READ(10, *) u2tx
        IF (TRIM(line) == "u2rx") READ(10, *) u2rx
        IF (TRIM(line) == "u1ty") READ(10, *) u1ty
        IF (TRIM(line) == "u1ry") READ(10, *) u1ry
        IF (TRIM(line) == "u2ty") READ(10, *) u2ty
        IF (TRIM(line) == "u2ry") READ(10, *) u2ry

        IF (TRIM(line) == "v1tx") READ(10, *) v1tx
        IF (TRIM(line) == "v1rx") READ(10, *) v1rx
        IF (TRIM(line) == "v2tx") READ(10, *) v2tx
        IF (TRIM(line) == "v2rx") READ(10, *) v2rx
        IF (TRIM(line) == "v1ty") READ(10, *) v1ty
        IF (TRIM(line) == "v1ry") READ(10, *) v1ry
        IF (TRIM(line) == "v2ty") READ(10, *) v2ty
        IF (TRIM(line) == "v2ry") READ(10, *) v2ry

        IF (TRIM(line) == "w1tx") READ(10, *) w1tx
        IF (TRIM(line) == "w1rx") READ(10, *) w1rx
        IF (TRIM(line) == "w2tx") READ(10, *) w2tx
        IF (TRIM(line) == "w2rx") READ(10, *) w2rx
        IF (TRIM(line) == "w1ty") READ(10, *) w1ty
        IF (TRIM(line) == "w1ry") READ(10, *) w1ry
        IF (TRIM(line) == "w2ty") READ(10, *) w2ty
        IF (TRIM(line) == "w2ry") READ(10, *) w2ry
        IF (TRIM(line) == "END") EXIT
    END DO

    NT = 3*M*N

    ! Calculating ABD

    IF (ISOTROPIC == "TRUE") THEN
        G12 = E11/(2*(1 + nu))

        A11 = E11*t/(1 - nu**2)
        A12 = nu*E11*t/(1 - nu**2)
        A16 = 0
        A22 = E11*t/(1 - nu**2)
        A26 = 0
        A66 = G12*t

        B11 = 0
        B12 = 0
        B16 = 0
        B22 = 0
        B26 = 0
        B66 = 0

        D11 = E11*t**3/(12*(1 - nu**2))
        D12 = nu*E11*t**3/(12*(1 - nu**2))
        D16 = 0
        D22 = E11*t**3/(12*(1 - nu**2))
        D26 = 0
        D66 = G12*t**3/12
    END IF

    ! allocating arrays
    ALLOCATE(K0(NT, NT))
    ALLOCATE(KG0(NT, NT))

    ! constitutive stiffness matrix
    CALL CALC_K0(M, N, K0, a, b, r, &
                 A11, A12, A16, A22, A26, A66, B11, B12, B16, B22, B26, B66, D11, D12, D16, D22, D26, D66, &
                 u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                 v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry, &
                 w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)

    ! geometric stiffness matrix
    CALL CALC_KG0(M, N, KG0, a, b, Nxx, Nyy, Nxy, w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)

    ! removing null rows and columns
    ALLOCATE(TMP(NT))
    TMP = 0
    WHERE (ABS(SUM(K0, DIM=1)) <= NULLTOL) TMP = 1
    nulls = SUM(TMP)
    WRITE(*, *) "Number of removed cols:", nulls

    ALLOCATE(K02(NT-nulls, NT-nulls))
    ALLOCATE(KG02(NT-nulls, NT-nulls))

    jd = 0
    DO j=1, NT
        IF (TMP(j) == 1) THEN
            jd = jd+1
            CYCLE
        END IF
        id = 0
        DO i=1, NT
            IF (TMP(i) == 1) THEN
                id = id+1
                CYCLE
            END IF
            K02(i-id, j-jd) = K0(i, j)
            KG02(i-id, j-jd) = KG0(i, j)
        END DO
    END DO
    DEALLOCATE(TMP)

    ! allocating arrays
    ALLOCATE(IWORK((NT-nulls)*25))

    ! allocating output arrays
    ALLOCATE(EIGVALS(NT-nulls))
    ALLOCATE(EIGVECS(NT-nulls, NT-nulls))
    ALLOCATE(IFAIL(NT-nulls))

    LDA = NT-nulls
    LDB = NT-nulls
    LDZ = NT-nulls

    WRITE(*, *) 'Eigenvalue analysis started...'

    ! signature of eigenvalue solver used:
    !
    ! CALL DSYGVX(ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, &
    !             VL, VU, IL, IU, ABSTOL, Mout, W, Z, LDZ, &
    !             WORK, LWORK, IWORK, IFAIL, INFO)

    EIGVALS = EIGVALS*0

    ! Workspace query
    LWORK = -1
    ALLOCATE(WORK(10))
    CALL DSYGVX(1, "N", "I", "U", (NT-nulls), KG02, LDB, K02, LDA, &
                -1.D10, 0, 1, NUM, 0., Mout, EIGVALS, EIGVECS, LDZ, &
                WORK, LWORK, IWORK, IFAIL, INFO)
    LWORK = WORK(1)
    DEALLOCATE(WORK)
    ! Eigensolver query
    ALLOCATE(WORK(LWORK))
    CALL DSYGVX(1, "N", "I", "U", (NT-nulls), KG02, LDB, K02, LDA, &
                -1.D10, 0, 1, NUM, 0., Mout, EIGVALS, EIGVECS, LDZ, &
                WORK, LWORK, IWORK, IFAIL, INFO)
    DEALLOCATE(WORK)

    WHERE(EIGVALS /= 0) EIGVALS = -1/EIGVALS

    WRITE(*, *) "Eigenvalue analysis completed!"

    ! Writing eigenvalues
    OPEN(11, FILE=output_file, ACTION="WRITE", STATUS="REPLACE")
    DO i=1, NUM
        WRITE(11, *) EIGVALS(i)
    END DO

    WRITE(*, *) 'EIGVALS:'
    WRITE(*, *) '    1st) ', EIGVALS(1)
    WRITE(*, *) '    2nd) ', EIGVALS(2)
    WRITE(*, *) '    3rd) ', EIGVALS(3)
    WRITE(*, *) '    4th) ', EIGVALS(4)
    WRITE(*, *) '    5th) ', EIGVALS(5)
    IF (INFO /= 0) THEN
        WRITE(*, *) 'Mout', Mout
        WRITE(*, *) 'INFO', NT-nulls, INFO
        !WRITE(*, *) 'IFAIL', IFAIL
        WRITE(*, *) 'MIN(K02), MAX(K02)', MINVAL(K02), MAXVAL(K02)
        WRITE(*, *) 'SUM(K02), SUM(KG02)', SUM(K02), SUM(KG02)
    END IF

    DEALLOCATE(K0)
    DEALLOCATE(KG0)
    DEALLOCATE(K02)
    DEALLOCATE(KG02)
    DEALLOCATE(IWORK)
    DEALLOCATE(EIGVALS)
    DEALLOCATE(EIGVECS)
    DEALLOCATE(IFAIL)

END PROGRAM BUCKLING_CPANEL_BARDELL


PROGRAM main

  IMPLICIT NONE

  REAL :: a, b, c, root1, root2
  REAL :: determinant

  PRINT*, "Enter coefficients for polynomial a x^2 + b x + c: "

  READ(*, *) a, b, c

  determinant = b**2 - 4.0 * a * c

  ! NOTE: we can't decide if the polynomial has only ONE root because
  ! we can't be sure if the determinant is exactly 0 or just too small
  ! to store in our real.

  IF(determinant < 0) THEN
    PRINT*, "The polynomial has no real roots"
  ELSE
    root1 = -b + sqrt(determinant)
    root2 = -b - sqrt(determinant)
    PRINT*, "The roots are ", root1, " and ", root2
  END IF

END PROGRAM


           program demo_product
           implicit none
             integer :: x(5) = [ 1, 2, 3, 4 ,5 ]
             print *, product(x)                    ! all elements, product = 120
             print *, product(x, mask=mod(x, 2)==1) ! odd elements, product = 15
           end program demo_product