!##############################################################################
!# ****************************************************************************
!# <name> matrixcheck </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains a set of basic testing routines for matrices.
!#
!# The following routines can be found in this module:
!#
!# 1.) mchk_isDiagDominant
!#     -> Checks if the matrix is diagonally dominant
!#
!# 2.) mchk_isMMatrix
!#     -> Checks if the matrix satisfies sufficient conditions of an M-matrix.
!#
!# 3.) mchk_isZMatrix
!#     -> Checks if the matrix satisfies sufficient conditions of an Z-matrix.
!#
!# The following auxiliary routines can be found in this module:
!#
!# 1.) mchk_calcStrongConnComp
!#     -> Calculates the strongly connected components of a directed graph
!# </purpose>
!##############################################################################

module matrixcheck

!$ use omp_lib
  use fsystem
  use genoutput
  use linearalgebra
  use linearsystemscalar
  use stackInt
  use storage

  implicit none

  private

!<constants>

!<constantblock description="Global constants for matrix checks">

  ! Check if matrix is diagonally dominant
  integer, parameter, public :: MCHK_DIAGDOMINANT             = 0

  ! Check if matrix is strictly diagonally dominant
  integer, parameter, public :: MCHK_DIAGDOMINANT_STRICT      = 1

  ! Check if matrix is irreducibly diagonally dominant
  integer, parameter, public :: MCHK_DIAGDOMINANT_IRREDUCIBLE = 2

!</constantblock>

!</constants>

  public :: mchk_isDiagDominant
  public :: mchk_isMMatrix
  public :: mchk_isZMatrix

contains

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

!<subroutine>

  subroutine mchk_isDiagDominant(rmatrix, ccheckType, dtreshold, bresult)

!<description>
    ! This subroutine checks if the matrix is (strictly/irreducibly)
    ! diagonally dominant depending on the parameter ccheckType. If
    ! the optional parameter bresult is present, then the result is
    ! returned. Otherwise, the outcome of the test is printed.
!</description>

!<input>
    ! Scalar matrix
    type(t_matrixScalar), intent(in) :: rmatrix

    ! One of the MCHK_DIAGONALDOMINANT_XXX constants
    integer, intent(in) :: ccheckType

    ! OPTIONAL: entries which are smaller than the given treshold
    ! value are not considered in the check.
    real(DP), intent(in), optional :: dtreshold
!</input>

!<output>
    ! OPTIONAL:: If present, the result of the check is returned.
    logical, intent(out), optional :: bresult
!</output>
!</subroutine>

    ! local variable
    real(DP), dimension(:), pointer :: p_Da
    real(SP), dimension(:), pointer :: p_Fa
    integer, dimension(:), pointer :: p_Kld,p_Kcol,p_Kdiagonal
    integer, dimension(:), pointer :: p_IsccIdx, p_Iscc
    integer :: nscc
    logical :: bresult1

    ! Check if matrix is square matrix
    if (rmatrix%NCOLS .ne. rmatrix%NEQ) then
      if (present(bresult)) then
        bresult = .false.
      else
        call output_line('Matrix is not square matrix!',&
            OU_CLASS_MSG,OU_MODE_STD,'mchk_isDiagDominant')
      end if
      return
    end if

    ! What matrix type are we?
    select case(rmatrix%cmatrixFormat)

    case(LSYSSC_MATRIX7)

      ! Set pointers
      call lsyssc_getbase_Kld(rmatrix, p_Kld)
      call lsyssc_getbase_Kcol(rmatrix, p_Kcol)

      ! What data type are we?
      select case(rmatrix%cdataType)

      case (ST_DOUBLE)
        call lsyssc_getbase_double(rmatrix, p_Da)
        call check_ddMat79DP(rmatrix%NEQ,&
            p_Kld, p_Kcol, p_Kld, p_Da, ccheckType, bresult1)

      case (ST_SINGLE)
        call lsyssc_getbase_single(rmatrix, p_Fa)
        call check_ddMat79SP(rmatrix%NEQ,&
            p_Kld, p_Kcol, p_Kld, p_Fa, ccheckType, bresult1)

      case default
        call output_line('Unsupported data type!',&
            OU_CLASS_ERROR,OU_MODE_STD,'mchk_isDiagDominant')
        call sys_halt()
      end select

    case(LSYSSC_MATRIX9)

      ! Set pointers
      call lsyssc_getbase_Kld(rmatrix, p_Kld)
      call lsyssc_getbase_Kcol(rmatrix, p_Kcol)
      call lsyssc_getbase_Kdiagonal(rmatrix, p_Kdiagonal)

      ! What data type are we?
      select case(rmatrix%cdataType)

      case (ST_DOUBLE)
        call lsyssc_getbase_double(rmatrix, p_Da)
        call check_ddMat79DP(rmatrix%NEQ,&
            p_Kld, p_Kcol, p_Kdiagonal, p_Da, ccheckType, bresult1)

      case (ST_SINGLE)
        call lsyssc_getbase_single(rmatrix, p_Fa)
        call check_ddMat79SP(rmatrix%NEQ,&
            p_Kld, p_Kcol, p_Kdiagonal, p_Fa, ccheckType, bresult1)

      case default
        call output_line('Unsupported data type!',&
            OU_CLASS_ERROR,OU_MODE_STD,'mchk_isDiagDominant')
        call sys_halt()
      end select

    case default
      call output_line('Unsupported matrix format!',&
          OU_CLASS_ERROR,OU_MODE_STD,'mchk_isDiagDominant')
      call sys_halt()
    end select

    ! Special check if matrix is irreducible
    if (bresult1 .and.&
        ccheckType .eq. MCHK_DIAGDOMINANT_IRREDUCIBLE) then
      call mchk_calcStrongConnComp(rmatrix, .true., nscc, dtreshold, p_IsccIdx, p_Iscc)
      bresult1 = (nscc .eq. 1)
    end if

    ! Report outcome of check?
    if (present(bresult)) then
      bresult = bresult1
    else
      select case(ccheckType)
      case (MCHK_DIAGDOMINANT)
        if (bresult1) then
          call output_line('Matrix is diagonally dominant!',&
              OU_CLASS_MSG,OU_MODE_STD,'mchk_isDiagDominant')
        else
          call output_line('Matrix is not diagonally dominant!',&
              OU_CLASS_MSG,OU_MODE_STD,'mchk_isDiagDominant')
        end if
      case (MCHK_DIAGDOMINANT_STRICT)
        if (bresult1) then
          call output_line('Matrix is strictly diagonally dominant!',&
              OU_CLASS_MSG,OU_MODE_STD,'mchk_isDiagDominant')
        else
          call output_line('Matrix is not strictly diagonally dominant!',&
              OU_CLASS_MSG,OU_MODE_STD,'mchk_isDiagDominant')
        end if
      case (MCHK_DIAGDOMINANT_IRREDUCIBLE)
        if (bresult1) then
          call output_line('Matrix is irreducibly diagonally dominant!',&
              OU_CLASS_MSG,OU_MODE_STD,'mchk_isDiagDominant')
        else
          call output_line('Matrix is not irreducibly diagonally dominant!',&
              OU_CLASS_MSG,OU_MODE_STD,'mchk_isDiagDominant')
        end if
      end select
    end if

  contains

    !***************************************************************************
    ! Diagonal dominance check for double-valued matrix stored in format 7/9

    pure subroutine check_ddMat79DP(NEQ, Kld, Kcol, Kdiagonal, Da,&
                                    ccheckType, bresult)

      real(DP), dimension(:), intent(in) :: Da
      integer, dimension(:), intent(in) :: Kld, Kcol, Kdiagonal
      integer, intent(in) :: NEQ, ccheckType
      logical, intent(out) :: bresult

      ! local variables
      real(DP) :: dtmp,ddiag
      integer :: ieq,ia
      logical :: ballDiagDominance,ballStrictDiagDominance
      logical :: banyDiagDominance,banyStrictDiagDominance

      ! Initialisation
      ballDiagDominance = .true.
      banyDiagDominance = .false.
      ballStrictDiagDominance = .true.
      banyStrictDiagDominance = .false.

      !$omp parallel do default(shared) private(dtmp,ddiag,ia)&
      !$omp reduction(.and. : ballDiagDominance,ballStrictDiagDominance)&
      !$omp reduction(.or.  : banyDiagDominance,banyStrictDiagDominance)
      do ieq = 1,NEQ

        ! Compute absolute row sum
        dtmp = 0.0_DP
        do ia = Kld(ieq), Kld(ieq+1)-1
          dtmp = dtmp + abs(Da(ia))
        end do

        ! Compute absolute value of diagonal coefficient
        ddiag = 2.0_DP * abs(Da(Kdiagonal(ieq)))

        ! Check for diagonal dominance
        ballDiagDominance =  ballDiagDominance .and. (ddiag .ge. dtmp)
        banyDiagDominance =  banyDiagDominance .or.  (ddiag .ge. dtmp)

        ! Check for strict diagonal dominance
        ballStrictDiagDominance =  ballStrictDiagDominance .and. (ddiag .gt. dtmp)
        banyStrictDiagDominance =  banyStrictDiagDominance .or.  (ddiag .gt. dtmp)
      end do
      !$omp end parallel do

      ! What check should be applied?
      select case(ccheckType)
      case (MCHK_DIAGDOMINANT)
        bresult = ballDiagDominance
      case (MCHK_DIAGDOMINANT_STRICT)
        bresult = ballStrictDiagDominance
      case (MCHK_DIAGDOMINANT_IRREDUCIBLE)
        bresult = ballDiagDominance .and. banyStrictDiagDominance
      end select
    end subroutine check_ddMat79DP

    !***************************************************************************
    ! Diagonal dominance check for single-valued matrix stored in format 7/9

    pure subroutine check_ddMat79SP(NEQ, Kld, Kcol, Kdiagonal, Fa,&
                                    ccheckType, bresult)

      real(SP), dimension(:), intent(in) :: Fa
      integer, dimension(:), intent(in) :: Kld, Kcol, Kdiagonal
      integer, intent(in) :: NEQ, ccheckType
      logical, intent(out) :: bresult

      ! local variables
      real(SP) :: ftmp,fdiag
      integer :: ieq,ia
      logical :: ballDiagDominance,ballStrictDiagDominance
      logical :: banyDiagDominance,banyStrictDiagDominance

      ! Initialisation
      ballDiagDominance = .true.
      banyDiagDominance = .false.
      ballStrictDiagDominance = .true.
      banyStrictDiagDominance = .false.

      !$omp parallel do default(shared) private(ftmp,fdiag,ia)&
      !$omp reduction(.and. : ballDiagDominance,ballStrictDiagDominance)&
      !$omp reduction(.or.  : banyDiagDominance,banyStrictDiagDominance)
      do ieq = 1,NEQ

        ! Compute absolute row sum
        ftmp = 0.0_SP
        do ia = Kld(ieq), Kld(ieq+1)-1
          ftmp = ftmp + abs(Fa(ia))
        end do

        ! Compute absolute value of diagonal coefficient
        fdiag = 2.0_SP * abs(Fa(Kdiagonal(ieq)))

        ! Check for diagonal dominance
        ballDiagDominance =  ballDiagDominance .and. (fdiag .ge. ftmp)
        banyDiagDominance =  banyDiagDominance .or.  (fdiag .ge. ftmp)

        ! Check for strict diagonal dominance
        ballStrictDiagDominance =  ballStrictDiagDominance .and. (fdiag .gt. ftmp)
        banyStrictDiagDominance =  banyStrictDiagDominance .or.  (fdiag .gt. ftmp)
      end do
      !$omp end parallel do

      ! What check should be applied?
      select case(ccheckType)
      case (MCHK_DIAGDOMINANT)
        bresult = ballDiagDominance
      case (MCHK_DIAGDOMINANT_STRICT)
        bresult = ballStrictDiagDominance
      case (MCHK_DIAGDOMINANT_IRREDUCIBLE)
        bresult = ballDiagDominance .and. banyStrictDiagDominance
      end select
    end subroutine check_ddMat79SP

  end subroutine mchk_isDiagDominant

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

!<subroutine>

  subroutine mchk_isMMatrix(rmatrix, dtreshold, bresult)

!<description>
    ! This subroutine checks if the matrix satisfies the sufficient
    ! conditions of an M-matrix, that is, all diagonal entries are
    ! strictly positive, all off-diagonal entries are non-positive and
    ! the matrix is irreducibly diagonally dominant.
!</description>

!<input>
    ! Scalar matrix
    type(t_matrixScalar), intent(in) :: rmatrix

    ! OPTIONAL: entries which are smaller than the given treshold
    ! value are not considered in the check.
    real(DP), intent(in), optional :: dtreshold
!</input>

!<output>
    ! OPTIONAL:: If present, the result of the check is returned.
    logical, intent(out), optional :: bresult
!</output>
!</subroutine>

    ! local variable
    type(t_matrixScalar) :: rmatrixDense
    real(DP), dimension(:), pointer :: p_Da
    real(SP), dimension(:), pointer :: p_Fa
    integer, dimension(:), pointer :: p_Kld,p_Kcol,p_Kdiagonal
    integer, dimension(:), allocatable :: Iperm
    real(DP) :: dtrhold
    logical :: bresult1

    dtrhold = 0.0_DP
    if (present(dtreshold)) dtrhold = dtreshold

    ! --------------------------------------------------------------------------
    ! Sufficient conditions for square matrices to be M-matrix are as follows:
    !
    ! #1: A is Z-matrix (a_{ij} <= 0 for all j/=i) and
    !     A is strictly diagonally dominant and a_{ii} > 0 for all i
    !
    ! #2: A is Z-matrix (a_{ij} <= 0 for all j/=i) and
    !     A is irreducibly diagonally dominant and a_{ii} > 0 for all i
    !
    ! #3: A is Z-matrix (a_{ij} <= 0 for all j/=i) and
    !     all leading principal minors are positive
    ! --------------------------------------------------------------------------

    ! Check if matrix is square matrix
    bresult1 = rmatrix%NEQ .eq. rmatrix%NCOLS

    if (.not.bresult1) then
      if (present(bresult)) then
        bresult = bresult1
      else
        call output_line('Matrix is not an M-matrix!',&
            OU_CLASS_MSG,OU_MODE_STD,'mchk_isMMatrix')
      end if
      return
    end if

    ! Check if matrix is Z-matrix
    call mchk_isZmatrix(rmatrix, dtrhold, bresult1)

    if (.not.bresult1) then
      if (present(bresult)) then
        bresult = bresult1
      else
        call output_line('Matrix is not an M-matrix!',&
            OU_CLASS_MSG,OU_MODE_STD,'mchk_isMMatrix')
      end if
      return
    end if

    ! Check if all diagonal entries are strictly positive (cf. #1 and #2)

    ! What matrix type are we?
    select case(rmatrix%cmatrixFormat)

    case(LSYSSC_MATRIX7)

      ! Set pointers
      call lsyssc_getbase_Kld(rmatrix, p_Kld)
      call lsyssc_getbase_Kcol(rmatrix, p_Kcol)

      ! What data type are we?
      select case(rmatrix%cdataType)

      case (ST_DOUBLE)
        call lsyssc_getbase_double(rmatrix, p_Da)
        call check_signMat79DP(rmatrix%NEQ, rmatrix%dscaleFactor,&
            dtrhold, p_Kld, p_Kcol, p_Da, bresult1)

      case (ST_SINGLE)
        call lsyssc_getbase_single(rmatrix, p_Fa)
        call check_signMat79SP(rmatrix%NEQ, real(rmatrix%dscaleFactor,SP),&
            real(dtrhold,SP), p_Kld, p_Kcol, p_Fa, bresult1)

      case default
        call output_line('Unsupported data type!',&
            OU_CLASS_ERROR,OU_MODE_STD,'mchk_isMMatrix')
        call sys_halt()
      end select

    case(LSYSSC_MATRIX9)

      ! Set pointers
      call lsyssc_getbase_Kcol(rmatrix, p_Kcol)
      call lsyssc_getbase_Kdiagonal(rmatrix, p_Kdiagonal)

      ! What data type are we?
      select case(rmatrix%cdataType)

      case (ST_DOUBLE)
        call lsyssc_getbase_double(rmatrix, p_Da)
        call check_signMat79DP(rmatrix%NEQ, rmatrix%dscaleFactor,&
            dtrhold, p_Kdiagonal, p_Kcol, p_Da, bresult1)

      case (ST_SINGLE)
        call lsyssc_getbase_single(rmatrix, p_Fa)
        call check_signMat79SP(rmatrix%NEQ, real(rmatrix%dscaleFactor,SP),&
            real(dtrhold,SP), p_Kdiagonal, p_Kcol, p_Fa, bresult1)

      case default
        call output_line('Unsupported data type!',&
            OU_CLASS_ERROR,OU_MODE_STD,'mchk_isMMatrix')
        call sys_halt()
      end select

    case default
      call output_line('Unsupported matrix format!',&
          OU_CLASS_ERROR,OU_MODE_STD,'mchk_isMMatrix')
      call sys_halt()
    end select

    ! If all diagonal entries are strictky positive then it suffices
    ! to check if matrix A is strictly or irreducibly diagonally
    ! dominant to detect that matrix A is(!) an M-matrix. If this
    ! check fails this does not mean that A is not an M-matrix.

    if (bresult1) then
      ! Check if matrix is strictly diagonally dominant (cf. #1)
      call mchk_isDiagDominant(rmatrix,&
          MCHK_DIAGDOMINANT_STRICT, dtreshold, bresult1)

      if (bresult1) then
        ! Report outcome of check?
        if (present(bresult)) then
          bresult = bresult1
        else
          call output_line('Matrix is an M-matrix!',&
              OU_CLASS_MSG,OU_MODE_STD,'mchk_isMMatrix')
        end if
        return
      end if

      ! Check if matrix is irreducibly diagonally dominant (cf. #2)
      call mchk_isDiagDominant(rmatrix,&
          MCHK_DIAGDOMINANT_IRREDUCIBLE, dtreshold, bresult1)

      if (bresult1) then
        ! Report outcome of check?
        if (present(bresult)) then
          bresult = bresult1
        else
          call output_line('Matrix is an M-matrix!',&
              OU_CLASS_MSG,OU_MODE_STD,'mchk_isMMatrix')
        end if
        return
      end if
    end if

    ! If we end up here, then matrix A does not satisfy the sufficient
    ! condition of an M-matrix but nontheless A can be an M-matrix.
    call output_line('Check did not return a definite answer. Thus, '//&
        'we permform an extensive check (time consuming)!',&
        OU_CLASS_MSG,OU_MODE_STD,'mchk_isMMatrix')

    ! Duplicate matrix and convert it to full matrix
    call lsyssc_duplicateMatrix(rmatrix, rmatrixDense,&
        LSYSSC_DUP_SHARE, LSYSSC_DUP_SHARE)
    call lsyssc_convertMatrix(rmatrixDense, LSYSSC_MATRIX1, .true.)

    ! Allocate memory for permutation vector
    allocate(Iperm(rmatrixDense%NEQ))

    select case(rmatrixDense%cdataType)
    case(ST_DOUBLE)
      call lsyssc_getbase_double(rmatrixDense, p_Da)
      bresult1 = check_InverseMat1DP(rmatrix%NEQ, rmatrix%NCOLS,&
          p_Da, Iperm, dtrhold)

    case(ST_SINGLE)
      call lsyssc_getbase_single(rmatrixDense, p_Fa)
      bresult1 = check_InverseMat1SP(rmatrix%NEQ, rmatrix%NCOLS,&
          p_Fa, Iperm, real(dtrhold,SP))

    case default
      call output_line('Unsupported data type!',&
          OU_CLASS_ERROR,OU_MODE_STD,'mchk_isMMatrix')
      call sys_halt()
    end select

    ! Release temporal memory
    call lsyssc_releaseMatrix(rmatrixDense)

    ! Deallocate temporal memory
    deallocate(Iperm)

    ! Report outcome of check?
    if (present(bresult)) then
      bresult = bresult1
    else
      if (bresult1) then
        call output_line('Matrix is an M-matrix!',&
            OU_CLASS_MSG,OU_MODE_STD,'mchk_isMMatrix')
      else
        call output_line('Matrix is not an M-matrix!',&
            OU_CLASS_MSG,OU_MODE_STD,'mchk_isMMatrix')
      end if
    end if

  contains

    ! Here, the real working routines start

    !***************************************************************************
    ! Sign check for double-valued matrix stored in format 7/9

    pure subroutine check_signMat79DP(NEQ, dscale, dtreshold, Kdiagonal,&
                                      Kcol, Da, bresult)

      integer, intent(in) :: NEQ
      real(DP), intent(in) :: dscale,dtreshold
      real(DP), dimension(:), intent(in) :: Da
      integer, dimension(:), intent(in) :: Kdiagonal, Kcol
      logical, intent(out) :: bresult

      ! local variables
      integer :: ieq

      ! Initialisation
      bresult = .true.

      if (dscale .eq. 1.0_DP) then
        !$omp parallel do default(shared) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if diagonal entry is strictly positive
          if (abs(Da(Kdiagonal(ieq))) .le. dtreshold) cycle
          bresult = (bresult .and. Da(Kdiagonal(ieq)) .gt. 0.0_DP)
        end do
        !$omp end parallel do
      else
        !$omp parallel do default(shared) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if diagonal entry is strictly positive
          if (abs(dscale*Da(Kdiagonal(ieq))) .le. dtreshold) cycle
          bresult = (bresult .and. dscale*Da(Kdiagonal(ieq)) .gt. 0.0_DP)
        end do
        !$omp end parallel do
      end if

    end subroutine check_signMat79DP

    !***************************************************************************
    ! Sign check for single-valued matrix stored in format 7/9

    pure subroutine check_signMat79SP(NEQ, fscale, ftreshold, Kdiagonal,&
                                      Kcol, Fa, bresult)

      integer, intent(in) :: NEQ
      real(SP), intent(in) :: fscale,ftreshold
      real(SP), dimension(:), intent(in) :: Fa
      integer, dimension(:), intent(in) :: Kdiagonal, Kcol
      logical, intent(out) :: bresult

      ! local variables
      integer :: ieq

      ! Initialisation
      bresult = .true.

      if (fscale .eq. 1.0_SP) then
        !$omp parallel do default(shared) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if diagonal entry is strictly positive
          if (abs(Fa(Kdiagonal(ieq))) .le. ftreshold) cycle
          bresult = (bresult .and. Fa(Kdiagonal(ieq)) .gt. 0.0_SP)
        end do
        !$omp end parallel do
      else
        !$omp parallel do default(shared) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if diagonal entry is strictly positive
          if (abs(fscale*Fa(Kdiagonal(ieq))) .le. ftreshold) cycle
          bresult = (bresult .and. fscale*Fa(Kdiagonal(ieq)) .gt. 0.0_SP)
        end do
        !$omp end parallel do
      end if

    end subroutine check_signMat79SP

    !***************************************************************************
    ! Compute LU-factorisation of double-valued dense matrix and check
    ! if inverse matrix exists and all of its entries are non-negative

    function check_InverseMat1DP(NEQ, NCOLS, DA, Iperm, dtreshold)&
        result(bresult)

      integer, intent(in) :: NEQ,NCOLS
      real(DP), intent(in) :: dtreshold

      real(DP), dimension(NEQ,NCOLS), intent(inout) :: Da
      integer, dimension(:), intent(inout) :: Iperm

      logical :: bresult

      ! local variables
      real(DP), dimension(:), allocatable :: Db,Dx
      integer :: iaux,icol,ieq,ipiv,jeq,iuv
      real(DP) :: daux

      ! Initialisation
      bresult = .true.

      ! Compute the LU-decomposition of matrix using Gaussian
      ! elimination with partial pivoting

      do ieq = 1,NEQ
        Iperm(ieq) = ieq
      end do

      ! Perform Gaussian elimination
      row: do ieq = 1,NEQ

        ! Row-wise pivoting
        ipiv = ieq

        do jeq = ieq,NEQ
          if (abs(Da(Iperm(jeq),ieq)) .gt. abs(Da(Iperm(ipiv),ieq))) then
            ipiv = jeq
          end if
        end do

        ! Swap rows IPIV <-> IEQ
        if (Iperm(ipiv) .ne. Iperm(ieq)) then
          iaux        = Iperm(ieq)
          Iperm(ieq)  = Iperm(ipiv)
          Iperm(ipiv) = iaux
        end if

        ! Get pivot element
        daux = Da(Iperm(ieq),ieq)

        ! Check for zero determinant
        if (abs(daux) .le. SYS_EPSREAL_DP) then
          ! Matrix is not invertible
          bresult = .false.
          return
        end if

        ! Elimination step
        col: do jeq = ieq+1,NEQ
          Da(Iperm(jeq),ieq) = Da(Iperm(jeq),ieq) / daux
          do icol = ieq+1,NCOLS
            Da(Iperm(jeq),icol) = Da(Iperm(jeq),icol)&
                                - Da(Iperm(ieq),icol)*Da(Iperm(jeq),ieq)
          end do
        end do col
      end do row

      ! Allocate temporal memory
      allocate(Db(NEQ),Dx(NCOLS))

      ! Loop over all unit vectors and compute inverse matrix
      ! column-by-column
      do iuv = 1,NEQ

        ! Initialise i-th unit vector
        Db = 0.0_DP
        Db(iuv) = 1.0_DP

        ! Forward substitution
        do ieq = 1,NEQ-1
          do jeq = ieq+1,NEQ
            Db(Iperm(jeq)) = Db(Iperm(jeq))-Db(Iperm(ieq))*Da(Iperm(jeq),ieq)
          end do
        end do

        ! Initialise solution
        Dx = 0.0_DP

        ! Backward substitution
        do ieq = NEQ,1,-1
          Dx(Iperm(ieq)) = Db(Iperm(ieq))
          do jeq = ieq+1,NEQ
            Dx(Iperm(ieq)) = Dx(Iperm(ieq)) - Da(Iperm(ieq),jeq)*Dx(Iperm(jeq))
          end do
          Dx(Iperm(ieq)) = Dx(Iperm(ieq)) / Da(Iperm(ieq),ieq)

          ! Check if entry is negative
          if (Dx(Iperm(ieq)) .lt. -dtreshold) then
            bresult = .false.
            deallocate(Db,Dx)
            return
          end if
        end do
      end do

      ! Deallocate temporal memory
      deallocate(Db,Dx)

    end function check_InverseMat1DP

    !***************************************************************************
    ! Compute LU-factorisation of single-valued dense matrix and check
    ! if inverse matrix exists and all of its entries are non-negative

    function check_InverseMat1SP(NEQ, NCOLS, FA, Iperm, ftreshold)&
        result(bresult)

      integer, intent(in) :: NEQ,NCOLS
      real(SP), intent(in) :: ftreshold

      real(SP), dimension(NEQ,NCOLS), intent(inout) :: Fa
      integer, dimension(:), intent(inout) :: Iperm

      logical :: bresult

      ! local variables
      real(SP), dimension(:), allocatable :: Fb,Fx
      integer :: iaux,icol,ieq,ipiv,jeq,iuv
      real(SP) :: faux

      ! Initialisation
      bresult = .true.

      ! Compute the LU-decomposition of matrix using Gaussian
      ! elimination with partial pivoting

      do ieq = 1,NEQ
        Iperm(ieq) = ieq
      end do

      ! Perform Gaussian elimination
      row: do ieq = 1,NEQ

        ! Row-wise pivoting
        ipiv = ieq

        do jeq = ieq,NEQ
          if (abs(Fa(Iperm(jeq),ieq)) .gt. abs(Fa(Iperm(ipiv),ieq))) then
            ipiv = jeq
          end if
        end do

        ! Swap rows IPIV <-> IEQ
        if (Iperm(ipiv) .ne. Iperm(ieq)) then
          iaux        = Iperm(ieq)
          Iperm(ieq)  = Iperm(ipiv)
          Iperm(ipiv) = iaux
        end if

        ! Get pivot element
        faux = Fa(Iperm(ieq),ieq)

        ! Check for zero determinant
        if (abs(faux) .le. SYS_EPSREAL_SP) then
          ! Matrix is not invertible
          bresult = .false.
          return
        end if

        ! Elimination step
        col: do jeq = ieq+1,NEQ
          Fa(Iperm(jeq),ieq) = Fa(Iperm(jeq),ieq) / faux
          do icol = ieq+1,NCOLS
            Fa(Iperm(jeq),icol) = Fa(Iperm(jeq),icol)&
                                - Fa(Iperm(ieq),icol)*Fa(Iperm(jeq),ieq)
          end do
        end do col
      end do row

      ! Allocate temporal memory
      allocate(Fb(NEQ),Fx(NCOLS))

      ! Loop over all unit vectors and compute inverse matrix
      ! column-by-column
      do iuv = 1,NEQ

        ! Initialise i-th unit vector
        Fb = 0.0_SP
        Fb(iuv) = 1.0_SP

        ! Forward substitution
        do ieq = 1,NEQ-1
          do jeq = ieq+1,NEQ
            Fb(Iperm(jeq)) = Fb(Iperm(jeq))-Fb(Iperm(ieq))*Fa(Iperm(jeq),ieq)
          end do
        end do

        ! Initialise solution
        Fx = 0.0_SP

        ! Backward substitution
        do ieq = NEQ,1,-1
          Fx(Iperm(ieq)) = Fb(Iperm(ieq))
          do jeq = ieq+1,NEQ
            Fx(Iperm(ieq)) = Fx(Iperm(ieq)) - Fa(Iperm(ieq),jeq)*Fx(Iperm(jeq))
          end do
          Fx(Iperm(ieq)) = Fx(Iperm(ieq)) / Fa(Iperm(ieq),ieq)

          ! Check if entry is negative
          if (Fx(Iperm(ieq)) .lt. -dtreshold) then
            bresult = .false.
            deallocate(Fb,Fx)
            return
          end if
        end do
      end do

      ! Deallocate temporal memory
      deallocate(Fb,Fx)

    end function check_InverseMat1SP

  end subroutine mchk_isMMatrix

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

!<subroutine>

  subroutine mchk_isZMatrix(rmatrix, dtreshold, bresult)

!<description>
    ! This subroutine checks if the matrix is a Z-matrix.
    ! That is, all off-diagonal entries are non-positive.
    !
    ! $$ A=(a_{ij}),\quad a_{ij}\le 0\, \forall j\ne i $$
    !
    ! If the optional parameter dtreshold is present, then the above
    ! condition is relaxed as follows:
    !
    ! $$ A=(a_{ij}),\quad a_{ij}\le -|dtreshold|\, \forall j\ne i $$
    !
    ! If the optional parameter bresult is present, then the result
    ! is returned. Otherwise, the outcome of the test is printed.
!</description>

!<input>
    ! Scalar matrix
    type(t_matrixScalar), intent(in) :: rmatrix

    ! OPTIONAL: entries which are smaller than the given treshold
    ! value are not considered in the check.
    real(DP), intent(in), optional :: dtreshold
!</input>

!<output>
    ! OPTIONAL:: If present, the result of the check is returned.
    logical, intent(out), optional :: bresult
!</output>
!</subroutine>

    ! local variable
    real(DP), dimension(:), pointer :: p_Da
    real(SP), dimension(:), pointer :: p_Fa
    integer, dimension(:), pointer :: p_Kld,p_Kcol,p_Kdiagonal
    real(DP) :: dtrhold
    logical :: bresult1

    dtrhold = 0.0_DP
    if (present(dtreshold)) dtrhold = dtreshold

    ! Check if all off-diagonal entries are non-positive

    ! What matrix type are we?
    select case(rmatrix%cmatrixFormat)

    case(LSYSSC_MATRIX7)

      ! Set pointers
      call lsyssc_getbase_Kld(rmatrix, p_Kld)
      call lsyssc_getbase_Kcol(rmatrix, p_Kcol)

      ! What data type are we?
      select case(rmatrix%cdataType)

      case (ST_DOUBLE)
        call lsyssc_getbase_double(rmatrix, p_Da)
        call check_signMat7DP(rmatrix%NEQ, rmatrix%dscaleFactor,&
            dtrhold, p_Kld, p_Kcol, p_Da, bresult1)

      case (ST_SINGLE)
        call lsyssc_getbase_single(rmatrix, p_Fa)
        call check_signMat7SP(rmatrix%NEQ, real(rmatrix%dscaleFactor,SP),&
            real(dtrhold,SP), p_Kld, p_Kcol, p_Fa, bresult1)

      case default
        call output_line('Unsupported data type!',&
            OU_CLASS_ERROR,OU_MODE_STD,'mchk_isMMatrix')
        call sys_halt()
      end select

    case(LSYSSC_MATRIX9)

      ! Set pointers
      call lsyssc_getbase_Kld(rmatrix, p_Kld)
      call lsyssc_getbase_Kcol(rmatrix, p_Kcol)
      call lsyssc_getbase_Kdiagonal(rmatrix, p_Kdiagonal)

      ! What data type are we?
      select case(rmatrix%cdataType)

      case (ST_DOUBLE)
        call lsyssc_getbase_double(rmatrix, p_Da)
        call check_signMat9DP(rmatrix%NEQ, rmatrix%dscaleFactor,&
            dtrhold, p_Kld, p_Kcol, p_Kdiagonal, p_Da, bresult1)

      case (ST_SINGLE)
        call lsyssc_getbase_single(rmatrix, p_Fa)
        call check_signMat9SP(rmatrix%NEQ, real(rmatrix%dscaleFactor,SP),&
            real(dtrhold,SP),p_Kld, p_Kcol, p_Kdiagonal, p_Fa, bresult1)

      case default
        call output_line('Unsupported data type!',&
            OU_CLASS_ERROR,OU_MODE_STD,'mchk_isZMatrix')
        call sys_halt()
      end select

    case default
      call output_line('Unsupported matrix format!',&
          OU_CLASS_ERROR,OU_MODE_STD,'mchk_isZMatrix')
      call sys_halt()
    end select

    ! Report outcome of check?
    if (present(bresult)) then
      bresult = bresult1
    else
      if (bresult1) then
        call output_line('Matrix is a Z-matrix!',&
            OU_CLASS_MSG,OU_MODE_STD,'mchk_isZMatrix')
      else
        call output_line('Matrix is not a Z-matrix!',&
            OU_CLASS_MSG,OU_MODE_STD,'mchk_isZMatrix')
      end if
    end if

  contains

    ! Here, the real working routines start

    !***************************************************************************
    ! Sign check for double-valued matrix stored in format 7

    pure subroutine check_signMat7DP(NEQ, dscale, dtreshold, Kld, Kcol,&
                                     Da, bresult)

      integer, intent(in) :: NEQ
      real(DP), intent(in) :: dscale,dtreshold
      real(DP), dimension(:), intent(in) :: Da
      integer, dimension(:), intent(in) :: Kld, Kcol
      logical, intent(out) :: bresult

      ! local variables
      integer :: ieq,ia

      ! Initialisation
      bresult = .true.

      if (dscale .eq. 1.0_DP) then
        !$omp parallel do default(shared) private(ia) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if off-diagonal entries are non-positive
          do ia = Kld(ieq)+1, Kld(ieq+1)-1
            if (abs(Da(ia)) .le. dtreshold) cycle
            bresult = (bresult .and. Da(ia) .le. 0.0_DP)
          end do
        end do
        !$omp end parallel do
      else
        !$omp parallel do default(shared) private(ia) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if off-diagonal entries are non-positive
          do ia = Kld(ieq)+1, Kld(ieq+1)-1
            if (abs(dscale*Da(ia)) .le. dtreshold) cycle
            bresult = (bresult .and. dscale*Da(ia) .le. 0.0_DP)
          end do
        end do
        !$omp end parallel do
      end if

    end subroutine check_signMat7DP

    !***************************************************************************
    ! Sign check for single-valued matrix stored in format 7

    pure subroutine check_signMat7SP(NEQ, fscale, ftreshold, Kld, Kcol,&
                                     Fa, bresult)

      integer, intent(in) :: NEQ
      real(SP), intent(in) :: fscale,ftreshold
      real(SP), dimension(:), intent(in) :: Fa
      integer, dimension(:), intent(in) :: Kld, Kcol
      logical, intent(out) :: bresult

      ! local variables
      integer :: ieq,ia

      ! Initialisation
      bresult = .true.

      if (fscale .eq. 1.0_SP) then
        !$omp parallel do default(shared) private(ia) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if off-diagonal entries are non-positive
          do ia = Kld(ieq)+1, Kld(ieq+1)-1
            if (abs(Fa(ia)) .le. ftreshold) cycle
            bresult = (bresult .and. Fa(ia) .le. 0.0_SP)
          end do
        end do
        !$omp end parallel do
      else
        !$omp parallel do default(shared) private(ia) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if off-diagonal entries are non-positive
          do ia = Kld(ieq)+1, Kld(ieq+1)-1
            if (abs(fscale*Fa(ia)) .le. ftreshold) cycle
            bresult = (bresult .and. fscale*Fa(ia) .le. 0.0_SP)
          end do
        end do
        !$omp end parallel do
      end if

    end subroutine check_signMat7SP

    !***************************************************************************
    ! Sign check for double-valued matrix stored in format 9

    pure subroutine check_signMat9DP(NEQ, dscale, dtreshold, Kld, Kcol,&
                                     Kdiagonal, Da, bresult)

      integer, intent(in) :: NEQ
      real(DP), intent(in) :: dscale,dtreshold
      real(DP), dimension(:), intent(in) :: Da
      integer, dimension(:), intent(in) :: Kld, Kcol, Kdiagonal
      logical, intent(out) :: bresult

      ! local variables
      integer :: ieq,ia

      ! Initialisation
      bresult = .true.

      if (dscale .eq. 1.0_DP) then
        !$omp parallel do default(shared) private(ia) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if off-diagonal entries are non-positive
          do ia = Kld(ieq), Kdiagonal(ieq)-1
            if (abs(Da(ia)) .le. dtreshold) cycle
            bresult = (bresult .and. Da(ia) .le. 0.0_DP)
          end do
          do ia = Kdiagonal(ieq)+1, Kld(ieq+1)-1
            if (abs(Da(ia)) .le. dtreshold) cycle
            bresult = (bresult .and. Da(ia) .le. 0.0_DP)
          end do
        end do
        !$omp end parallel do
      else
        !$omp parallel do default(shared) private(ia) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if off-diagonal entries are non-positive
          do ia = Kld(ieq), Kdiagonal(ieq)-1
            if (abs(dscale*Da(ia)) .le. dtreshold) cycle
            bresult = (bresult .and. dscale*Da(ia) .le. 0.0_DP)
          end do
          do ia = Kdiagonal(ieq)+1, Kld(ieq+1)-1
            if (abs(dscale*Da(ia)) .le. dtreshold) cycle
            bresult = (bresult .and. dscale*Da(ia) .le. 0.0_DP)
          end do
        end do
        !$omp end parallel do
      end if

    end subroutine check_signMat9DP

    !***************************************************************************
    ! Sign check for single-valued matrix stored in format 9

    pure subroutine check_signMat9SP(NEQ, fscale, ftreshold, Kld, Kcol,&
                                     Kdiagonal, Fa, bresult)

      integer, intent(in) :: NEQ
      real(SP), intent(in) :: fscale,ftreshold
      real(SP), dimension(:), intent(in) :: Fa
      integer, dimension(:), intent(in) :: Kld, Kcol, Kdiagonal
      logical, intent(out) :: bresult

      ! local variables
      integer :: ieq,ia

      ! Initialisation
      bresult = .true.

      if (fscale .eq. 1.0_SP) then
        !$omp parallel do default(shared) private(ia) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if off-diagonal entries are non-positive
          do ia = Kld(ieq), Kdiagonal(ieq)-1
            if (abs(Fa(ia)) .le. ftreshold) cycle
            bresult = (bresult .and. Fa(ia) .le. 0.0_SP)
          end do
          do ia = Kdiagonal(ieq)+1, Kld(ieq+1)-1
            if (abs(Fa(ia)) .le. ftreshold) cycle
            bresult = (bresult .and. Fa(ia) .le. 0.0_SP)
          end do
        end do
        !$omp end parallel do
      else
        !$omp parallel do default(shared) private(ia) reduction(.and. : bresult)
        do ieq = 1,NEQ
          ! Check if off-diagonal entries are non-positive
          do ia = Kld(ieq), Kdiagonal(ieq)-1
            if (abs(fscale*Fa(ia)) .le. ftreshold) cycle
            bresult = (bresult .and. fscale*Fa(ia) .le. 0.0_SP)
          end do
          do ia = Kdiagonal(ieq)+1, Kld(ieq+1)-1
            if (abs(fscale*Fa(ia)) .le. ftreshold) cycle
            bresult = (bresult .and. fscale*Fa(ia) .le. 0.0_SP)
          end do
        end do
        !$omp end parallel do
      end if

    end subroutine check_signMat9SP

  end subroutine mchk_isZMatrix

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

!<subroutine>

  subroutine mchk_calcStrongConnComp(rmatrix, bdata, nscc, dtreshold,&
                                     p_IsccIdx, p_Iscc)

!<description>
    ! This subroutine calculates the strongly connected components of
    ! the graph that corresponds to to matrix rmatrix. This algorithm
    ! is known as Tarjan's arlgorithm.
!</description>

!<input>
    ! Scalar matrix
    type(t_matrixScalar), intent(in) :: rmatrix

    ! Whether to consider the real data of the matrix or its sparsity
    ! pattern
    logical, intent(in) :: bdata

    ! OPTIONAL: If bdata=true, then matrix coefficients with absolute
    ! value smaller than the given treshold are considered zero
    real(DP), intent(in), optional :: dtreshold
!</input>

!<output>
    ! Number of strongly connected components
    integer, intent(out) :: nscc

    ! OPTIONAL: Pointer to integer array storing the strongly
    ! connected components. If not present, then this routine returns
    ! only the number of strongly connected components (nscc).
    integer, dimension(:), pointer, optional :: p_IsccIdx, p_Iscc
!</output>
!</subroutine>

    ! locale variables
    type(t_stackInt) :: rstack
    integer, dimension(:), pointer :: p_Kld,p_Kcol
    integer, dimension(:), allocatable :: Index,LowLink
    real(DP), dimension(:), pointer :: p_Da
    real(SP), dimension(:), pointer :: p_Fa
    real(DP) :: dtrhold
    integer :: ieq,idx

    dtrhold = 0.0_DP
    if (present(dtreshold)) dtrhold = dtreshold

    ! Initialisation
    call stack_create(rstack, rmatrix%NEQ)

    allocate(index(rmatrix%NEQ), LowLink(rmatrix%NEQ))
    call lalg_clearVector(Index)
    idx  = 1
    nscc = 0

    ! What matrix type are we?
    select case(rmatrix%cmatrixFormat)

    case(LSYSSC_MATRIX7, LSYSSC_MATRIX9)

      ! Set pointers
      call lsyssc_getbase_Kld(rmatrix, p_Kld)
      call lsyssc_getbase_Kcol(rmatrix, p_Kcol)

      if (bdata) then

        ! What data type are we?
        select case(rmatrix%cdataType)

        case (ST_DOUBLE)
          call lsyssc_getbase_double(rmatrix, p_Da)

          ! Tarjan`s algorithm based on the double-valued matrix
          ! coefficients
          do ieq = 1, rmatrix%NEQ
            if (index(ieq) .eq. 0)&
                call strongconnectMat79DP(rstack, p_Kld, p_Kcol, p_Da, ieq,&
                                          Index, LowLink, idx, nscc)
          end do

          ! Generate list of strongly connected components?
          if (present(p_IsccIdx) .and. present(p_Iscc)) then
            allocate(p_IsccIdx(nscc+1), p_Iscc(rmatrix%NEQ))

            call stack_clear(rstack)
            call lalg_clearVector(Index)
            idx  = 1
            nscc = 0
            p_IsccIdx(1) = 1

            ! Tarjan`s algorithm based on the double-valued matrix
            ! coefficients
            do ieq = 1, rmatrix%NEQ
              if (index(ieq) .eq. 0)&
                  call strongconnectMat79DP(rstack, p_Kld, p_Kcol, p_Da, ieq,&
                                            Index, LowLink, idx, nscc,&
                                            p_IsccIdx, p_Iscc)
            end do
          end if

        case (ST_SINGLE)
          call lsyssc_getbase_single(rmatrix, p_Fa)

          ! Tarjan`s algorithm based on the double-valued matrix
          ! coefficients
          do ieq = 1, rmatrix%NEQ
            if (index(ieq) .eq. 0)&
                call strongconnectMat79SP(rstack, p_Kld, p_Kcol, p_Fa, ieq,&
                                          Index, LowLink, idx, nscc)
          end do

          ! Generate list of strongly connected components?
          if (present(p_IsccIdx) .and. present(p_Iscc)) then
            allocate(p_IsccIdx(nscc+1), p_Iscc(rmatrix%NEQ))

            call stack_clear(rstack)
            call lalg_clearVector(Index)
            idx  = 1
            nscc = 0
            p_IsccIdx(1) = 1

            ! Tarjan`s algorithm based on the double-valued matrix
            ! coefficients
            do ieq = 1, rmatrix%NEQ
              if (index(ieq) .eq. 0)&
                  call strongconnectMat79SP(rstack, p_Kld, p_Kcol, p_Fa, ieq,&
                                            Index, LowLink, idx, nscc,&
                                            p_IsccIdx, p_Iscc)
            end do
          end if

        case default
          call output_line('Unsupported data type!',&
              OU_CLASS_ERROR,OU_MODE_STD,'mchk_calcStrongConnComp')
          call sys_halt()
        end select

      else

        ! Tarjan`s algorithm based on the sparsity graph
        do ieq = 1, rmatrix%NEQ
          if (index(ieq) .eq. 0)&
              call strongconnectMat79(rstack, p_Kld, p_Kcol, ieq,&
                                      Index, LowLink, idx, nscc)
        end do

        ! Generate list of strongly connected components?
        if (present(p_IsccIdx) .and. present(p_Iscc)) then
          allocate(p_IsccIdx(nscc+1), p_Iscc(rmatrix%NEQ))

          call stack_clear(rstack)
          call lalg_clearVector(Index)
          idx  = 1
          nscc = 0
          p_IsccIdx(1) = 1

          ! Tarjan`s algorithm based on the sparsity graph
          do ieq = 1, rmatrix%NEQ
            if (index(ieq) .eq. 0)&
                call strongconnectMat79(rstack, p_Kld, p_Kcol, ieq,&
                                        Index, LowLink, idx, nscc,&
                                        p_IsccIdx, p_Iscc)
          end do
        end if

      end if

    case default
      call output_line('Unsupported matrix format!',&
          OU_CLASS_ERROR,OU_MODE_STD,'mchk_calcStrongConnComp')
      call sys_halt()
    end select

    ! Finalisation
    call stack_release(rstack)
    deallocate(Index,LowLink)

  contains

    ! Here, the real working routine follows

    !***************************************************************************
    ! Compute SCC based on the sparsity graph for matrix format 7 and 9

    recursive subroutine strongconnectMat79(rstack, Kld, Kcol, ieq, Index,&
                                            LowLink, idx, nscc, IsccIdx, Iscc)

      integer, dimension(:), intent(in) :: Kld,Kcol
      integer, intent(in) :: ieq

      type(t_stackInt), intent(inout) :: rstack
      integer, dimension(:), intent(inout) :: Index,LowLink
      integer, intent(inout) :: idx,nscc

      integer, dimension(:), optional :: IsccIdx, Iscc

      ! local variables
      integer :: ia,jeq,iidx

      ! Set the depth index for IEQ to the smallest unused index
      index(ieq)   = idx
      LowLink(ieq) = idx
      idx = idx+1
      call stack_push(rstack, ieq)

      ! Consider successor of IEQ
      do ia = Kld(ieq), Kld(ieq+1)-1
        jeq = Kcol(ia)

        if (index(jeq) .eq. 0) then
          ! Successor JEQ has not yet been visited; recurse on it
          call strongconnectMat79(rstack, Kld, Kcol, jeq, Index,&
                                  LowLink, idx, nscc, IsccIdx, Iscc)

          LowLink(ieq) = min(LowLink(ieq), LowLink(jeq))
        elseif (stack_contains(rstack, jeq)) then
          ! Successor JEQ is in the stack and hence in the current
          ! strongly connected component
          LowLink(ieq) = min(LowLink(ieq), index(jeq))
        end if
      end do

      ! If IEQ is a root node, pop the stack and generate a new
      ! strongly connected component; two versions!

      if (present(IsccIdx) .and. present(Iscc)) then

        if (LowLink(ieq) .eq. index(ieq)) then
          nscc = nscc+1
          iidx = IsccIdx(nscc)
          scc1: do
            call stack_pop(rstack, jeq)
            Iscc(iidx) = jeq
            iidx = iidx+1
            if (jeq .eq. ieq) exit scc1
          end do scc1
          IsccIdx(nscc+1) = iidx
        end if

      else

        if (LowLink(ieq) .eq. index(ieq)) then
          nscc = nscc+1
          scc2: do
            call stack_pop(rstack, jeq)
            if (jeq .eq. ieq) exit scc2
          end do scc2
        end if

      end if

    end subroutine strongconnectMat79

    !***************************************************************************
    ! Compute SCC based on double-based data for matrix format 7 and 9

    recursive subroutine strongconnectMat79DP(rstack, Kld, Kcol, Da, ieq, Index,&
                                              LowLink, idx, nscc, IsccIdx, Iscc)

      real(DP), dimension(:), intent(in) :: Da
      integer, dimension(:), intent(in) :: Kld,Kcol
      integer, intent(in) :: ieq

      type(t_stackInt), intent(inout) :: rstack
      integer, dimension(:), intent(inout) :: Index,LowLink
      integer, intent(inout) :: idx,nscc

      integer, dimension(:), optional :: IsccIdx, Iscc

      ! local variables
      integer :: ia,jeq,iidx

      ! Set the depth index for IEQ to the smallest unused index
      index(ieq)   = idx
      LowLink(ieq) = idx
      idx = idx+1
      call stack_push(rstack, ieq)

      ! Consider successor of IEQ
      do ia = Kld(ieq), Kld(ieq+1)-1
        if (abs(Da(ia)) .le. dtrhold) cycle
        jeq = Kcol(ia)

        if (index(jeq) .eq. 0) then
          ! Successor JEQ has not yet been visited; recurse on it
          call strongconnectMat79DP(rstack, Kld, Kcol, Da, jeq, Index,&
                                    LowLink, idx, nscc, IsccIdx, Iscc)

          LowLink(ieq) = min(LowLink(ieq), LowLink(jeq))
        elseif (stack_contains(rstack, jeq)) then
          ! Successor JEQ is in the stack and hence in the current
          ! strongly connected component
          LowLink(ieq) = min(LowLink(ieq), index(jeq))
        end if
      end do

      ! If IEQ is a root node, pop the stack and generate a new
      ! strongly connected component; two versions!

      if (present(IsccIdx) .and. present(Iscc)) then

        if (LowLink(ieq) .eq. index(ieq)) then
          nscc = nscc+1
          iidx = IsccIdx(nscc)
          scc1: do
            call stack_pop(rstack, jeq)
            Iscc(iidx) = jeq
            iidx = iidx+1
            if (jeq .eq. ieq) exit scc1
          end do scc1
          IsccIdx(nscc+1) = iidx
        end if

      else

        if (LowLink(ieq) .eq. index(ieq)) then
          nscc = nscc+1
          scc2: do
            call stack_pop(rstack, jeq)
            if (jeq .eq. ieq) exit scc2
          end do scc2
        end if

      end if

    end subroutine strongconnectMat79DP

    !***************************************************************************
    ! Compute SCC based on single-based data for matrix format 7 and 9

    recursive subroutine strongconnectMat79SP(rstack, Kld, Kcol, Fa, ieq, Index,&
                                              LowLink, idx, nscc, IsccIdx, Iscc)

      real(SP), dimension(:), intent(in) :: Fa
      integer, dimension(:), intent(in) :: Kld,Kcol
      integer, intent(in) :: ieq

      type(t_stackInt), intent(inout) :: rstack
      integer, dimension(:), intent(inout) :: Index,LowLink
      integer, intent(inout) :: idx,nscc

      integer, dimension(:), optional :: IsccIdx, Iscc

      ! local variables
      integer :: ia,jeq,iidx

      ! Set the depth index for IEQ to the smallest unused index
      index(ieq)   = idx
      LowLink(ieq) = idx
      idx = idx+1
      call stack_push(rstack, ieq)

      ! Consider successor of IEQ
      do ia = Kld(ieq), Kld(ieq+1)-1
        if (abs(Fa(ia)) .le. real(dtrhold,SP)) cycle
        jeq = Kcol(ia)

        if (index(jeq) .eq. 0) then
          ! Successor JEQ has not yet been visited; recurse on it
          call strongconnectMat79SP(rstack, Kld, Kcol, Fa, jeq, Index,&
                                    LowLink, idx, nscc, IsccIdx, Iscc)

          LowLink(ieq) = min(LowLink(ieq), LowLink(jeq))
        elseif (stack_contains(rstack, jeq)) then
          ! Successor JEQ is in the stack and hence in the current
          ! strongly connected component
          LowLink(ieq) = min(LowLink(ieq), index(jeq))
        end if
      end do

      ! If IEQ is a root node, pop the stack and generate a new
      ! strongly connected component; two versions!

      if (present(IsccIdx) .and. present(Iscc)) then

        if (LowLink(ieq) .eq. index(ieq)) then
          nscc = nscc+1
          iidx = IsccIdx(nscc)
          scc1: do
            call stack_pop(rstack, jeq)
            Iscc(iidx) = jeq
            iidx = iidx+1
            if (jeq .eq. ieq) exit scc1
          end do scc1
          IsccIdx(nscc+1) = iidx
        end if

      else

        if (LowLink(ieq) .eq. index(ieq)) then
          nscc = nscc+1
          scc2: do
            call stack_pop(rstack, jeq)
            if (jeq .eq. ieq) exit scc2
          end do scc2
        end if

      end if

    end subroutine strongconnectMat79SP

  end subroutine mchk_calcStrongConnComp

end module matrixcheck


c-----------------------------------------------------------------------------
c     Hicks-Henne based shape deformation parameterization
c     Deformation is interpolated to interior nodes using Thin-Plate Spline RBF
c     interpolation
c
c     Input files:
c       shape.in  : Defines fixed and moving surfaces
c       hicks.in  : Hicks-Henne parameters
c       grid.0    : Base grid
c
c     Output files:
c-----------------------------------------------------------------------------
      program deform
      implicit none
      include 'dim.h'
      include 'param.h'
      include 'kulfan.h'
      integer total_pts
      real,allocatable:: r(:), dr(:), rw(:,:), drw(:,:), wt(:,:)
      integer,allocatable:: idx(:,:)

      integer i, j, ioffrt, iblk, npts, nwp, ir, di, dj, mn, ifid
      real    fun

      integer dfid, nwp0
      Character(len=25) :: dfilename

c     Read input file defining moving and fixed surfaces
      call readin()

c     Total number of grid points to allocate memory
      npts = total_pts(nblks, idim, jdim)
      if(nblks.gt.nblkmax)then
         print*,'main: increase maxblks'
         print*,'      nblks   =',nblks
         print*,'      maxblks =',nblkmax
         stop
      endif
      allocate ( r (npts*NDIM) )
      allocate (dr (npts*NDIM) )

c     Create offset array for coordinates storage
      ioffrt = 0
      do i=1,nblks
         ioffr(i) = ioffrt
         ioffrt   = ioffrt + idim(i) * jdim(i)
      enddo
      call readgrd(nblks, idim, jdim, ioffr, r)

c     Count number of boundary points to allocate memory
      nwp = 0
      mn  = 0
      do i=1,nsurf
         di  = abs(iend(i) - ibeg(i)) + 1
         dj  = abs(jend(i) - jbeg(i)) + 1
         nwp = nwp + di*dj
         mn  = max( mn, di*dj )
         nspt(i) = di*dj
      enddo
      allocate( rw  (NDIM, nwp) )
      allocate( drw (NDIM, nwp) )
      allocate( wt  (NDIM, nwp+NDIM+1) )
      allocate( idx (mn, nsurf) )

c     For mirror surfaces like in symmetric airfoil
      do i=1,nsurf
         nhhpo(i) = nhhp(i)
         if(nhhp(i).lt.0)then
            ir      =-nhhp(i)
            nhhp(i) = nhhp(ir)
            do j=1,nhhp(i)
               xw(j,i) = -xw(j,ir)
            enddo
         endif
      enddo

c     Loop over surfaces
c     Put boundary points in rw and deformation into drw
c     Count number nwp of boundary points: there may be duplicate points
      nwp  = 0
      nwp0 = 1
      do i=1,nsurf
         print*,'Applying deformation to surface =',i
         iblk = blk(i)
         ir   = ioffr(iblk)*NDIM + 1
         call shape_deform(ibeg(i), jbeg(i), iend(i), jend(i), nhhp(i),
     1                     idim(iblk), jdim(iblk), r(ir),
     2                     rw, drw, nwp, xw(1,i), idx(1,i), param_type)

c     Temporary insert of code segment to extract coordinates of "deformed" surfaces
         if(nhhp(i).gt.0)then
             write (dfilename, fmt='(a,i1,a)') 'def_surf_', i, '.dat'
             dfid = 1000
             open(dfid,file=dfilename)
			 do j=nwp0,nwp
				 write(dfid,*) rw(1,j)+drw(2,j),rw(2,j)+drw(2,j)
			 enddo
			 close(dfid)
         endif
         nwp0=nwp+1

      enddo
      print*,'Number of wall points (inc. duplicates) =',nwp

c     Remove duplicate boundary points
      call rem_dup(nwp, rw, drw, nsurf, nspt, mn, idx)

c     Construct RBF interpolant
      call rbf_train(nwp, rw, drw, wt)
c     do i=1,nwp
c        print*,i,drw(1,i),drw(2,i)
c     enddo
c     stop
c     do i=1,nwp+3
c        print*,i,wt(1,i),wt(2,i)
c     enddo

c     Copy initial grid into dr, only for visualization
      dr(:) = r(:)

c     Compute deformation for interior points
      print*,'Applying deformation to grid'
      do iblk=1,nblks
         ir   = ioffr(iblk)*NDIM + 1
         print*,'   Block =',iblk
         call rbf_eval(idim(iblk), jdim(iblk), r(ir), nwp, rw, wt)
c        call shepard(idim(iblk), jdim(iblk), r(ir), nwp, rw, drw)
      enddo

c     write out new grid
      ifid = 20
      open(ifid,file='grid.unf',form='unformatted')
      if(nblks.gt.1) write(ifid) nblks
      write(ifid)(idim(i),jdim(i),i=1,nblks)
      do i=1,nblks
         ir   = ioffr(i)*NDIM + 1
         call wrtgrd(ifid, idim(i), jdim(i), r(ir), dr(ir))
      enddo
      close(ifid)
      print*,'Deformed grid written into grid.unf'

c     Test function
c     fun = 0
c     do i=1,nblks
c        ir   = ioffr(iblk)*NDIM + 1
c        call testfun(idim(i), jdim(i), r(ir), fun)
c     enddo
c     print*,'Function =',fun

      stop
      end


      subroutine qlratgam(ratp,ratm,ieps,p3sq,m3sq,m4sq)
*****comment:************************************************************
*									*
*	Calculate the function                                          *
*									*
*		  +p3sq+m4sq-m3sq+sqrt((p3sq+m4sq-m3sq)^2-4*p3sq*m4sq)  *
* rat(p^2,m,mp) = --------------------------------------------------    *
*                 -p3sq+m4sq-m3sq+sqrt((p3sq+m4sq-m3sq)^2-4*p3sq*m4sq)  *
*									*
*	the roots are allowed to be imaginary				*
*									*
***comment:*************************************************************
      implicit none
      double precision p3sq,m3sq,m4sq,ieps
      double complex root,ratp,ratm

      root=dcmplx((p3sq-m3sq+m4sq)**2-4d0*m4sq*p3sq)
      root=sqrt(root)
      ratp=(dcmplx(+p3sq+m4sq-m3sq)+root)/(dcmplx(-p3sq+m4sq-m3sq)+root)
      ratm=(dcmplx(+p3sq+m4sq-m3sq)-root)/(dcmplx(-p3sq+m4sq-m3sq)-root)
      ieps=0d0
      end


      subroutine rel_diff(f1,f2,N,res)
         implicit none
         integer N
         real*8 f1(N)
         real*8 f2(N)
         real*8 res
         integer i
         res =0.0D0
         do i=1, N, 1
           if ( dabs(f1(i)-f2(i))/abs(f1(i)) > res )  then
              res = dabs(f1(i)-f2(i))/abs(f1(i))
           end if
         end do
         END


! **********************************************
!   1/11/2012
! **********************************************
!
! Main program for computing roots of a polynomial
! using a factorization of the companion matrix
! and a modification of Francis' single shift algorithm
! that preserves the factored structure. This method was
! developed by David Watkins and Raf Vandebril.
!

program main

  implicit none

  complex(kind(1d0)), allocatable :: poly(:),roots(:)
  double precision, allocatable :: residuals(:,:)
  integer, allocatable :: iterations(:)
  double precision :: our_time,res_time,preal,pimag

  integer :: i,j,degree,zero,flag
  integer :: clock_start,clock_end,clock_rate

degree = 1200
flag = 0

  allocate(poly(degree),roots(degree),iterations(degree),residuals(degree,6))

  call init_random_seed()
  call cnormalpoly(degree,poly)

  CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate)
  CALL SYSTEM_CLOCK(COUNT=clock_start)

  call avw(poly,degree,roots,iterations,flag)

  CALL SYSTEM_CLOCK(COUNT=clock_end)
  our_time = dble(clock_end - clock_start)/dble(clock_rate)
  write(*,*)"AVW time =",our_time

  CALL SYSTEM_CLOCK(COUNT_RATE=clock_rate)
  CALL SYSTEM_CLOCK(COUNT=clock_start)

  call rescheck(degree,poly,roots,1,residuals)

  CALL SYSTEM_CLOCK(COUNT=clock_end)
  res_time = dble(clock_end - clock_start)/dble(clock_rate)
  write(*,*)"RESCHECK time =",res_time
  write(*,*)"RESCHECK RATIO =",res_time/our_time

  open (unit=7, file='roots.txt', status='unknown')
  do j=1,degree
  	write (7,*) dble(roots(j)),dimag(roots(j))
  end do
  close(7)

  open (unit=8, file='poly.txt', status='unknown')
  do j=1,degree
  	write (8,*) dble(poly(j)),dimag(poly(j))
  end do
  close(8)

  open (unit=9, file='iterations.txt', status='unknown')
  do j=1,degree
  	write (9,*) iterations(j)
  end do
  close(9)

  open (unit=10, file='residuals.txt', status='unknown')
  do j=1,degree
  	write (10,*) residuals(j,:)
  end do
  close(10)

  deallocate(poly,roots,iterations,residuals)

end program main


      subroutine waxpby(n, w, alpha, x, beta, y)
      integer n, incx, incy
      double precision alpha
      double precision yy(n)
      double precision w(*), x(*), y(*)
c
c   WAXPBY
c   in
c     alpha : scalar,
c     x : vector,
c     beta : scalar,
c     y : vector
c   out
c     w : vector
c   {
c     w = alpha * x + beta * y
c   }
c
      incx = 1
      incy = 1
c
c  Copy y into yy so that input is not overwritten.
c
      call dcopy(n, y, incx, yy, incy)
c
c  Put beta*yy into yy
c
      call dscal(n, beta, yy, incx )
c
c  Put x + yy into yy
c
      call daxpy(n, alpha, x, incx, yy, incy)
c
c  Copy yy into w.
c
      call dcopy(n, yy, incx, w, incy)
c
c
      return
      end


! Copyright 2005-2016 ECMWF.
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
!
! In applying this licence, ECMWF does not waive the privileges and immunities granted to it by
! virtue of its status as an intergovernmental organisation nor does it submit to any jurisdiction.
!
!  Description: Practical example of an ensemble mean using grib_api
!
!
!  Author: Cristian D Codorean
!
!
program ensemble_mean

	use grib_api

	implicit none

	character(len=100)                  ::  file_name,out_file
	integer                             ::  ifile,ofile
	integer                             ::  igrib,ogrib
	integer                             ::  numberOfValues, nMessages
	integer                             ::  iret
	real(8), dimension(:), allocatable  ::  values,sums

	! --- get input arguments
	call getarg(1,file_name)
	call getarg(2,out_file)

	call grib_open_file(ifile,file_name,'r')
	call grib_open_file(ofile,out_file,'w')

	! --- count number of messages in grib
	call grib_count_in_file(ifile,nMessages)

	call grib_new_from_file(ifile,igrib,iret)

	! --- create ouput grib from this one
	call grib_clone(igrib,ogrib)

	! --- get the number of values, we suppose all messages have
	! -     the same size for the sake of this example
	call grib_get(igrib,'numberOfValues',numberOfValues)

	! --- one should check if allocation was successfull
	allocate(values(numberOfValues))
	allocate(sums(numberOfValues))

	! --- compute the ensemble mean
	sums = 0
	do while (iret/=GRIB_END_OF_FILE)
		call grib_get(igrib,'values',values)
		sums = sums + values
		call grib_new_from_file(ifile,igrib,iret)
	end do
	sums = sums/nMessages

	! --- write to the out file
	call grib_set(ogrib,'values',sums)
	call grib_write(ogrib,ofile)

	! --- release mem
	deallocate(values)
	deallocate(sums)
	call grib_release(igrib)
	call grib_close_file(ifile)
	call grib_close_file(ofile)

end program ensemble_mean


module assumed_module ! i added this
  use, intrinsic :: iso_c_binding
  ! Assume this code is inside a module

  type random_stream
     ! A (uniform) random number generator (URNG)
   contains
     procedure(random_uniform), deferred, pass(stream) :: next
     ! Generates the next number from the stream
  end type random_stream

  abstract interface
     ! Abstract interface of Fortran URNG
     subroutine random_uniform(stream, number)
       import :: random_stream, c_double
       class(random_stream), intent(inout) :: stream
       real(c_duoble), intent(out) :: number
     end subroutine random_uniform
  end interface

  type :: urng_state ! No BIND(C), as this type is not interoperable
     class(random_stream), allocatable :: stream
  end type urng_state

contains ! i added this
  subroutine initialize_urng(state_handle, method) &
       bind(c, name="InitializeURNG")
    type(c_ptr), intent(out) :: state_handle
    ! An opaque handle for the URNG
    character(c_char), dimension(*), intent(in) :: method
    ! The algorithm to be used
    type(urng_state), pointer :: state
    ! An actual URNG object
    allocate(state)
    ! There needs to be a corresponding finalizatin
    ! procedure to avoid memory leaks, not shown in this example
    ! Allocate state%stream with a dynamic type depending on method

    state_handle=c_loc(state)
    ! Obtain an opaque handle to return to C
  end subroutine initialize_urng

  ! Generate a random number:
  subroutine generate_uniform(state_handle, number) &
       bind(c, name="GenerateUniform")
    type(c_ptr), intent(in), value :: state_handle
    ! An opaque handle: Obained via a call to initialize_urng
    real(c_double), intent(out) :: number

    type(urng_state), pointer :: state
    ! A pointer to the actual urng

    call c_f_pointer(c_ptr=state_handle, fptr=state)
    ! Convert the opaque handle into a usable pointer
    call state%stream%next(number)
    ! Use the type-bound procedure next to generate number
  end subroutine generate_uniform
end module assumed_module


c=======================================================================
c
c     GENUNF
c
c     Generate Uniform random number between LOW and HIGH
c
c-----------------------------------------------------------------------
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION genunf(low, high)
c-----------------------------------------------------------------------
c
c     INPUT
c      low  : low bound (exclusive) value to be generated         double
c      high : high bound (exclusive) value to be generated        double
c
c-----------------------------------------------------------------------
c
c     scalar arguments
      DOUBLE PRECISION high, low
c
c     external functions
      DOUBLE PRECISION ranf
      EXTERNAL ranf
c
c     executable statements
      genunf = low + (high-low)*ranf()
c
      RETURN
      END


module mgh
    implicit none
    save

    private
    integer :: n, nprob, ntries

    integer,           dimension(18) :: vn      = (/ 3, 6, 3, 2, 3, 4, 10, 2, 2, 2, 4, 3, 2, 12, 4, 2, 4, 2/)
    integer,           dimension(18) :: vntries = (/ 2, 2, 2, 3, 2, 4,  4, 2, 2, 5, 2, 2, 2,  5, 2, 2, 4, 2/)
    character(len=30), dimension(18) :: names   = [character(len=30) :: &
                                                   "Helical Valley", &
                                                   "Biggs EXP6", &
                                                   "Gaussian", &
                                                   "Powell Badly Scaled", &
                                                   "Box 3D", &
                                                   "Variably Dimensioned", &
                                                   "Watson", &
                                                   "Penalty I", &
                                                   "Penalty II", &
                                                   "Brown Badly Scaled", &
                                                   "Brown and Dennis", &
                                                   "Gulf Research and Development", &
                                                   "Trigonometric", &
                                                   "Extended Rosebrock", &
                                                   "Extended Powell Singular", &
                                                   "Beale", &
                                                   "Wood", &
                                                   "Chebyquad"]

    public :: setprob, getdim, gettries, getname, getinit, mgh_f, mgh_g, mgh_h
contains
    subroutine setprob(i)
        integer, intent(in)  :: i

        n      = vn(i)
        nprob  = i
        ntries = vntries(i)
    end subroutine setprob

    function getdim()
        integer             :: getdim

        getdim = n
    end function getdim

    function gettries()
        integer :: gettries

        gettries = vntries(nprob)
    end function gettries

    function getname()
        character(len=30)   :: getname

        getname = names(nprob)
    end function getname

    subroutine getinit(x0, factor)
        double precision, intent(inout) :: x0(:)
        double precision, intent(in)    :: factor

        call INITPT(n, x0, nprob, factor)
    end subroutine getinit

    function mgh_f(x)
        double precision, intent(in) :: x(:)
        double precision             :: mgh_f

        call OBJFCN(n, x, mgh_f, nprob)
    end function mgh_f

    subroutine mgh_g(gx, x)
      double precision, intent(out) :: gx(:)
      double precision, intent(in)  :: x(:)

      call GRDFCN(n, x, gx, nprob)
  end subroutine mgh_g

    subroutine mgh_h(hx, x)
        double precision, intent(out) :: hx(:, :)
        double precision, intent(in)  :: x(:)

        integer                      :: i, j
        double precision             :: hesd(n)
        double precision             :: hesl(n*(n-1)/2)
        double precision             :: hij

        call HESFCN(n, x, hesd, hesl, nprob)

        ! Constroi a hessiana
        do j = 1, n
            hx(j, j) = hesd(j)
            do i = j+1, n
                hij     = hesl((i-1)*(i-2)/2 + j)
                hx(i, j) = hij
                hx(j, i) = hij
            end do
        end do
  end subroutine mgh_h
end module mgh


program demo

    use constants, only: set_constants, pi, e

    implicit none
    real(kind=8) :: r, a

    call set_constants()
    print *, "In main program, pi = ", pi, "  e = ", e
    print *, "Input r: "
    read *, r
    call area(r,a)
 10 format("A circle of radius ", e21.15," has area ", e21.15)
    print 10, r, a

end program demo


!==============================================================================!
  subroutine User_Mod_Source(grid, phi, a_matrix, b_vector)
!------------------------------------------------------------------------------!
!   This is a prototype of a function for customized source for scalar.        !
!   It is called from "Compute_Scalar" function, just before calling the       !
!   linear solver.  Both system matrix ("a_matrix") and right hand side        !
!   vector ("b_vector") are sent should the user want to stabilize the         !
!   system for always positive variables, for example.                         !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Grid_Mod
  use Var_Mod
  use Matrix_Mod
  use Flow_Mod
  use Const_Mod, only: PI
!------------------------------------------------------------------------------!
  implicit none
!----------------------------------[Locals]------------------------------------!
  integer :: c
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type)    :: grid
  type(Var_Type)     :: phi
  type(Matrix_Type)  :: a_matrix
  real, dimension(:) :: b_vector
!==============================================================================!

  !-----------------------------------------------------!
  !                                                     !
  !   Set source depending on which variable you have   !
  !                                                     !
  !-----------------------------------------------------!
  !
  !
  !  /
  ! |
  ! |dT/dz * Uz * volume
  ! |
  !/
  ! dT/dz is derived from condition that there is no
  ! change of energy in the system. It means
  ! mass_flux * cp * dT - Q * Area = 0, Area = 2 r pi * dz ,
  !  dT/dz = 2 r pi Q / (mass_flux*cp).
  ! where Q is heat flux through the wall.

  !-------------------------------!
  !  Set source for temperature   !
  !-------------------------------!
  if( phi % name .eq. 'T' ) then
    do c = 1, grid % n_cells

      b_vector(c) = b_vector(c)   &
                  - 2.0 * pi * heat_flux * w % n(c) &
      / (bulk % flux_z * capacity) * grid % vol(c)

    end do
  end if

  end subroutine  ! fourth level comments


        subroutine idz_sffti(l,ind,n,wsave)
c
c       initializes wsave for use with routine idz_sfft.
c
c       input:
c       l -- number of entries in the output of idz_sfft to compute
c       ind -- indices of the entries in the output of idz_sfft
c              to compute
c       n -- length of the vector to be transformed
c
c       output:
c       wsave -- array needed by routine idz_sfft for processing
c
        implicit none
        integer l,ind(l),n,nblock,ii,m,idivm,imodm,i,j,k
        real*8 r1,twopi,fact
        complex*16 wsave(2*l+15+3*n),ci,twopii
c
        ci = (0,1)
        r1 = 1
        twopi = 2*4*atan(r1)
        twopii = twopi*ci
c
c
c       Determine the block lengths for the FFTs.
c
        call idz_ldiv(l,n,nblock)
        m = n/nblock
c
c
c       Initialize wsave for use with routine zfftf.
c
        call zffti(nblock,wsave)
c
c
c       Calculate the coefficients in the linear combinations
c       needed for the direct portion of the calculation.
c
        fact = 1/sqrt(r1*n)
c
        ii = 2*l+15
c
        do j = 1,l
c
          i = ind(j)
c
          idivm = (i-1)/m
          imodm = (i-1)-m*idivm
c
          do k = 1,m
            wsave(ii+m*(j-1)+k) = exp(-twopii*imodm*(k-1)/(r1*m))
     1       * exp(-twopii*(k-1)*idivm/(r1*n)) * fact
          enddo ! k
c
        enddo ! j
c
c
        return
        end
c
c
c
c


! Calculate flux from optical depth using the formula F ~ exp(-tau).

subroutine calc_flux(tau, lo, hi, ng, A, flux)
    use, intrinsic :: iso_c_binding
    implicit none

    integer(c_int), intent(in) :: lo(3), hi(3), ng
    real(c_double), intent(in) :: tau (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
    real(c_double), intent(in) :: A

    real(c_double), intent(out) :: flux (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)

    integer(c_int) :: i, j, k

    do k = lo(3), hi(3)
      do j = lo(2), hi(2)
        do i = lo(1), hi(1)
          flux (i, j, k, 1) = exp (-A * tau (i, j, k, 1))
        end do
      end do
    end do

end subroutine calc_flux


!*==LINPK.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005
!   SPAG options set to convert source form only
! *** Double-precision Linpack benchmark
      PROGRAM LINPK
      PARAMETER (N=2500,LDA=N+1)
      DOUBLE PRECISION a(LDA,N) , b(N) , x(N)
      DOUBLE PRECISION norma , normx
      DOUBLE PRECISION resid , residn , eps
      REAL*8 EPSLON
      INTEGER ipvt(N)

      CALL MATGEN(a,LDA,N,b,norma)
      CALL DGEFA(a,LDA,N,ipvt,info)
      CALL DGESL(a,LDA,N,ipvt,b,0)

!     compute a residual to verify results.

      DO i = 1 , N
         x(i) = b(i)
      ENDDO
      CALL MATGEN(a,LDA,N,b,norma)
      DO i = 1 , N
         b(i) = -b(i)
      ENDDO
      CALL DMXPY(N,b,N,LDA,x,a)
      resid = 0.0D00
      normx = 0.0D00
      DO i = 1 , N
         resid = DMAX1(resid,DABS(b(i)))
         normx = DMAX1(normx,DABS(x(i)))
      ENDDO
      eps = EPSLON(1.0D0)
      residn = resid/(N*norma*normx*eps)
      WRITE (*,200)
 200  FORMAT ('     norm. resid      resid           machep',           &
     &        '         x(1)          x(n)')
      WRITE (*,300) residn , resid , eps , x(1) , x(N)
 300  FORMAT (1P5d16.8)

      END
!*==MATGEN.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

      SUBROUTINE MATGEN(A,Lda,N,B,Norma)
      DOUBLE PRECISION A(Lda,*) , B(*) , Norma

      init = 1325
      Norma = 0.0
      DO j = 1 , N
         DO i = 1 , N
            init = MOD(3125*init,65536)
            A(i,j) = (init-32768.0)/16384.0
            Norma = DMAX1(A(i,j),Norma)
         ENDDO
      ENDDO
      DO i = 1 , N
         B(i) = 0.0
      ENDDO
      DO j = 1 , N
         DO i = 1 , N
            B(i) = B(i) + A(i,j)
         ENDDO
      ENDDO
      CONTINUE
      END
!*==DGEFA.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

      SUBROUTINE DGEFA(A,Lda,N,Ipvt,Info)
      INTEGER Lda , N , Ipvt(*) , Info
      DOUBLE PRECISION A(Lda,*)

!     dgefa factors a double precision matrix by gaussian elimination.

!     dgefa is usually called by dgeco, but it can be called
!     directly with a saving in time if  rcond  is not needed.
!     (time for dgeco) = (1 + 9/n)*(time for dgefa) .

!     on entry

!     a       double precision(lda, n)
!     the matrix to be factored.

!     lda     integer
!     the leading dimension of the array  a .

!     n       integer
!     the order of the matrix  a .

!     on return

!     a       an upper triangular matrix and the multipliers
!     which were used to obtain it.
!     the factorization can be written  a = l*u  where
!     l  is a product of permutation and unit lower
!     triangular matrices and  u  is upper triangular.

!     ipvt    integer(n)
!     an integer vector of pivot indices.

!     info    integer
!     = 0  normal value.
!     = k  if  u(k,k) .eq. 0.0 .  this is not an error
!     condition for this subroutine, but it does
!     indicate that dgesl or dgedi will divide by zero
!     if called.  use  rcond  in dgeco for a reliable
!     indication of singularity.

!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.

!     subroutines and functions

!     blas daxpy,dscal,idamax

!     internal variables

      DOUBLE PRECISION t
      INTEGER IDAMAX , j , k , kp1 , l , nm1

!     gaussian elimination with partial pivoting

      Info = 0
      nm1 = N - 1
      IF ( nm1.GE.1 ) THEN
         DO k = 1 , nm1
            kp1 = k + 1

!             find l = pivot index

            l = IDAMAX(N-k+1,A(k,k),1) + k - 1
            Ipvt(k) = l

!             zero pivot implies this column already triangularized

            IF ( A(l,k).EQ.0.0D0 ) THEN
               Info = k
            ELSE

!                 interchange if necessary

               IF ( l.NE.k ) THEN
                  t = A(l,k)
                  A(l,k) = A(k,k)
                  A(k,k) = t
               ENDIF

!                 compute multipliers

               t = -1.0D0/A(k,k)
               CALL DSCAL(N-k,t,A(k+1,k),1)

!                 row elimination with column indexing

               DO j = kp1 , N
                  t = A(l,j)
                  IF ( l.NE.k ) THEN
                     A(l,j) = A(k,j)
                     A(k,j) = t
                  ENDIF
                  CALL DAXPY(N-k,t,A(k+1,k),1,A(k+1,j),1)
               ENDDO
            ENDIF
         ENDDO
      ENDIF
      Ipvt(N) = N
      IF ( A(N,N).EQ.0.0D0 ) Info = N
      CONTINUE
      END
!*==DGESL.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

      SUBROUTINE DGESL(A,Lda,N,Ipvt,B,Job)
      INTEGER Lda , N , Ipvt(*) , Job
      DOUBLE PRECISION A(Lda,*) , B(*)

!     dgesl solves the double precision system
!     a * x = b  or  trans(a) * x = b
!     using the factors computed by dgeco or dgefa.

!     on entry

!     a       double precision(lda, n)
!     the output from dgeco or dgefa.

!     lda     integer
!     the leading dimension of the array  a .

!     n       integer
!     the order of the matrix  a .

!     ipvt    integer(n)
!     the pivot vector from dgeco or dgefa.

!     b       double precision(n)
!     the right hand side vector.

!     job     integer
!     = 0         to solve  a*x = b ,
!     = nonzero   to solve  trans(a)*x = b  where
!     trans(a)  is the transpose.

!     on return

!     b       the solution vector  x .

!     error condition

!     a division by zero will occur if the input factor contains a
!     zero on the diagonal.  technically this indicates singularity
!     but it is often caused by improper arguments or improper
!     setting of lda .  it will not occur if the subroutines are
!     called correctly and if dgeco has set rcond .gt. 0.0
!     or dgefa has set info .eq. 0 .

!     to compute  inverse(a) * c  where  c  is a matrix
!     with  p  columns
!     call dgeco(a,lda,n,ipvt,rcond,z)
!     if (rcond is too small) go to ...
!     do 10 j = 1, p
!     call dgesl(a,lda,n,ipvt,c(1,j),0)
!     10 continue

!     linpack. this version dated 08/14/78 .
!     cleve moler, university of new mexico, argonne national lab.

!     subroutines and functions

!     blas daxpy,ddot

!     internal variables

      DOUBLE PRECISION DDOT , t
      INTEGER k , kb , l , nm1

      nm1 = N - 1
      IF ( Job.EQ.0 ) THEN

!         job = 0 , solve  a * x = b
!         first solve  l*y = b

         IF ( nm1.GE.1 ) THEN
            DO k = 1 , nm1
               l = Ipvt(k)
               t = B(l)
               IF ( l.NE.k ) THEN
                  B(l) = B(k)
                  B(k) = t
               ENDIF
               CALL DAXPY(N-k,t,A(k+1,k),1,B(k+1),1)
            ENDDO
         ENDIF

!         now solve  u*x = y

         DO kb = 1 , N
            k = N + 1 - kb
            B(k) = B(k)/A(k,k)
            t = -B(k)
            CALL DAXPY(k-1,t,A(1,k),1,B(1),1)
         ENDDO
      ELSE

!         job = nonzero, solve  trans(a) * x = b
!         first solve  trans(u)*y = b

         DO k = 1 , N
            t = DDOT(k-1,A(1,k),1,B(1),1)
            B(k) = (B(k)-t)/A(k,k)
         ENDDO

!         now solve trans(l)*x = y

         IF ( nm1.GE.1 ) THEN
            DO kb = 1 , nm1
               k = N - kb
               B(k) = B(k) + DDOT(N-k,A(k+1,k),1,B(k+1),1)
               l = Ipvt(k)
               IF ( l.NE.k ) THEN
                  t = B(l)
                  B(l) = B(k)
                  B(k) = t
               ENDIF
            ENDDO
         ENDIF
      ENDIF
      CONTINUE
      END
!*==DAXPY.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

      SUBROUTINE DAXPY(N,Da,Dx,Incx,Dy,Incy)

!     constant times a vector plus a vector.
!     uses unrolled loops for increments equal to one.
!     jack dongarra, linpack, 3/11/78.

      DOUBLE PRECISION Dx(*) , Dy(*) , Da
      INTEGER i , Incx , Incy , ix , iy , m , mp1 , N

      IF ( N.GT.0 ) THEN
         IF ( Da.NE.0.0D0 ) THEN
            IF ( Incx.NE.1 .OR. Incy.NE.1 ) THEN

!                 code for unequal increments or equal increments
!                 not equal to 1

               ix = 1
               iy = 1
               IF ( Incx.LT.0 ) ix = (-N+1)*Incx + 1
               IF ( Incy.LT.0 ) iy = (-N+1)*Incy + 1
               DO i = 1 , N
                  Dy(iy) = Dy(iy) + Da*Dx(ix)
                  ix = ix + Incx
                  iy = iy + Incy
               ENDDO
            ELSE

!                 code for both increments equal to 1

!                 clean-up loop

               m = MOD(N,4)
               IF ( m.NE.0 ) THEN
                  DO i = 1 , m
                     Dy(i) = Dy(i) + Da*Dx(i)
                  ENDDO
                  IF ( N.LT.4 ) RETURN
               ENDIF
               mp1 = m + 1
               DO i = mp1 , N , 4
                  Dy(i) = Dy(i) + Da*Dx(i)
                  Dy(i+1) = Dy(i+1) + Da*Dx(i+1)
                  Dy(i+2) = Dy(i+2) + Da*Dx(i+2)
                  Dy(i+3) = Dy(i+3) + Da*Dx(i+3)
               ENDDO
            ENDIF
         ENDIF
      ENDIF
      CONTINUE
      END
!*==DDOT.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005
      DOUBLE PRECISION FUNCTION DDOT(N,Dx,Incx,Dy,Incy)

!     forms the dot product of two vectors.
!     uses unrolled loops for increments equal to one.
!     jack dongarra, linpack, 3/11/78.

      DOUBLE PRECISION Dx(*) , Dy(*) , dtemp
      INTEGER i , Incx , Incy , ix , iy , m , mp1 , N

      DDOT = 0.0D0
      dtemp = 0.0D0
      IF ( N.GT.0 ) THEN
         IF ( Incx.NE.1 .OR. Incy.NE.1 ) THEN

!             code for unequal increments or equal increments
!             not equal to 1

            ix = 1
            iy = 1
            IF ( Incx.LT.0 ) ix = (-N+1)*Incx + 1
            IF ( Incy.LT.0 ) iy = (-N+1)*Incy + 1
            DO i = 1 , N
               dtemp = dtemp + Dx(ix)*Dy(iy)
               ix = ix + Incx
               iy = iy + Incy
            ENDDO
            DDOT = dtemp
         ELSE

!             code for both increments equal to 1

!             clean-up loop

            m = MOD(N,5)
            IF ( m.NE.0 ) THEN
               DO i = 1 , m
                  dtemp = dtemp + Dx(i)*Dy(i)
               ENDDO
               IF ( N.LT.5 ) GOTO 1
            ENDIF
            mp1 = m + 1
            DO i = mp1 , N , 5
               dtemp = dtemp + Dx(i)*Dy(i) + Dx(i+1)*Dy(i+1) + Dx(i+2)  &
     &                 *Dy(i+2) + Dx(i+3)*Dy(i+3) + Dx(i+4)*Dy(i+4)
            ENDDO
 1          DDOT = dtemp
         ENDIF
      ENDIF
      CONTINUE
      END
!*==DSCAL.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

      SUBROUTINE DSCAL(N,Da,Dx,Incx)

!     scales a vector by a constant.
!     uses unrolled loops for increment equal to one.
!     jack dongarra, linpack, 3/11/78.

      DOUBLE PRECISION Da , Dx(*)
      INTEGER i , Incx , m , mp1 , N , nincx

      IF ( N.GT.0 ) THEN
         IF ( Incx.EQ.1 ) THEN

!             code for increment equal to 1

!             clean-up loop

            m = MOD(N,5)
            IF ( m.NE.0 ) THEN
               DO i = 1 , m
                  Dx(i) = Da*Dx(i)
               ENDDO
               IF ( N.LT.5 ) RETURN
            ENDIF
            mp1 = m + 1
            DO i = mp1 , N , 5
               Dx(i) = Da*Dx(i)
               Dx(i+1) = Da*Dx(i+1)
               Dx(i+2) = Da*Dx(i+2)
               Dx(i+3) = Da*Dx(i+3)
               Dx(i+4) = Da*Dx(i+4)
            ENDDO
         ELSE

!             code for increment not equal to 1

            nincx = N*Incx
            DO i = 1 , nincx , Incx
               Dx(i) = Da*Dx(i)
            ENDDO
         ENDIF
      ENDIF
      CONTINUE
      END
!*==IDAMAX.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005
      INTEGER FUNCTION IDAMAX(N,Dx,Incx)

!     finds the index of element having max. dabsolute value.
!     jack dongarra, linpack, 3/11/78.

      DOUBLE PRECISION Dx(*) , dmax
      INTEGER i , Incx , ix , N

      IDAMAX = 0
      IF ( N.GE.1 ) THEN
         IDAMAX = 1
         IF ( N.NE.1 ) THEN
            IF ( Incx.EQ.1 ) THEN

!                 code for increment equal to 1

               dmax = DABS(Dx(1))
               DO i = 2 , N
                  IF ( DABS(Dx(i)).GT.dmax ) THEN
                     IDAMAX = i
                     dmax = DABS(Dx(i))
                  ENDIF
               ENDDO
            ELSE

!                 code for increment not equal to 1

               ix = 1
               dmax = DABS(Dx(1))
               ix = ix + Incx
               DO i = 2 , N
                  IF ( DABS(Dx(ix)).GT.dmax ) THEN
                     IDAMAX = i
                     dmax = DABS(Dx(ix))
                  ENDIF
                  ix = ix + Incx
               ENDDO
            ENDIF
         ENDIF
      ENDIF
      CONTINUE
      END
!*==EPSLON.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

      REAL*8 FUNCTION EPSLON(X)
      REAL*8 X

!     estimate unit roundoff in quantities of size x.

      REAL*8 a , b , c , eps

!     this program should function properly on all systems
!     satisfying the following two assumptions,
!     1.  the base used in representing dfloating point
!     numbers is not a power of three.
!     2.  the quantity  a  in statement 10 is represented to
!     the accuracy used in dfloating point variables
!     that are stored in memory.
!     the statement number 10 and the go to 10 are intended to
!     force optimizing compilers to generate code satisfying
!     assumption 2.
!     under these assumptions, it should be true that,
!     a  is not exactly equal to four-thirds,
!     b  has a zero for its last bit or digit,
!     c  is not exactly equal to one,
!     eps  measures the separation of 1.0 from
!     the next larger dfloating point number.
!     the developers of eispack would appreciate being informed
!     about any systems where these assumptions do not hold.

!     *****************************************************************
!     this routine is one of the auxiliary routines used by eispack iii
!     to avoid machine dependencies.
!     *****************************************************************

!     this version dated 4/6/83.

      a = 4.0D00/3.0D00
!     a = 4.0d00  * 0.33333333d00
      DO WHILE ( .TRUE. )
         b = a - 1.0D00
         c = b + b + b
         eps = DABS(c-1.0D00)
         IF ( eps.NE.0.0 ) GOTO 1
      ENDDO
 1    EPSLON = eps*DABS(X)
      CONTINUE
      END
!*==MM.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

!      DOUBLE PRECISION FUNCTION epslon(x)
!      DOUBLE PRECISION x

!     estimate unit roundoff in quantities of size x.

!      DOUBLE PRECISION a,b,c,eps

!     this program should function properly on all systems
!     satisfying the following two assumptions,
!     1.  the base used in representing dfloating point
!     numbers is not a power of three.
!     2.  the quantity  a  in statement 10 is represented to
!     the accuracy used in dfloating point variables
!     that are stored in memory.
!     the statement number 10 and the go to 10 are intended to
!     force optimizing compilers to generate code satisfying
!     assumption 2.
!     under these assumptions, it should be true that,
!     a  is not exactly equal to four-thirds,
!     b  has a zero for its last bit or digit,
!     c  is not exactly equal to one,
!     eps  measures the separation of 1.0 from
!     the next larger dfloating point number.
!     the developers of eispack would appreciate being informed
!     about any systems where these assumptions do not hold.

!     *****************************************************************
!     this routine is one of the auxiliary routines used by eispack iii
!     to avoid machine dependencies.
!     *****************************************************************

!     this version dated 4/6/83.

!      a = 4.0D0/3.0D0
!     a = 4.0d0 * 0.33333333d0
!	print*, 'In EPSLON'
!      DO WHILE ( .TRUE. )
!          b = a-1.0D0
!          c = b+b+b
!          eps = dabs(c-1.0D0)
!          IF ( eps .NE. 0.0D0 ) go to 1
!    1 END DO
!      print*, 'after loop'
!      epslon = eps*dabs(x)
!      RETURN
!      END

      SUBROUTINE MM(A,Lda,N1,N3,B,Ldb,N2,C,Ldc)
      DOUBLE PRECISION A(Lda,*) , B(Ldb,*) , C(Ldc,*)

!     purpose:
!     multiply matrix b times matrix c and store the result in matrix a.

!     parameters:

!     a double precision(lda,n3), matrix of n1 rows and n3 columns

!     lda integer, leading dimension of array a

!     n1 integer, number of rows in matrices a and b

!     n3 integer, number of columns in matrices a and c

!     b double precision(ldb,n2), matrix of n1 rows and n2 columns

!     ldb integer, leading dimension of array b

!     n2 integer, number of columns in matrix b, and number of rows in
!     matrix c

!     c double precision(ldc,n3), matrix of n2 rows and n3 columns

!     ldc integer, leading dimension of array c

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

      DO j = 1 , N3
         DO i = 1 , N1
            A(i,j) = 0.0
         ENDDO
         CALL DMXPY(N2,A(1,j),N1,Ldb,C(1,j),B)

      ENDDO
      CONTINUE
      END
!*==DMXPY.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005

      SUBROUTINE DMXPY(N1,Y,N2,Ldm,X,M)
      DOUBLE PRECISION Y(*) , X(*) , M(Ldm,*)

!     purpose:
!     multiply matrix m times vector x and add the result to vector y.

!     parameters:

!     n1 integer, number of elements in vector y, and number of rows in
!     matrix m

!     y double precision(n1), vector of length n1 to which is added
!     the product m*x

!     n2 integer, number of elements in vector x, and number of columns
!     in matrix m

!     ldm integer, leading dimension of array m

!     x double precision(n2), vector of length n2

!     m double precision(ldm,n2), matrix of n1 rows and n2 columns

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

!     cleanup odd vector

      j = MOD(N2,2)
      IF ( j.GE.1 ) THEN
         DO i = 1 , N1
            Y(i) = (Y(i)) + X(j)*M(i,j)
         ENDDO
      ENDIF

!     cleanup odd group of two vectors

      j = MOD(N2,4)
      IF ( j.GE.2 ) THEN
         DO i = 1 , N1
            Y(i) = ((Y(i))+X(j-1)*M(i,j-1)) + X(j)*M(i,j)
         ENDDO
      ENDIF

!     cleanup odd group of four vectors

      j = MOD(N2,8)
      IF ( j.GE.4 ) THEN
         DO i = 1 , N1
            Y(i) = ((((Y(i))+X(j-3)*M(i,j-3))+X(j-2)*M(i,j-2))+X(j-1)   &
     &             *M(i,j-1)) + X(j)*M(i,j)
         ENDDO
      ENDIF

!     cleanup odd group of eight vectors

      j = MOD(N2,16)
      IF ( j.GE.8 ) THEN
         DO i = 1 , N1
            Y(i) = ((((((((Y(i))+X(j-7)*M(i,j-7))+X(j-6)*M(i,j-6))+X(j-5&
     &             )*M(i,j-5))+X(j-4)*M(i,j-4))+X(j-3)*M(i,j-3))+X(j-2) &
     &             *M(i,j-2))+X(j-1)*M(i,j-1)) + X(j)*M(i,j)
         ENDDO
      ENDIF

!     main loop - groups of sixteen vectors

      jmin = j + 16
      DO j = jmin , N2 , 16
         DO i = 1 , N1
            Y(i) = ((((((((((((((((Y(i))+X(j-15)*M(i,j-15))+X(j-14)*M(i,&
     &             j-14))+X(j-13)*M(i,j-13))+X(j-12)*M(i,j-12))+X(j-11) &
     &             *M(i,j-11))+X(j-10)*M(i,j-10))+X(j-9)*M(i,j-9))      &
     &             +X(j-8)*M(i,j-8))+X(j-7)*M(i,j-7))+X(j-6)*M(i,j-6))  &
     &             +X(j-5)*M(i,j-5))+X(j-4)*M(i,j-4))+X(j-3)*M(i,j-3))  &
     &             +X(j-2)*M(i,j-2))+X(j-1)*M(i,j-1)) + X(j)*M(i,j)
         ENDDO
      ENDDO
      CONTINUE
      END


! The additional terms in the induction equation
! due to a time harmonic vertical field B_ac = B0 sin(wt) e_y

FUNCTION appliedB( model,n,t ) RESULT(c1)
   USE types

   TYPE(model_t) :: model
   INTEGER :: n
   REAL(KIND=dp) :: t,c1
   REAL(KIND=dp), PARAMETER :: B0=0.0001_dp, f=3_dp

! B_ac for nabla x ( v x B )
   c1 = B0 * SIN(2.0_dp*PI*f*t)

 END FUNCTION appliedB

FUNCTION applieddBdt( model,n,t ) RESULT(c2)
   USE types

   TYPE(model_t) :: model
   INTEGER :: n
   REAL(KIND=dp) :: t,c2,w
   REAL(KIND=dp), PARAMETER :: B0=0.0001_dp, f=3_dp

   w = 2.0_dp * PI * f
! -@B_ac/@t
   c2 = - B0 * w * COS(w*t)

 END FUNCTION applieddBdt


module pic

    use iso_c_binding
    implicit none

contains

pure integer function mod1( x, y)

integer(c_int32_t), intent(in) :: x
integer(c_int32_t), intent(in) :: y

mod1 = modulo(x-1, y) + 1

end function mod1

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

pure subroutine push_v( nbpart, p, dt, nx, ny, dx, dy, ex, ey, bz) bind(C, name="push_v")

integer(c_int32_t), intent(in) :: nbpart
real(c_double), intent(inout) :: p(5,nbpart)
real(c_double), intent(in) :: dt
integer(c_int32_t), intent(in) :: nx, ny
real(c_double), intent(in) :: dx, dy
real(c_double), intent(in) :: ex(nx+1,ny+1)
real(c_double), intent(in) :: ey(nx+1,ny+1)
real(c_double), intent(in) :: bz(nx+1,ny+1)

real(c_double) :: tantheta, sintheta
real(c_double) :: hdt, v1, v2, e1, e2, b3
real(c_double) :: a1, a2, a3, a4
real(c_double) :: xp, yp, dxp, dyp
integer(c_int32_t) :: i, j, ipart

hdt = 0.5 * dt

do ipart = 1, nbpart

   v1 = p(3,ipart)
   v2 = p(4,ipart)

   xp = p(1,ipart) / dx
   yp = p(2,ipart) / dy

   i = floor( xp ) + 1
   j = floor( yp ) + 1

   dxp = xp - i + 1
   dyp = yp - j + 1

   a1 = (1-dxp) * (1-dyp)
   a2 = dxp * (1-dyp)
   a3 = dxp * dyp
   a4 = (1-dxp) * dyp

   e1 = a1 * ex(i,j) + a2 * ex(i+1,j) + a3 * ex(i+1,j+1) + a4 * ex(i,j+1)
   e2 = a1 * ey(i,j) + a2 * ey(i+1,j) + a3 * ey(i+1,j+1) + a4 * ey(i,j+1)
   b3 = a1 * bz(i,j) + a2 * bz(i+1,j) + a3 * bz(i+1,j+1) + a4 * bz(i,j+1)

   v1 = v1 + hdt * e1
   v2 = v2 + hdt * e2

   tantheta = hdt * b3
   sintheta = 2.0 * tantheta / ( 1. + tantheta*tantheta)

   v1 = v1 + v2 * tantheta
   v2 = v2 - v1 * sintheta
   v1 = v1 + v2 * tantheta

   p(3,ipart) = v1 + hdt * e1
   p(4,ipart) = v2 + hdt * e2

end do

end subroutine push_v

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

pure subroutine push_x( nbpart, dimx, dimy, p, dt ) bind(C, name="push_x")

integer(c_int32_t), intent(in) :: nbpart
real(c_double), intent(in) :: dimx, dimy, dt
real(c_double), intent(inout) :: p(5,nbpart)
real(c_double) ::  p1, p2
integer :: ipart

do ipart=1,nbpart
   p1 = p(1,ipart) + p(3,ipart) * dt
   p2 = p(2,ipart) + p(4,ipart) * dt
   if ( p1 > dimx ) p1 = p1 - dimx
   if ( p1 < 0.0  ) p1 = p1 + dimx
   if ( p2 > dimy ) p2 = p2 - dimy
   if ( p2 < 0.0  ) p2 = p2 + dimy
   p(1,ipart) = p1
   p(2,ipart) = p2
end do

end subroutine push_x

pure subroutine deposition( nbpart, nx, ny, dx, dy, p, jx, jy ) bind(C, name="deposition")

integer(c_int32_t), intent(in) :: nbpart, nx, ny
real(c_double), intent(in)  :: dx, dy
real(c_double), intent(in)  :: p(5,nbpart)
real(c_double), intent(out) :: jx(nx+1,ny+1)
real(c_double), intent(out) :: jy(nx+1,ny+1)

real(c_double) :: a1, a2, a3, a4, w1, w2, xp, yp, dxp, dyp, factor
integer(c_int32_t) :: ipart, i, j

jx = 0.0
jy = 0.0

factor = real(nx * ny) / nbpart

do ipart=1,nbpart

   xp = p(1,ipart) / dx
   yp = p(2,ipart) / dy

   i = floor(xp) + 1
   j = floor(yp) + 1

   dxp = xp - i + 1
   dyp = yp - j + 1

   a1 = (1-dxp) * (1-dyp)
   a2 = dxp * (1-dyp)
   a3 = dxp * dyp
   a4 = (1-dxp) * dyp

   w1 = p(3,ipart) * factor
   w2 = p(4,ipart) * factor

   jx(i,j)     = jx(i,j)     + a1*w1
   jx(i+1,j)   = jx(i+1,j)   + a2*w1
   jx(i+1,j+1) = jx(i+1,j+1) + a3*w1
   jx(i,j+1)   = jx(i,j+1)   + a4*w1

   jy(i,j)     = jy(i,j)     + a1*w2
   jy(i+1,j)   = jy(i+1,j)   + a2*w2
   jy(i+1,j+1) = jy(i+1,j+1) + a3*w2
   jy(i,j+1)   = jy(i,j+1)   + a4*w2

end do

end subroutine deposition

end module pic