!=====================================================================!
! Module that contains handy linear algebra operations using LAPACK.
!=====================================================================!

module linear_algebra

  ! import dependencies
  use iso_fortran_env, only : dp => REAL64

  use lapack, only: dsyevd, dsygvd, ilaenv, zgetri, zgetrf, zheevd, &
                    dgeev , zgeev , zhegvd, dgesv , zgesv , dgetrf, &
                    dgetri, dgelsy, zgelsy, dgesvd, zgesvd

  ! disable implicit datatypes
  implicit none

  ! restrict access to all functions
  private

  ! expose only a required functions
  public :: eig, eigvals, eigh              ! eigenvals and vec
  public :: inv, solve, lstsq, svdvals, svd ! linear system
  public :: det, eye, diag, trace           ! matrix utils
  public :: assert, stop_error              ! misc

  ! Module parameters
  complex(dp), parameter :: i_ = (0, 1)

  !===================================================================!
  ! Eigen interfaces
  !===================================================================!

  ! eigenvalue/-vector problem for general matrices:
  interface eig
     module procedure deig
     module procedure zeig
  end interface eig

  ! eigenvalue/-vector problem for real symmetric/complex hermitian
  ! matrices:
  interface eigh
     module procedure deigh_generalized
     module procedure deigh_simple
     module procedure zeigh_generalized
     module procedure zeigh_simple
  end interface eigh

  ! eigenvalues for general matrices:
  interface eigvals
     module procedure deigvals
     module procedure zeigvals
  end interface eigvals

  !===================================================================!
  ! Linear solve interfaces
  !===================================================================!

  ! matrix inversion for real/complex matrices:
  interface inv
     module procedure dinv
     module procedure zinv
  end interface inv

  ! solution to linear systems of equation with real/complex
  ! coefficients:
  interface solve
     module procedure dsolve
     module procedure zsolve
  end interface solve

  ! least square solutions the real/complex systems of equations of
  ! possibly non-square shape:
  interface lstsq
     module procedure dlstsq
     module procedure zlstsq
  end interface lstsq

  ! singular values of real/complex matrices:
  interface svdvals
     module procedure dsvdvals
     module procedure zsvdvals
  end interface svdvals

  ! singular value decomposition of real/complex matrices:
  interface svd
     module procedure dsvd
     module procedure zsvd
  end interface svd

  !===================================================================!
  ! Utility interfaces
  !===================================================================!

  ! determinants of real/complex square matrices:
  interface det
     module procedure ddet
     module procedure zdet
  end interface det

  ! construction of square matrices from the diagonal elements:
  interface diag
     module procedure ddiag
     module procedure zdiag
  end interface diag

  ! trace of real/complex matrices:
  interface trace
     module procedure dtrace
     module procedure ztrace
  end interface trace

  ! assert shape of matrices:
  interface assert_shape
     module procedure dassert_shape
     module procedure zassert_shape
  end interface assert_shape

contains

  !-------------------------------------------------------------------!
  ! Get the eigenvalues and eigenvectors of a real matrix.
  !
  ! TODO: add optional switch for left or right eigenvectors in deig()
  ! and zeig()?
  ! -------------------------------------------------------------------!

  subroutine deig(A, lam, c)

    real(dp), intent(in)     :: A(:,:)  ! matrix for eigenvalue compuation
    complex(dp), intent(out) :: lam(:)  ! eigenvalues: A c = lam c
    complex(dp), intent(out) :: c(:,:)  ! eigenvectors: A c = lam c; c(i,j) = ith component of jth vec.

    ! LAPACK variables for DGEEV:
    real(dp), allocatable :: At(:,:), vl(:,: ), vr(:,:)
    real(dp), allocatable :: wi(:), work(:), wr(:)
    integer               :: info, lda, ldvl, ldvr, lwork, n, i

    preprocess: block

      ! Determine the size of the linear system
      lda = size(A(:,1))
      n = size(A(1,:))
      call assert_shape(A, [n, n], "solve", "A")
      call assert_shape(c, [n, n], "solve", "c")
      ldvl = n
      ldvr = n
      lwork = 8*n  ! TODO: can this size be optimized? query first?
      allocate(At(lda,n), wr(n), wi(n), vl(ldvl,n), vr(ldvr,n), work(lwork))
      At = A

    end block preprocess

    solve: block

      ! Call LAPACK to find the eigen values and vectors
      call dgeev('N', 'V', n, At, lda, wr, wi, vl, ldvl, vr, ldvr, &
           work, lwork, info)

    end block solve

    postprocess: block

      if (info .ne. 0) then
         print *, "dgeev returned info = ", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "the QR algorithm failed to compute all the"
            print *, "eigenvalues, and no eigenvectors have been computed;"
            print *, "elements ", info+1, ":", n, "of WR and WI contain eigenvalues which"
            print *, "have converged."
         end if
         call stop_error('eig: dgeev error')
      end if

      lam = wr + i_*wi
      ! As DGEEV has a rather complicated way of returning the
      ! eigenvectors, it is necessary to build the complex array of
      ! eigenvectors from two real arrays:
      do concurrent (i = 1: n)
         if (wi(i) > 0.0) then
            ! first of two conjugate eigenvalues
            c(:, i) = vr(:, i) + i_*vr(:, i+1)
         elseif (wi(i) < 0.0_dp) then
            ! second of two conjugate eigenvalues
            c(:, i) = vr(:, i-1) - i_*vr(:, i)
         else
            c(:, i) = vr(:, i)
         end if
      end do

    end block postprocess

  end subroutine deig

  !-------------------------------------------------------------------!
  ! Get the eigenvalues and eigenvectors of a complex matrix.
  !
  ! TODO: add optional switch for left or right eigenvectors in deig()
  ! and zeig()?
  !-------------------------------------------------------------------!

  subroutine zeig(A, lam, c)

    complex(dp), intent(in)  :: A(:, :) ! matrix to solve eigenproblem for
    complex(dp), intent(out) :: lam(:)  ! eigenvalues: A c = lam c
    complex(dp), intent(out) :: c(:,:)  ! eigenvectors: A c = lam c;
                                        ! c(i,j) = ith component of
                                        ! jth vec.

    ! LAPACK variables:
    integer                  :: info, lda, ldvl, ldvr, lwork, n, lrwork
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: vl(:,:), vr(:,:), work(:)

    preprocess: block

      ! Determine the size of matrix
      lda = size(A(:,1))
      n = size(A(1,:))
      call assert_shape(A, [n, n], "solve", "A")
      call assert_shape(c, [n, n], "solve", "c")
      ldvl = n
      ldvr = n
      lwork = 8*n  ! TODO: can this size be optimized? query first?
      lrwork = 2*n
      allocate(vl(ldvl,n), vr(ldvr,n), work(lwork), rwork(lrwork))
      c = A

    end block preprocess

    solve: block

      ! Find the eigen values
      call zgeev('N', 'V', n, c, lda, lam, vl, ldvl, vr, ldvr, work, &
           lwork, rwork, info)

    end block solve

    postprocess: block

      if (info .ne. 0) then
         print *, "zgeev returned info = ", info
         if (info .lt. 0) then
            print *, "the ",-info, "-th argument had an illegal value."
         else
            print *, "the QR algorithm failed to compute all the"
            print *, "eigenvalues, and no eigenvectors have been computed;"
            print *, "elements and ", info+1, ":", n, " of W contain eigenvalues which have"
            print *, "converged."
         end if
         call stop_error('eig: zgeev error')
      end if

      c = vr

    end block postprocess

  end subroutine zeig

  !-------------------------------------------------------------------!
  ! Returns the eigen values of the matrix
  !-------------------------------------------------------------------!

  function deigvals(A) result(lam)

    real(dp), intent(in)     :: A(:, :) ! matrix for eigenvalue compuation
    complex(dp), allocatable :: lam(:)  ! eigenvalues: A c = lam c

    ! LAPACK variables for DGEEV:
    real(dp), allocatable :: At(:,:), vl(:,: ), vr(:,:)
    real(dp), allocatable :: wi(:), work(:), wr(:)
    integer               :: info, lda, ldvl, ldvr, lwork, n

    preprocess: block

      ! Determine the size of the matrix
      lda = size(A(:,1))
      n = size(A(1,:))
      call assert_shape(A, [n, n], "solve", "A")
      ldvl = n
      ldvr = n
      lwork = 8*n  ! TODO: can this size be optimized? query first?
      allocate(At(lda,n), wr(n), wi(n), vl(ldvl,n), vr(ldvr,n), work(lwork), lam(n))
      At = A

    end block preprocess

    solve: block

      ! Determine the eigenvalues
      call dgeev('N', 'N', n, At, lda, wr, wi, vl, ldvl, vr, ldvr, &
           work, lwork, info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "dgeev returned info = ", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "the QR algorithm failed to compute all the"
            print *, "eigenvalues, and no eigenvectors have been computed;"
            print *, "elements ", info+1, ":", n, "of WR and WI contain eigenvalues which"
            print *, "have converged."
         end if
         call stop_error('eigvals: dgeev error')
      end if

      lam = wr + i_*wi

    end block postprocess

  end function deigvals

  !===================================================================!
  ! Eigenvalues of a complex matrix
  !===================================================================!

  function zeigvals(A) result(lam)

    complex(dp), intent(in)  :: A(:, :)  ! matrix to solve eigenproblem for
    complex(dp), allocatable :: lam(:)  ! eigenvalues: A c = lam c

    ! LAPACK variables:
    integer                  :: info, lda, ldvl, ldvr, lwork, n, lrwork
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: At(:,:), vl(:,:), vr(:,:), work(:)

    preprocess: block

      ! Determine the size of the matrix
      lda = size(A(:,1))
      n = size(A(1,:))
      call assert_shape(A, [n, n], "solve", "A")
      ldvl = n
      ldvr = n
      lwork = 8*n  ! TODO: can this size be optimized? query first?
      lrwork = 2*n
      allocate(At(lda,n), &
           & vl(ldvl,n), vr(ldvr,n), &
           & work(lwork), rwork(lrwork), lam(n))
      At = A

    end block preprocess

    solve: block

      ! Determine the eigen values
      call zgeev('N', 'N', n, At, lda, lam, vl, ldvl, vr, ldvr, work, &
           lwork, rwork, info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "zgeev returned info = ", info
         if (info .lt. 0) then
            print *, "the ",-info, "-th argument had an illegal value."
         else
            print *, "the QR algorithm failed to compute all the"
            print *, "eigenvalues, and no eigenvectors have been computed;"
            print *, "elements and ", info+1, ":", n, " of W contain eigenvalues which have"
            print *, "converged."
         end if
         call stop_error('eig: zgeev error')
      end if

    end block postprocess

  end function zeigvals

  !-------------------------------------------------------------------!
  ! Solves generalized eigen value problem for all eigenvalues and
  ! eigenvectors. Am must be symmetric and Bm symmetric positive
  ! definite. Only the lower triangular part of Am and Bm is used in
  ! computations.
  !-------------------------------------------------------------------!

  subroutine deigh_generalized(Am, Bm, lam, c)

    real(dp), intent(in)  :: Am(:,:)  ! LHS matrix: Am c = lam Bm c
    real(dp), intent(in)  :: Bm(:,:)  ! RHS matrix: Am c = lam Bm c
    real(dp), intent(out) :: lam(:)   ! eigenvalues: Am c = lam Bm c
    real(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam Bm c;
                                      ! c(i,j) = ith component of jth
                                      ! vec.
    integer :: n

    ! LLAPACK variables
    integer               :: lwork, liwork, info
    integer, allocatable  :: iwork(:)
    real(dp), allocatable :: Bmt(:,:), work(:)

    preprocess: block

      ! Matrix size
      n = size(Am,1)
      call assert_shape(Am, [n, n], "eigh", "Am")
      call assert_shape(Bm, [n, n], "eigh", "B")
      call assert_shape(c, [n, n], "eigh", "c")

      ! Determine the work size arrays
      lwork = 1 + 6*n + 2*n**2
      liwork = 3 + 5*n
      allocate(Bmt(n,n), work(lwork), iwork(liwork))
      c = Am; Bmt = Bm  ! Bmt temporaries overwritten by dsygvd

    end block preprocess

    solve: block

      call dsygvd(1,'V','L',n,c,n,Bmt,n,lam,work,lwork,iwork,liwork,info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "dsygvd returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else if (info .le. n) then
            print *, "the algorithm failed to compute an eigenvalue while working"
            print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
            print *, "through", mod(info, n+1)
         else
            print *, "The leading minor of order ", info-n, &
                 "of B is not positive definite. The factorization of B could ", &
                 "not be completed and no eigenvalues or eigenvectors were computed."
         end if
         call stop_error('eigh: dsygvd error')
      end if

    end block postprocess

  end subroutine deigh_generalized

  !-------------------------------------------------------------------!
  ! Solves eigenvalue problem for all eigenvalues and eigenvectors. Am
  ! must by symmetric. Only the lower triangular part of Am is used.
  !-------------------------------------------------------------------!

  subroutine deigh_simple(Am, lam, c)

    real(dp), intent(in)  :: Am(:,:)  ! LHS matrix: Am c = lam c
    real(dp), intent(out) :: lam(:)   ! eigenvalues: Am c = lam c
    real(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam c;
                                      ! c(i,j) = ith component of jth
                                      ! vec.
    integer               :: n

    ! Lapack variables
    integer               :: lwork, liwork, info
    integer, allocatable  :: iwork(:)
    real(dp), allocatable :: work(:)

    preprocess: block

      ! Determine space
      n = size(Am,1)
      call assert_shape(Am, [n, n], "eigh", "Am")
      call assert_shape(c, [n, n], "eigh", "c")
      lwork = 1 + 6*n + 2*n**2
      liwork = 3 + 5*n
      allocate(work(lwork), iwork(liwork))
      c = Am

    end block preprocess

    solve: block

      ! Solve
      call dsyevd('V','L',n,c,n,lam,work,lwork,iwork,liwork,info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "dsyevd returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "the algorithm failed to compute an eigenvalue while working"
            print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
            print *, "through", mod(info, n+1)
         end if
         call stop_error('eigh: dsyevd error')
      end if

    end block postprocess

  end subroutine deigh_simple

  !-------------------------------------------------------------------!
  ! Solves generalized eigen value problem for all eigenvalues and
  ! eigenvectors Am must by hermitian, Bm hermitian positive definite.
  ! Only the lower triangular part of Am and Bm is used.
  !-------------------------------------------------------------------!

  subroutine zeigh_generalized(Am, Bm, lam, c)

    complex(dp), intent(in)  :: Am(:,:)   ! LHS matrix: Am c = lam Bm c
    complex(dp), intent(in)  :: Bm(:,:)   ! RHS matrix: Am c = lam Bm c
    real(dp), intent(out)    :: lam(:)      ! eigenvalues: Am c = lam Bm c
    complex(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam Bm c; c(i,j) = ith component of jth vec.

    ! LAPACK variables
    integer                  :: info, liwork, lrwork, lwork, n
    integer, allocatable     :: iwork(:)
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: Bmt(:,:), work(:)

    preprocess: block

      ! Determine shape
      n = size(Am,1)
      call assert_shape(Am, [n, n], "eigh", "Am")
      call assert_shape(Bm, [n, n], "eigh", "Bm")
      call assert_shape(c, [n, n], "eigh", "c")
      lwork = 2*n + n**2
      lrwork = 1 + 5*N + 2*n**2
      liwork = 3 + 5*n
      allocate(Bmt(n,n), work(lwork), rwork(lrwork), iwork(liwork))
      c = Am; Bmt = Bm  ! Bmt temporary overwritten by zhegvd

    end block preprocess

    solve: block

      ! Solve using lapack
      call zhegvd(1,'V','L',n,c,n,Bmt,n,lam,work,lwork,rwork,lrwork,iwork,liwork,info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "zhegvd returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else if (info .le. n) then
            print *, "the algorithm failed to compute an eigenvalue while working"
            print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
            print *, "through", mod(info, n+1)
         else
            print *, "The leading minor of order ", info-n, &
                 "of B is not positive definite. The factorization of B could ", &
                 "not be completed and no eigenvalues or eigenvectors were computed."
         end if
         call stop_error('eigh: zhegvd error')
      end if

    end block postprocess

  end subroutine zeigh_generalized

  !-------------------------------------------------------------------!
  ! Solves eigenvalue problem for all eigenvalues and eigenvectors. Am
  ! must by symmetric Only the lower triangular part of Am is used.
  !-------------------------------------------------------------------!

  subroutine zeigh_simple(Am, lam, c)

    complex(dp), intent(in)  :: Am(:,:)   ! LHS matrix: Am c = lam c
    real(dp), intent(out)    :: lam(:)   ! eigenvalues: Am c = lam c
    complex(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam c; c(i,j) = ith component of jth vec.

    ! LAPACK variables:
    integer                  :: info, lda, liwork, lrwork, lwork, n
    integer, allocatable     :: iwork(:)
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: work(:)

    preprocess: block

      ! use LAPACK's zheevd routine
      n = size(Am, 1)
      call assert_shape(Am, [n, n], "eigh", "Am")
      call assert_shape(c, [n, n], "eigh", "c")
      lda = max(1, n)
      lwork = 2*n + n**2
      lrwork = 1 + 5*n + 2*n**2
      liwork = 3 + 5*n
      allocate(work(lwork), rwork(lrwork), iwork(liwork))
      c = Am

    end block preprocess

    solve: block

      ! Solve
      call zheevd("V", "L", n, c, lda, lam, work, lwork, rwork, lrwork, &
           iwork, liwork, info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "zheevd returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "the algorithm failed to compute an eigenvalue while working"
            print *, "through the submatrix lying in rows and columns through"
            print *, info/(n+1), " through ", mod(info, n+1)
         end if
         call stop_error('eigh: zheevd error')
      end if

    end block postprocess

  end subroutine zeigh_simple

  !-------------------------------------------------------------------!
  ! Return the inverse of a real matrix
  !-------------------------------------------------------------------!

  function dinv(Am) result(Bm)

    real(dp), intent(in)  :: Am(:,:)  ! matrix to be inverted
    real(dp)              :: Bm(size(Am, 1), size(Am, 2))   ! Bm = inv(Am)
    real(dp), allocatable :: Amt(:,:), work(:)  ! temporary work arrays

    ! LAPACK variables:
    integer              ::  info, lda, n, lwork, nb
    integer, allocatable :: ipiv(:)

    ! use LAPACK's dgetrf and dgetri
    n = size(Am(1, :))
    call assert_shape(Am, [n, n], "inv", "Am")
    lda = n
    nb = ilaenv(1, 'DGETRI', "UN", n, -1, -1, -1)  ! TODO: check UN param
    lwork = n*nb
    if (nb .lt. 1) nb = max(1, n)
    allocate(Amt(n,n), work(lwork), ipiv(n))
    Amt = Am

    ! Solve
    call dgetrf(n, n, Amt, lda, ipiv, info)

    ! Post process
    if (info .ne. 0) then
       print *, "dgetrf returned info =", info
       if (info .lt. 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, and division by zero will occur if it is used"
          print *, "to solve a system of equations."
       end if
       call stop_error('inv: dgetrf error')
    end if

    ! Solve
    call dgetri(n, Amt, n, ipiv, work, lwork, info)

    ! Post process
    if (info .ne. 0) then
       print *, "dgetri returned info =", info
       if (info .lt. 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; the matrix is"
          print *, "singular and its inverse could not be computed."
       end if
       call stop_error('inv: dgetri error')
    end if

    ! Result
    Bm = Amt

  end function dinv

  !-------------------------------------------------------------------!
  ! Inverse of a complex matrix
  !-------------------------------------------------------------------!

  function zinv(Am) result(Bm)

    ! Inverts the general complex matrix Am
    complex(dp), intent(in) :: Am(:,:)   ! Matrix to be inverted
    complex(dp)             :: Bm(size(Am, 1), size(Am, 2))   ! Bm = inv(Am)
    integer                 :: n, nb

    ! LAPACK variables
    integer                  :: lwork, info
    complex(dp), allocatable :: Amt(:,:), work(:)
    integer, allocatable     :: ipiv(:)

    ! Determine size
    n = size(Am, 1)
    call assert_shape(Am, [n, n], "inv", "Am")
    nb = ilaenv(1, 'ZGETRI', "UN", n, -1, -1, -1) ! TODO: check UN param
    if (nb .lt. 1) nb = max(1, n)
    lwork = n*nb
    allocate(Amt(n,n), ipiv(n), work(lwork))
    Amt = Am

    ! Solve
    call zgetrf(n, n, Amt, n, ipiv, info)

    ! Post process
    if (info .ne. 0) then
       print *, "zgetrf returned info =", info
       if (info .lt. 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, and division by zero will occur if it is used"
          print *, "to solve a system of equations."
       end if
       call stop_error('inv: zgetrf error')
    end if

    ! Solve
    call zgetri(n, Amt, n, ipiv, work, lwork, info)
    if (info .ne. 0) then
       print *, "zgetri returned info =", info
       if (info .lt. 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; the matrix is"
          print *, "singular and its inverse could not be computed."
       end if
       call stop_error('inv: zgetri error')
    end if

    Bm = Amt

  end function zinv

  !-------------------------------------------------------------------!
  ! Solves a system of equations A x = b with one right hand side
  !-------------------------------------------------------------------!

  function dsolve(A, b) result(x)

    real(dp), intent(in)  :: A(:,:)  ! coefficient matrix A
    real(dp), intent(in)  :: b(:)  ! right-hand-side A x = b
    real(dp), allocatable :: x(:)

    ! LAPACK variables:
    real(dp), allocatable :: At(:,:), bt(:,:)
    integer               :: n, info, lda
    integer, allocatable  :: ipiv(:)

    preprocess: block

      ! Determine size
      n = size(A(1,:))
      lda = size(A(:, 1))  ! TODO: remove lda (which is = n!)
      call assert_shape(A, [n, n], "solve", "A")
      allocate(At(lda,n), bt(n,1), ipiv(n), x(n))
      At = A
      bt(:,1) = b(:)

    end block preprocess

    solve: block

      ! Solve the linear system
      call dgesv(n, 1, At, lda, ipiv, bt, n, info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "dgesv returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "U(", info, ",", info, ") is exactly zero; The factorization"
            print *, "has been completed, but the factor U is exactly"
            print *, "singular, so the solution could not be computed."
         end if
         call stop_error('inv: dgesv error')
      end if

      ! Store the result
      x = bt(:,1)

    end block postprocess

  end function dsolve

  !-------------------------------------------------------------------!
  ! Solves a system of equations A x = b with one right hand side
  !-------------------------------------------------------------------!

  function zsolve(A, b) result(x)

    complex(dp), intent(in)  :: A(:,:)  ! coefficient matrix A
    complex(dp), intent(in)  :: b(:)    ! right-hand-side A x = b
    complex(dp), allocatable :: x(:)

    ! LAPACK variables:
    complex(dp), allocatable :: At(:,:), bt(:,:)
    integer                  :: n, info, lda
    integer, allocatable     :: ipiv(:)

    preprocess: block
      ! Determine size
      n = size(A(1,:))
      lda = size(A(:, 1))  ! TODO: remove lda here, too
      call assert_shape(A, [n, n], "solve", "A")
      allocate(At(lda,n), bt(n,1), ipiv(n), x(n))
      At = A
      bt(:,1) = b(:)
    end block preprocess

    solve: block
      ! Solve using LAPACK
      call zgesv(n, 1, At, lda, ipiv, bt, n, info)
    end block solve

    postprocess: block
      ! Post process
      if (info .ne. 0) then
         print *, "zgesv returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "U(", info, ",", info, ") is exactly zero; The factorization"
            print *, "has been completed, but the factor U is exactly"
            print *, "singular, so the solution could not be computed."
         end if
         call stop_error('inv: zgesv error')
      end if

      ! Store the result
      x = bt(:,1)
    end block postprocess

  end function zsolve

  !-------------------------------------------------------------------!
  ! Generates a nxn identity matrix
  !-------------------------------------------------------------------!

  pure function eye(n)

    integer, intent(in) :: n
    real(dp)    :: eye(n,n)
    integer     :: i, j

    ! generate a zero matrix
    eye = 0.0_dp

    ! replace the diagonals with one
    forall(i=1:n)
       eye(i,i) = 1.0_dp
    end forall

  end function eye

  !-------------------------------------------------------------------!
  ! A function that returns the determinant value of the matrix. This
  ! computes the determinant of a REAL matrix using an LU
  ! factorization.
  !-------------------------------------------------------------------!

  real(dp) function ddet(A) result(x)

    real(dp), intent(in) :: A(:, :)
    integer              :: i

    ! LAPACK variables:
    integer               :: info, n
    integer, allocatable  :: ipiv(:)
    real(dp), allocatable :: At(:,:)

    preprocess: block

      ! Determine the size of the linear system
      n = size(A(1,:))
      call assert_shape(A, [n, n], "det", "A")

      !allocate(At, source=A) ! not supported by compiler yet

      ! Make a copy of the matrix as the input is modified in LU
      ! decomposition
      allocate(At(n,n), ipiv(n))
      At = A

    end block preprocess

    solve: block

      ! LU decomposition on the temp matrix
      call dgetrf(n, n, At, n, ipiv, info)

    end block solve

    postprocess: block

      ! Check the LAPACK output flag for potential issues in solution
      if (info .ne. 0) then
         print *, "dgetrf returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "U(", info, ",", info, ") is exactly zero; The factorization"
            print *, "has been completed, but the factor U is exactly"
            print *, "singular, and division by zero will occur if it is used"
            print *, "to solve a system of equations."
         end if
         call stop_error('det: dgetrf error')
      end if

      ! At now contains the LU of the factorization A = PLU as L has
      ! unit diagonal entries, the determinant can be computed from the
      ! product of U's diagonal entries. Additional sign changes
      ! stemming from the permutations P have to be taken into account
      ! as well.
      x = 1.0_dp
      do i = 1, n
         if (ipiv(i) .ne. i) then  ! additional sign change
            x = -x*At(i,i)
         else
            x = x*At(i,i)
         end if
      end do

    end block postprocess

  end function ddet

  !-------------------------------------------------------------------!
  ! A function that returns the determinant value of the matrix. This
  ! computes the determinant of a COMPLEX matrix using an LU
  ! factorization.
  !-------------------------------------------------------------------!

  complex(dp) function zdet(A) result(x)

    complex(dp), intent(in) :: A(:, :)
    integer                 :: i

    ! LAPACK variables:
    integer                  :: info, n
    integer, allocatable     :: ipiv(:)
    complex(dp), allocatable :: At(:,:)

    preprocess: block

      ! Determine the size of the linear system
      n = size(A(1,:))
      call assert_shape(A, [n, n], "det", "A")

      ! Make a copy of the matrix as the input is modified in LU
      ! decomposition
      allocate(At(n,n), ipiv(n))
      At = A

    end block preprocess

    solve: block

      ! LU decomposition on the temp matrix
      call zgetrf(n, n, At, n, ipiv, info)

    end block solve

    postprocess: block

      ! Check the LAPACK output flag for potential issues in solution
      if (info .ne. 0) then
         print *, "zgetrf returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "U(", info, ",", info, ") is exactly zero; The factorization"
            print *, "has been completed, but the factor U is exactly"
            print *, "singular, and division by zero will occur if it is used"
            print *, "to solve a system of equations."
         end if
         call stop_error('inv: zgetrf error')
      end if

      ! Compute the determinant (see ddet for details)
      x = 1.0_dp + 0*i_
      do i = 1, n
         if (ipiv(i) .ne. i) then  ! additional sign change
            x = -x*At(i,i)
         else
            x = x*At(i,i)
         end if
      end do

    end block postprocess

  end function zdet

  !-------------------------------------------------------------------!
  ! Compute least square solution to A x = b for real A, b
  !-------------------------------------------------------------------!

  function dlstsq(A, b) result(x)

    real(dp), intent(in)  :: A(:,:), b(:)
    real(dp), allocatable :: x(:)

    ! LAPACK variables:
    integer               :: info, ldb, lwork, m, n, rank
    real(dp)              :: rcond
    real(dp), allocatable :: work(:), At(:,:), Bt(:,:)
    integer, allocatable  :: jpvt(:)

    ! Handle allocations
    preprocess: block

      ! Determine the matrix size
      m = size(A(:,1)) ! = lda
      n = size(A(1,:))
      ldb = size(b)

      ! Determine the optimal workspace size
      allocate(x(n), At(m,n), Bt(ldb,1), jpvt(n), work(1))
      call dgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
           -1, info)  ! query optimal workspace size
      lwork = int(real(work(1)))
      deallocate(work)

      ! Allocate with optimal size
      allocate(work(lwork))  ! allocate with ideal size
      rcond = 0.0_dp
      jpvt(:) = 0
      Bt(:,1) = b(:)  ! only one right-hand side
      At(:,:) = A(:,:)

    end block preprocess

    solve: block

      ! Call LAPACK for lease squares solution
      call dgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
           lwork, info)

    end block solve

    postprocess: block

      ! Find any error code
      if (info .ne. 0) then
         print *, "dgelsy returned info = ", info
         print *, "the ", -info, "-th argument had an illegal value"
         call stop_error('lstsq: dgelsy error')
      end if

      ! Store the solution
      x(:) = Bt(1:n,1)

    end block postprocess

  end function dlstsq

  !-------------------------------------------------------------------!
  ! Compute least square solution to A x = b for complex A, b
  !-------------------------------------------------------------------!

  function zlstsq(A, b) result(x)

    complex(dp), intent(in)  :: A(:,:), b(:)
    complex(dp), allocatable :: x(:)

    ! LAPACK variables:
    integer                  :: info, ldb, lwork, m, n, rank
    real(dp)                 :: rcond
    complex(dp), allocatable :: At(:,:), Bt(:,:), work(:)
    real(dp), allocatable    :: rwork(:)
    integer, allocatable     :: jpvt(:)

    preprocess: block

      ! Determine the matrix size
      m = size(A(:,1)) ! = lda
      n = size(A(1,:))
      ldb = size(b)

      ! Query optimal workspace size
      allocate(x(n), At(m,n), Bt(ldb,1), jpvt(n), work(1), rwork(2*n))
      call zgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
           -1, rwork, info)
      lwork = int(real(work(1)))
      deallocate(work)

      ! Allocate the optimal (ideal) workspace size
      allocate(work(lwork))
      rcond = 0.0_dp
      jpvt(:) = 0
      Bt(:,1) = b(:)  ! only one right-hand side
      At(:,:) = A(:,:)

    end block preprocess

    solve: block

      ! Call LAPACK to solve the system
      call zgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
           lwork, rwork, info)

    end block solve

    ! Post process
    postprocess: block

      if (info /= 0) then
         print *, "zgelsy returned info = ", info
         print *, "the ", -info, "-th argument had an illegal value"
         call stop_error('lstsq: zgelsy error')
      end if

      ! Store the results
      x(:) = Bt(1:n,1)

    end block postprocess

  end function zlstsq

  !-------------------------------------------------------------------!
  ! Construct real matrix from diagonal elements
  !-------------------------------------------------------------------!

  pure function ddiag(x) result(A)

    real(dp), intent(in)  :: x(:)
    real(dp), allocatable :: A(:,:)
    integer               :: i, n

    n = size(x)

    allocate(A(n,n))
    A = 0.0_dp

    forall(i=1:n) A(i,i) = x(i)

  end function ddiag

  !-------------------------------------------------------------------!
  ! Construct complex matrix from diagonal elements
  !-------------------------------------------------------------------!

  pure function zdiag(x) result(A)

    complex(dp), intent(in)  :: x(:)
    complex(dp), allocatable :: A(:,:)
    integer                  :: i, n

    n = size(x)

    allocate(A(n,n))

    A = 0*i_

    forall(i=1:n) A(i,i) = x(i)

  end function zdiag

  !-------------------------------------------------------------------!
  ! Return trace along the main diagonal of a real matrix
  !-------------------------------------------------------------------!

  pure real(dp) function dtrace(A) result(t)

    real(dp), intent(in) :: A(:,:)
    integer              :: i

    t = 0.0_dp
    do i = 1, minval(shape(A))
       t = t + A(i,i)
    end do

  end function dtrace

  !-------------------------------------------------------------------!
  ! Return trace along the main diagonal of a real matrix
  !-------------------------------------------------------------------!

  pure complex(dp) function ztrace(A) result(t)

    complex(dp), intent(in) :: A(:,:)
    integer                 :: i

    t = 0*i_
    do i = 1, minval(shape(A))
       t = t + A(i,i)
    end do

  end function ztrace

  !-------------------------------------------------------------------!
  ! Find the singular values s_i of a real m x n matrix
  !-------------------------------------------------------------------!

  function dsvdvals(A) result(s)

    real(dp), intent(in)  :: A(:,:)
    real(dp), allocatable :: s(:)

    ! LAPACK related:
    integer               :: info, lwork, m, n
    real(dp), allocatable :: work(:), At(:,:)
    real(dp)              :: u(1,1), vt(1,1)  ! not used if only s is
                                              ! to be computed
    preprocess: block

      m = size(A(:,1))  ! = lda
      n = size(A(1,:))
      allocate(At(m,n), s(min(m,n)))
      At(:,:) = A(:, :)  ! A is overwritten in dgesvd

      ! Query optimal lwork and allocate workspace:
      allocate(work(1))
      call dgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, -1, info)
      lwork = int(real(work(1)))
      deallocate(work)
      allocate(work(lwork))

    end block preprocess

    solve: block

      ! Compute the singular value decomposition
      call dgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, lwork, info)

    end block solve

    postprocess: block

      if (info .ne. 0) then
         print *, "dgesvd returned info = ", info
         if (info .lt. 0) then
            print *, "the ", -info, "-th argument had an illegal value"
         else
            print *, "DBDSQR did not converge, there are ", info
            print *, "superdiagonals of an intermediate bidiagonal form B"
            print *, "did not converge to zero. See the description of WORK"
            print *, "in DGESVD's man page for details."
         end if
         call stop_error('svdvals: dgesvd error')
      end if

    end block postprocess

  end function dsvdvals

  !-------------------------------------------------------------------!
  ! Find the singular values s_i of a complex m x n matrix
  !-------------------------------------------------------------------!

  function zsvdvals(A) result(s)

    complex(dp), intent(in) :: A(:,:)
    real(dp), allocatable   :: s(:)

    ! LAPACK related:
    integer                  :: info, lwork, m, n, lrwork
    complex(dp), allocatable :: work(:), At(:,:)
    real(dp), allocatable    :: rwork(:)
    complex(dp)              :: u(1,1), vt(1,1)  ! not used if only s is to be computed

    preprocess: block

      ! Determine size and allocate space
      m = size(A(:,1))  ! = lda
      n = size(A(1,:))
      lrwork = 5*min(m,n)
      allocate(At(m,n), s(min(m,n)), rwork(lrwork))
      At(:,:) = A(:,:)  ! A is overwritten in zgesvd!

      ! Query optimal lwork and allocate workspace
      allocate(work(1))
      call zgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, -1, rwork, info)
      lwork = int(real(work(1)))
      deallocate(work)
      allocate(work(lwork))

    end block preprocess

    solve: block

      ! Compute the singular value decomposition
      call zgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, lwork, rwork, info)

    end block solve

    postprocess: block

      if (info .ne. 0) then
         print *, "zgesvd returned info = ", info
         if (info .lt. 0) then
            print *, "the ", -info, "-th argument had an illegal value"
         else
            print *, "ZBDSQR did not converge, there are ", info
            print *, "superdiagonals of an intermediate bidiagonal form B"
            print *, "did not converge to zero. See the description of RWORK"
            print *, "in ZGESVD's man page for details."
         end if
         call stop_error('svdvals: zgesvd error')
      end if

    end block postprocess

  end function zsvdvals

  !-------------------------------------------------------------------!
  ! compute the singular value decomposition A = U sigma V^T of a real
  ! m x n matrix A. U is m x m. V^T is n x n. s has size min(m, n) -->
  ! sigma matrix is (n x m) with sigma_ii = s_i
  ! -------------------------------------------------------------------!

  subroutine dsvd(A, s, U, Vtransp)

    real(dp), intent(in)  :: A(:,:)
    real(dp), intent(out) :: s(:), U(:,:), Vtransp(:,:)

    ! LAPACK related:
    integer               :: info, lwork, m, n, ldu
    real(dp), allocatable :: work(:), At(:,:)

    preallocate: block

      m = size(A(:,1))  ! = lda
      n = size(A(1,:))
      ldu = m
      allocate(At(m,n))
      At(:,:) = A(:,:)  ! use a temporary as dgesvd destroys its input

      call assert_shape(U, [m, m], "svd", "U")
      call assert_shape(Vtransp, [n, n], "svd", "Vtransp")

      ! query optimal lwork and allocate workspace:
      allocate(work(1))
      call dgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, -1, info)
      lwork = int(real(work(1)))
      deallocate(work)
      allocate(work(lwork))

    end block preallocate

    solve: block

      call dgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, lwork, info)

    end block solve

    postprocess: block

      if (info /= 0) then
         print *, "dgesvd returned info = ", info
         if (info < 0) then
            print *, "the ", -info, "-th argument had an illegal value"
         else
            print *, "DBDSQR did not converge, there are ", info
            print *, "superdiagonals of an intermediate bidiagonal form B"
            print *, "did not converge to zero. See the description of WORK"
            print *, "in DGESVD's man page for details."
         end if
         call stop_error('svd: dgesvd error')
      end if

    end block postprocess

  end subroutine dsvd

  !-------------------------------------------------------------------!
  ! compute the singular value decomposition A = U sigma V^H of a
  ! complex m x m matrix A
  ! U is m x min(m, n)
  ! Vtransp is n x n
  ! sigma is m x n with with sigma_ii = s_i
  ! note that this routine returns V^H, not V!
  !-------------------------------------------------------------------!

  subroutine zsvd(A, s, U, Vtransp)

    complex(dp), intent(in)  :: A(:,:)
    real(dp), intent(out)    :: s(:)
    complex(dp), intent(out) :: U(:,:), Vtransp(:,:)

    ! LAPACK related:
    integer                  :: info, lwork, m, n, ldu, lrwork
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: work(:), At(:,:)

    ! TODO: check shapes here and in other routines?

    preprocess: block

      m = size(A(:,1))  ! = lda
      n = size(A(1,:))
      ldu = m
      lrwork = 5*min(m,n)
      allocate(rwork(lrwork), At(m,n))
      At(:,:) = A(:,:)  ! use a temporary as zgesvd destroys its input

      call assert_shape(U, [m, m], "svd", "U")
      call assert_shape(Vtransp, [n, n], "svd", "Vtransp")

      ! query optimal lwork and allocate workspace:
      allocate(work(1))
      call zgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, -1,&
           rwork, info)
      lwork = int(real(work(1)))
      deallocate(work)
      allocate(work(lwork))

    end block preprocess

    solve: block

      call zgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, &
           lwork, rwork, info)

    end block solve

    postprocess: block

      if (info /= 0) then
         print *, "zgesvd returned info = ", info
         if (info < 0) then
            print *, "the ", -info, "-th argument had an illegal value"
         else
            print *, "ZBDSQR did not converge, there are ", info
            print *, "superdiagonals of an intermediate bidiagonal form B"
            print *, "did not converge to zero. See the description of WORK"
            print *, "in DGESVD's man page for details."
         end if
         call stop_error('svd: zgesvd error')
      end if

    end block postprocess

  end subroutine zsvd

  !-------------------------------------------------------------------!
  ! Make sure a given real matrix has a given shape
  !-------------------------------------------------------------------!

  subroutine dassert_shape(A, shap, routine, matname)

    real(dp), intent(in) :: A(:,:)
    integer, intent(in)  :: shap(:)
    character(len=*)     :: routine, matname

    if (any(shape(A) .ne. shap)) then
       print *, "In routine " // routine // " matrix " // matname // " has illegal shape ", shape(A)
       print *, "Shape should be ", shap
       call stop_error("Aborting due to illegal matrix operation")
    end if

  end subroutine dassert_shape

  !-------------------------------------------------------------------!
  ! Make sure a given real matrix has a given shape
  !-------------------------------------------------------------------!

  subroutine zassert_shape(A, shap, routine, matname)

    complex(dp), intent(in) :: A(:,:)
    integer, intent(in)     :: shap(:)
    character(len=*)        :: routine, matname

    if (any(shape(A) .ne. shap)) then
       print *, "In routine " // routine // " matrix " // matname // " has illegal shape ", shape(A)
       print *, "Shape should be ", shap
       call stop_error("Aborting due to illegal matrix operation")
    end if

  end subroutine zassert_shape

  !-------------------------------------------------------------------!
  ! Stop with an error message
  !-------------------------------------------------------------------!

  subroutine stop_error( message )

    character(len=*) :: message

    print *, message
    stop

  end subroutine stop_error

  !-------------------------------------------------------------------!
  ! Assert if the condition is not met (i.e. condition .eq. false)
  !-------------------------------------------------------------------!

  subroutine assert(condition)

    logical, intent(in) :: condition

    if (.not. condition) call stop_error("Assert failed.")

  end subroutine assert

end module linear_algebra


module module_math
  use module_globals
  use module_autodiff
  implicit none

  private
  public IntegralTest, load_integral_test, f, Df

  type :: IntegralTest
     real(8) :: st, en, le, cn, seikai
  end type IntegralTest

contains
  !========================================================================================
  subroutine load_integral_test(test)
    type(IntegralTest),intent(out) :: test

    ! int_[a->b](sin(x))dx
    test%st=0.d0
    test%en=30.d0
    test%seikai=-cos(test%en)+cos(test%st)

    !int_[0.01->2](sin(x)/x)dx
    ! test%st=0.01d0
    ! test%en=1.d0
    ! test%seikai=0.93608312592257190411368860853800106052127274d0

    ! !int_[0->30](sin(x)/x)dx
    ! test%st=1.d0
    ! test%en=30.d0
    ! test%seikai=0.620673469663168096042377995183618508711157d0

    ! int_[-1->1] 1/(1+25*x^2) dx
    test%st=-5.d0
    test%en=5.d0
    test%seikai=(atan(5.d0*test%en)-atan(5.d0*test%st))/5.d0

    ! int_[0,1] bessel_j0(x) dx
    ! test%st=0.d0
    ! test%en=1.d0
    ! test%seikai=0.919730410089760239314421194080619970661d0

    ! test%st=0.d0
    ! test%en=2.d0
    ! test%seikai=(test%en**30-test%st**30)/30.d0

    test%le=test%en-test%st
    test%cn=(test%st+test%en)*0.5d0

  end subroutine load_integral_test

  !========================================================================================
  real(8) function f(x)
    real(8),intent(in) :: x
    !f=sin(x)
    !f=sin(x)/x
    !f=sin(x)/x
    f=1.d0/(1.d0+25.d0*x*x)
    !f=bessel_j0(x)
    !f=x**29
  end function f

  !========================================================================================
  type(Dcomplex8) function Df(x)
    type(Dcomplex8),intent(in) :: x
    !Df=sin(x)
    !Df=sin(x)/x
    !Df=sin(x)/x
    Df=1.d0/(1.d0+25.d0*x*x)
    !Df=bessel_j0(x)
    !Df=x**29
  end function Df

end module module_math


     subroutine fort_set_dirichlet_bcs(lo,hi,domlo,domhi, &
                           phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3,dx);

     use amrex_fort_module, only : rt => amrex_real
     use bl_constants_module         , only : M_PI
     use probdata_module             , only : a1,a3,center
     use meth_params_module          , only : NVAR
     use fundamental_constants_module, only : Gconst

     implicit none

     integer         ,intent(in   ) :: lo(3),hi(3),domlo(3),domhi(3)
     integer         ,intent(in   ) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3
     real(rt),intent(  out) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
     real(rt),intent(in   ) :: dx(3)

     integer          :: i,j,k
     real(rt) :: x,y,z,rsq,zsq
     real(rt) :: a1sq,a3sq
     real(rt) :: e,esq,b,lambda,h,ah

     a1sq = a1**2
     a3sq = a3**2

     esq = 1.d0 - a3sq/a1sq
      e   = dsqrt(esq)

     if (lo(1).eq.domlo(1)) then
        i = lo(1)-1
        x = 0.d0 - center(1)
        do k = lo(3), hi(3)
           z = (dble(k)+0.5d0)*dx(3) - center(3)
           zsq = z**2
              do j = lo(2), hi(2)
                 y = (dble(j)+0.5d0)*dx(2) - center(2)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )

           end do
        end do
     end if

     if (hi(1).eq.domhi(1)) then
        i = hi(1)+1
        x = 1.d0 - center(1)
        do k = lo(3), hi(3)
           z = (dble(k)+0.5d0)*dx(3) - center(3)
           zsq = z**2
              do j = lo(2), hi(2)
                 y = (dble(j)+0.5d0)*dx(2) - center(2)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     if (lo(2).eq.domlo(2)) then
        j = lo(2)-1
        y = 0.d0 - center(2)
        do k = lo(3), hi(3)
           z = (dble(k)+0.5d0)*dx(3) - center(3)
           zsq = z**2
              do i = lo(1), hi(1)
                 x = (dble(i)+0.5d0)*dx(1) - center(1)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     if (hi(2).eq.domhi(2)) then
        j = hi(2)+1
        y = 1.d0 - center(2)
        do k = lo(3), hi(3)
           z = (dble(k)+0.5d0)*dx(3) - center(3)
           zsq = z**2
              do i = lo(1), hi(1)
                 x = (dble(i)+0.5d0)*dx(1) - center(1)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     if (lo(3).eq.domlo(3)) then
        k = lo(3)-1
        z = 0.d0 - center(3)
        zsq = z**2
        do j = lo(2), hi(2)
           y = (dble(j)+0.5d0)*dx(2) - center(2)
              do i = lo(1), hi(1)
                 x = (dble(i)+0.5d0)*dx(1) - center(1)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     if (hi(3).eq.domhi(3)) then
        k = hi(3)+1
        z = 1.d0 - center(3)
        zsq = z**2
        do j = lo(2), hi(2)
           y = (dble(j)+0.5d0)*dx(2) - center(2)
              do i = lo(1), hi(1)
                 x = (dble(i)+0.5d0)*dx(1) - center(1)
                    rsq = x**2 + y**2
                    b = a1sq + a3sq - rsq - zsq
                    lambda = 0.5d0 * ( -b + dsqrt( b**2 - 4.d0 * &
                                     (a1sq * a3sq - rsq * a3sq - zsq * a1sq) ) )
                    h = a1 * e / (dsqrt(a3sq + lambda))
                    ah = datan(h)
                    phi(i,j,k) = &
                       2.d0 * M_PI * Gconst * a1 * a3 / e * ( &
                       ah - 0.5d0 / (a1sq * esq) * &
                       ( rsq * (ah - h / (1.d0+h**2) ) + 2.d0 * zsq * (h - ah) ) )
           end do
        end do
     end if

     end subroutine fort_set_dirichlet_bcs

     subroutine fort_set_homog_bcs(lo,hi,domlo,domhi, &
                                   phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3,dx);

     use amrex_fort_module, only : rt => amrex_real
     implicit none

     integer         ,intent(in   ) :: lo(3),hi(3),domlo(3),domhi(3)
     integer         ,intent(in   ) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3
     real(rt),intent(  out) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
     real(rt),intent(in   ) :: dx(3)

     phi = 0.d0

     end subroutine fort_set_homog_bcs

     ! ************************************************************************************
     ! Loops over the particles and adds their monopole contribution to phi outside the boundary
     ! ************************************************************************************

     subroutine fort_add_monopole_bcs(lo,hi,domlo,domhi, &
                                      np,part_locs,part_mass, &
                                      phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3,dx);

     use amrex_fort_module, only : rt => amrex_real
     use fundamental_constants_module, only : Gconst

     implicit none

     integer         ,intent(in   ) :: lo(3),hi(3),domlo(3),domhi(3),np
     integer         ,intent(in   ) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3
     real(rt),intent(in   ) :: part_locs(0:3*np-1)
     real(rt),intent(in   ) :: part_mass(0:  np-1)
     real(rt),intent(  out) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
     real(rt),intent(in   ) :: dx(3)

     ! Local variables
     integer          :: i,j,k,n
     real(rt) :: x,y,z,r
     real(rt) :: x0,y0,z0

     phi = 0.d0

     ! Define phi = -G M / r where r is distance from particle and M is mass of particle

     do k = lo(3)-1,hi(3)+1
         do j = lo(2)-1,hi(2)+1
             do i = lo(1)-1,hi(1)+1

                   if (i.lt.domlo(1) .or. i.gt.domhi(1) .or. &
                       j.lt.domlo(2) .or. j.gt.domhi(2) .or. &
                       k.lt.domlo(3) .or. k.gt.domhi(3)) then

                       if (i.lt.domlo(1)) then
                           x0 = (dble(i+1))*dx(1)
                       else if (i.gt.domhi(1)) then
                           x0 = (dble(i))*dx(1)
                       else
                           x0 = (dble(i)+0.5d0)*dx(1)
                       end if

                       if (j.lt.domlo(2)) then
                           y0 = (dble(j+1))*dx(2)
                       else if (j.gt.domhi(2)) then
                           y0 = (dble(j))*dx(2)
                       else
                           y0 = (dble(j)+0.5d0)*dx(2)
                       end if

                       if (k.lt.domlo(3)) then
                           z0 = (dble(k+1))*dx(3)
                       else if (k.gt.domhi(3)) then
                           z0 = (dble(k))*dx(3)
                       else
                           z0 = (dble(k)+0.5d0)*dx(3)
                       end if

                       do n = 0, np-1
                           x = x0 - part_locs(3*n  )
                           y = y0 - part_locs(3*n+1)
                           z = z0 - part_locs(3*n+2)
                           r = sqrt(x*x + y*y + z*z)
                           phi(i,j,k) = phi(i,j,k) - Gconst * part_mass(n) / r
                       end do

                   end if
              end do
         end do
     end do

     end subroutine fort_add_monopole_bcs


!SUBROUTINE INVERSSYMDEF(A,AINV)
!  IMPLICIT REAL*8 (A-H,O-Z)
!  DIMENSION A(3,3),AINV(3,3)
!  det= a(1,1)*a(2,2)*a(3,3)+a(1,2)*a(2,3)*a(3,1)+a(1,3)*a(2,1)*a(3,2)-a(3,1)*a(2,2)*a(1,3)-a(1,1)*a(3,2)*a(2,3)-a(2,1)*a(1,2)*a(3,3)
!  AINV(1,1) =(   A(2,2) * A(3,3) - A(2,3) * A(3,2) ) / det
!  AINV(2,1) =( - A(2,1) * A(3,3) + A(2,3) * A(3,1) ) / det
!  AINV(3,1) =(   A(2,1) * A(3,2) - A(2,2) * A(3,1) ) / det
!  AINV(1,2) =( - A(1,2) * A(3,3) + A(1,3) * A(3,2) ) / det
!  AINV(2,2) =(   A(1,1) * A(3,3) - A(1,3) * A(3,1) ) / det
!  AINV(3,2) =( - A(1,1) * A(3,2) + A(1,2) * A(3,1) ) / det
!  AINV(1,3) =(   A(1,2) * A(2,3) - A(1,3) * A(2,2) ) / det
!  AINV(2,3) =( - A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / det
!  AINV(3,3) =(   A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / det
!  RETURN
!END SUBROUTINE INVERSSYMDEF
SUBROUTINE inv_3x3(A,Ainv)
  IMPLICIT NONE
  REAL*8, intent(in)  :: A(3,3)
  REAL*8, intent(out) :: Ainv(3,3)
  ! locals
  REAL*8 :: det
  det = A(1,1)*A(2,2)*A(3,3) + A(1,2)*A(2,3)*A(3,1) + A(1,3)*A(2,1)*A(3,2) &
      - A(3,1)*A(2,2)*A(1,3) - A(1,1)*A(3,2)*A(2,3) - A(2,1)*A(1,2)*A(3,3)
  Ainv(1,1) =(   A(2,2) * A(3,3) - A(2,3) * A(3,2) ) / det
  Ainv(1,2) =( - A(1,2) * A(3,3) + A(1,3) * A(3,2) ) / det
  Ainv(1,3) =(   A(1,2) * A(2,3) - A(1,3) * A(2,2) ) / det
  Ainv(2,1) =( - A(2,1) * A(3,3) + A(2,3) * A(3,1) ) / det
  Ainv(2,2) =(   A(1,1) * A(3,3) - A(1,3) * A(3,1) ) / det
  Ainv(2,3) =( - A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / det
  Ainv(3,1) =(   A(2,1) * A(3,2) - A(2,2) * A(3,1) ) / det
  Ainv(3,2) =( - A(1,1) * A(3,2) + A(1,2) * A(3,1) ) / det
  Ainv(3,3) =(   A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / det
  RETURN
END SUBROUTINE inv_3x3


PROGRAM EXAMPLE
  IMPLICIT NONE

  INTEGER :: i, j

  DO i = 0, 3
    DO j = 0, 6
       WRITE(*, "(I10)", ADVANCE="NO") Ackermann(i, j)
    END DO
    WRITE(*,*)
  END DO

CONTAINS

  RECURSIVE FUNCTION Ackermann(m, n) RESULT(ack)
    INTEGER :: ack, m, n

    IF (m == 0) THEN
      ack = n + 1
    ELSE IF (n == 0) THEN
      ack = Ackermann(m - 1, 1)
    ELSE
      ack = Ackermann(m - 1, Ackermann(m, n - 1))
    END IF
  END FUNCTION Ackermann

END PROGRAM EXAMPLE


      SUBROUTINE WEIGHT (T, W)
C----------------------------------------------------------------------
C
C     Computes the weights at 0 <= t <= 1 for the spline function and
C     its 1st derivative defined by:
C
C     x  (t) = x1*W11(t) + x2*W21(t) + dx1*W31(t) + dx2*W41(t)
C     x' (t) = x1*W12(t) + x2*W22(t) + dx1*W32(t) + dx2*W42(t)
C     x''(t) = x1*W13(t) + x2*W23(t) + dx1*W33(t) + dx2*W43(t)
C
C                           2                  2
C     W (t) = (1 + 2t) (t-1),   W (t)=  t (t-1)
C      11                        31
C                       2                     2
C     W (t) = (3 - 2t) t    ,   W (t)= (t-1) t
C      21                        41
C
C
C     For t=0 W (:,1)= [ 1, 0, 0, 0],
C             W (:,2)= [ 0, 0, 1, 0],
C             W (:,3)= [-6, 6,-4,-2]
C
C     For t=1 W (:,1)= [ 0, 1, 0, 0],
C             W (:,2)= [ 0, 0, 0, 1],
C             W (:,3)= [ 6,-6, 2, 4]
C
C     x(t), x'(t) and x''(t) are continuous over an element
C     truncation error is O(h^4)
C
C----------------------------------------------------------------------
      IMPLICIT NONE
      INCLUDE 'knd_params.inc'
C
      REAL(KIND=RK) T
      REAL(KIND=RK) W (4, 2)
C
      W (1, 1) = (T - 1.0D0) ** 2 * (1.0D0 + 2.0D0 * T)
      W (2, 1) = T ** 2           * (3.0D0 - 2.0D0 * T)
      W (3, 1) = (T - 1.0D0) ** 2 *  T
      W (4, 1) = T ** 2           * (T - 1.0D0)
      W (1, 2) = 6.0D0 * T * (T - 1.0D0)
      W (2, 2) =-6.0D0 * T * (T - 1.0D0)
      W (3, 2) = (3.0D0 * T - 1.0D0) * (T - 1.0D0)
      W (4, 2) = (3.0D0 * T - 2.0D0) *  T
C
      RETURN
      END


module distributions
    use constants
    contains

    function maxbolt(v,v0)
        ! Maxwell-Boltzmann (MB) probability distribution

        implicit none

        real(kind=8), intent(in) :: v
        real(kind=8), intent(in) :: v0
        real(kind=8) :: maxbolt

        maxbolt = exp(-(v/v0)**2.0d0) / ((pi)**1.5d0 * v0**3.0d0)

    end function maxbolt

    function shm(v, v0, vesc)
        ! Standard halo model probability distribution, i.e.
        ! a MB distribution with a sharp cutoff to recognize the
        ! finite escape speed of the galaxy.

        implicit none

        real(kind=8), intent(in) :: v, v0, vesc
        real(kind=8) :: shm
        real(kind=8) :: Nresc, z, y

        if (v > vesc) then
            shm = 0d0
            return
        end if

        z = vesc / v0
        y = v / v0

        Nresc = erf(z) - 2d0*z * exp(-z*z)/sqrt(pi)
        shm = exp(-y*y) / (Nresc * (pi)**1.5d0 * v0**3d0)

    end function shm

    function sshm(v, ve, v0, vesc)
        ! Smooth standard halo model. Basically a SHM with an extra constant
        ! term meanth to smooth the distribution near vesc.

        implicit none

        real(kind=8), intent(in) :: v, ve, v0, vesc
        real(kind=8) :: sshm
        real(kind=8) :: Nesc, z

        z = vesc / v0

        Nesc = (erf(z)-2d0*z*(1d0+z*z/1.5d0)*exp(-z*z)/sqrt(pi))*pi**1.5d0*v0**3d0
        sshm = (Imbcutoff(v, ve, v0, vesc) - Isccutoff(v, ve, v0, vesc))/Nesc

    end function sshm

    function Imbcutoff(v, ve, v0, vesc)
        ! Integrand for radial part of Maxwell Boltzmann distribution with cutoff

        implicit none

        real(kind=8), intent(in) :: v, ve, v0, vesc
        real(kind=8) :: Imbcutoff

        if (v<vesc-ve) then
            Imbcutoff = g(v-ve,v0)-g(v+ve,v0)
        else ! v>vesc-ve
            Imbcutoff = g(v-ve,v0)-g(vesc,v0)
        end if
        Imbcutoff = Imbcutoff * pi*(v0**2d0/ve)

    end function Imbcutoff

    function Isccutoff(v, ve, v0, vesc)
        ! Integrand for radial part of smooth component with cutoff

        implicit none

        real(kind=8), intent(in) :: v, ve, v0, vesc
        real(kind=8) :: Isccutoff

        if (v<vesc-ve) then
            Isccutoff = 2d0 * v
        else ! v>vesc-ve
            Isccutoff = (vesc**2d0 - (v-ve)**2d0)/(2d0*ve)
        end if
        Isccutoff = Isccutoff * 2d0*pi*g(vesc,v0)

    end function Isccutoff

    function g(v, v0)
        ! Gaussian term

        implicit none

        real(kind=8), intent(in) :: v
        real(kind=8), intent(in) :: v0
        real(kind=8) :: g

        g = exp(-(v/v0)**2d0)

    end function

end module


FUNCTION distance_between_points(x0,y0,z0,x1,y1,z1)
    IMPLICIT NONE
    DOUBLE PRECISION :: distance_between_points
    DOUBLE PRECISION :: x0,y0,z0,x1,y1,z1
    DOUBLE PRECISION :: dx,dy,dz
    dx = x1 - x0
    dy = y1 - y0
    dz = z1 - z0
    distance_between_points = SQRT(dx * dx  + dy * dy + dz * dz)
END FUNCTION

FUNCTION find_nearest_neighbors (npoints,x,y,z,n0,n1,n2)
    IMPLICIT NONE
    INTEGER, INTENT(IN):: npoints
    INTEGER :: i,j, k, kk
    INTEGER :: find_nearest_neighbors
    DOUBLE PRECISION :: x(npoints),y(npoints),z(npoints)
    INTEGER :: n0(npoints),n1(npoints),n2(npoints)
    DOUBLE PRECISION :: r
    DOUBLE PRECISION :: distance_between_points
    INTEGER :: nn_index(3)
    DOUBLE PRECISION :: nn_distance(3)

    DO i = 1, npoints, 1
        DO k = 1, 3
            nn_index(k) = 0
            nn_distance(k) = 0.0
        END DO

        DO j = 1, npoints, 1
            IF (i.NE.j) THEN
                r = distance_between_points(x(i), y(i), z(i), &
                 x(j), y(j), z(j))

                DO k = 1, 3
                    IF (nn_index(k).EQ.0) THEN
                        nn_index(k) = j
                        nn_distance(k) = r
                        EXIT
                    ELSE
                        IF (r.LT.nn_distance(k)) THEN
                            DO kk = 3, k, -1
                                nn_index(kk) = nn_index(kk-1)
                                nn_distance(kk) = nn_distance(kk-1)
                            END DO
                            nn_index(k) = j
                            nn_distance(k) = r
                            EXIT
                        END IF
                    END IF
                END DO
            END IF
        END DO

        n0(i) = nn_index(1)
        n1(i) = nn_index(2)
        n2(i) = nn_index(3)
    END DO

    find_nearest_neighbors = 0
END FUNCTION


C$Procedure      MTXV  ( Matrix transpose times vector, 3x3 )

      SUBROUTINE MTXV ( MATRIX, VIN, VOUT )

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

      DOUBLE PRECISION  MATRIX   ( 3,3 )
      DOUBLE PRECISION  VIN      (   3 )
      DOUBLE PRECISION  VOUT     (   3 )

C$ Brief_I/O
C
C     VARIABLE  I/O              DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MATRIX     I   3X3 double precision matrix.
C     VIN        I   3-dimensional double precision vector.
C     VOUT       O   3-dimensional double precision vector. VOUT is
C                    the product MATRIX**T * VIN.
C
C$ Detailed_Input
C
C     MATRIX     is an arbitrary 3x3 double precision matrix.
C                Typically, MATRIX will be a rotation matrix since
C                then its transpose is its inverse (but this is NOT
C                a requirement).
C
C     VIN        is an arbitrary 3-dimensional double precision
C                vector.
C
C$ Detailed_Output
C
C     VOUT       is a 3-dimensional double precision vector. VOUT is
C                the product VOUT = (MATRIX**T)  x (VIN).
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The code reflects precisely the following mathematical expression
C
C        For each value of the subscript I from 1 to 3:
C
C        VOUT(I) = Summation from K=1 to 3 of  ( MATRIX(K,I) * VIN(K) )
C
C     Note that the reversal of the K and I subscripts in the left-hand
C     matrix MATRIX is what makes VOUT the product of the TRANSPOSE of
C     and not simply of MATRIX itself.
C
C$ Examples
C
C     Typically the matrix MATRIX will be a rotation matrix. Because
C     the transpose of an orthogonal matrix is equivalent to its
C     inverse, applying the rotation to the vector is accomplished by
C     multiplying the vector by the transpose of the matrix.
C
C                -1
C     Let  MATRIX   * VIN = VOUT. If MATRIX is an orthogonal matrix,
C     then  (MATRIX**T) * VIN = VOUT.
C
C
C     If MATRIX  = |  1.0D0  1.0D0  0.0D0 |   and  VIN = |  5.0D0 |
C                  |                      |              |        |
C                  | -1.0D0  1.0D0  0.0D0 |              | 10.0D0 |
C                  |                      |              |        |
C                  |  0.0D0  0.0D0  1.0D0 |              | 15.0D0 |
C
C
C     then the call
C
C        CALL MTXV ( MATRIX, VIN, VOUT )
C
C     produces the vector
C
C
C        VOUT = | -5.0D0 |
C               |        |
C               | 15.0D0 |
C               |        |
C               | 15.0D0 |
C
C
C$ Restrictions
C
C     The user is responsible for checking the magnitudes of the
C     elements of MATRIX and VIN so that a floating point overflow does
C     not occur.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     matrix_transpose times 3-dimensional vector
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION  PRODV(3)
      INTEGER           I

C
C  Perform the matrix-vector multiplication
C
      DO I = 1, 3
        PRODV(I) = MATRIX(1,I)*VIN(1) +
     .             MATRIX(2,I)*VIN(2) +
     .             MATRIX(3,I)*VIN(3)
      END DO

C
C  Move the result into VOUT
C
      VOUT(1) = PRODV(1)
      VOUT(2) = PRODV(2)
      VOUT(3) = PRODV(3)

      RETURN
      END


subroutine coarse_to_fine_uface(e_2h, nx, ny, e_h)
use kind_parameters
implicit none

integer, intent(in):: nx, ny
real(kind=dp), intent(in), dimension(nx,ny):: e_2h
real(kind=dp), intent(out), dimension(2*nx-1,2*ny-2):: e_h
integer:: i, j

!write(*,*) nx, ny

! Apply linear interpolation to get values from coarse to fine grid
! Input
! e_2h   Variable in coarse grid
! hx, hy     grid spacing
!
! Output
! e_h     Variable in fine grid

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012

do j = 2,ny-2

    do i = 1,nx-1

        e_h(2*i-1,2*j-1) = (1.0/4.0)*(3.0*e_2h(i,j) + e_2h(i,j+1))
        e_h(2*i,2*j) = (1.0/8.0)*(3.0*e_2h(i,j+1) + 3.0*e_2h(i+1,j+1) + e_2h(i,j) + e_2h(i+1,j))
        e_h(2*i, 2*j-1) = (1.0/8.0)*(e_2h(i,j+1) + e_2h(i+1,j+1) + 3.0*e_2h(i,j) + 3.0*e_2h(i+1,j))
        e_h(2*i-1,2*j) = (1.0/4.0)*(e_2h(i,j) + 3.0*e_2h(i,j+1))

    end do

end do

j = 1

do i = 1,nx-1

	e_h(2*i-1,2*j) = (1.0/2.0)*(e_2h(i,j) + e_2h(i,j+1))
    e_h(2*i,2*j) = (1.0/4.0)*(e_2h(i,j) + e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))

end do

j = ny-1

do i = 1,nx-1

    e_h(2*i-1,2*j-1) = (1.0/2.0)*(e_2h(i,j) + e_2h(i,j+1))
    e_h(2*i,2*j-1) = (1.0/4.0)*(e_2h(i,j) + e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))

end do

end subroutine


! POUR EXECUTER SUR  http://tpcg.io/5QC2CL, ENLEVER '-std=f95' DANS PROJECT->COMPILE OPTIONS

program newton
    use, intrinsic :: iso_fortran_env, only: real128
    implicit none

    integer, parameter :: wp = real128
    real(wp) :: a, f, z
    integer :: it, itmax
    real(wp) :: gn, dgn, xn, tol
    real(wp) :: best

    write(*,*) '[INFO] Programme pour résoudre par Newton f = a cosh(phi z) / cosh(phi), inconnue phi, le module de Thiele'
    write(*,*) "       On reformule le problème : on cherche le zero de la fonction"
    write(*,*) "              g(phi) = phi - acosh( a / f * cosh(phi z) )"
    write(*,*)
    write(*,*) "[INFO] Fournir depuis STDIN les valeurs numériques"
    write(*,*) "       a       Épaisseur du dépôt en micron à l'entrée du pore"
    write(*,*) "       f       Épaisseur du dépôt en micron en z"
    write(*,*) "       z       Distance relative entre l'entrée (z=1) et le milieu (z=0) du pore"
    write(*,*) "       tol     Tolérance: on accepte phi si g(phi) < tol. Mettre 1E-3 si inconnu "
    write(*,*) "       itmax   Nombre maximal d'itérations. Mettre 100 si inconnu. "
    write(*,*) "       phi0    Estimation grossière du module pour démarrer l'algo. Mettre 1 si inconnu."
    write(*,*)

    read(*,*) a
    if (a.lt.0.) then
      write(*,*) "[FAIL] a doit être positif"
      error stop
    end if
    read(*,*) f
    if (f.lt.0.) then
      write(*,*) "[FAIL] f doit être positif"
      error stop
    end if
    read(*,*) z
    if ((z.lt.0.).or.(z.gt.1.)) then
      write(*,*) "[FAIL] z doit être compris entre 0 et 1"
      error stop
    end if
    read(*,*) tol
    read(*,*) itmax
    read(*,*) xn

    it = 0
    best = xn
    gn = g(xn,a,f,z)
    dgn = dg(xn,a,f,z)

    write(*,*) "[INFO] Lancement de l'algorithme pour "
    write(*,'(7x,*(a16,1x))') 'a','f','z'
    write(*,'(7x,*(es16.9,1x))') a, f, z
    write(*,*) "       ..."
    do while ((abs(gn).gt.abs(tol)).and.(it.lt.itmax))
      gn = g(xn,a,f,z)
      dgn = dg(xn,a,f,z)
      if (abs(gn).lt.abs(g(best,a,f,z))) then
        best = xn
      end if
      ! write(*,'(i16,1x,3(es16.9,1x))') it, xn, gn, dgn
      xn = xn - gn/dgn
      it = it + 1
    end do
    if (it.lt.itmax) then
      write(*,*) "[OK]   L'algorithme a trouvé un zéro à la tolérance demandée."
    else
      write(*,*) "[FAIL] L'algorithme n'a pas fini dans le nombre maximal d'itérations autorisées."
      write(*,*) "       Peut être faut-il plus d'itérations ou une tolérance plus grande."
      write(*,*) "       Néanmoins, le meilleur phi était"
    end if
    write(*, '(1x,*(a,es12.5))') "phi = ", best, ', g(phi) = ',g(best,a,f,z)

contains

pure function g(phi,a,f,z)
  real(wp) :: g
  real(wp),intent(in) :: phi,a,f,z
  g = phi - acosh(a/f*cosh(phi*z))
end function

pure function dg(phi,a,f,z)
  real(wp) :: dg
  real(wp),intent(in) :: phi,a,f,z
  dg = 1._wp - (a*z*sinh(phi*z))/(f*sqrt((a*cosh(phi*z))/f - 1._wp)*sqrt((a*cosh(phi*z))/f + 1._wp))
end function
end program


module Stationary

contains

  ! Accepts row-major triple format

  subroutine sym_gauss_seidel(irows,icols,vals,b,N,NNZ,x, N_ITER)
    integer, intent(in) :: N, NNZ
    integer, intent(in), dimension(NNZ) :: irows, icols
    real(kind=8), intent(in), dimension(NNZ) :: vals
    real(kind=8), intent(in), dimension(N) :: b
    real(kind=8), intent(out), dimension(N) :: x
    integer,intent(in) ::  N_ITER

    integer :: i,k
    real(kind=8) :: diag

    x = 0.0

    do it=1,n_iter

       ! Forward iteration
       k=1
       do i=1,N
          ! calculate x[i]
          x(i) = b(i)
          do while (k<=NNZ .AND. irows(k)==i)
             j=icols(k) ! column index
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k+1
          end do
          x(i) = x(i) / diag
       end do

       ! Backward iteration
       k=NNZ
       do i=N,1,-1
          ! calculate x[i]
          x(i) = b(i)
          do while (k>0 .AND. irows(k)==i)
             j=icols(k) ! column index
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k-1
          end do
          x(i) = x(i) / diag
       end do

    end do

  end subroutine sym_gauss_seidel

  ! Accepts row-major triple format
  ! Irows and icols can start with values 0
  ! This was modified by me

  subroutine sym_gauss_seidel_zero(irows,icols,vals,b,N,NNZ,x, N_ITER)
    integer, intent(in) :: N, NNZ
    integer, intent(in), dimension(NNZ) :: irows, icols
    real(kind=8), intent(in), dimension(NNZ) :: vals
    real(kind=8), intent(in), dimension(N) :: b
    real(kind=8), intent(out), dimension(N) :: x
    integer,intent(in) ::  N_ITER

    integer :: i,k
    real(kind=8) :: diag

    x = 0.0

    do it=1,n_iter

       ! Forward iteration
       k=1
       do i=1,N
          ! calculate x[i]
          x(i) = b(i)
          do while (k<=NNZ .AND. irows(k)==i-1) ! see SGSFortranPreconditioner
             j=icols(k)+1 ! column index, see SGSFortranPreconditioner
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k+1
          end do
          x(i) = x(i) / diag
       end do

       ! Backward iteration
       k=NNZ
       do i=N,1,-1
          ! calculate x[i]
          x(i) = b(i)
          do while (k>0 .AND. irows(k)==i-1) ! see SGSFortranPreconditioner
             j=icols(k)+1 ! column index, see SGSFortranPreconditioner
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k-1
          end do
          x(i) = x(i) / diag
       end do

    end do

  end subroutine sym_gauss_seidel_zero

  ! Uses 0-based indexing
  ! Suggested by user thrope in freenode

  subroutine sym_gauss_seidel_thrope(irows,icols,vals,b,N,NNZ,x, N_ITER)
    integer, intent(in) :: N, NNZ
    integer, intent(in), dimension(0:NNZ-1) :: irows, icols
    real(kind=8), intent(in), dimension(0:NNZ-1) :: vals
    real(kind=8), intent(in), dimension(0:N-1) :: b
    real(kind=8), intent(out), dimension(0:N-1) :: x
    integer,intent(in) ::  N_ITER

    integer :: i,k
    real(kind=8) :: diag

    x = 0.0

    do it=1,n_iter

       ! Forward iteration
       k=0
       do i=0,N-1
          ! calculate x[i]
          x(i) = b(i)
          do while (k<NNZ .AND. irows(k)==i)
             j=icols(k) ! column index
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k+1
          end do
          x(i) = x(i) / diag
       end do

       ! Backward iteration
       k=NNZ - 1
       do i=N-1,0,-1
          ! calculate x[i]
          x(i) = b(i)
          do while (k>=0 .AND. irows(k)==i)
             j=icols(k) ! column index
             if (i==j) then
                diag = vals(k) ! diagonal
             else
                x(i) = x(i) - x(j)*vals(k)
             end if
             k = k-1
          end do
          x(i) = x(i) / diag
       end do

    end do

  end subroutine sym_gauss_seidel_thrope
end module Stationary


PROGRAM BESSEL
    USE INTERPOLATION

    IMPLICIT NONE

    INTEGER, PARAMETER         :: N = 10, NGRID = 90

    REAL, DIMENSION(N)         :: t, J0, J1, J2
    REAL, DIMENSION(NGRID + 1) :: x, Lx, S3

    INTEGER                    :: i
    REAL                       :: dgrid

    ! (t, y) for interpolation
     t = [ ( REAL(i), i = 1, N ) ]
    J0 = BESSEL_J0(t)
    J1 = BESSEL_J1(t)
    J2 = BESSEL_JN(2, t)

    ! 1d grid
    dgrid = (t(N) - t(1)) / NGRID
    x     = [ ( t(1) + dgrid * i , i = 0, NGRID ) ]

    ! Lagrange interpolation
    ! N poly requires N+1 (x, f(x)) pair
    Lx = LAGRANGE_INTERPOLATION(x, t(4:7), J1(4:7))

    ! cubic spline interpolation
    S3 = CUBIC_SPLINE_INTERPOLATION(x, t, J1)

    ! debug
    DO i = 1, NGRID+1
        PRINT 1000, x(i), BESSEL_J1(x(i)), Lx(i), S3(i)
        1000 FORMAT (4F13.6)
    END DO

CONTAINS

SUBROUTINE PRINT_TABLE
    IMPLICIT NONE

    INTEGER                  :: i

    DO i = 1, N
        PRINT 1000, i, J0(i), J1(i), J2(i)
    END DO

    1000 FORMAT (I3, (3F13.6))
END SUBROUTINE Print_Table

END PROGRAM BESSEL


program pi_openmp

  use ISO_FORTRAN_ENV

  implicit none

  double precision              :: step, x, s, mypi, start, stop, omp_get_wtime
  integer(kind=int64)           :: num_steps, i
  character(len=:), allocatable :: a
  integer, external             :: omp_get_max_threads
  integer                       :: argl

  num_steps = 1000000000

! Get command line args (Fortran 2003 standard)
  if (command_argument_count() > 0) then
     call get_command_argument(1, length=argl)
     allocate(character(argl) :: a)
     call get_command_argument(1, a)
     read(a,*) num_steps
  end if

! Output start message

  write(*,'(A)') "Calculating PI using:"
  write(*,'(A,1I16,A)') "                  ",num_steps, " slices"
  write(*,'(A,1I16,A)') "                  ",omp_get_max_threads()," OpenMP threads"

! Initialise time counter and sum: set step size

  start = omp_get_wtime()
  s = 0d0
  step = 1.0d0 / num_steps

! Specify that the loop be parallelised, with summation of individual
! threads' s values to yield overall sum. Specify that the variable
! x is local to each thread.

!$OMP PARALLEL
!$OMP DO PRIVATE(x) REDUCTION(+:s)
  do i = 1, num_steps
    x = (i - 0.5d0) * step
    s = s + 4.0d0 / (1.0d0 + x*x)
  end do
!$OMP ENDDO
!$OMP END PARALLEL

! Evaluate PI from the final sum value, and stop the clock

  mypi = s * step
  stop = omp_get_wtime()

! output value of PI and time taken

  write(*,'(A,1F12.10,A)') "Obtained value of PI: ", mypi
  write(*,'(A,1F12.5,A)') "Time taken:           ",(stop-start), " seconds"

end program pi_openmp


program example
  ! Example 10.3 from NMUM/Mathews.
  ! Integrate the 1D heat equation forward in time given simple initial
  ! conditions.  This is a simple example of how to use Fortran90.  There
  ! are better ways to code this problem...

  ! Begin the declaration section.
  ! ALWAYS start with implicit none.
  implicit none

  ! Declare some variables.  Set intital values on some.
  ! Note that xLim is a 2-element vector.
  real    :: dt=0.02, dx=0.2, tLimit=0.2, xLim(2)=(/0,1/)
  real    :: r
  integer :: nX, nT, i, j
  logical :: DoTest = .true.

  ! Create character variables.  We must declare their size.
  character(len=23) :: fmt1
  character(len=17) :: fmt2

  ! Domain array.  We don't know the size yet because we need to
  ! calculate that.  So let's make them "allocatable."
  real, allocatable :: Domain_II(:,:), xGrid(:)

  ! Constants.  Make them "parameters" that cannot be changed.
  integer, parameter :: iUnitFile=10
  real,    parameter :: cDiffusion = 1.0

  ! Now, begin execution section.
  !---------------------------------------------------------------------
  ! Write a message to Standard Out with no defined format:
  write(*,*) "Setting up simulation..."

  ! Calculate the number of points in X and in time.
  ! Ceiling rounds up and returns an integer, which matches the data
  ! type of "ceiling".  Without ceiling, our value would be a "real" type,
  ! which may be rounded up, down, or truncated (compiler dependent).
  nX = ceiling( (xLim(2)-xLim(1))/dx ) + 1
  nT = ceiling( tLimit/dt ) + 1

  ! If logical DoTest is .true., produce extra information to screen.
  if(DoTest)write(*,*) '     Grid size (nX, nT) = ', nX, nT

  ! Allocate arrays now that we know their size.
  ! Remember: if we do not de-allocate, it's possible to create a mem leak.
  allocate(Domain_II(nX, nT))
  allocate(xGrid(nX))

  !It's usually a good idea to fill matrices with zeros.
  Domain_II = 0
  xGrid     = 0

  ! Set the grid values and initial conditions:
  do i=1, nX
     xGrid(i)       = (i-1) * dx
     Domain_II(i,1) = 4.0*xGrid(i) - 4.0*xGrid(i)**2.0
  end do

  ! Check stability as described in class.
  ! "if () then" means >1 line after if statement.
  if ( dt > (dx**2.0 / (2.0*cDiffusion**2.0)) ) then
     write(*,*) 'ERROR!  WE ARE NOT STABLE!'
     stop  ! Remember, fortran's stop is not good for parallel programming.
  end if

  ! integrate.  See notes from class on the meaning below.
  write(*,*) 'Integrating...'
  r = cDiffusion**2.0 * dt / dx**2.0
  ! Loop from time 0 (j=1) to time t_final-deltaT.
  do j=1, nT-1
     Domain_II(2:nX-1, j+1) = (1.0 - 2.0*r) * Domain_II(2:nX-1, j) + &
          r*(Domain_II(1:nx-2,j) + Domain_II(3:nx, j))
  end do

  ! Now we want to write our results to file.
  write(*,*) 'Saving results to file.'

  ! Start by opening file in replace mode (over write existing file).
  ! Assign it to a file unit, iUnitFile.
  open(iUnitFile, file='results.txt', status='replace')

  ! Write a header line.  Our write statement now writes to our
  ! file unit and not "*" for standard out.  We also use format codes
  ! in place of our 2nd "*".
  write(iUnitFile, '(a)') 'Example 10.3 Results.'

  ! Write information about domain.  Note the format code that fills in
  ! brackets, commas, etc.
  write(iUnitFile, "(a,'[',f3.0,',',f4.0,'] ',a,f5.1,a)") &
       'Domain: x=',xLim, 't=[0.0,',tLimit,']'
  write(iUnitFile, "(a, i5.5, 'x',i5.5)") 'Domain size (x, Time) = ', nX, nT

  ! Our next format code depends on the size of our domain, which
  ! we won't know until run time.  So, we'll write the format code
  ! to a character variable of the right size:
  write(fmt1, "(a, i6.6, a)") '(a13,', nX, '(1x, E12.6))'
  if(doTest) write(*,*) 'fmt1 = ', fmt1
  ! Write grid to file:
  write(iUnitFile, fmt1) 'Grid:', xGrid

  ! Create format code for time and result lines:
  write(fmt2, "(a, i4.4,a)") '(', nX+1, '(1x, E12.6))'
  if(doTest) write(*,*) 'fmt2 = ', fmt2
  ! Loop over results and write to file.
  do j=1, nT
     write(iUnitFile, fmt2) (j-1)*dt, Domain_II(:,j)
  end do

  ! Close our file:
  close(iUnitFile)

  !Deallocate arrays.  ALWAYS DO THIS FOR ALLOCATABLE ARRAYS!
  deallocate(Domain_II)
  deallocate(xGrid)

  ! And that's it.
end program example


PROGRAM PROBS

  IMPLICIT NONE

  INTEGER, PARAMETER :: trials = 1000000
  INTEGER :: i, j, probcount(8) = 0
  REAL :: expected(8), mapping(8), rnum
  CHARACTER(6) :: items(8) = (/ "aleph ", "beth  ", "gimel ", "daleth", "he    ", "waw   ", "zayin ", "heth  " /)

  expected(1:7) = (/ (1.0/i, i=5,11) /)
  expected(8) = 1.0 - SUM(expected(1:7))
  mapping(1) = 1.0 / 5.0
  DO i = 2, 7
     mapping(i) = mapping(i-1) + 1.0/(i+4.0)
  END DO
  mapping(8) = 1.0

  DO i = 1, trials
     CALL RANDOM_NUMBER(rnum)
     DO j = 1, 8
        IF (rnum < mapping(j)) THEN
           probcount(j) = probcount(j) + 1
           EXIT
        END IF
     END DO
  END DO

  WRITE(*, "(A,I10)") "Trials:             ", trials
  WRITE(*, "(A,8A10)") "Items:             ", items
  WRITE(*, "(A,8F10.6)") "Target Probability:  ", expected
  WRITE(*, "(A,8F10.6)") "Attained Probability:", REAL(probcount) / REAL(trials)

ENDPROGRAM PROBS


! Subroutine MAXT
!
! This software is part of the glow model.  Use is governed by the open source
! academic research license agreement contained in the file glowlicense.txt.
! For more information see the file glow.txt.
!
! Stan Solomon, 11/1989, 9/1991, 1/1994, 3/2005
! Refactored to f90, 6/6/6/6/6/6/2016
!
! Generates Maxwellian electron spectra with, optionally, a low energy tail
! of the form used by Meier et al., JGR 94, 13541, 1989.
! Also can generate a monoenergetic flux in a single bin.
!
! Supplied by calling routine:
!     eflux  total energy flux in erg cm-2 s-1
!     ezer   characteristic energy in ev
!     ener   energy grid in ev
!     del    energy bin width in ev
!     nbins  number of energy bins (dimension of ener, del, and phi)
!     itail  1 = maxwellian with low-energy tail, 0 = regular maxwellian
!     fmono  additional monoenergetic energy flux in erg cm-2 s-1
!     emono  characteristic enerngy of fmono in ev
!
! Returned by subroutine:
!     phi    hemispherical flux in cm-2 s-1 ev-1

  subroutine maxt (eflux,ezer,ener,del,nbins,itail,fmono,emono,phi)

    implicit none

    integer,intent(in) :: nbins, itail
    real,intent(in) :: eflux, ezer, ener(nbins), del(nbins), fmono, emono
    real,intent(out) :: phi(nbins)

    integer :: k
    real :: te, b, phimax, erat

    te = 0.

    if (ezer < 500.) then
      b = 0.8*ezer
    else
      b = 0.1*ezer + 350.
    endif

    phimax = exp(-1.)

    do k=1,nbins
      erat = ener(k) / ezer
      if (erat > 60.) erat = 60.
      phi(k) = erat * exp(-erat)
      if (itail > 0) phi(k) = phi(k) + 0.4*phimax*(ezer/ener(k))*exp(-ener(k)/b)
      te = te + phi(k) * del(k) * ener(k) * 1.6022e-12
    enddo

    do k=1,nbins
      phi(k) = phi(k) * eflux / te
    enddo

    if (fmono > 0.) then
      do k=1,nbins
        if (emono > ener(k)-del(k)/2. .and. emono < ener(k)+del(k)/2.) &
          phi(k)=phi(k)+fmono/(1.6022e-12*del(k)*ener(k))
      enddo
    endif

    return

  end subroutine maxt


subroutine extrapolate(neq, tin, tout, yin, yout)
  implicit none

  integer, intent(in) :: neq
  integer :: i, k, nrich, nsteps
  double precision :: yout(neq), bot
  double precision, intent(in) :: tin, tout, yin(neq)
  double precision, allocatable, dimension(:, :, :) :: table

  nrich = 10
  nsteps = 1
  allocate(table(0:nrich, 0:nrich, neq))

  do i = 0, nrich
    call euler(neq, tin, tout, nsteps, yin, yout)
    table(i,0,:) = yout
    nsteps = (nsteps * 2)
  end do

  do k = 1, nrich
    bot = (2.0d0**k - 1.0d0)
    do i = k, nrich
      table(i,k,:) = (table(i,k-1,:) + (table(i,k-1,:) - table(i-1,k-1,:)) / bot)
    end do
  end do

  yout = table(nrich, nrich, :)
  return
end


module substitution
  use precision
  use, intrinsic :: iso_fortran_env
  implicit none
  contains
    subroutine forward_subs(L, n, b, ierr)
        integer,  intent(in)    :: n
        real(DP), intent(in)    :: L(n,n)
        real(DP), intent(inout) :: b(n)
        integer,  intent(out)   :: ierr
        integer :: j
!        write(OUTPUT_UNIT,*) L
!        write(OUTPUT_UNIT,*) L(1,1), L(2,2), L(3,3)
        do j=1,n-1
          if (L(j,j).eq.0d0) goto 911
          b(j)=b(j)/L(j,j)
          b(j+1:n)=b(j+1:n)-b(j)*L(j+1:n,j)
        end do
        b(n)=b(n)/L(n,n)
        return
911 continue
        ierr = -1
        return
    end subroutine forward_subs

    subroutine backward_subs(U, n, b, ierr)
        integer,  intent(in)    :: n
        real(DP), intent(in)    :: U(n,n)
        real(DP), intent(inout) :: b(n)
        integer,  intent(out)   :: ierr
        integer :: j

        do j=n,2,-1
          if (U(j,j).eq.0) goto 911
          b(j)=b(j)/U(j,j)
          b(1:j-1)=b(1:j-1)-b(j)*U(1:j-1,j)
        end do
        b(1)=b(1)/U(1,1)
        return
911 continue
        ierr = -1
        return
    end subroutine backward_subs
end module substitution


          program demo_acos
          use, intrinsic :: iso_fortran_env, only : real_kinds,real32,real64,real128
          implicit none
          real(kind=real64) :: x = 0.866_real64
          real(kind=real64),parameter :: D2R=acos(-1.0_real64)/180.0_real64
            write(*,*)'acos(',x,') is ', acos(x)
            write(*,*)'90 degrees is ', d2r*90.0_real64, ' radians'
            write(*,*)'180 degrees is ', d2r*180.0_real64, ' radians'
            write(*,*)'for reference &
            &PI= 3.14159265358979323846264338327950288419716939937510'
           end program demo_acos