!*****************************************************************************************
!> 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
    end type 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
        end subroutine destroy_func
    end interface

    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
    end type 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
    end type 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
    end type 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
    end type 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
    end type 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
    end type linear_interp_6d

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

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

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

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

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

    type,extends(linear_interp_6d),public :: nearest_interp_6d
        !! Class for 6d nearest neighbor interpolation.
        contains
        procedure,public :: evaluate => nearest_6d
    end type 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()

    end subroutine 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()

    end subroutine 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()

    end subroutine 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()

    end subroutine 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()

    end subroutine 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()

    end subroutine 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.

    end subroutine 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.

    end subroutine 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.

    end subroutine 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.

    end subroutine 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.

    end subroutine 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.

    end subroutine 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.
        end if
    end if

    end subroutine 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.
        end if
    end if

    end subroutine 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.
        end if
    end if

    end subroutine 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.
        end if
    end if

    end subroutine 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.
        end if
    end if

    end subroutine 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.
        end if
    end if

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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
        end if
    end if

    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
        end if
        if ( n<=1 ) then
            mflag = -1
            ileft = 1
            iright= 2
            if (present(inearest)) inearest = 1
            return
        end if
        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
                end if
                ihi = n
            elseif ( x>=xt(ihi) ) then
                istep = istep*2
                cycle
            endif
            exit
        end do

    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
                end if
            end if
            return
        end if
        ! 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
                end if
            elseif ( x<xt(ilo) ) then
                istep = istep*2
                cycle
            endif
            exit
        end do

    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
                end if
            end if
            return
        end if
        ! note. it is assumed that imid = ilo in case ihi = ilo+1
        if ( x<xt(imid) ) then
            ihi = imid
        else
            ilo = imid
        endif
    end do

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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

    end if

    end subroutine 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
        end if
    end do

    end function 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
                    end do
                    do
                        i = i + 1
                        if ( dx(i)>=dmnmx ) exit
                    end do
                    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
                end do
                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

        end do

    end if

    end subroutine 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
        end select
    end if

    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
            end if
        end do

        end subroutine check

    end subroutine check_inputs
!*****************************************************************************************

!*****************************************************************************************
    end module linear_interpolation_module
!*****************************************************************************************


      SUBROUTINE CNMN04 (II,XBAR,EPS,X1,Y1,SLOPE,X2,Y2,X3,Y3,X4,Y4)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C     ROUTINE TO FIND FIRST XBAR.GE.EPS CORRESPONDING TO A MINIMUM
C     OF A ONE-DIMENSIONAL REAL FUNCTION BY POLYNOMIEL INTERPOLATION.
C     BY G. N. VANDERPLAATS                          APRIL, 1972.
C     NASA-AMES RESEARCH CENTER,  MOFFETT FIELD, CALIF.
C
C     II = CALCULATION CONTROL.
C          1:  2-POINT QUADRATIC INTERPOLATION, GIVEN X1, Y1, SLOPE,
C              X2 AND Y2.
C          2:  3-POINT QUADRATIC INTERPOLATION, GIVEN X1, Y1, X2, Y2,
C              X3 AND Y3.
C          3:  3-POINT CUBIC INTERPOLATION, GIVEN X1, Y1, SLOPE, X2, Y2,
C              X3 AND Y3.
C          4:  4-POINT CUBIC INTERPOLATION, GIVEN X1, Y1, X2, Y2, X3,
C              Y3, X4 AND Y4.
C     EPS MAY BE NEGATIVE.
C     IF REQUIRED MINIMUM ON Y DOES NOT EXITS, OR THE FUNCTION IS
C     ILL-CONDITIONED, XBAR = EPS-1.0 WILL BE RETURNED AS AN ERROR
C     INDICATOR.
C     IF DESIRED INTERPOLATION IS ILL-CONDITIONED, A LOWER ORDER
C     INTERPOLATION, CONSISTANT WITH INPUT DATA, WILL BE ATTEMPTED,
C     AND II WILL BE CHANGED ACCORDINGLY.
      XBAR1=EPS-1.
      XBAR=XBAR1
      X21=X2-X1
      IF (ABS(X21).LT.1.0E-20) RETURN
      NSLOP=MOD(II,2)
      GO TO (10,20,40,50),II
10    CONTINUE
C     ------------------------------------------------------------------
C                 II=1: 2-POINT QUADRATIC INTERPOLATION
C     ------------------------------------------------------------------
      II=1
      DX=X1-X2
      IF (ABS(DX).LT.1.0E-20) RETURN
      AA=(SLOPE+(Y2-Y1)/DX)/DX
      IF (AA.LT.1.0E-20) RETURN
      BB=SLOPE-2.*AA*X1
      XBAR=-.5*BB/AA
      IF (XBAR.LT.EPS) XBAR=XBAR1
      RETURN
20    CONTINUE
C     ------------------------------------------------------------------
C                 II=2: 3-POINT QUADRATIC INTERPOLATION
C     ------------------------------------------------------------------
      II=2
      X21=X2-X1
      X31=X3-X1
      X32=X3-X2
      QQ=X21*X31*X32
      IF (ABS(QQ).LT.1.0E-20) RETURN
      AA=(Y1*X32-Y2*X31+Y3*X21)/QQ
      IF (AA.LT.1.0E-20) GO TO 30
      BB=(Y2-Y1)/X21-AA*(X1+X2)
      XBAR=-.5*BB/AA
      IF (XBAR.LT.EPS) XBAR=XBAR1
      RETURN
30    CONTINUE
      IF (NSLOP.EQ.0) RETURN
      GO TO 10
40    CONTINUE
C     ------------------------------------------------------------------
C                   II=3: 3-POINT CUBIC INTERPOLATION
C     ------------------------------------------------------------------
      II=3
      X21=X2-X1
      X31=X3-X1
      X32=X3-X2
      QQ=X21*X31*X32
      IF (ABS(QQ).LT.1.0E-20) RETURN
      X11=X1*X1
      DNOM=X2*X2*X31-X11*X32-X3*X3*X21
      IF (ABS(DNOM).LT.1.0E-20) GO TO 20
      AA=((X31*X31*(Y2-Y1)-X21*X21*(Y3-Y1))/(X31*X21)-SLOPE*X32)/DNOM
      IF (ABS(AA).LT.1.0E-20) GO TO 20
      BB=((Y2-Y1)/X21-SLOPE-AA*(X2*X2+X1*X2-2.*X11))/X21
      CC=SLOPE-3.*AA*X11-2.*BB*X1
      BAC=BB*BB-3.*AA*CC
      IF (BAC.LT.0.) GO TO 20
      BAC=SQRT(BAC)
      XBAR=(BAC-BB)/(3.*AA)
      IF (XBAR.LT.EPS) XBAR=EPS
      RETURN
50    CONTINUE
C     ------------------------------------------------------------------
C                    II=4: 4-POINT CUBIC INTERPOLATION
C     ------------------------------------------------------------------
      X21=X2-X1
      X31=X3-X1
      X41=X4-X1
      X32=X3-X2
      X42=X4-X2
      X11=X1*X1
      X22=X2*X2
      X33=X3*X3
      X44=X4*X4
      X111=X1*X11
      X222=X2*X22
      Q2=X31*X21*X32
      IF (ABS(Q2).LT.1.0E-30) RETURN
      Q1=X111*X32-X222*X31+X3*X33*X21
      Q4=X111*X42-X222*X41+X4*X44*X21
      Q5=X41*X21*X42
      DNOM=Q2*Q4-Q1*Q5
      IF (ABS(DNOM).LT.1.0E-30) GO TO 60
      Q3=Y3*X21-Y2*X31+Y1*X32
      Q6=Y4*X21-Y2*X41+Y1*X42
      AA=(Q2*Q6-Q3*Q5)/DNOM
      BB=(Q3-Q1*AA)/Q2
      CC=(Y2-Y1-AA*(X222-X111))/X21-BB*(X1+X2)
      BAC=BB*BB-3.*AA*CC
      IF (ABS(AA).LT.1.0E-20.OR.BAC.LT.0.) GO TO 60
      BAC=SQRT(BAC)
      XBAR=(BAC-BB)/(3.*AA)
      IF (XBAR.LT.EPS) XBAR=XBAR1
      RETURN
60    CONTINUE
      IF (NSLOP.EQ.1) GO TO 40
      GO TO 20
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! FEAST Expert Driver - Dense Storage
!!!!!!! solving Ax=ex with A complex-symmetric (non-Hermitian)
!!!!!!! James Kestyn, Eric Polizzi 2015
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program pdriver

  implicit none
include 'mpif.h'
!!!!!!!!!!!!!!!!! Feast declaration variable
  integer,dimension(64) :: feastparam
  integer :: loop
  character(len=1) :: UPLO='F' ! 'L' or 'U' also fine

!!!!!!!!!!!!!!!!! Matrix declaration variable
  character(len=100) :: name
  integer :: n,nnz
  complex(kind=kind(1.0d0)),dimension(:,:),allocatable :: A,B

!!!!!!!!!!!!!!!!! Contour
  integer :: ccN
  complex(kind=kind(1.0d0)),dimension(:),allocatable :: Zne, Wne, Zedge
  integer, dimension(:), allocatable :: Nedge, Tedge

!!!!!!!!!!!!!!!!! FEAST
  integer :: M0,M,info
  double precision :: r,epsout
  complex(kind=kind(1.0d0)) :: Emid
  complex(kind=kind(1.0d0)),dimension(:,:),allocatable :: XR ! eigenvectors
  complex(kind=kind(1.0d0)),dimension(:),allocatable :: E ! eigenvalues
  double precision,dimension(:),allocatable :: resr ! residual

!!!!!!!!!!!!!!!!! Others
  integer :: t1,t2,tim
  integer :: i,j,k
  double precision :: rea,img
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MPI!!!!!!!!!!!!!!!!!!!!
integer :: code,rank,nb_procs
  call MPI_INIT(code)
  call MPI_COMM_SIZE(MPI_COMM_WORLD,nb_procs,code)
  call MPI_COMM_RANK(MPI_COMM_WORLD,rank,code)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!Read Coordinate format and convert to dense format
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  name='../../system4'

  open(10,file=trim(name),status='old')
  read(10,*) n,nnz
  allocate(A(1:n,1:n))
  A=0.0d0
  do k=1,nnz
     read(10,*) i,j,rea,img
     A(i,j)=rea*(1.0d0,0.0d0)+img*(0.0d0,1.0d0)
  enddo
  close(10)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!! INFORMATION ABOUT MATRIX !!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  if(rank ==0) print *,'dense matrix -system4- size',n

  call system_clock(t1,tim)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!! FEAST in dense format !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call feastinit(feastparam)
  feastparam(1)=1
  M0=50 !! M0>=M

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Create Custom Contour

  ccN = 3     !! number of pieces that make up contour
  allocate(Zedge(1:ccN))
  allocate(Nedge(1:ccN))
  allocate(Tedge(1:ccN))

  !!! Example contour - triangle
  Zedge = (/(0.10d0,0.410d0),(4.2d0,0.41d0),(4.2d0,-8.3d0)/)
  Tedge(:) = (/0,0,0/)
  Nedge(:) = (/6,6,18/)

  !! Note: user must specify total # of contour points and edit feastparam(8)
  feastparam(8) = sum(Nedge(1:ccN))
  allocate(Zne(1:feastparam(8))) !! Contains the complex valued contour points
  allocate(Wne(1:feastparam(8))) !! Contains the complex valued integrations weights

  !! Fill Zne/Wne
  print *, 'Enter FEAST CC'
  call zfeast_customcontour(feastparam(8),ccN,Nedge,Tedge,Zedge,Zne,Wne)

if(rank==0)then
  print *,'---- Printing Countour ----'
  do i=1,feastparam(8)
     write(*,*)i,dble(Zne(i)),aimag(Zne(i))
  enddo
endif

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!! ALLOCATE VARIABLE
  allocate(E(1:M0))     ! Eigenvalue
  allocate(XR(1:n,1:M0)) ! Right Eigenvectors ( XL = CONJG(XR) )
  allocate(resr(1:M0))   ! Residual (if needed)

!!!!!!!!!!!!  FEAST
  print *, 'Enter FEAST',rank
  call zfeast_syevx(UPLO,N,A,N,feastparam,epsout,loop,Emid,r,M0,E,XR,M,resr,info,Zne,Wne)

!!!!!!!!!! POST-PROCESSING !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  call system_clock(t2,tim)
  if(rank==0)print *,'FEAST OUTPUT INFO',info
  if (info==0 .and. rank==0) then
     print *,'*************************************************'
     print *,'************** REPORT ***************************'
     print *,'*************************************************'
     print *,'SIMULATION TIME',(t2-t1)*1.0d0/tim
     print *,'# mode found/subspace',M,M0
     print *,'# iterations',loop
     print *,'TRACE',sum(E(1:M))
     print *,'Relative error on the Trace',epsout
     print *,'Eigenvalues/Residuals'
     do i=1,M
        print *,i,dble(E(i)),aimag(E(i)),resr(i)
     enddo
  endif

  call MPI_FINALIZE(code)

end program pdriver


program problem37
  use euler
  implicit none
  integer, parameter :: limit=11
  integer            :: count=0,answer=0
  integer*8          :: i

  i=11
  do while(count<limit)
     if (left_prime(i) .and. right_prime(i)) then
        print *, i
        count=count+1
        answer=answer+i
     end if
     i=i+2
  end do

  print *, answer

contains

  pure function left_prime(n)
    implicit none
    integer*8, intent(in) :: n
    integer*8             :: temp
    logical               :: left_prime

    left_prime=.true.
    temp=n
    do while(temp>0)
       if (.not. is_prime(temp)) then
          left_prime=.false.
          exit
       end if
       temp=mod(temp,10**(number_length(temp)-1))
    end do

  end function left_prime

  pure function right_prime(n)
    implicit none
    integer*8, intent(in) :: n
    integer*8             :: temp
    logical               :: right_prime

    right_prime=.true.
    temp=n
    do while(temp>0)
       if (.not. is_prime(temp)) then
          right_prime=.false.
          exit
       end if
       temp=temp/10
    end do

  end function right_prime

end program problem37


! The  KISS (Keep It Simple Stupid) random number generator. Combines:
! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
! (2) A 3-shift shift-register generator, period 2^32-1,
! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
!  Overall period>2^123;
!
      FUNCTION random()
      IMPLICIT NONE
      INTEGER(kind=4) :: kiss,x,y,z,w
      REAL(kind=8) :: random
	COMMON /kisscom/x,y,z,w
C
      x = 69069*x + 1327217885
      y = IEOR(y,ISHFT(y,13))
      y = IEOR(y,ISHFT(y,-17))
      y = IEOR(y,ISHFT(y,5))
      z = 18000*IAND(z,65535) + ISHFT(z,-16)
      w = 30903*IAND(w,65535) + ISHFT(w,-16)
      kiss = x + y + ISHFT(z,16) + w
      random = (DBLE(kiss) + 2147483648.d0)/4294967296.d0
      RETURN
	END
!-------------------------------
      SUBROUTINE rand_init(seed)
!-------------------------------
      IMPLICIT NONE
      INTEGER,INTENT(IN) :: seed
      INTEGER,PARAMETER :: init_x = 123456789
      INTEGER,PARAMETER :: init_y = 362436069
      INTEGER,PARAMETER :: init_z = 521288629
      INTEGER,PARAMETER :: init_w = 916191069
      REAL(kind=4) :: x,y,z,w
	COMMON /kisscom/x,y,z,w
c
      x = init_x + seed
      y = init_y + seed
      z = init_z + seed
      w = init_w + seed

      END SUBROUTINE
c
c     Uncomment the following section to test the random number generator
c     gfortran random.f ; for mpi processes, use mpif90 random.f
c     ./a.out ; for mpi process, use mpirun -np 4 ./a.out
c      PROGRAM main
c	IMPLICIT NONE
c      INCLUDE "mpif.h"
c	INTEGER :: i,seed
c      INTEGER :: myrank,ierr,nprocs
c	REAL(kind=8) :: rand,rand2,random
c      CHARACTER(LEN=100):: fo_name2
c
c      CALL MPI_INIT(IERR)
c      CALL MPI_COMM_SIZE(MPI_COMM_WORLD,NPROCS,IERR)
c      CALL MPI_COMM_RANK(MPI_COMM_WORLD,MYRANK,IERR)
c	seed = 123456789*(1 + myrank)
c 	CALL rand_init(seed)
c	WRITE(*,*) myrank, seed
c      WRITE(fo_name2,444) 'random',myrank
c      OPEN (1,file=fo_name2,form='formatted',status='unknown')
c
c	DO i = 1,700
c         WRITE(1,*) random(), random()
c	END DO
c
c      CLOSE(1)
c      CALL MPI_FINALIZE(IERR)
c444   FORMAT(A,I3.3,'.dat')
c	STOP
c      END


**********************************************************************
**********************************************************************
      subroutine detko(alf,phi,del)
*
* is called to determine coefficients of taylor series for interpolation
*	of deflection angle due to cells
*
* input:
*        alf(8)  - vector with four angles alphax(1), ..., alphay(4)
*        del     - distance between two adjacent rays
*
* output:
*        phi(8)  - coefficients
*
* called in:
*           main
*
* use of subroutines:
*           none
*
* use of functions:
*           none
*					October 31, 1991; J. Wambsganss
*
      implicit none
      integer debug
      double precision alf(8),phi(8),fac(4),del,oodel
      common/test/debug
*
      oodel  =  1.0d0/del
      fac(1) =  0.250d0
      fac(2) =  0.125d0*oodel
      fac(3) =  0.250d0*oodel*oodel
      fac(4) =  0.375d0*oodel*oodel*oodel
*
      phi(1) = fac(1)*
     &       (+alf(1)       +alf(3)       +alf(5)       +alf(7)        )
      phi(2) = fac(1)*
     &       (       +alf(2)       +alf(4)       +alf(6)       +alf(8) )
      phi(3) = fac(2)*
     &       (+alf(1)-alf(2)-alf(3)-alf(4)-alf(5)+alf(6)+alf(7)+alf(8) )
      phi(4) = fac(2)*
     &       (+alf(1)+alf(2)+alf(3)-alf(4)-alf(5)-alf(6)-alf(7)+alf(8) )
      phi(5) = fac(3)*
     &       (       -alf(2)       +alf(4)       -alf(6)       +alf(8) )
      phi(6) = fac(3)*
     &       (+alf(1)       -alf(3)       +alf(5)       -alf(7)        )
      phi(7) = fac(4)*
     &       (-alf(1)-alf(2)+alf(3)-alf(4)+alf(5)+alf(6)-alf(7)+alf(8) )
      phi(8) = fac(4)*
     &       (+alf(1)-alf(2)+alf(3)+alf(4)-alf(5)+alf(6)-alf(7)-alf(8) )
*
      return
      end


FUNCTION zeroin(f, ax, bx, aerr, rerr) RESULT(fn_val)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-07-14  Time: 12:32:54

!-----------------------------------------------------------------------

!         FINDING A ZERO OF THE FUNCTION F(X) IN THE INTERVAL (AX,BX)

!                       ------------------------

!  INPUT...

!  F      FUNCTION SUBPROGRAM WHICH EVALUATES F(X) FOR ANY X IN THE
!         CLOSED INTERVAL (AX,BX).  IT IS ASSUMED THAT F IS CONTINUOUS,
!         AND THAT F(AX) AND F(BX) HAVE DIFFERENT SIGNS.
!  AX     LEFT ENDPOINT OF THE INTERVAL
!  BX     RIGHT ENDPOINT OF THE INTERVAL
!  AERR   THE ABSOLUTE ERROR TOLERANCE TO BE SATISFIED
!  RERR   THE RELATIVE ERROR TOLERANCE TO BE SATISFIED

!  OUTPUT...

!         ABCISSA APPROXIMATING A ZERO OF F IN THE INTERVAL (AX,BX)

!-----------------------------------------------------------------------
!  ZEROIN IS A SLIGHTLY MODIFIED TRANSLATION OF THE ALGOL PROCEDURE
!  ZERO GIVEN BY RICHARD BRENT IN ALGORITHMS FOR MINIMIZATION WITHOUT
!  DERIVATIVES, PRENTICE-HALL, INC. (1973).
!-----------------------------------------------------------------------

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)

REAL (dp), INTENT(IN)  :: ax
REAL (dp), INTENT(IN)  :: bx
REAL (dp), INTENT(IN)  :: aerr
REAL (dp), INTENT(IN)  :: rerr
REAL (dp)              :: fn_val

! EXTERNAL f
INTERFACE
  FUNCTION f(x) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
    REAL (dp), INTENT(IN)  :: x
    REAL (dp)              :: fn_val
  END FUNCTION f
END INTERFACE

REAL (dp)  :: a, b, c, d, e, eps, fa, fb, fc, tol, xm, p, q, r, s, atol, rtol

!  COMPUTE EPS, THE RELATIVE MACHINE PRECISION

eps = EPSILON(0.0_dp)

! INITIALIZATION

a = ax
b = bx
fa = f(a)
fb = f(b)
atol = 0.5 * aerr
rtol = MAX(0.5_dp*rerr, 2.0_dp*eps)

! BEGIN STEP

10 c = a
fc = fa
d = b - a
e = d
20 IF (ABS(fc) < ABS(fb)) THEN
  a = b
  b = c
  c = a
  fa = fb
  fb = fc
  fc = fa
END IF

! CONVERGENCE TEST

tol = rtol * MAX(ABS(b),ABS(c)) + atol
xm = 0.5 * (c-b)
IF (ABS(xm) > tol) THEN
  IF (fb /= 0.0) THEN

! IS BISECTION NECESSARY

    IF (ABS(e) >= tol) THEN
      IF (ABS(fa) > ABS(fb)) THEN

! IS QUADRATIC INTERPOLATION POSSIBLE

        IF (a == c) THEN

! LINEAR INTERPOLATION

          s = fb / fc
          p = (c-b) * s
          q = 1.0 - s
        ELSE

! INVERSE QUADRATIC INTERPOLATION

          q = fa / fc
          r = fb / fc
          s = fb / fa
          p = s * ((c-b)*q*(q-r)-(b-a)*(r-1.0))
          q = (q-1.0) * (r-1.0) * (s-1.0)
        END IF

! ADJUST SIGNS

        IF (p > 0.0) q = -q
        p = ABS(p)

! IS INTERPOLATION ACCEPTABLE

        IF (2.0*p < (3.0*xm*q-ABS(tol*q))) THEN
          IF (p < ABS(0.5*e*q)) THEN
            e = d
            d = p / q
            GO TO 30
          END IF
        END IF
      END IF
    END IF

! BISECTION

    d = xm
    e = d

! COMPLETE STEP

    30 a = b
    fa = fb
    IF (ABS(d) > tol) b = b + d
    IF (ABS(d) <= tol) b = b + SIGN(tol,xm)
    fb = f(b)
    IF (fb*(fc/ABS(fc)) > 0.0) GO TO 10
    GO TO 20
  END IF
END IF

! DONE

fn_val = b
RETURN
END FUNCTION zeroin


*DECK DQAWCE
      SUBROUTINE DQAWCE (F, A, B, C, EPSABS, EPSREL, LIMIT, RESULT,
     +   ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST)
C***BEGIN PROLOGUE  DQAWCE
C***PURPOSE  The routine calculates an approximation result to a
C            CAUCHY PRINCIPAL VALUE I = Integral of F*W over (A,B)
C            (W(X) = 1/(X-C), (C.NE.A, C.NE.B), hopefully satisfying
C            following claim for accuracy
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I))
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A1, J4
C***TYPE      DOUBLE PRECISION (QAWCE-S, DQAWCE-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE,
C             CLENSHAW-CURTIS METHOD, QUADPACK, QUADRATURE,
C             SPECIAL-PURPOSE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Computation of a CAUCHY PRINCIPAL VALUE
C        Standard fortran subroutine
C        Double precision version
C
C        PARAMETERS
C         ON ENTRY
C            F      - Double precision
C                     Function subprogram defining the integrand
C                     function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            A      - Double precision
C                     Lower limit of integration
C
C            B      - Double precision
C                     Upper limit of integration
C
C            C      - Double precision
C                     Parameter in the WEIGHT function, C.NE.A, C.NE.B
C                     If C = A OR C = B, the routine will end with
C                     IER = 6.
C
C            EPSABS - Double precision
C                     Absolute accuracy requested
C            EPSREL - Double precision
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     the routine will end with IER = 6.
C
C            LIMIT  - Integer
C                     Gives an upper bound on the number of subintervals
C                     in the partition of (A,B), LIMIT.GE.1
C
C         ON RETURN
C            RESULT - Double precision
C                     Approximation to the integral
C
C            ABSERR - Double precision
C                     Estimate of the modulus of the absolute error,
C                     which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine
C                             the estimates for integral and error are
C                             less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more sub-
C                             divisions by increasing the value of
C                             LIMIT. However, if this yields no
C                             improvement it is advised to analyze the
C                             the integrand, in order to determine the
C                             the integration difficulties. If the
C                             position of a local difficulty can be
C                             determined (e.g. SINGULARITY,
C                             DISCONTINUITY within the interval) one
C                             will probably gain from splitting up the
C                             interval at this point and calling
C                             appropriate integrators on the subranges.
C                         = 2 The occurrence of roundoff error is detec-
C                             ted, which prevents the requested
C                             tolerance from being achieved.
C                         = 3 Extremely bad integrand behaviour
C                             occurs at some interior points of
C                             the integration interval.
C                         = 6 The input is invalid, because
C                             C = A or C = B or
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             or LIMIT.LT.1.
C                             RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1),
C                             IORD(1) and LAST are set to zero. ALIST(1)
C                             and BLIST(1) are set to A and B
C                             respectively.
C
C            ALIST   - Double precision
C                      Vector of dimension at least LIMIT, the first
C                       LAST  elements of which are the left
C                      end points of the subintervals in the partition
C                      of the given integration range (A,B)
C
C            BLIST   - Double precision
C                      Vector of dimension at least LIMIT, the first
C                       LAST  elements of which are the right
C                      end points of the subintervals in the partition
C                      of the given integration range (A,B)
C
C            RLIST   - Double precision
C                      Vector of dimension at least LIMIT, the first
C                       LAST  elements of which are the integral
C                      approximations on the subintervals
C
C            ELIST   - Double precision
C                      Vector of dimension LIMIT, the first  LAST
C                      elements of which are the moduli of the absolute
C                      error estimates on the subintervals
C
C            IORD    - Integer
C                      Vector of dimension at least LIMIT, the first K
C                      elements of which are pointers to the error
C                      estimates over the subintervals, so that
C                      ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST
C                      If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST
C                      otherwise, form a decreasing sequence
C
C            LAST    - Integer
C                      Number of subintervals actually produced in
C                      the subdivision process
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DQC25C, DQPSRT
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DQAWCE
C
      DOUBLE PRECISION A,AA,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,
     1  B,BB,BLIST,B1,B2,C,D1MACH,ELIST,EPMACH,EPSABS,EPSREL,
     2  ERRBND,ERRMAX,ERROR1,ERRO12,ERROR2,ERRSUM,F,RESULT,RLIST,UFLOW
      INTEGER IER,IORD,IROFF1,IROFF2,K,KRULE,LAST,LIMIT,MAXERR,NEV,
     1  NEVAL,NRMAX
C
      DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*),
     1  IORD(*)
C
      EXTERNAL F
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST
C                       ERROR ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQAWCE
      EPMACH = D1MACH(4)
      UFLOW = D1MACH(1)
C
C
C           TEST ON VALIDITY OF PARAMETERS
C           ------------------------------
C
      IER = 6
      NEVAL = 0
      LAST = 0
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.0D+00
      ELIST(1) = 0.0D+00
      IORD(1) = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF (C.EQ.A.OR.C.EQ.B.OR.(EPSABS.LE.0.0D+00.AND.
     1    EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28))) GO TO 999
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
      AA=A
      BB=B
      IF (A.LE.B) GO TO 10
      AA=B
      BB=A
10    IER=0
      KRULE = 1
      CALL DQC25C(F,AA,BB,C,RESULT,ABSERR,KRULE,NEVAL)
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      ALIST(1) = A
      BLIST(1) = B
C
C           TEST ON ACCURACY
C
      ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT))
      IF(LIMIT.EQ.1) IER = 1
      IF(ABSERR.LT.MIN(0.1D-01*ABS(RESULT),ERRBND)
     1  .OR.IER.EQ.1) GO TO 70
C
C           INITIALIZATION
C           --------------
C
      ALIST(1) = AA
      BLIST(1) = BB
      RLIST(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      NRMAX = 1
      IROFF1 = 0
      IROFF2 = 0
C
C           MAIN DO-LOOP
C           ------------
C
      DO 40 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST
C           ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
        B2 = BLIST(MAXERR)
        IF(C.LE.B1.AND.C.GT.A1) B1 = 0.5D+00*(C+B2)
        IF(C.GT.B1.AND.C.LT.B2) B1 = 0.5D+00*(A1+C)
        A2 = B1
        KRULE = 2
        CALL DQC25C(F,A1,B1,C,AREA1,ERROR1,KRULE,NEV)
        NEVAL = NEVAL+NEV
        CALL DQC25C(F,A2,B2,C,AREA2,ERROR2,KRULE,NEV)
        NEVAL = NEVAL+NEV
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(ABS(RLIST(MAXERR)-AREA12).LT.0.1D-04*ABS(AREA12)
     1    .AND.ERRO12.GE.0.99D+00*ERRMAX.AND.KRULE.EQ.0)
     2    IROFF1 = IROFF1+1
        IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX.AND.KRULE.EQ.0)
     1    IROFF2 = IROFF2+1
        RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = MAX(EPSABS,EPSREL*ABS(AREA))
        IF(ERRSUM.LE.ERRBND) GO TO 15
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
C
        IF(IROFF1.GE.6.AND.IROFF2.GT.20) IER = 2
C
C           SET ERROR FLAG IN THE CASE THAT NUMBER OF INTERVAL
C           BISECTIONS EXCEEDS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE.
C
        IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)
     1    *(ABS(A2)+0.1D+04*UFLOW)) IER = 3
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
   15   IF(ERROR2.GT.ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
   30    CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF(IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 50
   40 CONTINUE
C
C           COMPUTE FINAL RESULT.
C           ---------------------
C
   50 RESULT = 0.0D+00
      DO 60 K=1,LAST
        RESULT = RESULT+RLIST(K)
   60 CONTINUE
      ABSERR = ERRSUM
   70 IF (AA.EQ.B) RESULT=-RESULT
  999 RETURN
      END


*deck aratio_qud
      subroutine aratio_qud(xl1,yl1,zl1,
     *                      xl2,yl2,zl2,
     *                      xl3,yl3,zl3,
     *                      xl4,yl4,zl4,
     *                      aratqud)
C
C
C #####################################################################
C
C     PURPOSE -
C
C        Finds the aspect ratio of a quad.
C
C     INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x4,y4,z4) - The coordinates of the quad.
C
C     OUTPUT ARGUMENTS -
C
C        aratqud : The aspect ratio of the quad.
C
C     CHANGE HISTORY -
C
C $Log: aratio_qud.f,v $
C Revision 2.00  2007/11/05 19:45:46  spchu
C Import to CVS
C
CPVCS
CPVCS       Rev 1.0   Fri Aug 29 14:11:36 1997   dcg
CPVCS    Initial revision.
C
C ######################################################################
C
C
      implicit none
C
      include "local_element.h"
C
      real*8 xl1,yl1,zl1,xl2,yl2,zl2,xl3,yl3,zl3,xl4,yl4,zl4
      real*8 aratqud
      real*8 xb,yb,zb,xc,yc,zc
      real*8 smdiag,lardiag,dist1,dist2
C
C ######################################################################
C
C
C  Calculation of "dist", the length of the
C  diagonals of the quad.
C
      xb = xl1 - xl3
      yb = yl1 - yl3
      zb = zl1 - zl3
      xc = xl2 - xl4
      yc = yl2 - yl4
      zc = zl2 - zl4
      dist1 = sqrt ( xb*xb + yb*yb + zb*zb )
      dist2 = sqrt ( xc*xc + yc*yc + zc*zc )
      if (dist1 .lt. dist2) then
         smdiag = dist1
         lardiag = dist2
      else
         lardiag = dist1
         smdiag = dist2
      endif

      aratqud = smdiag/lardiag

      return
      end