!>------------------------------------------------------------
!! Supplies 1D and 2D FFT shift procedures ala matlab fftshift
!!
!! Uses a generic interface so that procedures can be called with
!! any variation of complex, real, 1D or 2D arrays
!! 2D can also be called with C_DOUBLE_COMPLEX variables
!!
!! fftshift swaps the left and right sides of an array.  For a
!!  2D array, the top and bottom halves are also swapped.
!!
!!  @author
!!  Ethan Gutmann (gutmann@ucar.edu)
!!
!!------------------------------------------------------------
module fftshifter
    use fft
    implicit none
    !> Generic interface to 1D, 2D real, complex, and C-complex fftshift routines
    interface fftshift
        module procedure fftshift2cc, fftshift2c, fftshift2r, fftshift1c, fftshift1r
    end interface
    !> Generic interface to 1D, 2D real, complex, and C-complex inverse fftshift routines
    interface ifftshift
        module procedure ifftshift2cc_z, ifftshift2cc, ifftshift2c, ifftshift2r, ifftshift1c, ifftshift1r
    end interface
contains
    subroutine fftshift1c(fftimage)
        implicit none
        complex, intent(inout),dimension(:):: fftimage
        integer::nx
        complex,allocatable,dimension(:) :: tmp
        integer::i,ii

        nx=size(fftimage)
        allocate(tmp(nx))
        do i=1, nx
            ii = mod(i+(nx+1)/2,nx)
            if(ii==0) ii = nx

            tmp(ii) = fftimage(i)
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine fftshift1c
    subroutine fftshift1r(fftimage)
        implicit none
        real, intent(inout),dimension(:):: fftimage
        integer::nx
        real,allocatable,dimension(:) :: tmp
        integer::i,ii

        nx=size(fftimage)
        allocate(tmp(nx))
        do i=1, nx
            ii = mod(i+(nx+1)/2,nx)
            if(ii==0) ii = nx

            tmp(ii) = fftimage(i)
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine fftshift1r
    subroutine fftshift2cc_z(fftimage,fixed_axis)
        implicit none
        complex(C_DOUBLE_COMPLEX), intent(inout),dimension(:,:,:):: fftimage
        integer, intent(in) :: fixed_axis
        integer::nx,ny
        complex, allocatable,dimension(:,:) :: tmp
        integer::i,j,ii,jj

        nx=size(fftimage,1)
        ny=size(fftimage,2)
        allocate(tmp(nx,ny))
        do j=1, ny
            jj = mod(j+(ny+1)/2,ny)
            if(jj==0) jj = ny
            do i=1, nx
                ii = mod(i+(nx+1)/2,nx)
                if(ii==0) ii = nx

                tmp(ii,jj) = fftimage(i,j,fixed_axis)
            enddo
        enddo
        fftimage(:,:,fixed_axis) = tmp
        deallocate(tmp)
    end subroutine fftshift2cc_z
    subroutine fftshift2cc(fftimage)
        implicit none
        complex(C_DOUBLE_COMPLEX), intent(inout),dimension(:,:):: fftimage
        integer::nx,ny
        complex, allocatable,dimension(:,:) :: tmp
        integer::i,j,ii,jj

        nx=size(fftimage,1)
        ny=size(fftimage,2)
        allocate(tmp(nx,ny))
        do j=1, ny
            jj = mod(j+(ny+1)/2,ny)
            if(jj==0) jj = ny
            do i=1, nx
                ii = mod(i+(nx+1)/2,nx)
                if(ii==0) ii = nx

                tmp(ii,jj) = fftimage(i,j)
            enddo
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine fftshift2cc
    subroutine fftshift2c(fftimage)
        implicit none
        complex, intent(inout),dimension(:,:):: fftimage
        integer::nx,ny
        complex, allocatable,dimension(:,:) :: tmp
        integer::i,j,ii,jj

        nx=size(fftimage,1)
        ny=size(fftimage,2)
        allocate(tmp(nx,ny))
        do j=1, ny
            jj = mod(j+(ny+1)/2,ny)
            if(jj==0) jj = ny
            do i=1, nx
                ii = mod(i+(nx+1)/2,nx)
                if(ii==0) ii = nx

                tmp(ii,jj) = fftimage(i,j)
            enddo
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine fftshift2c
    subroutine fftshift2r(fftimage)
        implicit none
        real, intent(inout),dimension(:,:):: fftimage
        integer::nx,ny
        real, allocatable,dimension(:,:) :: tmp
        integer::i,j,ii,jj

        nx=size(fftimage,1)
        ny=size(fftimage,2)
        allocate(tmp(nx,ny))
        do j=1, ny
            jj = mod(j+(ny+1)/2,ny)
            if(jj==0) jj = ny
            do i=1, nx
                ii = mod(i+(nx+1)/2,nx)
                if(ii==0) ii = nx

                tmp(ii,jj) = fftimage(i,j)
            enddo
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine fftshift2r

    subroutine ifftshift1c(fftimage)
        implicit none
        complex, intent(inout),dimension(:):: fftimage
        integer::nx
        complex,allocatable,dimension(:) :: tmp
        integer::i,ii

        nx=size(fftimage)
        allocate(tmp(nx))
        do i=1, nx
            ii = mod(i+(nx+1)/2,nx)
            if(ii==0) ii = nx

            tmp(i) = fftimage(ii)
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine ifftshift1c
    subroutine ifftshift1r(fftimage)
        implicit none
        real, intent(inout),dimension(:):: fftimage
        integer::nx
        real,allocatable,dimension(:) :: tmp
        integer::i,ii

        nx=size(fftimage)
        allocate(tmp(nx))
        do i=1, nx
            ii = mod(i+(nx+1)/2,nx)
            if(ii==0) ii = nx

            tmp(i) = fftimage(ii)
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine ifftshift1r
    subroutine ifftshift2cc_z(fftimage, fixed_axis)
        implicit none
        complex(C_DOUBLE_COMPLEX), intent(inout),dimension(:,:,:):: fftimage
        integer, intent(in) :: fixed_axis
        integer::nx,ny
        complex, allocatable,dimension(:,:) :: tmp
        integer::i,j,ii,jj

        nx=size(fftimage,1)
        ny=size(fftimage,2)
        allocate(tmp(nx,ny))
        do j=1, ny
            jj = mod(j+(ny+1)/2,ny)
            if(jj==0) jj = ny
            do i=1, nx
                ii = mod(i+(nx+1)/2,nx)
                if(ii==0) ii = nx

                tmp(i,j) = fftimage(ii,jj,fixed_axis)
            enddo
        enddo
        fftimage(:,:,fixed_axis) = tmp
        deallocate(tmp)
    end subroutine ifftshift2cc_z
    subroutine ifftshift2cc(fftimage)
        implicit none
        complex(C_DOUBLE_COMPLEX), intent(inout),dimension(:,:):: fftimage
        integer::nx,ny
        complex, allocatable,dimension(:,:) :: tmp
        integer::i,j,ii,jj

        nx=size(fftimage,1)
        ny=size(fftimage,2)
        allocate(tmp(nx,ny))
        do j=1, ny
            jj = mod(j+(ny+1)/2,ny)
            if(jj==0) jj = ny
            do i=1, nx
                ii = mod(i+(nx+1)/2,nx)
                if(ii==0) ii = nx

                tmp(i,j) = fftimage(ii,jj)
            enddo
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine ifftshift2cc
    subroutine ifftshift2c(fftimage)
        implicit none
        complex, intent(inout),dimension(:,:):: fftimage
        integer::nx,ny
        complex, allocatable,dimension(:,:) :: tmp
        integer::i,j,ii,jj

        nx=size(fftimage,1)
        ny=size(fftimage,2)
        allocate(tmp(nx,ny))
        do j=1, ny
            jj = mod(j+(ny+1)/2,ny)
            if(jj==0) jj = ny
            do i=1, nx
                ii = mod(i+(nx+1)/2,nx)
                if(ii==0) ii = nx

                tmp(i,j) = fftimage(ii,jj)
            enddo
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine ifftshift2c
    subroutine ifftshift2r(fftimage)
        implicit none
        real, intent(inout),dimension(:,:):: fftimage
        integer::nx,ny
        real, allocatable,dimension(:,:) :: tmp
        integer::i,j,ii,jj

        nx=size(fftimage,1)
        ny=size(fftimage,2)
        allocate(tmp(nx,ny))
        do j=1, ny
            jj = mod(j+(ny+1)/2,ny)
            if(jj==0) jj = ny
            do i=1, nx
                ii = mod(i+(nx+1)/2,nx)
                if(ii==0) ii = nx

                tmp(i,j) = fftimage(ii,jj)
            enddo
        enddo
        fftimage = tmp
        deallocate(tmp)
    end subroutine ifftshift2r

end module fftshifter


include "interpolate_tracer.f90"
!----------------------------------------
subroutine upwind(trac, u, dtrac, order, l, m, n)
  !
  ! compute dtrac = -delta[ trac*U ]
  ! where delta[ ] is the finite difference in the i direction
  ! which is the third entry of the 3D array
  ! U is the contravariant component
  ! trac is upwinded at u-point
  !
  ! note that with arbitrary coordinates we should have
  ! dtrac = -delta[ trac*U*vol ] / vol
  !
  ! in Cartesian coordinates, vol is uniform, so vol
  ! can be drop out
  !
  implicit none

  integer, intent(in):: order, l, m, n
  real*8, dimension(l, m, n), intent(in) :: trac, u
  real*8, dimension(l, m, n), intent(inout) :: dtrac

  !f2py intent(inplace):: trac, dtrac, u

  integer:: i, j, k, ii
  real*8::c1,c2,c3, b1, b2, b3, b4, b5
  real*8:: UU, fx, fxm
  real*8,dimension(n) :: phi, qm, qp, um, up

  do k = 1, l
     do j = 1, m
        do i = 1, n
           UU = abs(u(k,j,i))
           up(i) = 0.5*(u(k,j,i)+UU) ! right-going flux
           um(i) = 0.5*(u(k,j,i)-UU) ! left-going flux
           phi(i) = trac(k,j,i)
        enddo
        !
        call interpolate(phi, qp, qm, order, n)
        !
        if (mod(order, 2).eq.0) then
           fxm = 0.
           do i=1,n-1
              fx = u(k,j,i)*qp(i)
              dtrac(k, j, i) = dtrac(k, j, i) + fxm - fx
              fxm = fx
           enddo
           i=n
           fx = 0.
           dtrac(k, j, i) = dtrac(k, j, i) + fxm - fx
        else
           fxm = 0.
           do i=1,n-1
              fx = up(i)*qp(i) + um(i)*qm(i+1)
              dtrac(k, j, i) = dtrac(k, j, i) + fxm - fx
              fxm = fx
           enddo
           i=n
           fx = 0.
           dtrac(k, j, i) = dtrac(k, j, i) + fxm - fx
        endif
     enddo
  enddo

end subroutine upwind


program complex_dp_param

    integer, parameter :: prec1 = 4, prec2 = 8
    complex(prec1) :: u = (1.05, 1.05)
    complex(prec2) :: v = (1.05, 1.05_8)
    complex(prec2) :: zero = 0.0_4
    print *, u, v, zero

end program


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id$
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE COSTMI (N, WSAVE, LENSAV, IER)
      INTEGER    N, LENSAV, IER
      REAL       WSAVE(LENSAV)
C
      IER = 0
C
      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN
        IER = 2
        CALL XERFFT ('COSTMI', 3)
        GO TO 300
      ENDIF
C
      IF (N .LE. 3) RETURN
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      PI = 4.*ATAN(1.)
      DT = PI/FLOAT(NM1)
      FK = 0.
      DO 101 K=2,NS2
         KC = NP1-K
         FK = FK+1.
         WSAVE(K) = 2.*SIN(FK*DT)
         WSAVE(KC) = 2.*COS(FK*DT)
  101 CONTINUE
      LNSV = NM1 + INT(LOG(REAL(NM1))) +4
      CALL RFFTMI (NM1, WSAVE(N+1), LNSV, IER1)
      IF (IER1 .NE. 0) THEN
        IER = 20
        CALL XERFFT ('COSTMI',-5)
      ENDIF
  300 CONTINUE
      RETURN
      END


      SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( * ), E( * )
*     ..
*
*  Purpose
*  =======
*
*  DPTSV computes the solution to a real system of linear equations
*  A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
*  matrix, and X and B are N-by-NRHS matrices.
*
*  A is factored as A = L*D*L**T, and the factored form of A is then
*  used to solve the system of equations.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the n diagonal elements of the tridiagonal matrix
*          A.  On exit, the n diagonal elements of the diagonal matrix
*          D from the factorization A = L*D*L**T.
*
*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
*          On entry, the (n-1) subdiagonal elements of the tridiagonal
*          matrix A.  On exit, the (n-1) subdiagonal elements of the
*          unit bidiagonal factor L from the L*D*L**T factorization of
*          A.  (E can also be regarded as the superdiagonal of the unit
*          bidiagonal factor U from the U**T*D*U factorization of A.)
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
*          On entry, the N-by-NRHS right hand side matrix B.
*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, the leading minor of order i is not
*                positive definite, and the solution has not been
*                computed.  The factorization has not been completed
*                unless i = N.
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           DPTTRF, DPTTRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPTSV ', -INFO )
         RETURN
      END IF
*
*     Compute the L*D*L' (or U'*D*U) factorization of A.
*
      CALL DPTTRF( N, D, E, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL DPTTRS( N, NRHS, D, E, B, LDB, INFO )
      END IF
      RETURN
*
*     End of DPTSV
*
      END


      subroutine splined(x,y,n,yp1,ypn,y2)

      parameter(pi=3.1415926535)
      parameter(nmax=100000)

      integer n
      real yp1,ypn,x(n),y(n),y2(n)
      integer i,k
      real p,qn,sig,un,u(nmax)
      if (yp1.gt..99e30) then
         y2(1)=0.
         u(1)=0.
      else
         y2(1)=-0.5
         u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
      endif
      do 11 i=2,n-1
         sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
         p=sig*y2(i-1)+2.
         y2(i)=(sig-1.)/p
         u(i)=(6.*((y(i+1)-y(i))/(x(i+
     *        1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*
     *        u(i-1))/p

 11   continue
      if (ypn.gt..99e30) then
         qn=0.
         un=0.
      else
         qn=0.5
         un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
      endif
      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
      do 12 k=n-1,1,-1
         y2(k)=y2(k)*y2(k+1)+u(k)
 12   continue
      return
      end


       subroutine convl2(npts, x, y, gamma, xout, yout)
c  broaden the two arrays x and y with a lorentzian
c  arrays are assumed to be on the same even grid
c
c  note: gamma is the lorentzian width in units of grid points!!
       implicit none
       integer npts, i, j
       double precision x(npts), y(npts), xout(npts), yout(npts)
       double precision gamma, sum, factr, zero, one, small
       double precision  tmpx, tmpy, gami2
       parameter  (zero = 0.d0, one = 1.d0, small = 1.d-20)

      gamma = max(small, gamma)
      gami2 = one /(gamma*gamma)
       do 100 i = 1, npts
          sum  = zero
          tmpx = zero
          tmpy = zero
          do 50 j = 1, npts
             factr = 1 / ( 1 + gami2 * (j-i) * (j-i) )
             sum   = sum  + factr
             tmpx  = tmpx + x(j) *  factr
             tmpy  = tmpy + y(j) *  factr
 50       continue
          yout(i) = tmpy / max (small, sum)
          xout(i) = tmpx / max (small, sum)
 100   continue
       return
       end


! ------------------------------------------------------------------
! Programmer(s): David J. Gardner, Cody J. Balos @ LLNL
!                Daniel R. Reynolds @ SMU
! ------------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2021, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ------------------------------------------------------------------
! This test simulates a brusselator problem from chemical kinetics.
! This is an ODE system with 3 components, Y = [u,v,w], satisfying
! the equations,
!
!    du/dt = a - (w+1)*u + v*u^2
!    dv/dt = w*u - v*u^2
!    dw/dt = (b-w)/ep - w*u
!
! for t in the interval [0.0, 10.0], with initial conditions
! Y0 = [3.9, 1.1, 2.8], and parameter values a=1.2, b=2.5, and
! ep=1.0e-5
!
! Here, all three components exhibit a rapid transient change during
! the first 0.2 time units, followed by a slow and smooth evolution.
! ------------------------------------------------------------------

module ode_mod

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  !======= Declarations =========
  implicit none

  ! number of equations
  integer(c_long), parameter :: neq = 3

  ! ODE parameters
  double precision, parameter :: a  = 1.2d0
  double precision, parameter :: b  = 2.5d0
  double precision, parameter :: ep = 1.0d-5

contains

  ! ----------------------------------------------------------------
  ! RhsFn provides the right hand side function for the
  ! ODE: dy/dt = f(t,y)
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) &
       result(ierr) bind(C,name='RhsFn')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tn        ! current time
    type(N_Vector)        :: sunvec_y  ! solution N_Vector
    type(N_Vector)        :: sunvec_f  ! rhs N_Vector
    type(c_ptr),    value :: user_data ! user-defined data

    ! pointers to data in SUNDIALS vectors
    real(c_double), pointer :: yvec(:)
    real(c_double), pointer :: fvec(:)

    !======= Internals ============

    ! get data arrays from SUNDIALS vectors
    yvec => FN_VGetArrayPointer(sunvec_y)
    fvec => FN_VGetArrayPointer(sunvec_f)

    ! fill RHS vector
    fvec(1) = a  -  (yvec(3) + 1.0d0) * yvec(1)  +  yvec(2) * yvec(1) * yvec(1)
    fvec(2) = yvec(3) * yvec(1)  -  yvec(2) * yvec(1) * yvec(1)
    fvec(3) = (b-yvec(3))/ep - yvec(3) * yvec(1)

    ! return success
    ierr = 0
    return

  end function RhsFn

  ! ----------------------------------------------------------------
  ! JacFn: The Jacobian of the ODE hand side function J = df/dy
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function JacFn(tn, sunvec_y, sunvec_f, sunmat_J, &
       user_data, tmp1, tmp2, tmp3) &
       result(ierr) bind(C,name='JacFn')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod
    use fsunmatrix_dense_mod
    use fsundials_matrix_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tn               ! current time
    type(N_Vector)        :: sunvec_y         ! current solution N_Vector
    type(N_Vector)        :: sunvec_f         ! current rhs N_Vector
    type(SUNMatrix)       :: sunmat_J         ! Jacobian SUNMatrix
    type(c_ptr), value    :: user_data        ! user-defined data
    type(N_Vector)        :: tmp1, tmp2, tmp3 ! workspace N_Vectors

    ! pointers to data in SUNDIALS vectors
    real(c_double), pointer :: yvec(:)

    ! pointer to data in SUNDIALS matrix
    real(c_double), pointer :: Jmat(:)

    !======= Internals ============

    ! get data array from SUNDIALS vector
    yvec => FN_VGetArrayPointer(sunvec_y)

    ! get data arrays from SUNDIALS vectors
    Jmat => FSUNDenseMatrix_Data(sunmat_J)

    ! fill Jacobian matrix
    Jmat = [-(yvec(3)+1.0d0) + 2.0d0*yvec(1)*yvec(2),&
            yvec(3) - 2.0d0*yvec(1)*yvec(2), -yvec(3),&
            yvec(1)*yvec(1), -yvec(1)*yvec(1), 0.0d0,&
            -yvec(1), yvec(1), -1.0d0/ep - yvec(1)]

    ! return success
    ierr = 0
    return

  end function JacFn

end module ode_mod

program main

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  use fsundials_context_mod
  use fcvode_mod                 ! Fortran interface to CVODE
  use fnvector_serial_mod        ! Fortran interface to serial N_Vector
  use fsunmatrix_dense_mod       ! Fortran interface to dense SUNMatrix
  use fsunlinsol_dense_mod       ! Fortran interface to dense SUNLinearSolver
  use fsundials_linearsolver_mod ! Fortran interface to generic SUNLinearSolver
  use fsundials_matrix_mod       ! Fortran interface to generic SUNMatrix
  use fsundials_nvector_mod      ! Fortran interface to generic N_Vector
  use ode_mod                    ! ODE functions

  !======= Declarations =========
  implicit none

                                                 ! local variables
  real(c_double)                 :: tstart       ! initial time
  real(c_double)                 :: tend         ! final time
  real(c_double)                 :: rtol, atol   ! relative and absolute tolerance
  real(c_double)                 :: dtout        ! output time interval
  real(c_double)                 :: tout         ! output time
  real(c_double)                 :: tcur(1)      ! current time

  integer(c_int)                 :: ierr         ! error flag from C functions
  integer(c_int)                 :: nout         ! number of outputs

  integer                        :: outstep      ! output loop counter

  type(c_ptr)                    :: ctx          ! SUNDIALS context
  type(c_ptr)                    :: cvode_mem    ! CVODE memory
  type(N_Vector),        pointer :: sunvec_y     ! sundials vector
  type(SUNMatrix),       pointer :: sunmat_A     ! sundials matrix
  type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver

  ! solution vector, neq is set in the ode_mod module
  real(c_double) :: yvec(neq)

  !======= Internals ============

  ! initialize ODE
  tstart = 0.0d0
  tend   = 10.0d0
  tcur   = tstart
  tout   = tstart
  dtout  = (tend-tstart)/10.d0
  nout   = ceiling(tend/dtout)

  ! initialize solution vector
  yvec(1) = 3.9d0
  yvec(2) = 1.1d0
  yvec(3) = 2.8d0

  ! create SUNDIALS context
  ierr = FSUNContext_Create(c_null_ptr, ctx)

  ! create SUNDIALS N_Vector
  sunvec_y => FN_VMake_Serial(neq, yvec, ctx)
  if (.not. associated(sunvec_y)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  ! create a dense matrix
  sunmat_A => FSUNDenseMatrix(neq, neq, ctx)
  if (.not. associated(sunmat_A)) then
     print *, 'ERROR: sunmat = NULL'
     stop 1
  end if

  ! create a dense linear solver
  sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, ctx)
  if (.not. associated(sunlinsol_LS)) then
     print *, 'ERROR: sunlinsol = NULL'
     stop 1
  end if

  ! create CVode memory
  cvode_mem = FCVodeCreate(CV_BDF, ctx)
  if (.not. c_associated(cvode_mem)) then
     print *, 'ERROR: cvode_mem = NULL'
     stop 1
  end if

  ! initialize CVode
  ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_y)
  if (ierr /= 0) then
     print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! set relative and absolute tolerances
  rtol = 1.0d-5
  atol = 1.0d-10

  ierr = FCVodeSStolerances(cvode_mem, rtol, atol)
  if (ierr /= 0) then
     print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! attach linear solver
  ierr = FCVodeSetLinearSolver(cvode_mem, sunlinsol_LS, sunmat_A);
  if (ierr /= 0) then
     print *, 'Error in FCVodeSetLinearSolver, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! set Jacobian routine
  ierr = FCVodeSetJacFn(cvode_mem, c_funloc(JacFn))
  if (ierr /= 0) then
     print *, 'Error in FCVodeSetJacFn, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! start time stepping
  print *, '   '
  print *, 'Finished initialization, starting time steps'
  print *, '   '
  print *, '      t           u           v           w'
  print *, '----------------------------------------------------'
  print '(1x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3)
  do outstep = 1,nout

     ! call CVode
     tout = min(tout + dtout, tend)
     ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL)
     if (ierr /= 0) then
        print *, 'Error in FCVODE, ierr = ', ierr, '; halting'
        stop 1
     endif

     ! output current solution
     print '(1x,4(es12.5,1x))', tcur, yvec(1), yvec(2), yvec(3)

  enddo

  ! diagnostics output
  call CVodeStats(cvode_mem)

  ! clean up
  call FCVodeFree(cvode_mem)
  ierr = FSUNLinSolFree(sunlinsol_LS)
  call FSUNMatDestroy(sunmat_A)
  call FN_VDestroy(sunvec_y)
  ierr = FSUNContext_Free(ctx)

end program Main

! ----------------------------------------------------------------
! CVodeStats
!
! Print CVODE statstics to standard out
! ----------------------------------------------------------------
subroutine CVodeStats(cvode_mem)

  !======= Inclusions ===========
  use iso_c_binding
  use fcvode_mod

  !======= Declarations =========
  implicit none

  type(c_ptr), intent(in) :: cvode_mem ! solver memory structure

  integer(c_int)  :: ierr          ! error flag

  integer(c_long) :: nsteps(1)     ! num steps
  integer(c_long) :: nfevals(1)    ! num function evals
  integer(c_long) :: nlinsetups(1) ! num linear solver setups
  integer(c_long) :: netfails(1)   ! num error test fails

  integer(c_int)  :: qlast(1)      ! method order in last step
  integer(c_int)  :: qcur(1)       ! method order for next step

  real(c_double)  :: hinused(1)    ! initial step size
  real(c_double)  :: hlast(1)      ! last step size
  real(c_double)  :: hcur(1)       ! step size for next step
  real(c_double)  :: tcur(1)       ! internal time reached

  integer(c_long) :: nniters(1)    ! nonlinear solver iterations
  integer(c_long) :: nncfails(1)   ! nonlinear solver fails

  integer(c_long) :: njevals(1)    ! num Jacobian evaluations

  !======= Internals ============

  ! general solver statistics
  ierr = FCVodeGetIntegratorStats(cvode_mem, nsteps, nfevals, nlinsetups, &
       netfails, qlast, qcur, hinused, hlast, hcur, tcur)
  if (ierr /= 0) then
     print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! nonlinear solver statistics
  ierr = FCVodeGetNonlinSolvStats(cvode_mem, nniters, nncfails)
  if (ierr /= 0) then
     print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! nonlinear solver statistics
  ierr = FCVodeGetNumJacEvals(cvode_mem, njevals)
  if (ierr /= 0) then
     print *, 'Error in FCVodeGetNumJacEvals, ierr = ', ierr, '; halting'
     stop 1
  end if

  print *, ' '
  print *, ' General Solver Stats:'
  print '(4x,A,i9)'    ,'Total internal steps taken =',nsteps
  print '(4x,A,i9)'    ,'Total rhs function calls   =',nfevals
  print '(4x,A,i9)'    ,'Num lin solver setup calls =',nlinsetups
  print '(4x,A,i9)'    ,'Num error test failures    =',netfails
  print '(4x,A,i9)'    ,'Last method order          =',qlast
  print '(4x,A,i9)'    ,'Next method order          =',qcur
  print '(4x,A,es12.5)','First internal step size   =',hinused
  print '(4x,A,es12.5)','Last internal step size    =',hlast
  print '(4x,A,es12.5)','Next internal step size    =',hcur
  print '(4x,A,es12.5)','Current internal time      =',tcur
  print '(4x,A,i9)'    ,'Num nonlinear solver iters =',nniters
  print '(4x,A,i9)'    ,'Num nonlinear solver fails =',nncfails
  print '(4x,A,i9)'    ,'Num Jacobian evaluations   =',njevals
  print *, ' '

  return

end subroutine CVodeStats


!
!
!     ------------------------------------------------------------------
!     I N V M A T
!     ------------------------------------------------------------------
!
      SUBROUTINE INVMAT(A, B, MATDIM, NDIM)
! FIND INVERSE OF MATRIX A
! INPUT :
!        A : MATRIX TO BE INVERTED
!        B : SCRATCH ARRAY
!        MATDIM : PHYSICAL DIMENSION OF MATRICES
!        NDIM :   DIMENSION OF SUBMATRIX TO BE INVERTED
!
! OUTPUT : A : INVERSE MATRIX ( ORIGINAL MATRIX THUS DESTROYED )
! WARNINGS ARE ISSUED IN CASE OF CONVERGENCE PROBLEMS )
!
!************************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:08:49   1/ 6/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE bndinv_I
      USE wrtmat_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: MATDIM
      INTEGER  :: NDIM
      REAL(DOUBLE)  :: A(MATDIM,MATDIM)
      REAL(DOUBLE)  :: B(MATDIM,MATDIM)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER      :: ITEST, NTEST
      REAL(DOUBLE) :: DETERM, EPSIL
!-----------------------------------------------
!
      ITEST = 0
      IF (NDIM == 1) THEN
         IF (A(1,1) /= 0.0D0) THEN
            A(1,1) = 1.0D0/A(1,1)
         ELSE
            ITEST = 1
         ENDIF
      ELSE
         DETERM = 0.0D0
         EPSIL = 0.0D0
         CALL BNDINV (A, B, NDIM, DETERM, EPSIL, ITEST, MATDIM)
      ENDIF
!
      IF (ITEST /= 0) THEN
         WRITE (6, '(A,I3)') ' INVERSION PROBLEM NUMBER..', ITEST
         STOP
      ENDIF
      NTEST = 0
      IF (NTEST /= 0) THEN
         WRITE (6, *) ' INVERTED MATRIX '
         CALL WRTMAT (A, NDIM, NDIM, MATDIM, MATDIM)
      ENDIF
!
      RETURN
      END SUBROUTINE INVMAT


module global_module

! This module contains data needed throughout the program.
! Most data is specified as a parameter, as to make the execution faster.
! This module is loaded by most other modules.

  implicit none

  ! Time integration

  ! For Euler ! real(kind=8), parameter :: dt    = 1.0d-6 ! [s] time step for the simulation
  ! For Euler ! real(kind=8), parameter :: t_end = 1.0d-2 ! [s] total simulated time (from 0 to t_end)

  real(kind=8), parameter :: dt    = 1.0d-4 ! [s] time step for the simulation
  real(kind=8), parameter :: t_end = 10.0d0 ! [s] total simulated time (from 0 to t_end)

  ! Specify domain and discretization

  real(kind=8), parameter :: x_min = -1.0 ! [m]
  real(kind=8), parameter :: x_max = 2.0  ! [m]
  real(kind=8), parameter :: y_min = -1.0 ! [m]
  real(kind=8), parameter :: y_max = 1.0  ! [m]

  ! Total number of cells (including 2 ghost cells for each side)
  ! (using 2 ghost cells makes it easy to reach second order accuracy)

  integer, parameter :: Nx = 500
  integer, parameter :: Ny = 500

  real(kind=8), parameter :: dx = (x_max-x_min)/(Nx-4)
  real(kind=8), parameter :: dy = (y_max-y_min)/(Ny-4)

  ! Spacial accuracy (order)
  ! 1: uniform sol in cell, first order in space
  ! 2: MUSCL with TVD slope limiter, second order in space
  ! 3: WENO 3rd order
  ! 5: WENO 5th order
  integer, parameter :: space_order = 5

  ! Time accuracy (order)
  ! 1: forward Euler, first order in time
  ! 2: midpoint Euler, second order in time
  ! 3: explicit TVD Runge-Kutta, third order in time
  integer, parameter :: time_order = 3

  ! Space fluxes: choose ONLY one
  logical, parameter :: flux_type_Rusanov = .true.

end module


*> \brief \b CGET02
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB,
*                          RWORK, RESID )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANS
*       INTEGER            LDA, LDB, LDX, M, N, NRHS
*       REAL               RESID
*       ..
*       .. Array Arguments ..
*       REAL               RWORK( * )
*       COMPLEX            A( LDA, * ), B( LDB, * ), X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CGET02 computes the residual for a solution of a system of linear
*> equations  A*x = b  or  A'*x = b:
*>    RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
*> where EPS is the machine epsilon.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies the form of the system of equations:
*>          = 'N':  A *x = b
*>          = 'T':  A^T*x = b, where A^T is the transpose of A
*>          = 'C':  A^H*x = b, where A^H is the conjugate transpose of A
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of columns of B, the matrix of right hand sides.
*>          NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA,N)
*>          The original M x N matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is COMPLEX array, dimension (LDX,NRHS)
*>          The computed solution vectors for the system of linear
*>          equations.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  If TRANS = 'N',
*>          LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX array, dimension (LDB,NRHS)
*>          On entry, the right hand side vectors for the system of
*>          linear equations.
*>          On exit, B is overwritten with the difference B - A*X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  IF TRANS = 'N',
*>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (M)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is REAL
*>          The maximum over the number of right hand sides of
*>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex_eig
*
*  =====================================================================
      SUBROUTINE CGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB,
     $                   RWORK, RESID )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            LDA, LDB, LDX, M, N, NRHS
      REAL               RESID
*     ..
*     .. Array Arguments ..
      REAL               RWORK( * )
      COMPLEX            A( LDA, * ), B( LDB, * ), X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            CONE
      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            J, N1, N2
      REAL               ANORM, BNORM, EPS, XNORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               CLANGE, SCASUM, SLAMCH
      EXTERNAL           LSAME, CLANGE, SCASUM, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEMM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Quick exit if M = 0 or N = 0 or NRHS = 0
*
      IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.EQ.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
*
      IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
         N1 = N
         N2 = M
      ELSE
         N1 = M
         N2 = N
      END IF
*
*     Exit with RESID = 1/EPS if ANORM = 0.
*
      EPS = SLAMCH( 'Epsilon' )
      ANORM = CLANGE( '1', M, N, A, LDA, RWORK )
      IF( ANORM.LE.ZERO ) THEN
         RESID = ONE / EPS
         RETURN
      END IF
*
*     Compute  B - A*X  (or  B - A'*X ) and store in B.
*
      CALL CGEMM( TRANS, 'No transpose', N1, NRHS, N2, -CONE, A, LDA, X,
     $            LDX, CONE, B, LDB )
*
*     Compute the maximum over the number of right hand sides of
*        norm(B - A*X) / ( norm(A) * norm(X) * EPS ) .
*
      RESID = ZERO
      DO 10 J = 1, NRHS
         BNORM = SCASUM( N1, B( 1, J ), 1 )
         XNORM = SCASUM( N2, X( 1, J ), 1 )
         IF( XNORM.LE.ZERO ) THEN
            RESID = ONE / EPS
         ELSE
            RESID = MAX( RESID, ( ( BNORM/ANORM )/XNORM )/EPS )
         END IF
   10 CONTINUE
*
      RETURN
*
*     End of CGET02
*
      END


! Created by EverLookNeverSee@GitHub  on 4/14/20.
! This program gets  mile and yard values from user
! and converts it to kilometer.

program Mile_to_Km
    implicit none
    ! mile to kilometer conversion factor
    real, parameter :: factor = 1.609
    integer :: mile
    integer :: yard
    real :: km
    print *, "Enter mile: "
    read *, mile
    print *, "Enter yard: "
    read *, yard
    km = factor * (mile + yard / 1760.0)   ! 1 mile = 1760 yards
    print *, mile, "mile(s) and ", yard, "yard(s) = ", km, "kilometer(s)."
end program Mile_to_Km


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testSelectedKinds
#include "UnitTest.h"
USE UnitTest
USE IntrType

IMPLICIT NONE

REAL(SSK) :: singlefloat
REAL(SDK) :: doublefloat
INTEGER(SNK) :: singleint
INTEGER(SLK) :: doubleint

CREATE_TEST('Testing Selected Kinds')

CALL evalIntModel()
CALL evalFPModel()

REGISTER_SUBTEST('APPROXEQ', testAPPROXEQ)
REGISTER_SUBTEST('APPROXEQA', testAPPROXEQA)
REGISTER_SUBTEST('APPROXEQR', testAPPROXEQR)
REGISTER_SUBTEST('APPROXEQF', testAPPROXEQF)
REGISTER_SUBTEST('APPROXLE', testAPPROXLE)
REGISTER_SUBTEST('APPROXGE', testAPPROXGE)
REGISTER_SUBTEST('SOFTEQ', testSOFTEQ)
REGISTER_SUBTEST('SOFT...', testSOFTCompare)
REGISTER_SUBTEST('isNAN', testisNAN)
REGISTER_SUBTEST('isINF', testisINF)
REGISTER_SUBTEST('CharToInt', testCharToInt)
REGISTER_SUBTEST('CharToSingle', testCharToSingle)
REGISTER_SUBTEST('CharToDouble', testCharToDouble)
REGISTER_SUBTEST('CharToBool', testCharToBool)
!REGISTER_SUBTEST('CharToIntArray', testCharToIntArray)
!REGISTER_SUBTEST('CharToDoubleArray', testCharToDoubleArray)
!REGISTER_SUBTEST('CharToStrArray', testCharToStrArray)

FINALIZE_TEST()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE evalFPModel()
  INTEGER :: id

  WRITE(*,*) 'TESTING FLOATING POINT MODEL'
  WRITE(*,*)
  WRITE(*,'(a,i1,a)') ' REAL(',SSK,') :: singlefloat'
  WRITE(*,*) '      RADIX(singlefloat) = ',RADIX(singlefloat)
  WRITE(*,*) '     DIGITS(singlefloat) = ',DIGITS(singlefloat)
  WRITE(*,*) 'MINEXPONENT(singlefloat) = ',MINEXPONENT(singlefloat)
  WRITE(*,*) 'MAXEXPONENT(singlefloat) = ',MAXEXPONENT(singlefloat)
  WRITE(*,*) '      RANGE(singlefloat) = ',RANGE(singlefloat)
  WRITE(*,*) '  PRECISION(singlefloat) = ',PRECISION(singlefloat)
  WRITE(*,*) '    EPSILON(singlefloat) = ',EPSILON(singlefloat)
  WRITE(*,*) '       HUGE(singlefloat) = ',HUGE(singlefloat)
  WRITE(*,*) '       TINY(singlefloat) = ',TINY(singlefloat)
  DO id=0,15
    singlefloat=REAL(10**id,SSK)
    WRITE(*,'(a,i2.2,a,es13.6)') '            SPACING(1e',id,') = ',SPACING(singlefloat)
  ENDDO

  WRITE(*,*)
  WRITE(*,'(a,i1,a)') ' REAL(',SDK,') :: doublefloat'
  WRITE(*,*) '      RADIX(doublefloat) = ',RADIX(doublefloat)
  WRITE(*,*) '     DIGITS(doublefloat) = ',DIGITS(doublefloat)
  WRITE(*,*) 'MINEXPONENT(doublefloat) = ',MINEXPONENT(doublefloat)
  WRITE(*,*) 'MAXEXPONENT(doublefloat) = ',MAXEXPONENT(doublefloat)
  WRITE(*,*) '      RANGE(doublefloat) = ',RANGE(doublefloat)
  WRITE(*,*) '  PRECISION(doublefloat) = ',PRECISION(doublefloat)
  WRITE(*,*) '    EPSILON(doublefloat) = ',EPSILON(doublefloat)
  WRITE(*,*) '       HUGE(doublefloat) = ',HUGE(doublefloat)
  WRITE(*,*) '       TINY(doublefloat) = ',TINY(doublefloat)
  DO id=0,15
    doublefloat=REAL(10**id,SDK)
    WRITE(*,'(a,i2.2,a,es13.6)') '            SPACING(1e',id,') = ',SPACING(doublefloat)
  ENDDO
  WRITE(*,*) '---------------------------------------------------'
ENDSUBROUTINE evalFPModel
!
!-------------------------------------------------------------------------------
SUBROUTINE evalIntModel()
  WRITE(*,*) 'TESTING INTEGER MODEL'
  WRITE(*,*)
  WRITE(*,'(a,i1,a)') ' INTEGER(',SNK,') :: singleint'
  WRITE(*,*) '   BIT_SIZE(singleint) = ',BIT_SIZE(singleint)
  WRITE(*,*) '      RADIX(singleint) = ',RADIX(singleint)
  WRITE(*,*) '     DIGITS(singleint) = ',DIGITS(singleint)
  WRITE(*,*) '      RANGE(singleint) = ',RANGE(singleint)
  WRITE(*,*) '       HUGE(singleint) = ',HUGE(singleint)

  WRITE(*,*)
  WRITE(*,'(a,i1,a)') ' INTEGER(',SLK,') :: doubleint'
  WRITE(*,*) '   BIT_SIZE(doubleint) = ',BIT_SIZE(doubleint)
  WRITE(*,*) '      RADIX(doubleint) = ',RADIX(doubleint)
  WRITE(*,*) '     DIGITS(doubleint) = ',DIGITS(doubleint)
  WRITE(*,*) '      RANGE(doubleint) = ',RANGE(doubleint)
  WRITE(*,*) '       HUGE(doubleint) = ',HUGE(doubleint)

  WRITE(*,*) '---------------------------------------------------'
ENDSUBROUTINE evalIntModel
!
!-------------------------------------------------------------------------------
FUNCTION approxeq_test(a,b) RESULT(bool)
  REAL(SDK),INTENT(IN) :: a,b
  LOGICAL(SBK) :: bool
  REAL(SDK) :: eps

  eps=MAX(ABS(a),ABS(b))*1.e-14_SDK
  IF(a == 0.0_SRK .OR. b == 0.0_SRK) eps=1.e-14_SDK

  bool=(ABS(a-b) <= eps)

  !CHARACTER(LEN=23) :: aString,bString
  !CHARACTER(LEN=8) :: expString
  !INTEGER(SNK) :: intA_left,intB_left,intA_exp,intB_exp,diffExp
  !INTEGER(SLK) :: intA_right,intB_right
  !REAL(SDK) :: tol
  !
  !!Convert to character variable
  !WRITE(aString,'(es23.15E3)') a
  !WRITE(bString,'(es23.15E3)') b
  !
  !!First digit that is left of decimal
  !READ(aString(1:2),'(i2)') intA_left
  !READ(bString(1:2),'(i2)') intB_left
  !
  !IF(intA_left == 0 .OR. intB_left == 0) THEN
  !  !Special case for 0, use absolute comparison
  !  bool=(ABS(a-b) <= EPSD)
  !ELSE
  !  !Conver exponent and numbers right of decimal to integers
  !  READ(aString(4:18),'(i15)') intA_right
  !  READ(bString(4:18),'(i15)') intB_right
  !  READ(aString(20:23),'(i4)') intA_exp
  !  READ(bString(20:23),'(i4)') intB_exp
  !  diffExp=ABS(intA_exp-intB_exp)
  !
  !  IF(diffExp < 2) THEN
  !    IF(diffExp == 0 .AND. intA_left == intB_left) THEN
  !      !exponents are the same and left of decimal numbers are same,
  !      !so compare sig figs to the right of the decimal
  !      bool=(ABS(intA_right-intB_right) < 11)
  !    ELSE
  !      !Exponent or number may have rolled over (e.g. 1.0 and 0.9)
  !      !Compute tolerance based on larger exponent
  !      WRITE(expString,'(a,sp,i4.3)') '1.0d',(MAX(intA_exp,intB_exp)-14)
  !      READ(expString,*) tol
  !      bool=(ABS(a-b) <= tol)
  !    ENDIF
  !  ELSE
  !    bool=.FALSE.
  !  ENDIF
  !ENDIF
ENDFUNCTION approxeq_test
!
!-------------------------------------------------------------------------------
SUBROUTINE testAPPROXEQ()
  LOGICAL(SBK) :: bool

  COMPONENT_TEST('.APPROXEQ. (SINGLE PRECISION)')
  bool=.NOT.(1.234560_SSK .APPROXEQ. 1.234571_SSK)
  ASSERT(bool, '1.234560_SSK .APPROXEQ. 1.234571_SSK')
  bool=1.234560_SSK .APPROXEQ. 1.234569_SSK
  ASSERT(bool, '1.234560_SSK .APPROXEQ. 1.234570_SSK')
  bool=.NOT.(1.234560e10_SSK .APPROXEQ. 1.234575e10_SSK)
  ASSERT(bool, '1.234560e10_SSK .APPROXEQ. 1.234575e10_SSK')
  bool=.NOT.(1.234560e10_SSK .APPROXEQ. 1.234570e10_SSK)
  ASSERT(bool, '1.234560e10_SSK .APPROXEQ. 1.234570e10_SSK')
  bool=1.234560e-10_SSK .APPROXEQ. 1.234575e-10_SSK
  ASSERT(bool, '1.234560e-10_SSK .APPROXEQ. 1.234575e-10_SSK')
  bool=1.234560e-10_SSK .APPROXEQ. 1.234570e-10_SSK
  ASSERT(bool, '1.234560e-10_SSK .APPROXEQ. 1.234570e-10_SSK')
  bool=0.8_SSK .APPROXEQ. 0.79999999_SSK
  ASSERT(bool, '0.8_SSK .APPROXEQ. 0.79999999_SSK')
  bool=.NOT.(1.0e20_SSK .APPROXEQ. 0.9999999e20_SSK)
  ASSERT(bool, '1.0e20_SSK .APPROXEQ. 0.9999999e20_SSK')
  bool=0.0_SSK .APPROXEQ. 1.2345678e-18_SSK
  ASSERT(bool, '0.0_SSK .APPROXEQ. 1.2345678e-18_SSK')
  bool=.NOT.(1.0_SSK .APPROXEQ. -1.0_SSK)
  ASSERT(bool, '1.0_SSK .APPROXEQ. -1.0_SSK')
  bool=.NOT.(1.0e10_SSK .APPROXEQ. 1.0e-10_SSK)
  ASSERT(bool, '1.0e10_SSK .APPROXEQ. 1.0e-10_SSK')

  COMPONENT_TEST('.APPROXEQ. (DOUBLE PRECISION)')
  bool=.NOT.(1.234567890123450_SDK .APPROXEQ. 1.234567890123465_SDK)
  ASSERT(bool, '1.234567890123450_SDK .APPROXEQ. 1.234567890123465_SDK')
  bool=1.234567890123450_SDK .APPROXEQ. 1.234567890123460_SDK
  ASSERT(bool, '1.234567890123450_SDK .APPROXEQ. 1.234567890123460_SDK')
  bool=.NOT.(1.234567890123450e10_SDK .APPROXEQ. 1.234567890123465e10_SDK)
  ASSERT(bool, '1.234567890123450e10_SDK .APPROXEQ. 1.234567890123465e10_SDK')
  bool=.NOT.(1.234567890123450e10_SDK .APPROXEQ. 1.234567890123460e10_SDK)
  ASSERT(bool, '1.234567890123450e10_SDK .APPROXEQ. 1.234567890123460e10_SDK')
  bool=1.234567890123450e-10_SDK .APPROXEQ. 1.234567890123465e-10_SDK
  ASSERT(bool, '1.234567890123450e-10_SDK .APPROXEQ. 1.234567890123465e-10_SDK')
  bool=1.234567890123450e-10_SDK .APPROXEQ. 1.234567890123460e-10_SDK
  ASSERT(bool, '1.234567890123450e-10_SDK .APPROXEQ. 1.234567890123460e-10_SDK')
  bool=0.8_SDK .APPROXEQ. 0.7999999999999999_SDK
  ASSERT(bool, '0.8_SDK .APPROXEQ. 0.7999999999999999_SDK')
  bool=.NOT.(1.0e20_SDK .APPROXEQ. 0.9999999999999999e20_SDK)
  ASSERT(bool, '1.0e20_SDK .APPROXEQ. 0.9999999999999999e20_SDK')
  bool=0.0_SDK .APPROXEQ. 1.234567890123450e-18_SDK
  ASSERT(bool, '0.0_SDK .APPROXEQ. 1.234567890123450e-18_SDK')
  bool=.NOT.(1.0_SDK .APPROXEQ. -1.0_SDK)
  ASSERT(bool, '1.0_SDK .APPROXEQ. -1.0_SDK')
  bool=.NOT.(1.0e10_SDK .APPROXEQ. 1.0e-10_SDK)
  ASSERT(bool, '1.0e10_SDK .APPROXEQ. 1.0e-10_SDK')
ENDSUBROUTINE testAPPROXEQ
!
!-------------------------------------------------------------------------------
SUBROUTINE testAPPROXEQA()
  LOGICAL(SBK) :: bool

  COMPONENT_TEST('.APPROXEQA. (SINGLE PRECISION)')
  bool=.NOT.(1.234560_SSK .APPROXEQA. 1.234571_SSK)
  ASSERT(bool, '1.234560_SSK .APPROXEQA. 1.234571_SSK')
  bool=1.234560_SSK .APPROXEQA. 1.234569_SSK
  ASSERT(bool, '1.234560_SSK .APPROXEQA. 1.234570_SSK')
  bool=.NOT.(1.234560e10_SSK .APPROXEQA. 1.234575e10_SSK)
  ASSERT(bool, '1.234560e10_SSK .APPROXEQA. 1.234575e10_SSK')
  bool=.NOT.(1.234560e10_SSK .APPROXEQA. 1.234570e10_SSK)
  ASSERT(bool, '1.234560e10_SSK .APPROXEQA. 1.234570e10_SSK')
  bool=1.234560e-10_SSK .APPROXEQA. 1.234575e-10_SSK
  ASSERT(bool, '1.234560e-10_SSK .APPROXEQA. 1.234575e-10_SSK')
  bool=1.234560e-10_SSK .APPROXEQA. 1.234570e-10_SSK
  ASSERT(bool, '1.234560e-10_SSK .APPROXEQA. 1.234570e-10_SSK')
  bool=0.8_SSK .APPROXEQA. 0.79999999_SSK
  ASSERT(bool, '0.8_SSK .APPROXEQA. 0.79999999_SSK')
  bool=.NOT.(1.0e20_SSK .APPROXEQA. 0.9999999e20_SSK)
  ASSERT(bool, '1.0e20_SSK .APPROXEQA. 0.9999999e20_SSK')
  bool=0.0_SSK .APPROXEQA. 1.2345678e-18_SSK
  ASSERT(bool, '0.0_SSK .APPROXEQA. 1.2345678e-18_SSK')
  bool=.NOT.(1.0_SSK .APPROXEQA. -1.0_SSK)
  ASSERT(bool, '1.0_SSK .APPROXEQA. -1.0_SSK')
  bool=.NOT.(1.0e10_SSK .APPROXEQA. 1.0e-10_SSK)
  ASSERT(bool, '1.0e10_SSK .APPROXEQA. 1.0e-10_SSK')

  COMPONENT_TEST('.APPROXEQA. (DOUBLE PRECISION)')
  bool=.NOT.(1.234567890123450_SDK .APPROXEQA. 1.234567890123465_SDK)
  ASSERT(bool, '1.234567890123450_SDK .APPROXEQA. 1.234567890123465_SDK')
  bool=1.234567890123450_SDK .APPROXEQA. 1.234567890123460_SDK
  ASSERT(bool, '1.234567890123450_SDK .APPROXEQA. 1.234567890123460_SDK')
  bool=.NOT.(1.234567890123450e10_SDK .APPROXEQA. 1.234567890123465e10_SDK)
  ASSERT(bool, '1.234567890123450e10_SDK .APPROXEQA. 1.234567890123465e10_SDK')
  bool=.NOT.(1.234567890123450e10_SDK .APPROXEQA. 1.234567890123460e10_SDK)
  ASSERT(bool, '1.234567890123450e10_SDK .APPROXEQA. 1.234567890123460e10_SDK')
  bool=1.234567890123450e-10_SDK .APPROXEQA. 1.234567890123465e-10_SDK
  ASSERT(bool, '1.234567890123450e-10_SDK .APPROXEQA. 1.234567890123465e-10_SDK')
  bool=1.234567890123450e-10_SDK .APPROXEQA. 1.234567890123460e-10_SDK
  ASSERT(bool, '1.234567890123450e-10_SDK .APPROXEQA. 1.234567890123460e-10_SDK')
  bool=0.8_SDK .APPROXEQA. 0.7999999999999999_SDK
  ASSERT(bool, '0.8_SDK .APPROXEQA. 0.7999999999999999_SDK')
  bool=.NOT.(1.0e20_SDK .APPROXEQA. 0.9999999999999999e20_SDK)
  ASSERT(bool, '1.0e20_SDK .APPROXEQA. 0.9999999999999999e20_SDK')
  bool=0.0_SDK .APPROXEQA. 1.234567890123450e-18_SDK
  ASSERT(bool, '0.0_SDK .APPROXEQA. 1.234567890123450e-18_SDK')
  bool=.NOT.(1.0_SDK .APPROXEQA. -1.0_SDK)
  ASSERT(bool, '1.0_SDK .APPROXEQA. -1.0_SDK')
  bool=.NOT.(1.0e10_SDK .APPROXEQA. 1.0e-10_SDK)
  ASSERT(bool, '1.0e10_SDK .APPROXEQA. 1.0e-10_SDK')
ENDSUBROUTINE testAPPROXEQA
!
!-------------------------------------------------------------------------------
SUBROUTINE testAPPROXEQR()
  LOGICAL(SBK) :: bool

  COMPONENT_TEST('.APPROXEQR. (SINGLE PRECISION)')
  bool=.NOT.(1.234560_SSK .APPROXEQR. 1.234575_SSK)
  ASSERT(bool, '1.234560_SSK .APPROXEQR. 1.234575_SSK')
  bool=1.234560_SSK .APPROXEQR. 1.234570_SSK
  ASSERT(bool, '1.234560_SSK .APPROXEQR. 1.234570_SSK')
  bool=.NOT.(1.234560e10_SSK .APPROXEQR. 1.234575e10_SSK)
  ASSERT(bool, '1.234560e10_SSK .APPROXEQR. 1.234575e10_SSK')
  bool=1.234560e10_SSK .APPROXEQR. 1.234570e10_SSK
  ASSERT(bool, '1.234560e10_SSK .APPROXEQR. 1.234570e10_SSK')
  bool=.NOT.(1.234560e-10_SSK .APPROXEQR. 1.234575e-10_SSK)
  ASSERT(bool, '1.234560e-10_SSK .APPROXEQR. 1.234575e-10_SSK')
  bool=1.234560e-10_SSK .APPROXEQR. 1.234570e-10_SSK
  ASSERT(bool, '1.234560e-10_SSK .APPROXEQR. 1.234570e-10_SSK')
  bool=0.8_SSK .APPROXEQR. 0.79999999_SSK
  ASSERT(bool, '0.8_SSK .APPROXEQR. 0.79999999_SSK')
  bool=1.0e20_SSK .APPROXEQR. 0.9999999e20_SSK
  ASSERT(bool, '1.0e20_SSK .APPROXEQR. 0.9999999e20_SSK')
  bool=0.0_SSK .APPROXEQR. 1.2345678e-18_SSK
  ASSERT(bool, '0.0_SSK .APPROXEQR. 1.2345678e-18_SSK')
  bool=.NOT.(1.0_SSK .APPROXEQR. -1.0_SSK)
  ASSERT(bool, '1.0_SSK .APPROXEQR. -1.0_SSK')
  bool=.NOT.(1.0e10_SSK .APPROXEQR. 1.0e-10_SSK)
  ASSERT(bool, '1.0e10_SSK .APPROXEQR. 1.0e-10_SSK')

  COMPONENT_TEST('.APPROXEQR. (DOUBLE PRECISION)')
  bool=.NOT.(1.234567890123450_SDK .APPROXEQR. 1.234567890123465_SDK)
  ASSERT(bool, '1.234567890123450_SDK .APPROXEQR. 1.234567890123465_SDK')
  bool=1.234567890123450_SDK .APPROXEQR. 1.234567890123460_SDK
  ASSERT(bool, '1.234567890123450_SDK .APPROXEQR. 1.234567890123460_SDK')
  bool=.NOT.(1.234567890123450e10_SDK .APPROXEQR. 1.234567890123465e10_SDK)
  ASSERT(bool, '1.234567890123450e10_SDK .APPROXEQR. 1.234567890123465e10_SDK')
  bool=1.234567890123450e10_SDK .APPROXEQR. 1.234567890123460e10_SDK
  ASSERT(bool, '1.234567890123450e10_SDK .APPROXEQR. 1.234567890123460e10_SDK')
  bool=.NOT.(1.234567890123450e-10_SDK .APPROXEQR. 1.234567890123465e-10_SDK)
  ASSERT(bool, '1.234567890123450e-10_SDK .APPROXEQR. 1.234567890123465e-10_SDK')
  bool=1.234567890123450e-10_SDK .APPROXEQR. 1.234567890123460e-10_SDK
  ASSERT(bool, '1.234567890123450e-10_SDK .APPROXEQR. 1.234567890123460e-10_SDK')
  bool=0.8_SDK .APPROXEQR. 0.7999999999999999_SDK
  ASSERT(bool, '0.8_SDK .APPROXEQR. 0.7999999999999999_SDK')
  bool=1.0e20_SDK .APPROXEQR. 0.9999999999999999e20_SDK
  ASSERT(bool, '1.0e20_SDK .APPROXEQR. 0.9999999999999999e20_SDK')
  bool=0.0_SDK .APPROXEQR. 1.234567890123450e-18_SDK
  ASSERT(bool, '0.0_SDK .APPROXEQR. 1.234567890123450e-18_SDK')
  bool=.NOT.(1.0_SDK .APPROXEQR. -1.0_SDK)
  ASSERT(bool, '1.0_SDK .APPROXEQR. -1.0_SDK')
  bool=.NOT.(1.0e10_SDK .APPROXEQR. 1.0e-10_SDK)
  ASSERT(bool, '1.0e10_SDK .APPROXEQR. 1.0e-10_SDK')
ENDSUBROUTINE testAPPROXEQR
!
!-------------------------------------------------------------------------------
SUBROUTINE testAPPROXEQF()
  LOGICAL(SBK) :: bool
  COMPONENT_TEST('.APPROXEQF. (SINGLE PRECISION)')
  bool=.NOT.(1.234560_SSK .APPROXEQF. 1.234575_SSK)
  ASSERT(bool, '1.234560_SSK .APPROXEQF. 1.234575_SSK')
  bool=1.234560_SSK .APPROXEQF. 1.234561_SSK
  ASSERT(bool, '1.234560_SSK .APPROXEQF. 1.234561_SSK')
  bool=.NOT.(1.234560e10_SSK .APPROXEQF. 1.234575e10_SSK)
  ASSERT(bool, '1.234560e10_SSK .APPROXEQF. 1.234575e10_SSK')
  bool=1.234560e10_SSK .APPROXEQF. 1.234561e10_SSK
  ASSERT(bool, '1.234560e10_SSK .APPROXEQF. 1.234561e10_SSK')
  bool=.NOT.(1.234560e-10_SSK .APPROXEQF. 1.234575e-10_SSK)
  ASSERT(bool, '1.234560e-10_SSK .APPROXEQF. 1.234575e-10_SSK')
  bool=1.234560e-10_SSK .APPROXEQF. 1.234561e-10_SSK
  ASSERT(bool, '1.234560e-10_SSK .APPROXEQF. 1.234561e-10_SSK')
  bool=0.8_SSK .APPROXEQF. 0.79999999_SSK
  ASSERT(bool, '0.8_SSK .APPROXEQF. 0.79999999_SSK')
  bool=1.0e20_SSK .APPROXEQF. 0.9999999e20_SSK
  ASSERT(bool, '1.0e20_SSK .APPROXEQF. 0.9999999e20_SSK')
  bool=0.0_SSK .APPROXEQF. 1.2345678e-18_SSK
  ASSERT(bool, '0.0_SSK .APPROXEQF. 1.2345678e-18_SSK')
  bool=.NOT.(1.0_SSK .APPROXEQF. -1.0_SSK)
  ASSERT(bool, '1.0_SSK .APPROXEQF. -1.0_SSK')
  bool=.NOT.(1.0e10_SSK .APPROXEQF. 1.0e-10_SSK)
  ASSERT(bool, '1.0e10_SSK .APPROXEQF. 1.0e-10_SSK')

  COMPONENT_TEST('.APPROXEQF. (DOUBLE PRECISION)')
  bool=.NOT.(1.234567890123450_SDK .APPROXEQF. 1.234567890123465_SDK)
  ASSERT(bool, '1.234567890123450_SDK .APPROXEQF. 1.234567890123465_SDK')
  bool=1.234567890123450_SDK .APPROXEQF. 1.234567890123452_SDK
  ASSERT(bool, '1.234567890123450_SDK .APPROXEQF. 1.234567890123452_SDK')
  bool=.NOT.(1.234567890123450e10_SDK .APPROXEQF. 1.234567890123465e10_SDK)
  ASSERT(bool, '1.234567890123450e10_SDK .APPROXEQF. 1.234567890123465e10_SDK')
  bool=1.234567890123450e10_SDK .APPROXEQF. 1.234567890123452e10_SDK
  ASSERT(bool, '1.234567890123450e10_SDK .APPROXEQF. 1.234567890123452e10_SDK')
  bool=.NOT.(1.234567890123450e-10_SDK .APPROXEQF. 1.234567890123465e-10_SDK)
  ASSERT(bool, '1.234567890123450e-10_SDK .APPROXEQF. 1.234567890123465e-10_SDK')
  bool=1.234567890123450e-10_SDK .APPROXEQF. 1.234567890123452e-10_SDK
  ASSERT(bool, '1.234567890123450e-10_SDK .APPROXEQF. 1.234567890123452e-10_SDK')
  bool=0.8_SDK .APPROXEQF. 0.7999999999999999_SDK
  ASSERT(bool, '0.8_SDK .APPROXEQF. 0.7999999999999999_SDK')
  bool=1.0e20_SDK .APPROXEQF. 0.9999999999999999e20_SDK
  ASSERT(bool, '1.0e20_SDK .APPROXEQF. 0.9999999999999999e20_SDK')
  bool=0.0_SDK .APPROXEQF. 1.234567890123450e-18_SDK
  ASSERT(bool, '0.0_SDK .APPROXEQF. 1.234567890123450e-18_SDK')
  bool=.NOT.(1.0_SDK .APPROXEQF. -1.0_SDK)
  ASSERT(bool, '1.0_SDK .APPROXEQF. -1.0_SDK')
  bool=.NOT.(1.0e10_SDK .APPROXEQF. 1.0e-10_SDK)
  ASSERT(bool, '1.0e10_SDK .APPROXEQF. 1.0e-10_SDK')
ENDSUBROUTINE testAPPROXEQF
!
!-------------------------------------------------------------------------------
SUBROUTINE testAPPROXLE()
  LOGICAL(SBK) :: bool
  COMPONENT_TEST('.APPROXLE. (DOUBLE PRECISION)')
  bool=.NOT.(.NOT.(1.00000000000001_SDK .APPROXLE. 1._SDK) .OR. &
             .NOT.(1._SDK               .APPROXLE. 3._SDK) .OR. &
                  (1.000000000000011_SDK .APPROXLE. 1._SDK) .OR. &
                  (3._SDK                .APPROXLE. 1._SDK))
  ASSERT(bool, '.APPROXLE. (DOUBLE PRECISION)')
  COMPONENT_TEST('.APPROXLE. (SINGLE PRECISION)')
  bool=.NOT.(.NOT.(1.000009_SSK .APPROXLE. 1._SSK) .OR. &
             .NOT.(1._SSK       .APPROXLE. 3._SSK) .OR. &
                  (1.000011_SSK .APPROXLE. 1._SSK) .OR. &
                  (3._SSK       .APPROXLE. 1._SSK))
  ASSERT(bool, '.APPROXLE. (SINGLE PRECISION)')
ENDSUBROUTINE testAPPROXLE
!
!-------------------------------------------------------------------------------
SUBROUTINE testAPPROXGE()
  LOGICAL(SBK) :: bool
  COMPONENT_TEST('.APPROXGE. (DOUBLE PRECISION)')
  bool=.NOT.(.NOT.(1._SDK .APPROXGE. 1.00000000000001_SDK) .OR. &
             .NOT.(3._SDK .APPROXGE.               1._SDK) .OR. &
                  (1._SDK .APPROXGE. 1.000000000000011_SDK) .OR. &
                  (1._SDK .APPROXGE.               3._SDK))
  ASSERT(bool, '.APPROXGE. (DOUBLE PRECISION)')
  COMPONENT_TEST('.APPROXGE. (SINGLE PRECISION)')
  bool=.NOT.(.NOT.(1._SSK .APPROXGE. 1.000009_SSK) .OR. &
             .NOT.(3._SSK .APPROXGE.       1._SSK) .OR. &
                  (1._SSK .APPROXGE. 1.000011_SSK) .OR. &
                  (1._SSK .APPROXGE.        3._SSK))
  ASSERT(bool, '.APPROXGE. (SINGLE PRECISION)')
ENDSUBROUTINE testAPPROXGE
!
!-------------------------------------------------------------------------------
SUBROUTINE testSOFTEQ()
  LOGICAL(SBK) :: bool
  COMPONENT_TEST('.SOFTEQ. (DOUBLE PRECISION)')
  bool=.NOT.(.NOT.(SOFTEQ(1.0000001_SDK,1._SDK,1.0E-6_SDK)) .OR. &
                  (SOFTEQ(1.0000011_SDK,1._SDK,1.0E-6_SDK)))
  ASSERT(bool, 'SOFTEQ(...) (DOUBLE PRECISION)')
  COMPONENT_TEST('.SOFTEQ. (SINGLE PRECISION)')
  bool=.NOT.(.NOT.(SOFTEQ(1.00001_SSK,1._SSK,1.0E-4_SSK)) .OR. &
                  (SOFTEQ(1.00011_SSK,1._SSK,1.0E-4_SSK)))
  ASSERT(bool, 'SOFTEQ(...) (SINGLE PRECISION)')
ENDSUBROUTINE testSOFTEQ
!
!-------------------------------------------------------------------------------
SUBROUTINE testSOFTCompare()
  LOGICAL(SBK) :: bool
  COMPONENT_TEST('SOFTLT (DOUBLE PRECISION)')
  bool = SOFTLT(1.0_SDK,1.11_SDK,0.1_SDK)
  ASSERT(bool, "is less than")
  bool = .NOT.SOFTLT(1.0_SDK,1.09_SDK,0.1_SDK)
  ASSERT(bool, "not less than")

  COMPONENT_TEST('SOFTLT (SINGLE PRECISION)')
  bool = SOFTLT(1.0_SSK,1.11_SSK,0.1_SSK)
  ASSERT(bool, "is less than")
  bool = .NOT.SOFTLT(1.0_SSK,1.09_SSK,0.1_SSK)
  ASSERT(bool, "not less than")

  COMPONENT_TEST('SOFTLE (DOUBLE PRECISION)')
  bool = SOFTLE(1.09_SDK,1.0_SDK,0.1_SDK)
  ASSERT(bool, "is less than/equal to")
  bool = .NOT.SOFTLT(1.11_SDK,1.0_SDK,0.1_SDK)
  ASSERT(bool, "too big")

  COMPONENT_TEST('SOFTLE (SINGLE PRECISION)')
  bool = SOFTLE(1.09_SSK,1.0_SSK,0.1_SSK)
  ASSERT(bool, "is less than/equal to")
  bool = .NOT.SOFTLT(1.11_SSK,1.0_SSK,0.1_SSK)
  ASSERT(bool, "too big")

  COMPONENT_TEST('SOFTGT (DOUBLE PRECISION)')
  bool = SOFTGT(1.11_SDK,1.0_SDK,0.1_SDK)
  ASSERT(bool, "is greater than")
  bool = .NOT.SOFTGT(1.09_SDK,1.0_SDK,0.1_SDK)
  ASSERT(bool, "too small")

  COMPONENT_TEST('SOFTGT (SINGLE PRECISION)')
  bool = SOFTGT(1.11_SSK,1.0_SSK,0.1_SSK)
  ASSERT(bool, "is greater than")
  bool = .NOT.SOFTGT(1.09_SSK,1.0_SSK,0.1_SSK)
  ASSERT(bool, "too small")

  COMPONENT_TEST('SOFTGE (DOUBLE PRECISION)')
  bool = SOFTGE(0.91_SDK,1.0_SDK,0.1_SDK)
  ASSERT(bool, "is greater than")
  bool = .NOT.SOFTGE(0.89_SDK,1.0_SDK,0.1_SDK)
  ASSERT(bool, "too small")

  COMPONENT_TEST('SOFTGE (SINGLE PRECISION)')
  bool = SOFTGE(0.91_SSK,1.0_SSK,0.1_SSK)
  ASSERT(bool, "is greater than")
  bool = .NOT.SOFTGE(0.89_SSK,1.0_SSK,0.1_SSK)
  ASSERT(bool, "too small")
ENDSUBROUTINE testSOFTCompare
!
!-------------------------------------------------------------------------------
SUBROUTINE testisNAN()
  LOGICAL(SBK) :: bool
  COMPONENT_TEST('isNAN (DOUBLE PRECISION)')
  doublefloat=-1.0_SDK
  bool=.NOT.(.NOT.(isNAN(REAL(SQRT(doublefloat),SDK))) .OR. &
                  (isNAN(REAL(SQRT(1.0_SDK),SDK))))
  ASSERT(bool, 'isNAN(...) (DOUBLE PRECISION)')
  COMPONENT_TEST('isNAN (SINGLE PRECISION)')
  singlefloat=-1.0_SSK
  bool=.NOT.(.NOT.(isNAN(REAL(SQRT(singlefloat),SSK))) .OR. &
                  (isNAN(REAL(SQRT(1.0_SSK),SSK))))
  ASSERT(bool, 'isNAN(...) (SINGLE PRECISION)')
ENDSUBROUTINE testisNAN
!
!-------------------------------------------------------------------------------
SUBROUTINE testisINF()
  LOGICAL(SBK) :: bool
  COMPONENT_TEST('isInf (DOUBLE PRECISION)')
  doublefloat=0.0_SDK
  bool=.NOT.(.NOT.(isINF(REAL(1.0_SDK/doublefloat,SDK))) .OR. &
                  (isINF(REAL(1.0_SDK,SDK))))
  ASSERT(bool, 'isINF(...) (DOUBLE PRECISION)')
  COMPONENT_TEST('isInf (SINGLE PRECISION)')
  singlefloat=0.0_SDK
  bool=.NOT.(.NOT.(isINF(REAL(1.0_SSK/singlefloat,SSK))) .OR. &
                  (isINF(REAL(1.0_SSK,SSK))))
  ASSERT(bool, 'isINF(...) (SINGLE PRECISION)')
ENDSUBROUTINE testisInf
!
!-------------------------------------------------------------------------------
SUBROUTINE testCharToInt()
  CHARACTER(LEN=*),PARAMETER :: c1='1234567890'
  CHARACTER(LEN=*),PARAMETER :: c2='-1234567890'
  CHARACTER(LEN=*),PARAMETER :: c3='0'
  CHARACTER(LEN=*),PARAMETER :: c4='-0'
  CHARACTER(LEN=*),PARAMETER :: c5='2147483647'
  CHARACTER(LEN=*),PARAMETER :: c6='-2147483647'
  INTEGER(SIK) :: intVal

  COMPONENT_TEST('Char to integer assignment')
  intVal=c1
  ASSERT(intVal == 1234567890, 'char to int assignment')
  intVal=c2
  ASSERT(intVal == -1234567890, 'char to int assignment')
  intVal=c3
  ASSERT(intVal == 0, 'char to int assignment, 0')
  intVal=c4
  ASSERT(intVal == 0, 'char to int assignment, -0')
  intVal=c5
  ASSERT(intVal == 2147483647, 'char to int assignment, maximum SIK value')
  intVal=c6
  ASSERT(intVal == -2147483647, 'char to int assignment, minimum SIK value')
ENDSUBROUTINE testCharToInt
!
!-------------------------------------------------------------------------------
SUBROUTINE testCharToSingle()
  CHARACTER(LEN=*),PARAMETER :: s1='1.1'
  CHARACTER(LEN=*),PARAMETER :: s2='-734723741.00003213'
  CHARACTER(LEN=*),PARAMETER :: s3='0.0000100'
  CHARACTER(LEN=*),PARAMETER :: s4='.5'
  CHARACTER(LEN=*),PARAMETER :: s5='2147483647.2147483647'
  CHARACTER(LEN=*),PARAMETER :: s6='1.4363e06'
  CHARACTER(LEN=*),PARAMETER :: s7='13612.59723'
  CHARACTER(LEN=*),PARAMETER :: s8='1234'
  CHARACTER(LEN=*),PARAMETER :: s9='1e-5'
  REAL(SSK) :: realVal

  COMPONENT_TEST('Char to single precision real')
  realVal=s1
  ASSERT(realVal .APPROXEQF. 1.1, 'Char to single precision real assignment')
  realVal=s2
  ASSERT(realVal .APPROXEQF. -734723741.000033, 'Char to single precision real assignment')
  realVal=s3
  ASSERT(realVal .APPROXEQF. 0., 'Char to single precision real assignment')
  realVal=s4
  ASSERT(realVal .APPROXEQF. .5, 'Char to single precision real assignment')
  realVal=s5
  ASSERT(realVal .APPROXEQF. 2147483647.3147483647, 'Char to single precision real assignment')
  realVal=s6
  ASSERT(realVal .APPROXEQF. 1.4363e06, 'Char to single precision real assignment, scientific')
  realVal=s7
  ASSERT(realVal .APPROXEQF. 13612.59723, 'Char to single precision real assignment')
  realVal=s8
  ASSERT(realVal == 1234, 'Char to single precision real assignment, integer value')
  realVal=s9
  ASSERT(realVal .APPROXEQF. 0.00001, 'Char to single precision real assignment, scientfic no decimal')
ENDSUBROUTINE testCharToSingle
!
!-------------------------------------------------------------------------------
SUBROUTINE testCharToDouble()
  CHARACTER(LEN=*),PARAMETER :: d1='1.1'
  CHARACTER(LEN=*),PARAMETER :: d2='-734723741.000033'
  CHARACTER(LEN=*),PARAMETER :: d3='0.0000100'
  CHARACTER(LEN=*),PARAMETER :: d4='.5'
  CHARACTER(LEN=*),PARAMETER :: d5='2147483647.2147483647'
  CHARACTER(LEN=*),PARAMETER :: d6='1.4363e06'
  CHARACTER(LEN=*),PARAMETER :: d8='11.000000000000100'
  CHARACTER(LEN=*),PARAMETER :: d9='1234'
  CHARACTER(LEN=*),PARAMETER :: d10='1e-5'
  REAL(SDK) :: doubleVal

  COMPONENT_TEST('Char to double precision real')
  doubleVal=d1
  ASSERT(doubleVal .APPROXEQF. 1.1_SDK, 'Char to double precision real assignment')
  doubleVal=d2
  ASSERT(doubleVal .APPROXEQF. -734723741.000033_SDK, 'Char to double precision real assignment')
  FINFO() doubleVal, d2
  doubleVal=d3
  ASSERT(doubleVal .APPROXEQF. 0.0000100_SDK, 'Char to double precision real assignment')
  doubleVal=d4
  ASSERT(doubleVal .APPROXEQF. .5_SDK, 'Char to double precision real assignment')
  doubleVal=d5
  ASSERT(doubleVal .APPROXEQF. 2147483647.2147483647_SDK, 'Char to double precision real assignment')
  FINFO() doubleVal, d5
  doubleVal=d6
  ASSERT(doubleVal .APPROXEQF. 1.4363e06_SDK, 'Char to double precision real assignment')
  doubleVal=d8
  ASSERT(doubleVal .APPROXEQF. 11.000000000000100_SDK, 'Char to double precision real assignment')
  FINFO() doubleVal, d8
  doubleVal=d9
  ASSERT(doubleVal == 1234, 'Char to double precision real assignment, integer value')
  doubleVal=d10
  ASSERT(doubleVal .APPROXEQF. 0.00001_SDK, 'Char to double precision value, scientific no decimal')
ENDSUBROUTINE testCharToDouble
!
!-------------------------------------------------------------------------------
SUBROUTINE testCharToBool()
  LOGICAL(SBK) :: bool
  CHARACTER(LEN=*),PARAMETER :: b1='true'
  CHARACTER(LEN=*),PARAMETER :: b2='false'

  COMPONENT_TEST('Char to boolean assignment')
  bool=b1
  ASSERT(bool == .TRUE., 'char to bool assignment, true')
  bool=b2
  ASSERT(bool == .FALSE., 'char to bool assignment, false')
ENDSUBROUTINE testCharToBool
!
!-------------------------------------------------------------------------------
!SUBROUTINE testCharToIntArray()
!  INTEGER(SIK),ALLOCATABLE :: intArray(:)
!  CHARACTER(LEN=*),PARAMETER :: ia1='{1,2,3,4,5,6,2394}'
!  CHARACTER(LEN=*),PARAMETER :: ia2='{10}'
!  CHARACTER(LEN=*),PARAMETER :: ia3='{}'
!  CHARACTER(LEN=*),PARAMETER :: ia4='{2147483647,-2147483647,0,-0, -1352}'
!  LOGICAL(SBK) :: bool
!  COMPONENT_TEST('Char to Int Array assignment')

!  CALL char_to_int_array(intArray,ia1)
!  bool=ALL(intArray == (/1,2,3,4,5,6,2394/))
!  ASSERT(bool, 'Basic char to int array assignment')
!  CALL char_to_int_array(intArray,ia2)
!  bool=ALL(intArray == (/10/))
!  ASSERT(bool, 'Char to int array assignment, one value')
!  CALL char_to_int_array(intArray,ia3)
!  ASSERT(.NOT.(ALLOCATED(intArray)), 'Char to int array, empty')
!  CALL char_to_int_array(intArray,ia4)
!  bool=ALL(intArray == (/2147483647,-2147483647,0,0/))
!  ASSERT(bool, 'Char to int array assignment, various values, negatives')

!ENDSUBROUTINE testCharToIntArray
!
!---!----------------------------------------------------------------------------
!SUBROUTINE testCharToDoubleArray()
!  REAL(SDK),ALLOCATABLE :: doubleArray(:)
!  CHARACTER(LEN=*),PARAMETER :: da1='{1.0,2.1,3.2,4.5,235.235}'
!  CHARACTER(LEN=*),PARAMETER :: da2='{-734723741.000033,2147483647.2147483647}'
!  CHARACTER(LEN=*),PARAMETER :: da3='{1e5,1e-5,1.351632e12,-4.324E-2}'
!  CHARACTER(LEN=*),PARAMETER :: da4='{8.2085e+05,1.1109e+05,5.5308e+03,&
!    1.8644e+02,3.7612e+01,3.5379e+01,2.7697e+01,2.1684e+01,2.0397e+01,&
!      1.5968e+01,7.1500e+00,6.7000e+00,6.3000e+00,1.0970e+00,1.0450e+00,&
!      9.5000e-01,3.5000e-01,2.0600e-01,1.0700e-01,5.8000e-02,2.5000e-02,&
!      1.0000e-02,1.0000e-05}'
!  LOGICAL(SBK) :: bool
!  COMPONENT_TEST('Char to Double Array assignment')

!  CALL char_to_double_array(doubleArray,da1)
!  bool=ALL(doubleArray .APPROXEQF. (/1.0_SDK,2.1_SDK,3.2_SDK,4.5_SDK,235.235_SDK/))
!  ASSERT(bool, 'Char to double array assignment')
!  CALL char_to_double_array(doubleArray,da2)
!  bool=ALL(doubleArray .APPROXEQF. (/-734723741.000033_SDK,2147483647.2147483647_SDK/))
!  ASSERT(bool, 'Char to double array assignment, big numbers')
!  CALL char_to_double_array(doubleArray,da3)
!  bool=ALL(doubleArray .APPROXEQF. (/1e5_SDK,1e-5_SDK,1.351632e12_SDK,-4.324E-2_SDK/))
!  ASSERT(bool, 'Char to double array assignment, scientific notation')
!  CALL char_to_double_array(doubleArray,da4)
!  bool=ALL(doubleArray .APPROXEQF. (/8.2085e+05_SDK,1.1109e+05_SDK,5.5308e+03_SDK,&
!    1.8644e+02_SDK,3.7612e+01_SDK,3.5379e+01_SDK,2.7697e+01_SDK,2.1684e+01_SDK,2.0397e+01_SDK,&
!      1.5968e+01_SDK,7.1500e+00_SDK,6.7000e+00_SDK,6.3000e+00_SDK,1.0970e+00_SDK,1.0450e+00_SDK,&
!      9.5000e-01_SDK,3.5000e-01_SDK,2.0600e-01_SDK,1.0700e-01_SDK,5.8000e-02_SDK,2.5000e-02_SDK,&
!      1.0000e-02_SDK,1.0000e-05_SDK/))
!  ASSERT(bool, 'Char to double array, large array')
!ENDSUBROUTINE testCharToDoubleArray
!
!-------------------------------------------------------------------------------
!SUBROUTINE testCharToStrArray()
!  COMPONENT_TEST('Char to String Array assignment')
!ENDSUBROUTINE testCharToStrArray
!
ENDPROGRAM testSelectedKinds


!-----------------------------------------------------------------------------
!+ Math/geometric routines
!
!  Subroutine quicksort
!  Subroutine int_curve_curve
!  Subroutine int_line_curve
!  Subroutine int_two_lines
!  Subroutine move_L_on_C
!  Subroutine linear_interp
!  Subroutine locate_bisect
!  Function rlinspace
!  Function inside_poly
!
!-----------------------------------------------------------------------------
Module math_geo_module
Implicit None
Private
Public :: linear_interp
Public :: rlinspace
Contains

!------------------------------------------------------------------------------
!+ Linear interpolation
!------------------------------------------------------------------------------
Subroutine linear_interp(xarr,yarr,narr,xin,yout,ierr)
Use kind_mod, Only: real64, int32
Implicit None
Integer(int32), Intent(In) :: narr
Real(real64), Intent(In) :: xarr(narr), yarr(narr), xin
Integer(int32), Intent(Out) :: ierr
Real(real64), Intent(Out) :: yout

Integer(int32) :: j

If (xin .lt. Minval(xarr)) Then
  Write(*,*) 'Error from linear_interp, x out of bounds lower (x,Minval(xarr))=',xin,Minval(xarr)
  ierr = 1
  Return
!  Stop "quitting"
Endif
If (xin .gt. Maxval(xarr)) Then
  Write(*,*) 'Error from linear_interp, x out of bounds upper (x,Maxval(xarr))=',xin,Maxval(xarr)
  ierr = 1
  Return
!  Stop "quitting"
Endif
Call locate_bisect(xarr,narr,xin,j,ierr)

If (j .eq. 0) Then
  If (abs(xin - xarr(1)) < 1.e-10) Then
    yout = yarr(1)
    ierr = 0
    Return
  Endif
Endif
If (j .eq. narr) Then
  If (abs(xin - xarr(narr)) < 1.e-10) Then
    yout = yarr(narr)
    ierr = 0
    Return
  Endif
Endif

If (ierr .eq. 1) Then
  Write(*,*) "xarr([1,end])",xarr(1),xarr(narr)
  Write(*,*) "xin",xin
  Write(*,*) 'xin - xarr(1)',xin-xarr(1)
  Stop "error linear interp!, ierr set from locate_bisect"
  yout = 0.d0
  Return
Endif

yout = yarr(j) + ((xin-xarr(j))/(xarr(j+1)-xarr(j)))*(yarr(j+1)-yarr(j))

End Subroutine linear_interp

!------------------------------------------------------------------------------
!+ Search an ordered list of xarr for x, returns j where xarr(j) <= x <= xarr(j+1)
!------------------------------------------------------------------------------
Subroutine locate_bisect(xarr,narr,x,j,ierr)
!
! If x is off the table (including exactly equal to end values!) then
!  j is set to 0 (off left end) or narr (off right end)
!
Use kind_mod, Only: real64, int32
Implicit None
Integer(int32), Intent(In) :: narr
Real(real64), Intent(In) :: xarr(narr), x
Integer(int32), Intent(Out) :: j, ierr
Logical :: test1
Integer(int32) :: jlo, jup, jmid
ierr = 0
jlo = 0
jup = narr + 1
test1 = ( xarr(narr) .gt. xarr(1) )

!If ( ( x .gt. Maxval(xarr) ) .OR. ( x .lt. Minval(xarr) ) ) Then
!  ierr = 1
!  Stop "x out of range in locate_bisect"
!Endif

Do While (jup - jlo .gt. 1)
  jmid = (jup + jlo)/2  ! compute midpoint
  If ( test1 .eqv. (x .gt. xarr(jmid)) ) Then
    jlo = jmid
  Else
    jup = jmid
  Endif
Enddo
j = jlo

If (( j .eq. 0 ) .OR. (j .eq. narr)) ierr = 1

End Subroutine locate_bisect

!------------------------------------------------------------------------------
!+ Returns a linearly spaced real vector given endpoints and number of elements
!------------------------------------------------------------------------------
Function rlinspace(xstart,xend,numel)  &
Result(rlinvec)
!
! Description:
!   This function returns a real vector of length(numel) with linearly spaced
!   values from xstart to xend.  Similar to the Matlab function.
!
! Inputs:
!  xstart,xend: Values of the first and last points of the array [real]
!  numel: Number of elements in the array [integer]
! Outputs:
!  rlinvec: The linearly spaced array
!
! History:
!  Version   Date      Comment
!  -------   ----      -------
!  1.0     07/22/2009  Original Code.  JL
!  1.1     09/01/2010  Updated for PENTA3. JL
!  1.2     07/18/2011  Ported to w7 routines. JL
!
! Author(s): J. Lore 07/2009 - 7/18/2011
!
! Modules used:
Use kind_mod, Only: real64, int32

Implicit None

! Input/output                      !See above for descriptions
Real(real64),    Intent(in) :: xstart
Real(real64),    Intent(in) :: xend
Integer(int32), Intent(in) :: numel
Real(real64)                :: rlinvec(numel)

! Local scalars
Integer(int32)   ::  ii
!- End of header -------------------------------------------------------------

If (numel .eq. 1) Then
  rlinvec(1) = xstart
  Return
Endif

Do ii = 1,numel
  rlinvec(ii) = ( Real(ii,real64) - 1._real64 ) * ( xend - xstart ) &
       / ( numel - 1._real64 ) + xstart
Enddo

EndFunction rlinspace

End Module math_geo_module


      SUBROUTINE filters( nt, rvector, srate, f1, f2, idb, ifiltyp,
     &                    minphase, iii )
c     FILTERS produces a frequency domain filter which is multiplied
c  with the transformed time series.  The time series is then inverse
c  transformed back to the time domain.
c
c  ARGUMENTS:
c  nt      - The number of time points in rvector.
c  rvector - The time series to be filtered.  The filtered output is
c            returned in rvector.  10000 max
c  srate   - The sample rate in samples per second.
c  f1      - The low corner frequency.
c  f2      - The high corner frequency.
c  idb     - The INTEGER attenuation in dB at first octave (6dB for each
c            pole)
c  ifiltyp - filter type
c          =0, a combination of low and high pass
c          =1, low pass Butterworth, where f1 is the corner frequency
c          =2, high pass Butterworth, where f1 is the corner frequency
c          =3, notch filter, where f1 is the lower frequency and
c               f2 is the upper one.
c  minphase =1 means minimum phase filter, otherwise it is zero phase.
c  iii     =1, generate a new filter, otherwise no filter is generated
c
c  Author: John Shay, Oregon State Univbersity, April 8, 1988
c  mod 31 jan 92 - change array sizes to 5000 from 10000 so that it
c         compiles on the Apollo!
c                - Also commented out an unused factor = statement.
c                - Correct high pass (type 2)
c  mod 1 July 93 - zero from nt+1 to nfft rather with data!
c  mod 20 Jun 95 by mwh - check trace length and make array lengths a
c                  parameter and increase it to a power of 2!
c mod 16 July 95 by Gail Christeson
c       - reduce output amplitudes by nfft
c       - Fix notch filters
c mod 18 Nov 96 - Alistair - Redo minimum phase so that it works in all cases
c  mod 15 Apr. 97 - Make some of filters.f arrays COMMON.
c  mod 16 Oct 03 - Alistair - Add factor of 2 to minimum phase dropoff
c
      INTEGER MAXLEN
c   IF you change MAXLEN, change contro also!
      PARAMETER( MAXLEN = 16384 * 2 )
      REAL maxabsval, rvector(1)
      LOGICAL firsttime
      COMMON /filtersc/ filt1(MAXLEN), refw(MAXLEN),
     &    filtl(MAXLEN), filth(MAXLEN)
      COMPLEX filt1, refw, filtl, filth
      COMPLEX filt(MAXLEN), filtt(1)
      EQUIVALENCE (filt,filtt)
      SAVE filt, firsttime, nfft, nw
      PARAMETER( pi = 3.14159265 )
      DATA nfftold/0/, f1old/0./, f2old/0./, idbold/0/
c
c  mod. June 95 - Change MAXLEN to 8192
c  mod. 23 Oct 95 - Change wording of error message

c      print *,' filters( ',nt, srate,f1,f2,idb,ifiltyp, minphase,iii
      nfft = 0
c     find the next power of 2 larger than nt
c     find the power of 2 of nfft
      npower2 = 1
      nfft = 2
   10 CONTINUE
      IF( nfft .LT. nt ) THEN
          nfft = nfft + nfft
          npower2 = npower2 + 1
          GOTO 10
      ENDIF
      rnfft = REAL(nfft)
c              force a new filter if this filter length is different from the last
      IF( nfft .NE. nfftold ) firsttime = .TRUE.
      nfftold = nfft

c     force a new filter if the corners are different from the last
      IF( f1 .NE. f1old .OR. f2 .NE. f2old ) firsttime = .TRUE.
      f1old = f1
      f2old = f2
      IF( idb .NE. idbold) firsttime = .TRUE.
      idbold = idb

c      IF( iii .EQ. 1 ) firsttime = .TRUE.

      IF( firsttime ) THEN
          deltafreq = 0.
          tsec = nfft / srate
          nw = nfft / 2

          IF( nfft .GT. MAXLEN .OR. nt .GT. MAXLEN ) THEN
              PRINT *,' ***  ERROR  ***  Too much data for freq filt.'
              PRINT *,' Use fewer samples per trace or change filters.f'
              PRINT *,' nt = ',nt,' nw = ',nw
              STOP
          ENDIF

          DO 500 i = 1, nw+1
             filt(i)  = CMPLX(1.0, 0.0)
             filtl(i) = CMPLX(1.0, 0.0)
             filth(i) = CMPLX(1.0, 0.0)
  500     CONTINUE

          IF( minphase .EQ. 1 ) deltafreq = 2. * pi / tsec

          IF( ifiltyp .EQ. 0 ) THEN
              poles = FLOAT(idb) / 6. + 1.
              tr = 1. / ((f2-deltafreq) * tsec)

              DO 501 j = 1, nw + 1
  501            filtl(j) = filtl(j) / SQRT(1.+(REAL(j-1)*tr)**poles)

              tr = 1. / ((f1 + deltafreq) * tsec)

              DO 502 j = 1, nw+1
                 factor = (REAL(j-1) * tr) ** poles
                 filth(j) = filth(j) * SQRT(factor / (1. + factor))
  502         CONTINUE

              DO 503 j = 1, nw+1
  503            filt(j) = filtl(j) * filth(j)

          ELSEIF (ifiltyp .EQ. 1 ) THEN
              poles = FLOAT(idb) / 6. + 1.
              tr = 1. / ((f1-deltafreq) * tsec)
              DO 504 j = 1, nw + 1
  504            filt(j) = filt(j) / SQRT(1.+(REAL(j-1)*tr)**poles)

          ELSEIF (ifiltyp .EQ. 2 ) THEN
              poles = FLOAT(idb) / 6. + 1.
              tr = 1. / ((f1+deltafreq) * tsec)
              DO 505 j = 1, nw + 1
                 factor = (REAL(j-1) * tr) ** poles
  505         filt(j) = filt(j) * SQRT(factor / (1. + factor))

          ELSEIF (ifiltyp .EQ. 3 ) THEN
              index1 = IFIX((f1-deltafreq) * tsec) + 1
              index2 = IFIX((f2-deltafreq) * tsec) + 2
              IF( index2 - index1 .LT. 16 ) THEN
                  PRINT *, ' ***  ERROR  ***  Notch too narrow'
                  STOP
              ENDIF
              tr = 1. - 10. ** (-FLOAT(idb) / 20.)
              DO 506 j = index1, index2
  506            filt(j) = filt(j) *
     &       (1.+tr*(COS(2.*pi*REAL((j-index1)/(index2-index1)))-1.)/2.)
          ENDIF

          IF( minphase .EQ. 1 ) THEN
c   This is the "efficient" version that reduces the number
c of operations - I have checked it on a simple test case, and believe if it
c doesn't work then the original will not work. However if you want to play
c safe the only real change need is for the rnfft scaling
c  Alistair

              DO 507 i = 1, nw+1
                 IF( REAL(filt(i)) .EQ. 0. ) THEN
                     filt(i) = CMPLX(-30.0,0.0)
                 ELSE
                     filt(i) = CMPLX(ALOG(REAL(filt(i))),0.0)
                 ENDIF
  507         CONTINUE

              DO 508 i = nw+2, nw*2
  508            filt(i) = CONJG(filt(nw*2-i+2))

              CALL fftinv( filt, npower2 )

              DO 509 i = 2, nw+1
                 r = (1. + COS(pi * REAL(i-1) / nw)) / 2.
                 filt(i) = r * filt(i)
  509         continue
c  509            filt(nw*2+2-i) = r * filt(nw*2+2-i)

c              DO 510 i = 1, nw
c  510            filt1(i) = filt(i)

c              DO 511 i = nw+1, nw*2
c  511            filt1(i) = -CONJG(filt(i))
              DO 511 i = nw+1, nfft
                  filt(i) = cmplx(0., 0.)
  511         continue

              CALL fftfwd( filt, npower2 )
c              CALL fftfwd( filt1 , npower2 )

              maxabsval = 0.

c   straight implementation of the analytic Kramers-Kronig
c   relationship - ajh
              DO 512 i = 1, nw+1
c                 filt(i) = CEXP((filt(i) + filt1(i))/2./rnfft)
c                 filt(i) = CEXP(filt(i)/rnfft)
c..                                     Add factor of 2 here ajh.
                 filt(i) = CEXP(2.*filt(i)/rnfft)
                 maxabsval = AMAX1(CABS(filt(i)),maxabsval)
  512         CONTINUE

              IF( maxabsval .EQ. 0. ) THEN
                  PRINT *,' Filter is zero, data not filtered.'
                  RETURN
              ENDIF

              DO 513 i = 1, nw+1
  513            filt(i) = filt(i) / maxabsval
         ENDIF
         firsttime = .FALSE.
      ENDIF

c     the actual filtering follows
      DO 519 i = 1, nt
  519    refw(i) = CMPLX( rvector(i),0. )
c     zero fill the backend of the data!
      IF( nt+1 .LT. nfft ) THEN
          DO 520 i = nt+1, nfft
c  520    refw(i) = CMPLX( rvector(i),0. )
  520     refw(i) = CMPLX( 0.,0. )
      ENDIF
      CALL fftfwd( refw, npower2 )

      DO 521 i = 1, nw+1
c       if( filt(i) .ne. 0. ) print *,' i=',i,' filt=',filt(i)
  521    refw(i) = refw(i) * filt(i)
      DO 522 i = nw+2, nw*2
  522    refw(i) = CONJG(refw(nw*2-i+2))

      CALL fftinv( refw, npower2 )

      DO 523 i = 1, nt
  523    rvector(i) = REAL(refw(i)) / nfft

      RETURN
      END


program vloc_nonrel
use dftatom
implicit none

! For non-singular potential, we need to set Z=0:
integer, parameter :: Z = 0
! Mesh parameters:
real(dp), parameter :: r_min = 1e-7_dp, r_max = 50.0_dp, a = 2.7e6_dp
integer, parameter :: NN = 5000

real(dp), parameter :: c = 137.035999037_dp, eps = 1e-12_dp
integer :: n, l, relat, converged
real(dp) :: r(NN+1), u(size(r)), Ein, E, P(size(r)), Q(size(r))
real(dp) :: Rp(NN+1)
real(dp) :: Emin_init, Emax_init
real(dp) :: D(5)

R = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
D = [0.65435_dp, 2.45106_dp, -1.536643785333E-01_dp, 1.153664378533E+00_dp, &
    5.0000_dp]
u = -D(5)/R * (D(3)*erf(sqrt(D(1)) * R) + D(4)*erf(sqrt(D(2)) * R))

print *, "Local part of a pseudopotential for N (5 electrons)"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print "(A3, A3, A15)", "n", "l", "E"
print *
do n = 1, 7
    do l = 0, n-1
        relat = 0
        Ein = 10
        Emin_init = -100
        Emax_init = 100
        call solve_radial_eigenproblem(n, l, Ein, eps, 100, r, rp, u, &
            Z, c, relat, .false., Emin_init, Emax_init, converged, E, P, Q)
        if (converged /= 0) call stop_error("Not converged")
        print "(I3, I3, F15.6)", n, l, E
    end do
end do
end program


subroutine Heaviside(phi, result, eps_heaviside)
use parameters
use kind_parameters
implicit none

real(kind=dp), intent(in):: phi, eps_heaviside
real(kind=dp), intent(out):: result
!real(kind=dp), parameter:: pi = 3.1415926535897932384626433832795028841971693993751058209d0

if (phi .lt. -1.0d0*eps_heaviside) then

 result = 0.0d0

else if (phi .gt. eps_heaviside) then

 result = 1.0d0

else

 result = (phi + eps_heaviside)/(2.0d0*eps_heaviside) + (0.5d0/pi)*sin(pi*phi/eps_heaviside)

end if

end subroutine


c     # ---------------------------------------------------------------
      double precision function q0_physical(xp,yp,zp)
      implicit none

      double precision xp, yp, zp

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      integer initchoice
      common /initchoice_comm/ initchoice

      double precision alpha, beta
      common /torus_comm/ alpha, beta

      double precision init_radius
      common /initradius_comm/ init_radius

      double precision x0, y0, z0
      double precision q0, Hsmooth, r, r0, th
      integer k

c     # Sphere centered at (0.5,0.5,0) on swirl
      r0 = init_radius
      if (initchoice .eq. 1) then
          q0 = 1.d0
      elseif (initchoice .eq. 2) then
          x0 = 1
          y0 = 0
          z0 = alpha

          r = sqrt((xp - x0)**2 + (yp-y0)**2 + (zp-z0)**2)
          !!q0 = Hsmooth(r + r0) - Hsmooth(r - r0)
          q0 = 1 - Hsmooth(r - r0)
      endif
      q0_physical = q0

      end

c     # ---------------------------------------------------------------
      double precision function Hsmooth(r)
      implicit none

      double precision r

      Hsmooth = (tanh(r/0.02d0) + 1)/2.d0

      end

      double precision function q0_init(xc,yc)
      implicit none

      double precision xc,yc

      double precision alpha, beta
      common /torus_comm/ alpha, beta

      double precision xp, yp, zp
      double precision q0_physical

      call mapc2m_torus2(xc,yc,xp,yp,zp)
      q0_init = q0_physical(xp,yp,zp)

      end


      SUBROUTINE GFUNP(N,IDEG,PDG,QDG,X,
     $ XDGM1,XDG,PXDGM1,PXDG,G,DG)
C
C GFUNP  EVALUATES THE START EQUATION "G".
C
C ON INPUT:
C
C N  IS THE NUMBER OF VARIABLES.
C
C IDEG(J)  IS THE DEGREE OF THE J-TH EQUATION.
C
C PDG(1,J), PDG(2,J)  ARE THE REAL AND IMAGINARY PARTS
C   OF THE POWERS OF P USED TO DEFINE G.
C
C QDG(1,J), QDG(2,J)  ARE THE REAL AND IMAGINARY PARTS
C   OF THE POWERS OF Q USED TO DEFINE G.
C
C X(1,J), X(2,J)  ARE THE REAL AND IMAGINARY PARTS OF THE
C   J-TH INDEPENDENT VARIABLE.
C
C XDGM1,XDG,PXDGM1,PXDG ARE WORKSPACE ARRAYS.
C
C ON OUTPUT:
C
C N,IDEG,PDG,QDG, AND X  ARE UNCHANGED.
C
C G(1,J),G(2,J)  ARE THE REAL AND IMAGINARY PARTS OF THE
C   J-TH START EQUATION.
C
C DG(1,J),DG(2,J)  ARE THE REAL AND IMAGINARY PARTS OF THE
C   PARTIAL DERIVATIVES OF THE J-TH START EQUATION WITH RESPECT TO THE
C   J-TH INDEPENDENT VARIABLE.
C
C SUBROUTINE:  MULP.
C
C DECLARATION OF INPUT AND OUTPUT:
      INTEGER N,IDEG
      DOUBLE PRECISION PDG,QDG,X,XDGM1,XDG,PXDGM1,PXDG,G,DG
      DIMENSION IDEG(N),PDG(2,N),QDG(2,N),X(2,N),
     $  XDGM1(2,N),XDG(2,N),PXDGM1(2,N),PXDG(2,N),
     $  G(2,N),DG(2,N)
C
C DECLARATION OF VARIABLES
      INTEGER I,J
C
C COMPUTE THE (IDEG-1)-TH AND IDEG-TH POWER OF X
      DO 5 J=1,N
        CALL POWP(IDEG(J)-1,X(1,J), XDGM1(1,J))
        CALL MULP(X(1,J),XDGM1(1,J), XDG(1,J))
  5   CONTINUE
C
C COMPUTE THE PRODUCT OF PDG AND XDGM1
      DO 10 J=1,N
          CALL MULP( PDG(1,J), XDGM1(1,J), PXDGM1(1,J) )
  10  CONTINUE
C
C COMPUTE THE PRODUCT OF PDG AND XDG
      DO 20 J=1,N
          CALL MULP( PDG(1,J), XDG(1,J), PXDG(1,J) )
  20  CONTINUE
      DO 30 J=1,N
      DO 30 I=1,2
          G(I,J)=PXDG(I,J) - QDG(I,J)
          DG(I,J)= IDEG(J)*PXDGM1(I,J)
  30  CONTINUE
      RETURN
      END


!  Routines for rk, fk, and gk
!======================================================================
      REAL(8) FUNCTION rk(i1, j1, i2, j2, k)
!======================================================================
!               k
!     Returns  R (i1, j1; i2, j2) base on the assembling the B-spline
!     integrals, which are supposed to be placed in the module
!     spline-integrals. If not, they are calculated by programs
!     mrk_diff or mrk_cell, depending of the parameter 'meth':
!     meth = 'd' - differential equation method
!          = 'c' - cell integration method
!----------------------------------------------------------------------

         USE spline_param
         USE hf_orbitals
         USE spline_integrals

         IMPLICIT NONE
         INTEGER(4), INTENT(in) :: i1, j1, i2, j2, k

         ! .. local variables

         INTEGER(4) :: i, ip, j, jp, msi, msj
         REAL(8), DIMENSION(ns, ks) :: a, b
         REAL(8) :: rkj

         ! .. check the B-spline integrals in module spline-integrals

         if (k .ne. krk .or. itype .ne. 'rk ') then
            Call MRK_cell(k)
         end if

         ! .. form cross-products

         Call density(ns, ks, a, p(1, i1), p(1, i2), 's', msi)
         Call density(ns, ks, b, p(1, j1), p(1, j2), 's', msj)

         ! .. assembling the B-spline integrals

         rk = 0.d0
         do ip = 1, ks
            do i = 1, msi - ip + 1
               rkj = 0.d0
               do jp = 1, ks
                  do j = 1, msj - jp + 1
                     rkj = rkj + b(j, jp)*rkb(j, i, jp, ip)
                  end do
               end do
               rk = rk + a(i, ip)*rkj
            end do
         end do

      END FUNCTION rk

!======================================================================
      REAL(KIND=8) FUNCTION fk(i, j, k)
!======================================================================
!                            k
!      Returns the value of F (i,j) based on the assembly of B-spline
!     integrals, which are supposed to be placed in the module
!     spline-integrals.
!---------------------------------------------------------------------
!

         IMPLICIT NONE
         INTEGER, INTENT(IN) :: i, j, k
         REAL(KIND=8), EXTERNAL :: rk

         fk = rk(i, j, i, j, k)

      END FUNCTION fk
!======================================================================
      REAL(KIND=8) FUNCTION gk(i, j, k)
!======================================================================
!                            k
!      Returns the value of F (i,j) based on the assembly of B-spline
!     integrals, which are supposed to be placed in the module
!     spline-integrals.
!---------------------------------------------------------------------
!

         IMPLICIT NONE
         INTEGER, INTENT(IN) :: i, j, k
         REAL(KIND=8), EXTERNAL :: rk

         gk = rk(i, j, j, i, k)

      END FUNCTION gk


      FUNCTION rd(x,y,z)
      REAL rd,x,y,z,ERRTOL,TINY,BIG,C1,C2,C3,C4,C5,C6
      PARAMETER (ERRTOL=.05,TINY=1.e-25,BIG=4.5E21,C1=3./14.,C2=1./6.,
     *C3=9./22.,C4=3./26.,C5=.25*C3,C6=1.5*C4)
      REAL alamb,ave,delx,dely,delz,ea,eb,ec,ed,ee,fac,sqrtx,sqrty,
     *sqrtz,sum,xt,yt,zt
      if(min(x,y).lt.0..or.min(x+y,z).lt.TINY.or.max(x,y,
     *z).gt.BIG)pause 'invalid arguments in rd'
      xt=x
      yt=y
      zt=z
      sum=0.
      fac=1.
1     continue
        sqrtx=sqrt(xt)
        sqrty=sqrt(yt)
        sqrtz=sqrt(zt)
        alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
        sum=sum+fac/(sqrtz*(zt+alamb))
        fac=.25*fac
        xt=.25*(xt+alamb)
        yt=.25*(yt+alamb)
        zt=.25*(zt+alamb)
        ave=.2*(xt+yt+3.*zt)
        delx=(ave-xt)/ave
        dely=(ave-yt)/ave
        delz=(ave-zt)/ave
      if(max(abs(delx),abs(dely),abs(delz)).gt.ERRTOL)goto 1
      ea=delx*dely
      eb=delz*delz
      ec=ea-eb
      ed=ea-6.*eb
      ee=ed+ec+ec
      rd=3.*sum+fac*(1.+ed*(-C1+C5*ed-C6*delz*ee)+delz*(C2*ee+delz*(-C3*
     *ec+delz*C4*ea)))/(ave*sqrt(ave))
      return
      END

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


      subroutine runCY_0000i(k,l,i1,Xtwiddle,Gtwiddle,Shat5zz,N0)
      implicit none
C---  Expression for C0000i obtained from 5.50, following the comment after
C     5.50 on how to add adcing adcitional "00" pairs
C---  (similar to Eq. 5.56b but with "00" added)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,i1,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat5zz(np,z2max,-2:0)

      if ((i1 .eq. l) .or. (i1 .eq. 0)) then
      return
      endif

      do ep=-2,0

      Cv(czzzzi(i1)+N0,ep)=
     . (-2*Gtwiddle(k,i1)*Cv(czzzzi(l)+N0,ep)
     . +Gtwiddle(k,1)*Shat5zz(1,z2(l,i1),ep)
     . +Gtwiddle(k,2)*Shat5zz(2,z2(l,i1),ep)
     . +Xtwiddle(0,k)*Cv(czzii(z2(l,i1))+N0,ep)
     . -Xtwiddle(0,0)*Cv(czziii(z3(k,l,i1))+N0,ep))/(2*Gtwiddle(k,l))

      enddo

      return
      end