!*****************************************************************************************
!>
!  Just an example using the lambert module.

    program lambert_test_1

    use fortran_astrodynamics_toolkit

    implicit none

    real(wp),dimension(3)               :: r1         !! first cartesian position [km]
    real(wp),dimension(3)               :: r2         !! second cartesian position [km]
    real(wp)                            :: tof        !! time of flight [sec]
    real(wp)                            :: mu         !! gravity parameter [km^3/s^2]
    logical                             :: long_way   !! when true, do "long way" (>pi) transfers
    integer                             :: multi_revs !! maximum number of multi-rev solutions to compute
    real(wp),dimension(:,:),allocatable :: v1         !! vector containing 3d arrays with the cartesian components of the velocities at r1
    real(wp),dimension(:,:),allocatable :: v2         !! vector containing 3d arrays with the cartesian components of the velocities at r2
    logical                             :: status_ok  !! true if everything is OK
    integer                             :: i          !! counter
    integer                             :: icase      !! different methods to run
    character(len=:),allocatable        :: prefix     !! file prefix for the different methods

    logical :: shortperiod
    real(wp),dimension(3) :: v1_vec
    real(wp),dimension(3) :: v2_vec
    real(wp),parameter :: tolerance = 1.0e-9_wp
    integer,parameter :: max_iterations = 1000

    r1 = [20.0d3, 20.0d3, zero]
    r2 = [-20.0d3, 10.0d3, zero]
    tof = 1.0d0 * day2sec
    mu = 398600.0_wp

    do icase = 1, 2 ! Gooding, Izzo

        long_way=.true.
        multi_revs = 1
        if (icase==1) then
            prefix = ''
            call solve_lambert_gooding(r1,r2,tof,mu,long_way,multi_revs,v1,v2,status_ok)
        else
            prefix = 'izzo_'
            call solve_lambert_izzo(r1,r2,tof,mu,long_way,multi_revs,v1,v2,status_ok)
        end if
        if (.not. status_ok) write(*,*) 'error'
        write(*,*) size(v1,2), 'long way solutions'
        call propagate_trajectory(prefix//'longway_n=0_s=1.txt',     [r1,v1(:,1)])
        call propagate_trajectory(prefix//'longway_n=1_s=1.txt',     [r1,v1(:,2)])
        call propagate_trajectory(prefix//'longway_n=1_s=2.txt',     [r1,v1(:,3)])

        long_way=.false.
        multi_revs = 1
        if (icase==1) then
            call solve_lambert_gooding(r1,r2,tof,mu,long_way,multi_revs,v1,v2,status_ok)
        else
            call solve_lambert_izzo(r1,r2,tof,mu,long_way,multi_revs,v1,v2,status_ok)
        end if
        if (.not. status_ok) write(*,*) 'error'
        write(*,*) size(v1,2), 'short way solutions'
        call propagate_trajectory(prefix//'shortway_n=0_s=1.txt',     [r1,v1(:,1)])
        call propagate_trajectory(prefix//'shortway_n=1_s=1.txt',     [r1,v1(:,2)])
        call propagate_trajectory(prefix//'shortway_n=1_s=2.txt',     [r1,v1(:,3)])

    end do

    ! Arora - solve for each one at a time:
    prefix = 'arora'

    long_way=.true.
    multi_revs = 0
    shortperiod = .true.
    call solve_lambert_arorarussell(r1,r2,tof,mu,one,multi_revs,long_way,&
                                            shortperiod,tolerance,&
                                            max_iterations,v1_vec,v2_vec)
    call propagate_trajectory(prefix//'longway_n=0_s=1.txt', [r1,v1_vec])

    long_way=.false.
    multi_revs = 0
    shortperiod = .true.
    call solve_lambert_arorarussell(r1,r2,tof,mu,one,multi_revs,long_way,&
                                            shortperiod,tolerance,&
                                            max_iterations,v1_vec,v2_vec)
    call propagate_trajectory(prefix//'shortway_n=0_s=1.txt', [r1,v1_vec])

    long_way=.true.
    multi_revs = 1
    shortperiod = .true.
    call solve_lambert_arorarussell(r1,r2,tof,mu,one,multi_revs,long_way,&
                                            shortperiod,tolerance,&
                                            max_iterations,v1_vec,v2_vec)
    call propagate_trajectory(prefix//'longway_n=1_s=1.txt', [r1,v1_vec])

    long_way=.false.
    multi_revs = 1
    shortperiod = .true.
    call solve_lambert_arorarussell(r1,r2,tof,mu,one,multi_revs,long_way,&
                                            shortperiod,tolerance,&
                                            max_iterations,v1_vec,v2_vec)
    call propagate_trajectory(prefix//'shortway_n=1_s=1.txt', [r1,v1_vec])

    long_way=.true.
    multi_revs = 1
    shortperiod = .false.
    call solve_lambert_arorarussell(r1,r2,tof,mu,one,multi_revs,long_way,&
                                            shortperiod,tolerance,&
                                            max_iterations,v1_vec,v2_vec)
    call propagate_trajectory(prefix//'longway_n=1_s=2.txt', [r1,v1_vec])

    long_way=.false.
    multi_revs = 1
    shortperiod = .false.
    call solve_lambert_arorarussell(r1,r2,tof,mu,one,multi_revs,long_way,&
                                            shortperiod,tolerance,&
                                            max_iterations,v1_vec,v2_vec)
    call propagate_trajectory(prefix//'shortway_n=1_s=2.txt', [r1,v1_vec])

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

        subroutine propagate_trajectory(name,rv0)

        implicit none

        character(len=*),intent(in) :: name

        real(wp),dimension(6),intent(in) :: rv0
        real(wp),dimension(6) :: rv,rvf
        integer :: iunit

        open(newunit=iunit,file=trim(name),status='REPLACE')

        !propagate it:
        rv = rv0
        write(iunit,'(*(E30.16,1X,A))') rv(1),',',rv(2),',',rv(3)
        do i=1,int(day2sec)
            call propagate(mu, rv, one, rvf)
            rv = rvf
            write(iunit,'(*(E30.16,1X,A))') rv(1),',',rv(2),',',rv(3)
        end do

        close(iunit)

        end subroutine propagate_trajectory

    end program lambert_test_1
!*****************************************************************************************


subroutine reduce_to_tridiagonal(A)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!********************************************************************
! SUBROUTINE reduce_to_tridiagonal                                  *
!                                                                   *
! Accepts a 3x3 matrix A and uses a single Householder matrix to    *
! reduce A to tridiagonal form. The matrix A is expected to be a    *
! real matrix with symmetric components.                            *
!                                                                   *
! Author : Sai Rapaka                                               *
!                                                                   *
!********************************************************************

implicit none
double precision, dimension(3,3) :: A, P, B
double precision, dimension(2)   :: x
double precision                 :: norm_x, H
double precision, parameter      :: tol = 1.0d-12
integer i,j

x(1) = A(2,1)
x(2) = A(3,1)

norm_x = sqrt(x(1)*x(1) + x(2)*x(2))
x(1) = x(1) - norm_x

H = 0.5d0*(x(1)*x(1) + x(2)*x(2))

if(H.gt.tol) then
  P = 0.0d0
  P(1,1) = 1.0d0
  do i=2,3
    do j=2,3
      if(i.eq.j) then
        P(i,j) = 1.0d0
      endif
      P(i,j) = P(i,j) - x(i-1)*x(j-1)/H
    enddo
  enddo

  B = MATMUL(P,A)
  A = MATMUL(B,P)

endif

end subroutine reduce_to_tridiagonal


      SUBROUTINE CROTG(CA,CB,C,S)
*     .. Scalar Arguments ..
      COMPLEX CA,CB,S
      REAL C
*     ..
*
*  Purpose
*  =======
*
*  CROTG determines a complex Givens rotation.
*
*  =====================================================================
*
*     .. Local Scalars ..
      COMPLEX ALPHA
      REAL NORM,SCALE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC CABS,CONJG,SQRT
*     ..
      IF (CABS(CA).EQ.0.) THEN
         C = 0.
         S = (1.,0.)
         CA = CB
      ELSE
         SCALE = CABS(CA) + CABS(CB)
         NORM = SCALE*SQRT((CABS(CA/SCALE))**2+ (CABS(CB/SCALE))**2)
         ALPHA = CA/CABS(CA)
         C = CABS(CA)/NORM
         S = ALPHA*CONJG(CB)/NORM
         CA = ALPHA*NORM
      END IF
      RETURN
      END


 FUNCTION GASDEV(IDUM)
   implicit none
   INTEGER IDUM
   REAL gasdev
! Uses ran1, returns a normally distributed deviate with zero mean and
! unit variance.
   Integer iset
   REAL :: fac,gset,rsq,v1,v2,ran1,zero=0.,one=1.,two=2.
   SAVE iset, gset
   DATA iset/0/
   IF (ISET.EQ.0) THEN
1     V1=two*RAN1(IDUM)-one
      V2=two*RAN1(IDUM)-one
      rsq=V1**2+V2**2
      IF(rsq >= one .or. rsq == zero)GO TO 1
      FAC=SQRT(-two*LOG(Rsq)/Rsq)
      GSET=V1*FAC
      GASDEV=V2*FAC
      ISET=1
   ELSE
      GASDEV=GSET
      ISET=0
   ENDIF
   RETURN
 END FUNCTION GASDEV


      FUNCTION arcdis (long1, lat1, long2, lat2)
!     Function to compute the distance between two latitude, longitude
!       points in nautical miles.
!     Algorithm from Doug MacAyeal, The University of Chicago, 1985.
!     Bullet-proofing added by Robert Grumbine 6 April 1994.
!     Returns -1 in event of errors.  Diagnostic printout eliminated.
!       Robert Grumbine 15 September 2005

      IMPLICIT none

      DOUBLE PRECISION ab, ac, bc, arg
      REAL arcdis, lat1, long1, lat2, long2

      DOUBLE PRECISION pi, rdpdg, kmtonm, rearth
      PARAMETER (pi = 3.141592654)
      PARAMETER (rdpdg = pi / 180.)
      PARAMETER (kmtonm = 1.852)
!ERROR found 13 September 1995      PARAMETER (rearth = 6730.949)
      PARAMETER (rearth = 6370.949)

!     Bullet-proofing: Check that lats are within +- 90, longs
!       longs are within +- 360.
      IF (ABS(lat1) .GT. 90. .OR. ABS(lat2) .GT. 90.) THEN
!D        PRINT *,'Latitudes are off the planet.'
!D        PRINT *,'No fix within arcdis.'
!D        PRINT *,'WARNING error.'
          arcdis = -1.
          RETURN
      ENDIF
      IF (ABS(long1) .GT. 360. .OR. ABS(long2) .GT. 360.) THEN
!D        PRINT *,'Longitudes are outside range.'
!D        PRINT *,'No fix within arcdis.'
!D        PRINT *,'WARNING long1, long2 = ',long1, long2
          arcdis = -1.
          RETURN
      ENDIF

!     Operational Code
!     Special case included because trig round off can give identical
!      points a nonzero separating distance. BG 6/3/93.
      IF (long1 .EQ. long2 .AND. lat1 .EQ. lat2) THEN
        arcdis = 0.0
        RETURN
      ENDIF

      ab = (90.-lat1)*rdpdg
      ac = (90.-lat2)*rdpdg
      bc = ABS((long1-long2)*rdpdg)
!     arg introduced 6/3/93 to proof against the special case that
!       round-off errors in trig produce a value for the argument
!       which is out of bounds for the arc-cosine function.  This
!       should be rare though not totally impossible.
      arg = COS(ab)*COS(ac)+SIN(ab)*SIN(ac)*COS(bc)
      IF (arg .GT.  1.0) THEN
!D        PRINT *,'Out of bounds arcdis ',lat1, long1, lat2, long2
        arg =  1.0
      ENDIF
      IF (arg .LT. -1.0) THEN
!D        PRINT *,'Out of bounds arcdis ',lat1, long1, lat2, long2
        arg = -1.0
      ENDIF
      arcdis = ACOS(arg)*rearth

!     Bullet-proofing: Verify that distance is less than circumference
!       of the earth.
      IF (arcdis .GT. 2.*pi*rearth) THEN
!D        PRINT *,'Failure in computation of distance on earth.'
!D        PRINT *,'Derived distance = ',arcdis,' nautical miles.'
!D        PRINT *,'FATAL error'
        arcdis = -1
        RETURN
      ENDIF

!D      arcdis = arcdis/kmtonm

      RETURN
      END


!
! dense kron matrix module
!

module kron
  implicit none

contains
  !
  ! Description:
  !   This routine computes the following kronecker product:
  !
  !     y = alpha (I_{n1} * trans(A) * I_{n2}) x + beta y
  !
  !   where A is an m-by-n square matrix,
  !         I_{n} is an n-by-n identity matrix, and;
  !         * is kronecker product.
  !
  ! Parameters:
  !   m, n: rows and columns of matrix A
  !   n1: size of identity matrix located on left
  !   n2: size of identity matrix located on right
  !

  subroutine dkronmv(trans, m, n, n1, n2, alpha, &
    A, lda, x, beta, y)

    character, intent(in) :: trans
    integer, intent(in) :: m, n, n1, n2, lda
    double precision, intent(in) :: alpha, beta, A(1:lda,1:n), x(1:*)
    double precision, intent(out) :: y(1:*)
    integer :: i, j, k

    select case (trans)
      case ('N', 'n')
        call dscal(m*n1*n2, beta, y, 1)
        i = 1
        j = 1
        do k = 1, n1
          call dgemm('N', 'T', n2, m, n, alpha, x(i), n2, A, lda, 1.0d0, y(j), n2)
          i = i + n*n2
          j = j + m*n2
        end do
      case ('T', 't')
        call dscal(n*n1*n2, beta, y, 1)
        i = 1
        j = 1
        do k = 1, n1
          call dgemm('N', 'N', n2, n, m, alpha, x(i), n2, A, lda, 1.0d0, y(j), n2)
          i = i + m*n2
          j = j + n*n2
        end do
      case default
        write (0,*), 'Unknown character for trans.'
    end select
  end subroutine dkronmv

  !
  ! Description:
  !   This routine computes the following aggregation on kronecker product:
  !
  !     B = B + alpha x^T y
  !       and element-wise aggregation of the m-by-n matrix A; I_{n1} * A * I_{n2}
  !
  !   where A is m-by-n matrix
  !         I_{n} is an n-by-n identity matrix, and;
  !         * is kronecker product.
  !
  ! Parameters:
  !   m, n: row and column sizes of square matrix A
  !   n1: size of identity matrix located on left
  !   n2: size of identity matrix located on right
  !

  subroutine dkronr(m, n, n1, n2, alpha, x, y, A, lda)
    integer, intent(in) :: m, n, n1, n2, lda
    double precision, intent(in) :: alpha, x(1:*), y(1:*)
    double precision, intent(out) :: A(1:lda,1:n)
    integer :: i, j, k

    i = 1
    j = 1
    do k = 1, n1
      call dgemm('T', 'N', m, n, n2, alpha, x(i), n2, y(j), n2, 1.0, A, lda)
      i = i + m*n2
      j = j + n*n2
    end do
  end subroutine dkronr

end module kron


!===============================================================================
program Cij2cijkl_prog
!===============================================================================
!  Convert from 6x6 to 3x3x3x3 elasticity tensor using Voigt contraction

use anisotropy_ajn

implicit none

real(kind=8) :: Cij(6,6),cijkl(3,3,3,3),rho
integer :: iostatus,i,j,k,l
character(len=250) :: fname

if (command_argument_count() > 1) then
   write(0,'(a)') 'Usage:  Cij2cijkl [.ecs file] > [outfile]',&
                  '   or:  Cij2cijkl < [list of 36-column ecs]'
   stop
endif

! If argument supplied, read .ecs file
if (command_argument_count() == 1) then
   call get_command_argument(1,fname)
   call CIJ_load(fname,Cij,rho)
   cijkl = Cij2cijkl(Cij)
   write(*,'(6e10.1)') Cij
!  Otherwuse, we're taking lists of constants from stdin.
else
   iostatus = 0
   do while (iostatus == 0)
      read(*,*,iostat=iostatus) ((Cij(i,j),j=1,6),i=1,6)
      if (iostatus < 0) exit
      if (iostatus > 0) then
         write(0,'(a)') 'Cij2cijkl: problem reading 6x6 matrix from stdin.'
         stop
      endif
      cijkl = Cij2cijkl(Cij)
      write(*,*) ((((cijkl(i,j,k,l),l=1,3),k=1,3),j=1,3),i=1,3)
   enddo
endif

end program Cij2cijkl_prog


module fv3geom_constants_mod

use, intrinsic :: iso_c_binding

implicit none

integer,              public, parameter :: kind_real = c_double
real(kind=kind_real), public, parameter :: pi = 3.1415926535897931_kind_real
real(kind=kind_real), public, parameter :: torad = pi/180.0_kind_real
real(kind=kind_real), public, parameter :: todeg = 180.0_kind_real/pi
real(kind=kind_real), public, parameter :: radius = 6.3712e+6_kind_real

end module fv3geom_constants_mod


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ellu_chol2eig( n, g, u, lam )

!  g contains the lower Cholesky factor G of the
!  n x n PSD matrix A = G * G^T.  The eigen-decomposition of A is:
!  A = u * lam^2 * u^T.  This routine returns u and lam (which are U
!  and S in the SVD of G = U S V^T).

implicit none
integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: g(n,n)
real(k_dp), intent(out) :: u(n,n), lam(n)

real(k_dp) :: vt(n,n), work(10*n*n+20*n)
integer    :: lwork, info

lwork = 10*n*n+20*n

! copy g into vt

vt = g

call dgesvd( 'A', 'N', n, n, vt, n, lam, u, n, vt, n, work, lwork, info)

if( info /= 0 ) then
   write(0,*)'ellu_chol2eig: info, lwork, work(1) = ', info, lwork, work(1)
   stop
endif

return
end subroutine ellu_chol2eig


program Bias_Unbias
  implicit none

  integer, parameter :: samples = 1000000
  integer :: i, j
  integer :: c1, c2, rand

  do i = 3, 6
    c1 = 0
    c2 = 0
    do j = 1, samples
      rand = bias(i)
      if (rand == 1) c1 = c1 + 1
      rand = unbias(i)
      if (rand == 1) c2 = c2 + 1
    end do
    write(*, "(i2,a,f8.3,a,f8.3,a)") i, ":", real(c1) * 100.0 / real(samples), &
                                     "%", real(c2) * 100.0 / real(samples), "%"
  end do

contains

function bias(n)
  integer :: bias
  integer, intent(in) :: n
  real :: r

  call random_number(r)
  if (r > 1 / real(n)) then
    bias = 0
  else
    bias = 1
  end if
end function

function unbias(n)
  integer :: unbias
  integer, intent(in) :: n
  integer :: a, b

  do
    a = bias(n)
    b = bias(n)
    if (a /= b) exit
  end do
  unbias = a
end function

end program


module ode1d

! General utilities for solving 1D ODEs. the Adams and rk4 subroutines
! are used by Schroedinger, Dirac and Poisson solvers. The integrate
! function is used at other places in dftatom to calculate integrals of the
! radial density/orbitals.

use types, only: dp
use utils, only: stop_error

implicit none
private
public integrate, normalize, parsefunction, get_n_nodes, get_min_idx, &
        adams_interp_outward, adams_extrapolation_outward, &
        adams_interp_outward_implicit, &
        adams_interp_inward_implicit, &
        get_midpoints, rk4_integrate3, rk4_integrate4, rk4_integrate, &
        integrate_trapz_1, integrate_trapz_3, integrate_trapz_5, &
        integrate_trapz_7, integrate_simpson, integrate_adams

contains

real(dp) function integrate(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)

! Choose one from the integration rules below:
!s = integrate_trapz_1(Rp, f)
!s = integrate_trapz_3(Rp, f)
!s = integrate_trapz_5(Rp, f)
s = integrate_trapz_7(Rp, f)
!s = integrate_simpson(Rp, f)
!s = integrate_adams(Rp, f)
end function

real(dp) function integrate_trapz_1(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)

real(dp) :: g(size(Rp))
integer :: N
N = size(Rp)
g = f * Rp
s = (g(1) + g(N)) / 2
s = s + sum(g(2:N-1))
end function

real(dp) function integrate_trapz_3(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)

real(dp) :: g(size(Rp))
integer :: N
N = size(Rp)
g = f * Rp
s = (9 * (g(1) + g(N)) + 28 * (g(2) + g(N-1)) + 23 * (g(3) + g(N-2))) / 24
s = s + sum(g(4:N-3))
end function

real(dp) function integrate_trapz_5(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)

real(dp) :: g(size(Rp))
integer :: N
N = size(Rp)
g = f * Rp
s = (  475 * (g(1) + g(N  )) &
    + 1902 * (g(2) + g(N-1)) &
    + 1104 * (g(3) + g(N-2)) &
    + 1586 * (g(4) + g(N-3)) &
    + 1413 * (g(5) + g(N-4)) &
    ) / 1440
s = s + sum(g(6:N-5))
end function

real(dp) function integrate_trapz_7(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)

real(dp) :: g(size(Rp))
integer :: N
N = size(Rp)
g = f * Rp
s = (  36799 * (g(1) + g(N  )) &
    + 176648 * (g(2) + g(N-1)) &
    +  54851 * (g(3) + g(N-2)) &
    + 177984 * (g(4) + g(N-3)) &
    +  89437 * (g(5) + g(N-4)) &
    + 130936 * (g(6) + g(N-5)) &
    + 119585 * (g(7) + g(N-6)) &
    ) / 120960
s = s + sum(g(8:N-7))
end function

real(dp) function integrate_simpson(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)

real(dp) :: g(size(Rp))
integer :: i, N
N = size(Rp)
g = f * Rp
s = 0
do i = 2, N-1, 2
    s = s + g(i-1) + 4*g(i) + g(i+1)
end do
s = s / 3
if (modulo(N, 2) == 0) then
    ! If N is even, add the last slice separately
    s = s + (5*g(N) + 8*g(N-1) - g(N-2)) / 12
end if
end function

real(dp) function integrate_adams(Rp, f) result(s)
real(dp), intent(in) :: Rp(:), f(:)

real(dp) :: g(size(Rp))
integer :: i
s = integrate_trapz_1(Rp(:4), f(:4))
g = f * Rp
do i = 4, size(Rp)-1
    s = s + adams_interp_outward(g, i)
end do
end function

subroutine normalize(Rp, Y)
!     normalizes Y inplace on the grid R
!     I.e. int |Y|^2 dr = 1
!     input parameters:
!     Y (array, in, out) .... the unnormalized wavefunction
!     R (array, in) .... the radial grid
!     output parameters:
!     Y is normalized inplace
real(dp), intent(in) :: Rp(:)
real(dp), intent(inout) :: Y(size(Rp))

real(dp) :: S
S = integrate(Rp, Y**2)
S = sqrt(abs(S))
if (S > 0) then
    Y = Y / S
else
    call stop_error("normalize: zero function")
end if
end subroutine

subroutine parsefunction(y, nodes, minidx, positive)
! parses the function y, returns:
! nodes: the number of intersection with the x-axis, not counting
!   the beginning and infinity
! minidx: the index of the last minimum, i.e. the place, where the
!   function was last closest to the x-axis (in absolute value), so for
!   indexes > minidx, the function goes to +- infinity, or possibly to
!   zero in infinity
! positive: true or false, depending if the y is approaching the x-axis
!   in the infinity from above (positive) or below (negative).
! This information is is used in the routine checke to determine, if the
! function lies below or above a certain energy.
real(dp), intent(in) :: y(:)
integer, intent(out) :: nodes, minidx
logical, intent(out) :: positive

nodes = get_n_nodes(y)
minidx = get_min_idx(y)
positive = y(size(y)) > 0
end subroutine

integer function get_n_nodes(y) result(nodes)
! Returns the number of nodes of the function 'y'
real(dp), intent(in) :: y(:)

integer :: last_sign, last_i, i, isy
nodes = 0
last_sign = int(sign(1.0_dp, y(1)))
last_i = -1

do i = 2, size(y)
  isy = int(sign(1.0_dp, y(i)))
  if (isy == -last_sign) then
      last_sign = isy
      last_i = i - 1
      nodes = nodes + 1
  end if
end do
end function

integer function get_min_idx(y) result(k)
! Returns the index of the last minimum of the function 'y'
real(dp), intent(in) :: y(:)
k = size(y)
do while (abs(y(k-1)) < abs(y(k)))
  k = k-1
  if (k == 1) exit
end do
k = k - 1
end function

real(dp) function adams_extrapolation_outward(y, i) result(r)
! Adams extrapolation formula
real(dp), intent(in) :: y(:)
integer, intent(in) :: i
r = +(55*y(i) - 59*y(i-1) + 37*y(i-2) - 9*y(i-3)) / 24
end function

real(dp) function adams_interp_outward(y, i) result(r)
! Adams interpolation formula
real(dp), intent(in) :: y(:)
integer, intent(in) :: i
r = +(9*y(i+1) + 19*y(i) - 5*y(i-1) + y(i-2)) / 24
end function

real(dp) function adams_interp_outward_implicit(y, i) result(r)
! Adams interpolation formula for implicit method
real(dp), intent(in) :: y(:)
integer, intent(in) :: i
r = +(19*y(i) - 5*y(i-1) + y(i-2)) / 24
end function

real(dp) function adams_interp_inward_implicit(y, i) result(r)
! Adams interpolation formula for implicit method
real(dp), intent(in) :: y(:)
integer, intent(in) :: i
r = -(19*y(i) - 5*y(i+1) + y(i+2)) / 24
end function

subroutine interp(t, X, n, Y, val)
!     Interpolates the x, y points to estimate the value at the point "t".
!     val (out) ...... the estimated function value at the point "t".
!     t (in).......... the "x" value at which to estimate the value
!     X (array, in) .. the x-values of the points
!     Y (array, in) .. the y-values of the points
!     n (in) ......... the length of the arrays X and Y
real(dp), intent(in) :: t
integer, intent(in) :: n
real(dp), intent(in) :: X(n), Y(n)
real(dp), intent(out) :: val
real(dp) :: f, denum
integer :: i, j
val = 0
do j = 1, n
    f = 1
    denum = 1
    do i=1, n
        if (i == j) cycle
        f = f * (t-X(i))
        denum = denum * (X(j)-X(i))
    end do
    val = val + Y(j) * f / denum
end do
end subroutine

subroutine get_val(f, x, R, n, V, i)
! returns the interpolated value of f(x), where f is defined on the
! grid R
! input parameters
! R ... grid
! n ... length of the grid
! f ... function defined on the grid R
! x ... point at which to interpolate
! i ... the integer number of the radial point at which "x" lies
! output parameters
! V ... the interpolated function value
integer, intent(in) :: n
real(dp), intent(in) :: f(n), x, R(n)
real(dp), intent(out) :: V
integer, intent(in) :: i

integer :: j1, j2, n1, n2
if (n < 4) call stop_error("get_val: n >= 4 required")
j1 = i-1
j2 = j1+1

n1 = j1-1
n2 = j2+1
if (n1 < 1) then
    n2 = n2-n1+1
    n1 = 1
end if
if (n2 > n) then
    n1 = n1-(n2-n)
    n2 = n
end if
call interp(x, r(n1:n2), n2-n1+1, f(n1:n2), V)
end subroutine

function get_midpoints(R, V) result(Vmid)
real(dp), intent(in) :: R(:), V(:)
real(dp) :: Vmid(size(R)-1)
integer :: i
if (.not.(size(R) == size(V))) then
    call stop_error("get_midpoints: incorrect array sizes")
end if
do i = 1, size(R) - 1
    call get_val(V, (R(i) + R(i+1))/2, R, size(R), Vmid(i), i+1)
end do
end function

subroutine rk4_integrate3(R, y0, C1, C2, C1mid, C2mid, max_val, y1, y2, imax)
! Integrates the following set of equations outwards:
! dy1/dx =           y2
! dy2/dx = C1 + C2 * y2
! The above system can be equivalently written as a second order ODE:
! y1'' - C2 * y1' = C1
! The coefficients C1 and C2 are passed in as arrays, so they can have any
! dependence on R. For example for a Poisson equation of the form:
! V'' + 2 * V' / R = -4*pi*n
! we would get C1 = -4*pi*n, C2 = -2/R
real(dp), intent(in) :: R(:) ! Grid
real(dp), intent(in) :: y0(:) ! Initial condition
! Coefficients C1 and C2 at grid points and midpoints:
real(dp), intent(in) :: C1(:), C2(:), C1mid(:), C2mid(:)
! Maximum value (if y1 > max_val, the integration stops)
real(dp), intent(in) :: max_val
! Solution y1 and y2
real(dp), intent(out) :: y1(:), y2(:)
! The integration stops at R(imax)
integer, intent(out) :: imax

integer :: i
integer :: n
real(dp), dimension(size(y0)) :: dym, dyt, yt, dydx, y
real(dp) :: h

n = size(R)
y = y0
y1(1) = y(1)
y2(1) = y(2)
do i = 2, n
    ! rk4 step size
    h = R(i)-R(i-1)

    ! Do rk4 step:
    dydx(1) =                      y(2)
    dydx(2) = C1(i-1)  + C2(i-1) * y(2)
    yt = y + h/2 * dydx
    dyt(1) =                           yt(2)
    dyt(2) = C1mid(i-1) + C2mid(i-1) * yt(2)
    yt = y + h/2 * dyt
    dym(1) =                           yt(2)
    dym(2) = C1mid(i-1) + C2mid(i-1) * yt(2)
    yt = y + h * dym
    dym = dyt + dym
    dyt(1) =                 yt(2)
    dyt(2) = C1(i) + C2(i) * yt(2)
    y = y + h/6 * (dydx + dyt + 2*dym)

    y1(i) = y(1)
    y2(i) = y(2)
    if (abs(y(1)) >= max_val) then
        imax = i
        return
    end if
end do
imax = n
end subroutine

subroutine rk4_integrate4(R, y0, C, Cmid, max_val, y1, y2, imax)
! Integrates the following set of equations outwards:
! dy1/dx = C(:, 1, 1) * y1 + C(:, 1, 2) * y2
! dy2/dx = C(:, 2, 1) * y1 + C(:, 2, 2) * y2
real(dp), intent(in) :: R(:) ! Grid
real(dp), intent(in) :: y0(:) ! Initial condition
! Coefficients C1 and C2 at grid points and midpoints:
real(dp), intent(in) :: C(:, :, :), Cmid(:, :, :)
! Maximum value (if y1 > max_val, the integration stops)
real(dp), intent(in) :: max_val
! Solution y1 and y2
real(dp), intent(out) :: y1(:), y2(:)
! The integration stops at R(imax)
integer, intent(out) :: imax

integer :: i
integer :: n
real(dp), dimension(size(y0)) :: dym, dyt, yt, dydx, y
real(dp) :: h

n = size(R)
y = y0
y1(1) = y(1)
y2(1) = y(2)
do i = 2, n
    ! rk4 step size
    h = R(i)-R(i-1)

    ! Do rk4 step:
    dydx(1) = C(i-1, 1, 1) * y(1) + C(i-1, 1, 2) * y(2)
    dydx(2) = C(i-1, 2, 1) * y(1) + C(i-1, 2, 2) * y(2)
    !dydx = matmul(C(i-1, :, :), y)
    yt = y + h/2 * dydx
    dyt(1) = Cmid(i-1, 1, 1) * yt(1) + Cmid(i-1, 1, 2) * yt(2)
    dyt(2) = Cmid(i-1, 2, 1) * yt(1) + Cmid(i-1, 2, 2) * yt(2)
    !dyt = matmul(Cmid(i-1, :, :), yt)
    yt = y + h/2 * dyt
    dym(1) = Cmid(i-1, 1, 1) * yt(1) + Cmid(i-1, 1, 2) * yt(2)
    dym(2) = Cmid(i-1, 2, 1) * yt(1) + Cmid(i-1, 2, 2) * yt(2)
    !dym = matmul(Cmid(i-1, :, :), yt)
    yt = y + h * dym
    dym = dyt + dym
    dyt(1) = C(i, 1, 1) * yt(1) + C(i, 1, 2) * yt(2)
    dyt(2) = C(i, 2, 1) * yt(1) + C(i, 2, 2) * yt(2)
    !dyt = matmul(C(i, :, :), yt)
    y = y + h/6 * (dydx + dyt + 2*dym)

    y1(i) = y(1)
    y2(i) = y(2)
    if (abs(y(1)) >= max_val .or. abs(y(2)) >= max_val) then
        imax = i
        return
    end if
end do
imax = n
end subroutine

subroutine rk4_integrate(R, y0, C1, C2, C1mid, C2mid, max_val, y1, y2, imax)
! Integrates the following set of equations outwards:
! dy1/dx =                y2
! dy2/dx = C1 * y1 + C2 * y2
real(dp), intent(in) :: R(:) ! Grid
real(dp), intent(in) :: y0(:) ! Initial condition
! Coefficients C1 and C2 at grid points and midpoints:
real(dp), intent(in) :: C1(:), C2(:), C1mid(:), C2mid(:)
! Maximum value (if y1 > max_val, the integration stops)
real(dp), intent(in) :: max_val
! Solution y1 and y2
real(dp), intent(out) :: y1(:), y2(:)
! The integration stops at R(imax)
integer, intent(out) :: imax

integer :: i
integer :: n
real(dp), dimension(size(y0)) :: dym, dyt, yt, dydx, y
real(dp) :: h

n = size(R)
y = y0
y1(1) = y(1)
y2(1) = y(2)
do i = 2, n
    ! rk4 step size
    h = R(i)-R(i-1)

    ! Do rk4 step:
    dydx(1) =                            y(2)
    dydx(2) = C1(i-1) * y(1) + C2(i-1) * y(2)
    yt = y + h/2 * dydx
    dyt(1) =                                   yt(2)
    dyt(2) = C1mid(i-1) * yt(1) + C2mid(i-1) * yt(2)
    yt = y + h/2 * dyt
    dym(1) =                                   yt(2)
    dym(2) = C1mid(i-1) * yt(1) + C2mid(i-1) * yt(2)
    yt = y + h * dym
    dym = dyt + dym
    dyt(1) =                         yt(2)
    dyt(2) = C1(i) * yt(1) + C2(i) * yt(2)
    y = y + h/6 * (dydx + dyt + 2*dym)

    y1(i) = y(1)
    y2(i) = y(2)
    if (abs(y(1)) >= max_val) then
        imax = i
        return
    end if
end do
imax = n
end subroutine

end module


program tsunami
  ! Solves 1-d non-linear shallow water equations:
  !
  !   Velocity:
  !       du/dt + u * du/dx + g * dh/dx = 0
  !
  !   Elevation:
  !       dh/dt + d((H + h) * u) / dx = 0
  !
  use mod_diff, only: diff => diff_centered
  use datetime_module, only: datetime

  implicit none

  integer, parameter :: grid_size = 100
  integer, parameter :: num_time_steps = 1000

  real, parameter :: dx = 1.0 ! grid spacing [m]
  real, parameter :: dt = 0.02 ! time steps [s]
  real, parameter :: g = 9.8 ! gravitational acceleration [m/s^2]
  real, parameter :: bottom_friction = 0.1
  real, parameter :: depth = 10 ! mean water depth [m]

  integer, parameter :: icenter = 50 ! center index of initial perturbation
  real, parameter :: decay = 0.02 ! lower value means slower decay

  real :: h(grid_size), u(grid_size) ! state arrays

  integer :: i, n ! spatial grid index and time step counter

  ! initialize velocity and water height arrays
  u = 0
  init: do i = 1, grid_size
    h(i) = exp(- decay * (i - icenter)**2)
  end do init

  n = 0

  print *, n, h ! print time step and water height array to standard output

  time_loop: do n = 1, num_time_steps

    ! compute velocity at the next time step
    u = u - (u * diff(u) + g * diff(h)) / dx * dt &
          - bottom_friction / (depth + h) * u**2 * dt

    ! compute water height at the next time step
    h = h - diff((depth + h) * u) / dx * dt

    print *, n, h ! print time step and water height array to standard output

  end do time_loop

end program tsunami


submodule(forlab) forlab_lu
    !! Version: experimental
    !!
    !! Discussion:
    !! ----
    !! https://fortran-lang.discourse.group/t/fortran-function-return-value-polymorphism/1350/5
    use forlab_kinds
    implicit none

contains
    module subroutine lu_sp (A, L, U)
        real(sp), dimension(:, :), intent(in) :: A
        real(sp), dimension(:, :), allocatable, intent(out) :: L, U
        integer :: i, j, k, m
        real(sp) :: flag

        if (issquare(A)) then
            m = size(A, 1)
            if (.not. allocated(L)) L = eye(m, flag)
            if (.not. allocated(U)) U = zeros(m, m, flag)

            do i = 1, m
                do j = 1, m
                    U(i, j) = A(i, j)
                    do k = 1, i - 1
                        U(i, j) = U(i, j) - L(i, k)*U(k, j)
                    end do
                end do
                do j = i + 1, m
                    L(j, i) = A(j, i)
                    do k = 1, i - 1
                        L(j, i) = L(j, i) - L(j, k)*U(k, i)
                    end do
                    L(j, i) = L(j, i)/U(i, i)
                end do
            end do
        else
            stop "Error: in A = LU, A should be square."
        end if
        return
    end subroutine

    module subroutine lu_dp (A, L, U)
        real(dp), dimension(:, :), intent(in) :: A
        real(dp), dimension(:, :), allocatable, intent(out) :: L, U
        integer :: i, j, k, m
        real(dp) :: flag

        if (issquare(A)) then
            m = size(A, 1)
            if (.not. allocated(L)) L = eye(m, flag)
            if (.not. allocated(U)) U = zeros(m, m, flag)

            do i = 1, m
                do j = 1, m
                    U(i, j) = A(i, j)
                    do k = 1, i - 1
                        U(i, j) = U(i, j) - L(i, k)*U(k, j)
                    end do
                end do
                do j = i + 1, m
                    L(j, i) = A(j, i)
                    do k = 1, i - 1
                        L(j, i) = L(j, i) - L(j, k)*U(k, i)
                    end do
                    L(j, i) = L(j, i)/U(i, i)
                end do
            end do
        else
            stop "Error: in A = LU, A should be square."
        end if
        return
    end subroutine

    module subroutine lu_qp (A, L, U)
        real(qp), dimension(:, :), intent(in) :: A
        real(qp), dimension(:, :), allocatable, intent(out) :: L, U
        integer :: i, j, k, m
        real(qp) :: flag

        if (issquare(A)) then
            m = size(A, 1)
            if (.not. allocated(L)) L = eye(m, flag)
            if (.not. allocated(U)) U = zeros(m, m, flag)

            do i = 1, m
                do j = 1, m
                    U(i, j) = A(i, j)
                    do k = 1, i - 1
                        U(i, j) = U(i, j) - L(i, k)*U(k, j)
                    end do
                end do
                do j = i + 1, m
                    L(j, i) = A(j, i)
                    do k = 1, i - 1
                        L(j, i) = L(j, i) - L(j, k)*U(k, i)
                    end do
                    L(j, i) = L(j, i)/U(i, i)
                end do
            end do
        else
            stop "Error: in A = LU, A should be square."
        end if
        return
    end subroutine

end submodule


      subroutine r8mktricubw(x,nx,y,ny,z,nz,f,nf2,nf3,
     >                    ibcxmin,bcxmin,ibcxmax,bcxmax,inb1x,
     >                    ibcymin,bcymin,ibcymax,bcymax,inb1y,
     >                    ibczmin,bczmin,ibczmax,bczmax,inb1z,
     >                    wk,nwk,ilinx,iliny,ilinz,ier)
c
c  setup a tricubic spline; store coefficients in compatct form
c  (as per suggestion of L. Zakharov, PPPL, Feb. 1999)
C  8 coeffs per (x,y,z) grid point:
C          f,fxx,fyy,fzz,fxxyy,fxxzz,fyyzz,fxxyyzz
C
C  input:
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER itest,iadfp,isiz1,iadfw,inwk
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 hxlast,hylast,hzlast
!============
      integer nx                        ! length of x vector
      integer ny                        ! length of y vector
      integer nz                        ! length of z vector
      REAL*8 x(nx)                        ! x vector, strict ascending
      REAL*8 y(ny)                        ! y vector, strict ascending
      REAL*8 z(nz)                        ! z vector, strict ascending
c
      integer nf2                       ! 2nd dim. of f array, nf2.ge.nx
      integer nf3                       ! 3rd dim. of f array, nf3.ge.ny
c
c  input/output:
c
      REAL*8 f(8,nf2,nf3,nz)              ! data and spline coefficients
c
C  on input:  f(1,i,j,k) = f(x(i),y(j),z(k))
C  on output:  f(1,i,j,k) unchanged
C              f(2,i,j,k) = d2f/dx2(x(i),y(j),z(k))
C              f(3,i,j,k) = d2f/dy2(x(i),y(j),z(k))
C              f(4,i,j,k) = d2f/dz2(x(i),y(j),z(k))
C              f(5,i,j,k) = d4f/dx2dy2(x(i),y(j),z(k))
C              f(6,i,j,k) = d4f/dx2dz2(x(i),y(j),z(k))
C              f(7,i,j,k) = d4f/dy2dz2(x(i),y(j),z(k))
C              f(8,i,j,k) = d6f/dx2dy2dz2(x(i),y(j),z(k))
C
C  there is a rather Hermite like interpolation formula to go with
C  this-- see evtricub.for.  Also the bicubic formula is given in
C  mkbicubw.for; the tricubic formula is precisely analogous.
C
C  boundary condition data
C  inputs:
      integer inb1x                     ! 1st dim of xmin & xmax bc arrays
      integer inb1y                     ! 1st dim of ymin & ymax bc arrays
      integer inb1z                     ! 1st dim of zmin & zmax bc arrays
C
      integer ibcxmin,ibcxmax           ! BC type flag @xmin, xmax
      integer ibcymin,ibcymax           ! BC type flag @ymin, ymax
      integer ibczmin,ibczmax           ! BC type flag @zmin, zmax
C
      REAL*8 bcxmin(inb1x,nz),bcxmax(inb1x,nz) ! xmin & xmax BC data, ny x nz
      REAL*8 bcymin(inb1y,nz),bcymax(inb1y,nz) ! ymin & ymax BC data, nx x nz
      REAL*8 bczmin(inb1z,ny),bczmax(inb1z,ny) ! zmin & zmax BC data, nx x ny
c
c  where BC data is not required, dummy scalars may be passed.
C  the ibc* flags determine whether BC data isneeded.
c
c  BC data:  bcxmin & bcxmax:  BC vs. y,z @xmin,xmax
C            bcymin & bcymax:  BC vs. x,z @ymin,ymax
C            bczmin & bczmax:  BC vs. x,y @zmin,zmax
C
c   ibcxmin -- indicator for boundary condition at xmin=x(1):
c    bcxmin(...) -- boundary condition data
c     =-1 -- use periodic boundary condition
c     =0 -- use "not a knot"
c     =1 -- match slope, specified at x(1),y(iy),z(iz) by bcxmin(iy,iz)
c     =2 -- match 2nd derivative, specified at x(1),y(iy),z(iz)
c           by bcxmin(iy,iz
c     =3 -- boundary condition is slope=0 (df/dx=0) at x(1), all y(j)
c     =4 -- boundary condition is d2f/dx2=0 at x(1), all y(j)
c     =5 -- match 1st derivative to 1st divided difference
c     =6 -- match 2nd derivative to 2nd divided difference
c     =7 -- match 3rd derivative to 3rd divided difference
c           (for more detailed definition of BCs 5-7, see the
c           comments of subroutine mkspline)
c   ***NOTE bcxmin(...) referenced ONLY if ibcxmin=1 or ibcxmin=2
c
c   ibcxmax -- indicator for boundary condition at x(nx):
c    bcxmax(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c     NOTE:  if ibcxmin=-1 then the periodic BC applies on both sides
c            and ibcxmax, bcxmax are ignored.
c   inb1x -- 1st dimension of bcxmin, bcxmax: if ibcxmin or ibcxmax .gt. 0
c            this must be .ge. ny.
c
c   interpretation of ibcymin,bcymin,ibcymax,bcymax,inb1y
c     is same as with ibcxmin,...
c
c   interpretation of ibczmin,bczmin,ibczmax,bczmax,inb1z
c     is same as with ibcxmin,...
c
c   the explicit bdy condition arrays are referenced only if the
c     corresponding "ibc" flag values are set to 1 or 2.
c
c  workspace:
      integer nwk                       ! size of workspace
      REAL*8 wk(nwk)                      ! workspace array
c
c  this version requires a very large workspace, nwk.ge.80*nx*ny*nz
c  so as to be able to use tcspline to calculate the spline coefficients.
c
c  output:
      integer ilinx                     ! x vector equal spacing flag
      integer iliny                     ! y vector equal spacing flag
      integer ilinz                     ! z vector equal spacing flag
c
c   ilinx -- =1 on output if x(nx) pts are nearly evenly spaced (tol=1e-3)
c   iliny -- =1 on output if y(ny) evenly spaced (tol=1e-3)
c   ilinz -- =1 on output if z(nz) evenly spaced (tol=1e-3)
c
      integer ier                       ! exit code
c   ier -- completion code, 0 for normal
c
C-----------------------------------------------------
C
      itest=80*nx*ny*nz
      if(nwk.lt.itest) then
         write(6,9901) nwk,itest
 9901    format(' ?mktricubw:  workspace too small:'/
     >          '  user supplied:  nwk=',i7,'; need at least:  ',i7/
     >      '  nwk = at least 21*nx*ny is required.')
         ier=1
         return
      endif
C
      iadfp=1
      isiz1=64*nx*ny*nz
      iadfw=iadfp+isiz1
      inwk = nwk-isiz1
C
      call r8mktricop(f,nf2,nf3,wk(iadfp),nx,ny,nz)
C
C  evaluate 4x4x4 continuous tricubic spline
C
      call r8tcspline(x,nx,y,ny,z,nz,wk(iadfp),nx,ny,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,inb1x,
     >   ibcymin,bcymin,ibcymax,bcymax,inb1y,
     >   ibczmin,bczmin,ibczmax,bczmax,inb1z,
     >   wk(iadfw),inwk,ilinx,iliny,ilinz,ier)
C
C  convert to 8-coefficient form
C
      hxlast=x(nx)-x(nx-1)
      hylast=y(ny)-y(ny-1)
      hzlast=z(nz)-z(nz-1)
      call r8mktricon(f,nf2,nf3,wk(iadfp),nx,ny,nz,hxlast,hylast,hzlast)
C
      return
      end
C----------------------------------------------------------------
C  mktricop -- copy spline function input data
C
      subroutine r8mktricop(fin,nf2,nf3,fwk,nx,ny,nz)
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nf3,nx,ny,nz,nf2,iz,iy,ix
!============
      REAL*8 fin(8,nf2,nf3,nz)
      REAL*8 fwk(4,4,4,nx,ny,nz)
C
      do iz=1,nz
         do iy=1,ny
            do ix=1,nx
               fwk(1,1,1,ix,iy,iz)=fin(1,ix,iy,iz)
            enddo
         enddo
      enddo
C
      return
      end
C----------------------------------------------------------------
C  mktricon -- create compact spline representation from 4x4
C             (bcspline) representation
C
      subroutine r8mktricon(fin,nf2,nf3,fwk,nx,ny,nz,
     >   hxlast,hylast,hzlast)
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nf3,nx,ny,nz,nf2,iz,iy,ix,iflag,ixuse,iyuse,izuse,j
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 hxlast,hylast,hzlast,dxuse,dyuse,dzuse
!============
      REAL*8 fin(8,nf2,nf3,nz)
      REAL*8 fwk(4,4,4,nx,ny,nz)
C-----------------------------------------------------
C  local arrays
C
      integer iselect(10)
      REAL*8 zvalues(10)
C
      data iselect/-1,0,0,0,0,0,0,0,0,0/
C
C-----------------------------------------------------
C
      do iz=1,nz
         do iy=1,ny
            do ix=1,nx
C
C  copy derivatives from result.  Special treatment needed for end zones
C
               iflag=0
               dxuse=0.0_r8
               dyuse=0.0_r8
               dzuse=0.0_r8
               ixuse=ix
               iyuse=iy
               izuse=iz
C
               if(ix.eq.nx) then
                  iflag=1
                  dxuse=hxlast
                  ixuse=ix-1
               endif
               if(iy.eq.ny) then
                  iflag=1
                  dyuse=hylast
                  iyuse=iy-1
               endif
               if(iz.eq.nz) then
                  iflag=1
                  dzuse=hzlast
                  izuse=iz-1
               endif
C
               if(iflag.eq.1) then
                  call r8tcspevfn(iselect,1,1,zvalues,
     >               ixuse,iyuse,izuse,dxuse,dyuse,dzuse,
     >               fwk,nx,ny,nz)
                  do j=2,8
                     fin(j,ix,iy,iz)=zvalues(j)
                  enddo
               else
                  fin(2,ix,iy,iz)=2.0_r8*fwk(3,1,1,ix,iy,iz)
                  fin(3,ix,iy,iz)=2.0_r8*fwk(1,3,1,ix,iy,iz)
                  fin(4,ix,iy,iz)=2.0_r8*fwk(1,1,3,ix,iy,iz)
                  fin(5,ix,iy,iz)=4.0_r8*fwk(3,3,1,ix,iy,iz)
                  fin(6,ix,iy,iz)=4.0_r8*fwk(3,1,3,ix,iy,iz)
                  fin(7,ix,iy,iz)=4.0_r8*fwk(1,3,3,ix,iy,iz)
                  fin(8,ix,iy,iz)=8.0_r8*fwk(3,3,3,ix,iy,iz)
               endif
C
            enddo
         enddo
      enddo
C
      return
      end


      SUBROUTINE SLESUM(X,N,A,SUM)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 SLESUM Krogh  Changes to use M77CON
C>> 1994-04-20 SLESUM CLL  Edited to make DP & SP files similar.
C>> 1992-03-13 SLESUM FTK  Removed implicit statements.
C>> 1985-08-02 SLESUM Lawson  Initial code.
C
C     THIS SUBROUTINE EVALUATES THE SUM OF
C          A(J) * P(J) FOR J = 0,...,N,
C     WHERE P(J)'S  ARE LEGENDRE POLYNOMIALS OF DEGREE J.
C
C     THE RECURSION FORMULA IS :
C     B(K) = X+B(K+1)*(2*K+1)/(K+1)-B(K+2)*(K+1)/(K+2)+A(K)
C
C     C.L.LAWSON & S.CHAN, JPL, 1983 JUNE 9
C
C     -------------------------------------------------------------
C     SUBROUTINE ARGUMENTS
C     --------------------
C     X     ARGUMENT OF LEG POLYS, X SHOULD BE NON-NEGATIVE.
C     N     SUM IS TO INCLUDE LEGENDRE POLYS OF DEGREE ZERO
C           THRU N.
C     A()   A,...,A(N) CONTAIN COEFFS TO BE USED IN
C           FORMING THE SUM.
C     SUM   SUM OF COMBINATION
C
C     -------------------------------------------------------------
c--S replaces "?": ?LESUM
C     -------------------------------------------------------------
      INTEGER K,N
      REAL             A(0:N),B,B1,B2,C1,C2,C3
      REAL             ONE,SUM,TWO,X,ZERO
      DATA ZERO,ONE,TWO / 0.E0, 1.E0, 2.E0 /
C     -------------------------------------------------------------
      IF (N .lt. 0) then
         SUM = ZERO
         RETURN
      endif
C
      C1 = REAL(N+1)
      C3 = C1 + C1 - ONE
      B1 = ZERO
      B  = A(N)
C
      DO 10 K = N-1,0,-1
C
C     C1 = K + 1, C3 = 2K + 1
C
        C2 = C1
        C1 = C1 - ONE
        C3 = C3 - TWO
        B2 = B1
        B1 = B
        B  = X * B1 * C3 / C1  -  B2 * C1 / C2  +  A(K)
  10  CONTINUE
      SUM = B
      RETURN
      END


program num_diff_main
  use nrtype
  use num_diff
  real(dp) :: x, h
  real(dp) :: i
  real(dp) :: start, finish
  real(dp) :: aux
  integer, allocatable :: coefs(:)
  real(dp), allocatable :: coefnk(:,:,:,:), coefnkc(:,:,:)

  open(unit=1, file = 'test_numdif.dat')
  !do i = 0._dp, tau, 0.01_dp
  !  write(1,*) i, sin(i), cos(i),sifodi1(sine,i,0.0001_dp), (cos(i)-sifodi1(sine,i,0.01_dp))*100._dp &
  !  ,eicedi1(sine,i,0.01_dp), (cos(i)-sifodi1(sine,i,0.01_dp))*100._dp
  !end do
  !call cpu_time(finish)

  call cpu_time(start)

  allocate(coefs(3))
  coefs = dncoef1(2)

  !do i = 0._dp, tau, 0.01_dp
  !  write(1,*) i, fdo1(sine, i, 0.01_dp, coefs), bdo1(sine, i, 0.01_dp, coefs), cdo1(sine, i, 0.01_dp, coefs)
  !end do

  !deallocate(coefs)
  !aux = 0.
  !allocate(coefs(3))
  !coefs = dncoefn(1,2)
  !print*, aux,aux,aux,aux, dncoef1(1)
  !print*, aux,aux,aux,-dncoef1(2)/2
  !print*, aux,aux, dncoef1(3)/3
  !print*, aux,-dncoef1(4)/4
  !print*, dncoef1(5)/5
  !print*, "--------"
!  print*, aux,aux, aux, dncoef1(2)
!  print*, aux,aux, -dncoef1(3)
!  print*, aux, dncoef1(4)
!  print*, dncoef1(5)
!  print*, dncoef1(6)
  !print*, dncoefn(2,3)

  allocate(coefnk(2,0:2,0:2,0:2))
  allocate(coefnkc(0:2,0:2,0:4))
  coefnk(1,:,:,:) = dncoefn(2, 2, [0._dp,1._dp,2._dp],0._dp)
  coefnk(2,:,:,:) = dncoefn(2, 2, [0._dp,-1._dp,-2._dp],0._dp)
  coefnkc(:,:,:)  = dncoefn(2, 2, [0._dp,1._dp,-1._dp,2._dp,-2._dp],0._dp)
  print*, coefnk(1,2,2,:)
  print*, coefnk(2,2,2,:)
  print*, coefnkc(2,2,:)

  do i = 0._dp, tau, 0.01_dp
    write(1,*) i, sin(i) + ndifnk(sine, i, 0.01_dp, 2, [0._dp,1._dp,2._dp],  coefnk(1,2,2,:)),&
                  sin(i) + ndifnk(sine, i, 0.01_dp, 2, [0._dp,-1._dp,-2._dp], coefnk(2,2,2,:)),&
                  sin(i) + ndifnk(sine, i, 0.01_dp, 2, [0._dp,1._dp,-1._dp,2._dp,-2._dp], coefnkc(2,2,:))
  end do

contains
    function sine(x)
      real(dp), intent(in) :: x
      real(dp)             :: sine
      sine = sin(x)
    end function sine
end program num_diff_main


program test_quad_mc

	use functions, only: g, gevals
    use quadrature_mc, only: quad_mc
    use random_util, only: init_random_seed

    implicit none
    integer, parameter :: ndim = 20
    real(kind=8), dimension(ndim) :: a, b
    real(kind=8) :: volume, int_true, int_mc, int_mc_total, error
    integer :: i, seed1, n_total
    integer :: num_chunks, points_per_chunk, npoints

    gevals = 0
    open(unit=25, file='mc_quad_error.txt', status='unknown')

    do i=1,ndim
        a(i) = 2.d0
        b(i) = 4.d0
        enddo

    ! compute the true integral for special case where
    ! g(x) = sum(x**2) over all dimensions  -- think about why this works!
    volume = product(b-a)  ! =  product of b(i)-a(i) of ndim dimensions
    int_true = volume * sum((b**3 - a**3) / (3.d0*(b-a)))

    print '("Testing Monte Carlo quadrature in ",i2," dimensions")', ndim
    print '("True integral: ", es22.14)', int_true

    seed1 = 12345   ! or set to 0 for random seed
    call init_random_seed(seed1)

    ! Start with Monte Carlo using only a few points:
    npoints = 10
    int_mc = quad_mc(g,a,b,ndim,npoints)

    ! start accumulating totals:
    int_mc_total = int_mc
    n_total = npoints

    ! relative error gives estimate of number of correct digits:
    error = abs(int_mc_total - int_true) / abs(int_true)
    write(25,'(i10,e23.15,e15.6)') n_total, int_mc_total, error

    ! loop to successively double the number of points used:

    do i=1,17
        ! compute approximation with new chunk of points
        int_mc = quad_mc(g,a,b,ndim,npoints)

        ! update estimate of integral based on doubling number:
        int_mc_total = 0.5*(int_mc_total + int_mc)
        n_total = n_total + npoints

        ! relative error:
        error = abs(int_mc_total - int_true) / abs(int_true)

        write(25,'(i10,e23.15,e15.6)') n_total, int_mc_total, error
        print '("With ",i9," points, the error is ",es15.8)', n_total,error

        npoints = 2*npoints
        enddo

    print '("Final approximation to integral: ",es22.14)',int_mc_total
    print *, "Total g evaluations: ",gevals

end program test_quad_mc


      subroutine getindx(nn,mid,size,loc,index,inflag)
c-----------------------------------------------------------------------
c
c     Gets the coordinate index location of a point within a grid
c     ***********************************************************
c
c
c nn       number of "nodes" or "cells" in this coordinate direction
c mid     origin at the center of the first cell
c size     size of the cells
c loc     location of the point being considered
c index   output index within [1,n]
c inflag  true if the location is actually in the grid (false otherwise
c         e.g., if the location is outside then index will be set to
c         nearest boundary
c
c
c
c-----------------------------------------------------------------------
	use varmod
	implicit none
      integer::nn,index
      real::mid,size,loc
      logical::inflag
c
c Compute the index of "loc":
c
      index = int( (loc-mid)/size + 1.5 )

c
c Check to see if in or out:
c
      if(index.lt.1) then
            index  = 1
            inflag = .false.
      else if(index.gt.nn) then
            index  = nn
            inflag = .false.
      else
            inflag = .true.
      end if
c
c Return to calling program:
c
      return
      end


module testmod_der1
implicit none
private
public fcn, dp

integer, parameter :: dp=kind(0d0)

contains

subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag)
integer, intent(in) :: m, n, ldfjac
integer, intent(inout) :: iflag
real(dp), intent(in) :: x(n)
real(dp), intent(inout) :: fvec(m), fjac(ldfjac, n)

integer :: i
real(dp) :: tmp1, tmp2, tmp3, tmp4, y(15)
y = [1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, 3.2D-1, 3.5D-1, 3.9D-1, &
        3.7D-1, 5.8D-1, 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0]

if (iflag == 1) then
    do i = 1, 15
        tmp1 = i
        tmp2 = 16 - i
        tmp3 = tmp1
        if (i .gt. 8) tmp3 = tmp2
        fvec(i) = y(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3))
    end do
else
    do i = 1, 15
        tmp1 = i
        tmp2 = 16 - i
        tmp3 = tmp1
        if (i .gt. 8) tmp3 = tmp2
        tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2
        fjac(i,1) = -1.D0
        fjac(i,2) = tmp1*tmp2/tmp4
        fjac(i,3) = tmp1*tmp3/tmp4
    end do
end if
end subroutine

end module

program example_lmder1
use minpack_module, only: enorm, lmder1, chkder
use testmod_der1, only: dp, fcn
implicit none

integer :: info
real(dp) :: tol, x(3), fvec(15), fjac(size(fvec), size(x))
integer :: ipvt(size(x))
real(dp), allocatable :: wa(:)

! The following starting values provide a rough fit.
x = [1._dp, 1._dp, 1._dp]

call check_deriv()

! Set tol to the square root of the machine precision. Unless high precision
! solutions are required, this is the recommended setting.
tol = sqrt(epsilon(1._dp))

allocate(wa(5*size(x) + size(fvec)))
call lmder1(fcn, size(fvec), size(x), x, fvec, fjac, size(fjac, 1), tol, &
    info, ipvt, wa, size(wa))
print 1000, enorm(size(fvec), fvec), info, x
1000 format(5x, 'FINAL L2 NORM OF THE RESIDUALS', d15.7 // &
            5x, 'EXIT PARAMETER', 16x, i10              // &
            5x, 'FINAL APPROXIMATE SOLUTION'            // &
            5x, 3d15.7)

contains

subroutine check_deriv()
integer :: iflag
real(dp) :: xp(size(x)), fvecp(size(fvec)), err(size(fvec))
call chkder(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), xp, fvecp, &
    1, err)
iflag = 1
call fcn(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), iflag)
iflag = 2
call fcn(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), iflag)
iflag = 1
call fcn(size(fvec), size(x), xp, fvecp, fjac, size(fjac, 1), iflag)
call chkder(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), xp, fvecp, &
    2, err)
print *, "Derivatives check (1.0 is correct, 0.0 is incorrect):"
print *, err
end subroutine

end program


!=======================================================================================
!>Module: module_solver                                                                !
!>Details: This module solves for flow paramters of the Couette-Poiseuille flow cases  !
!>======================================================================================

module module_solver
use module_triSolve
implicit none

contains
subroutine flowSolve(VW,H,N,YPAD,YHAD,ALPHA,DPDX,KIN_VIS,CONV_CRIT,MAX_ITER,OUTPUTFILE,NUM_CASE)
	implicit none
	REAL(8)                         :: UAVG                                 !Average flow velocity
	REAL(8)                         :: UTAU1        	                !Friction velocity at high-stress wall
	REAL(8)                         :: UTAU2	                        !Friction velocity at low-stress wall
	REAL(8)                         :: TKIN_VIS(1:N)	                !Average turbulent kinematic viscosity
	REAL(8)                         :: L_M(N), L_0(N),A1,A2                 !Parameters of Mixing Length Model
	REAL(8)                         :: U(N)                                 !Flow velocity at node points
        !OTHER SUPPELEMENTARY PARAMETERS
        CHARACTER(len=15),INTENT(IN)    :: OUTPUTFILE
	INTEGER                         :: I,ITER
	INTEGER,INTENT(IN)              :: N,NUM_CASE,MAX_ITER
	REAL(8),INTENT(IN)              :: KIN_VIS,H,VW,ALPHA,DPDX,CONV_CRIT
	REAL(8),INTENT(IN)              :: YPAD(N),YHAD(N)
	REAL(8)			        :: ERROR,U1(N),LD(1:N),MD(1:N),UD(1:N),D(1:N)
	REAL(8)			        :: TKIN_VISN(1:N),TKIN_VISS(1:N),A(1:N),B(1:N),YF(N-1)

	YF(1)=0.0d0
	do I=2,N-1
		YF(I)=YPAD(I)+ (YPAD(I)-YF(I-1))
	end do
	do I= 2,N-1
		L_0(I)=(0.21D0-(0.43D0*((1.0d0-(2.0d0*(YF(I)/H)))**4)) + (0.22D0*((1.0d0-(2.0d0*(YF(I))/H))**6)))*(H/2.0d0)
	end do
	ERROR=1.0d0
	ITER=0
	do
		if(ERROR>CONV_CRIT .AND. ITER<MAX_ITER )then
		U1=0.0d0
		     if (NUM_CASE<16) then
        		        UTAU1=DSQRT((dabs(U(2))/(YPAD(2)))*KIN_VIS)
                     else
				UTAU1=DSQRT((dabs(U(2)-U(1))/(YHAD(2)))*KIN_VIS)
                     end if
		UTAU2=DSQRT((dabs(U(N-1)-U(N))/(YHAD(N)))*KIN_VIS)
		A1=26.0d0*KIN_VIS/UTAU1
		A2=26.0d0*KIN_VIS/UTAU2
	        do I=2,(N+1)/2
			L_M(I)=L_0(I)*(1.0d0-DEXP(-YF(I)/A1))
			L_M(N-(I-1))=L_0(N-(I-1))*(1.0d0-DEXP(-YF(I)/A2))
		end do
		do I=2,N-1
			TKIN_VISN(I)=(L_M(I)**2)*Dabs((U(I+1)-U(I))/(YHAD(I+1)))
			TKIN_VISS(I)=(L_M(I)**2)*abs((U(I)-U(I-1))/(YHAD(I)))
			!AVERAGE of North and South Face Turbulent viscosity
			TKIN_VIS(I)=(TKIN_VISN(I)+TKIN_VISS(I))/2.0
		end do
		do I=2,N-1
	                A(I)= KIN_VIS + TKIN_VIS(I)
	                B(I)= KIN_VIS + TKIN_VIS(I-1)
 	        end do
		LD=0.0d0;MD=0.0d0;UD=0.0d0
		do I=2,N-1
			LD(I)=B(I)/YHAD(I)
			MD(I)=-((A(I)/YHAD(I+1))+(B(I)/YHAD(I)))
			UD(I)=A(I)/(YHAD(I+1))
		end do
		MD(1)=1.0d0;MD(N)=1.0d0
		UD(1)=1.0d0;LD(N)=1.0d0;LD(1)=0.0d0;UD(N)=0.0d0
		if (NUM_CASE<16) then
        		D(1)=0.0d0
		else
		        D(1)=2.0d0*VW
		end if
		do I=2,N-1
			D(I)=DPDX*((YPAD(I+1)-YPAD(I-1))/2.0d0)
		end do
		if (NUM_CASE<16) then
        		D(N)=2.0d0*VW
		else
		        D(N)=0.0d0
                end if
                !Solving with Tridiagonal Matrix Solver
                CALL triSolve(LD,MD,UD,D,U1,N)
                ERROR=0.0d0
		do I=2,N-1
  			ERROR=ERROR+(U(I)-U1(I))**2
  		end do
		ERROR=DSQRT(ERROR/DFLOAT(N-2))
		U=U1
		ITER= ITER+1

		else
      		       		EXIT
  		end if
	end do
  	if (ITER==MAX_ITER) then
          	print *, "Convergence was not reached !"
       		print *, "Calculations terminated after", MAX_ITER,"iterations."
  	else
        	print*,"Convergence was reached after, iterations =",ITER
	end if
	if (NUM_CASE<16) then
        	UTAU1=SQRT((abs(U(2))/(YPAD(2)))*KIN_VIS)
	else
	        UTAU1=DSQRT((dabs(U(2)-U(1))/(YHAD(2)))*KIN_VIS)
	end if
	UTAU2=SQRT((abs(U(N-1)-U(N))/(YHAD(N)))*KIN_VIS)
	print*,"UTAU1=",UTAU1,"UTAU2=",UTAU2
	UAVG=SUM(U(2:N-1))/DFLOAT(N-2)
	print*,"UAVG=",ABS(UAVG),"UMAX=",MAXVAL(ABS(U))
	open(33,file=OUTPUTFILE)
	write(33,*) "######################################################################"
	write(33,*) "#Data for Case=",NUM_CASE
	write(33,*) "#   ALPHA,             N,       ITER, VW,          UMAX ,       UAVG,           UTAU1,          UTAU2    "
	write(33,"(A3,ES16.8,I8,I10,5ES16.8)") "#",ALPHA,N,ITER,VW,MAXVAL(ABS(U)),ABS(UAVG),UTAU1,UTAU2
	write(33,*) "######################################################################"
	if (NUM_CASE<16) then
        	write(33,*) "# YPAD(I)/H,     U(I)/VW	"
	        write(33,"(2ES16.8)")0.0d0,0.0d0
	else
	        write(33,*) "# YPAD(I)/H,     U(I)/UAVG	"
	        write(33,"(2ES16.8)")0.0d0,VW/UTAU2
	end if
	do I=2,N-1
		if (NUM_CASE<15) then
		        write(33,"(2ES16.8)")YPAD(I)/H,U(I)/VW
		else if(NUM_CASE==15) then
		        write(33,"(2ES16.8)")YPAD(I)/H,U(I)/(MAXVAL(ABS(U)))
		else
		        write(33,"(2ES16.8)")YPAD(I)/H,U(I)/UAVG
		end if
	end do
	if (NUM_CASE<15) then
	        write(33,"(2ES16.8)")1.0d0,1.0d0
	else
	        write(33,"(2ES16.8)")1.0d0,0.0d0
	end if
	close(33)
end subroutine
end module module_solver


module sub1_module

contains
    subroutine sub1(radius, area, circumference)
        use iso_fortran_env, wp => real64
        use maths_module
        implicit none

        real(wp), intent(in) :: radius
        real(wp), intent(out) :: area, circumference

        area = pi*radius*radius
        circumference = 2._wp*pi*radius
    end subroutine
end module


subroutine falsapos(a,b,ET,x)

  implicit none
!!!!!!!!!!!!!!!!!
  !              AUTOR: BYRON J. ENCINAS
  !
  !                    PROPÓSITO:
  !      APROXIMAR RAÍCES REALES PARA FUNCIONES
  !      MEDIANTE MÉTODOS DE FALSA POSICIÓN
  !
!!!!!!!!!!!!!!!!!!

  integer,parameter::q=selected_real_kind(32,600)
  real,external:: F
  real,intent(INOUT)::a,b,ET,x
  real(kind=q)::G,ET2
  integer::i,k,j

  G = F(b)*F(a)	!!! Variable G nos comunica si hay cambio de signo en el primer intervalo

IF(G==0 .OR. G>0)THEN		!!!verificación
WRITE(*,*)'No hay cambio de signo'
STOP

ELSE
WRITE(*,*)'     X_n         F(X_n)           a_n           b_n'

Do

x = a - (F(a)*(b-a))/(F(b)-F(a))

PRINT*, x, F(x),a,b

ET2 = abs((x-a)*100/x)

IF(ET2 < ET)EXIT

!!=================================================================

	IF(F(x) /= 0)THEN

		IF(F(x)*F(a)<0)then
		!Si F(x)*F(a_n) <0 entonces hay cambio de signo
		!h<d por lo tanto daremos el nuevo valor de x a d (el
			b = x !! I=[a,x]

		ELSE IF(F(x)*F(b)<0)then
		a = x  !!I=[x,b]
		END IF

	ELSE
	PRINT*,"EUREKA TU SOLUCIÓN ES", x
STOP
	!============================
	END IF

END DO
END IF
END SUBROUTINE


subroutine MakeGridGLQC(gridglq, cilm, lmax, plx, zero, norm, csphase, &
                        lmax_calc, extend, exitstatus)
!------------------------------------------------------------------------------
!
!   Given the complex spherical harmonic coefficients CILM of a function, this
!   subroutine will evalate the function on a grid with equal spacing in
!   longitude and with latitude points appropriate for Gauss-Legendre
!   quadrature integrations. Note that this is done using FFTs for each degree
!   of each latitude band. The grid spacing is determined by the spherical
!   harmonic bandwidth LMAX, but the coefficients can be evaluated up to a
!   smaller spherical harmonic degree by specifying the optional parameter
!   LMAX_CALC.
!
!   The optional array PLX contains precomputed associated legendre functions
!   evaluated on the Gauss-Legendre quadrature nodes (obtained from SHGLQ with
!   CNORM = 1) and should not be precomputed when memory is an issue (i.e.,
!   lmax>360). If PLX is not present, the Legendre functions are computed on
!   the fly using the scaling methodolgy presented in Holmes and Featherston
!   (2002). When NORM = 1, 2 or 4, these are accurate to degree 2800. When
!   NORM = 3, the routine is only stable to about degree 15.
!
!   Calling Parameters
!
!       IN
!           cilm        Input spherical harmonic coefficients with
!                       dimensions (2, LMAX+1, LMAX+1).
!           lmax        Maximum spherical harmonic degree used in the
!                       expansion. This value determines the grid spacing of
!                       the output function.
!
!       OUT
!           gridglq     Gridded data of the spherical harmonic coefficients
!                       CILM with dimensions (LMAX+1 , 2*LMAX+1) when
!                       EXTEND=0 or (LMAX+1 , 2*LMAX+2) when EXTEND=1. The
!                       first index (latitude) corresponds to the Gauss points,
!                       and the second index corresponds to
!                       360*(k-1)/(2*LMAX +1).
!
!       OPTIONAL (IN)
!           plx         Input array of Associated Legendre Polnomials computed
!                       at the Gauss points (determined from a call to
!                       SHGLQ). If this is not included, then the optional
!                       array ZERO MUST be inlcuded. PLX must be computed using
!                       CNORM=1.
!           zero        Array of dimension lmax+1 that contains the latitudinal
!                       gridpoints used in the Gauss-Legendre quadrature
!                       integration scheme. Only needed if PLX is not included.
!           norm        Normalization to be used when calculating Legendre
!                       functions
!                           (1) "geodesy" (default)
!                           (2) Schmidt
!                           (3) unnormalized
!                           (4) orthonormalized
!           csphase 1   Do not include the phase factor of (-1)^m (default).
!                       -1: Apply the phase factor of (-1)^m.
!           lmax_calc   The maximum spherical harmonic degree to evaluate the
!                       coefficients up to.
!           extend      If 1, return a grid that contains an additional column
!                       corresponding to 360 E longitude. The dimension of the
!                       output grid is (LMAX+1 , 2*LMAX+2) when EXTEND is 1,
!                       and (LMAX+1 , 2*LMAX+1) when EXTEND is 0.

!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!       1.  If lmax is greater than the the maximum spherical harmonic
!           degree of the input coefficients, then the coefficients will be
!           zero padded.
!       2.  Latitude is geocentric latitude.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use FFTW3
    use ftypes
    use, intrinsic :: iso_c_binding

    implicit none

    complex(dp), intent(in) :: cilm(:,:,:)
    real(dp), intent(in), optional :: plx(:,:), zero(:)
    complex(dp), intent(out) :: gridglq(:,:)
    integer(int32), intent(in) :: lmax
    integer(int32), intent(in), optional :: norm, csphase, lmax_calc, extend
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: l, m, i, nlat, nlong, l1, m1, lmax_comp, i_s, astat(4), &
                      lnorm, k, nlong_out, phase, extend_grid
    real(dp) :: pi, scalef, rescalem, u, p, pmm, pm1, pm2, z
    complex(dp) :: coef(2*lmax+1), coefs(2*lmax+1), grid(2*lmax+1), &
                   grids(2*lmax+1)
    type(C_PTR) :: plan, plans
    real(dp), save, allocatable :: ff1(:,:), ff2(:,:), sqr(:)
    integer(int8), save, allocatable :: fsymsign(:,:)
    integer(int32), save :: lmax_old = 0, norm_old = 0

!$OMP   threadprivate(ff1, ff2, sqr, fsymsign, lmax_old, norm_old)

    if (present(exitstatus)) exitstatus = 0

    nlong = 2 * lmax + 1
    nlat = lmax + 1

    if (present(extend)) then
        if (extend == 0) then
            extend_grid = 0
            nlong_out = nlong
        else if (extend == 1) then
            extend_grid = 1
            nlong_out = nlong + 1
        else
            print*, "Error --- MakeGridGLQC"
            print*, "Optional parameter EXTEND must be 0 or 1."
            print*, "Input value is ", extend
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if
        end if
    else
        extend_grid = 0
        nlong_out = nlong
    end if

    if (size(cilm(:,1,1)) < 2) then
        print*, "Error --- MakeGridGLQC"
        print*, "CILM must be dimensioned as (2, *, *)."
        print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), &
                size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (size(gridglq(1,:)) < nlong_out .or. size(gridglq(:,1)) < nlat) then
        print*, "Error --- MakeGridGLQC"
        print*, "GRIDGLQ must be dimensioned as ", nlat, nlong_out
        print*, "Input array is dimensioned ", size(gridglq(:,1)), &
                                               size(gridglq(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (present(plx)) then
        if (size(plx(:,1)) < lmax+1 .or. &
                size(plx(1,:)) < ((lmax+1)*(lmax+2))/2) then
            print*, "Error --- MakeGridGLQC"
            print*, "PLX must be dimensioned as (LMAX+1, " // &
                    "(LMAX+1)*(LMAX+2)/2) where LMAX is ", lmax
            print*, "Input array is dimensioned as ", size(plx(:,1)), &
                    size(plx(1,:))
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    else if (present(zero)) then
        if (size(zero) < lmax+1) then
            print*, "Error --- MakeGridGLQC"
            print*, "ZERO must be dimensioned as (LMAX+1) where LMAX is ", lmax
            print*, "Input array is dimensioned ", size(zero)
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if
        end if

    else
        print*, "Error --- MakeGridGLQC"
        print*, "Either PLX or ZERO must be specified."
        if (present(exitstatus)) then
            exitstatus = 5
            return
        else
            stop
        end if

    end if

    if (present(norm)) then
        if (norm > 4 .or. norm < 1) then
            print*, "Error - MakeGridGLQC"
            print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), " // &
                    "3 (unnormalized), or 4 (orthonormalized)."
            print*, "Input value is ", norm
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if
        end if

        lnorm = norm

    else
        lnorm = 1

    end if

    if (present(csphase)) then
        if (csphase /= -1 .and. csphase /= 1) then
            print*, "Error --- MakeGridGLQC"
            print*, "CSPHASE must be 1 (exclude) or -1 (include)."
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            phase = csphase

        end if

    else
        phase = 1

    end if

    pi = acos(-1.0_dp)

    scalef = 1.0e-280_dp

    if (present(lmax_calc)) then
        if (lmax_calc > lmax) then
            print*, "Error --- MakeGridGLQC"
            print*, "LMAX_CALC must be less than or equal to LMAX."
            print*, "LMAX = ", lmax
            print*, "LMAX_CALC = ", lmax_calc
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1, &
                            lmax_calc)
        end if

    else
        lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1)
    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate recursion constants used in computing the Legendre functions.
    !
    !--------------------------------------------------------------------------
    if ((lmax_comp /= lmax_old .or. lnorm /= norm_old) .and. &
            .not. present(plx)) then

        if (allocated (sqr)) deallocate (sqr)
        if (allocated (ff1)) deallocate (ff1)
        if (allocated (ff2)) deallocate (ff2)
        if (allocated (fsymsign)) deallocate (fsymsign)

        allocate (sqr(2*lmax_comp+1), stat=astat(1))
        allocate (ff1(lmax_comp+1,lmax_comp+1), stat=astat(2))
        allocate (ff2(lmax_comp+1,lmax_comp+1), stat=astat(3))
        allocate (fsymsign(lmax_comp+1,lmax_comp+1), stat=astat(4))

        if (sum(astat(1:4)) /= 0) then
            print*, "Error ---MakeGridGLQC"
            print*, "Problem allocating arrays SQR, FF1, FF2, or FSYMSIGN", &
                    astat(1), astat(2), astat(3), astat(4)
            if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if
        end if

        !----------------------------------------------------------------------
        !
        !   Calculate signs used for symmetry of Legendre functions about
        !   equator.
        !
        !----------------------------------------------------------------------
        do l = 0, lmax_comp, 1
            do m = 0, l, 1
                if (mod(l-m,2) == 0) then
                    fsymsign(l+1,m+1) = 1

                else
                    fsymsign(l+1,m+1) = -1

                end if

            end do

        end do

        !----------------------------------------------------------------------
        !
        !   Precompute square roots of integers that are used several times.
        !
        !----------------------------------------------------------------------
        do l = 1, 2 * lmax_comp + 1
            sqr(l) = sqrt(dble(l))
        end do

        !----------------------------------------------------------------------
        !
        !   Precompute multiplicative factors used in recursion relationships
        !       P(l,m) = x*f1(l,m)*P(l-1,m) - P(l-2,m)*f2(l,m)
        !       k = l*(l+1)/2 + m + 1
        !   Note that prefactors are not used for the case when m=l as a
        !   different recursion is used. Furthermore, for m=l-1, Plmbar(l-2,m)
        !   is assumed to be zero.
        !
        !----------------------------------------------------------------------
        select case (lnorm)
            case (1, 4)
                if (lmax_comp /= 0) then
                    ff1(2,1) = sqr(3)
                    ff2(2,1) = 0.0_dp
                end if

                do l = 2, lmax_comp, 1
                    ff1(l+1,1) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
                    ff2(l+1,1) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)

                    do m = 1, l-2, 1
                        ff1(l+1,m+1) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) &
                                       / sqr(l-m)
                        ff2(l+1,m+1) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                                       / sqr(2*l-3) / sqr(l+m) / sqr(l-m)
                    end do

                    ff1(l+1,l) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                    ff2(l+1,l) = 0.0_dp

                end do

            case (2)
                if (lmax_comp /= 0) then
                    ff1(2,1) = 1.0_dp
                    ff2(2,1) = 0.0_dp
                end if

                do l = 2, lmax_comp, 1
                    ff1(l+1,1) = dble(2*l-1) / dble(l)
                    ff2(l+1,1) = dble(l-1) / dble(l)

                    do m = 1, l-2, 1
                        ff1(l+1,m+1) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                        ff2(l+1,m+1) = sqr(l-m-1) * sqr(l+m-1) / sqr(l+m) &
                                       / sqr(l-m)
                    end do

                    ff1(l+1,l)= dble(2*l-1) / sqr(l+m) / sqr(l-m)
                    ff2(l+1,l) = 0.0_dp

                end do

            case (3)
                do l = 1, lmax_comp, 1
                    ff1(l+1,1) = dble(2*l-1) / dble(l)
                    ff2(l+1,1) = dble(l-1) / dble(l)

                    do m = 1, l-1, 1
                        ff1(l+1,m+1) = dble(2*l-1) / dble(l-m)
                        ff2(l+1,m+1) = dble(l+m-1) / dble(l-m)
                    end do

                end do

        end select

        lmax_old = lmax_comp
        norm_old = lnorm

    end if

    !--------------------------------------------------------------------------
    !
    !   Do special case of lmax_comp = 0
    !
    !--------------------------------------------------------------------------
    if (lmax_comp == 0) then
        select case (lnorm)
            case (1, 2, 3); pm2 = 1.0_dp
            case (4); pm2 = 1.0_dp / sqrt(4.0_dp * pi)
        end select

        gridglq(1:nlat, 1:nlong_out) = cilm(1,1,1) * pm2

        return

    end if

    !--------------------------------------------------------------------------
    !
    !   Create generic plan for grid and grids.
    !
    !--------------------------------------------------------------------------
    plan = fftw_plan_dft_1d(nlong, coef(1:nlong), grid(1:nlong), &
                            FFTW_BACKWARD, FFTW_MEASURE)
    plans = fftw_plan_dft_1d(nlong, coefs(1:nlong), grids(1:nlong), &
                             FFTW_BACKWARD, FFTW_MEASURE)

    !--------------------------------------------------------------------------
    !
    !   Determine Cilms, one l at a time I by integrating over all
    !   latitudes using Gauss-Legendre Quadrature. When PLX is not
    !   present, the Legendre functions are computed on the fly
    !   during the summations over l and m. These are scaled using
    !   the methodology of Holmesand Featherstone (2002), with the
    !   exception of the m=0 terms that do not need to be scaled
    !
    !--------------------------------------------------------------------------
    if (present(plx)) then
        do i = 1, nlat
            coef = cmplx(0.0_dp, 0.0_dp, dp)
            ! This summation order is intended to add the smallest terms first

            do l = lmax_comp, 0, -1
                l1 = l + 1
                k = (l1 * l) / 2 + 1   ! m=0
                coef(1) = coef(1) + cilm(1,l1,1) * plx(i,k)

                do m = 1, l, 1
                    m1 = m + 1
                    k = (l1 * l) / 2 + m1
                    coef(m1) = coef(m1) + cilm(1,l1,m1) * plx(i,k)
                    coef(nlong-(m-1)) = coef(nlong-(m-1)) + &
                                        cilm(2,l1,m1) * plx(i,k) * &
                                        ((-1)**mod(m,2))
                end do

            end do

            call fftw_execute_dft(plan, coef, grid)
            gridglq(i,1:nlong) = grid(1:nlong)

        end do

    else
        do i = 1, (nlat+1) / 2
            coef = cmplx(0.0_dp, 0.0_dp, dp)

            if (i == (nlat+1)/2 .and. mod(nlat,2) /= 0) then
                ! This latitude is the equator; z=0, u=1
                u = 1.0_dp

                select case (lnorm)
                    case (1, 2, 3); pm2 = 1.0_dp
                    case (4); pm2 = 1.0_dp / sqrt(4.0_dp * pi)
                end select

                coef(1) = coef(1) + cilm(1,1,1) * pm2

                do l = 2, lmax_comp, 2
                    l1 = l + 1
                    p = - ff2(l1,1) * pm2
                    pm2 = p
                    coef(1) = coef(1) + cilm(1,l1,1) * p
                end do

                select case (lnorm)
                    case (1, 2, 3); pmm = scalef
                    case (4); pmm = scalef / sqrt(4.0_dp * pi)
                end select

                rescalem = 1.0_dp / scalef

                do m = 1, lmax_comp-1, 1
                    m1 = m + 1

                    select case (lnorm)
                        case (1, 4)
                            pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                            pm2 = pmm
                        case (2)
                            pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                            pm2 = pmm / sqr(2*m+1)
                        case (3)
                            pmm = phase * pmm * dble(2*m-1)
                            pm2 = pmm
                    end select

                    coef(m1) = coef(m1) + cilm(1,m1,m1) * pm2
                    coef(nlong-(m-1)) = coef(nlong-(m-1)) + cilm(2,m1,m1) * pm2

                    do l = m + 2, lmax_comp, 2
                        l1 = l + 1
                        p = - ff2(l1,m1) * pm2
                        coef(m1) = coef(m1) + cilm(1,l1,m1) * p
                        coef(nlong-(m-1)) = coef(nlong-(m-1)) &
                                            + cilm(2,l1,m1) * p
                        pm2 = p
                    end do

                    coef(m1) = coef(m1) * rescalem
                    coef(nlong-(m-1)) = coef(nlong-(m-1)) * rescalem &
                                        * ((-1)**mod(m,2))

                end do

                select case (lnorm)
                    case (1, 4)
                        pmm = phase * pmm * sqr(2*lmax_comp+1) &
                              / sqr(2*lmax_comp) * rescalem
                    case (2)
                        pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
                    case (3)
                        pmm = phase * pmm * (2*lmax_comp-1) * rescalem
                end select

                coef(lmax_comp+1) = coef(lmax_comp+1) &
                                    + cilm(1,lmax_comp+1,lmax_comp+1) * pmm
                coef(nlong-(lmax_comp-1)) = coef(nlong-(lmax_comp-1)) + &
                                            cilm(2,lmax_comp+1,lmax_comp+1) * &
                                            pmm * ((-1)**mod(lmax_comp,2))

                call fftw_execute_dft(plan, coef, grid)
                gridglq(i,1:nlong) = grid(1:nlong)

            else
                z = zero(i)
                u = sqrt( (1.0_dp-z) * (1.0_dp+z) )

                i_s = nlat + 1 - i

                coefs = cmplx(0.0_dp, 0.0_dp, dp)

                select case (lnorm)
                    case (1, 2, 3); pm2 = 1.0_dp
                    case (4); pm2 = 1.0_dp / sqrt(4.0_dp * pi)
                end select

                coef(1) = coef(1) + cilm(1,1,1) * pm2
                coefs(1) = coefs(1) + cilm(1,1,1) * pm2
                ! fsymsign is always 1 for l=m=0

                pm1 = ff1(2,1) * z * pm2
                coef(1) = coef(1) + cilm(1,2,1) * pm1
                coefs(1) = coefs(1) - cilm(1,2,1) * pm1 ! fsymsign = -1

                do l = 2, lmax_comp, 1
                    l1 = l + 1
                    p = ff1(l1,1) * z * pm1 - ff2(l1,1) * pm2
                    coef(1) = coef(1) + cilm(1,l1,1) * p
                    coefs(1) = coefs(1) + cilm(1,l1,1) * p * fsymsign(l1,1)
                    pm2 = pm1
                    pm1 = p
                end do

                select case (lnorm)
                    case (1, 2, 3); pmm = scalef
                    case (4); pmm = scalef / sqrt(4.0_dp * pi)
                end select

                rescalem = 1.0_dp / scalef

                do m = 1, lmax_comp-1, 1
                    m1 = m + 1
                    rescalem = rescalem * u

                    select case (lnorm)
                        case (1, 4)
                            pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                            pm2 = pmm
                        case (2)
                            pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
                            pm2 = pmm / sqr(2*m+1)
                        case (3)
                            pmm = phase * pmm * dble(2*m-1)
                            pm2 = pmm
                    end select

                    coef(m1) = coef(m1) + cilm(1,m1,m1) * pm2
                    coef(nlong-(m-1)) = coef(nlong-(m-1)) &
                                        + cilm(2,m1,m1) * pm2
                    coefs(m1) = coefs(m1) + cilm(1,m1,m1) * pm2
                    coefs(nlong-(m-1)) = coefs(nlong-(m-1)) &
                                         + cilm(2,m1,m1) * pm2
                    ! fsymsign = 1

                    pm1 = z * ff1(m1+1,m1) * pm2

                    coef(m1) = coef(m1) + cilm(1,m1+1,m1) * pm1
                    coef(nlong-(m-1)) = coef(nlong-(m-1)) &
                                        + cilm(2,m1+1,m1) * pm1
                    coefs(m1) = coefs(m1) - cilm(1,m1+1,m1) * pm1
                    coefs(nlong-(m-1)) = coefs(nlong-(m-1)) &
                                        - cilm(2,m1+1,m1) * pm1
                    ! fsymsign = -1

                    do l = m + 2, lmax_comp, 1
                        l1 = l + 1
                        p = z * ff1(l1,m1) * pm1 - ff2(l1,m1) * pm2
                        pm2 = pm1
                        pm1 = p
                        coef(m1) = coef(m1) + cilm(1,l1,m1) * p
                        coef(nlong-(m-1)) = coef(nlong-(m-1)) &
                                            + cilm(2,l1,m1) * p
                        coefs(m1) = coefs(m1) + cilm(1,l1,m1) &
                                    * p * fsymsign(l1,m1)
                        coefs(nlong-(m-1)) = coefs(nlong-(m-1)) &
                                             + cilm(2,l1,m1) * p * &
                                             fsymsign(l1,m1)
                    end do

                    coef(m1) = coef(m1) * rescalem
                    coef(nlong-(m-1)) = coef(nlong-(m-1)) * rescalem &
                                        * ((-1)**mod(m,2))
                    coefs(m1) = coefs(m1) * rescalem
                    coefs(nlong-(m-1)) = coefs(nlong-(m-1)) * rescalem &
                                         * ((-1)**mod(m,2))

                end do

                rescalem = rescalem * u

                select case (lnorm)
                    case (1, 4)
                        pmm = phase * pmm * sqr(2*lmax_comp+1) &
                              / sqr(2*lmax_comp) * rescalem
                    case (2)
                        pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
                    case (3)
                        pmm = phase * pmm * dble(2*lmax_comp-1) * rescalem
                end select

                coef(lmax_comp+1) = coef(lmax_comp+1) &
                                    + cilm(1,lmax_comp+1,lmax_comp+1) * pmm
                coef(nlong-(lmax_comp-1)) = coef(nlong-(lmax_comp-1)) &
                                            + cilm(2,lmax_comp+1,lmax_comp+1) &
                                            * pmm * ((-1)**mod(lmax_comp,2))
                coefs(lmax_comp+1) = coefs(lmax_comp+1) &
                                     + cilm(1,lmax_comp+1,lmax_comp+1) * pmm
                coefs(nlong-(lmax_comp-1)) = coefs(nlong-(lmax_comp-1)) &
                                             + cilm(2,lmax_comp+1,lmax_comp+1) &
                                             * pmm * ((-1)**mod(lmax_comp,2))
                ! fsymsign = 1

                call fftw_execute_dft(plan, coef, grid)
                gridglq(i,1:nlong) = grid(1:nlong)

                call fftw_execute_dft(plans, coefs, grids)
                gridglq(i_s,1:nlong) = grids(1:nlong)

            end if

        end do

    end if

    if (extend_grid == 1) then
        gridglq(1:nlat, nlong_out) = gridglq(1:nlat, 1)
    end if

    call fftw_destroy_plan(plan)
    call fftw_destroy_plan(plans)

end subroutine MakeGridGLQC


program testBoxAndCapsule
  use, intrinsic :: iso_fortran_env, only : stdin=>input_unit, &
       stdout=>output_unit, &
       stderr=>error_unit
  use geom_distances
  use geom_types
  use test_utils
  implicit none

  type(Box_t) :: box
  ! type(Line_t) :: line
  type(Segment_t) :: segment

  real(dp) :: d2

  call test_group('Line and Box')
  !----------------------------------------
  ! Lines parallel to edge
  !----------------------------------------
  call test_group('// Box face & Box edge')
  call reset(box, segment)
  segment%start = (/1, -1, 0/)
  segment%end = (/1, 1, 0/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Passing through edge")

  call reset(box, segment)
  segment%start = (/2, -10, 0/)
  segment%end = (/2, 10, 0/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 1._dp, 1d-14), "Parallel to edge, above face")

  call reset(box, segment)
  segment%start = (/2, 1, -10/)
  segment%end = (/2, 1, 10/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 1._dp, 1d-14), "Parallel to other edge, above face")

  call reset(box, segment)
  segment%start = (/2, 2, -10/)
  segment%end = (/2, 2, 10/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 2._dp, 1d-14), "Parallel to edge")

  call reset(box, segment)
  segment%start = (/-10, 2, 2/)
  segment%end = (/10, 2, 2/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 2._dp, 1d-14), "Line along segment")

  call reset(box, segment)
  segment%start = (/-1, 0, 0/) / 2._dp
  segment%end = (/1, 0, 0/) / 2._dp
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Within box")

  call test_group_close()

  !----------------------------------------
  ! Lines parallel to face only
  !----------------------------------------
  call test_group('// Box face only')
  call reset(box, segment)
  segment%start = (/1, 1, -10/)
  segment%end = (/1, 2, 10/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Passing through node")

  call reset(box, segment)
  segment%start = (/0, -1, -10/)
  segment%end = (/0, 1, 10/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Passing through face")

  call reset(box, segment)
  segment%start = (/1, 0, 0/)
  segment%end = (/10, 0, 0/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Touching face")

  call reset(box, segment)
  segment%start = (/2, 0, 0/)
  segment%end = (/10, 0, 0/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 1._dp, 1d-14), "Pointing out")

  call reset(box, segment)
  segment%start = (/0, 0, 0/)
  segment%end = (/10, 0, 0/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Crossing face")

  call reset(box, segment)
  segment%start = (/-1, 0, 0/) / 2._dp
  segment%end = (/1, 1, 0/) / 2._dp
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Within box")

  call test_group_close()

  !----------------------------------------
  ! Point like segments
  !----------------------------------------
  call test_group('Point-like')
  call reset(box, segment)
  segment%start = (/1, 0, 0/)
  segment%end = (/1, 0, 0/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "On face")

  call reset(box, segment)
  segment%start = (/2, 1, 0/) / 2._dp
  segment%end = (/2, 1, 0/) / 2._dp
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "On edge")

  call reset(box, segment)
  segment%start = (/1, 1, 1/)
  segment%end = (/1, 1, 1/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "On node")

  call reset(box, segment)
  segment%start = (/0, 0, 0/)
  segment%end = (/0, 0, 0/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Within box")

  call reset(box, segment)
  segment%start = (/2, 0, 0/)
  segment%end = (/2, 0, 0/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 1._dp, 1d-14), "Outside box (x direction)")

  call reset(box, segment)
  segment%start = (/0, 2, 0/)
  segment%end = (/0, 2, 0/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 1._dp, 1d-14), "Outside box (y direction)")

  call reset(box, segment)
  segment%start = (/0, 0, 2/)
  segment%end = (/0, 0, 2/)
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 1._dp, 1d-14), "Outside box (z direction)")

  call test_group_close()

  !----------------------------------------
  ! Any line
  !----------------------------------------
  call test_group('Any segment')
  call reset(box, segment)
  segment%start = (/-1, -2, -3/) / 3._dp
  segment%end = (/1, 4, 8/) / 8._dp
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Inside box")

  call reset(box, segment)
  segment%start = (/-1, -2, -3/) / 3._dp
  segment%end = (/1, 4, 8/) / 6._dp
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0._dp, 1d-14), "Trough box")

  call reset(box, segment)
  segment%start = (/0, 0, 11/) / 10._dp
  segment%end = (/1, 2, 20/) / 10._dp
  call LineSegmentBoxDistanceSquared(box, segment, d2)
  call assert(is_close(d2, 0.01_dp, 1d-14), "Outside box")

  call test_group_close()

  call test_group_close()
contains

  subroutine reset(box, segment)
    type(Box_t), intent(inout) :: box
    type(Segment_t), intent(inout) :: segment
    box%origin = (/0, 0, 0/)
    box%u = (/1, 0, 0/)
    box%v = (/0, 1, 0/)
    box%w = (/0, 0, 1/)
    box%extents = (/1, 1, 1/)

    segment%start = (/0, 0, 0/)
    segment%end = (/0, 0, 0/)
  end subroutine reset

  subroutine print_details
    print*, 'Box:'
    print*, '----'
    print*, box%origin
    print*, box%u
    print*, box%v
    print*, box%w
    print*, ''
    print*, 'Segment:'
    print*, '--------'
    print*, segment%start
    print*, segment%end
    print*, ''
    print*, 'Intersection'
    print*, '------------'
    print*, 'd=', sqrt(d2)
  end subroutine print_details

end program testBoxAndCapsule


SUBROUTINE lpmns(m,n,x,pm,pd)

!**************************************************************

!       ========================================================
!       Purpose: Compute associated Legendre functions Pmn(x)
!                and Pmn'(x) for a given order
!       Input :  x --- Argument of Pmn(x)
!                m --- Order of Pmn(x),  m = 0,1,2,...,n
!                n --- Degree of Pmn(x), n = 0,1,2,...,N
!       Output:  PM(n) --- Pmn(x)
!                PD(n) --- Pmn'(x)
!       ========================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: pm(0:n)
DOUBLE PRECISION, INTENT(OUT)            :: pd(0:n)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

DO  k=0,n
  pm(k)=0.0D0
  pd(k)=0.0D0
END DO
IF (DABS(x) == 1.0D0) THEN
  DO  k=0,n
    IF (m == 0) THEN
      pm(k)=1.0D0
      pd(k)=0.5D0*k*(k+1.0)
      IF (x < 0.0) THEN
        pm(k)=(-1)**k*pm(k)
        pd(k)=(-1)**(k+1)*pd(k)
      END IF
    ELSE IF (m == 1) THEN
      pd(k)=1.0D+300
    ELSE IF (m == 2) THEN
      pd(k)=-0.25D0*(k+2.0)*(k+1.0)*k*(k-1.0)
      IF (x < 0.0) pd(k)=(-1)**(k+1)*pd(k)
    END IF
  END DO
  RETURN
END IF
x0=DABS(1.0D0-x*x)
pm0=1.0D0
pmk=pm0
DO  k=1,m
  pmk=(2.0D0*k-1.0D0)*DSQRT(x0)*pm0
  pm0=pmk
END DO
pm1=(2.0D0*m+1.0D0)*x*pm0
pm(m)=pmk
pm(m+1)=pm1
DO  k=m+2,n
  pm2=((2.0D0*k-1.0D0)*x*pm1-(k+m-1.0D0)*pmk)/(k-m)
  pm(k)=pm2
  pmk=pm1
  pm1=pm2
END DO
pd(0)=((1.0D0-m)*pm(1)-x*pm(0))/(x*x-1.0)
DO  k=1,n
  pd(k)=(k*x*pm(k)-(k+m)*pm(k-1))/(x*x-1.0D0)
END DO
RETURN
END SUBROUTINE lpmns