*DECK DPCHIA
      DOUBLE PRECISION FUNCTION DPCHIA (N, X, F, D, INCFD, SKIP, A, B,
     +   IERR)
C***BEGIN PROLOGUE  DPCHIA
C***PURPOSE  Evaluate the definite integral of a piecewise cubic
C            Hermite function over an arbitrary interval.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3, H2A1B2
C***TYPE      DOUBLE PRECISION (PCHIA-S, DPCHIA-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP,
C             QUADRATURE
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          DPCHIA:  Piecewise Cubic Hermite Integrator, Arbitrary limits
C
C     Evaluates the definite integral of the cubic Hermite function
C     defined by  N, X, F, D  over the interval [A, B].
C
C     To provide compatibility with DPCHIM and DPCHIC, includes an
C     increment between successive values of the F- and D-arrays.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, IERR
C        DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N), A, B
C        DOUBLE PRECISION  VALUE, DPCHIA
C        LOGICAL  SKIP
C
C        VALUE = DPCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR)
C
C   Parameters:
C
C     VALUE -- (output) value of the requested integral.
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of function values.  F(1+(I-1)*INCFD) is
C           the value corresponding to X(I).
C
C     D -- (input) real*8 array of derivative values.  D(1+(I-1)*INCFD)
C           is the value corresponding to X(I).
C
C     INCFD -- (input) increment between successive values in F and D.
C           (Error return if  INCFD.LT.1 .)
C
C     SKIP -- (input/output) logical variable which should be set to
C           .TRUE. if the user wishes to skip checks for validity of
C           preceding parameters, or to .FALSE. otherwise.
C           This will save time in case these checks have already
C           been performed (say, in DPCHIM or DPCHIC).
C           SKIP will be set to .TRUE. on return with IERR.GE.0 .
C
C     A,B -- (input) the limits of integration.
C           NOTE:  There is no requirement that [A,B] be contained in
C                  [X(1),X(N)].  However, the resulting integral value
C                  will be highly suspect, if not.
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           Warning errors:
C              IERR = 1  if  A  is outside the interval [X(1),X(N)].
C              IERR = 2  if  B  is outside the interval [X(1),X(N)].
C              IERR = 3  if both of the above are true.  (Note that this
C                        means that either [A,B] contains data interval
C                        or the intervals do not intersect at all.)
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C                (VALUE will be zero in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C              IERR = -4  in case of an error return from DPCHID (which
C                         should never occur).
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DCHFIE, DPCHID, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820730  DATE WRITTEN
C   820804  Converted to SLATEC library version.
C   870707  Corrected XERROR calls for d.p. name(s).
C   870707  Corrected conversion to double precision.
C   870813  Minor cosmetic changes.
C   890206  Corrected XERROR calls.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890703  Corrected category record.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   930503  Corrected to set VALUE=0 when IERR.lt.0.  (FNF)
C   930504  Changed DCHFIV to DCHFIE.  (FNF)
C***END PROLOGUE  DPCHIA
C
C  Programming notes:
C  1. The error flag from DPCHID is tested, because a logic flaw
C     could conceivably result in IERD=-4, which should be reported.
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*), A, B
      LOGICAL  SKIP
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, IA, IB, IERD, IL, IR
      DOUBLE PRECISION  VALUE, XA, XB, ZERO
      SAVE ZERO
      DOUBLE PRECISION  DCHFIE, DPCHID
C
C  INITIALIZE.
C
      DATA  ZERO /0.D0/
C***FIRST EXECUTABLE STATEMENT  DPCHIA
      VALUE = ZERO
C
C  VALIDITY-CHECK ARGUMENTS.
C
      IF (SKIP)  GO TO 5
C
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
C
C  FUNCTION DEFINITION IS OK, GO ON.
C
    5 CONTINUE
      SKIP = .TRUE.
      IERR = 0
      IF ( (A.LT.X(1)) .OR. (A.GT.X(N)) )  IERR = IERR + 1
      IF ( (B.LT.X(1)) .OR. (B.GT.X(N)) )  IERR = IERR + 2
C
C  COMPUTE INTEGRAL VALUE.
C
      IF (A .NE. B)  THEN
         XA = MIN (A, B)
         XB = MAX (A, B)
         IF (XB .LE. X(2))  THEN
C           INTERVAL IS TO LEFT OF X(2), SO USE FIRST CUBIC.
C                   ---------------------------------------
            VALUE = DCHFIE (X(1),X(2), F(1,1),F(1,2),
     +                                 D(1,1),D(1,2), A, B)
C                   ---------------------------------------
         ELSE IF (XA .GE. X(N-1))  THEN
C           INTERVAL IS TO RIGHT OF X(N-1), SO USE LAST CUBIC.
C                   ------------------------------------------
            VALUE = DCHFIE(X(N-1),X(N), F(1,N-1),F(1,N),
     +                                  D(1,N-1),D(1,N), A, B)
C                   ------------------------------------------
         ELSE
C           'NORMAL' CASE -- XA.LT.XB, XA.LT.X(N-1), XB.GT.X(2).
C      ......LOCATE IA AND IB SUCH THAT
C               X(IA-1).LT.XA.LE.X(IA).LE.X(IB).LE.XB.LE.X(IB+1)
            IA = 1
            DO 10  I = 1, N-1
               IF (XA .GT. X(I))  IA = I + 1
   10       CONTINUE
C             IA = 1 IMPLIES XA.LT.X(1) .  OTHERWISE,
C             IA IS LARGEST INDEX SUCH THAT X(IA-1).LT.XA,.
C
            IB = N
            DO 20  I = N, IA, -1
               IF (XB .LT. X(I))  IB = I - 1
   20       CONTINUE
C             IB = N IMPLIES XB.GT.X(N) .  OTHERWISE,
C             IB IS SMALLEST INDEX SUCH THAT XB.LT.X(IB+1) .
C
C     ......COMPUTE THE INTEGRAL.
            IF (IB .LT. IA)  THEN
C              THIS MEANS IB = IA-1 AND
C                 (A,B) IS A SUBSET OF (X(IB),X(IA)).
C                      -------------------------------------------
               VALUE = DCHFIE (X(IB),X(IA), F(1,IB),F(1,IA),
     +                                      D(1,IB),D(1,IA), A, B)
C                      -------------------------------------------
            ELSE
C
C              FIRST COMPUTE INTEGRAL OVER (X(IA),X(IB)).
C                (Case (IB .EQ. IA) is taken care of by initialization
C                 of VALUE to ZERO.)
               IF (IB .GT. IA)  THEN
C                         ---------------------------------------------
                  VALUE = DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERD)
C                         ---------------------------------------------
                  IF (IERD .LT. 0)  GO TO 5004
               ENDIF
C
C              THEN ADD ON INTEGRAL OVER (XA,X(IA)).
               IF (XA .LT. X(IA))  THEN
                  IL = MAX(1, IA-1)
                  IR = IL + 1
C                                 -------------------------------------
                  VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR),
     +                                      D(1,IL),D(1,IR), XA, X(IA))
C                                 -------------------------------------
               ENDIF
C
C              THEN ADD ON INTEGRAL OVER (X(IB),XB).
               IF (XB .GT. X(IB))  THEN
                  IR = MIN (IB+1, N)
                  IL = IR - 1
C                                 -------------------------------------
                  VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR),
     +                                      D(1,IL),D(1,IR), X(IB), XB)
C                                 -------------------------------------
               ENDIF
C
C              FINALLY, ADJUST SIGN IF NECESSARY.
               IF (A .GT. B)  VALUE = -VALUE
            ENDIF
         ENDIF
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      DPCHIA = VALUE
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHIA',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      GO TO 5000
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHIA', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      GO TO 5000
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHIA',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      GO TO 5000
C
 5004 CONTINUE
C     TROUBLE IN DPCHID.  (SHOULD NEVER OCCUR.)
      IERR = -4
      CALL XERMSG ('SLATEC', 'DPCHIA', 'TROUBLE IN DPCHID', IERR, 1)
      GO TO 5000
C------------- LAST LINE OF DPCHIA FOLLOWS -----------------------------
      END


subroutine red2reg(nred,red,nlat,jlon,nlon,reg,ierror)
implicit none

integer, intent(in) :: nred
integer, intent(in) :: nlat
integer, intent(in) :: nlon

real(kind=8), intent(in)  :: red(nred)
integer, intent(in)       :: jlon(nlat)
real(kind=8), intent(out) :: reg(nlat,nlon)
integer, intent(out)      :: ierror

! Local Variables

real(kind=8), dimension(:,:), allocatable :: atmp
real(kind=8), dimension(:), allocatable   :: work
real(kind=8), dimension(:), allocatable   :: wsave

integer :: jlat
integer :: jptr

! ==========================================
! Error tests go here
! ==========================================

ierror=0

! ==========================================
! Forward FFT (real-> complex) the reduced
! grid data_values and store in the
! regular grid array
! ==========================================

reg(:,:) = 0.0_8
jptr=1
do jlat=1,nlat

   ! recompute FFT work arrays only when longitude changes

   if (jlat==1) then
      allocate(wsave(2*jlon(jlat)+15))
      allocate(work(jlon(jlat)))
      allocate(atmp(1,jlon(jlat)))

      call hrffti(jlon(jlat),wsave)
   else if (jlon(jlat) .ne. jlon(jlat-1)) then

      deallocate(wsave)
      deallocate(work)
      deallocate(atmp)

      allocate(wsave(2*jlon(jlat)+15))
      allocate(work(jlon(jlat)))
      allocate(atmp(1,jlon(jlat)))

      call hrffti(jlon(jlat),wsave)
   end if
   atmp(1,1:jlon(jlat)) = red(jptr:jlon(jlat)+jptr-1)
   call hrfftf(1,jlon(jlat),atmp,1,wsave,work)
   reg(jlat,1:jlon(jlat)) = atmp(1,1:jlon(jlat))/jlon(jlat) ! rescale wave numbers
   jptr=jptr+jlon(jlat)
end do

deallocate(wsave)
deallocate(work)
deallocate(atmp)

! =============================
! Inverse FFT (complex to real)
! =============================

allocate(wsave(2*nlon+15))
allocate(work(nlat*nlon))

call hrffti(nlon,wsave)
call hrfftb(nlat,nlon,reg,nlat,wsave,work)

deallocate(wsave)
deallocate(work)

end subroutine red2reg

subroutine reg2red(nlat,jlon,nlon,reg,nred,red,ierror)
implicit none

integer, intent(in) :: nlat
integer, intent(in) :: nlon
integer, intent(in) :: nred

integer, intent(in)                 :: jlon(nlat)
real(kind=8), intent(in)   ::   reg(nlat,nlon)
real(kind=8), intent(out)  :: red(nred)

integer, intent(out)                :: ierror

! Local Variables

real(kind=8), dimension(:,:), allocatable :: atmp, reg1
real(kind=8), dimension(:), allocatable :: work
real(kind=8), dimension(:), allocatable :: wsave

integer :: jlat, i
integer :: jptr

allocate(reg1(nlat,nlon))
reg1 = reg
! ===================================================
! Error tests go here.
! ===================================================

ierror=0

! ===================================================
! Forward FFT (complex to real) the regular grid data
! ===================================================

allocate(wsave(2*nlon+15))
allocate(work(nlat*nlon))

call hrffti(nlon,wsave)
call hrfftf(nlat,nlon,reg1,nlat,wsave,work)

deallocate(wsave)
deallocate(work)

! ==========================================
! Forward FFT (real-> complex) the reduced
! grid data_values and store in the
! regular grid array
! ==========================================

red(:) = 0.0_8
jptr=1
do jlat=1,nlat

   ! recompute FFT work arrays only when longitude changes

   if (jlat==1) then
      allocate(wsave(2*jlon(jlat)+15))
      allocate(work(jlon(jlat)))
      allocate(atmp(1,jlon(jlat)))

      call hrffti(jlon(jlat),wsave)
   else if (jlon(jlat) .ne. jlon(jlat-1)) then

      deallocate(wsave)
      deallocate(work)
      deallocate(atmp)

      allocate(wsave(2*jlon(jlat)+15))
      allocate(work(jlon(jlat)))
      allocate(atmp(1,jlon(jlat)))

      call hrffti(jlon(jlat),wsave)
   end if

   atmp(1,1:jlon(jlat)) = reg1(jlat,1:jlon(jlat))/nlon  ! rescale wave numbers
   call hrfftb(1,jlon(jlat),atmp,1,wsave,work)
   red(jptr:jlon(jlat)+jptr-1) = atmp(1,1:jlon(jlat))

   jptr=jptr+jlon(jlat)
end do

deallocate(wsave)
deallocate(work)
deallocate(atmp)
deallocate(reg1)

end subroutine reg2red

subroutine find_diff(nlats,ngpts,ngpts_perlats,u,un, &
          v,vn,ue,ve,iue,ive,ulat,ulon,vlat,vlon)
implicit none
integer, intent(in) :: nlats,ngpts,ngpts_perlats(nlats)
real(8), dimension(ngpts), intent(in) :: u,un,v,vn
real(8), intent(out) :: ue,ve
integer, intent(out) :: iue, ive, ulat,ulon,vlat,vlon
real(8) :: udf, vdf, uet, vet
integer :: gp, jlat, klon
ue = 0.d0
ve = 0.d0
gp = 0
do jlat = 1, nlats
  do klon = 1, ngpts_perlats(jlat)
    gp = gp + 1
    udf = u(gp) - un(gp)
    uet = udf/u(gp)
    if(abs(uet).ge.abs(ue)) then
       ue = uet
       iue = gp
       ulat = jlat
       ulon = klon
    endif
    vdf = v(gp) - vn(gp)
    vet = vdf/v(gp)
    if(abs(vet).ge.abs(ve)) then
       ve = vet
       ive = gp
       vlat = jlat
       vlon = klon
    endif
  end do
end do
end subroutine find_diff


subroutine inverse(np,a,y)
integer np
real a(np,np)
real y(np,np)
integer indx(np)
integer i
integer j
real d
do i=1,np
   do j=1,np
   y(i,j)=0.0
   end do
   y(i,i)=1.0
end do

call ludcmp_i(a,np,np,indx,d)
do j=1,np

   call lubksb_i(a,np,np,indx,y(1,j))

end do
return
end

      SUBROUTINE lubksb_i(a,n,np,indx,b)
      INTEGER n,np,indx(n)
      REAL a(np,np),b(n)
      INTEGER i,ii,j,ll
      REAL sum

      ii=0
      do 12 i=1,n
        ll=indx(i)
        sum=b(ll)
        b(ll)=b(i)
        if (ii.ne.0)then
          do 11 j=ii,i-1
            sum=sum-a(i,j)*b(j)
11        continue
        else if (sum.ne.0.) then
          ii=i
        endif
        b(i)=sum
12    continue
      do 14 i=n,1,-1
        sum=b(i)
        do 13 j=i+1,n
          sum=sum-a(i,j)*b(j)
13      continue
        b(i)=sum/a(i,i)
14    continue
      return
      END

            SUBROUTINE ludcmp_i(a,n,np,indx,d)
      INTEGER n,np,indx(n),NMAX
      REAL d,a(np,np),TINY
      PARAMETER (NMAX=500,TINY=1.0e-20)
      INTEGER i,imax,j,k
      REAL aamax,dum,sum,vv(NMAX)
      d=1.
      do 12 i=1,n
        aamax=0.
        do 11 j=1,n
          if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))
11      continue
        if (aamax.eq.0.) pause 'singular matrix in ludcmp'
        vv(i)=1./aamax
12    continue
      do 19 j=1,n
        do 14 i=1,j-1
          sum=a(i,j)
          do 13 k=1,i-1
            sum=sum-a(i,k)*a(k,j)
13        continue
          a(i,j)=sum
14      continue
        aamax=0.
        do 16 i=j,n
          sum=a(i,j)
          do 15 k=1,j-1
            sum=sum-a(i,k)*a(k,j)
15        continue
          a(i,j)=sum
          dum=vv(i)*abs(sum)
          if (dum.ge.aamax) then
            imax=i
            aamax=dum
          endif
16      continue
        if (j.ne.imax)then
          do 17 k=1,n
            dum=a(imax,k)
            a(imax,k)=a(j,k)
            a(j,k)=dum
17        continue
          d=-d
          vv(imax)=vv(j)
        endif
        indx(j)=imax
        if(a(j,j).eq.0.)a(j,j)=TINY
        if(j.ne.n)then
          dum=1./a(j,j)
          do 18 i=j+1,n
            a(i,j)=a(i,j)*dum
18        continue
        endif
19    continue
      return
      END


! 'utility_density.f90' contains a number of fortran functions for getting the
! average density of points in cells vs the the average value of a certain
! parameter within those cells.

subroutine get_counts_2d(x, y, dx, length, length_of_grid, length_of_points, counts)
    ! Gets the density and average parameter in a cell.
    !
    ! Parameters
    ! ----------
    ! x, y : array
    !    The positions of points.
    ! dx : float
    !    The size of each cell in each axis.
    ! length : int
    !    The length along a single axis of the grid.
    ! length_of_points : int
    !    Length of the x and y coordinates.
    ! length_of_grid : int
    !    Length of the x and y grid.
    !
    ! Returns
    ! -------
    ! counts : array
    !    The number of points in each cell.

    implicit none

    integer, intent(in) :: length, length_of_points, length_of_grid
    real, intent(in) :: x(length_of_points), y(length_of_points), dx
    real, intent(out) :: counts(length_of_grid)

    integer :: i, x_index, y_index, index

    do i = 1, length_of_grid
        counts(i) = 0.
    end do

    do i = 1, length_of_points
        x_index = floor(x(i) / dx)
        y_index = floor(y(i) / dx)
        if (x_index .eq. length) then
            x_index = x_index - 1
        end if
        if (y_index .eq. length) then
            y_index = y_index - 1
        end if
        index = length * x_index + y_index + 1
        counts(index) = counts(index) + 1.
    end do

end subroutine get_counts_2d

subroutine get_counts_3d(x, y, z, dx, length, length_of_grid, length_of_points, counts)
    ! Gets the density and average parameter in a cell.
    !
    ! Parameters
    ! ----------
    ! x, y, z : array
    !    The positions of points.
    ! dx : float
    !    The size of each cell in each axis.
    ! length : int
    !    The length along a single axis of the grid.
    ! length_of_points : int
    !    Length of the x and y coordinates.
    ! length_of_grid : int
    !    Length of the x and y grid.
    !
    ! Returns
    ! -------
    ! counts : array
    !    The number of points in each cell.

    implicit none

    integer, intent(in) :: length, length_of_points, length_of_grid
    real, intent(in) :: x(length_of_points), y(length_of_points), z(length_of_points), dx
    real, intent(out) :: counts(length_of_grid)

    integer :: i, x_index, y_index, z_index, index

    do i = 1, length_of_grid
        counts(i) = 0.
    end do

    do i = 1, length_of_points
        x_index = floor(x(i) / dx)
        y_index = floor(y(i) / dx)
        z_index = floor(z(i) / dx)
        if (x_index .eq. length) then
            x_index = x_index - 1
        end if
        if (y_index .eq. length) then
            y_index = y_index - 1
        end if
        if (z_index .eq. length) then
            z_index = z_index - 1
        end if
        index = (length * length * x_index) + (length * y_index) + z_index + 1
        counts(index) = counts(index) + 1.
    end do

end subroutine get_counts_3d

subroutine get_param_2d(x_param, y_param, param, dx, length, length_of_grid, length_of_param, mean_param)
    ! Gets the density and average parameter in a cell.
    !
    ! Parameters
    ! ----------
    ! x_param, y_param : array
    !    The positions associated with the measured parameter.
    ! param : array
    !    An array of the input parameter.
    ! dx : float
    !    The size of each cell in each axis.
    ! length : int
    !    The length along a single axis of the grid.
    ! length_of_points : int
    !    Length of the x and y coordinates.
    ! length_of_grid : int
    !    Length of the x and y grid.
    !
    ! Returns
    ! -------
    ! mean_param : array
    !    The mean of a parameter in each cell.

    implicit none

    integer, intent(in) :: length, length_of_param, length_of_grid
    real, intent(in) :: x_param(length_of_param), y_param(length_of_param), param(length_of_param), dx
    real, intent(out) :: mean_param(length_of_grid)

    integer :: i, x_index, y_index, index
    real :: counts(length_of_grid), total_param(length_of_grid)

    do i = 1, length_of_grid
        total_param(i) = 0.
        mean_param(i) = 0.
        counts(i) = 0.
    end do

    do i = 1, length_of_param
        x_index = floor(x_param(i) / dx)
        y_index = floor(y_param(i) / dx)
        if (x_index .eq. length) then
            x_index = x_index - 1
        end if
        if (y_index .eq. length) then
            y_index = y_index - 1
        end if
        index = (length * x_index) + y_index + 1
        total_param(index) = total_param(index) + param(i)
        counts(index) = counts(index) + 1.
    end do

    do i = 1, length_of_grid
        mean_param(i) = total_param(i) / counts(i)
    end do

end subroutine get_param_2d

subroutine get_param_3d(x_param, y_param, z_param, param, dx, length, length_of_grid, length_of_param, mean_param)
    ! Gets the density and average parameter in a cell.
    !
    ! Parameters
    ! ----------
    ! x_param, y_param, z_param : array
    !    The positions associated with the measured parameter.
    ! param : array
    !    An array of the input parameter.
    ! dx : float
    !    The size of each cell in each axis.
    ! length : int
    !    The length along a single axis of the grid.
    ! length_of_points : int
    !    Length of the x and y coordinates.
    ! length_of_grid : int
    !    Length of the x and y grid.
    !
    ! Returns
    ! -------
    ! mean_param : array
    !    The mean of a parameter in each cell.

    implicit none

    integer, intent(in) :: length, length_of_param, length_of_grid
    real, intent(in) :: x_param(length_of_param), y_param(length_of_param), z_param(length_of_param), param(length_of_param), dx
    real, intent(out) :: mean_param(length_of_grid)

    integer :: i, x_index, y_index, z_index, index
    real :: counts(length_of_grid), total_param(length_of_grid)

    do i = 1, length_of_grid
        total_param(i) = 0.
        mean_param(i) = 0.
        counts(i) = 0.
    end do

    do i = 1, length_of_param
        x_index = floor(x_param(i) / dx)
        y_index = floor(y_param(i) / dx)
        z_index = floor(z_param(i) / dx)
        if (x_index .eq. length) then
            x_index = x_index - 1
        end if
        if (y_index .eq. length) then
            y_index = y_index - 1
        end if
        if (z_index .eq. length) then
            z_index = z_index - 1
        end if
        index = (length * length * x_index) + (length * y_index) + z_index + 1
        total_param(index) = total_param(index) + param(i)
        counts(index) = counts(index) + 1.
    end do

    do i = 1, length_of_grid
        if (counts(i) > 0.) then
            mean_param(i) = total_param(i) / counts(i)
        else
            mean_param(i) = 0.
        end if
    end do

end subroutine get_param_3d


FUNCTION FSBDLD(DIASED,GPDIASED,D50,DEP,PEXP,PHID,CSHIELDS,SBDLDP,ISOPT)

  ! CHANGE RECORD
  !  MODIFED TO INCLUDE ALTERNATE FORMULAS FOR BED LOAD PHI
  !
  !
  ! **  CALCULATES DIMENSIONLESS BED LOAD TRANSPORT COEFFICIENT
  ! **  ISOPT=0  USE CONSTANT VALUE
  !

  IMPLICIT NONE

  INTEGER :: ISOPT
  REAL :: FSBDLD,DIASED,GPDIASED,D50,DEP,PEXP,PHID,CSHIELDS,SBDLDP,RD,TMP,TMP1,TMP2

  IF( ISOPT == 0 ) FSBDLD=SBDLDP

  ! **  ISOPT=1  BASED ON
  ! **
  ! **  VAN RIJN, L. C., 1984: SEDIMENT TRANSPORT, PART I: BED
  ! **  LOAD TRANSPORT, J. HYDRAULIC ENGINEERING, 110, 1431-1455.
  IF( ISOPT == 1 )THEN
    RD=DIASED*SQRT(GPDIASED)*1.E6
    RD=(1./RD)**0.2
    TMP=CSHIELDS**2.1
    FSBDLD=0.053*RD/TMP
  ENDIF

  ! **  ISOPT=2  BASED ON MODIFIED ENGULAND-HANSEN FORMULA
  ! **  REFERENCE TO BE ADDED
  IF( ISOPT == 2 )THEN
    TMP1=(DEP/D50)**0.33333
    TMP2=(PEXP/PHID)**1.125
    FSBDLD=2.0367*TMP1*TMP2
  ENDIF

  ! **  ISOPT=3  BASED ON WU, WANG AND JIA, J. HYDR. RES. V38, 2000
  IF( ISOPT == 3 )THEN
    TMP1=0.03*((PHID/PEXP)**0.6)
    TMP2=TMP1**2.2
    FSBDLD=0.0053/TMP2
  ENDIF

END FUNCTION


! This file is part of mctc-lib.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

!> Conversion factors
module mctc_io_convert
   use mctc_env_accuracy, only : wp
   use mctc_io_constants, only : pi, codata
   implicit none
   private

   !> Reducted Planck's constant
   real(wp), parameter :: hbar = codata%h/(2.0_wp*pi) ! J·s = kg·m²·s⁻¹

   !> Bohr radius
   real(wp), parameter :: bohr = hbar/(codata%me*codata%c*codata%alpha) ! m

   !> Hartree energy
   real(wp), parameter :: hartree = codata%me*codata%c**2*codata%alpha**2 ! J = kg·m²·s⁻²

   !> Conversion factor from bohr to Ångström
   real(wp), public, parameter :: autoaa = bohr * 1e10_wp

   !> Conversion factor from Ångström to bohr
   real(wp), public, parameter :: aatoau = 1.0_wp/autoaa

   !> Conversion factor from hartree to electron volts
   real(wp), public, parameter :: autoeV = hartree/codata%e

   !> Conversion factor from electron volts to hartree
   real(wp), public, parameter :: evtoau = 1.0_wp/autoev

   !> Coversion factor between calorine and joule
   real(wp), public, parameter :: caltoj = 4.184_wp

   !> Coversion factor between joule and calorine
   real(wp), public, parameter :: jtocal = 1.0_wp/caltoj

   !> Conversion from hartree to kJ/mol
   real(wp), public, parameter :: autokj = hartree*codata%na*1e-3_wp

   !> Conversion from kJ/mol to hartree
   real(wp), public, parameter :: kjtoau = 1.0_wp/autokj

   !> Conversion from hartree to kcal/mol
   real(wp), public, parameter :: autokcal = autokJ*Jtocal

   !> Conversion from kcal/mol to hartree
   real(wp), public, parameter :: kcaltoau = 1.0_wp/autokcal

   !> Conversion from hartree to reciprocal centimeters
   real(wp), public, parameter :: autorcm = hartree/(codata%h*codata%c)*1e-2_wp

   !> Conversion from reciprocal centimeters to hartree
   real(wp), public, parameter :: rcmtoau = 1.0_wp/autorcm

   !> Conversion from hartree to nanometers (wavelength)
   real(wp), public, parameter :: autonm = codata%h*codata%c/hartree * 1e+9_wp

   !> Conversion from nanometers (wavelength) to hartree
   real(wp), public, parameter :: nmtoau = 1.0_wp/autonm

   !> Conversion from electron mass (a.u.) to kg
   real(wp), public, parameter :: autokg = codata%me

   !> Conversion from kg to electron mass (a.u.)
   real(wp), public, parameter :: kgtoau = 1.0_wp/autokg

   !> Molecular mass per mole (g/mol) to electron mass (a.u.)
   real(wp), public, parameter :: autogmol = codata%me*codata%na*1e+3_wp

   !> Electron mass (a.u.) to molecular mass per mole (g/mol)
   real(wp), public, parameter :: gmoltoau = 1.0_wp/autogmol

   !> Molecular mass per mole (g/mol) to kg
   real(wp), public, parameter :: gmoltokg = gmoltoau*autokg

   !> kg to molecular mass per mole (g/mol)
   real(wp), public, parameter :: kgtogmol = 1.0_wp/gmoltokg

   !> Coulomb to atomic charge units
   real(wp), public, parameter :: autoc = codata%e

   !> Atomic charge units to Coulomb
   real(wp), public, parameter :: ctoau = 1.0_wp/autoc

end module mctc_io_convert


!> \file mo_spatialsimilarity.f90

!> \brief Routines for bias insensitive comparison of spatial patterns.

!> \details These routines are based on the idea that spatial similarity can be assessed by comparing
!>          the magnitude of neighboring pixels (e.g. is the neighboring pixel larger or smaller).

!> \author Matthias Zink, Juliane Mai
!> \date Mar 2013

MODULE mo_spatialsimilarity

  ! This module contains routines for the masked calculation of
  ! spatial similarity measures like NDV

  ! Written Nov 2012, Matthias Zink and Juliane Mai

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2012-2015 Matthias Zink, Juliane Mai
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind,   ONLY: i4, sp, dp

  IMPLICIT NONE

  PUBLIC :: NNDV       ! number of neighboring dominating values
  PUBLIC :: PD         ! patter dissimilarity measure

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

  !     NAME
  !         NNDV - number of neighboring dominating values

  !     PURPOSE
  !>         \brief    Calculates the number of neighboring dominating values, a measure for spatial dissimilarity.
  !>         \details
  !>             NNDV             = 1 - sum(abs(dominating_neighbors(mat1) - dominating_neighbors(mat2))) / count(mask)
  !>             dominating_neighbors(mat1) = comparison if pixel is larger than its neighbouring values
  !>
  !>            An array element value is compared with its 8 neighbouring cells to check if these cells are larger
  !>            than the array element value. The result is a 3x3 matrix in which larger cells are indicated by a
  !>            true value. For comparison this is done with both input arrays. The resulting array is the sum of
  !>            substraction of the 3x3 matrices for each of the both arrays. The resulting matrix is afterwards
  !>            normalized to its available neighbors.
  !>            Furthermore an average over the entire field is calculated. The valid interval of
  !>            the values for NNDV is [0..1]. In which 1 indicates full agreement and 0 full dismatching.
  !>

  !>            EXAMPLE:\n
  !>            mat1 =  | 12 17  1 | , mat2 = |  7  9 12 |
  !>                    |  4 10 11 |          | 12 11 11 |
  !>                    | 15  2 20 |          |  5 13  7 |
  !>            booleans determined for every grid cell following fortran array scrolling
  !>            i.e. (/col1_row1, col1_row2, col1_row3, col2_row1, .. ,col3_row3/),(/3,3/)
  !>
  !>            comp1 = | FFF FFF FTF, FFF FFF FFF, FTT FFT FFF |
  !>                    | FFF TFT TTF, TFT TFF FTT, TFF FFT FFF |
  !>                    | FFF FFF FFF, TTF TFF TTF, FFF FFF FFF |
  !>
  !>            comp2 = | FFF FFT FTT, FFT FFT FTT, FFF FFF FFF |
  !>                    | FFF FFF FFT, FTF FFT TFF, FFT TFF FFF |
  !>                    | FFF TFF TTF, FFF FFF FFF, TTF TFF FFF |
  !>
  !>           NNDVMatrix =
  !>           abs( count(comp1) - count(comp2) ) = | 1-3, 0-4, 3-0 | = | 2, 4, 3 |
  !>                                                | 4-1, 5-3, 2-2 |   | 3, 2, 0 |
  !>                                                | 0-3, 5-0, 0-3 |   | 3, 5, 3 |
  !>
  !>                                    DISSIMILAR / VALID NEIGH CELLS
  !>           NNDVMatrix / VALID NEIGH CELLS = | 2, 4, 3 | / | 3, 5, 3 |
  !>                                            | 3, 2, 0 |   | 5, 8, 5 |
  !>                                            | 3, 5, 3 |   | 3, 5, 3 |
  !>
  !>                                          = | 0.66, 0.80, 1.00 |
  !>                                            | 0.60, 0.25, 0.00 |
  !>                                            | 1.0,  1.00, 1.00 |
  !>
  !>           NNDV = 1 - sum(NNDVMatrix) / count(mask) = 1 - (6.31666666 / 9) = 0.2981
  !>

  !>
  !>           If an optinal mask is given, the calculations are over those locations that correspond to true values in the mask.
  !>           mat1 and mat2 can be single or double precision. The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !         out = NNDV(mat1, mat2, mask=mask, valid=valid)

  !     INDENT(IN)
  !>        \param[in] "real(sp/dp), dimension(:,:) :: mat1" 2D-array with input numbers
  !>        \param[in] "real(sp/dp), dimension(:,:) :: mat2" 2D-array with input numbers

  !     INDENT(INOUT)
  !         None

  !     INDENT(OUT)
  !        None

  !     INDENT(IN), OPTIONAL
  !>        \param[in] "logical,dimension(:,:),optinal :: mask" 2D-array of logical values with size(mat1/mat2).
  !>           If present, only those locations in mat1/mat2 having true values in mask are evaluated.

  !     INDENT(INOUT), OPTIONAL
  !         None

  !     INDENT(OUT), OPTIONAL
  !>        \param[out] "logical              :: valid"   indicates if the function could determine a valid value
  !>                                                      result can be unvalid if entire mask is .false. for ex.
  !>                                                      in this case PatternDissim is set to 0 (worst case)

  !     RETURN
  !>        \return real(sp/dp) :: NNDV — Number of neighboring dominating values

  !     RESTRICTIONS
  !         Input values must be floating points.

  !     EXAMPLE
  !         mat1 = reshape(/ 1., 2, 3., -999., 5., 6. /, (/3,3/))
  !         mat2 = reshape(/ 1., 2, 3., -999., 5., 6. /, (/3,3/))
  !         out  = NNDV(mat1, mat2, mask=(mat1 >= 0. .and. mat2 >= 0.))
  !         -> see also example in test directory

  !     LITERATURE
  !>         \note routine based on algorithm by Luis Samaniego 2009

  !     HISTORY
  !>         \author Matthias Zink
  !>         \date   Nov 2012
  !          update  May 2015 created documentation
  INTERFACE NNDV
     MODULE PROCEDURE NNDV_sp, NNDV_dp
  END INTERFACE NNDV

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

  !     NAME
  !         PD

  !     PURPOSE
  !>         \brief Calculates pattern dissimilarity (PD) measure
  !>         \details
  !>             PD             = 1 - sum(dissimilarity(mat1, mat2)) / count(mask)
  !>             dissimilarity(mat1, mat2) = comparison if pixel is larger than its neighbouring values
  !>
  !>            An array element value is compared with its 8 neighbouring cells to check if these cells are larger
  !>            than the array element value. The result is a 3x3 matrix in which larger cells are indicated by a
  !>            true value. For comparison this is done with both input arrays. The resulting array is the sum of
  !>            xor values of the 3x3 matrices for each of the both arrays.  This means only neighbourhood comparisons
  !>            which are different in the 2 matrices are counted. This resulting matrix is afterwards normalized to its
  !>            available neighbors. Furthermore an average over the entire field is calculated. The valid interval of
  !>            the values for PD is [0..1]. In which 1 indicates full agreement and 0 full dismatching.
  !>
  !>

  !>            EXAMPLE:\n
  !>            mat1 =  | 12 17  1 | , mat2 = |  7  9 12 |
  !>                    |  4 10 11 |          | 12 11 11 |
  !>                    | 15  2 20 |          |  5 13  7 |
  !>
  !>            booleans determined for every grid cell following fortran array scrolling
  !>            i.e. (/col1_row1, col1_row2, col1_row3, col2_row1, .. ,col3_row3/),(/3,3/)
  !>
  !>            comp1 = | FFF FFF FTF, FFF FFF FFF, FTT FFT FFF |
  !>                    | FFF TFT TTF, TFT TFF FTT, TFF FFT FFF |
  !>                    | FFF FFF FFF, TTF TFF TTF, FFF FFF FFF |
  !>
  !>            comp2 = | FFF FFT FTT, FFT FFT FTT, FFF FFF FFF |
  !>                    | FFF FFF FFT, FTF FFT TFF, FFT TFF FFF |
  !>                    | FFF TFF TTF, FFF FFF FFF, TTF TFF FFF |
  !>
  !>
  !>            xor=neq = | FFF FFT FFT, FFT FFT FTT, FTT FFT FFF |
  !>                      | FFF TFT TTT, TTT TFT TTT, TFT TFT FFF |
  !>                      | FFF TFF TTF, TTF TFF TTF, TTF TFF FFF |
  !>
  !>                        DISSIMILAR / VALID NEIGH CELLS
  !>            PDMatrix = | 2, 4, 3 | / | 3, 5, 3 | = | 0.66, 0.80, 1.00 |
  !>                       | 5, 8, 4 |   | 5, 8, 5 |   | 1.00, 1.00, 0.80 |
  !>                       | 3, 5, 3 |   | 3, 5, 3 |   | 1.00, 1.00, 1.00 |
  !>
  !>           PD = 1 - sum(PDMatrix) / count(mask) = 1 - (8.2666666 / 9) = 0.08148
  !>

  !>
  !>           If an optinal mask is given, the calculations are over those locations that correspond to true values in the mask.
  !>           mat1 and mat2 can be single or double precision. The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !         out = PD(mat1, mat2, mask=mask, valid=valid)

  !     INDENT(IN)
  !>        \param[in] "real(sp/dp), dimension(:,:) :: mat1" 2D-array with input numbers
  !>        \param[in] "real(sp/dp), dimension(:,:) :: mat2" 2D-array with input numbers

  !     INDENT(INOUT)
  !         None

  !     INDENT(OUT)
  !         None

  !     INDENT(IN), OPTIONAL
  !>        \param[in] "logical,dimension(:,:),optinal :: mask" 2D-array of logical values with size(mat1/mat2)
  !>           If present, only those locations in mat1/mat2 having true values in mask are evaluated.

  !     INDENT(INOUT), OPTIONAL
  !         None

  !     INDENT(OUT), OPTIONAL
  !>        \param[out] "logical,optinal :: valid"   indicates if the function could determine a valid value
  !>                                                      result can be unvalid if entire mask is .false. for ex.
  !>                                                      in this case PD is set to 0 (worst case)

  !     RETURN
  !>        \return real(sp/dp) :: PD — pattern dissimilarity measure

  !     RESTRICTIONS
  !         Input values must be floating points.

  !     EXAMPLE
  !         mat1 = reshape(/ 1., 2, 3., -999., 5., 6. /, (/3,3/))
  !         mat2 = reshape(/ 1., 2, 3., -999., 5., 6. /, (/3,3/))
  !         out  = PD(mat1, mat2, mask=(mat1 >= 0. .and. mat2 >= 0.))
  !         -> see also example in test directory

  !     LITERATURE
  !          None

  !     HISTORY
  !>         \author Matthias Zink and Juliane Mai
  !>         \date   Jan 2013
  INTERFACE PD
     MODULE PROCEDURE PD_sp, PD_dp
  END INTERFACE PD

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

CONTAINS

  FUNCTION NNDV_sp(mat1, mat2, mask, valid)

    IMPLICIT NONE

    REAL(sp),    DIMENSION(:,:),                                            INTENT(IN)  :: mat1, mat2
    LOGICAL,     DIMENSION(:,:),                                  OPTIONAL, INTENT(IN)  :: mask
    LOGICAL,                                                      OPTIONAL, INTENT(OUT) :: valid
    REAL(sp)                                                                            :: NNDV_sp

    INTEGER(i4)                                                                         :: iCo, iRo
    INTEGER(i4)                                                                         :: noValidPixels
    INTEGER(i4), DIMENSION(size(shape(mat1)) )                                          :: shapemask
    INTEGER(i4), DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: validcount
    REAL(sp),    DIMENSION(size(mat1, dim=1)+2_i4, size(mat1, dim=2)+2_i4)              :: bufferedMat1, bufferedMat2
    REAL(sp)   , DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: NNDVMatrix
    LOGICAL,     DIMENSION(size(mat1, dim=1)+2_i4, size(mat1, dim=2)+2_i4)              :: maske
    LOGICAL,     DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: validmaske

    ! check if input has all the same dimensions
    if (present(mask)) then
       shapemask = shape(mask)
    else
       shapemask = shape(mat1)
    end if
    !
    if (any(shape(mat1) .NE. shape(mat2)))  &
         stop 'NNDV_sp: shapes of input matrix 1 and input matrix 2 are not matching'
    if (any(shape(mat1) .NE. shapemask))    &
         stop 'NNDV_sp: shapes of input matrices and mask are not matching'
    !
    ! additional 2 rows and 2 cols added for checking the border cells without crashing the search agorithm
    ! so the search windows can always cover 9 cells even if it is checking a border cell
    ! buffer rows are initialized as false values within mask, i.e. they are not considered for the calculation
    ! of the criteria
    !
    ! initialize mask with default=.false.
    maske = .false.
    if (present(mask)) then
       maske(2:(size(maske,dim=1)-1_i4), 2:(size(maske,dim=2)-1_i4)) = mask
    else
       maske(2:(size(maske,dim=1)-1_i4), 2:(size(maske,dim=2)-1_i4)) = .true.
    end if
    !
    ! initialize bufferedMat1 & bufferedMat2
    bufferedMat1 = 0.0_sp
    bufferedMat2 = 0.0_sp
    bufferedMat1(2:(size(maske,dim=1)-1), 2:(size(maske,dim=2)-1)) = mat1
    bufferedMat2(2:(size(maske,dim=1)-1), 2:(size(maske,dim=2)-1)) = mat2
    !
    ! initialize NNDV
    NNDVMatrix = 0.0_sp
    !
    NNDV_sp = 0.0_sp
    do iCo = 2_i4, size(bufferedMat1, dim=2) - 1
       do iRo = 2_i4, size(bufferedMat1, dim=1) - 1
          if (.NOT. maske(iRo,iCo)) cycle
          NNDVMatrix(iRo-1_i4,iCo-1_i4) =   &
               real(    &
                  abs(  &
                     count((bufferedMat1(iRo-1:iRo+1 , iCo-1:iCo+1) - bufferedMat1(iRo,iCo) > epsilon(0.0_sp)) .AND. &
                           (maske(iRo-1:iRo+1 , iCo-1:iCo+1))) -                                                     &
                     count((bufferedMat2(iRo-1:iRo+1 , iCo-1:iCo+1) - bufferedMat2(iRo,iCo) > epsilon(0.0_sp)) .AND. &
                           (maske(iRo-1:iRo+1 , iCo-1:iCo+1)))                                                       &
                  ),    &
               sp)
          ! count - 1 to exclude referendce cell (iRo, iCo)
          validcount(iRo-1_i4,iCo-1_i4) = count(maske(iRo-1_i4:iRo+1_i4 , iCo-1_i4:iCo+1_i4)) - 1_i4
        end do
    end do
    !
    ! normalize every pixel to number of valid neighbouring cells (defined by maske) [0..8] --> [0..1]
    validmaske = (maske(2:size(maske, dim=1) - 1_i4, 2:size(maske, dim=2) - 1_i4) .and. (validcount > 0_i4))
    noValidPixels = count(validmaske)
    if (noValidPixels .GT. 0_i4) then
       NNDVMatrix = merge(NNDVMatrix/real(validcount, sp),NNDVMatrix, validmaske)
       ! average over all pixels
       NNDV_sp = 1.0_sp - sum(NNDVMatrix, mask=validmaske) / noValidPixels
       if (present(valid)) valid = .TRUE.
    ! case if maske is full of .false. or no valid neighbouring cells available for every pixel (validcount(:,:)=0)
    else
       NNDV_sp = 0.0_sp
       if (present(valid)) valid = .FALSE.
    end if
    !
  END FUNCTION NNDV_sp

 FUNCTION NNDV_dp(mat1, mat2, mask, valid)

    IMPLICIT NONE

    REAL(dp),    DIMENSION(:,:),                                            INTENT(IN)  :: mat1, mat2
    LOGICAL,     DIMENSION(:,:),                                  OPTIONAL, INTENT(IN)  :: mask
    LOGICAL,                                                      OPTIONAL, INTENT(OUT) :: valid
    REAL(dp)                                                                            :: NNDV_dp

    INTEGER(i4)                                                                         :: iCo, iRo
    INTEGER(i4)                                                                         :: noValidPixels
    INTEGER(i4), DIMENSION(size(shape(mat1)) )                                          :: shapemask
    INTEGER(i4), DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: validcount
    REAL(dp),    DIMENSION(size(mat1, dim=1)+2_i4, size(mat1, dim=2)+2_i4)              :: bufferedMat1, bufferedMat2
    REAL(dp)   , DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: NNDVMatrix
    LOGICAL,     DIMENSION(size(mat1, dim=1)+2_i4, size(mat1, dim=2)+2_i4)              :: maske
    LOGICAL,     DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: validmaske

    ! check if input has all the same dimensions
    if (present(mask)) then
       shapemask = shape(mask)
    else
       shapemask = shape(mat1)
    end if
    !
    if (any(shape(mat1) .NE. shape(mat2)))  &
         stop 'NNDV_dp: shapes of input matrix 1 and input matrix 2 are not matching'
    if (any(shape(mat1) .NE. shapemask))    &
         stop 'NNDV_dp: shapes of input matrices and mask are not matching'
    !
    ! additional 2 rows and 2 cols added for checking the border cells without crashing the search agorithm
    ! so the search windows can always cover 9 cells even if it is checking a border cell
    ! buffer rows are initialized as false values within mask, i.e. they are not considered for the calculation
    ! of the criteria
    !
    ! initialize mask with default=.false.
    maske = .false.
    if (present(mask)) then
       maske(2:(size(maske,dim=1)-1_i4), 2:(size(maske,dim=2)-1_i4)) = mask
    else
       maske(2:(size(maske,dim=1)-1_i4), 2:(size(maske,dim=2)-1_i4)) = .true.
    end if
    !
    ! initialize bufferedMat1 & bufferedMat2
    bufferedMat1 = 0.0_dp
    bufferedMat2 = 0.0_dp
    bufferedMat1(2:(size(maske,dim=1)-1), 2:(size(maske,dim=2)-1)) = mat1
    bufferedMat2(2:(size(maske,dim=1)-1), 2:(size(maske,dim=2)-1)) = mat2
    !
    ! initialize NNDV
    NNDVMatrix = 0.0_dp
    !
    NNDV_dp = 0.0_dp
    do iCo = 2_i4, size(bufferedMat1, dim=2) - 1
       do iRo = 2_i4, size(bufferedMat1, dim=1) - 1
          if (.NOT. maske(iRo,iCo)) cycle
          NNDVMatrix(iRo-1_i4,iCo-1_i4) =   &
               real(    &
                  abs(  &
                     count((bufferedMat1(iRo-1:iRo+1 , iCo-1:iCo+1) - bufferedMat1(iRo,iCo) > epsilon(0.0_dp)) .AND. &
                           (maske(iRo-1:iRo+1 , iCo-1:iCo+1))) -                                                     &
                     count((bufferedMat2(iRo-1:iRo+1 , iCo-1:iCo+1) - bufferedMat2(iRo,iCo) > epsilon(0.0_dp)) .AND. &
                           (maske(iRo-1:iRo+1 , iCo-1:iCo+1)))                                                       &
                  ),    &
               dp)
          ! count - 1 to exclude referendce cell (iRo, iCo)
          validcount(iRo-1_i4,iCo-1_i4) = count(maske(iRo-1_i4:iRo+1_i4 , iCo-1_i4:iCo+1_i4)) - 1_i4
        end do
    end do
    !
    ! normalize every pixel to number of valid neighbouring cells (defined by maske) [0..8] --> [0..1]
    validmaske = (maske(2:size(maske, dim=1) - 1_i4, 2:size(maske, dim=2) - 1_i4) .and. (validcount > 0_i4))
    noValidPixels = count(validmaske)
    if (noValidPixels .GT. 0_i4) then
       NNDVMatrix = merge(NNDVMatrix/real(validcount, dp),NNDVMatrix, validmaske)
       ! average over all pixels
       NNDV_dp = 1.0_dp - sum(NNDVMatrix, mask=validmaske) / noValidPixels
       if (present(valid)) valid = .TRUE.
    ! case if maske is full of .false. or no valid neighbouring cells available for every pixel (validcount(:,:)=0)
    else
       NNDV_dp = 0.0_dp
       if (present(valid)) valid = .FALSE.
    end if
    !
  END FUNCTION NNDV_dp

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

  FUNCTION PD_sp(mat1, mat2, mask, valid)

    IMPLICIT NONE

    REAL(sp),    DIMENSION(:,:),                                            INTENT(IN)  :: mat1, mat2
    LOGICAL,     DIMENSION(:,:)                                 , OPTIONAL, INTENT(IN)  :: mask
    LOGICAL,                                                      OPTIONAL, INTENT(OUT) :: valid
    REAL(sp)                                                                            :: PD_sp

    INTEGER(i4)                                                                         :: iCo, iRo
    INTEGER(i4)                                                                         :: noValidPixels
    INTEGER(i4), DIMENSION(size(shape(mat1)) )                                          :: shapemask
    INTEGER(i4), DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: validcount
    REAL(sp),    DIMENSION(size(mat1, dim=1)+2_i4, size(mat1, dim=2)+2_i4)              :: bufferedMat1, bufferedMat2
    REAL(sp),    DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: PDMatrix
    LOGICAL,     DIMENSION(size(mat1, dim=1)+2_i4, size(mat1, dim=2)+2_i4)              :: maske
    LOGICAL,     DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: validmaske
    ! check if input has all the same dimensions
    if (present(mask)) then
       shapemask = shape(mask)
    else
       shapemask = shape(mat1)
    end if
    !
    if (any(shape(mat1) .NE. shape(mat2)))  &
         stop 'PD_sp: shapes of input matrix 1 and input matrix 2 are not matching'
    if (any(shape(mat1) .NE. shapemask))    &
         stop 'PD_sp: shapes of input matrices and mask are not matching'
    !
    ! additional 2 rows and 2 cols added for checking the border cells without crashing the search agorithm
    ! so the search windows can always cover 9 cells even if it is checking a border cell
    ! buffer rows are initialized as false values within mask, i.e. they are not considered for the calculation
    ! of the criteria
    !
    ! initialize mask with default=.false.
    maske = .false.
    if (present(mask)) then
       maske(2:(size(maske,dim=1)-1_i4), 2:(size(maske,dim=2)-1_i4)) = mask
    else
       maske(2:(size(maske,dim=1)-1_i4), 2:(size(maske,dim=2)-1_i4)) = .true.
    end if
    !
    ! initialize bufferedMat1 & bufferedMat2
    bufferedMat1 = 0.0_sp
    bufferedMat2 = 0.0_sp
    bufferedMat1(2:(size(maske,dim=1)-1), 2:(size(maske,dim=2)-1)) = mat1
    bufferedMat2(2:(size(maske,dim=1)-1), 2:(size(maske,dim=2)-1)) = mat2
    !
    ! initialize PD
    PDMatrix = 0.0_sp
    do iCo = 2_i4, size(bufferedMat1, dim=2)-1_i4
       do iRo = 2_i4, size(bufferedMat1, dim=1)-1_i4
          ! no calculation at unmasked values
          if (.NOT. maske(iRo,iCo)) cycle
          ! .NEQV. is the fortran standard for .XOR.
          ! result is written to -1 column and row because of buffer
          PDMatrix(iRo-1_i4,iCo-1_i4) = &
            real( &
              count( &
                     ( &
                        ! determine higher neighbouring values in mat1
                        (bufferedMat1(iRo-1_i4:iRo+1_i4, iCo-1_i4:iCo+1_i4) -                         &
                         bufferedMat1(iRo,iCo)                              > epsilon(0.0_sp)) .NEQV. &
                        ! determine higher neighbouring values in mat2                                &
                        (bufferedMat2(iRo-1_i4:iRo+1_i4, iCo-1_i4:iCo+1_i4) -                         &
                         bufferedMat2(iRo,iCo)                              > epsilon(0.0_sp))        &
                     ) &
                  ! exclude unmasked values
                  .and. (maske(iRo-1_i4:iRo+1_i4 , iCo-1_i4:iCo+1_i4)) &
                  ), &
            sp )
          ! count - 1 to exclude reference cell / center pixel (iRo, iCo)
          validcount(iRo-1_i4,iCo-1_i4) = count(maske(iRo-1_i4:iRo+1_i4 , iCo-1_i4:iCo+1_i4)) - 1_i4
          !
       end do
    end do
    !
    ! normalize every pixel to number of valid neighbouring cells (defined by maske) [0..8] --> [0..1]
    validmaske = (maske(2:size(maske, dim=1) - 1_i4, 2:size(maske, dim=2) - 1_i4) .and. (validcount > 0_i4))
    noValidPixels = count(validmaske)
    if (noValidPixels .GT. 0_i4) then
       PDMatrix = merge(PDMatrix/real(validcount, sp),PDMatrix, validmaske)
       ! average over all pixels
       PD_sp = 1.0_sp - sum(PDMatrix, mask=validmaske) / noValidPixels
       if (present(valid)) valid = .TRUE.
    ! case if maske is full of .false. or no valid neighbouring cells available for every pixel (validcount(:,:)=0)
    else
       PD_sp = 0.0_sp
       if (present(valid)) valid = .FALSE.
    end if
    !
  END FUNCTION PD_sp

  FUNCTION PD_dp(mat1, mat2, mask, valid)

    IMPLICIT NONE

    REAL(dp),    DIMENSION(:,:),                                            INTENT(IN)  :: mat1, mat2
    LOGICAL,     DIMENSION(:,:)                                 , OPTIONAL, INTENT(IN)  :: mask
    LOGICAL,                                                      OPTIONAL, INTENT(OUT) :: valid
    REAL(dp)                                                                            :: PD_dp

    INTEGER(i4)                                                                         :: iCo, iRo
    INTEGER(i4)                                                                         :: noValidPixels
    INTEGER(i4), DIMENSION(size(shape(mat1)) )                                          :: shapemask
    INTEGER(i4), DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: validcount
    REAL(dp),    DIMENSION(size(mat1, dim=1)+2_i4, size(mat1, dim=2)+2_i4)              :: bufferedMat1, bufferedMat2
    REAL(dp),    DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: PDMatrix
    LOGICAL,     DIMENSION(size(mat1, dim=1)+2_i4, size(mat1, dim=2)+2_i4)              :: maske
    LOGICAL,     DIMENSION(size(mat1, dim=1), size(mat1, dim=2))                        :: validmaske
    ! check if input has all the same dimensions
    if (present(mask)) then
       shapemask = shape(mask)
    else
       shapemask = shape(mat1)
    end if
    !
    if (any(shape(mat1) .NE. shape(mat2)))  &
         stop 'PD_dp: shapes of input matrix 1 and input matrix 2 are not matching'
    if (any(shape(mat1) .NE. shapemask))    &
         stop 'PD_dp: shapes of input matrices and mask are not matching'
    !
    ! additional 2 rows and 2 cols added for checking the border cells without crashing the search agorithm
    ! so the search windows can always cover 9 cells even if it is checking a border cell
    ! buffer rows are initialized as false values within mask, i.e. they are not considered for the calculation
    ! of the criteria
    !
    ! initialize mask with default=.false.
    maske = .false.
    if (present(mask)) then
       maske(2:(size(maske,dim=1)-1_i4), 2:(size(maske,dim=2)-1_i4)) = mask
    else
       maske(2:(size(maske,dim=1)-1_i4), 2:(size(maske,dim=2)-1_i4)) = .true.
    end if
    !
    ! initialize bufferedMat1 & bufferedMat2
    bufferedMat1 = 0.0_dp
    bufferedMat2 = 0.0_dp
    bufferedMat1(2:(size(maske,dim=1)-1), 2:(size(maske,dim=2)-1)) = mat1
    bufferedMat2(2:(size(maske,dim=1)-1), 2:(size(maske,dim=2)-1)) = mat2
    !
    ! initialize PD
    PDMatrix = 0.0_dp
    do iCo = 2_i4, size(bufferedMat1, dim=2)-1_i4
       do iRo = 2_i4, size(bufferedMat1, dim=1)-1_i4
          ! no calculation at unmasked values
          if (.NOT. maske(iRo,iCo)) cycle
          ! .NEQV. is the fortran standard for .XOR.
          ! result is written to -1 column and row because of buffer
          PDMatrix(iRo-1_i4,iCo-1_i4) = &
            real( &
              count( &
                     ( &
                        ! determine higher neighbouring values in mat1
                        (bufferedMat1(iRo-1_i4:iRo+1_i4, iCo-1_i4:iCo+1_i4) -                         &
                         bufferedMat1(iRo,iCo)                              > epsilon(0.0_dp)) .NEQV. &
                        ! determine higher neighbouring values in mat2                                &
                        (bufferedMat2(iRo-1_i4:iRo+1_i4, iCo-1_i4:iCo+1_i4) -                         &
                         bufferedMat2(iRo,iCo)                              > epsilon(0.0_dp))        &
                     ) &
                  ! exclude unmasked values
                  .and. (maske(iRo-1_i4:iRo+1_i4 , iCo-1_i4:iCo+1_i4)) &
                  ), &
            dp )
          ! count - 1 to exclude referendce cell (iRo, iCo)
          validcount(iRo-1_i4,iCo-1_i4) = count(maske(iRo-1_i4:iRo+1_i4 , iCo-1_i4:iCo+1_i4)) - 1_i4
          !
       end do
    end do
    !
    ! normalize every pixel to number of valid neighbouring cells (defined by maske) [0..8] --> [0..1]
    validmaske = (maske(2:size(maske, dim=1) - 1_i4, 2:size(maske, dim=2) - 1_i4) .and. (validcount > 0_i4))
    noValidPixels = count(validmaske)
    if (noValidPixels .GT. 0_i4) then
       PDMatrix = merge(PDMatrix/real(validcount, dp),PDMatrix, validmaske)
       ! average over all pixels
       PD_dp = 1.0_dp - sum(PDMatrix, mask=validmaske) / noValidPixels
       if (present(valid)) valid = .TRUE.
    ! case if maske is full of .false. or no valid neighbouring cells available for every pixel (validcount(:,:)=0)
    else
       PD_dp = 0.0_dp
       if (present(valid)) valid = .FALSE.
    end if
    !
  END FUNCTION PD_dp
  !
END MODULE mo_spatialsimilarity


! train (and optionally optimize) a sparse GP from data files

program gp_in
  use m_util
  use m_gp
  use m_gp_sparse
  use m_gp_dense
  use m_gp_optim
  use m_cov_all
  use m_noise_all

  implicit none

!  type(SparseGP) :: gp
  class(BaseGP), allocatable :: gp

  ! number of training points, sparse points and dimension of the input
  integer :: n, nsparse, input_dimension
  ! unit number
  integer :: u
  ! loop counter
  integer :: i
  ! number of hyperparameters and noise parameters required
  integer :: ntheta, nnu

  real(dp), dimension(:), allocatable :: theta, nu, t, lbounds, ubounds
  real(dp), dimension(:,:), allocatable :: x
  integer, dimension(:), allocatable :: obs_type
  logical :: optimize

  integer :: optimize_max_iter
  real(dp) :: optimize_ftol

  character(len=max_name_len) :: covariance_function
  character(len=max_name_len) :: noise_model_name

  class(cov_fn), allocatable :: cf
  class(noise_model), allocatable :: nm

  namelist/DIMENSIONS/input_dimension, n, nsparse
  namelist/MODEL/covariance_function, noise_model_name
  namelist/HYPERPARAMETERS/nu, theta, lbounds, ubounds
  namelist/CONTROL/optimize, optimize_max_iter, optimize_ftol

  input_dimension = -1
  n = -1
  nsparse = -1

  read(*, nml=DIMENSIONS)

  if (input_dimension.le.0.or.n.le.0.or.nsparse.lt.-1) then
     write (*,*) "Invalid DIMENSIONS input block"
     stop 1
  end if
  if (nsparse.gt.n) then
     write (*,*) "More sparse points requested than total inputs (DIMENSIONS block)"
     stop 1
  end if

  read(*, nml=MODEL)

  call string_to_cov_fn(covariance_function, cf)
  call string_to_noise_model(noise_model_name, nm)

  nnu = nm%nparams_required(input_dimension)
  ntheta = cf%ntheta_required(input_dimension)

  allocate(real(dp) :: nu(nnu))
  allocate(real(dp) :: theta(ntheta))
  allocate(real(dp) :: lbounds(nnu + ntheta))
  allocate(real(dp) :: ubounds(nnu + ntheta))
  allocate(real(dp) :: t(n))
  allocate(real(dp) :: x(n,input_dimension))
  allocate(integer :: obs_type(n))

  nu = -1
  theta = -1
  lbounds(1) = 0.0
  lbounds(2:) = 0.01
  ubounds(:) = 100.0
  read(*, nml=HYPERPARAMETERS)

  optimize = .false.
  optimize_max_iter = 100
  optimize_ftol = 1.0d-2
  read(*, nml=CONTROL)

  open(newunit=u, file="DATA")

  read (u,*) (x(i,:), obs_type(i), t(i), i=1,n)

  if (nsparse.ge.n.or.nsparse.eq.-1) then
     allocate(gp, source=DenseGP(nu, theta, x, obs_type, t, cf, nm))
  else
     allocate(gp, source=SparseGP(nsparse, nu, theta, x, obs_type, t, cf, nm))
  end if

  if (optimize) then
     call log_lik_optim(nnu + ntheta, gp, lbounds, ubounds, optimize_max_iter, optimize_ftol)
  end if

  call gp%write_out("out.gp")

end program gp_in


      subroutine integr(delxi,dlxrct,drer0,nord,nrc,nrctmx,
     $ nrd1mx,rrelr0)
c
c     This subroutine integrates a Taylor's series for the relative
c     rate of a reaction to calculate the advancement in the
c     corresponding reaction progress variable (dlxrct).
c
c     This subroutine is called by:
c
c       EQ6/reacts.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       delxi  = overall reaction progress variable
c       drer0  = array of derivatives of relative rates for individual
c                  irreversible reactions
c       nord   = order of the finite difference approximation
c
c     Principal output:
c
c       dlxrct = array of increments of reaction progress for
c
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nrctmx,nrd1mx
c
      integer nord,nrc
c
      real*8 drer0(nrd1mx,nrctmx),rrelr0(nrctmx)
      real*8 delxi,dlxrct
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer n
c
      real*8 dxp
c
      real*8 fctrl
c
c-----------------------------------------------------------------------
c
      dlxrct = rrelr0(nrc)*delxi
      if (nord .gt. 0) then
        dxp = delxi
        do n = 1,nord
          dxp = dxp*delxi
          dlxrct = dlxrct + ( drer0(n,nrc)/fctrl(n + 1) )*dxp
        enddo
      endif
c
      end


!
  program test_boozer
!
  use neo_orb, only : NeoOrb, init_field
  use boozer_coordinates_mod, only : use_B_r, use_del_tp_B
  use new_vmec_stuff_mod,   only : nper
!
  implicit none
!
  type(NeoOrb) :: norb
!
  double precision :: r,vartheta_B,varphi_B,                                       &
                      A_phi,A_theta,dA_phi_dr,dA_theta_dr,d2A_phi_dr2,d3A_phi_dr3, &
                      B_vartheta_B,dB_vartheta_B,d2B_vartheta_B,                   &
                      B_varphi_B,dB_varphi_B,d2B_varphi_B,Bmod_B,B_r
  double precision, dimension(3) :: dBmod_B,dB_r
  double precision, dimension(6) :: d2Bmod_B,d2B_r
!
  double precision, parameter :: twopi=2.d0*3.14159265358979d0
  integer, parameter :: n=100
  integer :: it,ip,isw,i
  double precision, dimension(0:n) :: arr,arr1,arr2,arr3
  double precision :: deltheta_BV,delphi_BV,theta,varphi,eps,xi
  double precision, dimension(2) :: ddeltheta_BV,ddelphi_BV
!
  double precision :: dA_phi_dr_num,d2A_phi_dr2_num,        &
                      dB_vartheta_B_num,d2B_vartheta_B_num, &
                      dB_varphi_B_num,d2B_varphi_B_num
  double precision :: A_phi_p,A_phi_m
  double precision :: B_vartheta_B_p,B_vartheta_B_m
  double precision :: B_varphi_B_p,B_varphi_B_m
  double precision :: Bmod_B_p,Bmod_B_m,Bmod_B_pp,Bmod_B_mm,Bmod_B_pm,Bmod_B_mp
  double precision :: B_r_p,B_r_m,B_r_pp,B_r_mm,B_r_pm,B_r_mp
  double precision, dimension(3) :: dBmod_B_num,dB_r_num
  double precision, dimension(6) :: d2Bmod_B_num,d2B_r_num
!
!
!
  call init_field(norb, 'wout.nc', 5, 5, 5, -1)
!
!  use_B_r=.false.
  use_B_r=.true.        !important for plotting, not needed for canonical coordinates
  use_del_tp_B=.false.  !not very important (saves 1 iteration in coord. transform), don't use to save memory
!  use_del_tp_B=.true.
!
  call boozer_converter
!
!---------------------------------------------------------
!
! Plot mod-B, B_r, theta_B-theta_V and phi_B-phi_V on a given flux surface:
!
  r=0.5d0
  open(1234,file='angle.dat')
  open(12345,file='Bmod.dat')
  open(123456,file='B_r.dat')
  open(21345,file='deltheta.dat')
  open(213456,file='delphi.dat')
!
  do it=0,100
    vartheta_B=dble(it)*twopi/dble(n)
    do ip=0,100
      varphi_B=dble(ip)*twopi/dble(n*nper)
!
      call splint_boozer_coord(r,vartheta_B,varphi_B,                                       &
                               A_theta,A_phi,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                               B_vartheta_B,dB_vartheta_B,d2B_vartheta_B,                   &
                               B_varphi_B,dB_varphi_B,d2B_varphi_B,                         &
                               Bmod_B,dBmod_B,d2Bmod_B,                                     &
                               B_r,dB_r,d2B_r)
!
      arr(ip)=Bmod_B
      arr1(ip)=B_r
!
      isw=0
      call delthe_delphi_BV(isw,r,vartheta_B,varphi_B,deltheta_BV,delphi_BV, &
                              ddeltheta_BV,ddelphi_BV)
!
      arr2(ip)=deltheta_BV
      arr3(ip)=delphi_BV
    enddo
    write(1234,*) vartheta_B
    write(12345,*) arr
    write(123456,*) arr1
    write(21345,*) arr2
    write(213456,*) arr3
  enddo
!
  close(1234)
  close(12345)
  close(123456)
  close(21345)
  close(213456)
!
!---------------------------------------------------------
!
! Test forward-backward convertion of VMEC to Boozer angles:
!
  r=0.5d0
  theta=3.2602972560067962d0
  varphi=0.62918037430259344d0
!
  open(1234,file='forw_backw.dat')
  write(1234,*) theta,varphi
!
  do i=1,100
!
    call vmec_to_boozer(r,theta,varphi,vartheta_B,varphi_B)
!
    write(1234,*) vartheta_B,varphi_B
!
    call boozer_to_vmec(r,vartheta_B,varphi_B,theta,varphi)
!
    write(1234,*) theta,varphi
  enddo
!
  close(1234)
!
!
!---------------------------------------------------------
!
! Test derivatives
!
  open(1234,file='derivatives_spline.dat')
  open(12345,file='derivatives_findif.dat')
!
  eps=1.d-3
!
  do i=0,1000
    xi=1.d-3*dble(i)
    r=0.4d0+0.2d0*xi
    vartheta_B=0.1d0+twopi*xi
    varphi_B=0.1d0-twopi*xi
!
    call splint_boozer_coord(r,vartheta_B,varphi_B,                                       &
                             A_theta,A_phi,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B,dBmod_B,d2Bmod_B,                                     &
                             B_r,dB_r,d2B_r)
!
    write(1234,*) xi,dA_phi_dr,d2A_phi_dr2,     &
                  dB_vartheta_B,d2B_vartheta_B, &
                  dB_varphi_B,d2B_varphi_B,     &
                  dBmod_B,d2Bmod_B,dB_r,d2B_r
!
    call splint_boozer_coord(r+eps,vartheta_B,varphi_B,                                       &
                             A_theta,A_phi_p,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_p,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_p,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_p,dBmod_B,d2Bmod_B,                                     &
                             B_r_p,dB_r,d2B_r)
!
    call splint_boozer_coord(r-eps,vartheta_B,varphi_B,                                       &
                             A_theta,A_phi_m,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_m,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_m,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_m,dBmod_B,d2Bmod_B,                                     &
                             B_r_m,dB_r,d2B_r)
!
    dA_phi_dr_num=(A_phi_p-A_phi_m)/(2d0*eps)
    d2A_phi_dr2_num=(A_phi_p+A_phi_m-2.d0*A_phi)/eps**2
    dB_vartheta_B_num=(B_vartheta_B_p-B_vartheta_B_m)/(2d0*eps)
    d2B_vartheta_B_num=(B_vartheta_B_p+B_vartheta_B_m-2.d0*B_vartheta_B)/eps**2
    dB_varphi_B_num=(B_varphi_B_p-B_varphi_B_m)/(2d0*eps)
    d2B_varphi_B_num=(B_varphi_B_p+B_varphi_B_m-2.d0*B_varphi_B)/eps**2
    dBmod_B_num(1)=(Bmod_B_p-Bmod_B_m)/(2d0*eps)
    d2Bmod_B_num(1)=(Bmod_B_p+Bmod_B_m-2.d0*Bmod_B)/eps**2
    dB_r_num(1)=(B_r_p-B_r_m)/(2d0*eps)
    d2B_r_num(1)=(B_r_p+B_r_m-2.d0*B_r)/eps**2
!
!
    call splint_boozer_coord(r,vartheta_B+eps,varphi_B,                                       &
                             A_theta,A_phi_p,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_p,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_p,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_p,dBmod_B,d2Bmod_B,                                     &
                             B_r_p,dB_r,d2B_r)
!
    call splint_boozer_coord(r,vartheta_B-eps,varphi_B,                                       &
                             A_theta,A_phi_m,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_m,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_m,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_m,dBmod_B,d2Bmod_B,                                     &
                             B_r_m,dB_r,d2B_r)
!
    dBmod_B_num(2)=(Bmod_B_p-Bmod_B_m)/(2d0*eps)
    d2Bmod_B_num(4)=(Bmod_B_p+Bmod_B_m-2.d0*Bmod_B)/eps**2
    dB_r_num(2)=(B_r_p-B_r_m)/(2d0*eps)
    d2B_r_num(4)=(B_r_p+B_r_m-2.d0*B_r)/eps**2
!
!
    call splint_boozer_coord(r,vartheta_B,varphi_B+eps,                                       &
                             A_theta,A_phi_p,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_p,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_p,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_p,dBmod_B,d2Bmod_B,                                     &
                             B_r_p,dB_r,d2B_r)
!
    call splint_boozer_coord(r,vartheta_B,varphi_B-eps,                                       &
                             A_theta,A_phi_m,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_m,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_m,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_m,dBmod_B,d2Bmod_B,                                     &
                             B_r_m,dB_r,d2B_r)
!
    dBmod_B_num(3)=(Bmod_B_p-Bmod_B_m)/(2d0*eps)
    d2Bmod_B_num(6)=(Bmod_B_p+Bmod_B_m-2.d0*Bmod_B)/eps**2
    dB_r_num(3)=(B_r_p-B_r_m)/(2d0*eps)
    d2B_r_num(6)=(B_r_p+B_r_m-2.d0*B_r)/eps**2
!
!
    call splint_boozer_coord(r+eps,vartheta_B+eps,varphi_B,                                       &
                             A_theta,A_phi_p,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_p,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_p,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_pp,dBmod_B,d2Bmod_B,                                     &
                             B_r_pp,dB_r,d2B_r)
!
    call splint_boozer_coord(r-eps,vartheta_B-eps,varphi_B,                                       &
                             A_theta,A_phi_m,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_m,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_m,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_mm,dBmod_B,d2Bmod_B,                                     &
                             B_r_mm,dB_r,d2B_r)
!
    call splint_boozer_coord(r+eps,vartheta_B-eps,varphi_B,                                       &
                             A_theta,A_phi_p,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_p,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_p,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_pm,dBmod_B,d2Bmod_B,                                     &
                             B_r_pm,dB_r,d2B_r)
!
    call splint_boozer_coord(r-eps,vartheta_B+eps,varphi_B,                                       &
                             A_theta,A_phi_m,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_m,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_m,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_mp,dBmod_B,d2Bmod_B,                                     &
                             B_r_mp,dB_r,d2B_r)
!
    d2Bmod_B_num(2)=(Bmod_B_pp+Bmod_B_mm-Bmod_B_pm-Bmod_B_mp)/(2.d0*eps)**2
    d2B_r_num(2)=(B_r_pp+B_r_mm-B_r_pm-B_r_mp)/(2d0*eps)**2
!
!
    call splint_boozer_coord(r+eps,vartheta_B,varphi_B+eps,                                       &
                             A_theta,A_phi_p,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_p,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_p,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_pp,dBmod_B,d2Bmod_B,                                     &
                             B_r_pp,dB_r,d2B_r)
!
    call splint_boozer_coord(r-eps,vartheta_B,varphi_B-eps,                                       &
                             A_theta,A_phi_m,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_m,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_m,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_mm,dBmod_B,d2Bmod_B,                                     &
                             B_r_mm,dB_r,d2B_r)
!
    call splint_boozer_coord(r+eps,vartheta_B,varphi_B-eps,                                       &
                             A_theta,A_phi_p,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_p,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_p,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_pm,dBmod_B,d2Bmod_B,                                     &
                             B_r_pm,dB_r,d2B_r)
!
    call splint_boozer_coord(r-eps,vartheta_B,varphi_B+eps,                                       &
                             A_theta,A_phi_m,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_m,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_m,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_mp,dBmod_B,d2Bmod_B,                                     &
                             B_r_mp,dB_r,d2B_r)
!
    d2Bmod_B_num(3)=(Bmod_B_pp+Bmod_B_mm-Bmod_B_pm-Bmod_B_mp)/(2.d0*eps)**2
    d2B_r_num(3)=(B_r_pp+B_r_mm-B_r_pm-B_r_mp)/(2d0*eps)**2
!
!
    call splint_boozer_coord(r,vartheta_B+eps,varphi_B+eps,                                       &
                             A_theta,A_phi_p,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_p,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_p,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_pp,dBmod_B,d2Bmod_B,                                     &
                             B_r_pp,dB_r,d2B_r)
!
    call splint_boozer_coord(r,vartheta_B-eps,varphi_B-eps,                                       &
                             A_theta,A_phi_m,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_m,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_m,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_mm,dBmod_B,d2Bmod_B,                                     &
                             B_r_mm,dB_r,d2B_r)
!
    call splint_boozer_coord(r,vartheta_B-eps,varphi_B+eps,                                       &
                             A_theta,A_phi_p,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_p,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_p,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_pm,dBmod_B,d2Bmod_B,                                     &
                             B_r_pm,dB_r,d2B_r)
!
    call splint_boozer_coord(r,vartheta_B+eps,varphi_B-eps,                                       &
                             A_theta,A_phi_m,dA_theta_dr,dA_phi_dr,d2A_phi_dr2,d3A_phi_dr3, &
                             B_vartheta_B_m,dB_vartheta_B,d2B_vartheta_B,                   &
                             B_varphi_B_m,dB_varphi_B,d2B_varphi_B,                         &
                             Bmod_B_mp,dBmod_B,d2Bmod_B,                                     &
                             B_r_mp,dB_r,d2B_r)
!
    d2Bmod_B_num(5)=(Bmod_B_pp+Bmod_B_mm-Bmod_B_pm-Bmod_B_mp)/(2.d0*eps)**2
    d2B_r_num(5)=(B_r_pp+B_r_mm-B_r_pm-B_r_mp)/(2d0*eps)**2
!
!
    write(12345,*) xi,dA_phi_dr_num,d2A_phi_dr2_num,     &
                   dB_vartheta_B_num,d2B_vartheta_B_num, &
                   dB_varphi_B_num,d2B_varphi_B_num,     &
                   dBmod_B_num,d2Bmod_B_num,dB_r_num,d2B_r_num
  enddo
!
  close(1234)
  close(12345)
!
!
  end program test_boozer