c     3/97
c
c     a subroutine for testing slap,islap (ec,es,gc,gs)
c
c     (1) set a scalar field s as poly in x,y,z restricted to sphere
c
c     (2) compute scalar laplacian in array sclp using slap(ec,es,gc,gs)
c
c     (3) compare (2) with analytic scalar laplacian in sclpe
c
c     (4) compute the inverse  of (2) and compare with (1)
c
      program tslap
      parameter(nnlat=15,nnlon= 22, nnt = 3)
      parameter (mmdab = (nnlon+2)/2)

      parameter (lleng=15*nnlat*nnlat*nnlon,llsav=5*nnlat*nnlat*nnlon)
      dimension work(lleng),wsave(llsav)
      parameter (lldwork = nnlat*(nnlat+4))
      double precision dwork(lldwork)
      dimension a(mmdab,nnlat,nnt),b(mmdab,nnlat,nnt),s(nnlat,nnlon,nnt)
      dimension sclp(nnlat,nnlon,nnt)
      dimension sclpe(nnlat,nnlon,nnt)
      dimension ptrb(nnt),xlm(nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      mdab = mmdab
      lwork = lleng
      lsave = llsav
      nt = nnt
      call iout(nlat,4hnlat)
      call iout(nlon,4hnlon)
      call iout(nt,4h  nt)
      isym = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      ldwork = lldwork
      call gaqd(nlat,dtheta,dwts,work,lwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name(4hgaqd)
      call iout(ier,4h ier)
      call vecout(thetag,4hthtg,nlat)
c
c     set helmholtz constant zero for laplacian inversion
c
      do k=1,nt
	xlm(k) = 0.0
      end do
c
c     test all analysis and synthesis subroutines
c
      do icase=1,4
      call name(4h****)
      call name(4h****)
      call iout(icase,4hicas)
c
c
c     set scalar field as poly in x,y,z restricted to the sphere
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    d2xdt2 = -x
	    dxdp = -cost*sinp
	    d2xdp2 = -x
	    dydt = cost*sinp
	    d2ydt2 = -y
	    dydp = cost*cosp
	    d2ydp2 = -y
	    dzdt = -sint
	    d2zdt2 = -z
	    dzdp = 0.
	    d2zdp2 = 0.
	    if (k.eq.1) then
	      s(i,j,k) = x+y
	      sclpe(i,j,k) = -2.*(x+y)
	    else if (k.eq.2) then
	      s(i,j,k) = x+z
	      sclpe(i,j,k) = -2.*(x+z)
	    else if (k.eq.3) then
	      s(i,j,k) = y+z
	      sclpe(i,j,k) = -2.*(y+z)
	    end if
	  end do
	end do
      end do
c     do k=1,nt
c     call iout(k,4h   k)
c     call aout(s(1,1,k),4h   s,nlat,nlon)
c     call aout(sclpe(1,1,k),4hsclp,nlat,nlon)
c     end do

c     call aout(s,4h   s,nlat,nlon)

      if (icase.eq.1) then

      call name(4h**ec)

      call shaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hshai)
      call iout(ierror,4hierr)

      call shaec(nlat,nlon,isym,nt,s,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name(4hsha )
      call iout(ierror,4hierr)

      call shseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hshsi)
      call iout(ierror,4hierr)

      call slapec(nlat,nlon,isym,nt,sclp,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name(4hslap )
      call iout(ierror,4hierr)

      else if (icase.eq.2) then

      call name(4h**es)

      call shaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hshai)
      call iout(ierror,4hierr)

      call shaes(nlat,nlon,isym,nt,s,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name(4hsha )
      call iout(ierror,4hierr)

      call shsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hshsi)
      call iout(ierror,4hierr)

      call slapes(nlat,nlon,isym,nt,sclp,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name(4hslap)
      call iout(ierror,4hierr)

      else if (icase.eq.3) then

      call name(4h**gc)

      call shagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hshai)
      call iout(ierror,4hierr)

      call shagc(nlat,nlon,isym,nt,s,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name(4hsha )
      call iout(ierror,4hierr)

      call shsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hshsi)
      call iout(ierror,4hierr)

      call slapgc(nlat,nlon,isym,nt,sclp,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name(4hslap )
      call iout(ierror,4hierr)

      else if (icase.eq.4) then

      call name(4h**gs)

      call shagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hshai)
      call iout(ierror,4hierr)

      call shags(nlat,nlon,isym,nt,s,nlat,nlon,a,b,mdab,nlat,wsave,
     +lsave,work,lwork,ierror)
      call name(4hsha )
      call iout(ierror,4hierr)

      call shsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hshsi)
      call iout(ierror,4hierr)

      call slapgs(nlat,nlon,isym,nt,sclp,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name(4hslap)
      call iout(ierror,4hierr)
      end if
c
c     compute "error" in sclp
c
      err2 = 0.0
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    err2 = err2 + (sclpe(i,j,k)-sclp(i,j,k))**2
	  end do
	end do
c     call iout(k,4h   k)
c     call aout(sclp(1,1,k),4hsclp,nlat,nlon)
      end do
      err2 = sqrt(err2/(nt*nlat*nlon))
      call vout(err2,4herr2)
c
c     invert sclp
c
      if (icase.eq.1) then

      call shaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call shaec(nlat,nlon,isym,nt,sclp,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ierror)

      call shseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hshsi)
      call iout(ierror,4hierr)

      call islapec(nlat,nlon,isym,nt,xlm,s,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ptrb,ierror)
      call name(4hisla)
      call iout(ierror,4hierr)
      call vecout(ptrb,4hptrb,nt)

      else if (icase.eq.2) then

      call shaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call shaes(nlat,nlon,isym,nt,sclp,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ierror)

      call shsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hshsi)
      call iout(ierror,4hierr)

      call islapes(nlat,nlon,isym,nt,xlm,s,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ptrb,ierror)
      call name(4hisla)
      call iout(ierror,4hierr)
      call vecout(ptrb,4hptrb,nt)

      else if (icase.eq.3) then

      call shagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call shagc(nlat,nlon,isym,nt,sclp,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ierror)

      call shsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name(4hshsi)
      call iout(ierror,4hierr)

      call islapgc(nlat,nlon,isym,nt,xlm,s,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ptrb,ierror)
      call name(4hisla )
      call iout(ierror,4hierr)
      call vecout(ptrb,4hptrb,nt)

      else if (icase.eq.4) then

      call name(4h**gs)

      call shagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call shags(nlat,nlon,isym,nt,sclp,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ierror)

      call shsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name(4hshsi)
      call iout(ierror,4hierr)

      call islapgs(nlat,nlon,isym,nt,xlm,s,nlat,nlon,a,b,mdab,nlat,
     +wsave,lsave,work,lwork,ptrb,ierror)
      call name(4hisla)
      call iout(ierror,4hierr)
      call vecout(ptrb,4hptrb,nt)

      end if

c     call aout(s,4h   s,nlat,nlon)

c
c     compare s with original
c
      err2s = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    if (k.eq.1) then
	      se = x+y
	    else if (k.eq.2) then
	      se = x+z
	    else if (k.eq.3) then
	      se = y+z
	    end if
	    err2s = err2s+(s(i,j,k) - se)**2
	  end do
	end do
      end do
      err2s = sqrt(err2s/(nlat*nlon*nt))
      call vout(err2s,4herrs)
c
c     end of icase loop
c
      end do
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   Permission is hereby granted, free of charge, to any person obtaining a
!!!!   copy of this software and associated documentation files (the "Software"),
!!!!   to deal in the Software without restriction, including without limitation
!!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!!!!   and/or sell copies of the Software, and to permit persons to whom the
!!!!   Software is furnished to do so, subject to the following conditions:
!!!!
!!!!   The above copyright notice and this permission notice shall be
!!!!   included in all copies or substantial portions of the Software.
!!!!
!!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
!!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
!!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
!!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
!!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
!!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/master/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!>  \brief This module contains mathematical procedures.
!>  \author Amir Shahmoradi

module Matrix_mod

    implicit none

    character(*), parameter :: MODULE_NAME = "@Matrix_mod"

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the Cholesky factorization of the input positive-definite matrix.
    !>
    !> \param[in]       nd          :   The size of the input square matrix - `nd` by `nd`.
    !> \param[in,out]   PosDefMat   :   The input square matrix.
    !> \param[out]      Diagonal    :   The Diagonal elements of the Cholesky factorization.
    !>
    !> \remark
    !> If `nd = 1`, `PosDefMat` will not be touched, only `sqrt(PosDefMat)` will be output to `Diagonal`.
    !>
    !> \warning
    !> If Cholesky factorization fails, `Diagonal(1)` will be set to `-1` to indicate error on return.
    !>
    !> \details
    !> Returns in the lower triangle of `PosDefMat`, the Cholesky factorization L of \f$\texttt{PosDefMat} = L.L^T\f$.
    !> On input, the upper upper triangle of `PosDefMat` should be given, which remains intact on output.
    pure subroutine getCholeskyFactor(nd,PosDefMat,Diagonal)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getCholeskyFactor
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)    :: nd
        real(RK)   , intent(inout) :: PosDefMat(nd,nd) ! Upper triangle + diagonal is input matrix, lower is output.
        real(RK)   , intent(out)   :: Diagonal(nd)
        real(RK)                   :: summ
        integer(IK)                :: i
        do i=1,nd
            summ = PosDefMat(i,i) - dot_product(PosDefMat(i,1:i-1),PosDefMat(i,1:i-1))
            if (summ <= 0._RK) then
                Diagonal(1) = -1._RK
                return
            end if
            Diagonal(i) = sqrt(summ)
            PosDefMat(i+1:nd,i) = ( PosDefMat(i,i+1:nd) - matmul(PosDefMat(i+1:nd,1:i-1),PosDefMat(i,1:i-1)) ) / Diagonal(i)
        end do
    end subroutine getCholeskyFactor

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Solve the linear equation system of the form: \f$ \texttt{PosDefMat} \times \texttt{InputSolution} = \texttt{Intercept} \f$
    !>
    !> \param[in]       nd              :   The size of the input square matrix - `nd` by `nd`.
    !> \param[in]       PosDefMat       :   The input square matrix.
    !> \param[in]       Diagonal        :   The Diagonal elements of the Cholesky factorization.
    !> \param[in]       Intercept       :   The intercept.
    !> \param[in,out]   InputSolution   :   The input right-hand-side which becomes the solution on return.
    !>
    !> \remark
    !> `PosDefMat` and `Diagonal` are the output of subroutine [getCholeskyFactor](@ref getcholeskyfactor)
    !> (i.g., only the lower triangle of `PosDefMat` is used).
    subroutine solveLinearPosDefSystem(nd,PosDefMat,Diagonal,Intercept,InputSolution)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: solveLinearPosDefSystem
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)    :: nd
        real(RK)   , intent(in)    :: PosDefMat(nd,nd),Diagonal(nd),Intercept(nd)
        real(RK)   , intent(inout) :: InputSolution(nd)
        integer(IK)                :: i
        do i=1,nd
            InputSolution(i) = ( Intercept(i) - dot_product(PosDefMat(i,1:i-1),InputSolution(1:i-1)) ) / Diagonal(i)
        end do
        do i = nd,1,-1
            InputSolution(i) = ( InputSolution(i) - dot_product(PosDefMat(i+1:nd,i),InputSolution(i+1:nd)) ) / Diagonal(i)
        end do
    end subroutine solveLinearPosDefSystem

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the inverse matrix of a symmetric-positive-definite input matrix, which is given in the upper triangle of `MatInvMat`.
    !> On output `MatInvMat` is completely overwritten by in the inverse of the matrix. Also, return the square root of determinant
    !> of the inverse matrix.
    !>
    !> \param[in]       nd                  :   The size of the input square matrix - `nd` by `nd`.
    !> \param[in,out]   MatInvMat           :   The input square matrix. On input, the upper half must be covariance matrix.
    !>                                          On output, it is completely overwritten by the inverse matrix.
    !> \param[out]      sqrtDetInvPosDefMat :   The square root of the determinant of the inverse matrix.
    !>
    !> \warning
    !> Do not call this routine when `nd = 1`. There is no need to call this routine when `nd = 1`.
    !>
    !> \warning
    !> If the input matrix is not positive-definite, the output `sqrtDetInvPosDefMat`
    !> will be set to `-1` on return to indicate the occurrence of an error.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 1:54 AM, ICES, UT Austin
    pure subroutine getInvPosDefMatSqrtDet(nd,MatInvMat,sqrtDetInvPosDefMat)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvPosDefMatSqrtDet
#endif
        use Constants_mod, only: RK, IK ! LCOV_EXCL_LINE
        implicit none
        integer(IK), intent(in)    :: nd
        real(RK)   , intent(inout) :: MatInvMat(nd,nd)           ! input: upper half is covariance matrix, output: inverse matrix
        real(RK)   , intent(out)   :: sqrtDetInvPosDefMat        !
        real(RK)                   :: CholeskyLower(nd,nd)       ! Cholesky factor
        real(RK)                   :: Diagonal(nd)               ! diagonal terms of the inverse matrix
        real(RK)                   :: summ
        integer(IK)                :: i,j,k
        if (nd==1_IK) then
            MatInvMat = 1._RK / MatInvMat
            sqrtDetInvPosDefMat = MatInvMat(1,1)
            return
        end if
        do j=1,nd
            do i=1,j
                CholeskyLower(i,j) = MatInvMat(i,j)
            end do
        end do
        call getCholeskyFactor(nd,CholeskyLower,Diagonal)
        if (Diagonal(1)<0._RK) then
            sqrtDetInvPosDefMat = -1._RK
            return
        end if
        sqrtDetInvPosDefMat = 1._RK / product(Diagonal)
        do i = 1,nd
            CholeskyLower(i,i) = 1._RK / Diagonal(i)
            do j = i+1,nd
                summ = 0._RK
                do k = i,j-1
                    summ = summ - CholeskyLower(j,k) * CholeskyLower(k,i)
                end do
                CholeskyLower(j,i) = summ / Diagonal(j)
            end do
        end do
        do i = 1,nd
            do j = i,nd
                MatInvMat(j,i) = dot_product(CholeskyLower(j:nd,j),CholeskyLower(j:nd,i))
            end do
            MatInvMat(i,i:nd) = MatInvMat(i:nd,i)
        end do
  end subroutine getInvPosDefMatSqrtDet

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the inverse matrix of a symmetric-positive-definite matrix, whose Cholesky Lower triangle is given in the lower part
    !> of `CholeskyLower` and and its diagonal elements in `Diagonal`.
    !>
    !> \param[in]       nd              :   The size of the input square matrix - `nd` by `nd`.
    !> \param[in]       CholeskyLower   :   The Cholesky factorization of the matrix.
    !> \param[in]       Diagonal        :   The diagonal elements of the Cholesky factorization of the matrix.
    !>
    !> \return
    !> `InvMatFromCholFac` : The full inverse matrix.
    !>
    !> \warning
    !> Do not call this routine when `nd = 1`. For `nd = 1`: `InvMatFromCholFac = 1._RK / Diagonal(1)^2`.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 1:54 AM, ICES, UT Austin
    pure function getInvMatFromCholFac(nd,CholeskyLower,Diagonal) result(InvMatFromCholFac)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvMatFromCholFac
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: CholeskyLower(nd,nd),Diagonal(nd)
        real(RK)                :: InvMatFromCholFac(nd,nd)
        real(RK)                :: summ
        integer(IK)             :: i,j,k
        if (nd==1_IK) then
            InvMatFromCholFac(1,1) = 1._RK / Diagonal(1)**2
            return
        end if
        InvMatFromCholFac = 0._RK
        do j=1,nd-1
            do i=j+1,nd
                InvMatFromCholFac(i,j) = CholeskyLower(i,j)
            end do
        end do
        do i = 1,nd
            InvMatFromCholFac(i,i) = 1._RK / Diagonal(i)
            do j = i+1,nd
                summ = 0._RK
                do k = i,j-1
                    summ = summ - InvMatFromCholFac(j,k) * InvMatFromCholFac(k,i)
                end do
                InvMatFromCholFac(j,i) = summ / Diagonal(j)
            end do
        end do
        do i = 1,nd
            do j = i,nd
                InvMatFromCholFac(j,i) = dot_product(InvMatFromCholFac(j:nd,j),InvMatFromCholFac(j:nd,i))
                InvMatFromCholFac(i,j) = InvMatFromCholFac(j,i)
            end do
            !InvMatFromCholFac(i,i:nd) = InvMatFromCholFac(i:nd,i)
        end do
    end function getInvMatFromCholFac

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the inverse matrix of an input symmetric-positive-definite matrix `PosDefMat`.
    !>
    !> \param[in]   nd          :   The size of the input square matrix - `nd` by `nd`.
    !> \param[in]   PosDefMat   :   The input symmetric-positive-definite matrix.
    !>
    !> \return
    !> `InvPosDefMat` : The full inverse matrix.
    !>
    !> \warning
    !> If the input matrix is not positive definite, the function will return with `InvPosDefMat(1,1) = -1._RK` to indicate
    !> the occurrence of an error. This is done to preserve the purity of the function.
    !>
    !> \warning
    !> Do not call this routine when `nd = 1`. For `nd = 1`: `InvPosDefMat = 1._RK / InvPosDefMat`.
    !>
    !> \remark
    !> On input, only the upper half of `PosDefMat` needs to be given.
    !>
    !> \remark
    !> This routine has the same functionality as the subroutine [getInvPosDefMatSqrtDet()](@ref getinvposdefmatsqrtdet),
    !> but returns the result as a function output.
    !> According to the timing tests, `compare_InvMatRoutines_1()`, the function version appears to be 15-30% faster than
    !> the subroutine version [getInvPosDefMatSqrtDet()](@ref getinvposdefmatsqrtdet).
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 1:54 AM, ICES, UT Austin
    pure function getInvPosDefMat(nd,PosDefMat) result(InvPosDefMat)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvPosDefMat
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: PosDefMat(nd,nd)
        real(RK)                :: InvPosDefMat(nd,nd), CholeskyLower(nd,nd)
        real(RK)                :: Diagonal(nd)
        real(RK)                :: summ
        integer(IK)             :: i,j,k
       !if (nd==1) then
       !    InvPosDefMat(1,1) = 1._RK / sqrt(PosDefMat(1,1))
       !    return
       !end if
        do j=1,nd
            do i=1,j
                CholeskyLower(i,j) = PosDefMat(i,j)
            end do
        end do
        call getCholeskyFactor(nd,CholeskyLower,Diagonal)
        if (Diagonal(1)<0._RK) then
            InvPosDefMat = -1._RK   ! error occurred: getCholeskyFactor() failed in getInvPosDefMat()
            return
        end if
        do i = 1,nd
            CholeskyLower(i,i) = 1._RK / Diagonal(i)
            do j = i+1,nd
                summ = 0._RK
                do k = i,j-1
                    summ = summ - CholeskyLower(j,k) * CholeskyLower(k,i)
                end do
                CholeskyLower(j,i) = summ / Diagonal(j)
            end do
        end do
        do i = 1,nd
            do j = i,nd
                InvPosDefMat(j,i) = dot_product(CholeskyLower(j:nd,j),CholeskyLower(j:nd,i))
                InvPosDefMat(i,j) = InvPosDefMat(j,i)
            end do
        end do
  end function getInvPosDefMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the inverse matrix `InverseMatrix` of a `nd*nd` input matrix `MatrixLU`, and its determinant, using `LU` decomposition.
    !>
    !> \param[in]       nd              : The size of the square matrix and its `LU` decomposition - `nd` by `nd`.
    !> \param[inout]    MatrixLU        : The target symmetric-positive-definite matrix. On input it is the matrix, on output it is the LU decomposition.
    !> \param[out]      InverseMatrix   : The input symmetric-positive-definite matrix.
    !> \param[out]      detInvMat       : The determinant of the inverse of the symmetric-positive-definite matrix.
    !>
    !> \warning
    !> Do not call this routine when `nd = 1`. For `nd = 1`: `InverseMatrix = detInvMat = 1._RK / InverseMatrix`.
    !>
    !> \remark
    !> This routine has the same functionality as the function [getInvMat()](@ref getinvmat),
    !> but returns the result as a function output.
    !> According to the timing tests, `compare_InvMatRoutines_1()`, the function version of this code [getInvMat()](@ref getinvmat)
    !> appears to be 15-30% faster than this subroutine version.
    !>
    !> \author
    !> Amir Shahmoradi, Oct 18, 2009, 1:54 AM, MTU
    subroutine getInvMatDet(nd,MatrixLU,InverseMatrix,detInvMat)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvMatDet
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)    :: nd
        real(RK)   , intent(inout) :: MatrixLU(nd,nd) ! On input it is the matrix, on output it is the LU decomposition.
        real(RK)   , intent(out)   :: InverseMatrix(nd,nd)
        real(RK)   , intent(out)   :: detInvMat
        integer(IK)                :: i,j,Permutation(nd) ! LCOV_EXCL_LINE
        do i = 1,nd
            do j = 1,nd
                InverseMatrix(i,j) = 0._RK
            end do
            InverseMatrix(i,i) = 1._RK
        end do
        call getLU(nd,MatrixLU,Permutation,detInvMat)
        do j = 1,nd
            detInvMat = detInvMat * MatrixLU(j,j)
            call solveLinearSystem(nd,MatrixLU,Permutation,InverseMatrix(1:nd,j))
        end do
        detInvMat = 1._RK/detInvMat
  end subroutine getInvMatDet

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the inverse matrix `InverseMatrix` of a `nd*nd` input matrix `Matrix`, and its determinant, using `LU` decomposition.
    !>
    !> \param[in]       nd      :   The size of the square matrix and its `LU` decomposition - `nd` by `nd`.
    !> \param[inout]    Matrix  :   The target symmetric-positive-definite matrix.
    !>
    !> \return
    !> `InverseMatrix` : The full inverse matrix.
    !>
    !> \remark
    !> This routine has the same functionality as the subroutine [getInvMatDet()](@ref getinvmatdet),
    !> but returns the result as a function output.
    !> According to the timing tests, `compare_InvMatRoutines_1()`, this function version appears
    !> to be 15-30% faster than the subroutine equivalent [getInvMatDet()](@ref getinvmatdet).
    !>
    !> \author
    !> Amir Shahmoradi, Apr 8, 2017, 1:54 PM, MTU
    function getInvMat(nd,Matrix) result(InverseMatrix)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvMat
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: Matrix(nd,nd)
        real(RK)                :: InverseMatrix(nd,nd),LU(nd,nd)
        integer(IK)             :: i,j,Permutation(nd)
        real(RK)                :: parity
        do i = 1,nd
            do j = 1,nd
                InverseMatrix(i,j) = 0._RK
            end do
            InverseMatrix(i,i) = 1._RK
        end do
        LU = Matrix
        call getLU(nd,LU,Permutation,parity)
        do j = 1,nd
            call solveLinearSystem(nd,LU,Permutation,InverseMatrix(1:nd,j))
        end do
    end function getInvMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Solve the set of `nd` linear equations `Matrix * X = InputSolution`.
    !>
    !> \param[in]       nd              :   The size of the square matrix and its `LU` decomposition - `nd` by `nd`.
    !> \param[in]       LU              :   The LU factorization of the matrix, determined by the routine [getLU()](@ref getlu).
    !> \param[in]       Permutation     :   The permutation vector returned by [getLU()](@ref getlu).
    !> \param[inout]    InputSolution   :   The right-hand-side vector of length `nd`.
    !>                                      On output, it is completely overwritten by the solution to the system.
    !>
    !> \remark
    !> The input `nd`, `LU`, and `Permutation` parameters are not modified by this routine and,
    !> can be left in place for successive calls with different right-hand sides `InputSolution`.
    !>
    !> \remark
    !> This routine takes into account the possibility that `InputSolution` will begin with many zero elements,
    !> and is therefore efficient for matrix inversion.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 8, 2017, 1:54 PM, MTU
    subroutine solveLinearSystem(nd, LU, Permutation, InputSolution)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: solveLinearSystem
#endif
        use Constants_mod, only: RK, IK
        integer(IK), intent(in)    :: nd
        integer(IK), intent(in)    :: Permutation(nd)
        real(RK)   , intent(in)    :: LU(nd,nd)
        real(RK)   , intent(inout) :: InputSolution(nd)
        integer(IK)                :: i,ii
        real(RK)                   :: summ
        ii = 0
        do i=1,nd
            summ = InputSolution(Permutation(i))
            InputSolution(Permutation(i)) = InputSolution(i)
            if (ii /= 0) then
                summ = summ - dot_product( LU(i,ii:i-1) , InputSolution(ii:i-1) )
            else if (summ /= 0._RK) then
                ii = i
            end if
            InputSolution(i) = summ
        end do
        do i = nd,1,-1
            InputSolution(i) = ( InputSolution(i) - dot_product( LU(i,i+1:nd) , InputSolution(i+1:nd)) ) / LU(i,i)
        end do
    end subroutine solveLinearSystem

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the LU decomposition of the input matrix `MatrixLU(nd,nd)`.
    !>
    !> \param[in]       nd          :   The size of the square matrix and its `LU` decomposition - `nd` by `nd`.
    !> \param[inout]    MatrixLU    :   The input matrix. On output, it is completely overwritten by its LU decomposition.
    !> \param[out]      Permutation :   An output vector of length `nd` that records the row permutation effected by the partial pivoting.
    !> \param[out]      Parity      :   An output real as `+-1` depending on whether the number of row interchanges was even or odd, respectively.
    !>
    !> \remark
    !> This routine is used in combination with [solveLinearSystem](@ref solvelinearsystem) to solve linear equations or invert a matrix.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 1:43 PM, ICES, UT Austin
    subroutine getLU(nd,MatrixLU,Permutation,parity) ! ,errorOccurred)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getLU
#endif
        use Constants_mod, only: RK, IK
        use, intrinsic :: iso_fortran_env, only: output_unit
        integer(IK) , intent(in)    :: nd
        integer(IK) , intent(out)   :: Permutation(nd)
        real(RK)    , intent(inout) :: MatrixLU(nd,nd)
        real(RK)    , intent(out)   :: parity
        !logical     , intent(out)   :: errorOccurred
        real(RK)    , parameter     :: TINY = 1.e-20_RK
        real(RK)                    :: aamax,dum,summ,vv(nd)
        integer(IK)                 :: i,imax,j,k
        !errorOccurred = .false.
        parity = 1._RK
        do i = 1,nd
            aamax = 0._RK
            do j=1,nd
                if ( abs(MatrixLU(i,j)) > aamax ) aamax = abs( MatrixLU(i,j) )
            end do
            if (aamax == 0._RK) then
            ! LCOV_EXCL_START
                write(*,*) "Statistics@getLU() failed. Singular matrix detected."
                error stop
                !errorOccurred = .true.
                !return
            ! LCOV_EXCL_STOP
            end if
            vv(i) = 1._RK/aamax
        end do
        do j=1,nd
            do i=1,j-1
                summ = MatrixLU(i,j)
                do k=1,i-1
                    summ = summ - MatrixLU(i,k) * MatrixLU(k,j)
                end do
                MatrixLU(i,j) = summ
            end do
            aamax = 0._RK
            do i = j, nd
                summ = MatrixLU(i,j)
                do k = 1, j-1
                    summ = summ - MatrixLU(i,k) * MatrixLU(k,j)
                end do
                MatrixLU(i,j) = summ
                dum = vv(i) * abs(summ)
                if (dum >= aamax) then
                    imax = i
                    aamax = dum
                end if
            end do
            if (j /= imax)then
                do k=1,nd
                    dum = MatrixLU(imax,k)
                    MatrixLU(imax,k) = MatrixLU(j,k)
                    MatrixLU(j,k) = dum
                end do
                parity = - parity
                vv(imax) = vv(j)
            end if
            Permutation(j) = imax
            if (MatrixLU(j,j) == 0._RK) MatrixLU(j,j) = TINY
            if (j /= nd) then
                dum = 1._RK / MatrixLU(j,j)
                do i = j+1,nd
                    MatrixLU(i,j) = MatrixLU(i,j) * dum
                end do
            endif
        end do
  end subroutine getLU

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the product of two matrices.
    !> The product of two matrices is defined by `c(i,j) = a(i,1)*b(1,j) + a(i,2)*b(2,j) + ... + a(i,n)*b(n,j)`.
    !>
    !> \remark
    !> There is not reason to use this routine as the Fortran intrinsic already provides an optimized implementation of matrix
    !> multiplication via `matmul()`. It is present here only for archival and legacy reasons.
    !>
    !> \author
    !> Amir Shahmoradi, Oct 20, 2009, 10:56 PM, MTU
    subroutine multiplyMatrix(A,rowsA,colsA,B,rowsB,colsB,C)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: multiplyMatrix
#endif
        use Constants_mod, only: RK, IK
        use, intrinsic :: iso_fortran_env, only: output_unit
        !use Misc  , only: abortProgram
        implicit none
        integer(IK), intent(in)  :: rowsA, colsA, rowsB, colsB !Matrix Dimensions
        real(RK)   , intent(in)  :: A(rowsA,colsA)
        real(RK)   , intent(in)  :: B(rowsB,colsB)
        real(RK)   , intent(out) :: C(rowsA,colsB)
        integer(IK)              :: i,j,k,rowsC,colsC !Counters
        if (colsA == rowsB) then
            rowsC = rowsA
            colsC = colsB
        ! LCOV_EXCL_START
        else
            write(*,*) 'Matrix@multiplyMatrix() failed. dimensions of matrices do not match.'
            stop
            !call abortProgram( output_unit , 1 , 1 , 'Statistics@multiplyMatrix() failed. dimensions of matrices do not match.' )
        ! LCOV_EXCL_STOP
        end if
        ! Initialize product matrix to 0
        do i = 1, rowsC
            do j = 1, colsC
                C(i,j) = 0._RK
            end do
        end do
        ! Find product as per above formula
        do i = 1, rowsA
            do j = 1, colsB
                do k = 1, colsA
                    C(i,j) = C(i,j) + A(i,k)*B(k,j)
                end do
            end do
        end do
    end subroutine multiplyMatrix

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the determinant of a given `nd * nd` matrix via LU factorization.
    !>
    !> \param[in]       nd      :   The size of the square matrix - `nd` by `nd`.
    !> \param[in]       Matrix  :   The input matrix.
    !>
    !> \return
    !> `determinant` : The determinant of the matrix.
    !>
    !> \author
    !> Amir Shahmoradi, Oct 18, 2009, 4:10 PM, MTU
    function getDeterminant(nd,Matrix) result(determinant)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getDeterminant
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: Matrix(nd,nd)
        real(RK)                :: DummyMat(nd,nd)
        real(RK)                :: determinant
        integer(IK)             :: Permutation(nd)
        integer(IK)             :: j
        DummyMat = Matrix
        call getLU(nd,DummyMat,Permutation,determinant) ! This returns determinant as +-1.
        do j=1,nd
            determinant = determinant * DummyMat(j,j)
        end do
    end function getDeterminant

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> Return the square root of the determinant of a given positive-definite `nd * nd` matrix `PosDefMat` using Cholesky factorization.
    !>
    !> \param[in]       nd          :   The size of the square matrix - `nd` by `nd`.
    !> \param[in]       PosDefMat   :   The input matrix.
    !>
    !> \return
    !> `sqrtDetPosDefMat` : The square root of the determinant of the matrix.
    !>
    !> \warning
    !> If the input matrix is not positive definite, then `sqrtDetPosDefMat = -1._RK` upon return.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 4:10 PM, ICES, UT
    function getSqrtDetPosDefMat(nd,PosDefMat) result(sqrtDetPosDefMat)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getSqrtDetPosDefMat
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: PosDefMat(nd,nd)
        real(RK)                :: Diagonal(nd),DummyMat(nd,nd)
        real(RK)                :: sqrtDetPosDefMat
        integer(IK)             :: i,j
        do j=1,nd
            do i=1,j
                DummyMat(i,j) = PosDefMat(i,j)
            end do
        end do
        call getCholeskyFactor(nd,DummyMat,Diagonal)
        if (Diagonal(1)<0._RK) then
            sqrtDetPosDefMat = -1._RK
            return
        end if
        sqrtDetPosDefMat = product(Diagonal)
    end function getSqrtDetPosDefMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the natural logarithm of the square root of the determinant of a given positive-definite `nd * nd` matrix `PosDefMat`
    !> using Cholesky factorization.
    !>
    !> \param[in]       nd                  :   The size of the square matrix - `nd` by `nd`.
    !> \param[inout]    PosDefMat           :   The input matrix. On input, the upper triangle should be given, which remains intact on output.
    !> \param[out]      logSqrtDetPosDefMat :   The natural logarithm of the square root of the determinant of `PosDefMat`.
    !> \param[out]      failed              :   A logical value. If `.true.`, the determinant computation has failed.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 4:10 PM, ICES, UT
    pure subroutine getLogSqrtDetPosDefMat(nd,PosDefMat,logSqrtDetPosDefMat,failed)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getLogSqrtDetPosDefMat
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)     :: nd
        real(RK)   , intent(inout)  :: PosDefMat(nd,nd) ! Upper triangle + diagonal is input matrix, lower is output.
        real(RK)   , intent(out)    :: logSqrtDetPosDefMat
        logical    , intent(out)    :: failed
        real(RK)                    :: Diagonal(nd)
        real(RK)                    :: summ
        integer(IK)                 :: i
        failed = .false.
        do i=1,nd
            summ = PosDefMat(i,i) - dot_product(PosDefMat(i,1:i-1),PosDefMat(i,1:i-1))
            if (summ <= 0._RK) then
                failed = .true.
                return
            end if
            Diagonal(i) = sqrt(summ)
            PosDefMat(i+1:nd,i) = ( PosDefMat(i,i+1:nd) - matmul(PosDefMat(i+1:nd,1:i-1),PosDefMat(i,1:i-1)) ) / Diagonal(i)
        end do
        logSqrtDetPosDefMat = sum(log(Diagonal))
    end subroutine getLogSqrtDetPosDefMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return `.false.` value for `isPosDef`, if the Cholesky decomposition of the input matrix fails
    !> (i.e. matrix is not positive definite), otherwise return `.true.`.
    !>
    !> \param[in]       nd      :   The size of the square matrix - `nd` by `nd`.
    !> \param[inout]    Matrix  :   The input matrix.
    !>
    !> \return
    !> `isPosDef` : A logical value indicating whether the input matrix is positive-definite.
    !>
    !> \warning
    !> Do not call this routine when `nd = 1`. In such a case, if `Matrix(1,1) <= 0`, then the matrix is not positive-definite.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 4:10 PM, ICES, UT
    pure logical function isPosDef(nd,Matrix)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: isPosDef
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: Matrix(nd,nd)
        real(RK)                :: Array(nd,nd),p(nd)
        real(RK)                :: dummySum
        integer(IK)             :: i,j,k
        isPosDef = .true.
        Array = Matrix
        do i = 1,nd
            do j = i,nd
                dummySum = Array(i,j)
                do k = i-1,1,-1
                    dummySum = dummySum - Array(i,k) * Array(j,k)
                end do
                if(i==j)then
                    if(dummySum<=0._RK) then
                        isPosDef = .false.
                        return
                    end if
                    p(i) = sqrt(dummySum)
                else
                    Array(j,i)=dummySum/p(i)
                endif
            end do
        end do
    end function isPosDef

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the outer product of the two input matrices.
    !>
    !> \param[in]       Vector1 : The first input vector.
    !> \param[in]       Vector2 : The second input vector.
    !>
    !> \return
    !> `OuterProd` : A matrix of size `( size(Vector1), size(Vector2) )`.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 4:10 PM, ICES, UT
    pure function getOuterProd(Vector1,Vector2) result(OuterProd)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getOuterProd
#endif
        use Constants_mod, only: RK, IK
        real(RK), intent(in) :: Vector1(:),Vector2(:)
        real(RK)             :: OuterProd(size(Vector1), size(Vector2))
        OuterProd = spread(Vector1,dim=2,ncopies=size(Vector2)) * spread(Vector2,dim=1,ncopies=size(Vector1))
    end function getOuterProd

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return an ordered matrix of the input matrix by rearranging the columns corresponding to `ColIndx` to into the corresponding
    !> columns in `ColIndxMap`, while keeping the rest of the matrix structure intact,
    !> such that if it is positive-definite, it remains positive-definite.
    !> For example,
    !> ```
    !> 11.0    12.0    13.0    14.0    15.0
    !>  0.0    22.0    23.0    24.0    25.0
    !>  0.0     0.0    33.0    34.0    35.0
    !>  0.0     0.0     0.0    44.0    45.0
    !>  0.0 *******     0.0     0.0    55.0
    !> ```
    !> goes to the following by a `ColIndx=[4]`, `ColIndxMap=[5]`,
    !> ```
    !> 11.0    12.0    13.0    15.0    14.0
    !>  0.0    22.0    23.0    25.0    24.0
    !>  0.0     0.0    33.0    35.0    34.0
    !>  0.0     0.0     0.0    55.0    45.0
    !>  0.0     0.0     0.0     0.0    44.0
    !> ```
    !>
    !> \param[in]       rank            :   The number of columns (or rows) of the input square matrix `PosDefMatUpper`.
    !> \param[in]       PosDefMatUpper  :   The input matrix.
    !> \param[in]       lenColIndx      :   The length of the input `ColIndx` vector.
    !> \param[in]       ColIndx         :   An input array of indices indicating the order by which
    !>                                      the columns in the input matrix must be rearranged.
    !> \param[in]       ColIndxMap      :   An input array of length `lenColIndxs` that indicated the
    !>                                      new column index of the corresponding column indices in `ColIndx`.
    !>
    !> \return
    !> `SortedPosDefMatUpper` : An ordered matrix of size `( rank, rank )`.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 4:10 PM, ICES, UT
    pure function sortPosDefMat(rank,PosDefMatUpper,lenColIndx,ColIndx,ColIndxMap) result(SortedPosDefMatUpper)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: sortPosDefMat
#endif
        use Constants_mod, only: RK, IK
        integer(IK), intent(in) :: rank, lenColIndx, ColIndx(lenColIndx), ColIndxMap(lenColIndx)
        real(RK), intent(in)    :: PosDefMatUpper(rank,rank)
        real(RK)                :: SortedPosDefMatUpper(rank,rank)
        integer(IK)             :: iRow, iCol, iRowNew, iColNew, i
        loopIndx: do i = 1, lenColIndx
            do iCol = 1, rank
                iColNew = iCol
                if (iColNew==ColIndx(i)) then
                    iColNew = ColIndxMap(i)
                elseif (iColNew==ColIndxMap(i)) then
                    iColNew = ColIndx(i)
                end if
                do iRow = 1, iCol
                    iRowNew = iRow
                    if (iRowNew==ColIndx(i)) then
                        iRowNew = ColIndxMap(i)
                    elseif (iRowNew==ColIndxMap(i)) then
                        iRowNew = ColIndx(i)
                    end if
                    if (iRowNew>iColNew) then
                        SortedPosDefMatUpper(iRow,iCol) = PosDefMatUpper(iColNew,iRowNew)
                    else
                        SortedPosDefMatUpper(iRow,iCol) = PosDefMatUpper(iRowNew,iColNew)
                    end if
                end do
            end do
        end do loopIndx
    end function sortPosDefMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Symmetrize an input upper-triangular matrix by copying the upper to the lower triangle.
    !>
    !> \param[in]       nd                  :   The size of the input matrix `PosDefMatUpper`.
    !> \param[inout]    UpperSquareMatrix   :   The input upper, and output full matrix. On output, the matrix is symmetrized.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 4:10 PM, ICES, UT
    pure subroutine symmetrizeUpperSquareMatrix(nd,UpperSquareMatrix)
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK) , intent(in)    :: nd
        real(RK)    , intent(inout) :: UpperSquareMatrix(nd,nd)
        integer(IK)                 :: i, j
        do j = 1, nd
            do i = 1,j-1
                UpperSquareMatrix(j,i) = UpperSquareMatrix(i,j)
            end do
        end do
    end subroutine symmetrizeUpperSquareMatrix

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the the Regression Coefficient Matrix, whose dimension is `rankS11` by `rankS22`, as well as optionally the
    !> Schur complement of the `S22` block of rank `rankS22` of the input matrix `PosDefMat` of rank `rankPDM`.
    !> For example, if,
    !> \f{equation}{
    !> \texttt{PosDefMat} = \begin{pmatrix}
    !>                          S11 & S12 \\
    !>                          S21 & S22
    !>                      \end{pmatrix}
    !> \f}
    !> then, the Regression Coefficient Matrix given `S22` is: \f$ S12 \times S22^{-1} \f$, whose rank is `rankS11` by `rankS22`.
    !> The Schur complement of `S22` is:
    !> \f{equation}
    !>     \texttt{SchurComplement} = S11 - S12 \times S22^{-1} \times S21 ~,
    !> \f}
    !> whose rank is `rankS11` by `rankS11`.
    !>
    !> \warning
    !> On input, the full matrix PosDefMat must be given.
    !>
    !> \remark
    !> For clarity, note that `rankS11 + rankS22 = rankPDM`.
    !>
    !> \author
    !> Amir Shahmoradi, Apr 21, 2017, 4:10 PM, ICES, UT
    pure subroutine getRegresCoef(rankPDM,rankS11,rankS22,PosDefMat,RegresCoefMat,SchurComplement)
#if IFORT_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN) && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getRegresCoef
#endif
        use Constants_mod, only: RK, IK ! LCOV_EXCL_LINE
        implicit none
        integer(IK), intent(in)             :: rankPDM, rankS11, rankS22
        real(RK), intent(in)                :: PosDefMat(rankPDM,rankPDM)
        real(RK), intent(out)               :: RegresCoefMat(rankS11,rankS22)
        real(RK), intent(out), optional     :: SchurComplement(rankS11,rankS11)
        real(RK)                            :: InvS22(rankS22,rankS22), S22(rankS22,rankS22)
        integer(IK)                         :: startS22
        startS22 = rankS11 + 1
        S22 = PosDefMat(startS22:rankPDM,startS22:rankPDM)
        if (rankS22==1) then
            InvS22(1,1) = 1._RK/S22(1,1)
        else
            InvS22 = getInvPosDefMat(rankS22,S22)
        end if
        if (InvS22(1,1)<0._RK) then
            RegresCoefMat(1,1) = -1._RK
            return
        end if
        RegresCoefMat = matmul( PosDefMat(1:rankS11,startS22:rankPDM) , InvS22 )
        if (present(SchurComplement)) then
            SchurComplement = PosDefMat(1:rankS11,1:rankS11) - matmul( RegresCoefMat , PosDefMat(startS22:rankPDM,1:rankS11) )
        end if
    end subroutine getRegresCoef

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module Matrix_mod ! LCOV_EXCL_LINE


    subroutine divider(nx,ny,ncells,ncellsbest,noverlap,nnodes,nsubx,nsuby)

! Divide up nx by ny array into subfields for processing by PPMAP.

    implicit real (a-h,o-z)
    implicit integer (i,n)

    real(4) minrem
    logical nofit

    nnodes = 16			! number of nodes available simultaneously
    minrem = float(nx)*ny
    ncellsbest = ncells
    nofit = .true.

    do nc = 2*noverlap,ncells,2
	nsubxnom = (nx - noverlap)/(nc - noverlap)
	nsubynom = (ny - noverlap)/(nc - noverlap)
	nremx = nc - (nsubxnom*(nc-noverlap) + noverlap)
	nremy = nc - (nsubynom*(nc-noverlap) + noverlap)
	rem = float(nremx)*nremy
	if (rem < minrem) then
	    ncellsbest = nc
	    nremxbest = nremx
	    nremybest = nremy
	    nsubx = nsubxnom
	    nsuby = nsubynom
	    minrem = rem
	    nofit = .false.
	endif
    enddo

    if (nofit) then
	interval = ncells-noverlap
	nsubx = (nx-ncells)/interval + 1
	nsuby = (ny-ncells)/interval + 1
    endif

    print *,'Imaging array divided into',nsubx,' subfields in x, and', &
	nsuby,' in y,'
    print *,'with a subfield width of',ncellsbest,' pixels'
    print *,'Actual coverage:',0,(nsubx-1)*(ncellsbest-noverlap)+ncellsbest-1,&
        0,(nsuby-1)*(ncellsbest-noverlap)+ncellsbest-1
    print *,'Overlap =',noverlap

    end subroutine divider


  subroutine calerf(ARG,RESULT,jintval)

!------------------------------------------------------------------
!
! This routine can be freely obtained from Netlib
! at http://www.netlib.org/specfun/erf
!
! Most Netlib software packages have no restrictions on their use
! but Netlib recommends that you check with the authors to be sure.
! See http://www.netlib.org/misc/faq.html#2.3 for details.
!
!------------------------------------------------------------------
!
!   This packet evaluates erf(x) for a real argument x.
!   It contains one FUNCTION type subprogram: ERF,
!   and one SUBROUTINE type subprogram, CALERF.  The calling
!   statements for the primary entries are:
!
!                   Y = ERF(X)
!
!   The routine  CALERF  is intended for internal packet use only,
!   all computations within the packet being concentrated in this
!   routine.  The function subprograms invoke  CALERF  with the
!   statement
!
!          call CALERF(ARG,RESULT,jintval)
!
!   where the parameter usage is as follows
!
!      Function                     Parameters for CALERF
!       call              ARG                  Result          jintval
!
!     ERF(ARG)      ANY REAL ARGUMENT         ERF(ARG)          0
!
!   The main computation evaluates near-minimax approximations
!   from "Rational Chebyshev approximations for the error function"
!   by William J. Cody, Math. Comp., 1969, PP. 631-638.  This
!   transportable program uses rational functions that theoretically
!   approximate  erf(x)  and  erfc(x)  to at least 18 significant
!   decimal digits.  The accuracy achieved depends on the arithmetic
!   system, the compiler, the intrinsic functions, and proper
!   selection of the machine-dependent constants.
!
!*******************************************************************
!*******************************************************************
!
! Explanation of machine-dependent constants
!
!   XMIN   = the smallest positive floating-point number.
!   XINF   = the largest positive finite floating-point number.
!   XNEG   = the largest negative argument acceptable to ERFCX;
!            the negative of the solution to the equation
!            2*exp(x*x) = XINF.
!   XSMALL = argument below which erf(x) may be represented by
!            2*x/sqrt(pi)  and above which  x*x  will not underflow.
!            A conservative value is the largest machine number X
!            such that   1.0 + X = 1.0   to machine precision.
!   XBIG   = largest argument acceptable to ERFC;  solution to
!            the equation:  W(x) * (1-0.5/x**2) = XMIN,  where
!            W(x) = exp(-x*x)/[x*sqrt(pi)].
!   XHUGE  = argument above which  1.0 - 1/(2*x*x) = 1.0  to
!            machine precision.  A conservative value is
!            1/[2*sqrt(XSMALL)]
!   XMAX   = largest acceptable argument to ERFCX; the minimum
!            of XINF and 1/[sqrt(pi)*XMIN].
!
!   Approximate IEEE double precision values are defined below.
!
!*******************************************************************
!*******************************************************************
!
! Error returns
!
!  The program returns  ERFC = 0      for  ARG >= XBIG;
!
!  Author: William J. Cody
!          Mathematics and Computer Science Division
!          Argonne National Laboratory
!          Argonne, IL 60439, USA
!
!  Latest modification: March 19, 1990
!
!  Converted to Fortran90 and slightly modified by
!  Dimitri Komatitsch, University of Pau, France, November 2007.
!
!------------------------------------------------------------------

  implicit none

  integer I,jintval
  double precision A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEEN,SQRPI, &
       TWO,THRESHOLD,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, &
       Y,YSQ,ZERO
  dimension A(5),B(4),C(9),D(8),P(6),Q(5)

!------------------------------------------------------------------
!  Mathematical constants
!------------------------------------------------------------------
  data FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, &
       SQRPI/5.6418958354775628695D-1/,THRESHOLD/0.46875D0/, &
       SIXTEEN/16.0D0/

!------------------------------------------------------------------
!  Machine-dependent constants
!------------------------------------------------------------------
  data XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, &
       XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/

!------------------------------------------------------------------
!  Coefficients for approximation to  erf  in first interval
!------------------------------------------------------------------
  data A/3.16112374387056560D00,1.13864154151050156D02, &
         3.77485237685302021D02,3.20937758913846947D03, &
         1.85777706184603153D-1/
  data B/2.36012909523441209D01,2.44024637934444173D02, &
         1.28261652607737228D03,2.84423683343917062D03/

!------------------------------------------------------------------
!  Coefficients for approximation to  erfc  in second interval
!------------------------------------------------------------------
  data C/5.64188496988670089D-1,8.88314979438837594D0, &
         6.61191906371416295D01,2.98635138197400131D02, &
         8.81952221241769090D02,1.71204761263407058D03, &
         2.05107837782607147D03,1.23033935479799725D03, &
         2.15311535474403846D-8/
  data D/1.57449261107098347D01,1.17693950891312499D02, &
         5.37181101862009858D02,1.62138957456669019D03, &
         3.29079923573345963D03,4.36261909014324716D03, &
         3.43936767414372164D03,1.23033935480374942D03/

!------------------------------------------------------------------
!  Coefficients for approximation to  erfc  in third interval
!------------------------------------------------------------------
  data P/3.05326634961232344D-1,3.60344899949804439D-1, &
         1.25781726111229246D-1,1.60837851487422766D-2, &
         6.58749161529837803D-4,1.63153871373020978D-2/
  data Q/2.56852019228982242D00,1.87295284992346047D00, &
         5.27905102951428412D-1,6.05183413124413191D-2, &
         2.33520497626869185D-3/

  X = ARG
  Y = ABS(X)
  if (Y <= THRESHOLD) then

!------------------------------------------------------------------
!  Evaluate  erf  for  |X| <= 0.46875
!------------------------------------------------------------------
      YSQ = ZERO
      if (Y > XSMALL) YSQ = Y * Y
      XNUM = A(5)*YSQ
      XDEN = YSQ

      do I = 1, 3
         XNUM = (XNUM + A(I)) * YSQ
         XDEN = (XDEN + B(I)) * YSQ
      enddo

      RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
      if (jintval  /=  0) RESULT = ONE - RESULT
      if (jintval  ==  2) RESULT = EXP(YSQ) * RESULT
      goto 800

!------------------------------------------------------------------
!  Evaluate  erfc  for 0.46875 <= |X| <= 4.0
!------------------------------------------------------------------
   else if (Y <= FOUR) then
      XNUM = C(9)*Y
      XDEN = Y

      do I = 1, 7
         XNUM = (XNUM + C(I)) * Y
         XDEN = (XDEN + D(I)) * Y
      enddo

      RESULT = (XNUM + C(8)) / (XDEN + D(8))
      if (jintval  /=  2) then
         YSQ = AINT(Y*SIXTEEN)/SIXTEEN
         DEL = (Y-YSQ)*(Y+YSQ)
         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
      endif

!------------------------------------------------------------------
!  Evaluate  erfc  for |X| > 4.0
!------------------------------------------------------------------
   else
      RESULT = ZERO
      if (Y >= XBIG) then
         if (jintval /= 2 .or. Y >= XMAX) goto 300
         if (Y >= XHUGE) then
            RESULT = SQRPI / Y
            goto 300
         endif
      endif
      YSQ = ONE / (Y * Y)
      XNUM = P(6)*YSQ
      XDEN = YSQ

      do I = 1, 4
         XNUM = (XNUM + P(I)) * YSQ
         XDEN = (XDEN + Q(I)) * YSQ
      enddo

      RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
      RESULT = (SQRPI -  RESULT) / Y
      if (jintval /= 2) then
         YSQ = AINT(Y*SIXTEEN)/SIXTEEN
         DEL = (Y-YSQ)*(Y+YSQ)
         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
      endif
  endif

!------------------------------------------------------------------
!  Fix up for negative argument, erf, etc.
!------------------------------------------------------------------
  300 if (jintval == 0) then
      RESULT = (HALF - RESULT) + HALF
      if (X < ZERO) RESULT = -RESULT
   else if (jintval == 1) then
      if (X < ZERO) RESULT = TWO - RESULT
   else
      if (X < ZERO) then
         if (X < XNEG) then
               RESULT = XINF
            else
               YSQ = AINT(X*SIXTEEN)/SIXTEEN
               DEL = (X-YSQ)*(X+YSQ)
               Y = EXP(YSQ*YSQ) * EXP(DEL)
               RESULT = (Y+Y) - RESULT
         endif
      endif
  endif

  800 return

  end subroutine calerf

!--------------------------------------------------------------------

  double precision function netlib_specfun_erf(X)

! This subprogram computes approximate values for erf(x).
!   (see comments heading CALERF).
!
!   Author/date: William J. Cody, January 8, 1985

  implicit none

  integer jintval
  double precision X, RESULT

  jintval = 0
  call calerf(X,RESULT,jintval)
  netlib_specfun_erf = RESULT

  end function netlib_specfun_erf

!
! Subject: RE: Can one freely use and redistribute Fortran routines "specfun" from Netlib?
! From: Jack Dongarra
! Date: Wed, 21 Nov 2007 10:33:45 -0500
! To: Rusty Lusk, Dimitri Komatitsch
!
! Yes the code can freely be used and incorporated into other software. You
! should of course acknowledge the use of the software.
!
! Hope this helps,
!
! Jack Dongarra
!
! **********************************************************************
! Prof. Jack Dongarra; Innovative Computing Laboratory; EECS Department;
! 1122 Volunteer Blvd; University of Tennessee; Knoxville TN 37996-3450;
! +1-865-974-8295; http://www.cs.utk.edu/~dongarra/
!
! -----Original Message-----
! From: Rusty Lusk
! Sent: Wednesday, November 21, 2007 10:29 AM
! To: Dimitri Komatitsch
! Cc: Jack Dongarra
! Subject: Re: Can one freely use and redistribute Fortran routines "specfun"
! from Netlib?
!
! Netlib is managed at the University of Tennesee, not Argonne at this
! point. I have copied Jack Dongarra on this reply; he should be able
! to answer questions about licensing issues for code from Netlib.
!
! Regards,
! Rusty
!
! On Nov 21, 2007, at 8:36 AM, Dimitri Komatitsch wrote:
!
! >
! > Dear Sir,
! >
! > Can one freely use and redistribute Fortran routines "specfun" from
! > Netlib http://netlib2.cs.utk.edu/specfun/
! > which were written back in 1985-1990 by William J. Cody
! > from the Mathematics and Computer Science Division at Argonne?
! >
! > We use one of these routines (the error function, erf())
! > in one of our source codes, which we would like to
! > release as open source under GPL v2+, and we therefore
! > wonder if we could include that erf() routine in the
! > package in a separate file (of course saying in a comment in the
! > header that it comes from Netlib and was written by William J. Cody from
! > Argonne).
! >
! > Thank you,
! > Best regards,
! >
! > Dimitri Komatitsch.
! >
! > --
! > Dimitri Komatitsch - dimitri.komatitsch aT univ-pau.fr
! > Professor, University of Pau, Institut universitaire de France
! > and Inria Magique3D, France   http://www.univ-pau.fr/~dkomati1
! >


      SUBROUTINE mprove(a,alud,n,np,indx,b,x)
      INTEGER n,np,indx(n),NMAX
      REAL a(np,np),alud(np,np),b(n),x(n)
      PARAMETER (NMAX=500)
CU    USES lubksb
      INTEGER i,j
      REAL r(NMAX)
      DOUBLE PRECISION sdp
      do 12 i=1,n
        sdp=-b(i)
        do 11 j=1,n
          sdp=sdp+dble(a(i,j))*dble(x(j))
11      continue
        r(i)=sdp
12    continue
      call lubksb(alud,n,np,indx,r)
      do 13 i=1,n
        x(i)=x(i)-r(i)
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/mprove.for


$ Declare
   SUBROUTINE SICFactorY (LoadingType, a, c, B, W, L, tw, phi, rho, theta, Y, err)
!
! Stress intensity correction factor Y according to BS 7910:2005 M.3 Flat plates
!
! Parameters
   USE PublicPar
   IMPLICIT NONE
!
   INTEGER, INTENT(IN)             :: LoadingType  ! 1 = Membrane loading
                                                   ! 2 = Bending loading
   DOUBLE PRECISION, INTENT(IN)    :: a            ! Crack depth
   DOUBLE PRECISION, INTENT(IN)    :: c            ! Crack width
   DOUBLE PRECISION, INTENT(IN)    :: B            ! Plate thickness
   DOUBLE PRECISION, INTENT(IN)    :: W            ! Plate width
   DOUBLE PRECISION, INTENT(IN)    :: L            ! Attachment length [mm]
   DOUBLE PRECISION, INTENT(IN)    :: tw           ! WG = 2: Weld throat thickness [mm]
   DOUBLE PRECISION, INTENT(IN)	   :: phi		   ! Weld toe angle in degrees
   DOUBLE PRECISION, INTENT(IN)	   :: rho		   ! Weld toe radius in mm
   DOUBLE PRECISION, INTENT(IN)    :: theta        ! Crack angle in radians (0 => c, pi/2 => a)
   DOUBLE PRECISION, INTENT(OUT)   :: Y            ! Geometry factor
   INTEGER, INTENT(OUT)            :: err          ! out of validity for one of the input parameters
!
! Declarations
   DOUBLE PRECISION                :: fw
   DOUBLE PRECISION                :: M
   DOUBLE PRECISION                :: Mscf
   DOUBLE PRECISION                :: Mm
   DOUBLE PRECISION                :: Mmmax
   DOUBLE PRECISION                :: Mb
   DOUBLE PRECISION                :: Mk
   DOUBLE PRECISION                :: z
!
! Voorwaarden
   CALL SIMConditions (a, c, B, W, err)
   IF (err.EQ.0) THEN
!
! Calculate stress intensity magnification factor M
      CALL SIMFactorM (M)
!
! Factor Fw
      CALL Factorfw (a, c, B, W, fw)
!
! Calculate weld geometry factor Mk
      IF (WeldGeometry .EQ. 0 ) THEN
         Mk = 1.D0
      ELSE
         IF (theta .EQ. 0 ) THEN
	        z = 0.15D0
         ELSE
	        z = a
         END IF
         CALL WeldGeometryFactorMk (LoadingType, z, B, L, tw, phi, rho, Mk)
      END IF
!
! Calculate stress intensity magnification factor Mm or Mb
! Stress intensity correction factor Y = M fw Mm or Y = M fw Mb
      IF (LoadingType .EQ. 1) THEN
         CALL SIMFactorMm (a, c, B, W, theta, Mm, Mmmax)
	     Y = M * fw * Mm * Mk
      ELSE IF (LoadingType .EQ. 2) THEN
         CALL SIMFactorMb (a, c, B, W, theta, Mb)
	     Y = M * fw * Mb * Mk
      ELSE
         STOP 'Error in Subroutine SICFactorY: Unknown loadingtype'
      END IF
   END IF
!
! End subroutine
   RETURN
   END


      subroutine mapc2m_pillowdisk5(blockno,xc1,yc1,
     &      xp,yp,zp,alpha)
      implicit none

      integer blockno
      double precision xc1, yc1
      double precision xc,yc,zc,xp,yp,zp,alpha

      call mapc2m_fivepatch(blockno,xc1,yc1,xc,yc,zc,alpha)

c     # Map from [-1,1]x[-1,1] back to [0,1]x[0,1]
      xc = (xc + 1)/2.d0
      yc = (yc + 1)/2.d0

      call mapc2m_pillowdisk(blockno,xc,yc,xp,yp,zp)

      end


      subroutine ddpowe(v,p,rr,ri,ierr,iscmpl)
c!purpose
c     computes v^p with p and v double precision
c!calling sequence
c     subroutine ddpowe(v,p,rr,ri,ierr,iscmpl)
c     integer ierr
c     double precision v,p,rr,ri
c
c     rr   : result's real part
c     ri   : result's imaginary part
c     ierr : error flag
c            ierr=0 if ok
c            ierr=1 if 0**0
c            ierr=2 if  0**k with k<0
c     iscmpl :
c            iscmpl=0 if result is real
c            iscmpl=1 if result is complex
c!origin
c Serge Steer INRIA 1996
c!
c     Copyright INRIA
      integer ierr
      double precision v,p,sr,si,rr,ri,infinity
c
      ierr=0
      iscmpl=0
c
      if(dble(int(p)).eq.p) then
         call dipowe(v,int(p),rr,ierr)
         ri=0.0d0
      else
         if(v.gt.0.0d+0) then
            rr=v**p
            ri=0.0d0
         elseif(v.lt.0.0d+0) then
            call wlog(v,0.0d0,sr,si)
            sr=exp(sr*p)
            si=si*p
            rr=sr*cos(si)
            ri=sr*sin(si)
            iscmpl=1
         elseif(v.eq.0.d0) then
            if(p.lt.0.0d+0) then
               ri=0.0d0
               rr=infinity(ri)
               ierr=2
            elseif(p.eq.0.0d+0) then
c               ierr=1
               rr=1.0d0
               ri=0.0d0
            elseif(p.gt.0.d0) then
               rr=0.0d0
               ri=0.0d0
            else
c              p is nan
               rr = p
               ri = 0.d0
            endif
         else
c           v is nan
            rr = v
            ri = 0.d0
         endif
      endif
c
      return
      end


      real*8 function tripl(a,b,c)
      implicit none
      real*8 a(3),b(3),c(3)
      tripl=a(1)*b(2)*c(3)+a(2)*b(3)*c(1)+a(3)*b(1)*c(2)
     .     -a(3)*b(2)*c(1)-a(2)*b(1)*c(3)-a(1)*b(3)*c(2)
      return
      end


!##############################################################################
!# Tutorial 006c: Discretise with Q1, create a finite element matrix
!##############################################################################

module tutorial006c

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use spatialdiscretisation
  use linearsystemscalar
  use bilinearformevaluation

  use matrixio

  implicit none
  private

  public :: start_tutorial006c

contains

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

  subroutine start_tutorial006c

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialdiscretisation) :: rdiscretisation
    type(t_matrixScalar) :: rmatrix
    character(LEN=SYS_STRLEN) :: spostdir

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

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rdiscretisation
    ! which describes the discretisation.
    ! =================================

    call spdiscr_initDiscr_simple (rdiscretisation,EL_Q1_2D,rtriangulation)

    ! =================================
    ! Create a CSR-matrix for the above
    ! discretisation.
    ! =================================

    ! NOTE: Based on the above discretisation, we create a matrix
    ! in CSR format (matrix format LSYSSC_MATRIX9). We only create the
    ! "structure" at first, i.e., the index arrays that describe the
    ! positions of the nonzero entries.
    ! Later on, we allocate memory for the "content", i.e., the actual
    ! entries of the matrix.

    ! Create the matrix structure
    call bilf_createMatrixStructure (rdiscretisation,LSYSSC_MATRIX9,rmatrix)

    ! Allocate memory for the content.
    call lsyssc_allocEmptyMatrix (rmatrix)

    ! =================================
    ! Fill the matrix with 1.0.
    ! =================================

    call lsyssc_clearMatrix (rmatrix,1.0_DP)

    ! =================================
    ! Output of the matrix structure
    ! =================================
    call output_line ("Writing matrix to text files...")

    if (sys_getenv_string("POSTDIR",spostdir)) then
      ! Write the matrix to a text file, omit nonexisting entries in the matrix.
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006c_matrix.txt", "(E11.2)")

      ! Write the matrix to a MATLAB file.
      call matio_spyMatrix(&
          trim(spostdir)//"/tutorial006c_matrix.m","matrix",rmatrix,.true.)

      ! Write the matrix to a MAPLE file
      call matio_writeMatrixMaple (rmatrix, "matrix", 0, &
          trim(spostdir)//"/tutorial006c_matrix.maple", "(E11.2)")
    else
      ! Write the matrix to a text file, omit nonexisting entries in the matrix.
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006c_matrix.txt", "(E11.2)")

      ! Write the matrix to a MATLAB file.
      call matio_spyMatrix(&
          "./post/tutorial006c_matrix.m","matrix",rmatrix,.true.)

      ! Write the matrix to a MAPLE file
      call matio_writeMatrixMaple (rmatrix, "matrix", 0, &
          "./post/tutorial006c_matrix.maple", "(E11.2)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the matrix
    call lsyssc_releaseMatrix (rmatrix)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rdiscretisation)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


! **************************************************************************
! ... etkf.f90
! ... Quim Ballabrera, February 2013
! ...
! ... System Dynamics:
! ... ETKF equations
! ... The code assumes diagonal observation error covariance matrix
! ...
! **************************************************************************

subroutine etkf (iu,forget,X,Xa,xf,xam,n,rank,iobs,yobs,R,Nobs,xJ)

use sysdyn

! ...    n       :: dimension of the system
! ...    rank    :: ensemble size
! ...    Nobs    :: number of observations

implicit none

integer, intent(in)                            :: iu,n,rank,Nobs
real(kind=8), intent(in)                       :: forget
real(kind=8), dimension(n,rank), intent(inout) :: X,Xa
real(kind=8), dimension(n), intent(out)        :: xf,xam
integer, dimension(Nobs), intent(in)           :: iobs
real(kind=8), dimension(Nobs), intent(in)      :: yobs,R
real(kind=8), intent(out)                      :: xJ

logical verb
integer i,j,k,ii
real(kind=8) xlami,xsum,xJ1,xJ2
real(kind=8), dimension(:), ALLOCATABLE        :: wm,ws
real(kind=8), dimension(Nobs)                  :: Hxf
real(kind=8), dimension(Nobs)                  :: innovation
real(kind=8), dimension(:), ALLOCATABLE        :: vwork,vwork2
real(kind=8), dimension(:,:), ALLOCATABLE      :: rwork,Wa
real(kind=8), dimension(Nobs,rank)             :: HE
real(kind=8), dimension(rank,Nobs)             :: HER
real(kind=8), dimension(:,:), ALLOCATABLE      :: aLambda,U

if (rank.LE.1) call stop_error(1,'ETKF ERROR: rank <= 1')

xlami = (DBLE(rank)-1.0D0)/forget

! ... First thing: evaluate HX, Center it, and calculate anomalies:
! ...
write(iu,*) 'etkf    '
write(iu,*) 'Using Nobs    : ', Nobs
write(iu,*) 'iobs(:)       : ', iobs(:)
write(iu,*) 'Using forget  : ', forget

! ................................................................
! ................................................................
! ... Global operations: Does not matter local or global analysis

! ... H(xr+dx)
! ...
do k=1,rank
  call Hforward (X(:,k),n,iobs,Nobs,HE(:,k))
enddo

! ... H(xr) = Ensemble average of HE
! ...
call emean (HE,Nobs,rank,Hxf)

! ... H'*dx = H(xr+dx) - H(xr)
! ...
do i=1,Nobs
  HE(i,:) = HE(i,:) - Hxf(i)
enddo

! ... Innovation vector:
! ...
innovation(:) = yobs(:) - Hxf(:)

! ... Second thing: Evaluate xf, and the ensemble anomalies:
! ...
call emean (X,n,rank,xf)

do i=1,n
  X(i,:) = X(i,:) - xf(i)
enddo

! ... End Global operations
! ................................................................
! ................................................................

! ... Third thing: Evaluate HER = (HE)^T R^{-1}
! ...
do j=1,Nobs
  HER(:,j) = HE(j,:)/R(j)
enddo

! ... Fourth thing: Evaluate W = HER*HE
! ... and its eigenvalue factorization:
! ...
allocate (rwork(rank,rank))
rwork = MATMUL(HER,HE)
do i=1,rank
  rwork(i,i) = xlami + rwork(i,i)
enddo

allocate (U(rank,rank))
allocate (wm(rank))
allocate (ws(rank))
verb = .true.
call eigencov (rank,rwork,U,wm,ii,verb)
if (ii.LT.rank) call stop_error(1,'LOST THE rank')

! ... Root square of the inverse ...
! ...
do i=1,rank
  ws(i) = 1.0D0 / SQRT(wm(i))
enddo

! ... Fourth thing: Evaluate aLambda = [ ((rank-1)/forget)*I + HER*HE]^-1
! ... What we do is to evaluate is square root:
! ... Wa = SQRT(rank-1)*U Ws, aLambda = Wa * Wa^T
! ...
allocate (Wa(rank,rank))
allocate (aLambda(rank,rank))

do j=1,rank
  Wa(:,j) = U(:,j)*ws(j)      ! Root square of aLambda !!
enddo

do j=1,rank
do i=j,rank
  xsum = 0.0D0
  do k=1,rank
    xsum = xsum + Wa(i,k)*Wa(j,k)
  enddo
  aLambda(i,j) = xsum
  aLambda(j,i) = xsum
enddo
enddo

! ... Central analysis:
! ... Project the innovation vector on HER:
! ... wm is the amplitude of the modes of the central analysis:
! ...
allocate (vwork(rank))
vwork = MATMUL(HER,innovation)
wm    = MATMUL(aLambda,vwork)

! ... Cost function xJ:
! ... The first term does not depend on the amount of information projected
! ... onto the analysis subspace. The second term removes the part corrected
! ... by the analysis subspace !!!!!
! ...
xsum = 0.0D0
do i=1,rank
  xsum = xsum + innovation(i)**2/R(i)
enddo
xJ1 = xsum

allocate (vwork2(rank))
do i=1,rank
  xsum = 0.0D0
  do j=1,rank
    xsum = xsum + Wa(j,i)*vwork(k)
  enddo
  vwork2(i) = xsum
enddo
xJ2 = - DOT_PRODUCT(vwork2,vwork2)

xJ = xJ1 + xJ2

! ... Add the central analysis (vector) to each column of Wa (matrix):
! ...
do k=1,rank
  Wa(:,k) = SQRT(rank-1.0D0)*Wa(:,k) + wm(:)
enddo

! ... The ensemble of analysis perturbations:
! ...
Xa = MATMUL(X,Wa)

! ... The ensemble of analysis states:
! ...
do k=1,rank
  Xa(:,k) = xf(:) + Xa(:,k)
enddo

call emean (Xa,n,rank,xam)

! ... Deallocate the local working arrays
! ...
deallocate (rwork)
deallocate (vwork)
deallocate (vwork2)
deallocate (wm)
deallocate (ws)
deallocate (aLambda)
deallocate (U)
deallocate (Wa)

return
end subroutine etkf
! ...
! ========================================================================
! ...


!-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer b

      character arg*32

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,4,4,ceed_gauss_lobatto,b,&
     & err)
      call ceedbasisview(b,err)
      call ceedbasisdestroy(b,err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,4,4,ceed_gauss,b,err)
      call ceedbasisview(b,err)
      call ceedbasisdestroy(b,err)
      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


c=======================================================================
c
c     subroutine COVM
c
c     Empirical Covariance matrix and mean vector
c
c                       n
c                 1    ---
c     cov(i,j) = ---   \   [X(k,i) - rho(i)] * [X(k,j) - rho(j)]
c               (n-1)  /
c                      ---
c                      k=1
c
c                  n
c              1  ---
c     rho(j) = -  \   X(i,j) for j = 1,...,p
c              n  /
c                 ---
c                 i=1
c
c-----------------------------------------------------------------------
      SUBROUTINE covm ( n, p, X, dwork, cov, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : number of value(s) (n > 1)                      integer
c       p      : number of asset(s) (p >= 1)                     integer
c       X      : value(s) (n*p)                                   double
c
c     WORKSPACE
c       dwork  : p*n + p                                          double
c
c     OUTPUT
c       cov    : empirical covariance matrix (p*p)                double
c       info   : diagnostic argument                             integer
c
c     CALL
c       MCM    : mean of each column of a vectorized full matrix
c       EMPCOV : empirical covariance matrix
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, info
      DOUBLE PRECISION X(*), cov(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      integer pdwork, pdrho
c
c     external subroutines
      EXTERNAL MCM, empcov
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdrho = 1
c     prho: pointer ont the mean return rho, so p
      pdwork = pdrho + p
c     pdwork : pointer for relatives rents (n*p)
c
c     Total size of dwork array = p*n + p
c
c----------------------------------------------------------------------
c
c     means return(s)
      CALL MCM ( n, p, X, dwork(pdrho) )
c
c     empirical covariance matrix
      CALL empcov ( n, p, X, dwork(pdrho), dwork(pdwork), cov, info )
      RETURN
      END


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION RINTDENS (I, J)
!                                                                      *
!   The value of RINTDENS is an approximation to:                      *
!                                                                      *
!                                                                      *
!      (4pi^)-1  r^-2 |P (r)*P (r) + Q (r)*Q (r) | r -> 0              *
!                     I     J       I     J                            *
!                                                                      *
!   Call(s) to: [SMS92]:  POLINT                                       *
!                                                                      *
!   Written by Per Jonsson             Last revision: 24 Dec 1992      *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:07:11   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  11/02/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE def_C,           ONLY: cvac, pi
      USE grid_C
      USE wave_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE polint_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I, J
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: L
      REAL(DOUBLE), DIMENSION(3) :: XA, YA
      REAL(DOUBLE) :: DENS, DDENS
!-----------------------------------------------
!
      DO L = 4, 2, -1
         XA(L-1) = R(L)
         YA(L-1) = (PF(L,I)*PF(L,J) + QF(L,I)*QF(L,J))/(4.0D00*PI*R(L)*R(L))
      END DO
      CALL POLINT (XA, YA, 3, 0.0D00, DENS, DDENS)
      RINTDENS = DENS
!
      RETURN
      END FUNCTION RINTDENS


! Module that computes the variables, but also their dimension transformations

module mod_variables
  use mod_constants
  use mod_read_parameters
  implicit none

  private

  public :: compute_variables, dim_adim, dS_dt

contains

  ! Compute all the variables for a given state, i.e. a new S and/or T
  subroutine compute_variables(state_out)
    implicit none

    type(state), intent(inout) :: state_out

    real(x_precision), dimension(n_cell)   :: coeff_a, coeff_b, coeff_c
    real(x_precision), dimension(n_cell)   :: Delta
    real(x_precision), dimension(n_cell)   :: kappa_ff, epsilo
    real(x_precision), dimension(n_cell)   :: Sx
    real(x_precision), dimension(n_cell)   :: dS_over_dt, dSigma_over_dx, dT_over_dx
    real(x_precision), dimension(n_cell)   :: Sigma
    real(x_precision), dimension(0:n_cell) :: nuS ! one more dimension to store nuS(0)

    !-------------------------------------------------------------
    ! Compute trinomial coefficients for H
    coeff_a = (x_state%Omega * state_0%Omega_0)**2 * (state_out%S * state_0%S_0)
    coeff_b = - 2._x_precision * cst_rad * (state_out%T * state_0%T_0)**4 * x_state%x / (3._x_precision * state_0%H_0)
    coeff_c = - params%RTM * state_out%T * state_out%S * state_0%S_0 / state_0%H_0**2
    Delta = coeff_b**2 - 4._x_precision * coeff_a * coeff_c

    !-------------------------------------------------------------
    ! Compute variable depending on S, H
    state_out%H    = - 0.5_x_precision * (coeff_b + sign(sqrt(Delta), coeff_b)) / coeff_a
    state_out%cs   = x_state%Omega * state_out%H
    state_out%nu   = params%alpha * state_out%cs * state_out%H
    state_out%rho  = state_out%S / (state_out%H * x_state%x)

    !-------------------------------------------------------------
    ! Compute v while taking care of limit conditions. This is not an advection equation, so use mean derivative.
    nuS(0)        = 0
    nuS(1:n_cell) = state_out%nu * state_out%S
    Sx            = state_out%S * x_state%x

    state_out%v(1:n_cell-1) = - 1._x_precision / Sx(1:n_cell-1) * (nuS(2:n_cell) - nuS(0:n_cell-2)) / (2 * params%dx)
    state_out%v(n_cell)     = - state_out%Mdot(n_cell) / Sx(n_cell)

    state_out%Mdot = - state_out%v * Sx

    ! Compute variables needed for Fz
    kappa_ff      = 6.13e22_x_precision * state_0%rho_0 * state_out%rho * &
                    (state_0%T_0 * state_out%T)**(-3.5_x_precision)

    state_out%tau = 0.5_x_precision * sqrt(params%kappa_e * kappa_ff) * (state_0%S_0 * state_out%S / x_state%x)

    epsilo        = 6.22e20_x_precision * (state_0%rho_0 * state_out%rho)**2 * sqrt(state_0%T_0 * state_out%T)

    ! Compute Fz depending on the optical thickness
    where (state_out%tau >= 1)
       state_out%Fz = (2._x_precision * c**2 * x_state%x * state_out%T**4) / (27._x_precision * &
                       sqrt(3._x_precision) * (kappa_ff + params%kappa_e) * state_out%S * state_0%S_0)
    elsewhere
       state_out%Fz = epsilo * state_out%H * state_0%temps_0 / state_0%rho_0
    end where

    ! Compute variables related to pressure
    state_out%Pgaz = state_out%rho * state_out%T
    state_out%Prad = state_out%T**4
    state_out%beta = 1._x_precision / (1._x_precision + state_0%beta_0 * state_out%Prad / state_out%Pgaz)
    state_out%Cv   = params%RTM * ((12._x_precision * (gammag - 1._x_precision) * &
                     (1._x_precision - state_out%beta)) + state_out%beta) / &
                     (state_out%beta * (gammag - 1._x_precision))

    ! Compute heating/cooling terms
    state_out%Qplus  = 3._x_precision * state_0%v_0**2 * state_out%nu * x_state%Omega**2
    state_out%Qminus = state_out%Fz * x_state%x / state_out%S

    !-----------------------
    ! Compute advecting term
    !-----------------------

    dS_over_dt = dS_dt(state_out)

    ! Compute dT/dx as the right spatial derivative
    dT_over_dx(1:n_cell-1) = (state_out%T(2:n_cell) - state_out%T(1:n_cell-1)) / params%dx
    dT_over_dx(n_cell)     = 0

    ! Compute d(S/x)/dx as the right spatial derivative
    Sigma = state_out%S / x_state%x

    dSigma_over_dx(1:n_cell-1) = (Sigma(2:n_cell) - Sigma(1:n_cell-1)) / params%dx
    dSigma_over_dx(n_cell)     = - dS_over_dt(n_cell) / state_out%v(n_cell)

    ! Compute advecting term
    state_out%Qadv = params%RTM * (4._x_precision - 3._x_precision * state_out%beta) / state_out%beta * &
                     state_out%T / state_out%S * (dS_over_dt + state_out%v * dSigma_over_dx) - &
                     state_out%Cv * state_out%v / x_state%x * dT_over_dx

  end subroutine compute_variables

  ! Transform dimensions of variables
  subroutine dim_adim(mode, state_in)
    implicit none

    integer,     intent(in)    :: mode     ! Select 0 or 1 to adimension or dimension your state
    type(state), intent(inout) :: state_in

    select case(mode)
    case(0)
      state_in%nu     = state_in%nu     / state_0%nu_0
      state_in%v      = state_in%v      / state_0%v_0
      state_in%cs     = state_in%cs     / state_0%cs_0
      state_in%S      = state_in%S      / state_0%S_0
      state_in%H      = state_in%H      / state_0%H_0
      state_in%Mdot   = state_in%Mdot   / state_0%Mdot_0
      state_in%rho    = state_in%rho    / state_0%rho_0
      state_in%T      = state_in%T      / state_0%T_0
      state_in%Fz     = state_in%Fz     / state_0%Fz_0
      state_in%Cv     = state_in%Cv     / state_0%Cv_0
      state_in%Pgaz   = state_in%Pgaz   / state_0%Pgaz_0
      state_in%Prad   = state_in%Prad   / state_0%Prad_0
      state_in%Qplus  = state_in%Qplus  / state_0%Q_0
      state_in%Qminus = state_in%Qminus / state_0%Q_0
      state_in%Qadv   = state_in%Qadv   / state_0%Q_0
    case(1)
      state_in%nu     = state_in%nu     * state_0%nu_0
      state_in%v      = state_in%v      * state_0%v_0
      state_in%cs     = state_in%cs     * state_0%cs_0
      state_in%S      = state_in%S      * state_0%S_0
      state_in%H      = state_in%H      * state_0%H_0
      state_in%Mdot   = state_in%Mdot   * state_0%Mdot_0
      state_in%rho    = state_in%rho    * state_0%rho_0
      state_in%T      = state_in%T      * state_0%T_0
      state_in%Fz     = state_in%Fz     * state_0%Fz_0
      state_in%Cv     = state_in%Cv     * state_0%Cv_0
      state_in%Pgaz   = state_in%Pgaz   * state_0%Pgaz_0
      state_in%Prad   = state_in%Prad   * state_0%Prad_0
      state_in%Qplus  = state_in%Qplus  * state_0%Q_0
      state_in%Qminus = state_in%Qminus * state_0%Q_0
      state_in%Qadv   = state_in%Qadv   * state_0%Q_0
    case default
       stop
    end select

  end subroutine dim_adim

  function dS_dt(s)
    implicit none

    type(state), intent(in) :: s

    real(x_precision), dimension(n_cell)     :: dS_dt

    real(x_precision), dimension(0:n_cell+1) :: nuS   ! Two more for boundary conditions

    ! See BAD-report for explanation of nuS(0) and nuS(n_cell+1)
    nuS(0)        = 0
    nuS(1:n_cell) = s%nu * s%S
    nuS(n_cell+1) = s%Mdot(n_cell) * params%dx + nuS(n_cell)

    dS_dt = 1._x_precision / x_state%x**2 * &
            (nuS(2:n_cell+1) - 2._x_precision * nuS(1:n_cell) + nuS(0:n_cell-1)) / &
            params%dx**2

  end function dS_dt

end module mod_variables


!-------------------------------------------------------------------
! Fast Spectral Method
!-------------------------------------------------------------------

subroutine boltzmann_fft(Q, f, kn, phi, psi, phipsi, unum, vnum, wnum, m)

    !include 'fftw3.f'
    include '/opt/intel/oneapi/mkl/latest/include/fftw/fftw3.f'

    integer, intent(in) :: unum, vnum, wnum, m
    real(kind=8), intent(inout) :: Q(unum, vnum, wnum)
    real(kind=8), intent(in) :: f(unum, vnum, wnum)
    real(kind=8), intent(in) :: kn
    real(kind=8), intent(in) :: phi(unum, vnum, wnum, m*(m-1)), psi(unum, vnum, wnum, m*(m-1))
    real(kind=8), intent(in) :: phipsi(unum, vnum, wnum)
    complex(kind=8) :: f_spec(unum, vnum, wnum), fc(unum, vnum, wnum), fc1(unum, vnum, wnum), fc2(unum, vnum, wnum), &
                       f_temp(unum, vnum, wnum), fc11(unum, vnum, wnum), fc22(unum, vnum, wnum)
    integer(kind=8) :: plan_backward, plan_backward2, plan_forward, plan_conv_f1, plan_conv_f2
    integer :: i

    ! initialize DFT
    ! forward(-1)/backward(+1) Fourier transformation
    call dfftw_plan_dft_3d(plan_backward, unum, vnum, wnum, f_spec, f_spec, FFTW_BACKWARD, FFTW_MEASURE)
    call dfftw_plan_dft_3d(plan_backward2, unum, vnum, wnum, f_temp, f_temp, FFTW_BACKWARD, FFTW_MEASURE)
    call dfftw_plan_dft_3d(plan_forward, unum, vnum, wnum, f_spec, fc, FFTW_FORWARD, FFTW_MEASURE)
    call dfftw_plan_dft_3d(plan_conv_f1, unum, vnum, wnum, fc1, fc11, FFTW_FORWARD, FFTW_MEASURE)
    call dfftw_plan_dft_3d(plan_conv_f2, unum, vnum, wnum, fc2, fc22, FFTW_FORWARD, FFTW_MEASURE)

    f_spec = cmplx(f, 0.0d0)
    call dfftw_execute_dft(plan_backward, f_spec, f_spec) ! backward
    f_spec = f_spec / (unum * vnum * wnum)

    ! shift zero-frequency component to center of spectrum
    call fftshift3d(f_spec)

    ! gain term
    f_temp = cmplx(0.0)
    do i=1,M*(M-1)
        fc1 = cmplx(f_spec * phi(:, :, :, i))
        fc2 = cmplx(f_spec * psi(:, :, :, i))
        call dfftw_execute_dft(plan_conv_f1, fc1, fc11)
        call dfftw_execute_dft(plan_conv_f2, fc2, fc22)
        !convolution
        f_temp = f_temp + fc11*fc22
    enddo

    ! loss term
    fc1 = cmplx(f_spec * phipsi)
    fc2 = f_spec
    call dfftw_execute_dft(plan_conv_f1, fc1, fc11)
    call dfftw_execute_dft(plan_conv_f2, fc2, fc22)

    ! gain-loss
    f_temp = f_temp - fc11 * fc22
    Q = 4.0d0 * PI**2 / kn / M**2 * real(f_temp)

    call dfftw_destroy_plan(plan_backward)
    call dfftw_destroy_plan(plan_backward2)
    call dfftw_destroy_plan(plan_forward)
    call dfftw_destroy_plan(plan_conv_f1)
    call dfftw_destroy_plan(plan_conv_f2)

end


! { dg-do compile }
! PR Fortran/83548
program foo

   implicit none

   logical, parameter :: t = .true., f = .false.
   logical, parameter :: a1(2) = [t, f]
   logical(kind=1), parameter :: a2(2) = [logical(kind=1) :: t,  f]
   logical(kind=4), parameter :: a3(2) = [logical(kind=4) :: t,  f]
   logical(kind=1), parameter :: a4(2) = [logical(t, 1), logical(f, 1)]
   logical(kind=4), parameter :: a5(2) = [logical(t, 4), logical(f, 4)]
   logical(kind=1) b(2)
   logical(kind=4) c(2)

   real, parameter :: x = 1, y = 2
   real, parameter :: r1(2) = [x, y]
   real(kind=4), parameter :: r2(2) = [real(kind=4) :: x,  y]
   real(kind=8), parameter :: r3(2) = [real(kind=8) :: x,  y]
   real(kind=4), parameter :: r4(2) = [real(x, 4), real(y, 4)]
   real(kind=8), parameter :: r5(2) = [real(x, 8), real(y, 8)]
   real(kind=4) p(2)
   real(kind=8) q(2)

   p = [real(kind=4) :: x,  y]
   q = [real(kind=8) :: x,  y]
   if (any(p .ne. r2)) call abort
   if (any(q .ne. r3)) call aborts
end program foo


module lfortran_intrinsic_builtin
implicit none

interface
    integer function size(x)
    integer, intent(in) :: x(:)
    end function

    integer function lbound(x, dim)
    integer, intent(in) :: x(:)
    integer, intent(in) :: dim
    end function

    integer function ubound(x, dim)
    integer, intent(in) :: x(:)
    integer, intent(in) :: dim
    end function

    integer function max(a, b)
    integer, intent(in) :: a, b
    end function

    integer function min(a, b)
    integer, intent(in) :: a, b
    end function

    logical function allocated(x)
    integer, intent(in) :: x(:)
    end function

    integer function minval(x)
    integer, intent(in) :: x(:)
    end function

    integer function maxval(x)
    integer, intent(in) :: x(:)
    end function

    integer function sum(x)
    integer, intent(in) :: x(:)
    end function

    real function tiny(x)
    integer, intent(in) :: x(:)
    end function

    real function real(x, kind)
    integer, intent(in) :: x(:)
    integer, intent(in) :: kind
    end function

    integer function int(x, kind)
    real, intent(in) :: x(:)
    integer, intent(in) :: kind
    end function

    character function char(x)
    integer, intent(in) :: x
    end function

    integer function len(x, kind)
    character(len=*), intent(in) :: x
    integer, optional :: kind
    end function

    logical function present(x)
    integer, optional, intent(in) :: x
    end function

    integer function bit_size(x)
    integer, intent(in) :: x
    end function

    integer function not(x)
    integer, intent(in) :: x
    end function

    integer function iachar(c, kind)
    character(len=1), intent(in) :: c
    integer, optional :: kind
    end function

    character(len=1) function achar(i, kind)
    integer, intent(in) :: i
    integer, optional :: kind
    end function
end interface

end module


! { dg-do run }
! Tests the fix for PR29389, in which the  statement function would not be
! recognised as PURE within a PURE procedure.

! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>

  INTEGER :: st1, i = 99, a(4), q = 6
  st1 (i) = i * i * i
  FORALL(i=1:4) a(i) = st1 (i)
  FORALL(i=1:4) a(i) = u (a(i)) - a(i)** 2
  if (any (a .ne. 0)) call abort ()
  if (i .ne. 99) call abort ()
contains
  pure integer function u (x)
    integer,intent(in) :: x
    st2 (i) = i * i
    u = st2(x)
  end function
end


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE PLTNIC(X,TYPE,FN,NE,INTER,NMIN)
      CHARACTER*(*) TYPE
      CHARACTER*1 TTYPE
      REAL FNICE(11),INTERA(11),INTER
      INTEGER NMINA(11)
      DATA FNICE/0.,1.,2.,3.,4.,5.,6.,7.,8.,9.,10./
      DATA INTERA/1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1./
      DATA NMINA/10,10,10,10,5,5,5,5,5,5,5/

      TTYPE = TYPE
      CALL CHRUP(TTYPE,TTYPE)
      IF (X.EQ.0.) THEN
         FN = 0.
         NE = 0
         RETURN

      END IF

      XTEMP = ABS(X)
      IF (X.LT.0. .AND. TTYPE.EQ.'O') THEN
         TTYPE = 'U'

      ELSE IF (X.LT.0. .AND. TTYPE.EQ.'U') THEN
         TTYPE = 'O'
      END IF

      E1 = LOG10(XTEMP)
      JE = INT(E1)
      IF (JE.LE.0. .AND. XTEMP.LT.1.) THEN
         JE = JE - 1
      END IF

      IF (JE.LT.0) THEN
         E2 = 1./10.** (-JE)

      ELSE IF (JE.EQ.0) THEN
         E2 = 1.

      ELSE IF (JE.GT.0) THEN
         E2 = 10.**JE
      END IF

      F1 = XTEMP/E2
      IF (TTYPE.EQ.'O') THEN
         DO 2910 I = 1,11
            IF (F1/1.007.LE.FNICE(I)) THEN
               GO TO 2920

            END IF

 2910    CONTINUE
 2920    CONTINUE
      END IF

      IF (TTYPE.EQ.'U') THEN
         DO 2930 I = 11,1,-1
            IF (F1*1.007.GE.FNICE(I)) THEN
               GO TO 2940

            END IF

 2930    CONTINUE
 2940    CONTINUE
      END IF

      IF (I.GT.11) THEN
         I = 11
      END IF

      IF (I.LT.1) THEN
         I = 1
      END IF

      FN = FNICE(I)
      INTER = INTERA(I)
      NMIN = NMINA(I)
      NE = JE
      IF (X.LT.0.) THEN
         FN = -FN
      END IF

      IF (FN.EQ.0.) THEN
         NE = 0
      END IF

      RETURN

      END