module mathconsts
!----- LGPL --------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This library is free software; you can redistribute it and/or
!  modify it under the terms of the GNU Lesser General Public
!  License as published by the Free Software Foundation version 2.1.
!
!  This library is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!  Lesser General Public License for more details.
!
!  You should have received a copy of the GNU Lesser General Public
!  License along with this library; if not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: mathconsts.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/utils_lgpl/deltares_common/packages/deltares_common/src/mathconsts.f90 $
!!--description-----------------------------------------------------------------
!
! This module defines some general mathematical constants like pi and
! conversion factors from degrees to radians and from (earth) days to
! seconds.
!
! This module does NOT include physical constants like earth radius and
! gravity, or application dependent constants like missing values.
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
   use precision
   implicit none

   !
   ! flexible precision constants
   !
   real(fp), save :: ee     = exp(1.0_fp)                    !< ee = 2.718281...
   real(fp), save :: pi     = 4.0_fp*atan(1.0_fp)            !< pi = 3.141592...
   real(fp), save :: degrad = 4.0_fp*atan(1.0_fp)/180.0_fp   !< conversion factor from degrees to radians
   real(fp), save :: raddeg = 180.0_fp/(4.0_fp*atan(1.0_fp)) !< conversion factor from radians to degrees
   real(fp), save :: daysec = 24.0_fp*60.0_fp*60.0_fp        !< conversion factor from earth day to seconds
   real(fp), save :: eps_fp = epsilon(1.0_fp)                !< epsilon for fp

   !
   ! high precision constants
   !
   real(hp), save :: ee_hp      = exp(1.0_hp)                    !< ee = 2.71828182845904...
   real(hp), save :: pi_hp      = 4.0_hp*atan(1.0_hp)            !< pi = 3.14159265358979...
   real(hp), save :: degrad_hp  = 4.0_hp*atan(1.0_hp)/180.0_hp   !< conversion factor from degrees to radians
   real(hp), save :: raddeg_hp  = 180.0_hp/(4.0_hp*atan(1.0_hp)) !< conversion factor from radians to degrees
   real(hp), save :: daysec_hp  = 24.0_hp*60.0_hp*60.0_hp        !< conversion factor from earth day to seconds
   real(hp), save :: yearsec_hp = 31536000.0_hp                  !< conversion factor from earth year to seconds
   real(hp), save :: eps_hp     = epsilon(1.0_hp)                !< epsilon for hp

   contains

      !> Obsolete initialization method.
      subroutine init_mathconsts()
          !
      end subroutine init_mathconsts

end module mathconsts


subroutine NPZDPhy_size(PMU, NO3, tC, par_, muNet, SI, Lno3)
use bio_MOD
implicit none

!INPUT PARAMETERS:
real, intent(in)    :: PMU, NO3, tC, par_

!Output parameters:
real, intent(out)   :: muNet, SI, Lno3

!Local variable:
real                :: Kn, mu0hat

alphamu = params(ialphamu)
tf_p    = TEMPBOL(params(iEp),tC)
mu0hat  = dtdays*tf_p * params(imu0) * exp(alphamu*PMU)

Kn      = params(iKN) * exp( params(ialphaKN) * PMU)

! Effect of light limitation
SI      = 1d0 - max(exp(-params(iaI0) * par_ ),0d0)
Lno3    = NO3/(NO3+Kn)
muNet   = mu0hat * NO3 / (NO3 + Kn) * SI
return
end subroutine NPZDPhy_size


*----------------------------------------------------------------------*
      subroutine svd_get_left(nrow,ncol,mat)
*----------------------------------------------------------------------*
*     performs a singular value decomposition of a rectangular matrix
*     and returns the nonredundant part of the left unitary matrix
*
*     matthias, jun 2013
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'routes.h'
      include 'ifc_memman.h'

      integer, parameter ::
     &     ntest = 00
      real(8), parameter ::
     &     warn_sv = 1d-12 ! give a warning for small singular values
      integer, intent(in) ::
     &     nrow, ncol
      real(8), intent(inout) ::
     &     mat(nrow,ncol)

      real(8) ::
     &     singval(min(nrow,ncol)),
     &     dum1,dum2
      real(8),pointer ::
     &      wrk(:)
      integer ::
     &     idx, lwrk, info,
     &     ifree

      if (nrow*ncol.eq.0) return
      if (nrow.lt.ncol) call quit(1,'svd_get_left',
     &       'not yet tested for nrow < ncol')

      ifree = mem_setmark('svd_get_left')
      lwrk=max(1024,max(nrow,ncol)**2)
      ifree = mem_alloc_real(wrk, lwrk,'wrk')
      info = 0

      if (ntest.ge.100) then
        write(lulog,'(x,a)') '--------------------'
        write(lulog,'(x,a)') 'svd_get_left at work'
        write(lulog,'(x,a)') '--------------------'
        write(lulog,*) 'input matrix:'
        call wrtmat2(mat,nrow,ncol,nrow,ncol)
      end if

      ! calculate left-hand U and singular values:
      call dgesvd('O','N',nrow,ncol,
     &     mat,nrow,singval,
     &     dum1,1,dum2,1,
     &     wrk,lwrk,info)

      if (info.ne.0) then
        write(lulog,*) 'WARNING in svd_get_left: SVD in trouble'
      end if

      if (ntest.ge.100) then
        write(lulog,*) 'left-hand eigenvector matrix U:'
        call wrtmat2(mat,nrow,ncol,nrow,ncol)
        write(lulog,*) 'singular values:'
        call wrtmat2(singval,min(nrow,ncol),1,min(nrow,ncol),1)
      end if

      ! zero the columns with negligible singular values
      do idx = 1, min(nrow,ncol)
        if (singval(idx).lt.sv_thresh) then
          mat(1:nrow,idx) = 0d0
          if (singval(idx).gt.warn_sv) then
            write(lulog,*) 'small singular value: ',singval(idx)
            call warn('svd_get_left','small singular values')
          end if
        end if
      end do
      ifree = mem_flushmark()

      return
      end


! -*- coding: utf-8 -*-
program main
  use mod_force_raise
  implicit none

  real(8) :: rad
  real(8),allocatable :: x(:, :)
  real(8),allocatable :: l1(:, :)
  real(8),allocatable :: l2(:, :)
  real(8),allocatable :: kai(:)
  real(8),allocatable :: al(:)
  real(8),allocatable :: u(:)
  integer :: n
  real(8) :: rr
  real(8),parameter :: pi = 3.1415926535897932384626433832795028841971d0
  real(8),parameter :: arctwopi = 1d0/(2d0*pi)

  real(8) :: th
  integer :: i
  integer :: j
  integer,allocatable :: ipiv(:)
  integer :: info

  write(6,*) '# n, rad'
  open(1000, file='input', status='old')
  read(1000,*) n, rad
  close(1000)

  allocate(x(2, n))
  allocate(l1(n, n))
  allocate(l2(n, n))
  allocate(al(n))
  allocate(kai(n))
  allocate(ipiv(n))

  do i = 1, n
     th = 2d0*pi*(dble(i)+0.5d0)/dble(n)

     x(1, i) = rad*cos(th)
     x(2, i) = rad*sin(th)

     !x**3*y - x*y**3
     kai(i) = x(1, i)**3*x(2, i) - x(1, i)*x(2, i)**3
  end do

  al = kai

  do j = 1, n
     do i = 1, n
        rr = sqrt((x(1, i) - x(1, j))**2 + (x(2, i) - x(2, j))**2)
        if(rr .gt. 1d-13) then
           l1(i, j) = -log(rr)*arctwopi
        else
           l1(i, j) = 0d0
        end if
     end do
  end do

  l2 = l1

  call DGESV(n, 1, l1, n, ipiv, al, n, info)
  if(info.ne.0) then
     write(6,*) 'dgesv, info=', info
     call force_raise()
  endif
  deallocate(l1)
  deallocate(ipiv)

  u = matmul(l2, al)

  write(*,*) 'number of dof', n
  write(*,*) 'rad', rad
  write(*,*) 'relative error', sqrt(dot_product(u - kai, u - kai)/dot_product(kai, kai))

  deallocate(x)
  deallocate(l2)
  deallocate(kai)
  deallocate(al)
  deallocate(u)

end program main


! write out the group dependent boundary conditions
!
! This routine takes as input the file "group_structures.dat" which is
! output by RadMultiGroup.cpp.  That file defines the group centers
! and weights (widths).
!
! NOTE: in CASTRO, for multigroup, the radiation energy is stored with
! units of erg / cm^3, so that the total radiation energy can be found
! simply by summing over the groups.  This means that we normalize by
! multiplying the Planck function in each group by the group's width.

module constants_module

  ! fundamental constants
  use amrex_fort_module, only : rt => amrex_real
  real(rt)        , parameter :: h_planck = 6.62606957e-27_rt   ! erg s
  real(rt)        , parameter :: k_B = 1.3806488e-16_rt  ! erg / K
  real(rt)        , parameter :: c_light = 2.99792458e10_rt  ! cm / s
  real(rt)        , parameter :: ev2erg = 1.602176487e-12_rt ! erg/eV
  real(rt)        , parameter :: pi = 3.14159265358979323846e0_rt

  ! physical parameters
  real(rt)        , parameter :: T_sphere = 1500.e0_rt*ev2erg/k_B ! sphere temp (K

end module constants_module

function planck(nu,T) result (B)

  ! the Planck function for a Blackbody (actually, energy density,
  ! B = (4 pi / c) I, where I is the normal Planck function
  !
  ! nu = frequency (Hz)
  ! T  = temperature (K)

  ! see Swesty and Myra (2009), eq. 23, but note that we are working
  ! in Hz here, so we have units of erg / cm^3 / Hz, where they
  ! have units of erg / cm^3 / MeV.  As a result, we have one
  ! less factor of h_planck.
  use constants_module
  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)        , intent(in) :: nu, T
  real(rt)         :: B

  B = (8.e0_rt*pi*h_planck*nu**3/c_light**3)/(exp(h_planck*nu/(k_B*T)) - 1.e0_rt)

  return
end function planck

program bc

  ! compute the values of the blackbody function for the different
  ! energy groups.

  use constants_module

  implicit none

  integer :: ngroups
  real(rt)        , allocatable :: nu_groups(:), dnu_groups(:)
  real(rt)         :: planck

  integer :: n
  character(len=256) :: header_line
  integer :: ipos

  ! open the file
  open(unit=10,file="group_structure.dat")

  ! read in the number of groups
  read(10,fmt='(a256)') header_line
  ipos = index(header_line, "=") + 1
  read (header_line(ipos:),*) ngroups

  allocate (nu_groups(ngroups), dnu_groups(ngroups))

  ! skip the next header line
  read(10,*) header_line

  ! read in the group centers and weights (widths)
  do n = 1, ngroups
     read(10,*) nu_groups(n), dnu_groups(n)
  enddo

  do n = 1, ngroups
     print *, n, nu_groups(n), planck(nu_groups(n), T_sphere)*dnu_groups(n)
  enddo

  print *, "radiation.lo_bcval0 = ", &
       ((planck(nu_groups(n), T_sphere)*dnu_groups(n)), n=1,ngroups)

end program bc


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none

    ! model parameters
    real*8, parameter :: gamma = 1d0/1.5d0
    real*8, parameter :: egam = 1d0-1d0/gamma
    real*8, parameter :: growth = 0.0185d0
    real*8, parameter :: beta = 0.98d0*(1d0+growth)**egam
    real*8, parameter :: alpha = 0.3d0
    real*8, parameter :: delta = 0.075d0
    real*8, parameter :: rho = 0.6d0
    real*8, parameter :: sigma_eps = 0.09d0*(1d0-rho**2)
    real*8, parameter :: tau_w = 0.27d0
    real*8, parameter :: gy    = 0.217d0

    ! numerical parameters
    real*8, parameter :: a_l = 0d0
    real*8, parameter :: a_u = 100d0
    real*8, parameter :: a_grow = 0.01d0
    real*8, parameter :: sig_in = 1d-10
    real*8, parameter :: sig_out = 1d-6
    integer, parameter :: itermax = 50000

    ! macroeconomic variables
    real*8 :: KK, AA, BB, LL, YY, CC, II, GG
    real*8 :: r, w, rn, wn, tau_r, by

    ! the shock process
    integer, parameter :: NS = 7
    real*8 :: pi(NS, NS), eta(NS), weights(NS)

    ! policy and value function
    integer, parameter :: NA = 1000
    real*8 :: a(0:NA), c(0:NA, NS), V(0:NA, NS)

    ! variables to numerically determine policy function
    real*8 :: c_new(0:NA, NS), RHS(0:NA, NS)
    logical :: check

    ! variables to communicate with function
    real*8 :: a_com
    integer :: is_com

    ! variables to numerically determine the steady state distribution
    real*8 :: phi(0:NA, NS), phi_new(0:NA, NS)

contains

    ! calculate the difference on the asset market given an interest rate
    function asset_market(r_input)

        implicit none
        real*8, intent(in) :: r_input
        real*8 :: asset_market

        ! set the interest rate
        r = r_input

        ! calculate the corresponding capital stock
        KK = (alpha/(r+delta))**(1d0/(1d0-alpha))*LL

        ! get wages and output
        w = (1d0-alpha)*(KK/LL)**alpha
        YY = KK**alpha*LL**(1d0-alpha)

        ! calculate government quantities
        GG = gy*YY
        BB = by*YY

        ! back out aggregate asset holdings
        AA = KK + BB

        ! get budget balancing tax rates
        tau_r = (GG + (r-growth)*BB - tau_w*w*LL)/(r*AA)

        ! define net prices
        rn = r*(1d0-tau_r)
        wn = w*(1d0-tau_w)

        ! solve the household value function iteration problem
        call solve_household()

        ! calculate the invariant distribution directly
        call get_distribution()

        ! get aggregate assets
        AA = sum(a*sum(phi, 2))

        ! get the difference between asset demand and supply
        asset_market = (AA - KK - BB)/AA

        write(*,'(3f10.4,f12.8)')KK/YY*100d0, r*100d0, tau_r*100d0, AA-KK-BB

    end function

    ! determines the solution to the household optimization problem
    subroutine solve_household()

        use toolbox

        implicit none
        integer :: ia, is, iter
        real*8 :: con_lev, x_in

        ! set tolerance level for interior optimization
        call settol_root(sig_in)

        ! do a policy function iteration with rootfinding
        do iter = 1, itermax

            ! interpolate coefficients
            call interpolate()

            ! solve the household problem for all gridpoints
            do ia = 0, NA
                do is = 1, NS

                    ! initialize starting value/communication variables
                    x_in = c(ia, is)
                    a_com = a(ia)
                    is_com = is

                    ! find the optimal consumption level
                    call fzero(x_in, foc, check)
                    if(check)write(*,*)'ERROR IN ROOTFINDING PROCESS'

                    ! check for borrowing constraint
                    if(x_in > (1d0+rn)*a_com+wn*eta(is_com) - a_l) &
                       x_in = (1d0+rn)*a_com+wn*eta(is_com) - a_l

                    ! get optimal consumption and value function
                    c_new(ia, is) = x_in

                enddo
            enddo

            ! get convergence level
            con_lev = maxval(abs(c_new(:, :) - c(:, :))/max(abs(c(:, :)), 1d-10))

            ! check for convergence
            if(con_lev < sig_in)then
                return
            endif

            c = c_new
        enddo

        write(*,*)'Policy Function Iteration did not converge'

    end subroutine

    ! the first order condition
    function foc(x_in)

        use toolbox

        implicit none
        real*8, intent(in) :: x_in
        real*8 :: foc, aplus, varphi
        integer :: ial, iar

        ! future assets
        aplus = ((1d0+rn)*a_com + wn*eta(is_com) - x_in)/(1d0+growth)

        ! calculate future expected marginal utility
        call linint_Grow(aplus, a_l, a_u, a_grow, NA, ial, iar, varphi)
        foc = varphi*RHS(ial,is_com) + (1d0-varphi)*RHS(iar,is_com)

        ! get first order condition
        foc = x_in - foc

    end function

    ! Set up data for interpolation
    subroutine interpolate()

        implicit none
        integer :: is, ia, is_p

        do is = 1, NS
            do ia = 0, NA

                ! calculate the RHS of the first order condition
                RHS(ia, is) = 0d0
                do is_p = 1, NS
                    RHS(ia, is) = RHS(ia, is) + pi(is, is_p)*c_new(ia, is_p)**(-1d0/gamma)
                enddo
                RHS(ia, is) = (beta*(1d0+rn)*RHS(ia, is))**(-gamma)
            enddo
        enddo

    end subroutine

    ! calculates the invariant distribution of households
    subroutine get_distribution()

        use toolbox

        implicit none
        integer :: ia, is, iter, is_p
        real*8 :: aplus, con_lev
        integer :: ial(0:NA, NS), iar(0:NA, NS)
        real*8 :: varphi(0:NA, NS)

        ! get the interpolation shares and points
        do ia = 0, NA
            do is = 1, NS

                ! calculate where this guy would go
                aplus = ((1d0+rn)*a(ia) + wn*eta(is) - c(ia,is))/(1d0+growth)
                aplus = min(max(aplus, a_l), a_u)

                ! determine the gridpoints in between this decision lies
                call linint_Grow(aplus, a_l, a_u, a_grow, NA, &
                    ial(ia, is), iar(ia, is), varphi(ia, is))
            enddo
        enddo

        ! iterate until the distribution function converges
        do iter = 1, itermax

            phi_new = 0d0

            do ia = 0, NA
                do is = 1, NS

                    do is_p = 1, NS
                        phi_new(ial(ia,is), is_p) = phi_new(ial(ia,is), is_p) + &
                            pi(is,is_p)*varphi(ia,is)*phi(ia,is)
                        phi_new(iar(ia,is), is_p) = phi_new(iar(ia,is), is_p) + &
                            pi(is,is_p)*(1d0-varphi(ia,is))*phi(ia,is)
                    enddo
                enddo
            enddo

            con_lev = maxval(abs(phi_new(:, :) - phi(:, :))/max(abs(phi(:, :)), 1d-10))

            ! update distribution
            phi = phi_new

            ! check for convergence
            if(con_lev < sig_in)then
                return
            endif
        enddo

        write(*,*)'Distribution Function Iteration did not converge'

    end subroutine

end module


      subroutine invm3(xm,xminv,ierr)
c     ================================================================
c Inverts a 3x3 real*8 matrix
c
c Inputs: xm   real*8 array of (3,3), the 3x3 matrix
c Returns:xminv real*8 array of (3,3), inverse of xm
c         ierr  error code, 0 if inversion is successful, 1 if xm is singular
c
      implicit   none
c
      integer    ierr
c
      real*8     xm(3,3)
      real*8     xminv(3,3)
      real*8     det
      real*8    t1,t2,t3,t0
      real*8     tol
c
      parameter  (tol=1.d-10)
c
      t1=xm(2,2)*xm(3,3)-xm(2,3)*xm(3,2)
      t2=xm(2,1)*xm(3,3)-xm(2,3)*xm(3,1)
      t3=xm(2,1)*xm(3,2)-xm(2,2)*xm(3,1)
      det= xm(1,1)*t1
     >    -xm(1,2)*t2
     >    +xm(1,3)*t3
c
      if (abs(det) .lt. tol) then
         ierr=1
      else
         ierr=0
c
	 t0=1.d0/det
         xminv(1,1)=+t1*t0
         xminv(2,1)=-t2*t0
         xminv(3,1)=+t3*t0
         xminv(1,2)=-(xm(1,2)*xm(3,3)-xm(1,3)*xm(3,2))*t0
         xminv(2,2)=+(xm(1,1)*xm(3,3)-xm(1,3)*xm(3,1))*t0
         xminv(3,2)=-(xm(1,1)*xm(3,2)-xm(3,1)*xm(1,2))*t0
         xminv(1,3)=+(xm(1,2)*xm(2,3)-xm(1,3)*xm(2,2))*t0
         xminv(2,3)=-(xm(1,1)*xm(2,3)-xm(2,1)*xm(1,3))*t0
         xminv(3,3)=+(xm(1,1)*xm(2,2)-xm(2,1)*xm(1,2))*t0
      end if
c
      return
      end


MODULE m_force_gfm

! ----------------------------------------------------------------------
! MODULE: m_force_gfm.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the force_gfm subroutine
!
! Subroutines contained within the module:
! - force_gfm
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	15 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE force_gfm (GM, ae, r, n_max, m_max, Cnm, Snm , fx,fy,fz)

! ----------------------------------------------------------------------
! SUBROUTINE: force_gfm.f90
! ----------------------------------------------------------------------
! Purpose:
! Earth Gravity field effects
!  Computation of the acceleration based on a global Earth Gravity Field
!  Model expressed by a set of spherical harmonic coefficients
! ----------------------------------------------------------------------
! Input arguments:
! - GM:				Earth gravity constant  (m^3/sec^2)
! - ae:				Earth radius (meters)
! - r:				Position vector (m) in Terrestrial Reference System (ITRS)
!   				r = [x y z]
! - n_max:          maximum degree expansion
! - m_max:          maximum order expansion (m_max <= n_max)
! - Cnm, Snm:		Spherical Harmonic Coefficients (degree n, order m); dynamic allocatable arrays
!
! Output arguments:
! - fx,fy,fz:		Acceleration's cartesian components in ITRS (m)
! ----------------------------------------------------------------------
! Remark 1:
!  Cnm, Snm are dynamic allocatable arrays
!  Cnm and Snm arrays are formed into lower triangular matrices.
!  Coefficient Cnm corresponds to the matrix element Cnm(n+1,m+1)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	August 2015
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 15 November 2017:
!	Upgraded from Fortran 90 to Fortran 2003 for considering the
!	Fortran 2003 advantages in dynamic memory allocation
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE m_legendre
      USE m_legendre1
      USE mdl_param
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: GM, ae
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3) :: r
      INTEGER (KIND = prec_int8), INTENT(IN) :: n_max, m_max
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(:,:), ALLOCATABLE :: Cnm, Snm
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: fx,fy,fz
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: Pnm_norm, dPnm_norm
      REAL (KIND = prec_q) :: phi, lamda, radius, fgrav_3d
      REAL (KIND = prec_q) :: fr, ftheta, flamda
      REAL (KIND = prec_q) :: dV_r, dV_phi, dV_lamda
      INTEGER (KIND = prec_int8) :: n, m, m_limit
      INTEGER (KIND = prec_int2) :: comp_option
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! computation of spherical coordinates in radians
      CALL coord_r2sph (r , phi,lamda,radius)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! computation of normalized associated Legendre functions
      CALL legendre (phi, n_max, Pnm_norm)
! ----------------------------------------------------------------------
! First-order derivatives of normalized associated Legendre functions
      CALL legendre_drv1 (phi, n_max, dPnm_norm)
! ----------------------------------------------------------------------
!      PRINT *,"Pnm_norm", Pnm_norm
!      PRINT *,"dPnm_norm", dPnm_norm

! ----------------------------------------------------------------------
! Computation of acceleration vector components in a local tangent frame:
! ----------------------------------------------------------------------
      comp_option = 2
! ----------------------------------------------------------------------
! 1st approach:
      IF (comp_option == 1) THEN
! ----------------------------------------------------------------------
! - fr     : radius component
! - flamda : geocentric longitude component
! - ftheta : geocentric latitude component (theta = 90-latitude)
! ----------------------------------------------------------------------
       fr = 0.0D0
       ftheta = 0.0D0
       flamda = 0.0D0
! ----------------------------------------------------------------------
       DO n = 2 , n_max
           IF (n > m_max) THEN
               m_limit = m_max
           ELSE
               m_limit = n
           END IF
           DO m = 0 , m_limit
             fr = fr+ ( -1.0D0*(n+1) * ((ae/radius)**n) * Pnm_norm(n+1,m+1) &
			 * (Cnm(n+1,m+1)*cos(m*lamda) + Snm(n+1,m+1)*sin(m*lamda)) )

             ftheta = ftheta + ((ae/radius)**n) * dPnm_norm(n+1,m+1)    &
			 * (Cnm(n+1,m+1)*cos(m*lamda)+Snm(n+1,m+1)*sin(m*lamda))

             flamda = flamda + ((ae/radius)**n) * (1.0D0/cos(phi))        &
     		   * Pnm_norm(n+1,m+1) * m * (Snm(n+1,m+1)*cos(m*lamda)-Cnm(n+1,m+1)*sin(m*lamda))
           END DO
       END DO
! ----------------------------------------------------------------------
      fr = fr * (GM/radius**2) - GM / (radius**2)
      ftheta = ftheta * (GM/radius**2)
      flamda = flamda * (GM/radius**2)
! ----------------------------------------------------------------------
! Cartesian counterparts in the Earth fixed system (ITRF)
      fx = fr * cos(phi)*cos(lamda) + ftheta * sin(phi)*cos(lamda) - flamda * sin(lamda)
      fy = fr * cos(phi)*sin(lamda) + ftheta * sin(phi)*sin(lamda) + flamda * cos(lamda)
	  fz = fr * sin(phi) - ftheta * cos(phi)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! 2nd approach:
      ELSE
! ----------------------------------------------------------------------
! Partial derivatives of potential with respect to spherical coordinates :
! - dV_r     : partial derivative of geopotential to radius
! - dV_phi   : partial derivative of geopotential to latitude
! - dV_lamda : partial derivative of geopotential to longtitude
! ----------------------------------------------------------------------
      dV_r = 0.0D0
      dV_phi = 0.0D0
      dV_lamda = 0.0D0

      DO n = 2 , n_max
          IF (n > m_max) THEN
              m_limit = m_max
          ELSE
              m_limit = n
          END IF
          DO m = 0 , m_limit
            dV_r = dV_r + ( -1.0D0*(n+1) * ((ae/radius)**n)                 &
                   * Pnm_norm(n+1,m+1)                                  &
                   * ( Cnm(n+1,m+1) * cos(m*lamda)                      &
                   + Snm(n+1,m+1) * sin(m*lamda)) )

            dV_phi = dV_phi + ((ae/radius)**n) * dPnm_norm(n+1,m+1) *   &
                     ( Cnm(n+1,m+1)*cos(m*lamda) + Snm(n+1,m+1)*sin(m*lamda) )

            dV_lamda = dV_lamda + m * ((ae/radius)**n) * Pnm_norm(n+1,m+1) &
                      * ( Snm(n+1,m+1)*cos(m*lamda) - Cnm(n+1,m+1)*sin(m*lamda) )
          END DO
      END DO
      dV_r = - GM / (radius**2) + (GM/radius**2) * dV_r
      dV_phi = (GM / radius) * dV_phi
      dV_lamda = (GM / radius) * dV_lamda

! Computation of Cartesian counterparts of the acceleration
      fx = dV_r * cos(phi)*cos(lamda) + dV_phi * (1.0D0/radius)*sin(phi)*cos(lamda) &
           + dV_lamda * (-1.0D0/(radius*cos(phi)))*sin(lamda)
      fy = dV_r * cos(phi)*sin(lamda) + dV_phi * (1.0D0/radius)*sin(phi)*sin(lamda) &
           + dV_lamda * (1.0D0/(radius*cos(phi)))*cos(lamda)
      fz = dV_r * sin(phi) + dV_phi * (-1.0D0/radius)*cos(phi)
! ----------------------------------------------------------------------
      END IF

if (1<0) then
! ----------------------------------------------------------------------
! Arrays DeALLOCATION
! ----------------------------------------------------------------------
      DEALLOCATE (Pnm_norm, STAT = DeAllocateStatus)
!      print *,"Pnm_norm DeAllocateStatus=", DeAllocateStatus
      IF (DeAllocateStatus /= 0) THEN
         PRINT *, "Error: Memory deallocation error"
         PRINT *, "Error: SUBROUTINE force_gfm.f"
         PRINT *, "Error: Allocatable Array: Pnm_norm"
!         STOP "*** Not enough memory ***"
      END IF
! ----------------------------------------------------------------------
      DEALLOCATE (dPnm_norm, STAT = DeAllocateStatus)
!      print *,"dPnm_norm DeAllocateStatus=", DeAllocateStatus
      IF (DeAllocateStatus /= 0) THEN
         PRINT *, "Error: Memory deallocation error"
         PRINT *, "Error: SUBROUTINE force_gfm.f"
         PRINT *, "Error: Allocatable Array: dPnm_norm"
!         STOP "*** Not enough memory ***"
      END IF
! ----------------------------------------------------------------------
end if

END SUBROUTINE

END Module


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      double precision function stdev(npt,pts,mean)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Calculates standard deviation of data set given the mean.
      implicit none

      integer npt,i
      double precision pts(npt),mean,s,ep,adev,p,var,sdev,mean2

      s=0.
      do 11 i=1,npt
         s=s+pts(i)
 11   continue
      mean=s/npt

      ep=0.
      var=0.
      do 10 i=1,npt
         s=pts(i)-mean
         ep=ep+s
         p=s*s
         var=var+p
 10   continue
      var=(var-ep**2/npt)/(npt-1)
      sdev=sqrt(var)

      stdev=sdev

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      double precision function stdev2(npt,pts,mean)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Calculates standard deviation of data set given the mean.
      implicit none

      integer npt,i
      double precision pts(npt),mean,s,ep,adev,p,var,sdev,mean2

!      s=0.
!      do 11 i=1,npt
!         s=s+pts(i)
! 11   continue
!      mean=s/npt

      ep=0.
      var=0.
      do 10 i=1,npt
         s=pts(i)-mean
         ep=ep+s
         p=s*s
         var=var+p
 10   continue
      var=(var-ep**2/npt)/(npt-1)
      sdev=sqrt(var)

      stdev2=sdev

      return
      end


!==============================================================================
! NUMERIC                                                         (28-Jun-2017)
!
! Written by:
! 	   Dr. Randal J. Barnes
!     Department of Civil, Environmental, and Geo- Engineering
!     University of Minnesota
!     <barne003@umn.edu>
!==============================================================================

!==============================================================================
MODULE NUMERIC_MODULE
!==============================================================================
USE CONSTANTS_MODULE
USE ERROR_MODULE
USE ISO_FORTRAN_ENV, ONLY: INT64
IMPLICIT NONE
PRIVATE

!---------------------------------------------------------------------------
! Visibility
!---------------------------------------------------------------------------
PUBLIC CholeskyDecomposition
PUBLIC CholeskySolve
PUBLIC CholeskyInverse

PUBLIC MGSLeastSquares
PUBLIC RSPDInv

PUBLIC GaussianCDF
PUBLIC GaussianRN
PUBLIC GaussianRNG
PUBLIC MVNormalRNG
PUBLIC Randomize
PUBLIC ISINF
PUBLIC Dump

!==============================================================================
! Module procedures
!==============================================================================
CONTAINS

!------------------------------------------------------------------------------
! CholeskyDecomposition
!
!     This routine computes Cholesky decomposition of a real, symmertric,
!     positive definite matrix A.
!
! Arguments:
!     N  matrix dimension
!     A  a real, symmetric positive definite matrix.
!
!     L  the Cholesky decomposition of A; that is, the lower triangular
!        matrix L, where L L' = A.
!
! Notes:
!
! o   This routine is based upon Golub and Van Loan, 1983, Algorithm 5.2-1,
!     page 89.
!
! o   If a diagonal element is less than EPSILON the routine terminates.
!
! References:
! o   Golub, G.H., and Van Loan, C.F., 1983, MATRIX COMPUTATIONS, Johns
!     Hopkins University Press, Baltimore, Maryland, 476 pp.
!------------------------------------------------------------------------------
SUBROUTINE CholeskyDecomposition(N, A, L)
   ! Declare the arguments.
   INTEGER,                 INTENT(IN)  :: N
   REAL(8), DIMENSION(N,N), INTENT(IN)  :: A
   REAL(8), DIMENSION(N,N), INTENT(OUT) :: L

   ! Declare the local variables.
   INTEGER :: i, k

   ! Carry out the Cholesky decomposition on matrix "A".
   L = A

   DO k = 1, N
      L(k,k) = L(k,k) - DOT_PRODUCT( L(k,1:k-1), L(k,1:k-1) )
      IF( L(k,k) .LT. EPS ) CALL ExecutionError( A_ISNOTPD_ERROR, 'Numeric.f95', 'CholeskyDecomposition')  ! A is not positive definite.
      L(k,k) = SQRT( L(k,k) )

      DO i = k+1, N
         L(i,k) = ( L(i,k) - DOT_PRODUCT( L(i,1:k-1), L(k,1:k-1) ) ) / L(k,k)
         L(k,i) = 0
      END DO
   END DO
END SUBROUTINE CholeskyDecomposition

!------------------------------------------------------------------------------
! CholeskySolve
!
!     This routine solves the system of linear equations given by A x = b,
!     where A = L * L'. That is, L is the Cholesky factorizion of matrix A.
!
! Arguments:
!     N  matrix dimension
!
!     L  the Cholesky decomposition of A; that is, the (NxN) lower triangular
!        matrix L, where L L' = A.
!
!     b  the (Nx1) right-hand-side matrix.
!
!     x  the (Nx1) solution matrix.
!
! Notes:
! o   The Cholesky decomposition must be carried out before calling this
!     routine.
!
! o   This routine works in the following manner
!
!       L y = b  then  L'x = y
!
! o   This routine is based upon Golub and Van Loan, 1983, Algorithms 4.1-1
!     and 4.1-2, page 53.
!
! References:
! o   Golub, G.H., and Van Loan, C.F., 1983, MATRIX COMPUTATIONS, Johns
!     Hopkins University Press, Baltimore, Maryland, 476 pp.
!------------------------------------------------------------------------------
SUBROUTINE CholeskySolve(N, L, b, x)
   ! Declare the arguments.
   INTEGER,                 INTENT(IN)  :: N
   REAL(8), DIMENSION(N,N), INTENT(IN)  :: L
   REAL(8), DIMENSION(N),   INTENT(IN)  :: b
   REAL(8), DIMENSION(N),   INTENT(OUT) :: x

   ! Declare the local variables.
   INTEGER :: i, j

   ! Initialize.
   x = b

   ! Solve L y = b using forward elimination.
   DO i = 1, N
      DO j = 1, i-1
         x(i) = x(i) - L(i,j)*x(j)
      END DO
      x(i) = x(i) / L(i,i)
   END DO

   ! Solve L' x = y using back substitution.
   DO i = N, 1, -1
      DO j = i+1, N
         x(i) = x(i) - L(j,i)*x(j)
      END DO
      x(i) = x(i) / L(i,i)
   END DO
END SUBROUTINE CholeskySolve

!------------------------------------------------------------------------------
! CholeskyInverse
!
!     Compute the inverse of a real, symmetric, positive definite matrix A,
!     where A = L * L'.
!
! Notes:
!
! o   The inversion in place for an upper triangular matrix is based upon
!     the psudo-code given in Stewart (1998, p. 179).
!
! o   The matrices A and Ainv may be the same space in memory.
!
! References:
! o   Stewart, G., 1998, "Matrix Algorithms - Volume I: Basic Decompositions",
!     SIAM, Philadelphia, 458pp., ISBN 0-89871-414-1.
!------------------------------------------------------------------------------
SUBROUTINE CholeskyInverse(N, L, Ainv)

   ! Declare the arguments.
   INTEGER,                 INTENT(IN)  :: N
   REAL(8), DIMENSION(N,N), INTENT(IN)  :: L
   REAL(8), DIMENSION(N,N), INTENT(OUT) :: Ainv

   ! Declare the local variables.
   INTEGER :: i, k
   REAL(8), DIMENSION(N,N) :: U

   ! Initialize.
   U = TRANSPOSE(L)

   ! Invert U in place.
   DO k = 1, N
      U(k,k) = 1.0_8/U(k,k)

      DO i = 1, k-1
         U(i,k) = -U(k,k) * DOT_PRODUCT( U(i,i:k-1), U(i:k-1, k) )
      END DO
   END DO

   ! A = L L' = L U --> Ainv = Uinv Linv = Uinv (Uinv)'
   Ainv = MATMUL(U, TRANSPOSE(U))

END SUBROUTINE CholeskyInverse

!------------------------------------------------------------------------------
! MGSLeastSquares
!
!     Compute the least-squares solution to the overdetermined system of
!     linear equations:
!
!       A x = b
!
!     using a modified Gram-Schmidt orthogonalization algorithm.
!
! Arguments:
!     A        (m x n) coefficient matrix.               <OVER_WRITTEN>
!     b        (m x 1) right-hand-side column vector.    <OVER_WRITTEN>
!     x        (n x 1) solution column vector.
!
! Notes:
!
! o   WARNING: This is a DESTRUCTIVE routine.  A and b are both modified
!     during the execution of this routine.
!
! o   Matrix A must have at least as many rows as columns (i.e. m >= n),
!     and it must have full column rank:  i.e. rank(A) = n.
!
! o   This routine uses a modified Gram-Schmidt algorithm.  See Golub
!     and Van Loan (1996, Algorithm 5.2.5, p.231).  The Matrix A is
!     rewritten using a "thin" QR factorization:
!
!        A = Q R
!
!     where R (n x n) is upper triangular, and Q (m x n) with orthogonal
!     columns
!
!        Q'Q = I
!
!     Thus, the solution to the least squares problem can be given by
!     computing a simple back-substitution solution to
!
!       Rx = Q'b
!
!     See Golub and Van Loan (1996, Algorithm 3.1.2, p. 89).
!
! o   However, following the recommendation of Golub and Van Loan (1996),
!     Section 5.3.5, p. 233, the error properties of the solution can be
!     improved significantly by computing the factorization of the
!     augmented matrix
!
!        ( A b )  =  (Q q) ( R  z )
!                          ( 0  p )
!
!                 =  ( QR  Qz+qp )
!
!     thus
!
!        b  =  Qz + qp
!
!     and
!
!        Q'b  =  Q'Qz + Q'qp
!             =  z
!
!     we back-substitute on
!
!        R x  =  z
!
! o   In this implementation, Q overwrites A, q overwrites b, and
!     z is stored in x (which is then overwritten by the solution
!     during back-substitution).
!
! References:
!
! o   Golub, G. H., and C. F. Van Loan, 1996, MATRIX COMPUTATIONS (3rd
!     Edition), Johns Hopkins University Press, Baltimore Maryland,
!     ISBN 0-8018-5414-8.
!------------------------------------------------------------------------------
SUBROUTINE MGSLeastSquares( m, n, A, x, b )

   ! Declare the arguments.
   INTEGER,                 INTENT(IN)    :: m     ! # of equations
   INTEGER,                 INTENT(IN)    :: n     ! # of unknowns
   REAL(8), DIMENSION(m,n), INTENT(INOUT) :: A     ! coefficient matrix
   REAL(8), DIMENSION(n),   INTENT(OUT)   :: x     ! solution vector
   REAL(8), DIMENSION(m),   INTENT(INOUT) :: b     ! rhs vector

   ! Declare the local variables and parameters.
   INTEGER :: j, k

   ! Allocate the necessary local memory for the upper-triangular matrix R.
   ! The augmenting column "z" will be stored in "x".
   REAL(8), DIMENSION(n,n) :: R

   ! Do a simple validation on the input.
   IF( ANY(ISNAN(A)) .OR. ANY(ISINF(A)) ) CALL ExecutionError( A_ISNAN_ERROR, 'Numeric.f95', 'MGSLeastSquares' )
   IF( ANY(ISNAN(b)) .OR. ANY(ISINF(b)) ) CALL ExecutionError( B_ISNAN_ERROR, 'Numeric.f95', 'MGSLeastSquares' )

   ! Carry out the modified Gram-Schmidt orthogonalization.
   DO k = 1, n
      R(k,k) = SQRT( DOT_PRODUCT( A(1:m,k), A(1:m,k) ) )
      IF( R(k,k) .LT. EPS ) CALL ExecutionError( A_ISSINGULAR_ERROR, 'Numeric.f95', 'MGSLeastSquares' )  ! Not full column rank.
      A(1:m,k) = A(1:m,k)/R(k,k)

      DO j = k+1, n
         R(k,j) = DOT_PRODUCT( A(1:m,k), A(1:m,j) )
         A(1:m,j) = A(1:m,j) - A(1:m,k)*R(k,j)
      END DO

      ! Apply the orthogonalization to the augmented part of the system.
      x(k) = DOT_PRODUCT( A(1:m,k), b(1:m) )
      b(1:m) = b(1:m) - A(1:m,k)*x(k)
   END DO

   ! Compute x = R~z using back-substitution.  Recall that z is stored in x
   ! at this point.
   x(n) = x(n)/R(n,n)

   DO k = n-1, 1, -1
      x(k) = (x(k) - DOT_PRODUCT( R(k,k+1:n), x(k+1:n) ))/R(k,k)
   END DO

END SUBROUTINE MGSLeastSquares

!------------------------------------------------------------------------------
! RSPDInv
!
!     Compute the inverse of a real, symmetric, positive definite matraix A.
!
! Notes:
!
! o   The inversion in place for an upper triangular matrix is based upon
!     the psudo-code given in Stewart (1998, p. 179).
!
! o   The matrices A and Ainv may be the same space in memory.
!
! References:
!
!     Stewart, G., 1998, "Matrix Algorithms - Volume I: Basic Decompositions",
!     SIAM, Philadelphia, 458pp., ISBN 0-89871-414-1.
!------------------------------------------------------------------------------
SUBROUTINE RSPDInv(N, L, Ainv)

   ! Declare the arguments.
   INTEGER,                 INTENT(IN)  :: N
   REAL(8), DIMENSION(N,N), INTENT(IN)  :: L
   REAL(8), DIMENSION(N,N), INTENT(OUT) :: Ainv

   ! Declare the local variables.
   INTEGER :: i, k
   REAL(8), DIMENSION(N,N) :: U

   ! Compute the Cholesky decomposition.
   ! CALL CholeskyDecomposition(N, A, L)
   U = TRANSPOSE(L)

   ! Invert U in place.
   DO k = 1, N
      U(k,k) = 1.0_8/U(k,k)

      DO i = 1, k-1
         U(i,k) = -U(k,k) * DOT_PRODUCT( U(i,i:k-1), U(i:k-1, k) )
      END DO
   END DO

   ! A = L L' = L U --> Ainv = Uinv Linv = Uinv (Uinv)'
   Ainv = MATMUL(U, TRANSPOSE(U))

END SUBROUTINE RSPDInv

!------------------------------------------------------------------------------
! GaussianCDF
!
!     The Pr(z <= Z) for a Gaussian (standard Normal) distribution.
!
! Notes:
!
! o   This is an implementation of the rational approximation given by
!     Abramowitz & Stegun (26.2.17).
!
! o   The |error| < 7.5 x 10^-8.
!
! o   The tails are squashed at Z = +/- 5;  Pr(z<-5) = 0, Pr(z>+5) = 1.
!
! References:
!
! o   Abramowitz, M., and I. Stegun, 1972, "Handbook of Mathematical
!     Functions", Dover, New York, 1046 pp., ISBN 486-61272-4.
!------------------------------------------------------------------------------
FUNCTION GaussianCDF( Z ) RESULT( CDF )

   ! Declare the arguments.
   REAL(8), INTENT(IN) :: Z
   REAL(8) :: CDF

   ! Declare the local variables.
   REAL(8) :: E, T, P

   ! Deal with the extreme cases.
   IF( Z .LE. -5.0_8 ) THEN
      CDF = 0.0_8
   ELSEIF( Z .GE. 5.0_8 ) THEN
      CDF = 1.0_8
   ELSE
      ! Abramowitz & Stegun (26.2.17)
      E = ONE_OVER_SQRT_TWO_PI * EXP( -0.5_8*Z*Z )
      T = 1.0_8 / ( 1.0_8 + 0.2316419_8*ABS(Z) )
      P = ((((1.330274429_8*T - 1.821255978_8 )*T + 1.781477937_8)*T - 0.356563782_8)*T + 0.319381530_8)*T

      IF( Z .GT. 0.0_8 ) THEN
         CDF = 1.0_8 - E*P
      ELSE
         CDF = E*P
      ENDIF
   ENDIF

END FUNCTION GaussianCDF

!------------------------------------------------------------------------------
! GaussianRN
!
!     Generate a Gaussian (standard Normal) pseudo-random number.
!
! Notes:
!
! o   This code is based upon Flannery et al. (1986, p. 203).
!
! o   This routine computes two Gaussian pseudo-random number simultaneously,
!     using the Box-Mueller transformation.
!
! References:
!
! o   Press, W. B. Flannery, S. Teukolsky, and W. Vetterling, 1986, "Numerical
!     Recipes - The Art of Scientific Computing", Cambridge Univerty Press,
!     Cambridge, 818 pp., ISBN 0-521-30811-9.
!------------------------------------------------------------------------------
FUNCTION GaussianRN() RESULT(Z)

   ! Declare the arguments.
   REAL(8) :: Z

   ! Declare the local variables.
   LOGICAL, SAVE               :: Stored = .FALSE.
   REAL(8), SAVE, DIMENSION(2) :: V
   REAL(8)                     :: R

   ! Create new random variables, only if needed.
   IF( Stored ) THEN
      Z = V(2)
   ELSE
      R = 2
      DO WHILE( R .GE. 1 )
         CALL RANDOM_NUMBER( V )
         V = 2*V - 1
         R = V(1)*V(1) + V(2)*V(2)
      END DO

      V = SQRT(-2*LOG(R)/R) * V
      Z = V(1)
   END IF

END FUNCTION GaussianRN

!------------------------------------------------------------------------------
! GaussianRNG
!
!     Create a vector of independent, Gaussian, pseudo-random numbers.
!------------------------------------------------------------------------------
SUBROUTINE GaussianRNG(nSims, Z)

   ! Declare the arguments.
   INTEGER,               INTENT(IN)  :: nSims
   REAL(8), DIMENSION(:), INTENT(OUT) :: Z

   ! Declare the local variables.
   INTEGER :: n

   ! Generate a vector of independent pseudo-random variables.
   DO n = 1, nSims
      Z(n) = GaussianRN()
   END DO
END SUBROUTINE GaussianRNG

!------------------------------------------------------------------------------
! MVNormalRNG
!
!     Generates a set of pseudorandom vectors from a multivariate normal
!     distribution with mean vector Mu, and variance-covariance matrix Sigma.
!
! Notes:
!
! o   The rows of V are independent random vectors.  The columns of each are
!     are correlated random variables.
!------------------------------------------------------------------------------
SUBROUTINE MVNormalRNG( nSims, nVars, Mu, Sigma, V )

   ! Declare the arguments.
   INTEGER,                          INTENT(IN)  :: nSims
   INTEGER,                          INTENT(IN)  :: nVars
   REAL(8), DIMENSION(nVars),        INTENT(IN)  :: Mu
   REAL(8), DIMENSION(nVars, nVars), INTENT(IN)  :: Sigma

   REAL(8), DIMENSION(nSims, nVars), INTENT(OUT) :: V

   ! Declare the local variables.
   INTEGER :: m
   REAL(8), DIMENSION(nVars,nVars) :: C
   REAL(8), DIMENSION(nVars)       :: Z

   ! Cholesky decomposition of Sigma.
   CALL CholeskyDecomposition(nVars, Sigma, C)

   ! Simulate the vectors one at a time.
   DO m = 1, nSims
      CALL GaussianRNG(nVars, Z)
      V(m,1:nVars) = Mu(1:nVars) + MATMUL(C, Z)
   END DO

END SUBROUTINE MVNormalRNG

!------------------------------------------------------------------------------
! Randomize
!
!   Initialize the random number generator.
!
! Arguments:
!   flag   If .TRUE. the random number generator is initialized with an array
!          of seed values that guarnatee a different set of random numbers
!          from one run to the next.
!
!          If .FALSE. the random number generator is initialized to DEFAULT
!          seeting, so that every run generates the same sequence of random
!          numbers. Thus, this is NOT randomized.
!
! Notes:
! o This routine is based on the comparable routine given as an example in
!   the GFORTRAN manual.
!------------------------------------------------------------------------------
SUBROUTINE Randomize( flag )
   ! Declare the arguments.
   LOGICAL, INTENT(IN)  :: flag

   ! Declare the local variables.
   INTEGER, ALLOCATABLE :: seed(:)
   INTEGER :: i, n, dat(8), pid
   INTEGER(INT64) :: s, t

   ! Query the compiler for the size of the random seed array.
   CALL RANDOM_SEED(SIZE = n)
   ALLOCATE( seed(n) )

   ! Randomize or set to default.
   IF( flag ) THEN
      ! Generate the array of seed values by XOR:ing the current time and pid.
      ! The PID is useful in case one launches multiple instances of the same
      ! program in parallel. Then using this value in a crude LCG generator.
      CALL DATE_AND_TIME( VALUES=dat )
      t = (dat(1) - 2010) * 365_int64 * 24 * 60 * 60 * 1000 &
         + dat(2) * 31_int64 * 24 * 60 * 60 * 1000 &
         + dat(3) * 24_int64 * 60 * 60 * 1000 &
         + dat(5) * 60 * 60 * 1000 &
         + dat(6) * 60 * 1000 &
         + dat(7) * 1000 &
         + dat(8)

      pid = GETPID()
      s = IEOR(t, INT(pid, KIND(t)))

      DO i = 1, n
         s = mod(s * 279470273_INT64, 4294967291_INT64)
         seed(i) = INT( MOD(s, INT(HUGE(0), INT64)), KIND(0) )
      END DO
   ELSE
      DO i = 1, n
         seed(i) = i
      END DO
   END IF

   ! After all that, set the random seed array.
   CALL RANDOM_SEED( PUT=seed )
   DEALLOCATE( seed )
END SUBROUTINE Randomize

!------------------------------------------------------------------------------
! ISFINITE
!------------------------------------------------------------------------------
ELEMENTAL FUNCTION ISINF( A )
   LOGICAL ISINF
   REAL(8), INTENT(IN) :: A

   ISINF = (A .GE. INFINITY)
END FUNCTION ISINF

!------------------------------------------------------------------------------
! Dump
!------------------------------------------------------------------------------
SUBROUTINE Dump(OUNIT, A, M, N)
   ! Declare the arguments.
   INTEGER, INTENT(IN)                 :: OUNIT
   INTEGER, INTENT(IN)                 :: M
   INTEGER, INTENT(IN)                 :: N
   REAL(8), DIMENSION(M,N), INTENT(IN) :: A

   ! Declare the local variables.
   INTEGER :: i, j

   WRITE(*,*)
   DO i = 1, M
      WRITE(OUNIT, '(12(E12.4, 1X))') (A(i,j), j = 1,N)
   END DO
END SUBROUTINE Dump

!==============================================================================
END MODULE NUMERIC_MODULE
!==============================================================================


C$Procedure   MTXMG ( Matrix transpose times matrix, general dimension )

      SUBROUTINE MTXMG ( M1, M2, NC1, NR1R2, NC2, MOUT )

C$ Abstract
C
C      Multiply the transpose of a matrix with another matrix,
C      both of arbitrary size. (The dimensions of the matrices must be
C      compatible with this multiplication.)
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      MATRIX
C
C$ Declarations

      INTEGER            NC1
      INTEGER            NR1R2
      INTEGER            NC2
      DOUBLE PRECISION   M1   ( NR1R2,NC1 )
      DOUBLE PRECISION   M2   ( NR1R2,NC2 )
      DOUBLE PRECISION   MOUT ( NC1,  NC2 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       M1        I     Left-hand matrix whose transpose is to be
C                       multiplied.
C       M2        I     Right-hand matrix to be multiplied.
C       NC1       I     Column dimension of M1 and row dimension of
C                       MOUT.
C       NR1R2     I     Row dimension of M1 and row dimension of M2.
C       NC2       I     Column dimension of M2 and column dimension of
C                       MOUT.
C       MOUT      O     Product matrix M1**T * M2.
C                       MOUT must NOT overwrite either M1 or M2.
C
C$ Detailed_Input
C
C      M1      This is an double precision matrix of arbitrary dimension
C              whose transpose is the left hand multiplier of a matrix
C              multiplication.
C      M2      This is an double precision matrix of arbitrary dimension
C              whose transpose is the left hand multiplier of a matrix
C              multiplication.
C      NC1     This is the column dimension of M1 and row dimension of
C              MOUT.
C      NR1R2   This is the row dimension of both M1 and M2.
C      NC2     This is the column dimension of both M2 and MOUT.
C
C$ Detailed_Output
C
C      MOUT is a double precision matrix containing the product
C
C                        T
C             MOUT = (M1)   x (M2)
C
C      where the superscript T denotes the transpose of M1.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C      The code reflects precisely the following mathematical expression
C
C      For each value of the subscript I from 1 to NC1, and J from 1
C      to NC2:
C
C      MOUT(I,J) = Summation from K=1 to NR1R2 of  ( M1(K,I) * M2(K,J) )
C
C      Note that the reversal of the K and I subscripts in the left-hand
C      matrix M1 is what makes MOUT the product of the TRANSPOSE of M1
C      and not simply of M1 itself.
C
C      Since this subroutine operates on matrices of arbitrary size, it
C      is not possible to buffer intermediate results.  Thus, MOUT
C      should NOT overwrite either M1 or M2.
C
C$ Examples
C
C      Suppose that M1 = | 1  2  3  0 |
C                        | 1  1  1  1 |
C
C      and that     M2 = | 1  2  3 |
C                        | 0  0  0 |
C
C      Then calling MTXMG according to the following calling sequence
C
C      CALL MTXMG (M1, M2, 4, 2, 3, MOUT)
C
C      will yield the following value for MOUT
C
C             | 1  2  3 |
C      MOUT = | 2  4  6 |
C             | 3  6  9 |
C             | 0  0  0 |
C
C$ Restrictions
C
C      1) The user is responsible for checking the magnitudes of the
C      elements of M1 and M2 so that a floating point overflow does
C      not occur.
C      2) MOUT must not overwrite M1 or M2 or else the intermediate
C      will affect the final result.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None
C
C$ Author_and_Institution
C
C      N.J. Bachman    (JPL)
C      W.M. Owen       (JPL)
C
C$ Literature_References
C
C      None
C
C$ Version
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     matrix_transpose times matrix n-dimensional_case
C
C-&

C$ Revisions
C
C-     Beta Version 1.1.0, 16-FEB-1989 (NJB)
C
C         Contents of the Exceptions section was changed
C         to "error free" to reflect the decision that the
C         module will never participate in error handling.
C
C         Declaration of unused variable SUM removed.
C
C-&

      INTEGER               I
      INTEGER               J
      INTEGER               K

C
C  Perform the matrix multiplication
C
      DO I = 1, NC1
         DO J = 1, NC2

            MOUT(I,J) = 0.D0
            DO K = 1, NR1R2
               MOUT(I,J) = MOUT(I,J) + M1(K,I)*M2(K,J)
            END DO

         END DO
      END DO
C
      RETURN
      END


!> Orchid -- 2D/3D Euler/MagnetoHydroDynamics solver.
!> Copyright (C) Butakov Oleg 2019.

Module orchid_solver_grid_gauss_legendre_poly
Implicit None
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Function mhd_legendre_poly(m, x) Result(y)
    !> Legendre polynomial value.
    !> {{{
    Integer, Intent(In) :: m
    Real(8), Intent(In) :: x
    Real(8) :: y
    !> }}}
    Select Case ( m )
        Case ( 0 )
            y = 1.0D0
        Case ( 1 )
            y = x
        Case ( 2 )
            y = 1.5D0*x**2 - 0.5D0
        Case ( 3 )
            y = x*( 2.5D0*x**2 - 1.5D0 )
        Case ( 4 )
            y = x**2
            y = 4.375D0*y**2 - 3.75D0*y + 0.375D0
        Case ( 5 )
            y = x**2
            y = x*( 7.875D0*y**2 - 8.75*y + 1.875D0 )
        Case Default
            Write (0,*) 'Too large Legendre polynomial number.'
            Error Stop -1
    End Select
End Function mhd_legendre_poly
!########################################################################################################
!########################################################################################################
!########################################################################################################
Function mhd_legendre_func(m, x) Result(y)
    !> Legendre function (:= orhonormalized polynomial) value.
    !> {{{
    Integer, Intent(In) :: m
    Real(8), Intent(In) :: x
    Real(8) :: y
    !> }}}
    y = mhd_legendre_poly(m, x)
    y = Sqrt(0.5D0*( 2.0D0*Dble(m) + 1.0D0 ))*y
End Function mhd_legendre_func
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_grid_gauss_legendre_poly

Module orchid_solver_grid_gauss_legendre
Use orchid_solver_params
Use orchid_solver_grid_gauss
Implicit None
Type :: MhdGridGaussLegendreFunc
    Real(8) :: Psi
    Real(8) :: grad
    Real(8) :: grad_nx, grad_ny, grad_nz
    Contains
End Type MhdGridGaussLegendreFunc
Type, Extends(MhdGridGauss) :: MhdGridGaussLegendre
    Type(MhdGridGaussLegendreFunc), Dimension(:, :), Allocatable :: cell_node_funcs
    Type(MhdGridGaussLegendreFunc), Dimension(:, :, :), Allocatable :: face_node_funcs
    Contains
    Procedure, Public, Non_Overridable :: init_legendre_dummy => mhd_grid_gauss_legendre_init_dummy
    Procedure, Public, Non_Overridable :: init_legendre1D => mhd_grid_gauss_legendre_init1D
End Type MhdGridGaussLegendre
Private :: mhd_grid_gauss_legendre_init_dummy
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Subroutine mhd_grid_gauss_legendre_init_dummy(This)
    !> Initialize a dummy Legendre-Gauss grid.
    !> {{{
    Class(MhdGridGaussLegendre), Intent(InOut) :: This
    !> }}}
    Integer :: n
    !>-------------------------------------------------------------------------------
    !> Allocate the Gauss Grid.
    Allocate(This%cell_node_funcs(m_min:m_max, This%ncell_nodes_min:This%ncell_nodes_max))
    Allocate(This%face_node_funcs(m_min:m_max, 1:2, This%nface_nodes_min:This%nface_nodes_max))
    !>-------------------------------------------------------------------------------

    !>-------------------------------------------------------------------------------
    !> Initialize functions.
    This%cell_node_funcs(:, :)%psi = 1.0D0
    This%cell_node_funcs(:, :)%grad = 0.0D0
    This%cell_node_funcs(:, :)%grad_nx = 0.0D0
    This%cell_node_funcs(:, :)%grad_ny = 0.0D0
    This%cell_node_funcs(:, :)%grad_nz = 0.0D0
    This%face_node_funcs(:, :, :)%psi = 1.0D0
    This%face_node_funcs(:, :, :)%grad = 0.0D0
    This%face_node_funcs(:, :, :)%grad_nx = 0.0D0
    This%face_node_funcs(:, :, :)%grad_ny = 0.0D0
    This%face_node_funcs(:, :, :)%grad_nz = 0.0D0
    !>-------------------------------------------------------------------------------
End Subroutine mhd_grid_gauss_legendre_init_dummy
!########################################################################################################
!########################################################################################################
!########################################################################################################
Subroutine mhd_grid_gauss_legendre_init1D(This)
    !> Initialize a dummy Legendre-Gauss grid.
    !> {{{
    Class(MhdGridGaussLegendre), Intent(InOut) :: This
    !> }}}
    Integer :: n
    Real(8) :: h
    If (n_funcs == 1) Then
       Call this%init_legendre_dummy()
       Return
    End If

    !>-------------------------------------------------------------------------------
    !> Allocate the Gauss Grid.
    Allocate(This%cell_node_funcs(m_min:m_max, This%ncell_nodes_min:This%ncell_nodes_max))
    Allocate(This%face_node_funcs(m_min:m_max, 1:2, This%nface_nodes_min:This%nface_nodes_max))
    !>-------------------------------------------------------------------------------

    !>-------------------------------------------------------------------------------
    !> Initialize functions.
    This%cell_node_funcs(0, :)%psi = 1.0D0
    This%cell_node_funcs(0, :)%grad = 0.0D0
    This%cell_node_funcs(0, :)%grad_nx = 0.0D0
    This%cell_node_funcs(0, :)%grad_ny = 0.0D0
    This%cell_node_funcs(0, :)%grad_nz = 0.0D0
    This%face_node_funcs(0, :, :)%psi = 1.0D0
    This%face_node_funcs(0, :, :)%grad = 0.0D0
    This%face_node_funcs(0, :, :)%grad_nx = 0.0D0
    This%face_node_funcs(0, :, :)%grad_ny = 0.0D0
    This%face_node_funcs(0, :, :)%grad_nz = 0.0D0
    Do n = This%ncells_min, This%ncells_max
        h = This%cells(n)%Vcell
        This%cell_node_funcs(1, This%gcells(n)%nnode)%psi = &
             2.0D0/This%cells(n)%Vcell*( This%cell_nodes(This%gcells(n)%nnode)%x - This%cells(n)%x )
        This%cell_node_funcs(1, This%gcells(n)%nnode)%grad = 2.0D0/This%cells(n)%Vcell
        This%cell_node_funcs(1, This%gcells(n)%nnode)%grad_nx = 1.0D0
        This%cell_node_funcs(1, This%gcells(n)%nnode)%grad_ny = 0.0D0
        This%cell_node_funcs(1, This%gcells(n)%nnode)%grad_nz = 0.0D0
        This%cell_node_funcs(1, This%gcells(n)%nnode_end)%psi = &
             2.0D0/This%cells(n)%Vcell*( This%cell_nodes(This%gcells(n)%nnode_end)%x - This%cells(n)%x )
        This%cell_node_funcs(1, This%gcells(n)%nnode_end)%grad = 2.0D0/This%cells(n)%Vcell
        This%cell_node_funcs(1, This%gcells(n)%nnode_end)%grad_nx = 1.0D0
        This%cell_node_funcs(1, This%gcells(n)%nnode_end)%grad_ny = 0.0D0
        This%cell_node_funcs(1, This%gcells(n)%nnode_end)%grad_nz = 0.0D0
    End Do
    Do n = This%nfaces_min, This%nfaces_max
        This%face_node_funcs(1, 1, This%gfaces(n)%nnode)%psi = -1.0D0
        This%face_node_funcs(1, 2, This%gfaces(n)%nnode)%psi = +1.0D0
        This%face_node_funcs(1, :, This%gfaces(n)%nnode)%grad = 2.0D0/h
        This%face_node_funcs(1, :, This%gfaces(n)%nnode)%grad_nx = 1.0D0
        This%face_node_funcs(1, :, This%gfaces(n)%nnode)%grad_ny = 0.0D0
        This%face_node_funcs(1, :, This%gfaces(n)%nnode)%grad_nz = 0.0D0
    End Do
    !>-------------------------------------------------------------------------------
End Subroutine mhd_grid_gauss_legendre_init1D
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_grid_gauss_legendre


module mod_average

  ! This module provides the generic function average that returns
  ! the average value of an integer, real, or logical array.

  implicit none

  private
  public :: average, operator(.average.)

  interface average
    module procedure :: average_int
    module procedure :: average_real
    module procedure :: average_logical
  end interface average

  interface operator(.average.)
    module procedure :: average_int, average_real, average_logical
  end interface operator(.average.)

contains

  pure real function average_int(x) result(res)
    ! Returns an average of a real array x.
    ! Overloaded by the generic function average.
    integer, intent(in) :: x(:)
    res = real(sum(x), kind=kind(res)) / size(x)
  end function average_int

  pure real function average_real(x) result(res)
    ! Returns an average of a real array x.
    ! Overloaded by the generic function average.
    real, intent(in) :: x(:)
    res = sum(x) / size(x)
  end function average_real

  pure real function average_logical(x) result(res)
    ! Returns an average of a real array x.
    ! Overloaded by the generic function average.
    logical, intent(in) :: x(:)
    res = real(count(x), kind=kind(res)) / size(x)
  end function average_logical

end module mod_average


!------------------------------------------------------------------------
! This program solves one-dimensional convection-diffusion
! equation:
!
!   d (rho*u*phi) / dx = d (Gamma*d(phi)/dx) / dx
!
! by finite difference method
! with Dirichlet boundary conditions on both ends.
!
! The discrete equation can be written as
!
!  ae(i)*phi(i+1) + aw(i)*phi(i-1) + ap(i)*phi(i) = su(i)
!
! Discretization schemes:
!   diffusion term - Cetral Differencing Scheme (CDS)
!   convection term - Upwind Differencing Scheme (UDS) or CDS
!
! We can demenstrate the oscillations using CDS and false diffusion using UDS.
! And how they are reduced with grid refinement.
!
! Oscillations related to CDS can be reduced by ensuring that
! the local Pe is not larger than 2 in regions of high gradient change of phi.
! This can be demenstrated using a non-uniform grid.
!
! Finally, we can prove the order of accuracy of numerical schemes by
! calculating the average error with reduction of grid spacing
!
!
! Reference:
!   J. H. Ferziger and M. Peric, Computational Methods for Fluid Dynamics,
!   3rd ed. Springer Berlin Heidelberg, 2001.
!--------------------------------------------------------------------------
module conv_diff_mod

implicit none

integer, parameter :: dp = selected_real_kind(15) ! Double precision

contains

subroutine tdma(a, b, c, d, x)
!  Tri-diagonol system of equations
!|a1 -b1                    | | x1 | | d1 |
!|-c2 a2 -b2                | | x2 | | d2 |
!|   -c3 a3 -b3             | | x3 | | d3 |
!|       .. .. ..           |*| .. |=| .. |
!|          .. .. ..        | | .. | | .. |
!|          -cn-1 an-1 -bn-1| |xn-1| |dn-1|
!|                -cn   an  | | xn | | dn |
!  ith equation in the system:
!   a(i)x(i) = b(i)x(i+1) + c(i)x(i-1) + d(i)
implicit none
integer :: i, ierr
integer :: n
real(dp), dimension(:), intent(in) :: a, b, c, d
real(dp), dimension(:), intent(out) :: x
real(dp), allocatable, dimension(:) :: p, q
n = size(a(:))
allocate(p(1:n), q(1:n), stat=ierr)
!-----Forward elimination
! 1 and n are boundary values.
p(1) = 0.0_dp
q(1) = x(1)
do i = 2, n-1
  p(i) = b(i) / (a(i)-c(i)*p(i-1))
  q(i) = (d(i)+c(i)*q(i-1)) / (a(i)-c(i)*p(i-1))
end do
!-----Back substitution
do i = n-1, 2, -1
  x(i) = p(i)*x(i+1) + q(i)
end do
deallocate(p, q, stat=ierr)
end subroutine tdma

function PHI_EXACT(x, pe, l, phi_i, phi_o)
! Exact solution of 1-D advection-diffusion equation.
implicit none
real(dp), intent(in) :: x, pe, l, phi_i, phi_o
real(dp) :: PHI_EXACT

PHI_EXACT = phi_i + (phi_o-phi_i)*(EXP(x*pe/l)-1.0_dp)/(EXP(pe)-1.0_dp)

end function PHI_EXACT

end module conv_diff_mod

program fd1dscd
! Convection term: use upwind or central difference scheme.
! Diffusion term: use central difference scheme.
use conv_diff_mod
implicit none
integer :: i, ni, nim1
integer :: ierr, csm
real(dp) :: den, u, gam, pe, phi_in, phi_out, err
real(dp) :: xmin, xmax, dx, expf
real(dp) :: cw, ce, dw, de
real(dp), allocatable, dimension(:) :: x, phi, phi_ex
real(dp), allocatable, dimension(:) :: aw, ae, ap, su
!-----Initialize variables
ni = 11
nim1 = ni - 1
den = 1.0_dp  ! density
u = 1.0_dp  ! velocity, assume constant
gam = 0.02_dp  ! diffusion coefficient, assume constant
phi_in = 0.0_dp  ! left boundary value
phi_out = 1.0_dp ! right boundary value
xmin = 0.0_dp
xmax = 1.0_dp  ! length of domain
expf = 1.0_dp  ! grid expansion factor
csm = 1  ! convection scheme: 1.UDS 2.CDS
!-----Initialize arrays
allocate(x(ni), phi(ni), phi_ex(ni), stat=ierr)
allocate(aw(ni), ae(ni), ap(ni), su(ni), stat=ierr)
aw = 0.0_dp
ae = 0.0_dp
ap = 0.0_dp
su = 0.0_dp
x = 0.0_dp
phi = 0.0_dp
phi_ex = 0.0_dp
!-----Define grid
if (expf==1.0_dp) then
  ! uniform grid
  dx = (xmax-xmin) / (ni-1)
else
  ! non-uniform grid
  ! a little math here: need to know sum of a geometric series
  ! to get the first dx.
  dx = (xmax-xmin) * (1.0_dp-expf) / (1.0_dp-expf**(ni-1))
end if
x(1) = xmin
do i = 2, ni
  x(i) = x(i-1) + dx
  dx = dx * expf
end do
!-----Boundary values
phi(1) = phi_in
phi(ni) = phi_out
!-----Compute coefficients of algebraic equations at each point
do i = 2, nim1
  if (csm==1) then
!-----Upwind advection
    ce = min(den*u, 0.0_dp) / (x(i+1)-x(i))
    cw = -max(den*u, 0.0_dp) / (x(i)-x(i-1))
  else
!-----Central difference advection
    ce = den*u / (x(i+1)-x(i-1))
    cw = -den*u / (x(i+1)-x(i-1))
  end if
!-----Central difference diffusion
  de = -2.0_dp*gam / ((x(i+1)-x(i-1)) * (x(i+1)-x(i)))
  dw = -2.0_dp*gam / ((x(i+1)-x(i-1)) * (x(i)-x(i-1)))
!-----Assemble coefficient
  ae(i) = (ce + de)
  aw(i) = (cw + dw)
  ap(i) = aw(i) + ae(i)
end do
!-----Boundary nodes treatment
! included in the solver
!su(2) = su(2) + aw(2)*phi(1)
!aw(2) = 0.0_dp
!su(nim1) = su(nim1) + ae(nim1)*phi(ni)
!ae(nim1) = 0.0_dp
!-----Solve
call tdma(ap, ae, aw, su, phi)
!-----Exact solution
pe = den*u*xmax/gam
err = 0.0_dp
do i = 1, ni
  phi_ex(i) = PHI_EXACT(x(i), pe, xmax-xmin, phi_in, phi_out)
  err = err + ABS(phi(i) - phi_ex(i))
end do
err = err / ni
!-----Write out
write(*,*) '   One-dimension convection-diffusion problem'
write(*,*)
write(*,*) '   Peclet number: ', pe
write(*,*) '   Error avg: ', err
! coefficients
write(*,'(/,t8,4(a2,13x))') 'aw', 'ae', 'ap', 'su'
do i = 1, ni
  write(*,'(4(f15.3))') aw(i), ae(i), ap(i), su(i)
end do
! phi
write(*,'(/,t8,a2,10x,a3,6x,a9,5x,a5)') 'x', 'phi', &
                                        'phi_exact', 'Error'
do i = 1, ni
  write(*,'(4(f12.5))') x(i), phi(i), phi_ex(i), &
                        phi_ex(i)-phi(i)
end do
deallocate(aw, ae, ap, su)
deallocate(x, phi, phi_ex)
end program fd1dscd
!********************************************************************************


!>
module m_diffeq

  use m_parameters , only : INFINITY

  implicit none

  private
  public :: numerov_f, numerov_b

contains

  ! numerov_f
  !
  ! Brief:
  ! Calculates the values of $y(x)$, defined by the differential equation
  ! $$ y''(x) = -g(x)y(x) + s(x) $$ ,
  ! on a grid to fourth-order accuracy using the forward Numerov method.
  !
  ! Summary:
  ! Suppose, $X = \{x_{1}, \dotsc, x_{n_{x}}\}$, is a grid with $n_{x}$ points,
  ! such that $x_{i+1} - x_{i} = h$ for all $i = 1, \dotsc, n_{x}-1$,
  ! and that $g(x), s(x) : \mathbb{R} \to \mathbb{R}$ have been evaluated on
  ! this grid.
  ! Suppose further that $y : \mathbb{R} \to \mathbb{R}$ is defined by the
  ! differential equation,
  ! $$ y''(x) = -g(x)y(x) + s(x) $$ ,
  ! and the values of $y(x_{1}), y(x_{2})$ are known.
  ! The values of $y(x_{i})$ for $i = 3, \dotsc, n_{x}$ are calculated to
  ! fourth-order accuracy using the forward Numerov method.
  !
  ! Input:
  ! - `n_x` is the number of grid points.
  ! - `step_size` is the distance between consecutive points on the grid $X$.
  ! - `s_grid` is the evaluation of $s(x)$ on the grid $X$.
  ! - `g_grid` is the evaluation of $g(x)$ on the grid $X$.
  !
  ! Output:
  ! - `y_grid` is the evaluation of $y(x)$ on the grid $X$, calculated via the
  !   forward Numerov method.
  ! - `status` integer status code which takes the following values:
  !   - `status == 0` indicates successful execution;
  !   - `status > 0` indicates that the arguments were invalid;
  !   - `status == -1` indicates that a numerical error (NaN or infinity)
  !     occured during execution.
  !
  subroutine numerov_f (n_x, step_size, s_grid, g_grid, y_grid, status)
    integer , intent(in) :: n_x
    double precision , intent(in) :: step_size
    double precision , intent(in) :: s_grid(n_x)
    double precision , intent(in) :: g_grid(n_x)
    double precision , intent(out) :: y_grid(n_x)
    integer , intent(out) :: status
    double precision :: step_s_grid(n_x)
    double precision :: step_g_grid(n_x)
    integer :: ii

    ! check if arguments are valid
    status = 0

    if (n_x < 1) then
      ! no grid points
      status = 1
    end if

    if (step_size < 0.0d0) then
      ! non-positive step_size
      status = 2
    end if

    ! terminate subroutine if arguments are invalid, otherwise proceed
    if (status /= 0) then
      y_grid(:) = 0.0d0
      return
    end if

    ! perform forward-numerov method
    step_s_grid(:) = s_grid(:) * (step_size ** 2) / 12.0d0
    step_g_grid(:) = g_grid(:) * (step_size ** 2) / 12.0d0

    if (n_x >= 3) then
      do ii = 2, n_x - 1
        y_grid(ii+1) = &
            ((2*y_grid(ii)*(1.0d0 - 5.0d0*step_g_grid(ii))) &
            - (y_grid(ii-1)*(1.0d0 + step_g_grid(ii-1))) &
            + (step_s_grid(ii+1) + 10.0d0*step_s_grid(ii) + step_s_grid(ii-1)) &
            ) / (1.0d0 + step_g_grid(ii+1))

        ! check for and handle numerical error (NaN or Infinity) and terminates
        if ((y_grid(ii+1) /= y_grid(ii+1)) .or. (y_grid(ii+1) > INFINITY)) then
          status = -1

          if (ii + 2 <= n_x) then
            y_grid(ii+2:n_x) = 0.0d0
          end if

          return
        end if
      end do
    end if

  end subroutine numerov_f

  ! numerov_b
  !
  ! Brief:
  ! Calculates the values of $y(x)$, defined by the differential equation
  ! $$ y''(x) = -g(x)y(x) + s(x) $$ ,
  ! on a grid to fourth-order accuracy using the backward Numerov method.
  !
  ! Summary:
  ! Suppose, $X = \{x_{1}, \dotsc, x_{n_{x}}\}$, is a grid with $n_{x}$ points,
  ! such that $x_{i+1} - x_{i} = h$ for all $i = 1, \dotsc, n_{x}-1$,
  ! and that $g(x), s(x) : \mathbb{R} \to \mathbb{R}$ have been evaluated on
  ! this grid.
  ! Suppose further that $y : \mathbb{R} \to \mathbb{R}$ is defined by the
  ! differential equation,
  ! $$ y''(x) = -g(x)y(x) + s(x) $$ ,
  ! and the values of $y(x_{n_{x}-1}), y(x_{n_{x}})$ are known.
  ! The values of $y(x_{i})$ for $i = 1, \dotsc, n_{x} - 2$ are calculated to
  ! fourth-order accuracy using the backward Numerov method.
  !
  ! Input:
  ! - `n_x` is the number of grid points.
  ! - `step_size` is the distance between consecutive points on the grid $X$.
  ! - `s_grid` is the evaluation of $s(x)$ on the grid $X$.
  ! - `g_grid` is the evaluation of $g(x)$ on the grid $X$.
  !
  ! Output:
  ! - `y_grid` is the evaluation of $y(x)$ on the grid $X$, calculated via the
  !   backward Numerov method.
  ! - `status` integer status code which takes the following values:
  !   - `status == 0` indicates successful execution;
  !   - `status > 0` indicates that the arguments were invalid;
  !   - `status == -1` indicates that a numerical error (NaN or infinity)
  !     occured during execution.
  !
  subroutine numerov_b (n_x, step_size, s_grid, g_grid, y_grid, status)
    integer , intent(in) :: n_x
    double precision , intent(in) :: step_size
    double precision , intent(in) :: s_grid(n_x)
    double precision , intent(in) :: g_grid(n_x)
    double precision , intent(out) :: y_grid(n_x)
    integer , intent(out) :: status
    double precision :: step_s_grid(n_x)
    double precision :: step_g_grid(n_x)
    integer :: ii

    ! check if arguments are valid
    status = 0

    if (n_x < 1) then
      ! no grid points
      status = 1
    end if

    if (step_size < 0.0d0) then
      ! non-positive step_size
      status = 2
    end if

    ! terminate subroutine if arguments are invalid, otherwise, proceed
    if (status /= 0) then
      y_grid(:) = 0.0d0
      return
    end if

    ! perform forward-numerov method
    step_s_grid(:) = s_grid(:) * (step_size ** 2) / 12.0d0
    step_g_grid(:) = g_grid(:) * (step_size ** 2) / 12.0d0

    if (n_x >= 3) then
      do ii = n_x - 1, 2, -1
        y_grid(ii-1) = &
            ((2*y_grid(ii)*(1.0d0 - 5.0d0*step_g_grid(ii))) &
            - (y_grid(ii+1)*(1.0d0 + step_g_grid(ii+1))) &
            + (step_s_grid(ii+1) + 10.0d0*step_s_grid(ii) + step_s_grid(ii-1)) &
            ) / (1.0d0 + step_g_grid(ii-1))

        ! check for and handle numerical error (NaN or Infinity) and terminates
        if ((y_grid(ii-1) /= y_grid(ii-1)) .or. (y_grid(ii-1) > INFINITY)) then
          status = -1

          if (1 <= ii - 2) then
            y_grid(1:ii-2) = 0.0d0
          end if

          return
        end if
      end do
    end if

  end subroutine numerov_b

end module m_diffeq


module g_elimination
use utils

implicit none
contains
  subroutine gaussian_elimination(A, x, b)
    integer :: i, j, k, m
    real(wp), allocatable, intent(inout) :: A(:,:), x(:), b(:)
    m = size(A, dim=1)
    ! Gauss elimination (on regular matrix)
    do i = 1, m-1
        do j = i+1, m
            A(j,i) = A(j,i)/A(i,i)
            b(j) = b(j) - b(i)*A(j,i)
            do k = i+1, m
                A(j,k) = A(j,k) - A(i,k)*A(j,i)
            end do
            A(j,i) = 0
        end do
    end do
    ! Solving the system (on regular matrix)
    do i = m, 1, -1
        x(i) = b(i)
        do j = m, i+1, -1
            x(i) = x(i) - A(i,j)*x(j)
        end do
        x(i) = x(i)/A(i,i)
    end do
  end subroutine

  subroutine gaussian_elimination_banded(Row, x, b, lb, ub)
    integer :: i,j,k,l,m,n,ms,fix_col_index,fix_diag_col_index,temp_fix_col_index,diagonal,padding
    integer, intent(in) :: lb, ub
    real(wp), allocatable, intent(inout) :: x(:), b(:)
    type(col), allocatable, intent(inout) :: Row(:)

    ! Matrix Size:
    ms = size(Row)

    fix_col_index = 0
    fix_diag_col_index = 0
    ! Gaussian Elimination
    do i = 1, ms-1
        ! For each row:
        j = i + 1

        ! Fix pivot index
        if ( i > (lb+1) ) then
          fix_diag_col_index = fix_diag_col_index + 1
        end if

        do while ( j <= i+lb .and. j <= ms)

          ! Fix column index
          fix_col_index = 0
          if ( j > (lb+1) ) then
            fix_col_index = j - (lb+1)
          end if

          ! Multiplier
          Row(j)%Col(i-fix_col_index) = Row(j)%Col(i-fix_col_index)&
                        /Row(i)%Col(i-fix_diag_col_index)

          ! Apply multiplier to the systems solution (b)
          b(j) = b(j) - Row(j)%Col(i-fix_col_index)*b(i)

          ! For each column:
          k = i + 1
          do while ( k <= i+ub .and. k <= ms )
              Row(j)%Col(k-fix_col_index) = Row(j)%Col(k-fix_col_index)&
              - Row(i)%Col(k-fix_diag_col_index)*Row(j)%Col(i-fix_col_index)
              k = k + 1
          end do

          ! Set multiplier to zero
          Row(j)%Col(i-fix_col_index) = 0

          j = j + 1
        end do
!        call pprint_band(Row,lb,ub)
    end do

    ! Solving the system
    ! k, diagonal and padding are auxiliary variables
    ! for index fixing/shifting
    ! due to the way the band matrix is stored.

    padding = 0
    diagonal = size(Row(ms)%Col)
    do i = ms, 1, -1
      ! Fix index
      if ( ms-i > ub ) then
        padding = padding + 1
      end if
      if ( i <= lb ) then
        diagonal = diagonal - 1
      end if
      k = ms - padding

      ! Regular algorithm
      x(i) = b(i)
      do j = size(Row(i)%Col), diagonal + 1, -1
        x(i) = x(i) - Row(i)%Col(j)*x(k)
        k = k -1
      end do
      x(i) = x(i)/Row(i)%Col(j)
    end do

  end subroutine gaussian_elimination_banded

end module g_elimination


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

MODULE FACT

    IMPLICIT NONE

    CONTAINS
        ! ---------
        ! FACTORIAL
        ! ---------
        FUNCTION factorial(n) result(fact)
            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: n

            ! INTERMEDIATE VARIABLE
            INTEGER :: i

            ! OUTPUT
            INTEGER :: fact

            fact = 1

            DO i = 2, n
                fact = fact * i
            END DO

        END FUNCTION factorial

        ! ----------
        ! FACTORIAL2
        ! ----------
        FUNCTION factorial2(n) result(fact2)
            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: n

            ! INTERMEDIATE VARIABLE
            INTEGER :: i

            ! OUTPUT
            INTEGER :: fact2

            IF (n == -1) THEN
                fact2 = 1
            ELSE IF (MOD(n,2) == 0) THEN ! EVEN NUMBER
                fact2 = 1

                DO i = 2, n, 2
                    fact2 = fact2 * i
                END DO
            ELSE ! ODD NUMBER
                fact2 = 1

                DO i = 1, n, 2
                    fact2 = fact2 * i
                END DO
            END IF

        END FUNCTION factorial2

        ! --------------------
        ! BINOMIAL COEFFICIENT
        ! --------------------
        FUNCTION binom(n,k)
            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: n, k

            ! OUTPUT
            INTEGER :: binom

            binom = factorial(n)
            binom = binom / factorial(k)
            binom = binom / factorial(n-k)

        END FUNCTION binom

END MODULE FACT


! Subroutine EGRID sets up electron energy grid

! This software is part of the GLOW model.  Use is governed by the open source
! academic research license agreement contained in the file glowlicense.txt.
! For more information see the file glow.txt.

! Stan Solomon, 1/1992
! Refactored to f90, SCS, 6/2016

! Inputs:
!   nbins   number of bins in the electron energy grid
! Outputs:
!   ener    energy at center of each bin, eV
!   del     width of each bin, eV

subroutine egrid (ener, del, nbins)

  implicit none

  integer,intent(in) :: nbins
  real,intent(out) :: ener(nbins), del(nbins)

  integer :: n

  do n=1,nbins
    if (n <= 21) then
      ener(n) = 0.5 * float(n)
    else
      ener(n) = exp (0.05 * float(n+26))
    endif
  enddo

  del(1) = 0.5

  do n=2,nbins
    del(n) = ener(n)-ener(n-1)
  enddo

  do n=1,nbins
    ener(n) = ener(n) - del(n)/2.0
  enddo

  return

end subroutine egrid


! vim: set ft=fortran sw=4 ts=4:

program tsunami

    ! Tsunami simulator
    !
    ! This version solves the linearized 1-d advection equation:
    !
    !   du/dt + c du/dx = 0
    !
    ! Discretized as:
    !   u^{n+1}_i = u^n_i - c * dt * (u^n{i} - u^n_{n-1}) / dx

    use iso_fortran_env, only: int32, real32, output_unit

    implicit none

    integer(int32) :: i, n

    integer(int32), parameter :: im = 100 ! grid size in x
    integer(int32), parameter :: nm = 100 ! number of time steps

    real(real32), parameter :: dt = 1 ! time step [s]
    real(real32), parameter :: dx = 1 ! grid spacing [m]
    real(real32), parameter :: c = 1 ! phase speed [m/s]

    real(real32) :: du(im), u (im)

    ! initial position & shape of blob
    integer(int32), parameter :: ipos = 25
    real(real32), parameter :: decay = 0.02

    ! initialize a gaussian blob centered at i = ipos = 25
    do i = 1, im
        u(i) = exp(-decay * (i -ipos)**2)
    end do

    ! write initial state to screen
    write(output_unit, *) 0, u

    time_loop: do n = 1, nm

        ! apply the periodic boundary condition
        du(1) = u(1) - u(im)

        ! calculate the difference of u in space
        do concurrent (i = 2:im)
            du(i) = u(i) - u(i-1)
        end do

        ! compute u at next time step
        do concurrent (i = 1:im)
            u(i) = u(i) - c * du(i) / dx * dt
        end do

        ! write output state to screen
        write(output_unit, *) n, u

    end do time_loop

end program tsunami


      subroutine SCOV3( V, MDIM, N, SING, VAR, WORK, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SCOV3  Krogh   Added external statement.
C>> 1994-10-20 SCOV3  Krogh  Changes to use M77CON
C>> 1987-11-24 SCOV3  Lawson  Initial code.
c--S replaces "?": ?COV3, ?COPY, ?DOT, ?SCAL
C     Computes the covariance matrix for the solution vector of a
c     least-squares problem, Ax ~=~ b.  Assumes quantities are
c     available that have been computed by the singular value
c     decomposition subroutine, _SVDRS.
c     The covariance matrix is given by
c           VAR * (V*Pseudoinverse(S)) * Transp(V*Pseudoinverse(S))
c     ------------------------------------------------------------------
c                 Subroutine Arguments
c
c     V(,) [inout] Array containing the NxN orthogonal V matrix of the
c                  singular value decomposition of the matrix, A.
c                  On return contains the NxN symmetric
c                  covariance matrix.
c     MDIM   [in]  First dimension of the array, V(,).
c                  Require MDIM .ge. N.
c     N      [in]  Order of the matrix V contained in the array V(,).
c     SING() [in]  Singular values of the matrix, A.
c     VAR    [in]  Estimate of variance of error in the right-side
c                  vector, b, of the least-squares problem, Ax ~=~ b.
c     WORK() [scratch]  Work space of size N.
c     IERR   [out] Set to 0 if ok.  Set to J > 0 if the Jth singular
c                  value is zero.  In this latter case
c                  the covariance matrix cannot be computed and the
c                  contents of V(,) on return will be meaningless.
C     ------------------------------------------------------------------
c
c     May, 1987, C. L. Lawson & S. Y. Chiu, JPL.
c     Programmed in Fortran 77 for use in the JPL MATH77 library.
c     Prefixing subprogram names with S or D for s.p. or d.p. versions.
c     Using BLAS subprograms SCOPY, SDOT, & SSCAL, and
c     MATH77 error processing subr., IERM1, which uses IERMV1, ERMSG,
C     ERFIN, and AMACH.
C     ------------------------------------------------------------------
      external SDOT
      integer I, IERR, J, N, MDIM
      real             SING(N), V(MDIM,N), WORK(N), ZERO, SDOT
      real             STDDEV, VAR
C
      parameter(ZERO = 0.0E0)
C     ------------------------------------------------------------------
      STDDEV = sqrt(VAR)
c
C              For J = 1, ...,N,  multiply col J of V by STDDEV/SING(J)
c
      do 40 J = 1,N
         if(SING(J) .eq. ZERO) then
            call IERM1('SCOV3',1,0,'Jth singular value is zero',
     *      'J',J,'.')
            IERR = J
            return
         end if
         call SSCAL(N, STDDEV/SING(J), V(1,J), 1)
   40 continue

      do 80 I = 1,N
         call SCOPY(N, V(I,1), MDIM, WORK, 1)
         do 60 J = I,N
            V(I,J) = SDOT(N, WORK, 1, V(J,1), MDIM)
   60    continue
         do 70 J = 1,I-1
            V(I,J) = V(J,I)
   70    continue
   80 continue
      IERR = 0
      end


! { dg-do compile }
!
! PR fortran/48800
!
! Contributed by Daniel Carrera
!
     pure function runge_kutta_step(t, r_, dr, h) result(res)
         real, intent(in) :: t, r_(:), h
         real, dimension(:), allocatable :: k1, k2, k3, k4, res
         integer :: N

         interface
             pure function dr(t, r_)  ! { dg-error "cannot have a deferred shape" }
                 real, intent(in) :: t, r_(:)
                 real :: dr(:)
             end function
         end interface

         N = size(r_)
         allocate(k1(N),k2(N),k3(N),k4(N),res(N))

         k1 = dr(t, r_)
         k2 = dr(t + h/2, r_ + k1*h/2)
         k3 = dr(t + h/2, r_ + k2*h/2)
         k4 = dr(t + h  , r_ + k3*h)

         res = r_ + (k1 + 2*k2 + 2*k3 + k4) * h/6
     end function


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: func @_QPmodulo_testr(
! CHECK-SAME: %[[arg0:.*]]: !fir.ref<f64>{{.*}}, %[[arg1:.*]]: !fir.ref<f64>{{.*}}, %[[arg2:.*]]: !fir.ref<f64>{{.*}}) {
subroutine modulo_testr(r, a, p)
    real(8) :: r, a, p
    ! CHECK-DAG: %[[a:.*]] = fir.load %[[arg1]] : !fir.ref<f64>
    ! CHECK-DAG: %[[p:.*]] = fir.load %[[arg2]] : !fir.ref<f64>
    ! CHECK-DAG: %[[rem:.*]] = arith.remf %[[a]], %[[p]] : f64
    ! CHECK-DAG: %[[zero:.*]] = arith.constant 0.000000e+00 : f64
    ! CHECK-DAG: %[[remNotZero:.*]] = arith.cmpf une, %[[rem]], %[[zero]] : f64
    ! CHECK-DAG: %[[aNeg:.*]] = arith.cmpf olt, %[[a]], %[[zero]] : f64
    ! CHECK-DAG: %[[pNeg:.*]] = arith.cmpf olt, %[[p]], %[[zero]] : f64
    ! CHECK-DAG: %[[signDifferent:.*]] = arith.xori %[[aNeg]], %[[pNeg]] : i1
    ! CHECK-DAG: %[[mustAddP:.*]] = arith.andi %[[remNotZero]], %[[signDifferent]] : i1
    ! CHECK-DAG: %[[remPlusP:.*]] = arith.addf %[[rem]], %[[p]] : f64
    ! CHECK: %[[res:.*]] = arith.select %[[mustAddP]], %[[remPlusP]], %[[rem]] : f64
    ! CHECK: fir.store %[[res]] to %[[arg0]] : !fir.ref<f64>
    r = modulo(a, p)
  end subroutine

  ! CHECK-LABEL: func @_QPmodulo_testi(
  ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<i64>{{.*}}, %[[arg1:.*]]: !fir.ref<i64>{{.*}}, %[[arg2:.*]]: !fir.ref<i64>{{.*}}) {
  subroutine modulo_testi(r, a, p)
    integer(8) :: r, a, p
    ! CHECK-DAG: %[[a:.*]] = fir.load %[[arg1]] : !fir.ref<i64>
    ! CHECK-DAG: %[[p:.*]] = fir.load %[[arg2]] : !fir.ref<i64>
    ! CHECK-DAG: %[[rem:.*]] = arith.remsi %[[a]], %[[p]] : i64
    ! CHECK-DAG: %[[argXor:.*]] = arith.xori %[[a]], %[[p]] : i64
    ! CHECK-DAG: %[[signDifferent:.*]] = arith.cmpi slt, %[[argXor]], %c0{{.*}} : i64
    ! CHECK-DAG: %[[remNotZero:.*]] = arith.cmpi ne, %[[rem]], %c0{{.*}} : i64
    ! CHECK-DAG: %[[mustAddP:.*]] = arith.andi %[[remNotZero]], %[[signDifferent]] : i1
    ! CHECK-DAG: %[[remPlusP:.*]] = arith.addi %[[rem]], %[[p]] : i64
    ! CHECK: %[[res:.*]] = arith.select %[[mustAddP]], %[[remPlusP]], %[[rem]] : i64
    ! CHECK: fir.store %[[res]] to %[[arg0]] : !fir.ref<i64>
    r = modulo(a, p)
  end subroutine


      SUBROUTINE GLATS(NLAT, EPS, F, WT)
C
C THIS ROUTINE CALCULATES THE ROOTS OF THE ORDINARY LEGENDRE
C POLYNOMIALS OF ORDER NLAT WHICH CORRESPOND TO THE LATITUDE
C POINTS USED IN A GAUSSIAN QUADRATURE PROCEDURE ON THE SPHERE.
C THE ROUTINE USES A NEWTON-RAPHSON ITERATION PROCEDURE TO
C DETERMINE THE ROOTS TO A PRECISION GIVEN BY EPS.  A ROUTINE TO
C CALCULATE THE ORDINARY LEGENDRE POLYNOMIALS, IN THIS CASE ORDLEG,
C IS REQUIRED.
C
C CALLED BY: INPUT
C CALLS: ORDLEG
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C NUMBER OF ZEROS BETWEEN POLES
      INTEGER NLAT
C CONVERGENCE LIMIT FOR THE ITERATION PROCEDURE
      REAL EPS
C
C     Output
C
C RESULTING ROOTS EXPRESSED IN LATITUDE
      REAL F(NLAT)
C CORRESPONDING GAUSSIAN WEIGHTS
      REAL WT(NLAT)
C
C------ Local Parameters -----------------------------------------------
C
      REAL PI
      PARAMETER (PI=3.141592653589793)
C
C------ Local Variables ------------------------------------------------
C
      REAL FI, FI1, FN, DOT, DN, DN1, A, B, G, GM, GP, GT,
     &     FTEMP, GTEMP
      INTEGER IR, NL, IRP, IRM, NITER
C
C----- Executable Statements -------------------------------------------
C
      IR  = NLAT
      FI  = REAL(IR)
      FI1 = FI+1.
      FN  = REAL(NLAT/2)
C
C     FIRST GUESS AT ROOTS; F REPRESENTS COSINE OF COLATITUDE
C
      DO 20 NL = 1, NLAT/2
         DOT   = REAL(NL-1)
         F(NL) = -PI*.5*(DOT+.5)/FN + PI*.5
         F(NL) =  SIN(F(NL))
   20 CONTINUE
C
      DN  = FI/SQRT(4.*FI*FI-1.)
      DN1 = FI1/SQRT(4.*FI1*FI1-1.)
      A   = DN1*FI
      B   = DN*FI1
      IRP = IR + 1
      IRM = IR - 1
C
      DO 50 NL = 1, NLAT/2
C
C        NEWTON ITERATION LOOP
C
         NITER = 0
C
   30    NITER = NITER + 1
         IF(NITER .GE. 100) THEN
            WRITE (0, 90) NL
   90       FORMAT(/,' STSWM: FATAL ERROR IN GLATS:',/,
     &        ' NO CONVERGENCE IN NEWTON ITERATION FOR ROOT',/,
     &             ' LATITUDE  NL = ', I3)
            STOP
         ENDIF
C
         CALL ORDLEG(F(NL), IR, G)
         CALL ORDLEG(F(NL), IRM, GM)
         CALL ORDLEG(F(NL), IRP, GP)
         GT    = (A*GP-B*GM)/(F(NL)*F(NL)-1.)
         FTEMP = F(NL) - G/GT
         GTEMP = F(NL) - FTEMP
         F(NL) = FTEMP
C
C        CONVERGENCE CRITERION
C
         IF (ABS(GTEMP) .GT. 2.0*EPS) GO TO 30
C
   50 CONTINUE
C
C     CALCULATE WEIGHTS AND EXPRESS ROOTS IN TERMS OF COLATITUDE
C
      DO 60 NL = 1, NLAT/2
         A      = 2.0*(1.0 - F(NL)**2)
         CALL ORDLEG(F(NL), IRM, B)
         B      = B*B*FI*FI
         WT(NL) = A*(FI - 0.5)/B
         F (NL) = PI/2.0-ACOS(F(NL))
   60 CONTINUE
C
C     FILL IN THE INFORMATION ON THE OTHER HALF OF THE SPHERE
C
      DO 70 NL = 1,NLAT/2
         F (NLAT-NL+1) = - F(NL)
         WT(NLAT-NL+1) = WT(NL)
   70 CONTINUE
C
      RETURN
      END


!----------------------------------------------------------------------*
! SUBROUTINE SASTRO                                                    *
! Authors: Daniel van Kraalingen                                       *
! Date   : 12-June-1996, Version: 1.1                                  *
! Purpose: This subroutine calculates solar constant, daily            *
!          extraterrestrial radiation, daylength and some intermediate *
!          variables required by other routines. The routine has been  *
!          written such that latitudes from pole to pole can be used.  *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning                                     units  class *
! ----   ---- -------                                     -----  ----- *
! IDOY    I4  Day of year (Jan 1st = 1)                      d      I  *
! LAT     R4  Latitude of the site                       degrees    I  *
! SOLCON  R4  Solar constant at day=IDOY                   W/m2     O  *
! ANGOT   R4  Daily extraterrestrial radiation            J/m2/d    O  *
! DAYL    R4  Astronomical daylength (base = 0 degrees)      h      O  *
! DAYLP   R4  Photoperiodic daylength (base = -4 degrees)    h      O  *
! DSINB   R4  Daily total of sine of solar height            s      O  *
! DSINBE  R4  Daily integral of sine of solar height         s      O  *
!             corrected for lower transmission at low                  *
!             elevation                                                *
! SINLD   R4  Intermediate variable for subroutine SSKYC     -      O  *
! COSLD   R4  Intermediate variable for subroutine SSKYC     -      O  *
!                                                                      *
! Fatal error checks: LAT > 90, LAT < -90                              *
! Warnings          : LAT above polar circle, LAT within polar circle  *
! Subprograms called: FATALERR                                         *
! File usage        : none                                             *
!----------------------------------------------------------------------*

      SUBROUTINE SASTRO (IDOY  , LAT   , &
                         SOLCON, ANGOT , DAYL , DAYLP, &
                         DSINB , DSINBE, SINLD, COSLD)

      IMPLICIT NONE

!     Formal parameters
      REAL LAT, SOLCON, ANGOT, DAYL, DAYLP, DSINB, DSINBE, SINLD, COSLD
      INTEGER IDOY

!     Local parameters
      REAL AOB, PI, DEGTRAD, DOY, DEC, ZZCOS, ZZSIN, ZZA
      SAVE         ! TAOLI

!     PI and conversion factor from degrees to radians
      PARAMETER (PI=3.1415927, DEGTRAD=0.017453292)

!     Error check and conversion of day number
      IF (ABS (LAT).GT.90.) CALL FATALERR &
         ('SASTRO','LAT > 90 or LAT < -90')
      DOY = REAL (IDOY)

!     Declination of the sun as a function of daynumber,
!     calculation of daylength from intermediate variables
!     SINLD, COSLD and AOB

      DEC   = -ASIN (SIN (23.45*DEGTRAD)*COS (2.*PI*(DOY+10.)/365.))
      SINLD = SIN (DEGTRAD*LAT)*SIN (DEC)
      COSLD = COS (DEGTRAD*LAT)*COS (DEC)
      AOB   = SINLD/COSLD

      IF (AOB.LT.-1.) THEN
         WRITE (*,'(2A)') ' WARNING from SASTRO: ', &
                'latitude above polar circle, daylength=0 hours'
         DAYL  = 0.
         ZZCOS = 0.
         ZZSIN = 1.
      ELSE IF (AOB.GT.1.) THEN
         WRITE (*,'(2A)') ' WARNING from SASTRO: ', &
                'latitude within polar circle, daylength=24 hours'
         DAYL  = 24.
         ZZCOS =  0.
         ZZSIN = -1.
      ELSE
         DAYL  = 12.*(1.+2.*ASIN (AOB)/PI)
         DAYLP = 12.0*(1.+2.*ASIN ((-SIN(-4.*DEGTRAD)+SINLD)/COSLD)/PI)
         ZZA   = PI*(12.+DAYL)/24.
         ZZCOS = COS (ZZA)
         ZZSIN = SIN (ZZA)
      END IF

!     Daily integral of sine of solar height (DSINB) with a
!     correction for lower atmospheric transmission at lower solar
!     elevations (DSINBE)

      DSINB  = 2.*3600.*(DAYL*0.5*SINLD-12.*COSLD*ZZCOS/PI)
      DSINBE = 2.*3600.*(DAYL*(0.5*SINLD+0.2*SINLD**2+0.1*COSLD**2)- &
               (12.*COSLD*ZZCOS+9.6*SINLD*COSLD*ZZCOS+ &
               2.4*COSLD**2*ZZCOS*ZZSIN)/PI)

!     Solar constant and daily extraterrestrial radiation
      SOLCON = 1370.*(1.+0.033*COS (2.*PI*DOY/365.))
      ANGOT  = SOLCON*DSINB

      RETURN
      END