module SWEPlaneSolverModule
!> @file SWEPlaneSolver.f90
!> Data structure for solving the Shallow Water Equations (SWE) in the beta plane.
!> @author Peter Bosler, Sandia National Laboratories Center for Computing Research
!>
!>
!> @defgroup SWEPlaneSolver SWEPlaneSolver
!> Data structure for solving the Shallow Water Equations (SWE) in the beta plane.
!> Used with the @ref PlanarSWE module.
!>
!> The shallow water equations are presented in the detailed description of the @ref PlanarSWE module.  @n
!>
!> Integrals are used to compute the velocity @f$\vec{u}@f$, the double dot product @f$ \nabla\vec{u}:\nabla\vec{u} @f$, and a PSE integral (see @ref PSEDirectSum)
!> approximates the Laplacian of the fluid surface.@n
!> As with the other integrals in LPM, these integrals are computed as a parallel direct summation across all MPI ranks.@n
!> See sweplanesolvermodule::sweplanerhsintegrals.
!>
!> All other terms are computed as ODEs along each particle trajectory; see sweplanesolvermodule::timestepprivate.
!>
!> @{
use NumberKindsModule
use LoggerModule
use UtilitiesModule
use ParticlesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use PSEDirectSumModule
use PlanarSWEModule

implicit none

include 'mpif.h'

private
public SWESolver, New, Delete
public Timestep
public LogStats

!
!----------------
! types and module variables
!----------------
!
type SWESolver
	real(kreal), allocatable :: xStart(:) !< starting x-coordinate of each particle
	real(kreal), allocatable :: yStart(:) !< starting y-coordinate of each particle
	real(kreal), allocatable :: relVortStart(:) !< starting relative vorticity of each particle
	real(kreal), allocatable :: areaStart(:) !< starting area of each particle
	real(kreal), allocatable :: divStart(:) !< starting divergence of each particle
	real(kreal), allocatable :: hStart(:) !< starting depth at each particle
	real(kreal), allocatable :: u(:) !< x-component of fluid velocity
	real(kreal), allocatable :: v(:) !< y-component of fluid velocity
	logical(klog), allocatable :: mask(:) !< mask(i) is .TRUE. if particle i is active
	real(kreal), allocatable :: potVort(:) !< potential vorticity of each particle
	real(kreal), allocatable :: doubleDot(:) !< double dot product of velocity at each particle
	real(kreal), allocatable :: lapSurf(:) !< Laplacian of fluid surface at each particle

	real(kreal), allocatable :: xIn(:)  !< x-coordinate input to RK4
	real(kreal), allocatable :: xStage1(:) !< x-coordinates of each particle at RK4 stage 1
	real(kreal), allocatable :: xStage2(:) !< x-coordinates of each particle at RK4 stage 2
	real(kreal), allocatable :: xStage3(:) !< x-coordinates of each particle at RK4 stage 3
	real(kreal), allocatable :: xStage4(:) !< x-coordinates of each particle at RK4 stage 4
	real(kreal), allocatable :: yIn(:) !< y-coordinate input to RK4
	real(kreal), allocatable :: yStage1(:) !< y-coordinates of each particle at RK4 stage 1
	real(kreal), allocatable :: yStage2(:) !< y-coordinates of each particle at RK4 stage 2
	real(kreal), allocatable :: yStage3(:) !< y-coordinates of each particle at RK4 stage 3
	real(kreal), allocatable :: yStage4(:) !< y-coordinates of each particle at RK4 stage 4
	real(kreal), allocatable :: areaIn(:) !< area input to RK4
	real(kreal), allocatable :: areaStage1(:) !< area of each particle at RK4 stage 1
	real(kreal), allocatable :: areaStage2(:) !< area of each particle at RK4 stage 2
	real(kreal), allocatable :: areaStage3(:) !< area of each particle at RK4 stage 3
	real(kreal), allocatable :: areaStage4(:) !< area of each particle at RK4 stage 4
	real(kreal), allocatable :: relVortIn(:) !< relative vorticity input to RK4
	real(kreal), allocatable :: relVortStage1(:) !< relative vorticity of each particle at RK4 stage 1
	real(kreal), allocatable :: relVortStage2(:) !< relative vorticity of each particle at RK4 stage 2
	real(kreal), allocatable :: relVortStage3(:) !< relative vorticity of each particle at RK4 stage 3
	real(kreal), allocatable :: relVortStage4(:) !< relative vorticity of each particle at RK4 stage 4
	real(kreal), allocatable :: divIn(:) !< divergence input to RK4
	real(kreal), allocatable :: divStage1(:) !< divergence of each particle at RK4 stage 1
	real(kreal), allocatable :: divStage2(:) !< divergence of each particle at RK4 stage 2
	real(kreal), allocatable :: divStage3(:) !< divergence of each particle at RK4 stage 3
	real(kreal), allocatable :: divStage4(:) !< divergence of each particle at RK4 stage 4
	real(kreal), allocatable :: hIn(:) !< depth input to RK4
	real(kreal), allocatable :: hStage1(:) !< depth of each particle at RK4 stage 1
	real(kreal), allocatable :: hStage2(:) !< depth of each particle at RK4 stage 2
	real(kreal), allocatable :: hStage3(:) !< depth of each particle at RK4 stage 3
	real(kreal), allocatable :: hStage4(:) !< depth of each particle at RK4 stage 4

	contains
		final :: deletePrivate
end type

!
!----------------
! Module interfaces
!----------------
!
interface New
	module procedure newPrivate
end interface

interface Delete
	module procedure deletePrivate
end interface

interface Timestep
	module procedure timestepPrivate
end interface

interface LogStats
	module procedure logStatsPrivate
end interface

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28), save :: logKey = 'SWESolver'
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=MAX_STRING_LENGTH) :: logString

contains
!
!----------------
! public methods
!----------------
!

!> @brief Allocates memory for a new SWE Solver.  Initializes the solver to match the current mesh.
!> @param[out] self Target SWE Solver
!> @param[in] plane @ref PlanarSWE mesh
!> @param[in] topoFn bottom topography function, must conform to the numberkindsmodule::scalarFnOf2DSpace interface
subroutine newPrivate( self, plane, topoFn )
	type(SWESolver), intent(out) :: self
	type(SWEMesh), intent(in) :: plane
	procedure(scalarFnOf2dSpace) :: topoFn
	!
	integer(kint) :: i, nP

	if (.NOT. logInit ) call InitLogger(log, procRank)

	nP = plane%mesh%particles%N

	allocate(self%xStart(1:nP))
	allocate(self%yStart(1:nP))
	allocate(self%areaStart(1:nP))
	allocate(self%divStart(1:nP))
	allocate(self%relVortStart(1:nP))
	allocate(self%mask(1:nP))
	allocate(self%u(1:nP))
	allocate(self%v(1:nP))
	allocate(self%potVort(1:nP))
	allocate(self%hStart(1:nP))
	allocate(self%doubleDot(1:nP))
	allocate(self%lapSurf(1:nP))

	allocate(self%xIn(1:nP))
	allocate(self%xStage1(1:nP))
	allocate(self%xStage2(1:nP))
	allocate(self%xStage3(1:nP))
	allocate(self%xStage4(1:nP))
	allocate(self%yIn(1:nP))
	allocate(self%yStage1(1:nP))
	allocate(self%yStage2(1:nP))
	allocate(self%yStage3(1:nP))
	allocate(self%yStage4(1:nP))
	allocate(self%relVortIn(1:nP))
	allocate(self%relVortStage1(1:nP))
	allocate(self%relVortStage2(1:nP))
	allocate(self%relVortStage3(1:nP))
	allocate(self%relVortStage4(1:nP))
	allocate(self%divIn(1:nP))
	allocate(self%divStage1(1:nP))
	allocate(self%divStage2(1:nP))
	allocate(self%divStage3(1:nP))
	allocate(self%divStage4(1:nP))
	allocate(self%areaIn(1:nP))
	allocate(self%areaStage1(1:nP))
	allocate(self%areaStage2(1:nP))
	allocate(self%areaStage3(1:nP))
	allocate(self%areaStage4(1:nP))
	allocate(self%hIn(1:nP))
	allocate(self%hStage1(1:nP))
	allocate(self%hStage2(1:nP))
	allocate(self%hStage3(1:nP))
	allocate(self%hStage4(1:nP))

	self%xStart = plane%mesh%particles%x(1:nP)
	self%yStart = plane%mesh%particles%y(1:nP)
	self%areaStart = plane%mesh%particles%area(1:nP)
	self%relVortStart = plane%relVort%scalar(1:nP)
	self%potVort = plane%potVort%scalar(1:nP)
	self%divStart = plane%divergence%scalar(1:nP)
	self%hStart = plane%h%scalar(1:nP)
	self%u = plane%velocity%xComp(1:nP)
	self%v = plane%velocity%yComp(1:nP)
	self%mask = plane%mesh%particles%isActive(1:nP)

	call SWEPlaneRHSIntegrals( self%u, self%v, self%doubleDot, self%lapSurf, self%xStart, self%yStart, self%relVortStart, &
				self%divStart, self%hStart, topoFn, self%areaStart, self%mask, plane%pseEps, plane%mpiParticles)
end subroutine

subroutine logStatsPrivate(self, aLog)
	type(SWESolver), intent(in) :: self
	type(Logger), intent(inout) :: aLog

	call StartSection(aLog, trim(logKey)//" SWESolver Stats:")

	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "size xStart = ", size(self%xStart))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max xStart = ", maxval(self%xStart))

	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "size yStart = ", size(self%yStart))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max yStart = ", maxval(self%yStart))

	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "size u = ", size(self%u))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max u = ", maxval(self%u))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "size v = ", size(self%v))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max v = ", maxval(self%v))

	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "size doubleDot = ", size(self%doubleDot))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max doubleDot = ", maxval(self%doubleDot))

	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "size lapSurf = ", size(self%lapSurf))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max lapSurf = ", maxval(self%lapSurf))

	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "size relVortStart = ", size(self%relVortStart))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max relVortStart = ", maxval(self%relVortStart))

	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "size hStart = ", size(self%hStart))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max hStart = ", maxval(self%hStart))

	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "size areaStart = ", size(self%areaStart))
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "max areaStart = ", maxval(self%areaStart))

	call EndSection(aLog)
end subroutine

!> @brief Deletes and frees memory associated with an SWESolver.
!> @param[inout] self Solver
subroutine deletePrivate(self)
	type(SWESolver), intent(inout) :: self
	if ( allocated(self%xStart)) then
		deallocate(self%xStart)
		deallocate(self%yStart)
		deallocate(self%areaStart)
		deallocate(self%divStart)
		deallocate(self%relVortStart)
		deallocate(self%mask)
		deallocate(self%u)
		deallocate(self%v)
		deallocate(self%potVort)
		deallocate(self%hStart)
		deallocate(self%doubleDot)
		deallocate(self%lapSurf)

		deallocate(self%xIn)
		deallocate(self%xStage1)
		deallocate(self%xStage2)
		deallocate(self%xStage3)
		deallocate(self%xStage4)
		deallocate(self%yIn)
		deallocate(self%yStage1)
		deallocate(self%yStage2)
		deallocate(self%yStage3)
		deallocate(self%yStage4)
		deallocate(self%relVortIn)
		deallocate(self%relVortStage1)
		deallocate(self%relVortStage2)
		deallocate(self%relVortStage3)
		deallocate(self%relVortStage4)
		deallocate(self%divIn)
		deallocate(self%divStage1)
		deallocate(self%divStage2)
		deallocate(self%divStage3)
		deallocate(self%divStage4)
		deallocate(self%areaIn)
		deallocate(self%areaStage1)
		deallocate(self%areaStage2)
		deallocate(self%areaStage3)
		deallocate(self%areaStage4)
		deallocate(self%hIn)
		deallocate(self%hStage1)
		deallocate(self%hStage2)
		deallocate(self%hStage3)
		deallocate(self%hStage4)
	endif
end subroutine

!> @brief Advances a SWE mesh forward in time by one timestep using 4th order Runge-Kutta.
!> @param[inout] self SWE solver
!> @param[inout] plane @ref PlanarSWE mesh
!> @param[in] dt timestep increment
!> @param[in] topoFn bottom topography function, must conform to the numberkindsmodule::scalarFnOf2DSpace interface
subroutine timestepPrivate( self, plane, dt, topoFn )
	type(SWESolver), intent(inout) :: self
	type(SWEMesh), intent(inout) :: plane
	real(kreal), intent(in) :: dt
	procedure(scalarFnOf2dSpace) :: topoFn
	!
	integer(kint) :: i, nP

	nP = plane%mesh%particles%N
	!
	!	RK Stage 1
	!
	do i = 1, nP
		self%xStage1(i) = dt * self%u(i)
		self%yStage1(i) = dt * self%v(i)
		self%relVortStage1 = dt * ( - (self%relVortStart(i) + plane%f0 + plane%beta * self%yStart(i)) * self%divStart(i) - &
			plane%beta * self%v(i) )
		self%divStage1 = dt * ( - self%doubleDot(i) + ( plane%f0 + plane%beta * self%yStart(i)) * self%relVortStart(i) - &
			plane%g * self%lapSurf(i) )
		self%hStage1(i) = dt * ( - self%hStart(i) * self%divStart(i))
		self%areaStage1(i) = dt * ( self%areaStart(i) * self%divStart(i))
	enddo

	!
	!	RK Stage 2
	!
	do i = 1, nP
		self%xIn(i) = self%xStart(i) + 0.5_kreal * self%xStage1(i)
		self%yIn(i) = self%yStart(i) + 0.5_kreal * self%yStage1(i)
		self%relVortIn(i) = self%relVortStart(i) + 0.5_kreal * self%relVortStage1(i)
		self%divIn(i) = self%divStart(i) + 0.5_kreal * self%divStage1(i)
		self%areaIn(i) = self%areaStart(i) + 0.5_kreal * self%areaStage1(i)
		self%hIn(i) = self%hStart(i) + 0.5_kreal * self%hStage1(i)
	enddo

	call SWEPlaneRHSIntegrals( self%u, self%v, self%doubleDot, self%lapSurf, self%xIn, self%yIn, self%relVortIn, &
				self%divIn, self%hIn, topoFn, self%areaIn, self%mask, plane%pseEps, plane%mpiParticles)

	do i = 1, nP
		self%xStage2(i) = dt * self%u(i)
		self%yStage2(i) = dt * self%v(i)
		self%relVortStage2(i) = dt * ( - (self%relVortIn(i) + plane%f0 + plane%beta * self%yIn(i)) * self%divIn(i) - &
			plane%beta * self%v(i) )
		self%divStage2(i) = dt * ( - self%doubleDot(i) + (plane%f0 + plane%beta * self%yIn(i)) * self%relVortIn(i)  - &
			plane%g * self%lapSurf(i) )
		self%hStage2(i) = dt * ( - self%hIn(i) * self%divIn(i) )
		self%areaStage2(i) = dt * ( self%areaIn(i) * self%divIn(i) )
	enddo

	!
	! RK Stage 3
	!
	do i = 1, nP
		self%xIn(i) = self%xStart(i) + 0.5_kreal * self%xStage2(i)
		self%yIn(i) = self%yStart(i) + 0.5_kreal * self%yStage2(i)
		self%relVortIn(i) = self%relVortStart(i) + 0.5_kreal * self%relVortStage2(i)
		self%divIn(i) = self%divStart(i) + 0.5_kreal * self%divStage2(i)
		self%areaIn(i) = self%areaStart(i) + 0.5_kreal * self%areaStage2(i)
		self%hIn(i) = self%hStart(i) + 0.5_kreal * self%hStage2(i)
	enddo

	call SWEPlaneRHSIntegrals( self%u, self%v, self%doubleDot, self%lapSurf, self%xIn, self%yIn, self%relVortIn, &
				self%divIn, self%hIn, topoFn, self%areaIn, self%mask, plane%pseEps, plane%mpiParticles)

	do i = 1, nP
		self%xStage3(i) = dt * self%u(i)
		self%yStage3(i) = dt * self%v(i)
		self%relVortStage3(i) = dt * ( - (self%relVortIn(i) + plane%f0 + plane%beta * self%yIn(i)) * self%divIn(i) - &
			plane%beta * self%v(i) )
		self%divStage3(i) = dt * ( - self%doubleDot(i) + (plane%f0 + plane%beta * self%yIn(i)) * self%relVortIn(i)  - &
			plane%g * self%lapSurf(i) )
		self%hStage3(i) = dt * ( - self%hIn(i) * self%divIn(i) )
		self%areaStage3(i) = dt * ( self%areaIn(i) * self%divIn(i) )
	enddo

	!
	! RK Stage 4
	!
	do i = 1, nP
		self%xIn(i) = self%xStart(i) + self%xStage3(i)
		self%yIn(i) = self%yStart(i) + self%yStage3(i)
		self%relVortIn(i) = self%relVortStart(i) + self%relVortStage3(i)
		self%divIn(i) = self%divStart(i) + self%divStage3(i)
		self%areaIn(i) = self%areaStart(i) + self%areaStage3(i)
		self%hIn(i) = self%hStart(i) + self%hStage3(i)
	enddo

	call SWEPlaneRHSIntegrals( self%u, self%v, self%doubleDot, self%lapSurf, self%xIn, self%yIn, self%relVortIn, &
				self%divIn, self%hIn, topoFn, self%areaIn, self%mask, plane%pseEps, plane%mpiParticles)

	do i = 1, nP
		self%xStage4(i) = dt * self%u(i)
		self%yStage4(i) = dt * self%v(i)
		self%relVortStage4(i) = dt * ( - (self%relVortIn(i) + plane%f0 + plane%beta * self%yIn(i)) * self%divIn(i) - &
			plane%beta * self%v(i) )
		self%divStage4(i) = dt * ( - self%doubleDot(i) + (plane%f0 + plane%beta * self%yIn(i)) * self%relVortIn(i)  - &
			plane%g * self%lapSurf(i) )
		self%hStage4(i) = dt * ( - self%hIn(i) * self%divIn(i) )
		self%areaStage4(i) = dt * ( self%areaIn(i) * self%divIn(i) )
	enddo

	!
	! RK Update
	!
	do i = 1, nP
		self%xStart(i) = self%xStart(i) + self%xStage1(i) / 6.0_kreal + self%xStage2(i) / 3.0_kreal + &
										  self%xStage3(i) / 3.0_kreal + self%xStage4(i) / 6.0_kreal
		self%yStart(i) = self%yStart(i) + self%yStage1(i) / 6.0_kreal + self%yStage2(i) / 3.0_kreal + &
										  self%yStage3(i) / 3.0_kreal + self%yStage4(i) / 6.0_kreal
		self%relVortStart(i) = self%relVortStart(i) + self%relVortStage1(i) / 6.0_kreal + self%relVortStage2(i) / 3.0_kreal + &
										  self%relVortStage3(i) / 3.0_kreal + self%relVortStage4(i) / 6.0_kreal
		self%hStart(i) = self%hStart(i) + self%hStage1(i) / 6.0_kreal + self%hStage2(i) / 3.0_kreal + &
										  self%hStage3(i) / 3.0_kreal + self%hStage4(i) / 6.0_kreal
		self%areaStart(i) = self%areaStart(i) + self%areaStage1(i) / 6.0_kreal + self%areaStage2(i) / 3.0_kreal + &
										  self%areaStage3(i) / 3.0_kreal + self%areaStage4(i) / 6.0_kreal
		self%divStart(i) = self%divStart(i) + self%divStage1(i) / 6.0_kreal + self%divStage2(i) / 3.0_kreal + &
										  self%divStage3(i) / 3.0_kreal + self%divStage4(i) / 6.0_kreal
	enddo

	call SWEPlaneRHSIntegrals( self%u, self%v, self%doubleDot, self%lapSurf, self%xStart, self%yStart, self%relVortStart, &
			self%divStart, self%hStart, topoFn, self%areaStart, self%mask, plane%pseEps, plane%mpiParticles)

	plane%mesh%particles%x(1:nP) = self%xStart
	plane%mesh%particles%y(1:nP) = self%yStart
	plane%mesh%particles%area(1:nP) = self%areaStart
	plane%relVort%scalar(1:nP) = self%relVortStart
	plane%divergence%scalar(1:nP) = self%divStart
	plane%h%scalar(1:nP) = self%hStart
	plane%velocity%xComp(1:nP) = self%u
	plane%velocity%yComp(1:nP) = self%v
	call SetBottomHeightOnMesh(plane, topoFn)
end subroutine

!
!----------------
! private methods
!----------------
!

!> @brief Computes the integral expressions on the right-hand side of the set of ODEs from a Lagrangian method of lines discretization; see @ref PlanarSWE.
!>
!> Integrals are used to compute the double dot product @f$ \nabla\vec{u}:\nabla\vec{u} @f$ and a PSE integral (see @ref PSEDirectSum)
!> approximates the Laplacian of the fluid surface.@n
!> As with the other integrals in LPM, these integrals are computed as a parallel direct summation across all MPI ranks.
!>
!> @param[out] u x-component of velocity
!> @param[out] v y-component of velocity
!> @param[out] doubleDot double dot product
!> @param[out] lapSurf Laplacian of fluid surface
!> @param[in] x x-coordinates of particles
!> @param[in] y y-coordinates of particles
!> @param[in] vort vorticity carried by particles
!> @param[in] div divergence carried by particles
!> @param[in] h fluid depth at particles
!> @param[in] topoFn bottom topography height function, must conform to numberkindsmodule::scalarFnOf2DSpace interface
!> @param[in] area area represented by each particle
!> @param[in] mask mask(i) is true if particle i is active
!> @param[in] pseEps PSE particle influence radius
!> @param[in] mpiParticles @ref MPISetup to distribute work of particle integration across all MPI ranks
subroutine SWEPlaneRHSIntegrals(u, v, doubleDot, lapSurf, x, y, vort, div, h, topoFn, area, mask, pseEps, mpiParticles)
	real(kreal), dimension(:), intent(out) :: u
	real(kreal), dimension(:), intent(out) :: v
	real(kreal), dimension(:), intent(out) :: doubleDot
	real(kreal), dimension(:), intent(out) :: lapSurf
	real(kreal), dimension(:), intent(in) :: x
	real(kreal), dimension(:), intent(in) :: y
	real(kreal), dimension(:), intent(in) :: vort
	real(kreal), dimension(:), intent(in) :: div
	real(kreal), dimension(:), intent(in) :: h
	procedure(scalarFnOf2dSpace) :: topoFn
	real(kreal), dimension(:), intent(in) :: area
	logical(klog), dimension(:), intent(in) :: mask
	real(kreal), intent(in) :: pseEps
	type(MPISetup), intent(in) :: mpiParticles
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: rotStrength, potStrength, denom, ddotkernel, pseKin, lapKernel
	real(kreal) :: surfHeightI, surfHeightJ
	real(kreal) :: ux, uy, vx, vy, denom2, sqDist

	do i = mpiParticles%indexStart(procRank), mpiParticles%indexEnd(procRank)
		u(i) = 0.0_kreal
		v(i) = 0.0_kreal
		doubleDot(i) = 0.0_kreal
		lapSurf(i) = 0.0_kreal
		surfHeightI = h(i) + topoFn( x(i), y(i) )
		ux = 0.0_kreal
		uy = 0.0_kreal
		vx = 0.0_kreal
		vy = 0.0_kreal
		do j = 1, size(x)
			if ( mask(j) ) then
				surfHeightJ = h(j) + topoFn(x(j), y(j))
				sqdist = (x(i) - x(j))**2 + (y(i) - y(j))**2
				denom = 2.0_kreal * PI * sqdist
				denom2 = PI * sqdist * sqdist
				rotStrength = vort(j) * area(j) / denom
				potStrength = div(j) * area(j) / denom

				pseKin = sqrt( sqDist ) / pseEps
				lapKernel = bivariateLaplacianKernel8( pseKin ) / pseEps**2
				lapSurf(i) = lapSurf(i) + lapKernel * (surfHeightJ - surfHeightI) * area(j)

				if ( i == j ) cycle

				u(i) = u(i) - (y(i) - y(j)) * rotStrength + (x(i) - x(j)) * potStrength
				v(i) = v(i) + (x(i) - x(j)) * rotStrength + (y(i) - y(j)) * potStrength

				ux = ux + potStrength - ( (x(i) - x(j)) * ( (x(i) - x(j)) * div(j) - (y(i) - y(j)) * vort(j) ) ) * &
										 area(j) / denom2
				uy = uy - rotStrength - ( (y(i) - y(j)) * ( (x(i) - x(j)) * div(j) - (y(i) - y(j)) * vort(j) ) ) * &
										 area(j) / denom2
				vx = vx + rotStrength - ( (x(i) - x(j)) * ( (y(i) - y(j)) * div(j) + (x(i) - x(j)) * vort(j) ) ) * &
										 area(j) / denom2
				vy = vy + potStrength - ( (y(i) - y(j)) * ( (y(i) - y(j)) * div(j) + (x(i) - x(j)) * vort(j) ) ) * &
										 area(j) / denom2
			endif
		enddo
!		do j = i + 1, size(x)
!			if ( mask(j) ) then
!				surfHeightJ = h(j) + topoFn(x(j), y(j))
!				sqdist = (x(i) - x(j))**2 + (y(i) - y(j))**2
!				denom = 2.0_kreal * PI * sqdist
!				denom2 = PI * sqdist * sqdist
!				rotStrength = vort(j) * area(j) / denom
!				potStrength = div(j) * area(j) / denom
!
!				u(i) = u(i) - (y(i) - y(j)) * rotStrength + (x(i) - x(j)) * potStrength
!				v(i) = v(i) + (x(i) - x(j)) * rotStrength + (y(i) - y(j)) * potStrength
!
!				ux = ux + potStrength - ( (x(i) - x(j)) * ( (x(i) - x(j)) * div(j) - (y(i) - y(j)) * vort(j) ) ) * &
!					 			         area(j) / denom2
!				uy = uy - rotStrength - ( (y(i) - y(j)) * ( (x(i) - x(j)) * div(j) - (y(i) - y(j)) * vort(j) ) ) * &
!										 area(j) / denom2
!				vx = vx + rotStrength - ( (x(i) - x(j)) * ( (y(i) - y(j)) * div(j) + (x(i) - x(j)) * vort(j) ) ) * &
!										 area(j) / denom2
!				vy = vy + potStrength - ( (y(i) - y(j)) * ( (y(i) - y(j)) * div(j) + (x(i) - x(j)) * vort(j) ) ) * &
!										 area(j) / denom2
!
!				pseKin = sqrt( sqDist ) / pseEps
!				lapKernel = bivariateLaplacianKernel8( pseKin ) / pseEps**2
!				lapSurf(i) = lapSurf(i) + lapKernel * (surfHeightJ - surfHeightI) * area(j)
!			endif
!		enddo
		lapSurf(i) = lapSurf(i) / pseEps**2
		doubleDot(i) = ux * ux + 2.0_kreal * uy * vx + vy * vy
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST(u(mpiParticles%indexStart(i):mpiParticles%indexEnd(i)), mpiParticles%messageLength(i), &
				MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(v(mpiParticles%indexStart(i):mpiParticles%indexEnd(i)), mpiParticles%messageLength(i), &
				MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(doubleDot(mpiParticles%indexStart(i):mpiParticles%indexEnd(i)), mpiParticles%messageLength(i), &
				MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(lapSurf(mpiParticles%indexStart(i):mpiParticles%indexEnd(i)), mpiParticles%messageLength(i), &
				MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo

!	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" max u = ", maxval(u) )
!	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" min u = ", minval(u) )
!	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" max v = ", maxval(v) )
!	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" min v = ", minval(v) )
!	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" max(ddot) = ", maxval(doubleDot) )
!	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" min(ddot) = ", minval(doubleDot) )
!	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" max(lapS) = ", maxval(lapSurf) )
!	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey)//" min(lapS) = ", minval(lapSurf) )
end subroutine

!> @brief Initializes a logger for the planar SWE solver module
!>
!> Output is controlled both by message priority and by MPI Rank
!> @param aLog Target Logger object
!> @param rank Rank of this processor
subroutine InitLogger(aLog,rank)
! Initialize a logger for this module and processor
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
	logInit = .TRUE.
end subroutine

!> @}
end module


program fig
implicit none
    integer :: a
    integer :: b
    a = 1
    b = a + a
    Print *, "0"
    Print *, "1"
    Print *, a
    Print *, b
    do while (a < 1000000)
        a = a + b
        b = a + b
        Print *, a
        Print *, b
    end do
end program fig


#include "config_pp.hpp"

! MODULE: boris_module
!
! functions
! =========
! boris_step
! cross3
! Efield
! Bfield
!
module boris_module
    implicit none

    private

    public :: boris_step_fortran, b_field_const_z

contains

    ! FUNCTION: boris_step
    ! boris scheme for computing the movement of a charged particle in an
    !  electro-magnetic field.
    ! the B-field is given explicitly in form of a 4 dimensional array
    !  specifying the fields (vector-) values at each point of the 3
    !  dimensional grid.
    ! the E-field is given via the function `Efield` found in this module.
    !
    ! Params
    ! ======
    ! r     :   real array, dimension(3), location (will be modified!)
    ! v     :   real array, dimension(3), velocity (will be modified!)
    ! q     :   real, charge of particle
    ! m     :   real, mass of particle
    ! dt    :   real, time step
    ! bfield:   real array, dimension(N, N, N, 3), array giving the magnetic
    !            field
    !
    ! Returns
    ! =======
    ! res   :   real array, dimension(3), new location after time step
    !
    subroutine boris_step_fortran(r, v, q, m, dt, bfield_arr) bind(c)
        use iso_c_binding, only: c_double, c_int
        implicit none
        ! dimension
        integer, parameter :: d = 3
        ! arguments
        real(c_double), dimension(d), intent(inout) :: r, v
        real(c_double), intent(in), value :: q, m, dt
        real(c_double), dimension(d,N,N,N), intent(in) :: bfield_arr
        ! helper variables
        real(c_double) :: dtqm, a_sq
        real(c_double), dimension(d) :: E, B, p, v_prime
        integer(c_int), dimension(d) :: idx

        dtqm = q / m * dt

        ! compute half time-step with given velocity
        r = r + 0.5d0 * dt * v

        ! cast r to int and compute r mod N to use as indices for bfield_arr
        idx = mod(int(r), N) + 1

        ! compute E- and B-field at new (half time-step) location
#if EFIELD
        E = Efield(r, 0.0d0)
#else
        E = 0
#endif
        ! B = Bfield(r, 0.0d0)
        B = bfield_arr(:, idx(1), idx(2), idx(3))

        ! helper vector p = q*B*dt/(2*m)
        p = 0.5d0 * dtqm * B

        ! a = tan(theta/2), theta = angle(v-, v+)
        ! a_sq = a**2
        a_sq = 0.25d0 * dtqm ** 2 * dot_product(B, B)

        ! v- = v + q*E*dt/(2*m)
        v = v + 0.5d0 * dtqm * E

        ! v_prime
        v_prime = v + cross3(v, p)

        ! v+ = v- 2*(v' x p)/(1+a**2)
        v = v + 2.0d0 * cross3(v_prime, p) / (1 + a_sq)

        ! new velocity after full time-step
        ! v = v+ + q*E*dt/(2*m)
        v = v + 0.5d0 * dtqm * E

        ! new location after full time-step
        r = r + 0.5d0 * dt * v

    end subroutine boris_step_fortran

    !===================!
    ! PRIVATE FUNCTIONS !
    !===================!

    ! FUNCTION: cross3
    ! cross product of two real vectors in R^3
    !
    ! Params
    ! ======
    ! a, b  :   real array, dimension(3)
    !
    ! Returns
    ! =======
    ! c = a x b
    !
    function cross3(a, b) result(c)
        implicit none
        real(8),dimension(3),intent(in) :: a, b
        real(8),dimension(3) :: c
        c(1) = a(2) * b(3) - a(3) * b(2)
        c(2) = a(3) * b(1) - a(1) * b(3)
        c(3) = a(1) * b(2) - a(2) * b(1)
    end function cross3

    ! FUNCTION: Efield
    ! gives e-field for use in `boris_step`
    !
    ! Params
    ! ======
    ! r     :   real array, dimension(3), location
    ! t     :   real, time
    !
    ! Returns
    ! =======
    ! E(r, t)   :   real array, dimension(3), E-field at r and t
    !
    function Efield(r, t) result(e)
        implicit none
        real(8),dimension(:),intent(inout) :: r
        real(8),intent(in) :: t
        real(8),dimension(3) :: e
        ! e = [0.0d0, 0.0d0, 0.0d0]
        e = e_field_const_y(r)
    end function Efield

    ! FUNCTION: Bfield
    ! gives b-field for use in `boris_step`
    !
    ! Params
    ! ======
    ! r     :   real array, dimension(3), location
    ! t     :   real, time
    !
    ! Returns
    ! =======
    ! B(r, t)   :   real array, dimension(3), B-field at r and t
    !
    function Bfield(r, t) result(b)
        implicit none
        real(8),dimension(:),intent(inout) :: r
        real(8),intent(in) :: t
        real(8),dimension(3) :: b
        ! b = zylindrical_b_field(r)
        ! b = b_field_magnetic_mirror(r)
        b = b_field_const_z(r)
    end function Bfield

    ! zylindrical b_field
    ! B = 1/d * e_rho, d = sqrt(x**2 + y**2)
    function b_field_zylindrical(r) result(b)
        implicit none
        real(8),dimension(:),intent(inout) :: r
        real(8),dimension(3) :: b
        real(8) :: d, b0
        d = sqrt(r(1)**2 + r(2)**2)
        b0 = 1/d
        b = [-b0*r(2)/d, b0*r(1)/d, 0.5d0]
    end function b_field_zylindrical

    ! magnetic mirror
    !
    ! condition:
    !   div B = 0 => B_rho = -rho / 2 * dB_z/dz
    !
    ! here:
    !   B_z = 2 - cos(pi*z/10)
    !   B_rho = -rho / 2 * (2 * cos(pi*z/10) * sin(pi*z/10) * pi / 10)
    !
    function b_field_magnetic_mirror(r) result(b)
        implicit none
        real(8), parameter :: PI = 4 * atan(1.0d0)
        real(8), dimension(3), intent(in) :: r
        real(8), dimension(3) :: b
        real(8) :: rho, zarg, bz, brho
        zarg = PI / 10.0d0 * r(3)
        bz = 2.0d0 - cos(zarg)**2
        rho = sqrt(r(1)**2 + r(2)**2)
        brho = -0.5d0 * (2 * cos(zarg) * sin(zarg) * PI / 10.0d0) * rho
        b = [ brho * r(1) / (rho + 1e-6), brho * r(2) / (rho + 1e6), bz ]
    end function b_field_magnetic_mirror

    ! constant b-field in z direction
    function b_field_const_z(r) result(b)
        implicit none
        real(8), dimension(3), intent(in) :: r
        real(8), dimension(3) :: b
        real(8) :: b0z = 0.1d0
        b = [ 0.0d0, 0.0d0, b0z ]
    end function b_field_const_z

    ! constant e-field in y direction
    function e_field_const_y(r) result(e)
        implicit none
        real(8), dimension(3), intent(in) :: r
        real(8), dimension(3) :: e
        real(8) :: e0y = 1.0d0
        e = [ 0.0d0, e0y, 0.0d0 ]
    end function e_field_const_y

end module boris_module


SUBROUTINE cgsolve(g,q,its)

!-------------------------------------------------------------
!
!  Perform a simple conjugate gradient solution
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: g
INTEGER :: it, i
INTEGER, INTENT(OUT) :: its
REAL*8 :: alf, bet, df, dfmx, tmp, bnorm
REAL*8, DIMENSION(neq), INTENT(IN) :: q
REAL*8, DIMENSION(neq) :: res, sd, tmp1, phio

! Initialize my guess
phi(:,g) = 0.0
res = q
sd = res
tmp = DOT_PRODUCT(res,res)

!bnorm = SQRT(tmp)
!! Want to use just the residual when the bnorm is larger than one, means more iterations
!IF (bnorm > 1.0) THEN
!   bnorm = 1.0
!ELSE
!   ! Want to use faster multiplications at each iteration, so take inverse and store
!   bnorm = 1.0/bnorm
!END IF

DO it = 1, itmx
   ! Copy old phi vector
   phio = phi(:,g)

   ! The CG steps...should be optimized later or use outside solver
   tmp1 = MATMUL(jmat,sd)
   alf = tmp/(DOT_PRODUCT(sd,tmp1))
   phi(:,g) = phi(:,g) + alf*sd
   res = res - alf*tmp1
   bet = 1.0/tmp
   tmp = DOT_PRODUCT(res,res)
   bet = tmp*bet
   sd  = res + bet*sd
!   dfmx = SQRT(tmp)*bnorm
   dfmx = -1.0
   DO i = 1, neq, nmom
      IF (ABS(phio(i)) >= tolr) THEN
         df = ABS(phi(i,g)/phio(i) - 1.0)
      ELSE
         df = ABS(phi(i,g) - phio(i))
      END IF
      IF (df > dfmx) dfmx = df
   END DO

   IF (dfmx > cgr .AND. it < itmx .AND. it /= neq) THEN
      CYCLE
   ELSE IF (dfmx < cgr .OR. it == neq) THEN
      cnvf(g) = 1
      its = it
      EXIT
   ELSE IF (it == itmx) THEN
      cnvf(g) = 0
      its = it
      EXIT
   END IF
END DO

RETURN
END SUBROUTINE cgsolve


C   background_flow
C       -  Take box average at each point.
C       -  Doesn't account for cyclic or poles, just leaves border
C       - Last Edited 2014/8/14   - By A. Brammer
C   NCLFORTSTART
        subroutine background_flow(indata, bkgrd, nx,ny, dx, dy)
        real indata(nx,ny), bkgrd(nx,ny)
        integer nx, ny
        integer rx, ry
        real dx, dy
C NCLEND
        print *," * * * * * * * * * * * * "
        print *,"* * * * * * * * * * * * "
        print *," * * * * * * * * * * * * "
        print *,"  Box Average Routine "
        print *," * * * * * * * * * * * * "
        print *," Does not work near the boundaries"
        print *," Input Parameters: "
        print *," nlon =", nx ," nlat =",ny
        print *," width =",dx, "height =",dy

        rx = (dx*nx)/360
        print *, rx
        ry = (dy*(ny-1))/180
        print *, dx," = ",rx,"grid points"

        do i=(rx+1), (nx-rx)
            do j=ry, (ny-ry)
               bkgrd(i,j) = sum( indata( (i-rx):(i+rx),(j-ry):(j+ry) ) )
            enddo
        enddo

        bkgrd = bkgrd /( ((2*rx)+1)*((2*ry)+1) )

        return
        end

C  circle_avg
C       - Very Simple implementation
C       - Doesn't account for lat just takes circle on a equidistant grid
C       - Last edited 2014/8/14   - A. Brammer
C   NCLFORTSTART
        subroutine circle_avg(indata, bkgrd, nx,ny,dx)
        real indata(nx,ny), bkgrd(nx,ny), tempv
        integer nx, ny,cx ,i,j,y, ii, iii, dxi
        integer rx, ry, tot_cx, divider
        real dx
C NCLEND
        dxi = int(dx) ! need an integer version of dx

        tot_cx = 0
        do y=1, dxi
        tot_cx = tot_cx + int( sqrt( dx**2 - y**2 )+0.5)
        end do
        divider = (tot_cx*4) -1

        do i=1,nx
            do j=(dxi+1),(ny-dxi-1)
            tempv = 0.0
            y=1
            cx =   int( sqrt( dx**2 - y**2 )+0.5)
            tempv = tempv + sum( indata( (i-cx):(i+cx) , (j+(y-1))  ))
                do y=2,dxi
                cx =   int( sqrt( dx**2 - y**2 )+0.5)
                    do ii=(i-cx), (i+cx)
                        iii = ii
                        if(iii.lt.1)then
                            iii = iii+nx
                        end if
                        if(iii.gt.nx)then
                            iii = iii-nx
                        end if
        tempv = tempv + indata( iii , (j+(y-1)) )
        tempv = tempv + indata( iii , (j-(y-1)) )
                    end do
                enddo
       bkgrd(i,j) = tempv / divider
        tempv = 0.0
            enddo
        enddo
        bkgrd(:,1:dxi) = 9.96921e+36
        bkgrd(:,(ny-dxi):ny) = 9.96921e+36  !This if NCLs Float Missing Val.
        return
        end

C       circle_avg_m
C           - Accounted for Latitide and loops over cyclic
C           - Expects cyclic data, without overlap point
C           - Uses haversine to calc distances, some error but less than a grid space
C           - Last edited 2013/03/22  A Brammer.
C   NCLFORTSTART
        subroutine circle_avg_m(indata, bkgrd, inlat, nx,ny,dxm)
        real indata(nx,ny), bkgrd(nx,ny), tempv, R
        real lat(ny), inlat(ny), divider, lat1, lat2, eps, fillvalue
        integer nx, ny,cx ,i,j,y, ii, iii,dx, dxi,dxmi
        integer rx, ry, tot_cx
        real dxm, clat(ny)
C NCLEND
         eps = 2.0E-07
         fillvalue = 9.96921e+36
         R=6371. ! Earth radius km.
         pi=(355./113.) ! pi Approx good to 6 decimal places

         dxmi = int(dxm) ! need an integer version of dx
c       cx defines the longitudinal grid points for each lat.

          dx  = int(  dxmi/(2*pi*(R/nx)) ) ! expects consistent spaced
          dxi = int(dx)  ! not sure why this is needed but indexing fails without it.

c      Convert latitude to radians and cos(lat)
         lat = inlat   ! work with temp variable so as to not overwrite.
         lat = lat*(pi/180.)   ! convert to radians
         clat = cos(lat)         ! Take cos of radians

        do i=1,nx  ! Loop across longitudes
            do j=(dx+2),(ny-dx-2)  ! loop lats excluding radius of circle
            tempv = 0.0
            y=0
            divider = 0.0
            do y=-dx,dx ! work way up circle
              lat1 = lat(j)  !  centre of circle
              lat2 = lat(j+y) ! vertical distance from cirlce centre.
              xr=acos(-((sin(lat1)*sin(lat2))
     +         -cos(dxmi/R))/(cos(lat1)*cos(lat2)))         !! haversine trig
              xd = int( xr/(pi/180.)/(360./nx) )
              cx = xd ! conv. to grid points.
                 do ii=(i-cx), (i+cx)  ! work across circle
                        iii = ii
                        if(iii.lt.1)then ! loop over break assumes global w/o cyclic
                            iii = iii+nx
                        end if
                        if(iii.gt.nx)then
                            iii = iii-nx
                        end if
                  if( abs(indata( iii , (j+y))-fillvalue).gt.eps )then    !! don't include missing values
                     tempv = tempv + (clat(j+y))*indata( iii , (j+y) )
                     divider = divider + (clat(j+y))
                  end if
C                 tempv = tempv + (clat(j+y))*indata( iii , (j+y) )
C                 divider = divider + (clat(j+y))
                    end do
             end do
             if(divider .lt. eps)then            !! if any non-missing calc average
                 bkgrd(i,j) = fillvalue
              else
                 bkgrd(i,j) =  tempv/divider
              end if
             tempv = 0.0      !  not sure why this is here, it's reset at the top of the loop
            enddo  ! end j loop
        enddo      ! end i loop
        bkgrd(:,1:(dxi+2)) = indata(:,1:(dxi+2))  ! Fill poles with unsmoothed data.
        bkgrd(:,(ny-dxi-2):ny) = indata(:,(ny-dxi-2):ny)
        return
        end

C   NCLFORTSTART
        subroutine circle_avg_m_point(indata, bkgrd, inlat,inlon, nx,ny,
     +    dxm, rlat, rlon, rlat1,fillvalue  )
        integer rx, ry, tot_cx, rlat1
        real indata(nx,ny), bkgrd(rlat1), tempv, R
        real lat(ny), inlat(ny), inlon(nx), divider, lat1, lat2
        integer nx, ny,cx ,i,j,y, ii, iii, dx,dxi,dxmi
        real dxm, clat(ny), rlat(rlat1), rlon(rlat1), eps
C NCLEND
          eps = 2.0E-07
c
c       Last updated: April 22nd 2013
c       Considers latitude in size/shape of circle and weigths for average.
c       Potential error in that I use simple Trig for circle distances.
c
         R=6371. ! Earth radius km.
         pi=(355./113.) ! pi Approx good to 6 decimal places

         dxmi = int(dxm) ! need an integer version of dx
c       cx defines the longitudinal grid points for each lat.

          dx  = int(  dxmi/(2*pi*(R/nx)) )
          dxi = int(dx)  ! not sure why this is needed but indexing fails without it.

c      Convert latitude to radians and cos(lat)
         lat = inlat   ! work with temp variable so as to not overwrite.
         lat = lat*(pi/180.)   ! convert to radians
         clat = cos(lat)         ! Take cos of radians

        do k=1,rlat1
            j = minloc(abs(inlat - rlat(k) ) ,1 )
            i = minloc(abs(inlon - rlon(k) ) ,1 )
            tempv = 0.0
            y=0
            divider = 0.0
            do y=-dx,dx ! work way up circle
             if( j+y .ge. ny-5 .OR. j+y .le. 5 )then ! stuff gets funky at the poles
               cycle
             end if
              lat1 = lat(j)  !  centre of circle
              lat2 = lat(j+y) ! vertical distance from cirlce centre.
              xr=acos(-((sin(lat1)*sin(lat2))
     +         -cos(dxmi/R))/(cos(lat1)*cos(lat2)))
              xd = int( xr/(pi/180.)/(360./nx) )
              cx = xd ! conv. to grid points.
                 do ii=(i-cx), (i+cx)  ! work across circle
                        iii = ii
                        if(iii.lt.1)then ! loop over break assumes global w/o cyclic
                            iii = iii+nx
                        end if
                        if(iii.gt.nx)then
                            iii = iii-nx
                        end if
                  if( abs(indata( iii , (j+y))-fillvalue).gt.eps )then    !! don't include missing values
                  tempv = tempv + (clat(j+y))*indata( iii , (j+y) )
                  divider = divider + (clat(j+y))
                        end if
                    end do
             end do
            if(divider .lt. eps)then
              bkgrd(k) = fillvalue
            else
              bkgrd(k) =  tempv/divider
            end if
        end do
        return
        end

C       circle_avg_m
C           - Accounted for Latitide and loops over cyclic
C           - Expects cyclic data, without overlap point
C           - Uses haversine to calc distances, some error but less than a grid space
C           - Last edited 2013/03/22  A Brammer.
C   NCLFORTSTART
        subroutine circle_inout_m_point(bkgrd, inlat,inlon,nx,ny,
     +    dxm, rlat, rlon )
        real indata(nx,ny), bkgrd(nx,ny), tempv, R
        real lat(ny),inlat(ny),inlon(nx), rlat,rlon, divider, lat1, lat2
        integer nx, ny,cx ,i,j,y, ii, iii,dx, dxi,dxmi
        integer rx, ry, tot_cx
        real dxm, clat(ny)
C NCLEND

         R=6371. ! Earth radius km.
         pi=(355./113.) ! pi Approx good to 6 decimal places

         dxmi = int(dxm) ! need an integer version of dx
c       cx defines the longitudinal grid points for each lat.

          dx  = int(  dxmi/(2*pi*(R/nx)) )
          dxi = int(dx)  ! not sure why this is needed but indexing fails without it.

c      Convert latitude to radians and cos(lat)
         lat = inlat   ! work with temp variable so as to not overwrite.
         lat = lat*(pi/180.)   ! convert to radians
         clat = cos(lat)         ! Take cos of radians
            j = minloc(abs(inlat - rlat ) ,1 )
            i = minloc(abs(inlon - rlon ) ,1 )
            do y=-dx,dx ! work way up circle
              lat1 = lat(j)  !  centre of circle
              lat2 = lat(j+y) ! vertical distance from cirlce centre.
              xr=acos(-((sin(lat1)*sin(lat2))
     +         -cos(dxmi/R))/(cos(lat1)*cos(lat2)))
              xd = int( xr/(pi/180.)/(360./nx) )
              cx = xd ! conv. to grid points.
                 do ii=(i-cx), (i+cx)  ! work across circle
                        iii = ii
                        if(iii.lt.1)then ! loop over break assumes global w/o cyclic
                            iii = iii+nx
                        end if
                        if(iii.gt.nx)then
                            iii = iii-nx
                        end if
                        bkgrd( iii , (j+y) ) = 1
                  end do
             end do
        return
        end

C   NCLFORTSTART
        subroutine circle_inout_m_points(bkgrd, inlat,inlon,nx,ny,
     +    dxm, rlat, rlon, nr)
        real indata(nx,ny), bkgrd(nx,ny), tempv, R
        real lat(ny),inlat(ny),inlon(nx), rlat(nr),rlon(nr), divider
        real lat1, lat2
        integer nx, ny,cx ,i,j,y, ii, iii,dx, dxi,dxmi
        integer rx, ry, tot_cx, nr,l
        real dxm, clat(ny)
C NCLEND

         R=6371. ! Earth radius km.
         pi=(355./113.) ! pi Approx good to 6 decimal places

         dxmi = int(dxm) ! need an integer version of dx
c       cx defines the longitudinal grid points for each lat.

         dx  = int(  dxmi/(2*pi*(R/nx)) )
         dxi = int(dx)  ! not sure why this is needed but indexing fails without it.

c      Convert latitude to radians and cos(lat)
         lat = inlat   ! work with temp variable so as to not overwrite.
         lat = lat*(pi/180.)   ! convert to radians
         clat = cos(lat)         ! Take cos of radians
          do l = 1, nr
            j = minloc(abs(inlat - rlat(l) ) ,1 )
            i = minloc(abs(inlon - rlon(l) ) ,1 )
            do y=-dx,dx ! work way up circle
              lat1 = lat(j)  !  centre of circle
              lat2 = lat(j+y) ! vertical distance from cirlce centre.
              xr=acos(-((sin(lat1)*sin(lat2))
     +         -cos(dxmi/R))/(cos(lat1)*cos(lat2)))
              xd = int( xr/(pi/180.)/(360./nx) )
              cx = xd ! conv. to grid points.
                 do ii=(i-cx), (i+cx)  ! work across circle
                        iii = ii
                        if(iii.lt.1)then ! loop over break assumes global w/o cyclic
                            iii = iii+nx
                        end if
                        if(iii.gt.nx)then
                            iii = iii-nx
                        end if
                        bkgrd( iii , (j+y) ) = bkgrd( iii , (j+y) )+ 1
                  end do
            end do
          end do
        return
        end

C   NCLFORTSTART
        subroutine circle_stddev_m_point(indata, bkgrd,ave, inlat,inlon,
     +    nx, ny, dxm, rlat, rlon, rlat1,fillvalue  )
        integer rx, ry, tot_cx, rlat1
        real indata(nx,ny), bkgrd(rlat1), ave(rlat1), tempv, R,fillvalue
        real lat(ny), inlat(ny), inlon(nx), divider, lat1, lat2
        integer nx, ny,cx ,i,j,y, ii, iii,dx, dxi,dxmi
        real dxm, clat(ny), rlat(rlat1), rlon(rlat1),eps
C NCLEND
c
c       Last updated: April 22nd 2013
c       Considers latitude in size/shape of circle and weigths for average.
c       Potential error in that I use simple Trig for circle distances.
c
c
c
          eps = 2.0E-07

         R=6371. ! Earth radius km.
         pi=(355./113.) ! pi Approx good to 6 decimal places

         dxmi = int(dxm) ! need an integer version of dx
c       cx defines the longitudinal grid points for each lat.

          dx  = int(  dxmi/(2*pi*(R/nx)) )
          dxi = int(dx)  ! not sure why this is needed but indexing fails without it.

c      Convert latitude to radians and cos(lat)
         lat = inlat   ! work with temp variable so as to not overwrite.
         lat = lat*(pi/180.)   ! convert to radians
         clat = cos(lat)         ! Take cos of radians

        do k=1,rlat1
         if(abs(ave(k)-fillvalue).lt.eps)then
                 bkgrd(k) = fillvalue
            cycle
         end if
         j = minloc(abs(inlat - rlat(k) ) ,1 )
         i = minloc(abs(inlon - rlon(k) ) ,1 )

            tempv = 0.0
            y=0
            divider = 0.0
            do y=-dx,dx ! work way up circle
             if( j+y .ge. ny .OR. j+y .le. 0 )then
               cycle
             end if
              lat1 = lat(j)  !  centre of circle
              lat2 = lat(j+y) ! vertical distance from cirlce centre.
              xr=acos(-((sin(lat1)*sin(lat2))
     +         -cos(dxmi/R))/(cos(lat1)*cos(lat2)))
              xd = int( xr/(pi/180.)/(360./nx) )
              cx = xd ! conv. to grid points.
                 do ii=(i-cx), (i+cx)  ! work across circle
                        iii = ii
                        if(iii.lt.1)then ! loop over break assumes global w/o cyclic
                            iii = iii+nx
                        end if
                        if(iii.gt.nx)then
                            iii = iii-nx
                        end if
                  if( abs(indata( iii , (j+y))-fillvalue).gt.eps )then    !! don't include missing values
            tempv = tempv + (clat(j+y))*((indata(iii,(j+y) )-ave(k))**2)
                  divider = divider + (clat(j+y))
                  end if
                    end do
             end do
        if(divider .lt. eps)then
        bkgrd(k) = fillvalue
        else
        bkgrd(k) =  sqrt( tempv/divider )
        end if
        end do
        return
        end

C   NCLFORTSTART
        subroutine circle_lthresh_m_point(indata,bkgrd,thresh,
     +    inlat,inlon,nx, ny, dxm, rlat, rlon, rlat1,fillvalue  )
        integer rx, ry, tot_cx, rlat1
        real indata(nx,ny), bkgrd(rlat1), ave(rlat1), tempv, R,fillvalue
        real lat(ny), inlat(ny), inlon(nx), divider, lat1, lat2
        integer nx, ny,cx ,i,j,y, ii, iii,dx, dxi,dxmi
        real dxm, clat(ny), rlat(rlat1), rlon(rlat1),eps
C NCLEND
c
c       Last updated: April 22nd 2013
c       Considers latitude in size/shape of circle and weigths for average.
c       Potential error in that I use simple Trig for circle distances.
c
c
c
          eps = 2.0E-07

         R=6371. ! Earth radius km.
         pi=(355./113.) ! pi Approx good to 6 decimal places

         dxmi = int(dxm) ! need an integer version of dx
c       cx defines the longitudinal grid points for each lat.

          dx  = int(  dxmi/(2*pi*(R/nx)) )
          dxi = int(dx)  ! not sure why this is needed but indexing fails without it.

c      Convert latitude to radians and cos(lat)
         lat = inlat   ! work with temp variable so as to not overwrite.
         lat = lat*(pi/180.)   ! convert to radians
         clat = cos(lat)         ! Take cos of radians

        do k=1,rlat1
         j = minloc(abs(inlat - rlat(k) ) ,1 )
         i = minloc(abs(inlon - rlon(k) ) ,1 )

            tempv = 0.0
            y=0
            divider = 0.0
            do y=-dx,dx ! work way up circle
             if( j+y .ge. ny .OR. j+y .le. 0 )then
               cycle
             end if
              lat1 = lat(j)  !  centre of circle
              lat2 = lat(j+y) ! vertical distance from cirlce centre.
              xr=acos(-((sin(lat1)*sin(lat2))
     +         -cos(dxmi/R))/(cos(lat1)*cos(lat2)))
              xd = int( xr/(pi/180.)/(360./nx) )
              cx = xd ! conv. to grid points.
                 do ii=(i-cx), (i+cx)  ! work across circle
                        iii = ii
                        if(iii.lt.1)then ! loop over break assumes global w/o cyclic
                            iii = iii+nx
                        end if
                        if(iii.gt.nx)then
                            iii = iii-nx
                        end if
                  if( abs(indata( iii , (j+y))-fillvalue).gt.eps )then  !! don't include missing values
                    if(indata( iii , (j+y)).lt. thresh)then
                      tempv = tempv + (clat(j+y))
                    end if
                  end if
                 divider = divider + (clat(j+y))
                end do
             end do
        if(divider .lt. eps)then
        bkgrd(k) = fillvalue
        else
        bkgrd(k) = tempv/divider
        end if
        end do
        return
        end

C   NCLFORTSTART
        subroutine circle_gthresh_m_point(indata,bkgrd,thresh,
     +    inlat,inlon,nx, ny, dxm, rlat, rlon, rlat1,fillvalue  )
        integer rx, ry, tot_cx, rlat1
        real indata(nx,ny), bkgrd(rlat1), ave(rlat1), tempv, R,fillvalue
        real lat(ny), inlat(ny), inlon(nx), divider, lat1, lat2
        integer nx, ny,cx ,i,j,y, ii, iii,dx, dxi,dxmi
        real dxm, clat(ny), rlat(rlat1), rlon(rlat1),eps
C NCLEND
c
c       Last updated: April 22nd 2013
c       Considers latitude in size/shape of circle and weigths for average.
c       Potential error in that I use simple Trig for circle distances.
c
c
c
          eps = 2.0E-07

         R=6371. ! Earth radius km.
         pi=(355./113.) ! pi Approx good to 6 decimal places

         dxmi = int(dxm) ! need an integer version of dx
c       cx defines the longitudinal grid points for each lat.

          dx  = int(  dxmi/(2*pi*(R/nx)) )
          dxi = int(dx)  ! not sure why this is needed but indexing fails without it.

c      Convert latitude to radians and cos(lat)
         lat = inlat   ! work with temp variable so as to not overwrite.
         lat = lat*(pi/180.)   ! convert to radians
         clat = cos(lat)         ! Take cos of radians

        do k=1,rlat1
         j = minloc(abs(inlat - rlat(k) ) ,1 )
         i = minloc(abs(inlon - rlon(k) ) ,1 )

            tempv = 0.0
            y=0
            divider = 0.0
            do y=-dx,dx ! work way up circle
             if( j+y .ge. ny .OR. j+y .le. 0 )then
               cycle
             end if

              lat1 = lat(j)  !  centre of circle
              lat2 = lat(j+y) ! vertical distance from cirlce centre.
              xr=acos(-((sin(lat1)*sin(lat2))
     +         -cos(dxmi/R))/(cos(lat1)*cos(lat2)))
              xd = int( xr/(pi/180.)/(360./nx) )
              cx = xd ! conv. to grid points.
                 do ii=(i-cx), (i+cx)  ! work across circle
                        iii = ii
                        if(iii.lt.1)then ! loop over break assumes global w/o cyclic
                            iii = iii+nx
                        end if
                        if(iii.gt.nx)then
                            iii = iii-nx
                        end if
                  if( abs(indata( iii , (j+y))-fillvalue).gt.eps )then  !! don't include missing values
                    if(indata( iii , (j+y)) .gt. thresh)then
                      tempv = tempv + (clat(j+y))
                    end if
                  end if
                 divider = divider + (clat(j+y))
                end do
             end do
        if(divider .lt. eps)then
        bkgrd(k) = fillvalue
        else
        bkgrd(k) = tempv/divider
        end if
        end do
        return
        end

C   NCLFORTSTART
        subroutine circle_missing_m_point(indata,bkgrd,
     +    inlat,inlon,nx, ny, dxm, rlat, rlon, rlat1,fillvalue  )
        integer rx, ry, tot_cx, rlat1
        integer nx, ny,cx ,i,j,y, ii, iii,dx, dxi,dxmi
        real indata(nx,ny), bkgrd(rlat1), ave(rlat1), tempv, R,fillvalue
        real lat(ny), inlat(ny), inlon(nx), divider, lat1, lat2
        real dxm, clat(ny), rlat(rlat1), rlon(rlat1),eps
C NCLEND
c
c       Last updated: April 22nd 2013
c       Considers latitude in size/shape of circle and weigths for average.
c       Potential error in that I use simple Trig for circle distances.
c
c
        eps = 2.0E-07

         R=6371. ! Earth radius km.
         pi=(355./113.) ! pi Approx good to 6 decimal places

         dxmi = int(dxm) ! need an integer version of dx
c       cx defines the longitudinal grid points for each lat.

          dx  = int(  dxmi/(2*pi*(R/nx)) )
          dxi = int(dx)  ! not sure why this is needed but indexing fails without it.

c      Convert latitude to radians and cos(lat)
         lat = inlat   ! work with temp variable so as to not overwrite.
         lat = lat*(pi/180.)   ! convert to radians
         clat = cos(lat)         ! Take cos of radians

        do k=1,rlat1
         j = minloc(abs(inlat - rlat(k) ) ,1 )
         i = minloc(abs(inlon - rlon(k) ) ,1 )

            tempv = 0.0
            y=0
            divider = 0.0
            do y=-dx,dx ! work way up circle
             if( j+y .ge. ny .OR. j+y .le. 0 )then
               cycle
             end if
              lat1 = lat(j)  !  centre of circle
              lat2 = lat(j+y) ! vertical distance from cirlce centre.
              xr=acos(-((sin(lat1)*sin(lat2))
     +         -cos(dxmi/R))/(cos(lat1)*cos(lat2)))
              xd = int( xr/(pi/180.)/(360./nx) )
              cx = xd ! conv. to grid points.
                 do ii=(i-cx), (i+cx)  ! work across circle
                        iii = ii
                        if(iii.lt.1)then ! loop over break assumes global w/o cyclic
                            iii = iii+nx
                        end if
                        if(iii.gt.nx)then
                            iii = iii-nx
                        end if
                  if( abs(indata( iii , (j+y))-fillvalue).lt.eps )then  !! don't include missing values
                      tempv = tempv + (clat(j+y))
                  end if
                 divider = divider + (clat(j+y))
                end do
             end do
        bkgrd(k) = tempv/divider
        end do
        return
        end