!==============================================================================
! Module WELL_MODULE                                              (28-Jun-2017)
!
! Written by:
! 	   Dr. Randal J. Barnes
!     Department of Civil, Environmental, and Geo- Engineering
!     University of Minnesota
!     <barne003@umn.edu>
!==============================================================================

!==============================================================================
MODULE WELL_MODULE
!==============================================================================
   USE CONSTANTS_MODULE
   IMPLICIT NONE

   !===========================================================================
   ! Type T_WELL
   !===========================================================================
   TYPE T_WELL
      REAL(8) :: X = 0  ! X coordinate
      REAL(8) :: Y = 0  ! Y coordinate
      REAL(8) :: R = 0  ! radius
      REAL(8) :: Q = 0  ! discharge
   END TYPE T_WELL

   !===========================================================================
   ! INTERFACES
   !===========================================================================
   INTERFACE Potential
      MODULE PROCEDURE Potential_Well
   END INTERFACE

   INTERFACE Discharge
      MODULE PROCEDURE Discharge_Well
   END INTERFACE

CONTAINS
   !---------------------------------------------------------------------------
   ! Potential_Well
   !---------------------------------------------------------------------------
   FUNCTION Potential_Well( Well, X, Y ) Result( Phi )

   ! Declare the arguments.
   TYPE(T_WELL), INTENT(IN) :: Well    ! well of interest
   REAL(8),      INTENT(IN) :: X       ! X coordinate of interest
   REAL(8),      INTENT(IN) :: Y       ! Y coordinate of interest

   REAL(8)                  :: Phi     ! resulting discharge potential

   ! Declare the local variables.
   REAL(8) :: R

   ! Compute the discharge potential for the well.
   R = HYPOT(X - Well%X, Y - Well%Y)

   IF( R .LT. Well%R ) THEN
      Phi = Well%Q/TWO_PI * LOG(Well%R)
   ELSE
      Phi = Well%Q/TWO_PI * LOG(R)
   END IF

   END FUNCTION Potential_Well

   !---------------------------------------------------------------------------
   ! Discharge_Well
   !---------------------------------------------------------------------------
   FUNCTION Discharge_Well( Well, X, Y ) RESULT( Q )

   ! Declare the arguments.
   TYPE(T_WELL), INTENT(IN) :: Well    ! well of interest
   REAL(8),      INTENT(IN) :: X       ! X coordinate of interest
   REAL(8),      INTENT(IN) :: Y       ! Y coordinate of interest

   REAL(8), DIMENSION(2)    :: Q       ! resulting discharge vector

   ! Declare the local variables.
   REAL(8) :: DX, DY, R2

   ! Compute the discharge for the well.
   DX = X - Well%X
   DY = Y - Well%Y
   R2 = DX*DX + DY*DY

   IF( R2 .LT. Well%R*Well%R ) THEN
      Q = 0
   ELSE
      Q(1) = -Well%Q/TWO_PI * DX/R2
      Q(2) = -Well%Q/TWO_PI * DY/R2
   END IF

   END FUNCTION Discharge_Well

!==============================================================================
END MODULE WELL_MODULE
!==============================================================================


MODULE Cone
  USE bellhopMod
  USE MathConstants
  IMPLICIT NONE

CONTAINS

  SUBROUTINE ConeFormulas2D( z_xx, z_xy, z_yy, nBdry, xs, tradial, xray, BotTop )

    ! analytic formula for the conical seamount
    REAL (KIND=8),     INTENT( IN  ) :: xs( 3 ), tradial( 2 ), xray( 2 )
    CHARACTER (LEN=3), INTENT( IN  ) :: BotTop                  ! Flag indicating bottom or top reflection
    REAL (KIND=8),     INTENT( OUT ) :: z_xx, z_xy, z_yy, nBdry( 2 )
    REAL (KIND=8) :: nBdry3dCone( 3 ), theta, phi, Rray, Radius, x, y   ! for cone reflection

  IF ( BotTop == 'BOT' ) THEN
     phi   = 15 * DegRad   ! 15 degree angle of seamount
     Rray  = xray( 1 )   ! cylindrical range of ray from source

     ! get bearing from cone to ray using (x,y) coordinate of the ray
     x = xs( 1 ) + Rray * tradial( 1 )
     y = xs( 2 ) + Rray * tradial( 2 )
     theta = atan2( y, x )

     nBdry3dCone =  [ -cos( theta ) * sin( phi ), -sin( theta ) * sin( phi ), cos( phi ) ]

     ! nBdry3dCone = -[ -cos( theta ) * tan( phi ), -sin( theta ) * tan( phi ), 1.0D0 ]
     ! nBdry3dCone = -[ ray2D( is )%x( 1 ), ray2D( is )%x( 2 ), -1.0D0  ]
     ! nBdry3dCone = NBdry3dCone / NORM2( NBdry3dCone )

     nBdry( 1 ) = DOT_PRODUCT( nBdry3dCone( 1 : 2 ), tradial )
     nBdry( 2 ) = nBdry3dCone( 3 )

     ! curvatures
     Radius = SQRT( x ** 2 + y ** 2 )   ! radius of seamount at the bounce point

     ! z = z_xx / 2 * x^2 + z_xy * xy + z_yy / 2 * y^2; coefs are the kappa matrix

     z_xx =   y * y / Radius**3 * tan( phi )
     z_xy = - x * y / Radius**3 * tan( phi )
     z_yy =   x * x / Radius**3 * tan( phi )
  END IF
END SUBROUTINE ConeFormulas2D

  SUBROUTINE ConeFormulas3D( z_xx, z_xy, z_yy, nBdry, xs, xray, BotTop )

    ! analytic formula for the conical seamount

    REAL (KIND=8),     INTENT( IN  ) :: xs( 3 ), xray( 3 )
    CHARACTER (LEN=3), INTENT( IN  ) :: BotTop                  ! Flag indicating bottom or top reflection
    REAL (KIND=8),     INTENT( OUT ) :: z_xx, z_xy, z_yy, nBdry( 3 )
    REAL (KIND=8) :: theta, phi, Radius, x, y, RLen

    IF ( BotTop == 'BOT' ) THEN
       phi = 15 * DegRad     ! 15 degree angle of seamount

       x = xray( 1 )
       y = xray( 2 )

       theta = atan2( y, x )   ! bearing from origin (center of cone) to ray
       ! could write the folowing in terms of x, y, and z ...
       nBdry = [ -cos( theta ) * sin( phi ), -sin( theta ) * sin( phi ), cos( phi ) ]   ! unit normal to bdry

       ! curvatures

       Radius = SQRT( x ** 2 + y ** 2 )   ! radius of seamount at the bounce point
       ! z = z_xx / 2 * x^2 + z_xy * xy + z_yy * y^2 ! coefs are the kappa matrix

       RLen = SQRT( 1 + TAN( phi ) ** 2 )   ! 1 + fx^2 + fy^2
       z_xx =   y * y / Radius**3 * tan( phi ) / RLen
       z_xy = - x * y / Radius**3 * tan( phi ) / RLen
       z_yy =   x * x / Radius**3 * tan( phi ) / RLen
    END IF
  END SUBROUTINE ConeFormulas3D

END MODULE CONE


      SUBROUTINE spear(data1,data2,n,wksp1,wksp2,d,zd,probd,rs,probrs)
      INTEGER n
      REAL d,probd,probrs,rs,zd,data1(n),data2(n),wksp1(n),wksp2(n)
CU    USES betai,crank,erfcc,sort2
      INTEGER j
      REAL aved,df,en,en3n,fac,sf,sg,t,vard,betai,erfcc
      do 11 j=1,n
        wksp1(j)=data1(j)
        wksp2(j)=data2(j)
11    continue
      call sort2(n,wksp1,wksp2)
      call crank(n,wksp1,sf)
      call sort2(n,wksp2,wksp1)
      call crank(n,wksp2,sg)
      d=0.
      do 12 j=1,n
        d=d+(wksp1(j)-wksp2(j))**2
12    continue
      en=n
      en3n=en**3-en
      aved=en3n/6.-(sf+sg)/12.
      fac=(1.-sf/en3n)*(1.-sg/en3n)
      vard=((en-1.)*en**2*(en+1.)**2/36.)*fac
      zd=(d-aved)/sqrt(vard)
      probd=erfcc(abs(zd)/1.4142136)
      rs=(1.-(6./en3n)*(d+(sf+sg)/12.))/sqrt(fac)
      fac=(1.+rs)*(1.-rs)
      if(fac.gt.0.)then
        t=rs*sqrt((en-2.)/fac)
        df=en-2.
        probrs=betai(0.5*df,0.5,df/(df+t**2))
      else
        probrs=0.
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/spear.for


FUNCTION gamma_s(xx)
  USE mo_kind, only: sp
  USE mo_nrutil, ONLY : arth,assert
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: xx
  REAL(SP) :: gamma_s
  REAL(sp) :: tmp,x
  REAL(sp) :: stp = 2.5066282746310005_sp
  REAL(sp), DIMENSION(6) :: coef = (/76.18009172947146_sp,&
       -86.50532032941677_sp,24.01409824083091_sp,&
       -1.231739572450155_sp,0.1208650973866179e-2_sp,&
       -0.5395239384953e-5_sp/)
  call assert(xx > 0.0, 'gamma_s arg')
  x=xx
  tmp=x+5.5_sp
  tmp=(x+0.5_sp)*log(tmp)-tmp
  gamma_s=tmp+log(stp*(1.000000000190015_sp+&
       sum(coef(:)/arth(x+1.0_sp,1.0_sp,size(coef))))/x)
  gamma_s=exp(gamma_s)
END FUNCTION gamma_s

FUNCTION gamma_v(xx)
  USE mo_kind, only: sp, i4
  USE mo_nrutil, ONLY: assert
  IMPLICIT NONE
  INTEGER(I4) :: i
  REAL(SP), DIMENSION(:), INTENT(IN) :: xx
  REAL(SP), DIMENSION(size(xx)) :: gamma_v
  REAL(sp), DIMENSION(size(xx)) :: ser,tmp,x,y
  REAL(sp) :: stp = 2.5066282746310005_sp
  REAL(sp), DIMENSION(6) :: coef = (/76.18009172947146_sp,&
       -86.50532032941677_sp,24.01409824083091_sp,&
       -1.231739572450155_sp,0.1208650973866179e-2_sp,&
       -0.5395239384953e-5_sp/)
  if (size(xx) == 0) RETURN
  call assert(all(xx > 0.0), 'gamma_v arg')
  x=xx
  tmp=x+5.5_sp
  tmp=(x+0.5_sp)*log(tmp)-tmp
  ser=1.000000000190015_sp
  y=x
  do i=1,size(coef)
     y=y+1.0_sp
     ser=ser+coef(i)/y
  end do
  gamma_v=tmp+log(stp*ser/x)
  gamma_v=exp(gamma_v)
END FUNCTION gamma_v

FUNCTION dgamma_s(z)
  !  Uses Lanczos-type approximation to ln(gamma) for z > 0.
  !  Reference:
  !       Lanczos, C. ''A precision approximation of the gamma
  !               function'', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
  !  Accuracy: About 14 significant digits except for small regions
  !            in the vicinity of 1 and 2.
  !  Programmer: Alan Miller
  !              1 Creswick Street, Brighton, Vic. 3187, Australia
  !  e-mail: amiller @ bigpond.net.au
  !  Latest revision - 14 October 1996
  USE mo_kind, only: dp
  USE mo_nrutil, ONLY : assert
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: z
  REAL(DP) :: dgamma_s
  ! Local variables
  REAL(DP)  :: a(9) = (/ 0.9999999999995183_dp, 676.5203681218835_dp, &
       -1259.139216722289_dp, 771.3234287757674_dp, &
       -176.6150291498386_dp, 12.50734324009056_dp, &
       -0.1385710331296526_dp, 0.9934937113930748D-05, &
       0.1659470187408462D-06 /)
  REAL(DP)  :: zero = 0.0_dp,   &
       one = 1.0_dp, &
       lnsqrt2pi =  0.9189385332046727_dp, &
       half = 0.5_dp, &
       sixpt5 = 6.5_dp, &
       seven = 7.0_dp
  REAL(DP)  :: tmp
  INTEGER   :: j
  call assert(z > zero, 'dgamma_s arg')
  dgamma_s = zero
  tmp = z + seven
  DO j = 9, 2, -1
     dgamma_s = dgamma_s + a(j)/tmp
     tmp = tmp - one
  END DO
  dgamma_s = dgamma_s + a(1)
  dgamma_s = LOG(dgamma_s) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
  dgamma_s  = exp(dgamma_s)
END FUNCTION dgamma_s

FUNCTION dgamma_v(z)
  !  Uses Lanczos-type approximation to ln(gamma) for z > 0.
  !  Reference:
  !       Lanczos, C. ''A precision approximation of the gamma
  !               function'', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
  !  Accuracy: About 14 significant digits except for small regions
  !            in the vicinity of 1 and 2.
  !  Programmer: Alan Miller
  !              1 Creswick Street, Brighton, Vic. 3187, Australia
  !  e-mail: amiller @ bigpond.net.au
  !  Latest revision - 14 October 1996
  USE mo_kind, only: dp
  USE mo_nrutil, ONLY : assert
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: z
  REAL(DP), DIMENSION(size(z)) :: dgamma_v
  ! Local variables
  REAL(DP)  :: a(9) = (/ 0.9999999999995183_dp, 676.5203681218835_dp, &
       -1259.139216722289_dp, 771.3234287757674_dp, &
       -176.6150291498386_dp, 12.50734324009056_dp, &
       -0.1385710331296526_dp, 0.9934937113930748D-05, &
       0.1659470187408462D-06 /)
  REAL(DP)  :: zero = 0.0_dp,   &
       one = 1.0_dp, &
       lnsqrt2pi =  0.9189385332046727_dp, &
       half = 0.5_dp, &
       sixpt5 = 6.5_dp, &
       seven = 7.0_dp
  REAL(DP), DIMENSION(size(z)) :: tmp
  INTEGER   :: j
  if (size(z) == 0) RETURN
  call assert(all(z > 0.0_dp), 'dgamma_v arg')
  dgamma_v = zero
  tmp = z + seven
  DO j = 9, 2, -1
     dgamma_v = dgamma_v + a(j)/tmp
     tmp = tmp - one
  END DO
  dgamma_v = dgamma_v  + a(1)
  dgamma_v = LOG(dgamma_v) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
  dgamma_v  = exp(dgamma_v)
END FUNCTION dgamma_v


!*******************************************************************************
!> author: Jacob Williams
!
!  Test for the [[slsqp_module]].

    program slsqp_test_3

    use slsqp_module
    use slsqp_kinds

    implicit none

    integer,parameter               :: n = 2                      !! number of optimization variables
    integer,parameter               :: m = 1                      !! total number of constraints
    integer,parameter               :: meq = 0                    !! number of equality constraints
    integer,parameter               :: max_iter = 100             !! maximum number of allowed iterations
    real(wp),dimension(n),parameter :: xl = [-1.0_wp, -1.0_wp]    !! lower bounds
    real(wp),dimension(n),parameter :: xu = [ 1.0_wp,  1.0_wp]    !! upper bounds
    real(wp),parameter              :: acc = 1.0e-8_wp            !! tolerance
    integer,parameter               :: linesearch_mode = 1        !! use inexact linesearch.
    real(wp),parameter              :: gradient_delta = 1.0e-5_wp !! step to approximate gradient

    type(slsqp_solver)      :: solver        !! instantiate an slsqp solver
    real(wp),dimension(n)   :: x             !! optimization variable vector
    integer                 :: istat         !! for solver status check
    logical                 :: status_ok     !! for initialization status check
    integer                 :: iterations    !! number of iterations by the solver
    integer                 :: gradient_mode !! gradient computation mode

    ! test each of the gradient modes (backward, forward, and central diffs)
    do gradient_mode = 1, 3

        write(*,*) ''
        write(*,*) '---------------------------'
        write(*,*) 'gradient mode:', gradient_mode
        write(*,*) '---------------------------'

        x = [0.1_wp, 0.1_wp] !initial guess

        call solver%initialize(n,m,meq,max_iter,acc,rosenbrock_func,dummy_grad,&
                                xl,xu,linesearch_mode=linesearch_mode,status_ok=status_ok,&
                                report=report_iteration,&
                                gradient_mode=gradient_mode,gradient_delta=gradient_delta)

        if (status_ok) then
            call solver%optimize(x,istat,iterations)
            write(*,*) ''
            write(*,*) 'solution   :', x
            write(*,*) 'istat      :', istat
            write(*,*) 'iterations :', iterations
            write(*,*) ''
        else
            error stop 'error calling slsqp.'
        end if

    end do

    !solution:  x1 = 0.7864151509699762
    !           x2 = 0.6176983165977831
    !           f  = 0.0456748087191604
    !           c  = -0.0000000000028654

    contains

    subroutine rosenbrock_func(me,x,f,c)
        !! Rosenbrock function
        !!
        !! Minimize the Rosenbrock function: \( f(x) = 100 (x_2 - x_1)^2 + (1 - x_1)^2 \),
        !! subject to the inequality constraint: \( x_1^2 + x_2^2 \le 1 \).
        !!
        !! see: http://www.mathworks.com/help/optim/ug/example-nonlinear-constrained-minimization.html
        implicit none
        class(slsqp_solver),intent(inout) :: me
        real(wp),dimension(:),intent(in)  :: x      !! optimization variable vector
        real(wp),intent(out)              :: f      !! value of the objective function
        real(wp),dimension(:),intent(out) :: c      !! the constraint vector `dimension(m)`,
                                                    !! equality constraints (if any) first.

        f = 100.0_wp*(x(2) - x(1)**2)**2 + (1.0_wp - x(1))**2  !objective function
        c(1) = 1.0_wp - x(1)**2 - x(2)**2  !equality constraint (>=0)

    end subroutine rosenbrock_func

    subroutine dummy_grad(me,x,g,a)

        !! not used in this case

        implicit none

        class(slsqp_solver),intent(inout)   :: me
        real(wp),dimension(:),intent(in)    :: x    !! optimization variable vector
        real(wp),dimension(:),intent(out)   :: g    !! objective function partials w.r.t x `dimension(n)`
        real(wp),dimension(:,:),intent(out) :: a    !! gradient matrix of constraints w.r.t. x `dimension(m,n)`

        error stop 'this routine is not meant to be called'

    end subroutine dummy_grad

    subroutine report_iteration(me,iter,x,f,c)
        use, intrinsic :: iso_fortran_env, only: output_unit
        !! report an iteration (print to the console).
        implicit none
        class(slsqp_solver),intent(inout) :: me
        integer,intent(in)                :: iter
        real(wp),dimension(:),intent(in)  :: x
        real(wp),intent(in)               :: f
        real(wp),dimension(:),intent(in)  :: c

        !write a header:
        if (iter==0) then
            write(output_unit,'(*(A20,1X))') 'iteration', 'x(1)', 'x(2)', 'f(1)', 'c(1)'
        end if

        !write the iteration data:
        write(output_unit,'(I20,1X,(*(F20.16,1X)))') iter,x,f,c

    end subroutine report_iteration

    end program slsqp_test_3
!*******************************************************************************


      PROGRAM xbanmul
C     driver for routine banmul
      INTEGER NP,M1,M2,MP
      PARAMETER (NP=7,M1=2,M2=1,MP=M1+1+M2)
      INTEGER i,j,k
      REAL a(NP,MP),aa(NP,NP),ax(NP),b(NP),x(NP)
      do 12 i=1,M1
        do 11 j=1,NP
          a(j,i)=10*j+i
11      continue
12    continue
C     lower band
      do 13 i=1,NP
        a(i,M1+1)=i
13    continue
C     diagonal
      do 15 i=1,M2
        do 14 j=1,NP
          a(j,M1+1+i)=0.1*j+i
14      continue
15    continue
C     upper band
      do 17 i=1,NP
        do 16 j=1,NP
          k=i-M1-1
          if (j.ge.max(1,1+k).and.j.le.min(M1+M2+1+k,NP)) then
            aa(i,j)=a(i,j-k)
          else
            aa(i,j)=0.0
          endif
16      continue
17    continue
      do 18 i=1,NP
        x(i)=i/10.0
18    continue
      call banmul(a,NP,M1,M2,NP,MP,x,b)
      do 21 i=1,NP
        ax(i)=0.0
        do 19 j=1,NP
          ax(i)=ax(i)+aa(i,j)*x(j)
19      continue
21    continue
      write(*,'(t8,a,t32,a)') 'Reference vector','banmul vector'
      do 22 i=1,NP
        write(*,'(t8,f12.4,t32,f12.4)') ax(i),b(i)
22    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xbanmul.for


!*****************************************************************************************
!
!> Units test for 2d-6d linear interpolation.

    program linear_interpolation_test

    use linear_interpolation_module
    use,intrinsic :: iso_fortran_env, only: wp => real64

    implicit none

    integer,parameter :: nx = 6     !! number of points in x
    integer,parameter :: ny = 6     !! number of points in y
    integer,parameter :: nz = 6     !! number of points in z
    integer,parameter :: nq = 6     !! number of points in q
    integer,parameter :: nr = 6     !! number of points in r
    integer,parameter :: ns = 6     !! number of points in s

    real(wp) :: x(nx),y(ny),z(nz),q(nq),r(nr),s(ns)
    real(wp) :: fcn_1d(nx)
    real(wp) :: fcn_2d(nx,ny)
    real(wp) :: fcn_3d(nx,ny,nz)
    real(wp) :: fcn_4d(nx,ny,nz,nq)
    real(wp) :: fcn_5d(nx,ny,nz,nq,nr)
    real(wp) :: fcn_6d(nx,ny,nz,nq,nr,ns)

    type(linear_interp_1d) :: s1
    type(linear_interp_2d) :: s2
    type(linear_interp_3d) :: s3
    type(linear_interp_4d) :: s4
    type(linear_interp_5d) :: s5
    type(linear_interp_6d) :: s6

    real(wp) :: tol,rnd
    real(wp),dimension(6) :: val,tru,err,errmax
    logical :: fail
    integer :: i,j,k,l,m,n,idx,idy,idz,idq,idr,ids
    integer,dimension(6) :: iflag

    fail = .false.
    tol = 1.0e-14_wp
    do i=1,nx
        x(i) = dble(i-1)/dble(nx-1)
    end do
    do j=1,ny
        y(j) = dble(j-1)/dble(ny-1)
    end do
    do k=1,nz
        z(k) = dble(k-1)/dble(nz-1)
    end do
    do l=1,nq
        q(l) = dble(l-1)/dble(nq-1)
    end do
    do m=1,nr
        r(m) = dble(m-1)/dble(nr-1)
    end do
    do n=1,ns
        s(n) = dble(n-1)/dble(ns-1)
    end do
    do i=1,nx
                        fcn_1d(i) = f1(x(i))
        do j=1,ny
                        fcn_2d(i,j) = f2(x(i),y(j))
           do k=1,nz
                        fcn_3d(i,j,k) = f3(x(i),y(j),z(k))
              do l=1,nq
                        fcn_4d(i,j,k,l) = f4(x(i),y(j),z(k),q(l))
                 do m=1,nr
                        fcn_5d(i,j,k,l,m) = f5(x(i),y(j),z(k),q(l),r(m))
                     do n=1,ns
                        fcn_6d(i,j,k,l,m,n) = f6(x(i),y(j),z(k),q(l),r(m),s(n))
                     end do
                 end do
              end do
           end do
        end do
    end do

    ! initialize
    call s1%initialize(x,fcn_1d,            iflag(1))
    call s2%initialize(x,y,fcn_2d,          iflag(2))
    call s3%initialize(x,y,z,fcn_3d,        iflag(3))
    call s4%initialize(x,y,z,q,fcn_4d,      iflag(4))
    call s5%initialize(x,y,z,q,r,fcn_5d,    iflag(5))
    call s6%initialize(x,y,z,q,r,s,fcn_6d,  iflag(6))

    if (any(iflag/=0)) then
        do i=1,6
            if (iflag(i)/=0) then
                write(*,*) 'Error initializing ',i,'D interpolator. iflag=',iflag(i)
            end if
        end do
        stop 1
    end if

    ! compute max error at interpolation points

     errmax = 0.0_wp
     do i=1,nx
                        call RANDOM_NUMBER(rnd); rnd = (rnd - 0.5_wp) / 100.0_wp
                        call s1%evaluate(x(i)+rnd,val(1))
                        tru(1)    = f1(x(i)+rnd)
                        err(1)    = abs(tru(1)-val(1))
                        errmax(1) = max(err(1),errmax(1))
        do j=1,ny
                        call RANDOM_NUMBER(rnd); rnd = rnd / 100.0_wp
                        call s2%evaluate(x(i)+rnd,y(j)+rnd,val(2))
                        tru(2)    = f2(x(i)+rnd,y(j)+rnd)
                        err(2)    = abs(tru(2)-val(2))
                        errmax(2) = max(err(2),errmax(2))
           do k=1,nz
                        call RANDOM_NUMBER(rnd); rnd = rnd / 100.0_wp
                        call s3%evaluate(x(i)+rnd,y(j)+rnd,z(k)+rnd,val(3))
                        tru(3)    = f3(x(i)+rnd,y(j)+rnd,z(k)+rnd)
                        err(3)    = abs(tru(3)-val(3))
                        errmax(3) = max(err(3),errmax(3))
              do l=1,nq
                        call RANDOM_NUMBER(rnd); rnd = rnd / 100.0_wp
                        call s4%evaluate(x(i)+rnd,y(j)+rnd,z(k)+rnd,q(l)+rnd,val(4))
                        tru(4)    = f4(x(i)+rnd,y(j)+rnd,z(k)+rnd,q(l)+rnd)
                        err(4)    = abs(tru(4)-val(4))
                        errmax(4) = max(err(4),errmax(4))
                do m=1,nr
                        call RANDOM_NUMBER(rnd); rnd = rnd / 100.0_wp
                        call s5%evaluate(x(i)+rnd,y(j)+rnd,z(k)+rnd,q(l)+rnd,r(m)+rnd,val(5))
                        tru(5)    = f5(x(i)+rnd,y(j)+rnd,z(k)+rnd,q(l)+rnd,r(m)+rnd)
                        err(5)    = abs(tru(5)-val(5))
                        errmax(5) = max(err(5),errmax(5))
                    do n=1,ns
                        call RANDOM_NUMBER(rnd); rnd = rnd / 100.0_wp
                        call s6%evaluate(x(i)+rnd,y(j)+rnd,z(k)+rnd,q(l)+rnd,r(m)+rnd,s(n)+rnd,val(6))
                        tru(6)    = f6(x(i)+rnd,y(j)+rnd,z(k)+rnd,q(l)+rnd,r(m)+rnd,s(n)+rnd)
                        err(6)    = abs(tru(6)-val(6))
                        errmax(6) = max(err(6),errmax(6))
                    end do
                end do
              end do
           end do
        end do
     end do

    ! check max error against tolerance
    do i=1,6
        write(*,*) i,'D: max error:', errmax(i)
        if (errmax(i) >= tol) then
            write(*,*)  ' ** test failed ** '
        else
            write(*,*)  ' ** test passed ** '
        end if
        write(*,*) ''
    end do

    contains

        real(wp) function f1(x) !! 1d test function
        implicit none
        real(wp),intent(in) :: x
        f1 = x + x + x + x + x + x
        end function f1

        real(wp) function f2(x,y) !! 2d test function
        implicit none
        real(wp),intent(in) :: x,y
        f2 = x + y + x + y + x + y
        end function f2

        real(wp) function f3 (x,y,z) !! 3d test function
        implicit none
        real(wp),intent(in) :: x,y,z
        f3 = x + y + z + x + y + z
        end function f3

        real(wp) function f4 (x,y,z,q) !! 4d test function
        implicit none
        real(wp),intent(in) ::  x,y,z,q
        f4 = x + y + z + q + x + y
        end function f4

        real(wp) function f5 (x,y,z,q,r) !! 5d test function
        implicit none
        real(wp),intent(in) ::  x,y,z,q,r
        f5 = x + y + z + q + r + x
        end function f5

        real(wp) function f6 (x,y,z,q,r,s) !! 6d test function
        implicit none
        real(wp),intent(in) ::  x,y,z,q,r,s
        f6 = x + y + z + q + r + s
        end function f6

    end program linear_interpolation_test