module SphereGeomModule
!------------------------------------------------------------------------------
! Lagrangian Particle / Panel Method - Spherical Model
!------------------------------------------------------------------------------
!
!> @author
!> Peter Bosler, Department of Mathematics, University of Michigan
!
!> @defgroup SphereGeom Spherical Geometry
!> defines functions for performing geometric calculations on the surface of a sphere.
!
!
! DESCRIPTION:
!> @file
!> defines functions for performing geometric calculations on the surface of a sphere.
!
!------------------------------------------------------------------------------

use NumberKindsModule

implicit none

public

interface SphereTriArea
	module procedure SphereTriAreaVector
	module procedure SphereTriAreaComponents
end interface

interface SphereDistance
	module procedure SphereDistanceVector
	module procedure SphereDistanceComponents
end interface

interface SphereArcLength
	module procedure SphereArcLengthVector
	module procedure SphereArcLengthComponents
end interface

interface Latitude
	module procedure LatitudeVector
	module procedure LatitudeComponents
end interface

interface Longitude
	module procedure LongitudeVector
	module procedure LongitudeComponents
	module procedure LongitudeComponents2
end interface

contains

!----------------
! Basic geometry : length, area, coordinates, etc.
!----------------

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Euclidean distance between two points on the sphere
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3); vector on the sphere
!> @param[in] xyzB double precision real size(3); vector on the sphere
!> @return Distance double precision real, straight-line distance between xyzA and xyzB
function ChordDistance(xyzA, xyzB)
	! Outputs the Euclidean distance between two points in R3.
	! Units of length
	real(kreal), intent(in) :: xyzA(3), xyzB(3)
	real(kreal) :: ChordDistance
	ChordDistance = sqrt( sum( (xyzB - xyzA)*(xyzB-xyzA) ) )
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Great-circle distance between two points in the plane
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3); vector on the sphere
!> @param[in] xyzB double precision real size(3); vector on the sphere
!> @return Distance double precision real, great-circle distance between xyzA and xyzB
!------------------------------------------------------------------------------
function SphereDistanceVector( xyzA, xyzB )
! Finds the great circle distance between two points (xyzA and xyzB) on the sphere
! Units of length
	! Calling parameters
	real(KREAL), dimension(3), intent(in) :: xyzA, xyzB
	real(KREAL) :: SphereDistanceVector
	! Local variables
	real(KREAL), dimension(3) :: crossProd
	real(KREAL) :: dotProd , crossNorm

	crossProd = [xyzA(2)*xyzB(3)-xyzB(2)*xyzA(3),xyzB(1)*xyzA(3)-xyzA(1)*xyzB(3),&
    xyzA(1)*xyzB(2)-xyzB(1)*xyzA(2) ]

    crossNorm = sqrt(sum(crossProd*crossProd))

    dotProd = xyzA(1)*xyzB(1)+xyzA(2)*xyzB(2)+xyzA(3)*xyzB(3)

    SphereDistanceVector = atan2(crossNorm,dotProd)*EARTH_RADIUS
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Great-circle distance between two points in the plane
!
!> @ingroup SphereGeom
!
!> @param[in] xA double precision real
!> @param[in] yA double precision real
!> @param[in] zA
!> @param[in] xB
!> @param[in] yB
!> @param[in] zB
!> @return Distance double precision real, great-circle distance between xyzA and xyzB
!------------------------------------------------------------------------------
function SphereDistanceComponents(xA, yA, zA, xB, yB, zB)
! Finds the great circle distance between two points (xyzA and xyzB) on the sphere
! Units of length
	real(kreal), intent(in) :: xA, yA, zA
	real(kreal), intent(in) :: xB, yB, zB
	real(kreal) :: SphereDistanceComponents
	real(kreal) :: cp1, cp2, cp3, cpNorm, dp

	cp1 = yA*zB - yB*zA
	cp2 = xB*zA - xA*zB
	cp3 = xA*yB - xB*yA

	cpNorm = sqrt( cp1*cp1 + cp2*cp2 + cp3*cp3)

	dp = xA*xB + yA*yB + zA*zB

	SphereDistanceComponents = atan2(cpNorm,dp)*EARTH_RADIUS
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief central angle between two points in the plane
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3); vector on the sphere
!> @param[in] xyzB double precision real size(3); vector on the sphere
!> @return Distance double precision real, angular separation between xyzA and xyzB
!------------------------------------------------------------------------------
function SphereArcLengthVector(xyzA, xyzB)
! returns the arc length between two vectors on the surface of a sphere.
! dimensionless (angle)
	! Calling parameters
	real(KREAL), dimension(3), intent(in) :: xyzA, xyzB
	real(KREAL) :: SphereArcLengthVector
	! Local variables
	real(KREAL), dimension(3) :: crossProd
	real(KREAL) :: dotProd , crossNorm

	crossProd = [xyzA(2)*xyzB(3)-xyzB(2)*xyzA(3),xyzB(1)*xyzA(3)-xyzA(1)*xyzB(3),&
    xyzA(1)*xyzB(2)-xyzB(1)*xyzA(2) ]

    crossNorm = sqrt(sum(crossProd*crossProd))

    dotProd = xyzA(1)*xyzB(1)+xyzA(2)*xyzB(2)+xyzA(3)*xyzB(3)

    SphereArcLengthVector = atan2(crossNorm,dotProd)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief central angle between two points in the plane
!
!> @ingroup SphereGeom
!
!> @param[in] xA double precision real
!> @param[in] yA double precision real
!> @param[in] zA
!> @param[in] xB
!> @param[in] yB
!> @param[in] zB
!> @return Distance double precision real, angular separation between xyzA and xyzB
!------------------------------------------------------------------------------
function SphereArcLengthComponents(xA, yA, zA, xB, yB, zB)
! dimensionless (angle)
	real(kreal), intent(in) :: xA, yA, zA
	real(kreal), intent(in) :: xB, yB, zB
	real(kreal) :: SphereArcLengthComponents
	real(kreal) :: cp1, cp2, cp3, cpNorm, dp

	cp1 = yA*zB - yB*zA
	cp2 = xB*zA - xA*zB
	cp3 = xA*yB - xB*yA

	cpNorm = sqrt( cp1*cp1 + cp2*cp2 + cp3*cp3)

	dp = xA*xB + yA*yB + zA*zB

	SphereArcLengthComponents = atan2(cpNorm,dp)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief central angle between two points in the plane
!
!> @ingroup SphereGeom
!
!> @param[in] xyz double precision real size(3); vector on the sphere
!> @return northward-pointing unit vector at position xyz
!------------------------------------------------------------------------------
function LatUnitVector(xyz)
!	Returns the latitudinal unit vector at the point xyz
	real(kreal) :: LatUnitVector(3)
	real(kreal), intent(in) :: xyz(3)

	if ( xyz(3) == 0.0_kreal) then
		LatUnitVector = [0.0_kreal,0.0_kreal,0.0_kreal]
	else
		LatUnitVector(1) = -xyz(1)*xyz(3)
		LatUnitVector(2) = -xyz(2)*xyz(3)
		LatUnitVector(3) = 1.0_kreal - xyz(3)*xyz(3)

		LatUnitVector = LatUnitVector / sqrt(LatUnitVector(3))
	endif
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief central angle between two points in the plane
!
!> @ingroup SphereGeom
!
!> @param[in] xyz double precision real size(3); vector on the sphere
!> @return eastward-pointing unit vector at position xyz
!-----------------------------------------------------------------------------
function LonUnitVector(xyz)
!	Returns the Longitudinal unit vector at the point xyz
	real(kreal) :: LonUnitVector(3)
	real(kreal), intent(in) :: xyz(3)

	if ( xyz(3) == 0.0_kreal) then
		LonUnitVector = [0.0_kreal,0.0_kreal,0.0_kreal]
	else
		LonUnitVector(1) = -xyz(2)
		LonUnitVector(2) = -xyz(1)
		LonUnitVector(3) = 0.0_kreal

		LonUnitVector = LonUnitVector / sqrt( 1.0_kreal - xyz(3)*xyz(3))
	endif
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief midpoint of a great-circle segment connecting two points on the sphere
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3); vector on the sphere
!> @param[in] xyzB double precision real size(3); vector on the sphere
!> @return Midpoint vector
!------------------------------------------------------------------------------
function SphereMidpoint(xyzA, xyzB)
! Finds the midpoint of two points on the sphere by finding the midpoint of the chord
! connecting the two points, then projecting the chord midpoint to the sphere.
	! Calling parameters
	real(KREAL), dimension(3), intent(in) :: xyzA, xyzB
	real(KREAL), dimension(3) :: SphereMidpoint

	SphereMidpoint = (xyzA + xyzB)/2.0_KREAL
	SphereMidpoint = SphereMidpoint/sqrt(sum(sphereMidpoint*sphereMidpoint))*EARTH_RADIUS
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the centroid of a spherical triangle defined by three vertices
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3); vector on the sphere
!> @param[in] xyzB double precision real size(3); vector on the sphere
!> @param[in] xyzC double precision real size(3); vector on the sphere
!> @return centroid vector
!------------------------------------------------------------------------------
function SphereTriCenter(xyzA, xyzB, xyzC)
! Finds the midpoint of three points on the sphere by find their average position in Cartesian
! coordinates, then projecting that average onto the sphere.
	! Calling parameters
	real(KREAL), dimension(3), intent(in) :: xyzA, xyzB, xyzC
	real(KREAL), dimension(3) :: SphereTriCenter

	SphereTriCenter = (xyzA + xyzB + xyzC)/3.0_KREAL
	SphereTriCenter = SphereTriCenter/sqrt(sum(sphereTriCenter*sphereTriCenter))*EARTH_RADIUS
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the centroid of a spherical quadrilateral defined by four vertices
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3); vector on the sphere
!> @param[in] xyzB double precision real size(3); vector on the sphere
!> @param[in] xyzC double precision real size(3); vector on the sphere
!> @param[in] xyzD double precision real size(3); vector on the sphere
!> @return centroid vector
!------------------------------------------------------------------------------
function SphereQuadCenter(xyzA, xyzB, xyzC, xyzD)
! Finds the midpoint of four points on the sphere by finding their average position in
! Cartesian coordinates, then projecting that average onto the sphere.
	! Calling parameters
	real(KREAL), dimension(3), intent(in) :: xyzA, xyzB, xyzC, xyzD
	real(KREAL), dimension(3) :: sphereQuadCenter

	SphereQuadCenter = (xyzA + xyzB + xyzC + xyzD)/4.0_KREAL
	SphereQuadCenter = SphereQuadCenter/sqrt(sum(sphereQuadCenter*sphereQuadCenter))*EARTH_RADIUS
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the area of a spherical triangle defined by three vertices
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3); vector on the sphere
!> @param[in] xyzB double precision real size(3); vector on the sphere
!> @param[in] xyzC double precision real size(3); vector on the sphere
!> @return scalar area
!------------------------------------------------------------------------------
function SphereTriAreaVector(xyzA, xyzB, xyzC)
! Calculates the area of a spherical triangle on the unit sphere
!   NOTE : This function requires function sphereDistance.
	! Calling parameters
	real(KREAL), dimension(3), intent(in) :: xyzA, xyzB, xyzC
	real(KREAL) :: SphereTriAreaVector
	! Local variables
	real(KREAL) :: side1, side2, side3, halfPerimeter, zz

	side1 = SphereArcLength(xyzA,xyzB)
	side2 = SphereArcLength(xyzB,xyzC)
	side3 = SphereArcLength(xyzC,xyzA)

	halfPerimeter = (side1 + side2 + side3)/2.0_KREAL

	zz = tan(halfPerimeter/2.0_KREAL)*tan( (halfPerimeter-side1)/2.0_KREAL )*&
		tan( (halfPerimeter - side2)/2.0_KREAL )*tan( (halfPerimeter - side3)/2.0_KREAL )

	SphereTriAreaVector = 4.0_KREAL * atan2(sqrt(zz),1.0_KREAL)*EARTH_RADIUS*EARTH_RADIUS
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the area of a spherical triangle defined by three vertices
!
!> @ingroup SphereGeom
!
!> @param[in] xA double precision real
!> @param[in] yA double precision real
!> @param[in] zA
!> @param[in] xB
!> @param[in] yB
!> @param[in] zB
!> @param[in] xC
!> @param[in] yC
!> @param[in] zC
!> @return scalar area
!------------------------------------------------------------------------------
function SphereTriAreaComponents(xa,ya,za, xb,yb,zb, xc,yc,zc)
	real(kreal), intent(in) :: xa,ya,za
	real(kreal), intent(in) :: xb,yb,zb
	real(kreal), intent(in) :: xc,yc,zc
	real(kreal) :: SphereTriAreaComponents
	real(kreal) :: s1,s2,s3, halfPerim, zz

	s1 = SphereArcLengthComponents(xa,ya,za,xb,yb,zb)
	s2 = SphereArcLengthComponents(xb,yb,zb,xc,yc,zc)
	s3 = SphereArcLengthComponents(xc,yc,zc,xa,ya,za)

	halfPerim = (s1+s2+s3)/2.0_kreal
	zz = tan( halfPerim/2.0_kreal)*tan( (halfPerim-s1)/2.0_kreal) * &
		 tan( (halfPerim-s2)/2.0_kreal)*tan( (halfPerim-s3)/2.0_kreal)

	SphereTriAreaComponents = 4.0_kreal*atan(sqrt(zz))*EARTH_RADIUS*EARTH_RADIUS
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the area of a planar triangle defined by three vertices
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3); vector on the sphere
!> @param[in] xyzB double precision real size(3); vector on the sphere
!> @param[in] xyzC double precision real size(3); vector on the sphere
!> @return scalar area
!------------------------------------------------------------------------------
function PlaneTriArea(xyzA,xyzB,xyzC)
	! Outputs the area of a planar triangle in R3 with vertices xyzA,B,C.
	real(kreal) :: PlaneTriArea
	real(kreal), intent(in) :: xyzA(3), xyzB(3), xyzC(3)
	PlaneTriArea = crossMagnitude( xyzB-xyzA, xyzC-xyzA)/2.0_kreal
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the longitude of a point on the sphere
!
!> @ingroup SphereGeom
!
!> @param[in] xyz double precision real size(3); vector on the sphere in Cartesian coordinates
!> @return Longitude of xyz
!------------------------------------------------------------------------------
function longitudeVector(xyz)
	! Outputs the longitude of a point on the sphere.
	real(KREAL) :: longitudeVector
	real(KREAL), intent(in) :: xyz(3)
	longitudeVector = atan4(xyz(2),xyz(1))
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the longitude of a point on the sphere
!
!> @ingroup SphereGeom
!
!> @param[in] xyz double precision real size(3); vector on the sphere in Cartesian coordinates
!> @return Longitude of xyz
!------------------------------------------------------------------------------
function LongitudeComponents(x,y,z)
	real(kreal), intent(in) :: x, y, z
	real(kreal) :: LongitudeComponents
	LongitudeComponents = atan4(y,x)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the longitude of a point on the sphere
!
!> @ingroup SphereGeom
!
!> @param[in] xyz double precision real size(3); vector on the sphere in Cartesian coordinates
!> @return Longitude of xyz
!------------------------------------------------------------------------------
function LongitudeComponents2(x,y)
	real(kreal), intent(in) :: x, y
	real(kreal) :: LongitudeComponents2
	LongitudeCOmponents2 = atan4(y,x)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the latitude of a point on the sphere
!
!> @ingroup SphereGeom
!
!> @param[in] xyz double precision real size(3); vector on the sphere in Cartesian coordinates
!> @return Latitude of xyz
!------------------------------------------------------------------------------
function latitudeVector(xyz)
	! Outputs the latitude of a point on the unit sphere.
	real(KREAL) :: latitudeVector
	real(KREAL), intent(in) :: xyz(3)
	latitudeVector = atan2(xyz(3),sqrt(xyz(1)**2 + xyz(2)**2))
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Finds the latitude of a point on the sphere
!
!> @ingroup SphereGeom
!
!> @param[in] xyz double precision real size(3); vector on the sphere in Cartesian coordinates
!> @return Latitude of xyz
!------------------------------------------------------------------------------
function LatitudeComponents(x,y,z)
	real(kreal), intent(in) :: x, y, z
	real(kreal) :: LatitudeComponents
	LatitudeComponents = atan2(z,sqrt(x*x+y*y))
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief A 4-quadrant inverse tangent function with range 0 to 2*pi instead of -pi to pi.
!
!> @ingroup SphereGeom
!
!> @param[in] y double precision real
!> @param[in] x double precision real
!> @return atan(y/x) in range 0 to 2*pi
!------------------------------------------------------------------------------
function atan4(y,x)
	!This function computes the inverse tangent (like atan2) but outputs angles in the range
	! 0 to 2 pi (rather than -pi to pi).
	! Adapted from John Burkhardt: http://people.sc.fsu.edu/~jburkhardt/m_src/halton/atan4.m
	real(kreal), intent(in) :: y,x
	real(kreal) :: atan4
	real(kreal) :: absY, absX, theta
	if ( x == 0.0_kreal) then
		if ( y > 0.0_kreal) then
			atan4 = PI/2.0_kreal
		elseif ( y < 0.0_kreal) then
			atan4 = 3.0_kreal*PI/2.0_kreal
		elseif ( y == 0.0_kreal) then
			atan4 = 0.0_kreal
		endif
	elseif ( y == 0.0_kreal) then
		if ( x > 0.0_kreal) then
			atan4 = 0.0_kreal
		elseif ( x < 0.0_kreal) then
			atan4 = PI
		endif
	else
		absY = abs(y)
		absX = abs(x)
		theta = atan2(absY,absX)
		if ( (x>0.0_kreal) .and. (y>0.0_kreal)) then
			atan4 = theta
		elseif ( (x < 0.0_kreal) .and. (y > 0.0_kreal)) then
			atan4 = pi -theta
		elseif ( (x < 0.0_kreal) .and. (y < 0.0_kreal)) then
			atan4 = pi+ theta
		elseif ( (x > 0.0_kreal) .and. (y<0.0_kreal)) then
			atan4 = 2.0_kreal*PI - theta
		endif
	endif
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Magnitude of the vector xyzA X xyzB
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3)
!> @param[in] xyzB double precision real size(3)
!> @return |xyzA x xyzB|
!------------------------------------------------------------------------------
function crossMagnitude(xyzA,xyzB)
	! Computes the magnitude of xyzA cross xyzB
	real(kreal) :: crossMagnitude
	real(kreal), intent(in) :: xyzA(3), xyzB(3)
	crossMagnitude = sqrt( (xyzA(2)*xyzB(3) - xyzA(3)*xyzB(2))*(xyzA(2)*xyzB(3) - xyzB(2)*xyzA(3)) + &
	   					   (xyzA(3)*xyzB(1) - xyzA(1)*xyzB(3))*(xyzA(3)*xyzB(1) - xyzA(1)*xyzB(3)) + &
	   					   (xyzA(1)*xyzB(2) - xyzA(2)*xyzB(1))*(xyzA(1)*xyzB(2) - xyzA(2)*xyzB(1)))
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Computes a vector cross product
!
!> @ingroup SphereGeom
!
!> @param[in] xyzA double precision real size(3)
!> @param[in] xyzB double precision real size(3)
!> @return xyzA x xyzB double precision real size(3)
!------------------------------------------------------------------------------
function crossProduct(xyzA,xyzB)
	! Computes the cross product vector xyzA cross xyzB
	real(kreal) :: crossProduct(3)
	real(kreal), intent(in) :: xyzA(3), xyzB(3)
	crossProduct(1) = xyzA(2)*xyzB(3) - xyzA(3)*xyzB(2)
	crossProduct(2) = xyzA(3)*xyzB(1) - xyzA(1)*xyzB(3)
	crossProduct(3) = xyzA(1)*xyzB(2) - xyzA(2)*xyzB(1)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Computes a vector triple product
!
!> @ingroup SphereGeom
!
!> @param[in] xA double precision real size(3)
!> @param[in] xB double precision real size(3)
!> @param[in] xC double precision real size(3)
!> @return \f$ x_A \cdot (x_b \times x_c) $\f double precision real size(3)
!------------------------------------------------------------------------------
function Determinant(xA,xB,xC)
	! Computes the vector determinant (triple product) of xA, xB, and xC
	! This result will be positive if xA lies to the left of the directed arc
	! xB to xC, and negative if xA lies to the right of the arc xB->xC.
	real(kreal) :: Determinant
	real(kreal), intent(in) :: xA(3), xB(3), xC(3)
	real(kreal) :: cross(3)
	cross = CrossProduct(xB,xC)
	Determinant = sum(xA*cross)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Generates a random point on the surface of a sphere
!
!> @ingroup SphereGeom
!
!> @return random vector satisfying x^2 + y^2 + z^2 = R^2
!------------------------------------------------------------------------------
function RandomSpherePoint()
	! Outputs a random point on the unit sphere.
	! Note : the seed is not initialized, so each sequence of
	!        random points will be the same.
	real(kreal) :: RandomSpherePoint(3)
	real(kreal) :: x, y, z
	!call Random_Seed()
	call Random_Number(x)
	call Random_Number(y)
	call Random_Number(z)
	x = -1.0_kreal + 2.0_kreal*x
	y = -1.0_kreal + 2.0_kreal*y
	z = -1.0_kreal + 2.0_kreal*z
	RandomSpherePoint(1) = x
	RandomSpherePoint(2) = y
	RandomSpherePoint(3) = z
	RandomSpherePoint = RandomSpherePoint/sqrt(sum(RandomSpherePoint*RandomSpherePoint))*EARTH_RADIUS
end function

subroutine NormalizePositionVectors(xyz)
	real(kreal), intent(inout) :: xyz(:,:)
	integer(kint) :: j, n
!	real(kreal) :: norm
	if ( size(xyz,1) /= 3) stop 'ERROR : position vector array shape error.'
	n = size(xyz,2)
	do j=1,n
		xyz(:,j) = xyz(:,j)/(sqrt(sum(xyz(:,j)*xyz(:,j))))*EARTH_RADIUS
	enddo
end subroutine

!function NorthPoleRotationMatrix(xyz)
!! returns a rotation matrix R so that R*x = (0,0,1)^T
!	real(kreal) :: NorthPoleRotationMatrix(3,3)
!	real(kreal), intent(in) :: xyz(3)
!	real(kreal) :: cy, sy, cx, sx
!
!	cy = sqrt(xyz(2)*xyz(2) + xyz(3)*xyz(3))
!	sy = xyz(1)
!
!	if (abs(cy) > ZERO_TOL) then
!		cx = xyz(3)/cy
!		sx = xyz(2)/cy
!	else
!		cx = 1.0_kreal
!		sx = 0.0_kreal
!	endif
!
!	NorthPoleRotationMatrix(1,1) = cy
!	NorthPoleRotationMatrix(2,1) = 0.0_kreal
!	NorthPoleRotationMatrix(3,1) = sy
!
!	NorthPoleRotationMatrix(1,2) = -sx*sy
!	NorthPoleRotationMatrix(2,2) = cx
!	NorthPoleRotationMatrix(3,2) = cy*sx
!
!	NorthPoleRotationMatrix(1,3) = -cx*sy
!	NorthPoleRotationMatrix(2,3) = -sx
!	NorthPoleRotationMatrix(3,3) = cx*cy
!
!end function

end module


submodule (maptran) ecef

implicit none (type, external)

contains

module procedure ecef2geodetic
!! convert ECEF (meters) to geodetic coordintes
!!
!! based on:
!! You, Rey-Jer. (2000). Transformation of Cartesian to Geodetic Coordinates without Iterations.
!! Journal of Surveying Engineering. doi: 10.1061/(ASCE)0733-9453

real(wp) :: ea, eb, r, E, u, Q, huE, Beta, eps, sinBeta, cosBeta
type(Ellipsoid) :: ell
logical :: d, inside

ell = wgs84Ellipsoid
if (present(spheroid)) ell = spheroid

ea = ell%SemimajorAxis
eb = ell%SemiminorAxis

r = sqrt(x**2 + y**2 + z**2)

E = sqrt(ea**2 - eb**2)

! eqn. 4a
u = sqrt(0.5 * (r**2 - E**2) + 0.5 * sqrt((r**2 - E**2)**2 + 4 * E**2 * z**2))

Q = hypot(x, y)

huE = hypot(u, E)

!> eqn. 4b
Beta = atan2(huE / u * z, hypot(x, y))

!> final output
if (abs(beta-pi/2) <= epsilon(beta)) then !< singularity
  lat = pi/2
  cosBeta = 0
  sinBeta = 1
elseif (abs(beta+pi/2) <= epsilon(beta)) then !< singularity
  lat = -pi/2
  cosBeta = 0
  sinBeta = -1
else
  !> eqn. 13
  eps = ((eb * u - ea * huE + E**2) * sin(Beta)) / (ea * huE * 1 / cos(Beta) - E**2 * cos(Beta))
  Beta = Beta + eps

  lat = atan(ea / eb * tan(Beta))
  cosBeta = cos(Beta)
  sinBeta = sin(Beta)
endif

lon = atan2(y, x)

! eqn. 7
if (present(alt)) then
  alt = hypot(z - eb * sinBeta, Q - ea * cosBeta)

  !> inside ellipsoid?
  inside = x**2 / ea**2 + y**2 / ea**2 + z**2 / eb**2 < 1._wp
  if (inside) alt = -alt
endif

d=.true.
if (present(deg)) d = deg

if (d) then
  lat = degrees(lat)
  lon = degrees(lon)
endif

end procedure ecef2geodetic

module procedure geodetic2ecef
!! # geodetic2ecef
!! convert from geodetic to ECEF coordiantes
!!
!! ## Inputs
!!
!! * lat,lon, alt:  ellipsoid geodetic coordinates of point(s) (degrees, degrees, meters)
!! * spheroid: Ellipsoid parameter struct
!! * deg: .true. degrees
!!
!! ## outputs
!!
!! * x,y,z:  ECEF coordinates of test point(s) (meters)

real(wp) :: N, sinLat, cosLat, cosLon, sinLon, lat, lon
type(Ellipsoid) :: ell
logical :: d

d = .true.
if (present(deg)) d = deg

ell = wgs84Ellipsoid
if (present(spheroid)) ell = spheroid

lat = llat
lon = llon
if (d) then
  lat = radians(lat)
  lon = radians(lon)
endif

!> Radius of curvature of the prime vertical section
N = radius_normal(lat, ell)

!! Compute cartesian (geocentric) coordinates given  (curvilinear) geodetic coordinates.

!> singularities.  Benchmark shows nearly zero runtime impact of these if statements for any real precision
if (abs(lat) <= epsilon(lat)) then
  cosLat = 1
  sinLat = 0
elseif (abs(lat-pi/2) <= epsilon(lat)) then
  cosLat = 0
  sinLat = 1
elseif (abs(lat+pi/2) <= epsilon(lat)) then
  cosLat = 0
  sinLat = -1
else
  cosLat = cos(lat)
  sinLat = sin(lat)
endif

if (abs(lon) <= epsilon(lon)) then
  cosLon = 1
  sinLon = 0
elseif (abs(lon-pi/2) <= epsilon(lon)) then
  cosLon = 0
  sinLon = 1
elseif (abs(lon+pi/2) <= epsilon(lon)) then
  cosLon = 0
  sinLon = -1
elseif (abs(lon+pi) <= epsilon(lon) .or. abs(lon-pi) <= epsilon(lon)) then
  cosLon = -1
  sinLon = 0
else
  cosLon = cos(lon)
  sinLon = sin(lon)
endif

x = (N + alt) * cosLat * cosLon
y = (N + alt) * cosLat * sinLon
z = (N * (ell%SemiminorAxis / ell%SemimajorAxis)**2 + alt) * sinLat

end procedure geodetic2ecef

module procedure enu2ecef
! enu2ecef  convert from ENU to ECEF coordiantes
!
! Inputs
! ------
! e,n,u:  East, North, Up coordinates of test points (meters)
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! angleUnit: string for angular units. Default 'd': degrees
!
! outputs
! -------
! x,y,z: Earth Centered Earth Fixed (ECEF) coordinates of test point (meters)

real(wp) :: x0,y0,z0,dx,dy,dz

call geodetic2ecef(lat0, lon0, alt0, x0, y0, z0, spheroid, deg)
call enu2uvw(e, n, u, lat0, lon0, dx, dy, dz, deg)

 x = x0 + dx
 y = y0 + dy
 z = z0 + dz
end procedure enu2ecef

module procedure ecef2enu
!! ecef2enu  convert ECEF to ENU
!!
!! ## Inputs
!!
!! * x,y,z: Earth Centered Earth Fixed (ECEF) coordinates of test point (meters)
!! * lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
!! * spheroid: Ellipsoid parameter struct
!! * angleUnit: string for angular units. Default 'd': degrees
!!
!! ## outputs
!!
!! * e,n,u:  East, North, Up coordinates of test points (meters)

real(wp) :: x0,y0,z0

call geodetic2ecef(lat0, lon0, alt0, x0,y0,z0, spheroid,deg)
call ecef2enuv(x - x0, y - y0, z - z0, lat0, lon0, east, north, up, deg)
end procedure ecef2enu

module procedure ecef2enuv
!! ecef2enuv convert *vector projection* UVW to ENU
!!
!! ## Inputs
!!
!! * u,v,w: meters
!! * lat0,lon0: geodetic latitude and longitude (degrees)
!! * deg: .true. degrees
!!
!! ## Outputs
!!
!! * east,north,Up:  East, North, Up vector

real(wp) :: t, lat0, lon0
logical :: d

d=.true.
if (present(deg)) d = deg

lat0 = llat0
lon0 = llon0
if (d) then
  lat0 = radians(lat0)
  lon0 = radians(lon0)
endif

t     =  cos(lon0) * u + sin(lon0) * v
east  = -sin(lon0) * u + cos(lon0) * v
up    =  cos(lat0) * t + sin(lat0) * w
north = -sin(lat0) * t + cos(lat0) * w
end procedure ecef2enuv

elemental real(wp) function radius_normal(lat,E)

real(wp), intent(in) :: lat
type(Ellipsoid), intent(in) :: E

!> singularity  pi/2 issue is inherent to real32
if (abs(lat) <= epsilon(lat)) then
  radius_normal = E%SemimajorAxis
else
  radius_normal = E%SemimajorAxis**2 / sqrt( E%SemimajorAxis**2 * cos(lat)**2 + E%SemiminorAxis**2 * sin(lat)**2 )
endif

end function radius_normal

end submodule ecef


!##############################################################################
!# Tutorial 005c: Basic linear algebra
!##############################################################################

module tutorial005c

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput
  use linearalgebra

  implicit none
  private

  public :: start_tutorial005c

contains

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

  subroutine start_tutorial005c

    ! Declare some variables
    real(DP), dimension(4) :: Dvec1, Dvec2, Dvec3, Dvec4, Dvec
    integer, dimension(4) :: Iperm
    real(DP) :: d
    integer :: i

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 005c")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Initialise vectors
    ! =================================

    Dvec1 = (/  1.0_DP, 2.0_DP,  3.0_DP, 4.0_DP /)
    Dvec2 = (/ -1.0_DP, 1.0_DP, -1.0_DP, 1.0_DP /)
    Dvec3 = (/  0.0_DP, 0.0_DP,  1.0_DP, 0.0_DP /)
    Dvec4 = (/  2.0_DP,-1.0_DP,  0.0_DP, 0.0_DP /)

    ! =================================
    ! Clear
    !   Dvec = 0
    ! =================================

    call lalg_clearVector (Dvec)

    do i=1,4
      call output_line (" " // sys_sdL(Dvec(i),2), bnolinebreak=(i .ne. 4) )
    end do

    ! =================================
    ! Set to constant
    !   Dvec = (1,1,1,1)
    ! =================================

    call lalg_setVector (Dvec,1.0_DP)

    do i=1,4
      call output_line (" " // sys_sdL(Dvec(i),2), bnolinebreak=(i .ne. 4) )
    end do

    ! =================================
    ! Copy and scale:
    !   Dvec = 2*Dvec1
    ! =================================

    call lalg_copyVector (Dvec1, Dvec)
    call lalg_scaleVector (Dvec, 2.0_DP)

    do i=1,4
      call output_line (" " // sys_sdL(Dvec(i),2), bnolinebreak=(i .ne. 4) )
    end do

    ! =================================
    ! Linear combination.
    !   Dvec = Dvec1 - (1,1,1,1)
    ! =================================

    call lalg_setVector (Dvec,1.0_DP)
    call lalg_vectorLinearComb (Dvec1,Dvec,1.0_DP,-1.0_DP)

    do i=1,4
      call output_line (" " // sys_sdL(Dvec(i),2), bnolinebreak=(i .ne. 4) )
    end do

    ! =================================
    ! Add constant
    !   Dvec = Dvec1 - (1,1,1,1)
    ! =================================

    call lalg_copyVector (Dvec1,Dvec)
    call lalg_vectorAddScalar (Dvec,-1.0_DP)

    do i=1,4
      call output_line (" " // sys_sdL(Dvec(i),2), bnolinebreak=(i .ne. 4) )
    end do

    ! =================================
    ! Sort vector backwards,
    !   Dvec = back(Dvec4)
    ! =================================

    Iperm = (/ 4, 3, 2, 1 /)
    call lalg_vectorSort (Dvec4, Dvec, Iperm)

    do i=1,4
      call output_line (" " // sys_sdL(Dvec(i),2), bnolinebreak=(i .ne. 4) )
    end do

    ! =================================
    ! Scalar product
    !   result = < Dvec2, Dvec3 >
    ! =================================

    d = lalg_scalarProduct(Dvec2,Dvec3)

    call output_line ("<vec2,vec3> = " // sys_sdL(d,2) )

    ! =================================
    ! Different norms
    !   result = || Dvec4 ||
    ! =================================

    ! SUM
    d = lalg_norm(Dvec4,LINALG_NORMSUM)
    call output_line ("||vec4||_SUM   = " // sys_sdL(d,2) )

    ! Euclid-norm
    d = lalg_norm(Dvec4,LINALG_NORMEUCLID)
    call output_line ("||vec4||_2     = " // sys_sdL(d,2) )

    ! L1-norm
    d = lalg_norm(Dvec4,LINALG_NORML1)
    call output_line ("||vec4||_l1    = " // sys_sdL(d,2) )

    ! L2-norm
    d = lalg_norm(Dvec4,LINALG_NORML2)
    call output_line ("||vec4||_l2    = " // sys_sdL(d,2) )

    ! MAX-norm
    d = lalg_norm(Dvec4,LINALG_NORMMAX)
    call output_line ("||vec4||_MAX   = " // sys_sdL(d,2) )

  end subroutine

end module


!##############################################################################
! PROGRAM MC_Option_Pricing
!
! ## Option pricing with Monte Carlo simulations - Asian options
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program MC_Option_Pricing

    use toolbox

    implicit none
    real*8, parameter :: Del_TT = 62d0/250d0     ! exercise date (in annualized values)
    real*8, parameter :: S_0 = 25d0              ! initial stock price
    real*8, parameter :: r = 0.04d0              ! annual interest rate
    real*8, parameter :: sigma = 0.10d0          ! standard deviation of stock returns
    real*8, parameter :: KK = 25d0                ! strike price
    integer, parameter :: TT = 200               ! number of sub-periods
    integer, parameter :: JJ = 20000             ! maximum number of simulation paths

    real*8 :: S(0:TT), z(TT), del_t
    real*8 :: S_bar, pi_c(JJ), pi_p(JJ)
    real*8 :: c_AS(JJ), p_AS(JJ), npaths(JJ)
    integer :: ij, it

    ! get length of sub-periods
    del_t = Del_TT/dble(TT)

    ! simulate price paths and corresponding profits
    do ij = 1, JJ

        ! generate a price path
        call simulate_normal(z, 0d0, 1d0)
        S(0) = S_0
        do it = 1, TT
            S(it) = S(it-1)*exp((r-sigma**2/2d0)*del_t + sigma*sqrt(del_t)*z(it))
        enddo

        ! get average stock price
        S_bar = 0
        do it = 1, TT
            S_bar = S_bar + S(it)
        enddo
        S_bar = S_bar/dble(TT)

        ! calculate associated payoff
        pi_c(ij) = max(S_bar - KK, 0d0)
        pi_p(ij) = max(KK - S_bar, 0d0)
    enddo

    ! use different number of paths to compute premium
    do ij = 1, JJ
        c_AS(ij) = exp(-r*Del_TT)*sum(pi_c(1:ij))/dble(ij)
        p_AS(ij) = exp(-r*Del_TT)*sum(pi_p(1:ij))/dble(ij)
        npaths(ij) = dble(ij)
    enddo

    ! plot option price as a function of number of paths used
    call plot(npaths(1:10000), c_AS(1:10000), legend='Asian Call Option')
    call plot(npaths(1:10000), p_AS(1:10000), legend='Asian Put Option')
    call execplot()

    write(*,'(a)')'OPTION PRICING USING MC SIMULATION'
    write(*,'(a, f12.5)')'Call Price = ', c_AS(JJ)
    write(*,'(a, f12.5)')'Put  Price = ', p_AS(JJ)

end program


! { dg-do compile }
! Testcase from PR 25396: User defined operators returning arrays.
module geometry

  implicit none

  interface operator(.cross.)
     module procedure cross
  end interface

contains

    ! Cross product between two 3d vectors.
    pure function cross(a, b)
      real, dimension(3), intent(in) :: a,b
      real, dimension(3) :: cross

     cross = (/ a(2) * b(3) - a(3) * b(2), &
           a(3) * b(1) - a(1) * b(3), &
           a(1) * b(2) - a(2) * b(1) /)
    end function cross

end module geometry

program opshape
  use geometry

  implicit none

  real :: t(3,3), a

  a = dot_product (t(:,1), t(:,2) .cross. t(:,3))

end program opshape


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c     file alf.f contains subroutines alfk,lfim,lfim1,lfin,lfin1,lfpt
c     for computing normalized associated legendre polynomials
c
c subroutine alfk (n,m,cp)
c
c dimension of           real cp(n/2 + 1)
c arguments
c
c purpose                routine alfk computes single precision fourier
c                        coefficients in the trigonometric series
c                        representation of the normalized associated
c                        legendre function pbar(n,m,theta) for use by
c                        routines lfp and lfpt in calculating single
c                        precision pbar(n,m,theta).
c
c                        first define the normalized associated
c                        legendre functions
c
c                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative of
c                        (x**2-1)**n with respect to x=cos(theta)
c
c                        where theta is colatitude.
c
c                        then subroutine alfk computes the coefficients
c                        cp(k) in the following trigonometric
c                        expansion of pbar(m,n,theta).
c
c                        1) for n even and m even, pbar(m,n,theta) =
c                           .5*cp(1) plus the sum from k=1 to k=n/2
c                           of cp(k+1)*cos(2*k*th)
c
c                        2) for n even and m odd, pbar(m,n,theta) =
c                           the sum from k=1 to k=n/2 of
c                           cp(k)*sin(2*k*th)
c
c                        3) for n odd and m even, pbar(m,n,theta) =
c                           the sum from k=1 to k=(n+1)/2 of
c                           cp(k)*cos((2*k-1)*th)
c
c                        4) for n odd and m odd,  pbar(m,n,theta) =
c                           the sum from k=1 to k=(n+1)/2 of
c                           cp(k)*sin((2*k-1)*th)
c
c
c usage                  call alfk(n,m,cp)
c
c arguments
c
c on input               n
c                          nonnegative integer specifying the degree of
c                          pbar(n,m,theta)
c
c                        m
c                          is the order of pbar(n,m,theta). m can be
c                          any integer however cp is computed such that
c                          pbar(n,m,theta) = 0 if abs(m) is greater
c                          than n and pbar(n,m,theta) = (-1)**m*
c                          pbar(n,-m,theta) for negative m.
c
c on output              cp
c                          single precision array of length (n/2)+1
c                          which contains the fourier coefficients in
c                          the trigonometric series representation of
c                          pbar(n,m,theta)
c
c
c special conditions     none
c
c precision              single
c
c algorithm              the highest order coefficient is determined in
c                        closed form and the remainig coefficients are
c                        determined as the solution of a backward
c                        recurrence relation.
c
c accuracy               comparison between routines alfk and double
c                        precision dalfk on the cray1 indicates
c                        greater accuracy for smaller values
c                        of input parameter n.  agreement to 14
c                        places was obtained for n=10 and to 13
c                        places for n=100.
c
      SUBROUTINE DALFK(N,M,CP)
      DOUBLE PRECISION CP
      DOUBLE PRECISION SC10
      DOUBLE PRECISION SC20
      DOUBLE PRECISION SC40
      DOUBLE PRECISION FNUM
      DOUBLE PRECISION FNMH
      DOUBLE PRECISION PM1
      DOUBLE PRECISION T1
      DOUBLE PRECISION FDEN
      DOUBLE PRECISION T2
      DOUBLE PRECISION CP2
      DOUBLE PRECISION FNNP1
      DOUBLE PRECISION FNMSQ
      DOUBLE PRECISION FK
      DOUBLE PRECISION A1
      DOUBLE PRECISION B1
      DOUBLE PRECISION C1
      DIMENSION CP(N/2+1)
      PARAMETER (SC10=1024.D0)
      PARAMETER (SC20=SC10*SC10)
      PARAMETER (SC40=SC20*SC20)
c
      CP(1) = 0.D0
      MA = IABS(M)
      IF (MA.GT.N) RETURN
      IF (N-1) 2,3,5
    2 CP(1) = SQRT(2.D0)
      RETURN
    3 IF (MA.NE.0) GO TO 4
      CP(1) = SQRT(1.5D0)
      RETURN
    4 CP(1) = SQRT(.75D0)
      IF (M.EQ.-1) CP(1) = -CP(1)
      RETURN
    5 IF (MOD(N+MA,2).NE.0) GO TO 10
      NMMS2 = (N-MA)/2
      FNUM = N + MA + 1
      FNMH = N - MA + 1
      PM1 = 1.D0
      GO TO 15
   10 NMMS2 = (N-MA-1)/2
      FNUM = N + MA + 2
      FNMH = N - MA + 2
      PM1 = -1.D0
   15 T1 = 1.D0/SC20
      NEX = 20
      FDEN = 2.D0
      IF (NMMS2.LT.1) GO TO 20
      DO 18 I = 1,NMMS2
          T1 = FNUM*T1/FDEN
          IF (T1.GT.SC20) THEN
              T1 = T1/SC40
              NEX = NEX + 40
          END IF
          FNUM = FNUM + 2.D0
          FDEN = FDEN + 2.D0
   18 CONTINUE
   20 T1 = T1/2.D0** (N-1-NEX)
      IF (MOD(MA/2,2).NE.0) T1 = -T1
      T2 = 1.D0
      IF (MA.EQ.0) GO TO 26
      DO 25 I = 1,MA
          T2 = FNMH*T2/ (FNMH+PM1)
          FNMH = FNMH + 2.D0
   25 CONTINUE
   26 CP2 = T1*SQRT((N+.5D0)*T2)
      FNNP1 = N* (N+1)
      FNMSQ = FNNP1 - 2.D0*MA*MA
      L = (N+1)/2
      IF (MOD(N,2).EQ.0 .AND. MOD(MA,2).EQ.0) L = L + 1
      CP(L) = CP2
      IF (M.GE.0) GO TO 29
      IF (MOD(MA,2).NE.0) CP(L) = -CP(L)
   29 IF (L.LE.1) RETURN
      FK = N
      A1 = (FK-2.D0)* (FK-1.D0) - FNNP1
      B1 = 2.D0* (FK*FK-FNMSQ)
      CP(L-1) = B1*CP(L)/A1
   30 L = L - 1
      IF (L.LE.1) RETURN
      FK = FK - 2.D0
      A1 = (FK-2.D0)* (FK-1.D0) - FNNP1
      B1 = -2.D0* (FK*FK-FNMSQ)
      C1 = (FK+1.D0)* (FK+2.D0) - FNNP1
      CP(L-1) = - (B1*CP(L)+C1*CP(L+1))/A1
      GO TO 30
      END
c subroutine lfim (init,theta,l,n,nm,pb,id,wlfim)
c
c dimension of           theta(l),  pb(id,nm+1),  wlfim(4*l*(nm+1))
c arguments
c
c purpose                given n and l, routine lfim calculates
c                        the normalized associated legendre functions
c                        pbar(n,m,theta) for m=0,...,n and theta(i)
c                        for i=1,...,l where
c
c                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative of
c                        (x**2-1)**n with respect to x=cos(theta)
c
c usage                  call lfim (init,theta,l,n,nm,pb,id,wlfim)
c
c arguments
c on input               init
c                        = 0
c                            initialization only - using parameters
c                            l, nm and array theta, subroutine lfim
c                            initializes array wlfim for subsequent
c                            use in the computation of the associated
c                            legendre functions pb. initialization
c                            does not have to be repeated unless
c                            l, nm, or array theta are changed.
c                        = 1
c                            subroutine lfim uses the array wlfim that
c                            was computed with init = 0 to compute pb.
c
c                        theta
c                          an array that contains the colatitudes
c                          at which the associated legendre functions
c                          will be computed. the colatitudes must be
c                          specified in radians.
c
c                        l
c                          the length of the theta array. lfim is
c                          vectorized with vector length l.
c
c                        n
c                          nonnegative integer, less than nm, specifying
c                          degree of pbar(n,m,theta). subroutine lfim
c                          must be called starting with n=0. n must be
c                          incremented by one in subsequent calls and
c                          must not exceed nm.
c
c                        nm
c                          the maximum value of n and m
c
c                        id
c                          the first dimension of the two dimensional
c                          array pb as it appears in the program that
c                          calls lfim. (see output parameter pb)
c
c                        wlfim
c                          an array with length 4*l*(nm+1) which
c                          must be initialized by calling lfim
c                          with init=0 (see parameter init)  it
c                          must not be altered between calls to
c                          lfim.
c
c
c on output              pb
c                          a two dimensional array with first
c                          dimension id in the program that calls
c                          lfim. the second dimension of pb must
c                          be at least nm+1. starting with n=0
c                          lfim is called repeatedly with n being
c                          increased by one between calls. on each
c                          call, subroutine lfim computes
c                          = pbar(m,n,theta(i)) for m=0,...,n and
c                          i=1,...l.
c
c                        wlfim
c                          array containing values which must not
c                          be altered unless l, nm or the array theta
c                          are changed in which case lfim must be
c                          called with init=0 to reinitialize the
c                          wlfim array.
c
c special conditions     n must be increased by one between calls
c                        of lfim in which n is not zero.
c
c precision              single
c
c
c algorithm              routine lfim calculates pbar(n,m,theta) using
c                        a four term recurrence relation. (unpublished
c                        notes by paul n. swarztrauber)
c
      SUBROUTINE DLFIM(INIT,THETA,L,N,NM,PB,ID,WLFIM)
      DOUBLE PRECISION THETA
      DOUBLE PRECISION PB
      DOUBLE PRECISION WLFIM
      DIMENSION PB(1),WLFIM(1)
c
c     total length of wlfim is 4*l*(nm+1)
c
      LNX = L* (NM+1)
      IW1 = LNX + 1
      IW2 = IW1 + LNX
      IW3 = IW2 + LNX
      CALL DLFIM1(INIT,THETA,L,N,NM,ID,PB,WLFIM,WLFIM(IW1),WLFIM(IW2),
     +           WLFIM(IW3),WLFIM(IW2))
      RETURN
      END
      SUBROUTINE DLFIM1(INIT,THETA,L,N,NM,ID,P3,PHZ,PH1,P1,P2,CP)
      DOUBLE PRECISION THETA
      DOUBLE PRECISION P3
      DOUBLE PRECISION PHZ
      DOUBLE PRECISION PH1
      DOUBLE PRECISION P1
      DOUBLE PRECISION P2
      DOUBLE PRECISION CP
      DOUBLE PRECISION SSQRT2
      DOUBLE PRECISION SQ5S6
      DOUBLE PRECISION SQ1S6
      DOUBLE PRECISION FN
      DOUBLE PRECISION TN
      DOUBLE PRECISION CN
      DOUBLE PRECISION FM
      DOUBLE PRECISION FNPM
      DOUBLE PRECISION FNMM
      DOUBLE PRECISION TEMP
      DOUBLE PRECISION CC
      DOUBLE PRECISION DD
      DOUBLE PRECISION EE
      DIMENSION P1(L,1),P2(L,1),P3(ID,1),PHZ(L,1),PH1(L,1),CP(1),
     +          THETA(1)

      NMP1 = NM + 1
      IF (INIT.NE.0) GO TO 5
      SSQRT2 = 1.D0/SQRT(2.D0)
      DO 10 I = 1,L
          PHZ(I,1) = SSQRT2
   10 CONTINUE
      DO 15 NP1 = 2,NMP1
          NH = NP1 - 1
          CALL DALFK(NH,0,CP)
          DO 16 I = 1,L
              CALL DLFPT(NH,0,THETA(I),CP,PHZ(I,NP1))
   16     CONTINUE
          CALL DALFK(NH,1,CP)
          DO 17 I = 1,L
              CALL DLFPT(NH,1,THETA(I),CP,PH1(I,NP1))
   17     CONTINUE
   15 CONTINUE
      RETURN
    5 IF (N.GT.2) GO TO 60
      IF (N-1) 25,30,35
   25 DO 45 I = 1,L
          P3(I,1) = PHZ(I,1)
   45 CONTINUE
      RETURN
   30 DO 50 I = 1,L
          P3(I,1) = PHZ(I,2)
          P3(I,2) = PH1(I,2)
   50 CONTINUE
      RETURN
   35 SQ5S6 = SQRT(5.D0/6.D0)
      SQ1S6 = SQRT(1.D0/6.D0)
      DO 55 I = 1,L
          P3(I,1) = PHZ(I,3)
          P3(I,2) = PH1(I,3)
          P3(I,3) = SQ5S6*PHZ(I,1) - SQ1S6*P3(I,1)
          P1(I,1) = PHZ(I,2)
          P1(I,2) = PH1(I,2)
          P2(I,1) = PHZ(I,3)
          P2(I,2) = PH1(I,3)
          P2(I,3) = P3(I,3)
   55 CONTINUE
      RETURN
   60 NM1 = N - 1
      NP1 = N + 1
      FN = DBLE(N)
      TN = FN + FN
      CN = (TN+1.D0)/ (TN-3.D0)
      DO 65 I = 1,L
          P3(I,1) = PHZ(I,NP1)
          P3(I,2) = PH1(I,NP1)
   65 CONTINUE
      IF (NM1.LT.3) GO TO 71
      DO 70 MP1 = 3,NM1
          M = MP1 - 1
          FM = DBLE(M)
          FNPM = FN + FM
          FNMM = FN - FM
          TEMP = FNPM* (FNPM-1.D0)
          CC = SQRT(CN* (FNPM-3.D0)* (FNPM-2.D0)/TEMP)
          DD = SQRT(CN*FNMM* (FNMM-1.D0)/TEMP)
          EE = SQRT((FNMM+1.D0)* (FNMM+2.D0)/TEMP)
          DO 70 I = 1,L
              P3(I,MP1) = CC*P1(I,MP1-2) + DD*P1(I,MP1) - EE*P3(I,MP1-2)
   70 CONTINUE
   71 FNPM = FN + FN - 1.D0
      TEMP = FNPM* (FNPM-1.D0)
      CC = SQRT(CN* (FNPM-3.D0)* (FNPM-2.D0)/TEMP)
      EE = SQRT(6.D0/TEMP)
      DO 75 I = 1,L
          P3(I,N) = CC*P1(I,N-2) - EE*P3(I,N-2)
   75 CONTINUE
      FNPM = FN + FN
      TEMP = FNPM* (FNPM-1.D0)
      CC = SQRT(CN* (FNPM-3.D0)* (FNPM-2.D0)/TEMP)
      EE = SQRT(2.D0/TEMP)
      DO 80 I = 1,L
          P3(I,N+1) = CC*P1(I,N-1) - EE*P3(I,N-1)
   80 CONTINUE
      DO 90 MP1 = 1,NP1
          DO 90 I = 1,L
              P1(I,MP1) = P2(I,MP1)
              P2(I,MP1) = P3(I,MP1)
   90 CONTINUE
      RETURN
      END
c subroutine lfin (init,theta,l,m,nm,pb,id,wlfin)
c
c dimension of           theta(l),  pb(id,nm+1),  wlfin(4*l*(nm+1))
c arguments
c
c purpose                given m and l, routine lfin calculates
c                        the normalized associated legendre functions
c                        pbar(n,m,theta) for n=m,...,nm and theta(i)
c                        for i=1,...,l where
c
c                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative of
c                        (x**2-1)**n with respect to x=cos(theta)
c
c usage                  call lfin (init,theta,l,m,nm,pb,id,wlfin)
c
c arguments
c on input               init
c                        = 0
c                            initialization only - using parameters
c                            l, nm and the array theta, subroutine lfin
c                            initializes the array wlfin for subsequent
c                            use in the computation of the associated
c                            legendre functions pb. initialization does
c                            not have to be repeated unless l, nm or
c                            the array theta are changed.
c                        = 1
c                            subroutine lfin uses the array wlfin that
c                            was computed with init = 0 to compute pb
c
c                        theta
c                          an array that contains the colatitudes
c                          at which the associated legendre functions
c                          will be computed. the colatitudes must be
c                          specified in radians.
c
c                        l
c                          the length of the theta array. lfin is
c                          vectorized with vector length l.
c
c                        m
c                          nonnegative integer, less than nm, specifying
c                          degree of pbar(n,m,theta). subroutine lfin
c                          must be called starting with n=0. n must be
c                          incremented by one in subsequent calls and
c                          must not exceed nm.
c
c                        nm
c                          the maximum value of n and m
c
c                        id
c                          the first dimension of the two dimensional
c                          array pb as it appears in the program that
c                          calls lfin. (see output parameter pb)
c
c                        wlfin
c                          an array with length 4*l*(nm+1) which
c                          must be initialized by calling lfin
c                          with init=0 (see parameter init)  it
c                          must not be altered between calls to
c                          lfin.
c
c
c on output              pb
c                          a two dimensional array with first
c                          dimension id in the program that calls
c                          lfin. the second dimension of pb must
c                          be at least nm+1. starting with m=0
c                          lfin is called repeatedly with m being
c                          increased by one between calls. on each
c                          call, subroutine lfin computes pb(i,n+1)
c                          = pbar(m,n,theta(i)) for n=m,...,nm and
c                          i=1,...l.
c
c                        wlfin
c                          array containing values which must not
c                          be altered unless l, nm or the array theta
c                          are changed in which case lfin must be
c                          called with init=0 to reinitialize the
c                          wlfin array.
c
c special conditions     m must be increased by one between calls
c                        of lfin in which m is not zero.
c
c precision              single
c
c algorithm              routine lfin calculates pbar(n,m,theta) using
c                        a four term recurrence relation. (unpublished
c                        notes by paul n. swarztrauber)
c
      SUBROUTINE DLFIN(INIT,THETA,L,M,NM,PB,ID,WLFIN)
      DOUBLE PRECISION THETA
      DOUBLE PRECISION PB
      DOUBLE PRECISION WLFIN
      DIMENSION PB(1),WLFIN(1)
c
c     total length of wlfin is 4*l*(nm+1)
c
      LNX = L* (NM+1)
      IW1 = LNX + 1
      IW2 = IW1 + LNX
      IW3 = IW2 + LNX
      CALL DLFIN1(INIT,THETA,L,M,NM,ID,PB,WLFIN,WLFIN(IW1),WLFIN(IW2),
     +           WLFIN(IW3),WLFIN(IW2))
      RETURN
      END
      SUBROUTINE DLFIN1(INIT,THETA,L,M,NM,ID,P3,PHZ,PH1,P1,P2,CP)
      DOUBLE PRECISION THETA
      DOUBLE PRECISION P3
      DOUBLE PRECISION PHZ
      DOUBLE PRECISION PH1
      DOUBLE PRECISION P1
      DOUBLE PRECISION P2
      DOUBLE PRECISION CP
      DOUBLE PRECISION SSQRT2
      DOUBLE PRECISION FM
      DOUBLE PRECISION TM
      DOUBLE PRECISION TEMP
      DOUBLE PRECISION CC
      DOUBLE PRECISION EE
      DOUBLE PRECISION FN
      DOUBLE PRECISION TN
      DOUBLE PRECISION CN
      DOUBLE PRECISION FNPM
      DOUBLE PRECISION FNMM
      DOUBLE PRECISION DD
      DIMENSION P1(L,1),P2(L,1),P3(ID,1),PHZ(L,1),PH1(L,1),CP(1),
     +          THETA(1)

      NMP1 = NM + 1
      IF (INIT.NE.0) GO TO 5
      SSQRT2 = 1.D0/SQRT(2.D0)
      DO 10 I = 1,L
          PHZ(I,1) = SSQRT2
   10 CONTINUE
      DO 15 NP1 = 2,NMP1
          NH = NP1 - 1
          CALL DALFK(NH,0,CP)
          DO 16 I = 1,L
              CALL DLFPT(NH,0,THETA(I),CP,PHZ(I,NP1))
   16     CONTINUE
          CALL DALFK(NH,1,CP)
          DO 17 I = 1,L
              CALL DLFPT(NH,1,THETA(I),CP,PH1(I,NP1))
   17     CONTINUE
   15 CONTINUE
      RETURN
    5 MP1 = M + 1
      FM = DBLE(M)
      TM = FM + FM
      IF (M-1) 25,30,35
   25 DO 45 NP1 = 1,NMP1
          DO 45 I = 1,L
              P3(I,NP1) = PHZ(I,NP1)
              P1(I,NP1) = PHZ(I,NP1)
   45 CONTINUE
      RETURN
   30 DO 50 NP1 = 2,NMP1
          DO 50 I = 1,L
              P3(I,NP1) = PH1(I,NP1)
              P2(I,NP1) = PH1(I,NP1)
   50 CONTINUE
      RETURN
   35 TEMP = TM* (TM-1.D0)
      CC = SQRT((TM+1.D0)* (TM-2.D0)/TEMP)
      EE = SQRT(2.D0/TEMP)
      DO 85 I = 1,L
          P3(I,M+1) = CC*P1(I,M-1) - EE*P1(I,M+1)
   85 CONTINUE
      IF (M.EQ.NM) RETURN
      TEMP = TM* (TM+1.D0)
      CC = SQRT((TM+3.D0)* (TM-2.D0)/TEMP)
      EE = SQRT(6.D0/TEMP)
      DO 70 I = 1,L
          P3(I,M+2) = CC*P1(I,M) - EE*P1(I,M+2)
   70 CONTINUE
      MP3 = M + 3
      IF (NMP1.LT.MP3) GO TO 80
      DO 75 NP1 = MP3,NMP1
          N = NP1 - 1
          FN = DBLE(N)
          TN = FN + FN
          CN = (TN+1.D0)/ (TN-3.D0)
          FNPM = FN + FM
          FNMM = FN - FM
          TEMP = FNPM* (FNPM-1.D0)
          CC = SQRT(CN* (FNPM-3.D0)* (FNPM-2.D0)/TEMP)
          DD = SQRT(CN*FNMM* (FNMM-1.D0)/TEMP)
          EE = SQRT((FNMM+1.D0)* (FNMM+2.D0)/TEMP)
          DO 75 I = 1,L
              P3(I,NP1) = CC*P1(I,NP1-2) + DD*P3(I,NP1-2) - EE*P1(I,NP1)
   75 CONTINUE
   80 DO 90 NP1 = M,NMP1
          DO 90 I = 1,L
              P1(I,NP1) = P2(I,NP1)
              P2(I,NP1) = P3(I,NP1)
   90 CONTINUE
      RETURN
      END
c subroutine lfpt (n,m,theta,cp,pb)
c
c dimension of
c arguments
c                        cp((n/2)+1)
c
c purpose                routine lfpt uses coefficients computed by
c                        routine alfk to compute the single precision
c                        normalized associated legendre function pbar(n,
c                        m,theta) at colatitude theta.
c
c usage                  call lfpt(n,m,theta,cp,pb)
c
c arguments
c
c on input               n
c                          nonnegative integer specifying the degree of
c                          pbar(n,m,theta)
c                        m
c                          is the order of pbar(n,m,theta). m can be
c                          any integer however pbar(n,m,theta) = 0
c                          if abs(m) is greater than n and
c                          pbar(n,m,theta) = (-1)**m*pbar(n,-m,theta)
c                          for negative m.
c
c                        theta
c                          single precision colatitude in radians
c
c                        cp
c                          single precision array of length (n/2)+1
c                          containing coefficients computed by routine
c                          alfk
c
c on output              pb
c                          single precision variable containing
c                          pbar(n,m,theta)
c
c special conditions     calls to routine lfpt must be preceded by an
c                        appropriate call to routine alfk.
c
c precision              single
c
c algorithm              the trigonometric series formula used by
c                        routine lfpt to calculate pbar(n,m,th) at
c                        colatitude th depends on m and n as follows:
c
c                           1) for n even and m even, the formula is
c                              .5*cp(1) plus the sum from k=1 to k=n/2
c                              of cp(k)*cos(2*k*th)
c                           2) for n even and m odd. the formula is
c                              the sum from k=1 to k=n/2 of
c                              cp(k)*sin(2*k*th)
c                           3) for n odd and m even, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*cos((2*k-1)*th)
c                           4) for n odd and m odd, the formula is
c                              the sum from k=1 to k=(n+1)/2 of
c                              cp(k)*sin((2*k-1)*th)
c
c accuracy               comparison between routines lfpt and double
c                        precision dlfpt on the cray1 indicates greater
c                        accuracy for greater values on input parameter
c                        n.  agreement to 13 places was obtained for
c                        n=10 and to 12 places for n=100.
c
c timing                 time per call to routine lfpt is dependent on
c                        the input parameter n.
c
      SUBROUTINE DLFPT(N,M,THETA,CP,PB)
      DOUBLE PRECISION THETA
      DOUBLE PRECISION CP
      DOUBLE PRECISION PB
      DOUBLE PRECISION CDT
      DOUBLE PRECISION SDT
      DOUBLE PRECISION CT
      DOUBLE PRECISION ST
      DOUBLE PRECISION SUM
      DOUBLE PRECISION CTH
      DIMENSION CP(1)
c
      PB = 0.D0
      MA = IABS(M)
      IF (MA.GT.N) RETURN
      IF (N) 10,10,30
   10 IF (MA) 20,20,30
   20 PB = SQRT(.5D0)
      GO TO 140
   30 NP1 = N + 1
      NMOD = MOD(N,2)
      MMOD = MOD(MA,2)
      IF (NMOD) 40,40,90
   40 IF (MMOD) 50,50,70
   50 KDO = N/2 + 1
      CDT = COS(THETA+THETA)
      SDT = SIN(THETA+THETA)
      CT = 1.D0
      ST = 0.D0
      SUM = .5D0*CP(1)
      DO 60 KP1 = 2,KDO
          CTH = CDT*CT - SDT*ST
          ST = SDT*CT + CDT*ST
          CT = CTH
          SUM = SUM + CP(KP1)*CT
   60 CONTINUE
      PB = SUM
      GO TO 140
   70 KDO = N/2
      CDT = COS(THETA+THETA)
      SDT = SIN(THETA+THETA)
      CT = 1.D0
      ST = 0.D0
      SUM = 0.D0
      DO 80 K = 1,KDO
          CTH = CDT*CT - SDT*ST
          ST = SDT*CT + CDT*ST
          CT = CTH
          SUM = SUM + CP(K)*ST
   80 CONTINUE
      PB = SUM
      GO TO 140
   90 KDO = (N+1)/2
      IF (MMOD) 100,100,120
  100 CDT = COS(THETA+THETA)
      SDT = SIN(THETA+THETA)
      CT = COS(THETA)
      ST = -SIN(THETA)
      SUM = 0.D0
      DO 110 K = 1,KDO
          CTH = CDT*CT - SDT*ST
          ST = SDT*CT + CDT*ST
          CT = CTH
          SUM = SUM + CP(K)*CT
  110 CONTINUE
      PB = SUM
      GO TO 140
  120 CDT = COS(THETA+THETA)
      SDT = SIN(THETA+THETA)
      CT = COS(THETA)
      ST = -SIN(THETA)
      SUM = 0.D0
      DO 130 K = 1,KDO
          CTH = CDT*CT - SDT*ST
          ST = SDT*CT + CDT*ST
          CT = CTH
          SUM = SUM + CP(K)*ST
  130 CONTINUE
      PB = SUM
  140 RETURN
      END


subroutine vecuni(n,v,mod)

!-----------------------------------------------------------------------
!
! This routine computes the length of vector V and converts it to
! a unit one
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in) :: n
  real(rp), intent(out)   :: v(n),mod
  integer(ip)             :: i

  mod=0.0_rp
  do i=1,n
     mod=mod + v(i)*v(i)
  end do
  mod=sqrt(mod)
  if(mod>1.0e-8) v=v/mod

end subroutine vecuni


	SUBROUTINE UT_85DY  ( r85day, irptdt, iret )
C************************************************************************
C* UT_85DY								*
C*									*
C* This routine computes and returns the report date-time corresponding	*
C* to the "1985 Day" in the original report.  The "1985 Day" is a count	*
C* of the number of days elapsed since 1/1/1985, 0000Z; for example:	*
C*	at 1/1/1985, 0000Z, the "1985 Day" is 0.00,			*
C*	at 1/2/1985, 0000Z, the "1985 Day" is 1.00,			*
C*	at 1/3/1985, 0000Z, the "1985 Day" is 2.00,			*
C*	at 1/3/1985, 1200Z, the "1985 Day" is 2.50, etc.		*
C*									*
C* UT_85DY ( R85DAY, IRPTDT, IRET )					*
C*									*
C* Input parameters:							*
C*	R85DAY		REAL*8		# of days since 1/1/1985, 0000Z	*
C*									*
C* Output parameters:							*
C*	IRPTDT (*)	INTEGER		Report date-time		*
C*					(YYYY, MM, DD, HH, MM ) 	*
C*	IRET		INTEGER		Return code:			*
C*					  0 = normal return		*
C*					 -1 = could not compute IRPTDT	*
C*									*
C**									*
C* Log:									*
C* J. Ator/NCEP		01/01						*
C* J. Ator/NCEP		06/01	Fixed error in docblock			*
C* R. Hollern/NCEP	07/02	Adapted from NA_85DY			*
C* R. Hollern/NCEP	04/03	Added logic to handle the case when the *
C*				computed report time hour is 24		*
C************************************************************************
	INTEGER		irptdt (*),  jrptdt (5)
	INTEGER		iwkdt (3)
C*
	real*8		r85day
C*
	LOGICAL		gotyr
C*-----------------------------------------------------------------------
	iret = -1
C
C*	Beginning with 1985, determine how many days are in each
C*	successive year, and continue doing so until the cumulative sum
C*	is greater than or equal to the whole (i.e. integer) portion of
C*	the "1985 Day".  The last year for which a count was determined
C*	is then equal to the year of the report.
C
	iwk85d = INT ( r85day )
C
	iwkdt (1) = 1985
	iwkdt (2) = 12
	iwkdt (3) = 31
C
	gotyr = .false.
	DO WHILE  ( .not. gotyr )
	    CALL TI_ITOJ  ( iwkdt, iwkyr, ijday, iertoj )
C
C*	    Note that 1/1/1985 represents day 0 (not day 1), so we need
C*	    to decrement by 1 our count of the number of days for that
C*	    particular year.
C
	    IF  ( iwkdt (1) .eq. 1985 )  ijday = ijday - 1
C
	    IF  ( ijday .lt. iwk85d )  THEN
		iwk85d = iwk85d - ijday
		iwkdt (1) = iwkdt (1) + 1
	    ELSE
		gotyr = .true.
		irptdt (1) = iwkdt (1)
	    END IF
	END DO
C
C*	Now, determine the month and day of the report by using the
C*	remaining number of days that was leftover from the previous
C*	determination of the year of the report.
C
	CALL TI_JTOI  ( irptdt (1), iwk85d, iwkdt, iertoi )
	IF  ( iertoi .ne. 0 )  THEN
	    RETURN
	END IF
	irptdt (2) = iwkdt (2)
	irptdt (3) = iwkdt (3)
C
C*	Now, use the fractional portion of the "1985 Day" to determine
C*	the hour and minute of the report.
C
	nmins = NINT ( ( r85day - FLOAT ( INT ( r85day ) ) ) * 1440. )
	irptdt (4) = nmins / 60
	irptdt (5) = MOD ( nmins, 60 )
C
C*	Check if hour is 24.  If it is, set hour to 00 and add a day
C*	to the date.
C
	IF ( irptdt (4) .eq. 24 ) THEN
C
	   irptdt (4) = 0
C
	   CALL TI_ADDD ( irptdt, jrptdt, iret )
C
C*	   IF ( iret .ne. 0 ) RETURN
C
	   irptdt (1) = jrptdt(1)
	   irptdt (2) = jrptdt(2)
	   irptdt (3) = jrptdt(3)
	END IF
C
	iret = 0
C*
	RETURN
	END


!**
!* Provides functions to produce linearly and exponentially spaced grids
!**
module grids
    use kinds, only: dp
    implicit none
    private
    public :: build_grid

    contains

        ! **
        ! * Searches for the root of the function f(x, [p2,p3,p4,p5])-offset_in.
        ! *
        ! * Input:
        ! *     - grid_length: the length of the grid to be produces
        ! *     - min: the value of the first (lowest value) point in the grid
        ! *     - max: the value of the last (highest value) point in the grid
        ! *     - expg_in (optional): specifies the order of the exponential spacing of the grid. Default is 0, which
        ! *       corresponds to a linear spacing of the grid (uniform grid). A value of 1 means an exponential grid,
        ! *       a value of 2 corresponds to a double exponential grid, and so on.
        ! *
        ! * Return value: the grid
        ! **
        function build_grid(grid_length,min,max,expg_in) result(grid)
            integer, intent(in)              :: grid_length
            real(dp), intent(in)             :: min,max
            integer, intent(in), optional    :: expg_in
            integer                          :: expg,i,e
            real(dp), dimension(grid_length) :: grid
            real(dp)                         :: v1,v2,step

            if (present(expg_in)) then
                expg = expg_in
            else
                expg = 0
            end if

            v1 = min
            v2 = max

            ! Loglinearize
            do e=1,expg
                v1 = log(v1+1)
                v2 = log(v2+1)
            end do

            step = (v2-v1) / (grid_length-1)
            do i=2,grid_length
                grid(i) = v1 + (i-1)*step
            end do

            ! Exp
            do e=1,expg
                grid = exp(grid)-1
            end do

            grid(1) = min
            grid(grid_length) = max

        end function build_grid
end module


!     This version solves the Schroedinger equation for the
!     one-dimensional
!     harmonic oscillator using matrix diagonalization

!     declaration of constants used in the calculations
!     define variables, where we have chosen to use atomic units for
!     m=c=hbar=k=1.

MODULE parameters
  USE constants
  !  the step
  REAL(DP), PUBLIC :: step
  !  r min
  REAL(DP), PUBLIC, PARAMETER :: rmin=-10.0_dp
  !  r max
  REAL(DP), PUBLIC, PARAMETER :: rmax=10.0_dp
  !  number of steps from rmin to rmin to rmax
  INTEGER, PUBLIC, PARAMETER ::  max_step=1000
  !  size of matrix to be diagonalized, do not need points at rmin and rmax
  INTEGER, PUBLIC, PARAMETER ::  n=998
END MODULE parameters

!  main program starts here

PROGRAM schroedinger_equation
  USE constants
  USE parameters
  USE f90library
  IMPLICIT NONE
  REAL(DP) :: potential, const1, const2
  REAL(DP), DIMENSION(:), ALLOCATABLE :: w, r
  REAL(DP), ALLOCATABLE, DIMENSION(:) :: e, d
  REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: z
  INTEGER :: i

  !  reserve place in memory for the arrays w, r, e, d and z

  ALLOCATE ( e(n) , d(n))
  ALLOCATE ( w(0:max_step), r(0:max_step))

  !  define the step size

  step=(rmax-rmin)/FLOAT(max_step)

  !  define constants for the matrix to be diagonalized

  const1=2./(step*step)
  const2=-1./(step*step)

  !     set up r and the function w for energy =0
  !     w corresponds then to the potential
  !  values at

  DO i=0, max_step
     r(i) = rmin+i*step
     w(i) = potential(r(i))
  ENDDO

  !     setup the diagonal d and the non-diagonal part e  of
  !     the  tri-diagonal matrix to be diagonalized

  d(1:n)=const1+w(1:n)  ;  e(1:n)=const2

  !  allocate space for eigenvector info

  ALLOCATE ( z(n,n) )

  !  obtain the eigenvalues

  CALL tqli(d,e,n,z)

  !  sort eigenvalues as an ascending series

  CALL eigenvalue_sort(d,n)

  !  write out

  WRITE(6,*) ' Rmin and Rmax ', rmin, rmax
  WRITE(6,*) ' Number of steps -1 ', n
  WRITE(6,*) ' The 5 lowest eigenvalues '
  WRITE(6,'(5F12.6)') d(1:5)

  !  find the wave function for the lowest lying state

  CALL plot(d(1), w, r)

  !  deallocate space in memory

  DEALLOCATE (z)
  DEALLOCATE ( w, r, d, e)

END PROGRAM schroedinger_equation

!  Harmonic oscillator potential

REAL(DP) FUNCTION potential(x)
  USE constants
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: x

  potential=x*x

END FUNCTION  potential

!
!           Sort the eigenvalues as
!           ascending series
!

SUBROUTINE eigenvalue_sort(e,n)
  USE constants
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: n
  INTEGER :: i, j
  REAL(DP), DIMENSION(n), INTENT(INOUT) :: e
  REAL(DP) :: temp

  DO i = 1, n
     DO j =i, n
        IF( ABS(e(i)) >   ABS(e(j)) ) THEN
           ! change the energy
           temp=e(i)
           e(i)=e(j)
           e(j)=temp
        ENDIF
     ENDDO
  ENDDO

END SUBROUTINE eigenvalue_sort

!  This function plots the wave function at the final energy

SUBROUTINE plot(energy, w ,r )
  USE constants
  USE parameters
  IMPLICIT NONE
  INTEGER :: i, match
  REAL(DP), DIMENSION(n) :: w, r
  REAL(DP), DIMENSION(:), ALLOCATABLE :: wf
  REAL(DP) :: energy, wwf, fac, norm, pi

  ALLOCATE ( wf(0:max_step))
  pi=ACOS(-1.) ; pi=SQRT(pi)

  !  add the chosen energy to the potential

  w=(w-energy)*step*step+2

  !  Boundary conditions
  !  value of the wave function at max step

  wf(max_step)=0.

  !  here we use the analytical form for the wave function for max step -1
  !  (taylor expansion of EXP(-r^2/2))

  wf(max_step-1)=step**2/2.

  !  start from right and move towards rmin

  OUTER_TO_INNER : DO
     DO i=max_step-2, 1, -1
        wf(i)=w(i+1)*wf(i+1)-wf(i+2)
        !  find point were the outer part starts turning in order to determine matching point
        IF ( wf(i) <=  wf(i+1) ) EXIT OUTER_TO_INNER
     ENDDO
  ENDDO OUTER_TO_INNER
  match = i+1
  wwf=wf(match)

  !  start from rmin  and move towards the matching point

  wf(0)=0.
  wf(1)=step**2/2.
  DO i=2, match
     wf(i)=w(i-1)*wf(i-1)-wf(i-2)
  ENDDO

  !  scale the wave function below the matching point

  fac=wwf/wf(match)
  wf(0:match)=wf(0:match)*fac

  !  normalize the wave function

  norm=step*SUM(wf*wf)
  IF ( norm > 0. ) norm = 1./SQRT(norm)
  wf=wf*norm
  WRITE(6,*) norm
  !  write out of numerically calculated and analytical expression for the wave functions

  WRITE(6,'(E12.6,2X,E12.6,2X,E12.6)')( r(i), wf(i), EXP(-(r(i)**2)/2.0_dp)/SQRT(pi),i=1, max_step)
  DEALLOCATE ( wf)

END SUBROUTINE plot


*DECK RJ
      REAL FUNCTION RJ (X, Y, Z, P, IER)
C***BEGIN PROLOGUE  RJ
C***PURPOSE  Compute the incomplete or complete (X or Y or Z is zero)
C            elliptic integral of the 3rd kind.  For X, Y, and Z non-
C            negative, at most one of them zero, and P positive,
C             RJ(X,Y,Z,P) = Integral from zero to infinity of
C                                  -1/2     -1/2     -1/2     -1
C                        (3/2)(t+X)    (t+Y)    (t+Z)    (t+P)  dt.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      SINGLE PRECISION (RJ-S, DRJ-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE THIRD KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     RJ
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation result to
C          RJ(X,Y,Z,P) = Integral from zero to infinity of
C
C                                -1/2     -1/2     -1/2     -1
C                      (3/2)(t+X)    (t+Y)    (t+Z)    (t+P)  dt,
C
C          where X, Y, and Z are nonnegative, at most one of them is
C          zero, and P is positive.  If X or Y or Z is zero, the
C          integral is COMPLETE.  The duplication theorem is iterated
C          until the variables are nearly equal, and the function is
C          then expanded in Taylor series to fifth order.
C
C
C   2.     Calling Sequence
C          RJ( X, Y, Z, P, IER )
C
C          Parameters On Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, nonnegative variable
C
C          Z      - Single precision, nonnegative variable
C
C          P      - Single precision, positive variable
C
C
C          On  Return     (values assigned by the RJ routine)
C
C          RJ     - Single precision approximation to the integral
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine.  It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C
C          X, Y, Z, P are unaltered.
C
C
C   3.    Error Messages
C
C         Value of IER assigned by the RJ routine
C
C                  Value Assigned        Error Message Printed
C                  IER = 1               MIN(X,Y,Z) .LT. 0.0E0
C                      = 2               MIN(X+Y,X+Z,Y+Z,P) .LT. LOLIM
C                      = 3               MAX(X,Y,Z,P) .GT. UPLIM
C
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C
C          LOLIM and UPLIM determine the valid range of X Y, Z, and P
C
C          LOLIM is not less than the cube root of the value
C          of LOLIM used in the routine for RC.
C
C          UPLIM is not greater than 0.3 times the cube root of
C          the value of UPLIM used in the routine for RC.
C
C
C                     Acceptable Values For:   LOLIM      UPLIM
C                     IBM 360/370 SERIES   :   2.0E-26     3.0E+24
C                     CDC 6000/7000 SERIES :   5.0E-98     3.0E+106
C                     UNIVAC 1100 SERIES   :   5.0E-13     6.0E+11
C                     CRAY                 :   1.32E-822   1.4E+821
C                     VAX 11 SERIES        :   2.5E-13     9.0E+11
C
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C
C
C          Relative error due to truncation of the series for RJ
C          is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C
C
C
C              The accuracy of the computed approximation to the inte-
C              gral can be controlled by choosing the value of ERRTOL.
C              Truncation of a Taylor series after terms of fifth order
C              Introduces an error less than the amount shown in the
C              second column of the following table for each value of
C              ERRTOL in the first column.  In addition to the trunca-
C              tion error there will be round-off error, but in prac-
C              tice the total error from both sources is usually less
C              than the amount given in the table.
C
C
C
C          Sample choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0E-3    4.0E-18
C                           3.0E-3    3.0E-15
C                           1.0E-2    4.0E-12
C                           3.0E-2    3.0E-9
C                           1.0E-1    4.0E-6
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   RJ Special Comments
C
C
C          Check by addition theorem: RJ(X,X+Z,X+W,X+P)
C          + RJ(Y,Y+Z,Y+W,Y+P) + (A-B) * RJ(A,B,B,A) + 3 / SQRT(A)
C          = RJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y
C          = Z * W,  A = P * P * (X+Y+Z+W),  B = P * (P+X) * (P+Y),
C          and B - A = P * (P-Z) * (P-W).  The sum of the third and
C          fourth terms on the left side is 3 * RC(A,B).
C
C
C          On Input:
C
C          X, Y, Z, and P are the variables in the integral RJ(X,Y,Z,P).
C
C
C          On Output:
C
C
C          X, Y, Z, and P are unaltered.
C
C          ********************************************************
C
C          Warning: Changes in the program may improve speed at the
C                   expense of robustness.
C
C ------------------------------------------------------------
C
C
C   Special Functions via RJ and RF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 3rd kind
C                  ----------------------------------------------
C
C
C                               PHI         2         -1
C                  P(PHI,K,N) = INT (1+N SIN (THETA) )   *
C                                0
C
C                                      2    2         -1/2
C                                 *(1-K  SIN (THETA) )     D THETA
C
C
C                                         2          2   2
C                       = SIN (PHI) RF(COS (PHI), 1-K SIN (PHI),1)
C
C                                  3            2         2   2
C                        -(N/3) SIN (PHI) RJ(COS (PHI),1-K SIN (PHI),
C
C                                 2
C                        1,1+N SIN (PHI))
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind
C                  ----------------------------------------------
C
C
C                                           2 2    2
C                  EL3(X,KC,P) = X RF(1,1+KC X ,1+X ) +
C
C                                            3          2 2    2     2
C                               +(1/3)(1-P) X  RJ(1,1+KC X ,1+X ,1+PX )
C
C
C                                           2
C                  CEL(KC,P,A,B) = A RF(0,KC ,1) +
C
C                                                     2
C                                 +(1/3)(B-PA) RJ(0,KC ,1,P)
C
C
C
C
C                  Heuman's LAMBDA function
C                  ------------------------
C
C
C                                 2                     2      2    1/2
C                  L(A,B,P) = (COS(A)SIN(B)COS(B)/(1-COS (A)SIN (B))   )
C
C                                           2         2       2
C                            *(SIN(P) RF(COS (P),1-SIN (A) SIN (P),1)
C
C                                 2       3            2       2
C                            +(SIN (A) SIN (P)/(3(1-COS (A) SIN (B))))
C
C                                   2         2       2
C                            *RJ(COS (P),1-SIN (A) SIN (P),1,1-
C
C                                2       2          2       2
C                            -SIN (A) SIN (P)/(1-COS (A) SIN (B))))
C
C
C
C
C                  (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) =
C
C
C                    2                         2       2    -1/2
C               = COS (A)  SIN(B) COS(B) (1-COS (A) SIN (B))
C
C                           2                  2       2
C                  *RF(0,COS (A),1) + (1/3) SIN (A) COS (A)
C
C                                       2       2    -3/2
C                  *SIN(B) COS(B) (1-COS (A) SIN (B))
C
C                           2         2       2          2       2
C                  *RJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B)))
C
C
C
C                  Jacobi ZETA function
C                  --------------------
C
C
C                             2                     2   2    1/2
C                  Z(B,K) = (K/3) SIN(B) COS(B) (1-K SIN (B))
C
C
C                                      2      2   2                2
C                             *RJ(0,1-K ,1,1-K SIN (B)) / RF (0,1-K ,1)
C
C
C    -------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  R1MACH, RC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC)).
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RJ
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6, XERN7
      INTEGER IER
      REAL ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3
      REAL LOLIM, UPLIM, EPSLON, ERRTOL
      REAL LAMDA, MU, P, PN, PNDEV
      REAL POWER4, RC, SIGMA, S1, S2, S3, X, XN, XNDEV
      REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  RJ
      IF (FIRST) THEN
         ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0)
         LOLIM  = (5.0E0 * R1MACH(1))**(1.0E0/3.0E0)
         UPLIM  = 0.30E0*( R1MACH(2) / 5.0E0)**(1.0E0/3.0E0)
C
         C1 = 3.0E0/14.0E0
         C2 = 1.0E0/3.0E0
         C3 = 3.0E0/22.0E0
         C4 = 3.0E0/26.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RJ = 0.0E0
      IF (MIN(X,Y,Z).LT.0.0E0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         CALL XERMSG ('SLATEC', 'RJ',
     *      'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 //
     *      ' AND Z = ' // XERN5, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y,Z,P).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') P
         WRITE (XERN7, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'RJ',
     *      'MAX(X,Y,Z,P).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 //
     *      ' AND UPLIM = ' // XERN7, 3, 1)
         RETURN
      ENDIF
C
      IF (MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') P
         WRITE (XERN7, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'RJ',
     *      'MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM WHERE X = ' // XERN3 //
     *      ' Y = ' // XERN4 // ' Z = '  // XERN5 // ' P = ' // XERN6 //
     *      ' AND LOLIM = ', 2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
      PN = P
      SIGMA = 0.0E0
      POWER4 = 1.0E0
C
   30 MU = (XN+YN+ZN+PN+PN)*0.20E0
      XNDEV = (MU-XN)/MU
      YNDEV = (MU-YN)/MU
      ZNDEV = (MU-ZN)/MU
      PNDEV = (MU-PN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV), ABS(PNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT =  SQRT(XN)
      YNROOT =  SQRT(YN)
      ZNROOT =  SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      ALFA = PN*(XNROOT+YNROOT+ZNROOT) + XNROOT*YNROOT*ZNROOT
      ALFA = ALFA*ALFA
      BETA = PN*(PN+LAMDA)*(PN+LAMDA)
      SIGMA = SIGMA + POWER4*RC(ALFA,BETA,IER)
      POWER4 = POWER4*0.250E0
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      ZN = (ZN+LAMDA)*0.250E0
      PN = (PN+LAMDA)*0.250E0
      GO TO 30
C
   40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV
      EB = XNDEV*YNDEV*ZNDEV
      EC = PNDEV*PNDEV
      E2 = EA - 3.0E0*EC
      E3 = EB + 2.0E0*PNDEV*(EA-EC)
      S1 = 1.0E0 + E2*(-C1+0.750E0*C3*E2-1.50E0*C4*E3)
      S2 = EB*(0.50E0*C2+PNDEV*(-C3-C3+PNDEV*C4))
      S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC
      RJ = 3.0E0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU))
      RETURN
      END


subroutine qinit(maxmx, maxmy, meqn, mbc, mx, my, x_low, y_low, dx, dy, q)

! Sets initial conditions for:
!     film height = q(:,:,1);
!     surfactant concentration = q(:,:,2).

    implicit none

    integer, intent(in) :: maxmx, maxmy, meqn, mbc, mx, my
    double precision, intent(in) :: x_low, y_low, dx, dy
    double precision, intent(out) :: q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)

    integer :: i, j, imode, k(4)
    double precision :: x, y, a, b, big_b, c(4), pi=dacos(-1.d0)
    double precision :: heaviside_1mx

    a = 1.d-2
    b = 5.d-2
    big_b = 5.d0

    c(1) = 1.d0
    c(2) = 1.d0
    c(3) = 1.d0
    c(4) = 0.5d0

    k(1) = 2
    k(2) = 5
    k(3) = 7
    k(4) = 20

    do j = 1,my
        y = y_low + (j-0.5d0)*dy
        do i = 1,mx
            x = x_low + (i-0.5d0)*dx

            heaviside_1mx = 0.5d0*(1+tanh(20*(1-x)))

            q(i,j,1) = (1-x**2+b)*heaviside_1mx + b*(1.d0-heaviside_1mx)

            do imode = 1,4
                q(i,j,1) = q(i,j,1) + a * exp(-big_b*(x-1)**2) * c(imode) * cos(k(imode)*y)
            end do

           q(i,j,2) = heaviside_1mx

        end do
    end do

end subroutine qinit


module random_mod
    use, intrinsic :: iso_fortran_env, only : sp => REAL32, dp => REAL64
    implicit none

    private
    public :: random_normal_number

contains

    subroutine random_normal_number(r)
        implicit none
        real(kind=dp), intent(out) :: r
        real(kind=dp), parameter :: pi = acos(-1.0_dp)
        real(kind=dp) :: x1, x2, r_temp
        real(kind=dp), save :: next_r
        logical, save :: prev_ok = .false.

        if (prev_ok) then
            prev_ok = .false.
            r = next_r
        else
            prev_ok = .true.
            call random_number(x1)
            call random_number(x2)
            r_temp = sqrt(-2.0_dp*log(x1))
            next_r = r_temp*cos(2.0_dp*pi*x2)
            r = r_temp*sin(2.0_dp*pi*x2)
        end if
    end subroutine random_normal_number

end module random_mod


submodule(forlab_math) forlab_math_is_close

    use, intrinsic :: ieee_arithmetic, only: ieee_is_nan
    implicit none

contains

    elemental module logical function is_close_rsp(a, b, rel_tol, abs_tol, equal_nan) result(close)
        real(sp), intent(in) :: a, b
        real(sp), intent(in), optional :: rel_tol, abs_tol
        logical, intent(in), optional :: equal_nan
        logical :: equal_nan_

        equal_nan_ = optval(equal_nan, .false.)

        if (ieee_is_nan(a) .or. ieee_is_nan(b)) then
            close = merge(.true., .false., equal_nan_ .and. ieee_is_nan(a) .and. ieee_is_nan(b))
        else
            close = abs(a - b) <= max(abs(optval(rel_tol, 1.0e-9_sp)*max(abs(a), abs(b))), &
                                      abs(optval(abs_tol, 0.0_sp)))
        end if

    end function is_close_rsp
    elemental module logical function is_close_rdp(a, b, rel_tol, abs_tol, equal_nan) result(close)
        real(dp), intent(in) :: a, b
        real(dp), intent(in), optional :: rel_tol, abs_tol
        logical, intent(in), optional :: equal_nan
        logical :: equal_nan_

        equal_nan_ = optval(equal_nan, .false.)

        if (ieee_is_nan(a) .or. ieee_is_nan(b)) then
            close = merge(.true., .false., equal_nan_ .and. ieee_is_nan(a) .and. ieee_is_nan(b))
        else
            close = abs(a - b) <= max(abs(optval(rel_tol, 1.0e-9_dp)*max(abs(a), abs(b))), &
                                      abs(optval(abs_tol, 0.0_dp)))
        end if

    end function is_close_rdp

    elemental module logical function is_close_csp(a, b, rel_tol, abs_tol, equal_nan) result(close)
        complex(sp), intent(in) :: a, b
        real(sp), intent(in), optional :: rel_tol, abs_tol
        logical, intent(in), optional :: equal_nan

        close = is_close_rsp(a%re, b%re, rel_tol, abs_tol, equal_nan) .and. &
                is_close_rsp(a%im, b%im, rel_tol, abs_tol, equal_nan)

    end function is_close_csp
    elemental module logical function is_close_cdp(a, b, rel_tol, abs_tol, equal_nan) result(close)
        complex(dp), intent(in) :: a, b
        real(dp), intent(in), optional :: rel_tol, abs_tol
        logical, intent(in), optional :: equal_nan

        close = is_close_rdp(a%re, b%re, rel_tol, abs_tol, equal_nan) .and. &
                is_close_rdp(a%im, b%im, rel_tol, abs_tol, equal_nan)

    end function is_close_cdp

end submodule forlab_math_is_close


subroutine SphericalCapCoef(coef, theta, lmax, exitstatus)
!------------------------------------------------------------------------------
!
!   This routine will return the coefficients for a spherical
!   cap (located at the north pole) with angular radius theta,
!   using the geodesy 4-pi normalization.
!
!   Calling Parameters
!
!       IN
!           theta       Angular radius of spherical cap in RADIANS.
!
!       OUT
!           coef        m=0 coefficients normalized according to the
!                       geodesy convention, further normalized such
!                       that the degree-0 term is 1. (i.e., function
!                       has an average value of one over the entire
!                       sphere).
!
!       OPTIONAL
!           lmax        Maximum spherical harmonic degree.
!
!       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.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!-------------------------------------------------------------------------------
    use SHTOOLS, only: PlBar
    use ftypes

    implicit none

    real(dp), intent(out) :: coef(:)
    real(dp), intent(in) :: theta
    integer(int32), intent(in), optional :: lmax
    integer(int32), intent(out), optional :: exitstatus
    real(dp) :: x, top, bot, pi
    real(dp), allocatable :: pl(:)
    integer(int32) :: l, lmax2, astat

    if (present(exitstatus)) exitstatus = 0

    pi = acos(-1.0_dp)
    coef = 0.0_dp
    x = cos(theta)

    if (present(lmax) ) then
        lmax2 = lmax

    else
        lmax2 = size(coef) - 1

    end if

    allocate (pl(lmax2+3), stat = astat)

    if(astat /= 0) then
        print*, "Error --- SphericalCapCoef"
        print*, "Unable to allocate array pl", astat
        if (present(exitstatus)) then
            exitstatus = 3
            return
        else
            stop
        end if

    end if

    if (present(exitstatus)) then
        call PlBar(pl, lmax2+2, x, exitstatus = exitstatus)
        if (exitstatus /= 0) return
    else
        call PlBar(pl, lmax2+2, x)
    end if

    coef(1) = 1.0_dp

    bot = pl(1) - pl(2) / sqrt(3.0_dp)

    do l = 1, lmax2
        top = pl(l) / sqrt(dble(2*l-1)) -pl(l+2) / sqrt(dble(2*l+3))
        coef(l+1) = top / (bot * sqrt(dble(2*l+1)))

    end do

    deallocate (pl)

end subroutine SphericalCapCoef