!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
!
!  spherical splines contains a few functions for fitting and evaluating
!  spherical splines, as given by
!     Wang & Dahlen (1995)  Spherical-spline parameterization of three-dimensional
!     Earth models.  GRL (22) 3099-3102.
!
!  This module uses LAPACK, and so must be compiled on a system with a version
!  available.  On Mac OS X, one can use the optimised 'vecLib' framework
!  by compiling with the options '-framework vecLib -llapack -lblas
!
!-------------------------------------------------------------------------------
!
!  Andy Nowacki,
!  University of Bristol
!
!-------------------------------------------------------------------------------
!  HISTORY:
!     2011-01-30: Inception date.  First working version (of sorts).
!     2012-02-24: Added alternative spline basis function, the Abel-Poisson
!                 kernel (sph_slines_func_AP), and subroutine to calculate the
!                 most appropriate value for its parameter, h, for a desired
!                 spline width.  Change splines_set type to keep track of which
!                 kernel we're using.
!
!-------------------------------------------------------------------------------
!  TODO:
!     + Allow for strongly irregular knot spacing by calculating f using a
!       local value for dbar, the mean knot spacing (in that region).
!===============================================================================
module spherical_splines
!===============================================================================

   implicit none

!  ** size constants
      integer, parameter, private :: i4 = selected_int_kind(9)       ! long int
      integer, parameter, private :: r4 = selected_real_kind(6,37)   ! SP
      integer, parameter, private :: r8 = selected_real_kind(15,307) ! DP

!  ** precision selector
      integer, parameter, private :: rs = r8

!  ** maths constants and other useful things
      real(rs), parameter, private :: pi = 3.141592653589793238462643_rs ;
      real(rs), parameter, private :: pi2 = pi/2._rs
      real(rs), parameter, private :: ZERO = 0._rs, ONE = 1._rs, TWO = 2._rs, &
         HALF = 0.5_rs, FOURTH = 0.25_rs, THIRD = 1._rs/3._rs

!  ** logical units
      integer, parameter, private :: lu_stdin  = 5
      integer, parameter, private :: lu_stdout = 6
      integer, parameter, private :: lu_stderr = 0
      integer, parameter, private :: lu_file = 10  ! LU to be used for reading and writing

!  ** Names and number of different kernels available
      integer, parameter :: NUM_KERNELS = 2  ! Number of kernel types available
      integer, parameter :: KERNEL_NAME_LEN = 2, &
                            KERNEL_LONG_NAME_LEN = 30
      character(len=KERNEL_NAME_LEN),dimension(NUM_KERNELS) :: &
                                          KERNEL_NAME = (/ 'B ','AP' /)
      character(len=KERNEL_LONG_NAME_LEN),dimension(NUM_KERNELS) :: &
        KERNEL_LONG_NAME = (/ 'B-spline                      ', &
                              'Abel-Poisson                  ' /)

!  ** Hide the helper functions
      private :: sph_splines_delta
      private :: sph_splines_fatal
      private :: sph_splines_info

!  ** derived types used by the module, containing knot/data points, spline
!     coefficients and so on
      type sph_splines_set
         real(rs),dimension(:),allocatable :: phi,theta, & ! Lon & colat
                                              c, &  ! Value at control points
                                              a     ! Spline coefficient
         real(rs) :: dbar = -1._rs, & ! Mean knot spacing globally (for B-splines) &
                     h = -1._rs       !  Abel-Poisson coefficient (-1 if unset)
         integer :: n                 ! Number of control knots
         logical :: degrees = .true.  ! Knot units; defaults to degrees
         character(len=KERNEL_NAME_LEN) :: kernel ! Type of kernel being used
      end type

!-------------------------------------------------------------------------------
CONTAINS

!===============================================================================
subroutine sph_splines_fit(s,quiet)
!===============================================================================
!  Calculate the coefficients of the spherical spline representation of a surface
!  field, with knot points as given in the data.
!
!  INPUT: sph_splines_set structure.  The following are unchanged
!         phi  \  Column vectors of implicit length which contain coordinates
!         theta } of the knot points and the surface values there.
!         c    /
!         degress Logical variable specifying whether input coordinates
!                 are in degrees or not.  (Default .true.)
!
!  OUTPUT: sph_splines_set structure.  The following are changed
!         a      Column vector of coefficients which can be used to calculate
!                the fitted function.  (Re-)Allocated within the subroutine.
!         dbar   Mean distance between knots points globally.
!
!  Constructs the set of knot coefficients by inverting the linear equations
!     c(theta_i,phi_i) = f_j(Delta_ij) * a(i)
!  ->                a = F^-1 * c
!  For this, I use LAPACK

   implicit none

   type(sph_splines_set) :: s
   logical,optional,intent(in) :: quiet
   logical :: silent
   integer :: n  ! number of knots; length of phi,theta,r
   integer :: i,j,ier,nd,npoints
   integer,allocatable :: ipiv(:)  ! Pivot rows used by LAPACK
   real(rs),allocatable :: F(:,:)   ! Matrix of distances between point i and j
   real(rs) :: dmin

!  Get the level of verbosity.  Default to noisy
   silent = .false.
   if (present(quiet)) silent = quiet

!  Check for the right things being present
   if (.not.(allocated(s%phi) .and. allocated(s%theta) .and. allocated(s%c))) &
      call sph_splines_fatal('sph_splines_fit: location or values of knot points not allocated')

!  Get length of input arrays and make sure they're the same length
   n = size(s%phi)
   if (s%n /= n .or. size(s%theta) /= n .or. size(s%c) /= n) &
      call sph_splines_fatal('sph_splines_fit: structure arrays must all be same length.')

!  (Re-)Allocate s%a if already allocated to a length != n
   if (allocated(s%a)) then
      if (size(s%a) /= n) then
         deallocate(s%a);  allocate(s%a(n))
         if (.not.silent) call sph_splines_info( &
               'sph_splines_fit: allocating memory for spline coefficients.')
      endif
   else
      allocate(s%a(n))
      if (.not.silent) call sph_splines_info( &
            'sph_splines_fit: allocating memory for spline coefficients.')
   endif

!  Construct matrix of distances between knots, F_ij = Delta_ij
   if (.not.silent) call sph_splines_info( &
      'sph_splines_fit: Calculating inter-knot spacings.')
   allocate(F(n,n))
   do i=1,n
      do j=i,n
         if (i==j) then
            F(i,j) = 0._rs
         else
            F(i,j) = sph_splines_delta(s%phi(i),s%theta(i),s%phi(j),s%theta(j),degrees=s%degrees)
         endif
         F(j,i) = F(i,j)
      enddo
   enddo

!  Work out average distance between adjacent points globally, dbar
   if (.not.silent) call sph_splines_info( &
      'sph_splines_fit: Calculating mean knot spacing.')
   s%dbar = 0._rs
   nd = 0
   do i=1,n
!  Take the nearest 6 or so points and take the average distance of these
      dmin = 0._rs
      npoints = 0
      do while (npoints <= 6)
         dmin = minval(F(i,:), F(i,:) > dmin)
         s%dbar = s%dbar + sum(F(i,:), F(i,:) == dmin)
         npoints = npoints + count(F(i,:) == dmin)
         nd = nd + count(F(i,:) == dmin)
      enddo
   enddo
   s%dbar = s%dbar/nd

!  Update F to contain the value of the B-spline function, not just the distance
!  F_ij = f_j(Delta_ij)
   if (.not.silent) call sph_splines_info('sph_splines_fit: Constructing F matrix.')
   do i=1,n
      do j=i,n
         F(i,j) = sph_splines_func(F(i,j),s%dbar)
!         F(j,i) = F(i,j)  ! Only need the upper half in passing to ?posv
      enddo
   enddo

!  Solve the set of equations F*a = c  (In LAPACK terms, A*X = B).
!  The knot coefficients, a, are placed in B, so we copy c into a for this.
!  F is replaced by the L and U factors from the factorisation.
   s%a = s%c

!  Create array for pivot rows
   allocate(ipiv(n))
!  Call the appropriate LAPACK routine for single or double precision
!  The matrix F is real, symmetric, and the diagonal is 0.  All eigenvalues are
!  positive, so it is positive definite.  (Please tell me if this is wrong!)
!  Hence solving by Cholesky decomposition should be faster than calling the more
!  general ?gesv, which uses LU decomposition.
!  If the input values do not give a positive definite matrix, LAPACK will report
!  ier > 0 and the users has probably entered the wrong knot locations or values.
   if (.not.silent) write(lu_stderr,'(a,i0,a,i0,a)') &
      'spherical_splines: sph_splines_fit: Finding spline coefficients by inverting ',&
      n,' x ',n,' matrix.'
   if (rs == r8) then
!      call dgesv(n,1,F,n,ipiv,s%a,n,ier)  ! Works for all non-singular matrices
      call dposv('U',n,1,F,n,s%a,n,ier)   ! Works for positive definite matrices
   else if (rs == r4) then
!      call sgesv(n,1,F,n,ipiv,s%a,n,ier)
      call sposv('U',n,1,F,n,s%a,n,ier)
   else
      call sph_splines_fatal('module compiled with neither real or double precision')
   endif

!  Check status
!   if (ier > 0) call sph_splines_fatal( &
!      'sph_splines_fit: trying to solve singular matrix.  Check knots and values.')
   if (ier > 0) call sph_splines_fatal( &
      'sph_splines_fit: F matrix is not positive definite.  Check knots and values.')
   if (ier < 0) call sph_splines_fatal( &
      'sph_splines_fit: illegal value somewhere in call to LAPACK.')
   if (ier == 0 .and..not.silent) call sph_splines_info( &
      'sph_splines_fit: Successfully solved for knot coefficients.')

!  Deallocate things we won't use outside the subroutine
   deallocate(F,ipiv)

!  Mark down which kernel we've fitted
   s%kernel = 'B '

end subroutine sph_splines_fit
!-------------------------------------------------------------------------------

!===============================================================================
subroutine sph_splines_fit_AP(s,half_width,quiet)
!===============================================================================
!  Calculate the spline coefficients for the Abel-Poisson kernel representation
!  h is the desired scaling parameter.  Using sph_splines_AP_width2h can give you
!  a value of h for the desired half-width in degrees of the kernel.
   implicit none
   type(sph_splines_set),intent(inout) :: s
   real(rs),intent(in),optional :: half_width  ! Degrees
   logical,intent(in),optional :: quiet
   logical :: silent
   integer :: n  ! number of knots; length of phi,theta,r
   integer :: i,j,ier
   real(rs),allocatable :: F(:,:)   ! Matrix of distances between point i and j
!   real(rs) :: d,dmin

!  Get the level of verbosity.  Default to noisy
   silent = .false.
   if (present(quiet)) silent = quiet

!  Check for conflict between supplied h or requested half_width
   if (s%h > 0._rs .and. present(half_width) .and. .not.silent) &
      call sph_splines_info('sph_splines_fit_AP: overwriting value of h with that ' &
                         // 'generated by call to sph_splines_AP_width2h')

!  Calculate the desired value of h if we don't know it already
   if (present(half_width)) then
      s%h = sph_splines_AP_width2h(half_width,degrees=.true.)
      if (.not.silent) write(lu_stderr,'(2a,f0.3)') 'spherical_splines: ', &
            'sph_splines_fit_AP: Using h-value of ',s%h
   endif

!  Check for the right things being present
   if (.not.(allocated(s%phi) .and. allocated(s%theta) .and. allocated(s%c))) &
      call sph_splines_fatal('sph_splines_fit_AP: location or values of knot points not allocated')

!  Get length of input arrays and make sure they're the same length
   n = size(s%phi)
   if (s%n /= n .or. size(s%theta) /= n .or. size(s%c) /= n) &
      call sph_splines_fatal('sph_splines_fit_AP: structure arrays must all be same length.')

!  (Re-)Allocate s%a if already allocated to a length != n
   if (allocated(s%a)) then
      if (size(s%a) /= n) then
         deallocate(s%a);  allocate(s%a(n))
         if (.not.silent) call sph_splines_info( &
               'sph_splines_fit_AP: allocating memory for spline coefficients.')
      endif
   else
      allocate(s%a(n))
      if (.not.silent) call sph_splines_info( &
            'sph_splines_fit_AP: allocating memory for spline coefficients.')
   endif

!  Construct matrix of distances between knots, F_ij = Delta_ij
   if (.not.silent) call sph_splines_info( &
      'sph_splines_fit_AP: Calculating inter-knot spacings.')
   allocate(F(n,n))
   do i=1,n
      do j=i,n
         if (i==j) then
            F(i,j) = 0._rs
         else
            F(i,j) = sph_splines_delta(s%phi(i),s%theta(i),s%phi(j),s%theta(j),degrees=s%degrees)
         endif
         F(j,i) = F(i,j)
      enddo
   enddo

!  Work out average distance between adjacent points globally, dbar
!   if (.not.silent) call sph_splines_info( &
!      'sph_splines_fit: Calculating mean knot spacing.')
!
!   s%dbar = 0._rs
!   nd = 0
!   do i=1,n
!  Take the nearest 6 or so points and take the average distance of these
!      dmin = 0._rs
!      npoints = 0
!      do while (npoints <= 6)
!         dmin = minval(F(i,:), F(i,:) > dmin)
!         s%dbar = s%dbar + sum(F(i,:), F(i,:) == dmin)
!         npoints = npoints + count(F(i,:) == dmin)
!         nd = nd + count(F(i,:) == dmin)
!      enddo
!   enddo
!   s%dbar = s%dbar/nd

!  If necessary, convert distances into radians, as assumed by sph_splines_func_AP
   if (s%degrees) F = F*pi/180_rs

!  Update F to contain the value of the AP-spline function, not just the distance
!  F_ij = f_j(Delta_ij)
   if (.not.silent) call sph_splines_info('sph_splines_fit_AP: Constructing F matrix.')
   do i=1,n
      do j=i,n
         F(i,j) = sph_splines_func_AP(F(i,j),s%h)
!         F(j,i) = F(i,j)  ! Only need the upper half in passing to ?posv
      enddo
   enddo

!  Solve the set of equations F*a = c  (In LAPACK terms, A*X = B).
!  The knot coefficients, a, are placed in B, so we copy c into a for this.
!  F is replaced by the L and U factors from the factorisation.
   s%a = s%c

!  Call the appropriate LAPACK routine for single or double precision
!  The matrix F is real, symmetric, and the diagonal is 0.  All eigenvalues are
!  positive, so it is positive definite.  (Please tell me if this is wrong!)
!  Hence solving by Cholesky decomposition should be faster than calling the more
!  general ?gesv, which uses LU decomposition.
!  If the input values do not give a positive definite matrix, LAPACK will report
!  ier > 0 and the users has probably entered the wrong knot locations or values.
   if (.not.silent) write(lu_stderr,'(a,i0,a,i0,a)') &
      'spherical_splines: sph_splines_fit_AP: Finding spline coefficients by inverting ',&
      n,' x ',n,' matrix.'
   if (rs == r8) then
      call dposv('U',n,1,F,n,s%a,n,ier)   ! Works for positive definite matrices
   else if (rs == r4) then
      call sposv('U',n,1,F,n,s%a,n,ier)
   else
      call sph_splines_fatal('module compiled with neither real or double precision')
   endif

!  Check status
!   if (ier > 0) call sph_splines_fatal( &
!      'sph_splines_fit: trying to solve singular matrix.  Check knots and values.')
   if (ier > 0) call sph_splines_fatal( &
      'sph_splines_fit_AP: F matrix is not positive definite.  Check knots and values.')
   if (ier < 0) call sph_splines_fatal( &
      'sph_splines_fit_AP: illegal value somewhere in call to LAPACK.')
   if (ier == 0 .and..not.silent) call sph_splines_info( &
      'sph_splines_fit_AP: Successfully solved for knot coefficients.')

!  Mark down which kernel we've fitted
   s%kernel = 'AP'

end subroutine sph_splines_fit_AP
!-------------------------------------------------------------------------------

!===============================================================================
subroutine sph_splines_eval(phi,theta,s,c,degrees)
!===============================================================================
!  Evaluate a set of splines with coefficients at a set of arbitrary points
!  on a sphere
   implicit none
   type(sph_splines_set),intent(in) :: s
   real(rs),intent(in),dimension(:) :: phi,theta
   real(rs),dimension(:),intent(out) :: c
   logical,optional,intent(in) :: degrees
   real(rs) :: conversion,d,torad
   integer :: n  ! length of phi and theta
   integer :: i,j

!  Get size of arrays and check a few things
   n = size(phi)
   if (size(theta) /= n .or. size(c) /= n) call sph_splines_fatal( &
      'sph_splines_eval: evaluation coordinates and values must be in arrays of same length')
   if (.not.(allocated(s%phi) .and. allocated(s%theta) .and. allocated(s%a) &
       .and. allocated(s%c))) call sph_splines_fatal( &
      'sph_splines_eval: one or more arrays in the supplied spline set not allocated.')
   if (.not.any(KERNEL_NAME == s%kernel)) call sph_splines_fatal( &
      'sph_splines_eval: kernel type "' // s%kernel // '" not supported.')

!  If necessary, convert input phi and theta to the same units as the
!  splines are given in.  Assume they are the same
   conversion = 1._rs
   if (present(degrees)) then
      if (degrees .eqv. s%degrees) then
         conversion = 1._rs
      else if (degrees) then      ! Must mean s%degrees = .false.
         conversion = pi/180._rs
      else if (.not.degrees) then ! Must mean s%degrees = .true.
         conversion = 180._rs/pi
      else
         call sph_splines_fatal('sph_splines_eval: Andy''s coding is wrong.')
      endif
   else  ! Assume input is in degrees
      if (s%degrees) conversion = 1._rs
      if (.not. s%degrees) conversion = pi/180._rs
   endif

!  We need to pass radians to the AP spline function, so one final conversion.
!  The B-sline function merely needs d and dbar in the same units, so no need to
!  change units for this function.
   torad = 1._rs
   if (s%degrees .and. s%kernel=="AP") torad = pi/180._rs

!  Evaluate spline at each point
   do i=1,n
!      c(i) = sum(s%a*sph_splines_func( &
!               sph_splines_delta(phi(i),theta(i),s%phi,s%theta,degrees=s%degrees),&
!               s%dbar)))
      c(i) = 0._rs
      do j=1,s%n
         d = torad * sph_splines_delta(conversion*phi(i),conversion*theta(i),&
                               s%phi(j),s%theta(j),degrees=s%degrees)
         if (s%kernel == 'B ') then
            c(i) = c(i) + sph_splines_func(d,s%dbar)*s%a(j)
         else if (s%kernel == 'AP') then
            c(i) = c(i) + sph_splines_func_AP(d,s%h)*s%a(j)
         else
            call sph_splines_fatal('sph_splines_fit: kernel "' // s%kernel // &
               '" is not recognised.')
         endif
      enddo
   enddo

end subroutine sph_splines_eval
!-------------------------------------------------------------------------------

!===============================================================================
function sph_splines_func(d,dbar) result(f)
!===============================================================================
!  Compute the spherical B-splines function:
!         { (3/4)d^3/(dbar^3) - (6/4)d^2/(dbar^2) + 1,         d <= dbar
!     f = {-(1/4)d1^3 + (3/4)d1^2 - (3/4)d1 + (1/4)  , dbar <= d <= 2dbar
!         { 0                                        ,         d >  2dbar
!  where
!     d1 = (d - dbar)/dbar.

   implicit none
   real(rs),intent(in)  :: d    ! Distance between this point and knot point
   real(rs),intent(in)  :: dbar ! Mean knot spacing
   real(rs) :: f
   real(rs) :: d1

!  Where the distance is zero, the value of the function is 1.
   if (d < 0._rs) then
      call sph_splines_fatal('sph_splines_func: distance must be > 0.')
   else if (d == 0.) then
      f = 1._rs
   else if (d <= dbar) then
      f = (3._rs/4._rs)*d**3/dbar**3 - (6._rs/4._rs)*d**2/dbar**2 + 1._rs
   else if (d > dbar .and. d <= 2._rs*dbar) then
      d1 = (d - dbar)/dbar
      f = -(1._rs/4._rs)*d1**3 + (3._rs/4._rs)*d1**2 - &
          (3._rs/4._rs)*d1 + (1._rs/4._rs)
   else  ! Outside 2dbar, the value and its derivatives are zero.
      f = 0._rs
   endif

end function sph_splines_func
!-------------------------------------------------------------------------------

!===============================================================================
function sph_splines_func_AP(d,h) result(K)
!===============================================================================
!  Compute the Abel-Poisson spherical splines kernel:
!     Kh(x,y) = (1/4*pi)*(1 - h**2)/(1 + h**2 - 2*h*dot_product(x,y))**(3/2),
!  where
!     x and y are points on the unit sphere.  (Hence x.y is the cosine of the
!  angular distance (d) between the two points.)
!     h is the scaling factor, 0<=h<=1.  Values of h=0.96 correspond to a
!  half-width of maximum intensity at ~1-h (radians)

   implicit none
   real(rs),intent(in) :: d,h  ! Angle between points (radians); and scaling
   real(rs) :: K

   if (d < 0._rs) &
      call sph_splines_fatal('sph_splines_func_AP: distance must be > 0.')
   K = (1._rs/(4._rs*pi))*(1._rs - h**2)/(1._rs + h**2 - 2._rs*h*cos(d))**(1.5_rs)

end function sph_splines_func_AP
!-------------------------------------------------------------------------------

!===============================================================================
subroutine sph_splines_write_coefs(s,outfile)
!===============================================================================
!  Write out the coefficients for a spherical splines set.
!
!  Format is (ascii):
!     [1]      n kernel g     ! n = num coefficients
!                             ! kernel = type of kernel
!                             ! g is dbar or h, depending on kernel
!     [2..n+1] lon lat c      ! lon, colat (degrees), value and coefficient

   implicit none
   type(sph_splines_set),intent(in) :: s
   character(len=*), intent(in) :: outfile
   real(rs) :: temp_val,conversion
   logical :: opened
   integer :: unit,i,iostatus

   call sph_splines_fatal('sph_splines_write_ceofs: Subroutine not tested yet!')

!  Look for available logical unit
   unit = 10
   opened = .true.
   do while(opened)
      inquire(unit,opened=opened)
      if (.not.opened) exit
      if (unit == 100) then
         call sph_splines_fatal( &
            'sph_splines_write_coefs: Unable to find available unit for writing.')
      endif
      unit = unit + 1
   enddo

!  Open file
   open(unit,file=trim(outfile),iostat=iostatus)
   if (iostatus /= 0) call sph_splines_fatal( &
      'sph_splines_write_coefs: Problem opening file "' // trim(outfile) // '"')

!  Write header line
   if (s%kernel == 'B') then
      temp_val = s%dbar
      if (.not.s%degrees) temp_val = s%dbar * 180._rs/pi
   elseif (s%kernel == 'AP') then
      temp_val = s%h
   else
      call sph_splines_fatal( &
         'sph_splines_write_coefs: Unknown kernel "' // s%kernel // '"')
   endif

!  If necessary, convert phi and theta to degrees for output
   conversion = 1._rs
   if (.not.s%degrees) conversion = 180._rs/pi
!  Write header
   write(unit,*) s%n, s%kernel, temp_val
!  Write knot points and coefficients
   do i=1,s%n
      write(unit,*) conversion*s%phi(i), conversion*s%theta(i), s%c(i), s%a(i)
   enddo

   close(unit)

end subroutine sph_splines_write_coefs
!-------------------------------------------------------------------------------

!===============================================================================
function sph_splines_read_coefs(infile) result(s)
!===============================================================================
!  Read the coefficients for a spherical splines set
!  For format of files, see sph_splines_write_coefs

   implicit none
   type(sph_splines_set) :: s
   character(len=*),intent(in) :: infile
   real(rs) :: temp_val
   integer :: i,iostatus,unit
   logical :: opened

   call sph_splines_fatal('sph_splines_read_coefs: Subroutine not tested yet!')

!  Look for available logical unit
   unit = 10
   opened = .true.
   do while(opened)
      inquire(unit,opened=opened)
      if (.not.opened) exit
      if (unit == 100) then
         call sph_splines_fatal( &
            'sph_splines_read_coefs: Unable to find available unit for reading.')
      endif
      unit = unit + 1
   enddo

!  Open file
   open(unit,file=trim(infile),iostat=iostatus)
   if (iostatus /= 0) call sph_splines_fatal( &
      'sph_splines_read_coefs: Problem opening file "' // trim(infile) // '"')

!  Read header
   read(unit,*) s%n, s%kernel, temp_val
   if (s%kernel == 'B') then
      s%dbar = temp_val
   elseif (s%kernel == 'AP') then
      s%h = temp_val
   else
      call sph_splines_fatal( &
         'sph_splines_read_coefs: Unknown kernel "' // trim(s%kernel) // '"')
   endif

!  Allocate space for coordinates and coefficients
   call sph_splines_realloc(s%n,s)

!  Read in data
   do i=1,s%n
      read(unit,*) s%phi(i), s%theta(i), s%c(i), s%a(i)
   enddo

   close(unit)

!  Set the units of the coefficients to be degrees
   s%degrees = .true.

end function sph_splines_read_coefs
!-------------------------------------------------------------------------------

!===============================================================================
function sph_splines_AP_width2h(x,degrees) result(h)
!===============================================================================
!  Using an empirical power law, return the value of h which produces a
!  Abel-Poisson kernel which has the requested half-width.
!  Optionally, specify desired half-width in degrees; default is radians.
   implicit none
   real(rs),intent(in) :: x
   logical,intent(in),optional :: degrees
   real(rs) :: h,r
   real(rs),parameter :: a = -1.31743_rs, b = 0.89017_rs, c = -0.315546_rs, &
                         d = 0.0468784_rs

   r = x  ! Input in radians
   if (present(degrees)) then
      if (degrees) r = pi*x/180._rs  ! Input in degrees
   endif

   h = 1._rs + a*r + b*r**2 + c*r**3 + d*r**4

end function sph_splines_AP_width2h
!-------------------------------------------------------------------------------

!===============================================================================
function sph_splines_delta(phi1,theta1,phi2,theta2,degrees) result(delta)
!===============================================================================
!  delta returns the angular distance between two points on a sphere given
!  the colat and lon of each using the Haversine formula

   implicit none
   real(rs),intent(in) :: phi1,theta1,phi2,theta2
   real(rs) :: delta
   real(rs) :: lon1,lon2,lat1,lat2,conversion
   logical,optional,intent(in) :: degrees

!   real(rs) :: cos_lat1,cos_lat2,sin_lat1,sin_lat2,&
!               cos_lon1,cos_lon2,sin_lon1,sin_lon2

!  Default to degrees input
   conversion = pi/180._rs
   if (present(degrees)) then
      if (.not.degrees) conversion = 1._rs
   endif

!  Convert to radians and from colat to lat for calculation
   lon1 = phi1*conversion         ;  lon2 = phi2*conversion
   lat1 = pi2 - theta1*conversion ;  lat2 = pi2 - theta2*conversion

   delta = atan2( sqrt( (cos(lat2)*sin(lon2-lon1))**2 + (cos(lat1)*sin(lat2) - &
           sin(lat1)*cos(lat2)*cos(lon2-lon1))**2) , &
           sin(lat1)*sin(lat2) + cos(lat1)*cos(lat2)*cos(lon2-lon1))

!  Convert back to desired units
   delta = delta/conversion

end function sph_splines_delta
!-------------------------------------------------------------------------------

!===============================================================================
subroutine sph_splines_fatal(string)
!===============================================================================
!  Utility to flag up a fatal error which stops the program.  Input should be:
!  <name of subroutine>: <error message>
   implicit none
   character(len=*) :: string

   write(lu_stderr,'(2a)') "spherical_splines: ",trim(string)
!  Assuming compiler compatibility, exit with non-0 status
   stop 1
end subroutine sph_splines_fatal
!-------------------------------------------------------------------------------

!===============================================================================
subroutine sph_splines_info(string)
!===============================================================================
!  Utility to write out some information to stderr.  Input should be:
!  <name of subroutine>: <info message>
   implicit none
   character(len=*) :: string

   write(lu_stderr,'(2a)') "spherical_splines: ",trim(string)
end subroutine sph_splines_info
!-------------------------------------------------------------------------------

!===============================================================================
subroutine sph_splines_realloc(n,s)
!===============================================================================
!  (Re)allocate the right amount of space for the arrays in the sph_splines_set
!  structure.
!  Defaults to verbose, so supply quiet=.true. to hush the subroutine up.

   implicit none
   type(sph_splines_set),intent(inout) :: s
   integer,intent(in) :: n

   if (allocated(s%phi)) then
      if (size(s%phi) /= n) then
         deallocate(s%phi);  allocate(s%phi(n))
      endif
   else
      allocate(s%phi(n))
   endif

   if (allocated(s%theta)) then
      if (size(s%theta) /= n) then
         deallocate(s%theta);  allocate(s%theta(n))
      endif
   else
      allocate(s%theta(n))
   endif

   if (allocated(s%a)) then
      if (size(s%a) /= n) then
         deallocate(s%a);  allocate(s%a(n))
      endif
   else
      allocate(s%a(n))
   endif

   if (allocated(s%c)) then
      if (size(s%c) /= n) then
         deallocate(s%c);  allocate(s%c(n))
      endif
   else
      allocate(s%c(n))
   endif

end subroutine sph_splines_realloc
!-------------------------------------------------------------------------------

!_______________________________________________________________________________
end module spherical_splines


	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
	REAL WATER(500),CIBR(500),BUFOUT(10000),VAL(32767)
	INTEGER IBUF(10000)
	CHARACTER*80 PRT
	CHARACTER*40 FILNAM(2)
C						open input, get size and org
	CALL XVUNIT(INUNIT1,'INP',1,ISTAT,' ')
	CALL XVOPEN(INUNIT1,ISTAT,'OPEN_ACT','SA','IO_ACT','SA',
     +		    'U_FORMAT','FULL',' ')
	CALL XVSIZE(ISL,ISS,NL,NS,NLIN,NSIN)
C			       					open output
	CALL XVUNIT(IOUTUNIT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUTUNIT,ISTAT,'OP','WRITE','U_NL',NL,'U_NS',NS,
     +		    'OPEN_ACT','SA','IO_ACT','SA',
     +		    'U_FORMAT','REAL','O_FORMAT','REAL',' ')
C							get remaining parameters
	CALL XVPARM('SCALE',SCALE,ICNT,IDEF,0)
	CALL XVPARM('INP',FILNAM,ICNT,IDEF,0)
C						    read in CIBR and H2O columns
	CALL READDS(FILNAM(2),WATER,CIBR,NVALS)
C						       compute linear regression
	N = 0
	SUMX = 0.0
	SUMY = 0.0
	SUMX2 = 0.0
	SUMXY = 0.0
	DO I=1,NVALS
	    IF (WATER(I).GT.0.0 .AND. CIBR(I).LT.1.0 .AND.
     +		CIBR(I).GT.0.0) THEN
		N = N+1
		X = ALOG(WATER(I))
		Y = ALOG(-1.0*ALOG(CIBR(I)))
		SUMX = SUMX + X
		SUMY = SUMY + Y
		SUMX2 = SUMX2 + X*X
		SUMXY = SUMXY + X*Y
		SUMY2 = SUMY2 + Y*Y
	    END IF
	END DO
	SLOPE = (SUMX*SUMY - N*SUMXY) / (SUMX*SUMX - N*SUMX2)
	OFFSET = (SUMY - SLOPE*SUMX) / N
	R2 = (SLOPE*SLOPE*(SUMX2 - (SUMX*SUMX/N))) /
     +		(SUMY2 - (SUMY*SUMY/N))
	ALPHA = EXP(OFFSET)
	BETA = SLOPE
C							      update VICAR label
	CALL XLADD(IOUTUNIT,'HISTORY','ALPHA',ALPHA,ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUTUNIT,'HISTORY','BETA',BETA,ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUTUNIT,'HISTORY','FIT',R2,ISTAT,
     +		   'FORMAT','REAL',' ')
	WRITE (PRT,100) ALPHA,BETA,R2
  100	FORMAT(' alpha = ',F7.5,'   beta = ',F7.5,'   fit = ',F6.4)
	CALL XVMESSAGE(PRT,' ')
	IF (ALPHA .LE. 0.0) THEN
	    CALL XVMESSAGE(' Invalid alpha value',' ')
	    CALL ABEND
	ENDIF
C								       build LUT
	X = -1.0/ALPHA
	Y = 1.0/BETA
	DO I=1,32767
	    Z = SCALE*I
	    IF (Z.LT.1.0) THEN
		VAL(I) = (X*LOG(Z))**Y
	    ELSE
		VAL(I) = -1.0
	    END IF
	END DO
C							      build output image
	IEL = ISL + NL - 1
	DO I=ISL,IEL
	    CALL XVREAD(INUNIT,IBUF,ISTAT,'SAMP',ISS,'NSAMPS',NS,
     +			'LINE',I,' ')
	    DO J=1,NS
		IF (IBUF(J) .GT. 0) THEN
		    BUFOUT(J) = VAL(IBUF(J))
		ELSE
		    BUFOUT(J) = 99999.0
		END IF
	    END DO
	    CALL XVWRIT(IOUTUNIT,BUFOUT,ISTAT,'NSAMPS',NS,' ')
	END DO
	RETURN
	END
C**************************************************************************
      SUBROUTINE READDS(FILENAME,COL1,COL2,NRECS)
C
C      This subroutine reads all records from the file FILENAME, and puts
C      the first numeric value that it finds in the COL1 array and the
C      second numeric value in the COL2 array.  If something other than a
C      numeric or delimiter is encountered prior to finding two numeric fields,
C      the entire line is discarded.
C
      CHARACTER*40 FILENAME
      REAL COL1(*),COL2(*)
C
      OPEN (51,FILE=FILENAME,STATUS='OLD')
      NRECS = 1
  100 CONTINUE
          READ (51,*,END=900,ERR=100) COL1(NRECS),COL2(NRECS)
	  NRECS = NRECS+1
          GO TO 100
  900 CONTINUE
      NRECS = NRECS-1
      RETURN
      END


      SUBROUTINE MECDF(NDIM, D, RHO, PROB, IER)
      INTEGER NDIM, IER
      DOUBLE PRECISION D(*), PROB, RHO(*)
C-----------------------------------------------------------------
C       6/29/90
C       This subroutine is designed to calculate the MVN CDF
C       using the Mendell-Elston procedure as described in
C       Kamakura (1989).  The current version is set up to go
C       as high as 19 dimensions (=> 20 MNP alternatives)
C       NOTE:  Equation (15) in Kamakura has an error.
C
C       Specifically, assume that Z is a set of random variables
C       with a standard normal distribution with correlations
C       stored in RHO (in packed form).  Then this subroutine
C       calculates Prob[Z(1)>D(1);...; Z(NDIM) > D(NDIM)].
C-----------------------------------------------------------------

      DOUBLE PRECISION ALNORM, PHI
      EXTERNAL ALNORM, PHI

      INTEGER MAXALT, NMAX
      PARAMETER (MAXALT=20, NMAX=MAXALT-1)

      INTEGER I, IM1, IR, J, JM1, K, KM1
      DOUBLE PRECISION PROBI, TMP
      DOUBLE PRECISION R(NMAX,NMAX,0:NMAX-1), SIG(NMAX,0:NMAX-1),
     1                 U(NMAX), UUMZ(NMAX-1), Z(NMAX,0:NMAX-1)

      DOUBLE PRECISION ONE, ZERO
      PARAMETER (ONE=1.D0, ZERO=0.D0)

C-----------------------------------------------------------------
C       Test dimension
      IER = 0
      IF (NDIM.GT.NMAX) THEN
         IER = -1
         RETURN
      ENDIF
C       Set up arrays
      IR = 0
      DO 10 I = 1, NDIM
         Z(I,0) = D(I)
         DO 10 J = 1, I-1
            IR = IR + 1
            R(J,I,0) = RHO(IR)
 10     CONTINUE
      PROB = ALNORM(Z(1,0), .TRUE.)
      IF (PROB.LE.ZERO) THEN
         IER = 1
         RETURN
      ENDIF
      U(1) = PHI(Z(1,0), ZERO)/PROB
      UUMZ(1) = U(1)*(U(1)-Z(1,0))

C       Main loop
      DO 40 I = 2, NDIM
         IM1 = I-1
         DO 30 J = 1, IM1
            JM1 = J-1
            DO 20 K = 1, JM1
               KM1 = K-1
               TMP = R(J,I,KM1)-R(K,J,KM1)*R(K,I,KM1)*UUMZ(K)
               R(J,I,K) = TMP/SIG(J,K)/SIG(I,K)
 20           CONTINUE
            SIG(I,J) = SQRT(ONE - UUMZ(J)*R(J,I,JM1)**2)
            Z(I,J) = (Z(I,JM1)-U(J)*R(J,I,JM1))/SIG(I,J)
 30        CONTINUE
         PROBI = ALNORM(Z(I,IM1), .TRUE.)
         IF (PROBI.LE.ZERO) THEN
            IER = I
            RETURN
         ENDIF
         PROB = PROB * PROBI
         IF (I.LT.NDIM) THEN
            U(I) = PHI(Z(I,IM1), ZERO)/PROBI
            UUMZ(I) = U(I)*(U(I)-Z(I,IM1))
         ENDIF
 40     CONTINUE
      END


MODULE module_sf_sfcdiags

CONTAINS

   SUBROUTINE SFCDIAGS(HFX,QFX,TSK,QSFC,CHS2,CQS2,T2,TH2,Q2, &
                     PSFC,CP,R_d,ROVCP,CHS,T3D,QV3D,UA_PHYS, &
                     ids,ide, jds,jde, kds,kde, &
                     ims,ime, jms,jme, kms,kme, &
                     its,ite, jts,jte, kts,kte )

      IMPLICIT NONE

      INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
                                        ims,ime, jms,jme, kms,kme, &
                                        its,ite, jts,jte, kts,kte
      REAL, DIMENSION( ims:ime, jms:jme ) , &
                INTENT(IN) :: HFX, &
                                                              QFX, &
                                                              TSK, &
                                                             QSFC
      REAL, DIMENSION( ims:ime, jms:jme ) , &
                INTENT(INOUT) :: Q2, &
                                                             TH2, &
                                                              T2
      REAL, DIMENSION( ims:ime, jms:jme ) , &
                INTENT(IN) :: PSFC, &
                                                             CHS2, &
                                                             CQS2
      REAL, INTENT(IN ) :: CP,R_d,ROVCP

      LOGICAL, INTENT(IN) :: UA_PHYS
      REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
            INTENT(IN ) :: QV3D,T3D
      REAL, DIMENSION( ims:ime, jms:jme ) , &
                INTENT(IN) :: CHS

      INTEGER :: I,J
      REAL :: RHO

      DO J=jts,jte
        DO I=its,ite
          RHO = PSFC(I,J)/(R_d * TSK(I,J))
          if(CQS2(I,J).lt.1.E-5) then
             Q2(I,J)=QSFC(I,J)
          else
              IF ( UA_PHYS ) THEN
                  Q2(I,J) = QSFC(I,J) - CHS(I,J)/CQS2(I,J)*(QSFC(I,J) - QV3D(i,1,j))
              ELSE
                  Q2(I,J) = QSFC(I,J) - QFX(I,J)/(RHO*CQS2(I,J))
              ENDIF
          endif
          if(CHS2(I,J).lt.1.E-5) then
             T2(I,J) = TSK(I,J)
          else
              IF ( UA_PHYS ) THEN
                  T2(I,J) = TSK(I,J) - CHS(I,J)/CHS2(I,J)*(TSK(I,J) - T3D(i,1,j))
              ELSE
                  T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J))
              ENDIF
          endif
          TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP
        ENDDO
      ENDDO

  END SUBROUTINE SFCDIAGS

END MODULE module_sf_sfcdiags


      subroutine moment(data,n,
     &                  ave,adev,sdev,var,skew,curt,
     &                  istatus)
c
c
      dimension data(9)
      parameter (r_missing_data = +1e37)
      istatus=0
      if(n.le.1)then
            print *, 'n must be at least 2'
            istatus=1
            return
      endif
      s=0.
      do 11 j=1,n
        s=s+data(j)
11    continue
      ave=s/n
      adev=0.
      var=0.
      skew=0.
      curt=0.
      do 12 j=1,n
        s=data(j)-ave
        adev=adev+abs(s)
        p=s*s
        var=var+p
        p=p*s
        skew=skew+p
        p=p*s
        curt=curt+p
12    continue
      adev=adev/n
      var=var/(n-1)
      if(var.ne.0.)then
        sdev=sqrt(var)
        skew=skew/(n*sdev**3)
        curt=curt/(n*var**2)-3.
      else
        sdev=r_missing_data
        skew=r_missing_data
        curt=r_missing_data
c       print*,  'no skew or kurtosis when zero variance'
      endif
      return
      end


!*==slag2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary to avoid over-/underflow.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLAG2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1,
!                         WR2, WI )
!
!       .. Scalar Arguments ..
!       INTEGER            LDA, LDB
!       REAL               SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
!       ..
!       .. Array Arguments ..
!       REAL               A( LDA, * ), B( LDB, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
!> problem  A - w B, with scaling as necessary to avoid over-/underflow.
!>
!> The scaling factor "s" results in a modified eigenvalue equation
!>
!>     s A - w B
!>
!> where  s  is a non-negative scaling factor chosen so that  w,  w B,
!> and  s A  do not overflow and, if possible, do not underflow, either.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] A
!> \verbatim
!>          A is REAL array, dimension (LDA, 2)
!>          On entry, the 2 x 2 matrix A.  It is assumed that its 1-norm
!>          is less than 1/SAFMIN.  Entries less than
!>          sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= 2.
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is REAL array, dimension (LDB, 2)
!>          On entry, the 2 x 2 upper triangular matrix B.  It is
!>          assumed that the one-norm of B is less than 1/SAFMIN.  The
!>          diagonals should be at least sqrt(SAFMIN) times the largest
!>          element of B (in absolute value); if a diagonal is smaller
!>          than that, then  +/- sqrt(SAFMIN) will be used instead of
!>          that diagonal.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= 2.
!> \endverbatim
!>
!> \param[in] SAFMIN
!> \verbatim
!>          SAFMIN is REAL
!>          The smallest positive number s.t. 1/SAFMIN does not
!>          overflow.  (This should always be SLAMCH('S') -- it is an
!>          argument in order to avoid having to call SLAMCH frequently.)
!> \endverbatim
!>
!> \param[out] SCALE1
!> \verbatim
!>          SCALE1 is REAL
!>          A scaling factor used to avoid over-/underflow in the
!>          eigenvalue equation which defines the first eigenvalue.  If
!>          the eigenvalues are complex, then the eigenvalues are
!>          ( WR1  +/-  WI i ) / SCALE1  (which may lie outside the
!>          exponent range of the machine), SCALE1=SCALE2, and SCALE1
!>          will always be positive.  If the eigenvalues are real, then
!>          the first (real) eigenvalue is  WR1 / SCALE1 , but this may
!>          overflow or underflow, and in fact, SCALE1 may be zero or
!>          less than the underflow threshold if the exact eigenvalue
!>          is sufficiently large.
!> \endverbatim
!>
!> \param[out] SCALE2
!> \verbatim
!>          SCALE2 is REAL
!>          A scaling factor used to avoid over-/underflow in the
!>          eigenvalue equation which defines the second eigenvalue.  If
!>          the eigenvalues are complex, then SCALE2=SCALE1.  If the
!>          eigenvalues are real, then the second (real) eigenvalue is
!>          WR2 / SCALE2 , but this may overflow or underflow, and in
!>          fact, SCALE2 may be zero or less than the underflow
!>          threshold if the exact eigenvalue is sufficiently large.
!> \endverbatim
!>
!> \param[out] WR1
!> \verbatim
!>          WR1 is REAL
!>          If the eigenvalue is real, then WR1 is SCALE1 times the
!>          eigenvalue closest to the (2,2) element of A B**(-1).  If the
!>          eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
!>          part of the eigenvalues.
!> \endverbatim
!>
!> \param[out] WR2
!> \verbatim
!>          WR2 is REAL
!>          If the eigenvalue is real, then WR2 is SCALE2 times the
!>          other eigenvalue.  If the eigenvalue is complex, then
!>          WR1=WR2 is SCALE1 times the real part of the eigenvalues.
!> \endverbatim
!>
!> \param[out] WI
!> \verbatim
!>          WI is REAL
!>          If the eigenvalue is real, then WI is zero.  If the
!>          eigenvalue is complex, then WI is SCALE1 times the imaginary
!>          part of the eigenvalues.  WI will always be non-negative.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup realOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE SLAG2(A,Lda,B,Ldb,Safmin,Scale1,Scale2,Wr1,Wr2,Wi)
      IMPLICIT NONE
!*--SLAG2159
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      INTEGER Lda , Ldb
      REAL Safmin , Scale1 , Scale2 , Wi , Wr1 , Wr2
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*) , B(Ldb,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE , TWO
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0,TWO=2.0E+0)
      REAL HALF
      PARAMETER (HALF=ONE/TWO)
      REAL FUZZY1
      PARAMETER (FUZZY1=ONE+1.0E-5)
!     ..
!     .. Local Scalars ..
      REAL a11 , a12 , a21 , a22 , abi22 , anorm , as11 , as12 , as22 , &
     &     ascale , b11 , b12 , b22 , binv11 , binv22 , bmin , bnorm ,  &
     &     bscale , bsize , c1 , c2 , c3 , c4 , c5 , diff , discr , pp ,&
     &     qq , r , rtmax , rtmin , s1 , s2 , safmax , shift , ss ,     &
     &     sum , wabs , wbig , wdet , wscale , wsize , wsmall
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , MIN , SIGN , SQRT
!     ..
!     .. Executable Statements ..
!
      rtmin = SQRT(Safmin)
      rtmax = ONE/rtmin
      safmax = ONE/Safmin
!
!     Scale A
!
      anorm = MAX(ABS(A(1,1))+ABS(A(2,1)),ABS(A(1,2))+ABS(A(2,2)),      &
     &        Safmin)
      ascale = ONE/anorm
      a11 = ascale*A(1,1)
      a21 = ascale*A(2,1)
      a12 = ascale*A(1,2)
      a22 = ascale*A(2,2)
!
!     Perturb B if necessary to insure non-singularity
!
      b11 = B(1,1)
      b12 = B(1,2)
      b22 = B(2,2)
      bmin = rtmin*MAX(ABS(b11),ABS(b12),ABS(b22),rtmin)
      IF ( ABS(b11)<bmin ) b11 = SIGN(bmin,b11)
      IF ( ABS(b22)<bmin ) b22 = SIGN(bmin,b22)
!
!     Scale B
!
      bnorm = MAX(ABS(b11),ABS(b12)+ABS(b22),Safmin)
      bsize = MAX(ABS(b11),ABS(b22))
      bscale = ONE/bsize
      b11 = b11*bscale
      b12 = b12*bscale
      b22 = b22*bscale
!
!     Compute larger eigenvalue by method described by C. van Loan
!
!     ( AS is A shifted by -SHIFT*B )
!
      binv11 = ONE/b11
      binv22 = ONE/b22
      s1 = a11*binv11
      s2 = a22*binv22
      IF ( ABS(s1)<=ABS(s2) ) THEN
         as12 = a12 - s1*b12
         as22 = a22 - s1*b22
         ss = a21*(binv11*binv22)
         abi22 = as22*binv22 - ss*b12
         pp = HALF*abi22
         shift = s1
      ELSE
         as12 = a12 - s2*b12
         as11 = a11 - s2*b11
         ss = a21*(binv11*binv22)
         abi22 = -ss*b12
         pp = HALF*(as11*binv11+abi22)
         shift = s2
      ENDIF
      qq = ss*as12
      IF ( ABS(pp*rtmin)>=ONE ) THEN
         discr = (rtmin*pp)**2 + qq*Safmin
         r = SQRT(ABS(discr))*rtmax
      ELSEIF ( pp**2+ABS(qq)<=Safmin ) THEN
         discr = (rtmax*pp)**2 + qq*safmax
         r = SQRT(ABS(discr))*rtmin
      ELSE
         discr = pp**2 + qq
         r = SQRT(ABS(discr))
      ENDIF
!
!     Note: the test of R in the following IF is to cover the case when
!           DISCR is small and negative and is flushed to zero during
!           the calculation of R.  On machines which have a consistent
!           flush-to-zero threshold and handle numbers above that
!           threshold correctly, it would not be necessary.
!
      IF ( discr>=ZERO .OR. r==ZERO ) THEN
         sum = pp + SIGN(r,pp)
         diff = pp - SIGN(r,pp)
         wbig = shift + sum
!
!        Compute smaller eigenvalue
!
         wsmall = shift + diff
         IF ( HALF*ABS(wbig)>MAX(ABS(wsmall),Safmin) ) THEN
            wdet = (a11*a22-a12*a21)*(binv11*binv22)
            wsmall = wdet/wbig
         ENDIF
!
!        Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
!        for WR1.
!
         IF ( pp>abi22 ) THEN
            Wr1 = MIN(wbig,wsmall)
            Wr2 = MAX(wbig,wsmall)
         ELSE
            Wr1 = MAX(wbig,wsmall)
            Wr2 = MIN(wbig,wsmall)
         ENDIF
         Wi = ZERO
      ELSE
!
!        Complex eigenvalues
!
         Wr1 = shift + pp
         Wr2 = Wr1
         Wi = r
      ENDIF
!
!     Further scaling to avoid underflow and overflow in computing
!     SCALE1 and overflow in computing w*B.
!
!     This scale factor (WSCALE) is bounded from above using C1 and C2,
!     and from below using C3 and C4.
!        C1 implements the condition  s A  must never overflow.
!        C2 implements the condition  w B  must never overflow.
!        C3, with C2,
!           implement the condition that s A - w B must never overflow.
!        C4 implements the condition  s    should not underflow.
!        C5 implements the condition  max(s,|w|) should be at least 2.
!
      c1 = bsize*(Safmin*MAX(ONE,ascale))
      c2 = Safmin*MAX(ONE,bnorm)
      c3 = bsize*Safmin
      IF ( ascale<=ONE .AND. bsize<=ONE ) THEN
         c4 = MIN(ONE,(ascale/Safmin)*bsize)
      ELSE
         c4 = ONE
      ENDIF
      IF ( ascale<=ONE .OR. bsize<=ONE ) THEN
         c5 = MIN(ONE,ascale*bsize)
      ELSE
         c5 = ONE
      ENDIF
!
!     Scale first eigenvalue
!
      wabs = ABS(Wr1) + ABS(Wi)
      wsize = MAX(Safmin,c1,FUZZY1*(wabs*c2+c3),                        &
     &        MIN(c4,HALF*MAX(wabs,c5)))
      IF ( wsize/=ONE ) THEN
         wscale = ONE/wsize
         IF ( wsize>ONE ) THEN
            Scale1 = (MAX(ascale,bsize)*wscale)*MIN(ascale,bsize)
         ELSE
            Scale1 = (MIN(ascale,bsize)*wscale)*MAX(ascale,bsize)
         ENDIF
         Wr1 = Wr1*wscale
         IF ( Wi/=ZERO ) THEN
            Wi = Wi*wscale
            Wr2 = Wr1
            Scale2 = Scale1
         ENDIF
      ELSE
         Scale1 = ascale*bsize
         Scale2 = Scale1
      ENDIF
!
!     Scale second eigenvalue (if real)
!
      IF ( Wi==ZERO ) THEN
         wsize = MAX(Safmin,c1,FUZZY1*(ABS(Wr2)*c2+c3),                 &
     &           MIN(c4,HALF*MAX(ABS(Wr2),c5)))
         IF ( wsize/=ONE ) THEN
            wscale = ONE/wsize
            IF ( wsize>ONE ) THEN
               Scale2 = (MAX(ascale,bsize)*wscale)*MIN(ascale,bsize)
            ELSE
               Scale2 = (MIN(ascale,bsize)*wscale)*MAX(ascale,bsize)
            ENDIF
            Wr2 = Wr2*wscale
         ELSE
            Scale2 = ascale*bsize
         ENDIF
      ENDIF
!
!     End of SLAG2
!
      END SUBROUTINE SLAG2


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!

submodule(centered_helmholtz_solvers) centered_cartesian_solver

contains

    !     SUBROUTINE hwscrt(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, bdd,
    !                        elmbda, f, idimf, pertrb, ierror)
    !
    ! DIMENSION OF           bda(n),      bdb(n),   bdc(m), bdd(m),
    ! ARGUMENTS              f(idimf, n)
    !
    ! PURPOSE                Solves the standard five-point finite
    !                        difference approximation to the helmholtz
    !                        equation in cartesian coordinates.  this
    !                        equation is
    !
    !                          (d/dx)(du/dx) + (d/dy)(du/dy)
    !                          + lambda*u = f(x, y).
    !
    ! USAGE                  call hwscrt (a, b, m, mbdcnd, bda, bdb, c, d, n,
    !                                     nbdcnd, bdc, bdd, elmbda, f, idimf,
    !                                     pertrb, ierror)
    !
    ! ARGUMENTS
    ! ON INPUT               a, b
    !
    !                          the range of x, i.e., a <= x <= b.
    !                          a must be less than b.
    !
    !                        m
    !                          the number of panels into which the
    !                          interval (a, b) is subdivided.
    !                          hence, there will be m+1 grid points
    !                          in the x-direction given by
    !                          x(i) = a+(i-1)dx for i = 1, 2, ..., m+1,
    !                          where dx = (b-a)/m is the panel width.
    !                          m must be greater than 3.
    !
    !                        mbdcnd
    !                          indicates the type of boundary conditions
    !                          at x = a and x = b.
    !
    !                          = 0  if the solution is periodic in x,
    !                               i.e., u(i, j) = u(m+i, j).
    !                          = 1  if the solution is specified at
    !                               x = a and x = b.
    !                          = 2  if the solution is specified at
    !                               x = a and the derivative of the
    !                               solution with respect to x is
    !                               specified at x = b.
    !                          = 3  if the derivative of the solution
    !                               with respect to x is specified at
    !                               at x = a and x = b.
    !                          = 4  if the derivative of the solution
    !                               with respect to x is specified at
    !                               x = a and the solution is specified
    !                               at x = b.
    !
    !                        bda
    !                          a one-dimensional array of length n+1 that
    !                          specifies the values of the derivative
    !                          of the solution with respect to x at x = a.
    !
    !                          when mbdcnd = 3 or 4,
    !
    !                            bda(j) = (d/dx)u(a, y(j)), j = 1, 2, ..., n+1.
    !
    !                          when mbdcnd has any other value, bda is
    !                          a dummy variable.
    !
    !                        bdb
    !                          a one-dimensional array of length n+1
    !                          that specifies the values of the derivative
    !                          of the solution with respect to x at x = b.
    !
    !                          when mbdcnd = 2 or 3,
    !
    !                            bdb(j) = (d/dx)u(b, y(j)), j = 1, 2, ..., n+1
    !
    !                          when mbdcnd has any other value bdb is a
    !                          dummy variable.
    !
    !                        c, d
    !                          the range of y, i.e., c <= y <= d.
    !                          c must be less than d.
    !
    !                        n
    !                          the number of panels into which the
    !                          interval (c, d) is subdivided.  hence,
    !                          there will be n+1 grid points in the
    !                          y-direction given by y(j) = c+(j-1)dy
    !                          for j = 1, 2, ..., n+1, where
    !                          dy = (d-c)/n is the panel width.
    !                          n must be greater than 3.
    !
    !                        nbdcnd
    !                          indicates the type of boundary conditions at
    !                          y = c and y = d.
    !
    !                          = 0  if the solution is periodic in y,
    !                               i.e., u(i, j) = u(i, n+j).
    !                          = 1  if the solution is specified at
    !                               y = c and y = d.
    !                          = 2  if the solution is specified at
    !                               y = c and the derivative of the
    !                               solution with respect to y is
    !                               specified at y = d.
    !                          = 3  if the derivative of the solution
    !                               with respect to y is specified at
    !                               y = c and y = d.
    !                          = 4  if the derivative of the solution
    !                               with respect to y is specified at
    !                               y = c and the solution is specified
    !                               at y = d.
    !
    !                        bdc
    !                          a one-dimensional array of length m+1 that
    !                          specifies the values of the derivative
    !                          of the solution with respect to y at y = c.
    !
    !                          when nbdcnd = 3 or 4,
    !
    !                            bdc(i) = (d/dy)u(x(i), c), i = 1, 2, ..., m+1
    !
    !                          when nbdcnd has any other value, bdc is
    !                          a dummy variable.
    !
    !                        bdd
    !                          a one-dimensional array of length m+1 that
    !                          specifies the values of the derivative
    !                          of the solution with respect to y at y = d.
    !
    !                          when nbdcnd = 2 or 3,
    !
    !                            bdd(i) = (d/dy)u(x(i), d), i = 1, 2, ..., m+1
    !
    !                          when nbdcnd has any other value, bdd is
    !                          a dummy variable.
    !
    !                        elmbda
    !                          the constant lambda in the helmholtz
    !                          equation.  if lambda > 0, a solution
    !                          may not exist.  however, hwscrt will
    !                          attempt to find a solution.
    !
    !                        f
    !                          a two-dimensional array, of dimension at
    !                          least (m+1)*(n+1), specifying values of the
    !                          right side of the helmholtz  equation and
    !                          boundary values (if any).
    !
    !                          on the interior, f is defined as follows:
    !                          for i = 2, 3, ..., m and j = 2, 3, ..., n
    !                          f(i, j) = f(x(i), y(j)).
    !
    !                          on the boundaries, f is defined as follows:
    !                          for j=1, 2, ..., n+1,  i=1, 2, ..., m+1,
    !
    !                          mbdcnd     f(1, j)        f(m+1, j)
    !                          ------     ---------     --------
    !
    !                            0        f(a, y(j))     f(a, y(j))
    !                            1        u(a, y(j))     u(b, y(j))
    !                            2        u(a, y(j))     f(b, y(j))
    !                            3        f(a, y(j))     f(b, y(j))
    !                            4        f(a, y(j))     u(b, y(j))
    !
    !
    !                          nbdcnd     f(i, 1)        f(i, n+1)
    !                          ------     ---------     --------
    !
    !                            0        f(x(i), c)     f(x(i), c)
    !                            1        u(x(i), c)     u(x(i), d)
    !                            2        u(x(i), c)     f(x(i), d)
    !                            3        f(x(i), c)     f(x(i), d)
    !                            4        f(x(i), c)     u(x(i), d)
    !
    !                          note:
    !                          if the table calls for both the solution u
    !                          and the right side f at a corner then the
    !                          solution must be specified.
    !
    !                        idimf
    !                          the row (or first) dimension of the array
    !                          f as it appears in the program calling
    !                          hwscrt.  this parameter is used to specify
    !                          the variable dimension of f.  idimf must
    !                          be at least m+1  .
    !
    !
    ! ON OUTPUT              f
    !                          contains the solution u(i, j) of the finite
    !                          difference approximation for the grid point
    !                          (x(i), y(j)), i = 1, 2, ..., m+1,
    !                          j = 1, 2, ..., n+1  .
    !
    !                        pertrb
    !                          if a combination of periodic or derivative
    !                          boundary conditions is specified for a
    !                          poisson equation (lambda = 0), a solution
    !                          may not exist.  pertrb is a constant,
    !                          calculated and subtracted from f, which
    !                          ensures that a solution exists.  hwscrt
    !                          then computes this solution, which is a
    !                          least squares solution to the original
    !                          approximation.  this solution plus any
    !                          constant is also a solution.  hence, the
    !                          solution is not unique.  the value of
    !                          pertrb should be small compared to the
    !                          right side f.  otherwise, a solution is
    !                          obtained to an essentially different
    !                          problem. this comparison should always
    !                          be made to insure that a meaningful
    !                          solution has been obtained.
    !
    !                        ierror
    !                          an error flag that indicates invalid input
    !                          parameters.  except for numbers 0 and 6,
    !                          a solution is not attempted.
    !
    !                          = 0  no error
    !                          = 1  a >= b
    !                          = 2  mbdcnd < 0 or mbdcnd > 4
    !                          = 3  c >= d
    !                          = 4  n <= 3
    !                          = 5  nbdcnd < 0 or nbdcnd > 4
    !                          = 6  lambda > 0
    !                          = 7  idimf < m+1
    !                          = 8  m <= 3
    !                          = 20 If the dynamic allocation of real and
    !                               complex workspace required for solution
    !                               fails (for example if n, m are too large
    !                               for your computer)
    !
    !                          since this is the only means of indicating
    !                          a possibly incorrect call to hwscrt, the
    !                          user should test ierror after the call.
    !
    !
    ! HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN THE LATE
    !                        1970'S.  RELEASED ON NCAR'S PUBLIC SOFTWARE
    !                        LIBRARIES IN January 1980.
    !                        Revised in June 2004 by John Adams using
    !                        Fortran 90 dynamically allocated workspace.
    !
    !
    ! ALGORITHM              The routine defines the finite difference
    !                        equations, incorporates boundary data, and
    !                        adjusts the right side of singular systems
    !                        and then calls genbun to solve the system.
    !
    ! TIMING                 For large  m and n, the operation count
    !                        is roughly proportional to
    !
    !                        m*n*log2(n)
    !
    !                        but also depends on input parameters nbdcnd
    !                        and mbdcnd.
    !
    ! ACCURACY               The solution process employed results in a loss
    !                        of no more than three significant digits for n
    !                        and m as large as 64.  more details about
    !                        accuracy can be found in the documentation for
    !                        subroutine genbun which is the routine that
    !                        solves the finite difference equations.
    !
    ! REFERENCES             Swarztrauber, P. and R. Sweet, "Efficient
    !                        FORTRAN subprograms for the solution of
    !                        elliptic equations"
    !                        NCAR TN/IA-109, July, 1975, 138 pp.
    !
    module subroutine hwscrt(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout)  :: f(:,:)

        ! Local variables
        type(FishpackWorkspace)  :: workspace

        ! Check input arguments
        call hwscrt_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, idimf, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Allocate memory
        call workspace%initialize_centered_workspace(n, m)

        ! Solve system
        associate( rew => workspace%real_workspace)
            call hwscrt_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, &
                n, nbdcnd, bdc, bdd, elmbda, f, idimf, pertrb, ierror, rew)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine hwscrt

    subroutine hwscrt_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror, w)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout)  :: f(idimf,*)
        real(wp),    intent(inout)  :: w(:)

        ! Local variables
        integer(ip) :: nperod, mperod, np, np1, mp, mp1, nstart, nstop, nskip
        integer(ip) :: nunk, mstart, mstop, mskip, munk, id2, id3, id4
        integer(ip) :: local_error_flag
        real(wp)    :: dx, twdelx, delxsq, dy
        real(wp)    :: twdely, delysq, s, two_s
        type(CenteredCyclicReductionUtility) :: util

        nperod = nbdcnd

        if (mbdcnd > 0) then
            mperod = 1
        else
            mperod = 0
        end if

        dx = (b - a)/m
        twdelx = TWO/dx
        delxsq = ONE/dx**2
        dy = (d - c)/n
        twdely = TWO/dy
        delysq = ONE/dy**2
        np = nbdcnd + 1
        np1 = n + 1
        mp = mbdcnd + 1
        mp1 = m + 1
        nstart = 1
        nstop = n
        nskip = 1

        select case (np)
            case (2)
                nstart = 2
            case (3)
                nstart = 2
                nstop = np1
                nskip = 2
            case (4)
                nstop = np1
                nskip = 2
        end select

        nunk = nstop - nstart + 1
        !
        ! Enter boundary data for x-boundaries.
        !
        mstart = 1
        mstop = m
        mskip = 1

        if (mp /= 1) then
            select case (mp)
                case (2)
                    mstart = 2
                    f(2, nstart:nstop) = f(2, nstart:nstop) - f(1, nstart:nstop)*delxsq
                case (3)
                    mstart = 2
                    mstop = mp1
                    mskip = 2
                    f(2, nstart:nstop) = f(2, nstart:nstop) - f(1, nstart:nstop)*delxsq
                case (4)
                    mstop = mp1
                    mskip = 2
                    f(1, nstart:nstop) = f(1, nstart:nstop) + bda(nstart:nstop)*twdelx
                case (5)
                    f(1, nstart:nstop) = f(1, nstart:nstop) + bda(nstart:nstop)*twdelx
            end select

            select case (mskip)
                case default
                    f(m, nstart:nstop) = f(m, nstart:nstop) - f(mp1, nstart:nstop)* &
                        delxsq
                case (2)
                    f(mp1, nstart:nstop) = f(mp1, nstart:nstop) - bdb(nstart:nstop)* &
                        twdelx
            end select
        end if

        munk = mstop - mstart + 1
        !
        ! Enter boundary data for y-boundaries.
        !
        if (np /= 1) then
            select case (np)
                case (2:3)
                    f(mstart:mstop, 2) = f(mstart:mstop, 2) - f(mstart:mstop, 1)*delysq
                case (4:5)
                    f(mstart:mstop, 1) = f(mstart:mstop, 1) + bdc(mstart:mstop)*twdely
            end select

            select case (nskip)
                case default
                    f(mstart:mstop, n) = f(mstart:mstop, n) - f(mstart:mstop, np1)* &
                        delysq
                case (2)
                    f(mstart:mstop, np1) = f(mstart:mstop, np1) - bdd(mstart:mstop)* &
                        twdely
            end select
        end if

        ! Multiply right side by deltay**2.
        delysq = dy**2
        f(mstart:mstop, nstart:nstop) = f(mstart:mstop, nstart:nstop)*delysq

        !     Define the a, b, c coefficients in w-array.
        id2 = munk
        id3 = id2 + munk
        id4 = id3 + munk
        s = delysq*delxsq
        two_s = TWO*s
        w(:munk) = s
        w(id2+1:munk+id2) = (-two_s) + elmbda*delysq
        w(id3+1:munk+id3) = s

        if (mp /= 1) then
            w(1) = ZERO
            w(id4) = ZERO
        end if

        select case (mp)
            case (3)
                w(id2) = two_s
            case (4)
                w(id2) = two_s
                w(id3+1) = two_s
            case (5)
                w(id3+1) = two_s
        end select

        pertrb = ZERO
        if (elmbda >= ZERO) then
            if (elmbda /= ZERO) then
                ierror = 6
            end if
        end if

        ! Set worspace indices
        associate( &
            iw1 => 1, &
            iw2 => id2 + 1, &
            iw3 => id3 + 1, &
            iw4 => id4 + 1 &
            )

            ! Solve system
            call util%genbun_lower_routine(nperod, nunk, mperod, munk, w(iw1:), w(iw2:), w(iw3:), &
                idimf, f(mstart, nstart), local_error_flag, w(iw4:))

            ! Check error flag
            if (local_error_flag /= 0) then
                error stop 'fishpack library: genbun_lower_routine call failed in hwscrt_lower_routine'
            end if
        end associate

        !  Fill in identical values when have periodic boundary conditions.
        if (nbdcnd == 0) f(mstart:mstop, np1) = f(mstart:mstop, 1)

        if (mbdcnd == 0) then
            f(mp1, nstart:nstop) = f(1, nstart:nstop)
            if (nbdcnd == 0) f(mp1, np1) = f(1, np1)
        end if

    end subroutine hwscrt_lower_routine

    pure subroutine hwscrt_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, idimf, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d

        ! Check input arguments
        if (ZERO <= (a - b)) then
            ierror = 1
        else if (mbdcnd < 0 .or. mbdcnd > 4) then
            ierror = 2
        else if (ZERO <= (c - d)) then
            ierror = 3
        else if (n <= 3) then
            ierror = 4
        else if (nbdcnd < 0 .or. nbdcnd > 4) then
            ierror = 5
        else if (idimf < m + 1) then
            ierror = 7
        else if (m <= 3) then
            ierror = 8
        else
            ierror = 0
        end if

    end subroutine hwscrt_check_input_arguments

end submodule centered_cartesian_solver
!
! REVISION HISTORY
!
! September 1973    Version 1
! April     1976    Version 2
! January   1978    Version 3
! December  1979    Version 3.1
! February  1985    Documentation upgrade
! November  1988    Version 3.2, FORTRAN 77 changes
! June      2004    Version 5.0, Fortran 90 changes
! May       2016    Fortran 2008 changes


      SUBROUTINE iterate(grid)
        IMPLICIT NONE

        INTEGER, DIMENSION(:,:,:,:) :: grid
        INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: scratch
        INTEGER :: grid_size
        INTEGER :: x, y, z, w
        INTEGER :: x1, x2, y1, y2, z1, z2, w1, w2
        INTEGER :: next
        LOGICAL :: active

        grid_size = SIZE(grid, 1)
        ALLOCATE( scratch(grid_size, grid_size, grid_size, grid_size) )
        scratch = 0

        DO w = 1, grid_size
          DO z = 1, grid_size
            DO y = 1, grid_size
              DO x = 1, grid_size
                x1 = MAX(x-1, 1)
                y1 = MAX(y-1, 1)
                z1 = MAX(z-1, 1)
                w1 = MAX(w-1, 1)
                x2 = MIN(x+1, grid_size)
                y2 = MIN(y+1, grid_size)
                z2 = MIN(z+1, grid_size)
                w2 = MIN(w+1, grid_size)
                next = SUM(grid(x1:x2, y1:y2, z1:z2, w1:w2))
                next = next - grid(x, y, z, w)
                IF (grid(x, y, z, w) .EQ. 1) THEN
                  IF (next .EQ. 2 .OR. next .EQ. 3) THEN
                    scratch(x, y, z, w) = 1
                  END IF
                ELSE
                  IF (next .EQ. 3) THEN
                    scratch(x, y, z, w) = 1
                  END IF
                END IF
              END DO
            END DO
          END DO
        END DO

        grid = scratch
        DEALLOCATE(scratch)
      END SUBROUTINE

      PROGRAM part1
        IMPLICIT NONE

        INTEGER :: iterations = 6

        INTEGER :: file_size
        INTEGER :: grid_size
        INTEGER :: max_size
        CHARACTER (LEN=:), ALLOCATABLE :: line
        CHARACTER :: char
        INTEGER, DIMENSION (:,:,:,:), ALLOCATABLE :: grid
        INTEGER :: index, inner
        INTEGER :: midpoint
        INTEGER :: x, y
        INTEGER :: cell

        INTERFACE
          SUBROUTINE iterate(grid)
            INTEGER, DIMENSION(:,:,:,:) :: grid
          END SUBROUTINE
        END INTERFACE

        INQUIRE(FILE="input", SIZE=file_size)
        ! Find grid size assuming input is a perfect square plus newlines
        DO index = 1, 20
          grid_size = index * (index + 2) - 2
          IF (grid_size .EQ. file_size) THEN
            grid_size = index
            EXIT
          END IF
        END DO
        max_size = grid_size + (iterations * 2)
        midpoint = max_size / 2

        ALLOCATE( grid(max_size, max_size, max_size, max_size) )
        ALLOCATE( CHARACTER(grid_size) :: line )

        OPEN(1, FILE="input")
        DO index = 1, grid_size
          y = midpoint - (grid_size / 2) + index
          READ(1, *) line
          DO inner = 1, grid_size
            x = midpoint - (grid_size / 2) + inner
            IF (line(inner:inner) .EQ. '#') THEN
              grid(x, y, midpoint + 1, midpoint + 1) = 1
            END IF
          END DO
        END DO

        DO index = 1, iterations
          !PRINT *, SUM(grid)
          CALL iterate(grid)
        END DO
        PRINT *, SUM(grid)

      END PROGRAM


! Copyright (c) 2016 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level of this distribution.

module gaussian
  ! 1D Gaussian module

  use progvars

  implicit none

  public :: gaussian_init
  public :: gaussian_cleanup
  public :: gaussian_p
  public :: gaussian_xt

  private

  ! Useful constants
  real(fp) :: p0_m, p0_2m
  real(fp) :: sig_x2
  real(fp) :: sig_p, sig_p2
  real(fp) :: norm_p
  complex(fp) :: j_hb, jhb_m

contains
  subroutine gaussian_init()
    ! Precalculate useful constants
    p0_m = p0 / m
    p0_2m = p0_m / 2.0_fp

    sig_x2 = sig_x ** 2

    j_hb = j / hbar
    jhb_m = j * hbar / m

    sig_p = hbar / sig_x
    sig_p2 = sig_p**2

    norm_p = sqrt(1.0_fp / (sig_p * sqrt_pi))

  end subroutine gaussian_init

  subroutine gaussian_cleanup()
  end subroutine gaussian_cleanup

  real(fp) function gaussian_p(p) result(val)
    ! Taken from Sakurai, p. 58
    real(fp), intent(in) :: p

    real(fp) :: exp_p

    exp_p = exp(- 0.5_fp * ( (p - p0) / sig_p )**2 )

    val = norm_p * exp_p
  end function gaussian_p

  complex(fp) function gaussian_xt(x, t) result(val)
    real(fp), intent(in) :: x
    real(fp), intent(in) :: t

    complex(fp) :: norm_x
    complex(fp) :: exp1, exp2

    norm_x = 1.0_fp / sqrt( sqrt_pi * (sig_x + jhb_m / sig_x * t) )
    exp1 = - ( (x - x0) - p0_m * t )**2 / &
         ( 2.0_fp * sig_x2 * (1 + jhb_m / sig_x2 * t) )
    exp2 = j_hb * p0 * ( (x - x0) - p0_2m * t )

    val = norm_x * exp(exp1 + exp2)

  end function gaussian_xt

end module gaussian


subroutine make_freq_intervals()
  use dyn_lc
  implicit none

  integer              :: jj
  double precision     :: min_freq, max_freq
  double precision , allocatable :: fq_min_arr(:), fq_max_arr(:), fq(:)
  character (len=200)  :: filename

  filename = 'products/ener_freq_info.txt'

  open(12, file = filename)

  write(*,*)
  write(*,*) '   Calculate the frequency intervals for the lag spectrum'
  write(*,*)
  write(*,*) '   Enter the minimum frequency in Hz '
  read (*,*)   min_freq
  write(*,*) '   Enter the maximum frequency in Hz '
  read (*,*)   max_freq
   ! min_freq = 2.9
   ! max_freq = 30.0
  write(*,*) '   Enter the number of frequency intervals (they will be log spaced) '
  read (*,*)    freq_num

   if(.not. allocated(upper_fq  )) allocate(upper_fq(freq_num))
   if(.not. allocated(lower_fq  )) allocate(lower_fq(freq_num))

   if(.not. allocated(fq_min_arr)) allocate(fq_min_arr(freq_num))
   if(.not. allocated(fq_max_arr)) allocate(fq_max_arr(freq_num))
   if(.not. allocated(fq)        ) allocate(fq        (freq_num + 1))

!log shape for the frequency ranges
   call make_array_logspace(min_freq, max_freq, freq_num + 1, fq)

   write(12,*) '   FREQUNECY INTERVALS INFORMATION for the lag vs energy spectra'
   write(12,*) '   User input:'
   write(12,*) '   Minimum frequency: ', min_freq
   write(12,*) '   Maximum frequency: ', max_freq
   write(12,*) '   Number of frequency intervals: ', freq_num
   write(12,*)
   write(12, *) '   Frequency intervals calculated from the boundaries give by the user'
   write(12,*)
   do jj = 1, freq_num
      fq_min_arr(jj) = fq(jj)
      fq_max_arr(jj) = fq(jj + 1)
      write(12,*) jj, fq_min_arr(jj), fq_max_arr(jj)
   enddo
   write(12,*)

   do jj = 1, freq_num
      lower_fq(jj) = ceiling(fq_min_arr(jj) * real(int_len_dim) * dt)
      upper_fq(jj) = floor  (fq_max_arr(jj) * real(int_len_dim) * dt)
      write(12,*) '----------------------------------------------'
      write(12,*) "   Frequency interval: ", jj
      write(12,*) "   Min frequency bin       = ", lower_fq(jj)
      write(12,*) "   Max frequency bin       = ", upper_fq(jj)
      write(12,*) "   Min true frequency (Hz) = ", lower_fq(jj) / (real(int_len_dim) * dt)
      write(12,*) "   Max true frequency (Hz) = ", upper_fq(jj) / (real(int_len_dim) * dt)
      write(12,*) '   Number of frequency bins in this interval ', upper_fq(jj) - lower_fq(jj) + 1
      write(12,*) '----------------------------------------------'
      write(12,*)
   enddo

   if (.not. allocated(relevant_freq)) allocate(relevant_freq(freq_num))

   do jj = 1, freq_num
      relevant_freq(jj) = (fq_max_arr(jj) + fq_min_arr(jj)) * 0.5d0
   enddo

   write(*,*) '   Frequnecy intervals have been calculated'
   write(*,*) '   Informations are in the file: ', trim(filename)
   write(*,*)
   write(*,*) '   Press Enter to continue'
   read (*,*)
   write(*,*)

   deallocate(fq_min_arr)
   deallocate(fq_max_arr)
   deallocate(fq        )

 end subroutine make_freq_intervals

 subroutine make_freq_intervals_obs()
  use dyn_lc
  implicit none

  integer              :: jj, o
  double precision     :: min_freq, max_freq
  double precision , allocatable :: fq_min_arr(:), fq_max_arr(:), fq(:)
  character (len=200)  :: filename

  filename = 'products/ener_freq_obs_info.txt'

  open(12, file = filename)

  write(*,*)
  write(*,*) '   Calculate the frequency intervals for the lag spectrum'
  write(*,*)
  write(*,*) '   Enter the minimum frequency in Hz '
  read (*,*)   min_freq
  write(*,*) '   Enter the maximum frequency in Hz '
  read (*,*)   max_freq
   ! min_freq = 2.9
   ! max_freq = 30.0
  write(*,*) '   Enter the number of frequency intervals (they will be log spaced) '
  read (*,*)    freq_num

   if(.not. allocated(upper_fq_obs)) allocate(upper_fq_obs(freq_num, obs_num))
   if(.not. allocated(lower_fq_obs)) allocate(lower_fq_obs(freq_num, obs_num))

   if(.not. allocated(fq_min_arr)  ) allocate(fq_min_arr(freq_num))
   if(.not. allocated(fq_max_arr)  ) allocate(fq_max_arr(freq_num))
   if(.not. allocated(fq)          ) allocate(fq        (freq_num + 1))

!log shape for the frequency ranges
   call make_array_logspace(min_freq, max_freq, freq_num + 1, fq)

   write(12,*) '   FREQUNECY INTERVALS INFORMATION for the lag vs energy spectra'
   write(12,*) '   User input:'
   write(12,*) '   Minimum frequency: ', min_freq
   write(12,*) '   Maximum frequency: ', max_freq
   write(12,*) '   Number of frequency intervals: ', freq_num
   write(12,*)
   write(12, *) '   Frequency intervals calculated from the boundaries give by the user'
   write(12,*)
   do jj = 1, freq_num
      fq_min_arr(jj) = fq(jj)
      fq_max_arr(jj) = fq(jj + 1)
      write(12,*) jj, fq_min_arr(jj), fq_max_arr(jj)
   enddo
   write(12,*)

   do o = 1, obs_num

      do jj = 1, freq_num
         lower_fq_obs(jj, o) = ceiling(fq_min_arr(jj) * real(int_len_dim_obs(o)) * dt)
         upper_fq_obs(jj, o) = floor  (fq_max_arr(jj) * real(int_len_dim_obs(o)) * dt)
         write(12,*) '----------------------------------------------'
         write(12,*) "   Frequency interval: ", jj
         write(12,*) "   Min frequency bin       = ", lower_fq_obs(jj,o)
         write(12,*) "   Max frequency bin       = ", upper_fq_obs(jj,o)
         write(12,*) "   Min true frequency (Hz) = ", lower_fq_obs(jj,o) / (real(int_len_dim_obs(o)) * dt)
         write(12,*) "   Max true frequency (Hz) = ", upper_fq_obs(jj,o) / (real(int_len_dim_obs(o)) * dt)
         write(12,*) '   Number of frequency bins in this interval ', upper_fq_obs(jj,o) - lower_fq_obs(jj,o) + 1
         write(12,*) '----------------------------------------------'
         write(12,*)
      enddo

   enddo

   if (.not. allocated(relevant_freq)) allocate(relevant_freq(freq_num))
   do jj = 1, freq_num
      relevant_freq(jj) = (fq_max_arr(jj) + fq_min_arr(jj)) * 0.5d0
   enddo

   write(*,*) '   Frequnecy intervals have been calculated for all the observations'
   write(*,*) '   Informations are in the file: ', trim(filename)
   write(*,*)
   write(*,*) '   Press Enter to continue'
   read (*,*)
   write(*,*)

   deallocate(fq_min_arr)
   deallocate(fq_max_arr)
   deallocate(fq        )

 end subroutine make_freq_intervals_obs


module SDEClass
    use RandomClass
    use ArrayClass
    use MathClass
    implicit none

    integer(int32) :: PF_SDE_GeometricBrown = 1
    type :: SDE_
        real(real64),allocatable :: process(:)
        real(real64) :: c = 0.0d0
        real(real64) :: sigma= 0.0d0
        integer(int32) :: SDEType=0
    contains
        procedure,public :: init => initSDE
        procedure,public :: solve => solveSDE
    end type
contains

subroutine initSDE(obj,SDEType,c,sigma)
    class(SDE_) ,intent(inout) :: obj
    integer(int32),intent(in) :: SDEType
    real(real64),optional,intent(in) :: c,sigma

    if(SDEType==PF_SDE_GeometricBrown)then
        ! Geometric Brown Motion
        if(.not. present(c) )then
            print *, "ERROR :: initSDE >> arg c is necessary."
            stop
        endif
        if(.not. present(sigma) )then
            print *, "ERROR :: initSDE >> arg sigma is necessary."
            stop
        endif
        obj%c = c
        obj%sigma = sigma
        obj%SDEType = PF_SDE_GeometricBrown

    endif

end subroutine

function solveSDE(obj,X0,dt,step)  result(ret)
    class(SDE_) ,intent(inout) :: obj
    real(real64),intent(in) :: X0,dt
    integer(int32),intent(in) :: step
    real(real64) ::t, Bt
    real(real64),allocatable :: ret(:)
    integer(int32) :: n,i
    type(Random_) :: random

    if(obj%SDEType==PF_SDE_GeometricBrown)then
        ! Geometric Brown Motion

        n = step
        ret = zeros(n)

        Bt = 0.0d0
        t=0.0d0
        ret(1) = X0
        do i=2,n
            t = t + dt
            Bt = Bt + random%gauss(mu=0.0d0,sigma=1.0d0)
            ret(i) = X0*exp( (obj%c - 0.50d0*obj%sigma*obj%sigma)*t + obj%sigma*Bt )
        enddo
    endif

end function

end module SDEClass