module compare
  use iso_fortran_env, only: real32, real64
  implicit none
  private
  public :: eq, gt, lt, ge, le, setTol

  real, parameter, private :: tolerance = 1e-8

! Provide functions to compare real and complex variables within a
! tolerance value, tolerance.

  interface eq
    module procedure r_eq
    module procedure z_eq
    module procedure r64_eq
    module procedure r_eq_arr
    module procedure r64_eq_arr
  end interface eq

  interface gt
    module procedure r_gt
    module procedure z_gt
  end interface gt

  interface lt
    module procedure r_lt
    module procedure z_lt
  end interface lt

  interface ge
    module procedure r_ge
    module procedure z_ge
  end interface ge

  interface le
    module procedure r_le
    module procedure z_le
  end interface le

contains

  real pure function setTol (t)
    real, intent(in), optional :: t
    real, parameter :: tolerance = 1e-8

    if (present(t)) then
      setTol = t
    else
      setTol = tolerance
    end if
  end function setTol

  logical pure function r_eq (r1, r2, t)
    real, intent(in) :: r1, r2
    real, intent(in), optional :: t

    if (abs(r1 - r2) <= setTol(t)) then
      r_eq = .true.
    else
      r_eq = .false.
    end if
  end function r_eq

  logical pure function r64_eq (r1, r2, t)
    real(kind=real64), intent(in) :: r1, r2
    real, intent(in), optional :: t

    if (abs(r1 - r2) <= setTol(t)) then
      r64_eq = .true.
    else
      r64_eq = .false.
    end if
  end function r64_eq

  logical pure function z_eq (z1, z2, t)
    complex, intent(in) :: z1, z2
    real, intent(in), optional :: t

    if (abs(z1 - z2) <= setTol(t)) then
      z_eq = .true.
    else
      z_eq = .false.
    end if
  end function z_eq

  logical pure function r_eq_arr (r1,r2,t)
    real, dimension(:), intent(in) :: r1, r2
    real, intent(in), optional :: t
    integer :: i

    r_eq_arr = .false.

    if (size(r1) /= size(r2)) then
      return
    else
      do i = 1, size(r1)
        if (eq(r1(i),r2(i),setTol(t))) then
          r_eq_arr = .true.
        else
          r_eq_arr = .false.
          return
        end if
      end do
    end if
  end function r_eq_arr

  logical pure function r64_eq_arr (r1,r2,t)
    real(kind=real64), dimension(:), intent(in) :: r1, r2
    real, intent(in), optional :: t
    integer :: i

    r64_eq_arr = .false.

    if (size(r1) /= size(r2)) then
      return
    else
      do i = 1, size(r1)
        if (eq(r1(i),r2(i),setTol(t))) then
          r64_eq_arr = .true.
        else
          r64_eq_arr = .false.
          return
        end if
      end do
    end if
  end function r64_eq_arr

  logical pure function r_gt (r1, r2, t)
    real, intent(in) :: r1, r2
    real, intent(in), optional :: t

    if ((r1 - r2) > setTol(t)) then
      r_gt = .true.
    else
      r_gt = .false.
    end if
  end function r_gt

  logical pure function z_gt (z1, z2, t)
    complex, intent(in) :: z1, z2
    real, intent(in), optional :: t

    if ((real(z1) - real(z2)) > setTol(t)) then
      z_gt = .true.
    else
      z_gt = .false.
    end if
  end function z_gt

  logical pure function r_lt (r1, r2, t)
    real, intent(in) :: r1, r2
    real, intent(in), optional :: t

    if ((r2 - r1) > setTol(t)) then
      r_lt = .true.
    else
      r_lt = .false.
    end if
  end function r_lt

  logical pure function z_lt (z1, z2, t)
    complex, intent(in) :: z1, z2
    real, intent(in), optional :: t

    if ((real(z2) - real(z1)) > setTol(t)) then
      z_lt = .true.
    else
      z_lt = .false.
    end if
  end function z_lt

  logical pure function r_ge (r1, r2, t)
    real, intent(in) :: r1, r2
    real, intent(in), optional :: t

    if (r_eq(r1,r2, setTol(t)) .or. r_gt(r1,r2, setTol(t))) then
      r_ge = .true.
    else
      r_ge = .false.
    end if
  end function r_ge

  logical pure function z_ge (z1, z2, t)
    complex, intent(in) :: z1, z2
    real, intent(in), optional :: t

    if (z_eq(z1,z2,setTol(t)) .or. z_gt(z1,z2,setTol(t))) then
      z_ge = .true.
    else
      z_ge = .false.
    end if
  end function z_ge

  logical pure function r_le (r1, r2, t)
    real, intent(in) :: r1, r2
    real, intent(in), optional :: t

    if (r_eq(r1,r2,setTol(t)) .or. r_lt(r1,r2,setTol(t))) then
      r_le = .true.
    else
      r_le = .false.
    end if
  end function r_le

  logical pure function z_le (z1, z2, t)
    complex, intent(in) :: z1, z2
    real, intent(in), optional :: t

    if (z_eq(z1,z2,setTol(t)) .or. z_lt(z1,z2,setTol(t))) then
      z_le = .true.
    else
      z_le = .false.
    end if
  end function z_le

end module compare


      real function fprati(p1,f1,p2,f2,p3,f3)
c  given three points (p1,f1),(p2,f2) and (p3,f3), function fprati
c  gives the value of p such that the rational interpolating function
c  of the form r(p) = (u*p+v)/(p+w) equals zero at p.
c  ..
c  ..scalar arguments..
      real p1,f1,p2,f2,p3,f3
c  ..local scalars..
      real h1,h2,h3,p
c  ..
      if(p3.gt.0.) go to 10
c  value of p in case p3 = infinity.
      p = (p1*(f1-f3)*f2-p2*(f2-f3)*f1)/((f1-f2)*f3)
      go to 20
c  value of p in case p3 ^= infinity.
  10  h1 = f1*(f2-f3)
      h2 = f2*(f3-f1)
      h3 = f3*(f1-f2)
      p = -(p1*p2*h3+p2*p3*h1+p3*p1*h2)/(p1*h1+p2*h2+p3*h3)
c  adjust the value of p1,f1,p3 and f3 such that f1 > 0 and f3 < 0.
  20  if(f2.lt.0.) go to 30
      p1 = p2
      f1 = f2
      go to 40
  30  p3 = p2
      f3 = f2
  40  fprati = p
      return
      end


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   Computes elementary rotations
! ___________________________________________________________________
module z_ctransformations

use u_parameters
implicit none
private
public z_compute_ct, z_apply_ct_r, z_apply_ct_l, &
       z_compute_ct_complexc, z_apply_ct_r_complexc, z_apply_ct_l_complexc

contains

  subroutine z_compute_ct(x,y,c,s,r)
    ! Computes an elementary ctransformation that introduces a zero
    ! in a 2x1 vector :
    ! [ c  s ]    [ x  ]        [ r   ]
    ! [ _  _ ] *  [    ]    =   [     ]
    ! [-s  c ]    [ y  ]        [ 0   ]
    ! Wrapper around LAPACKs ZLARTG
    ! Our own implementation uses a complex variable for c. This is
    ! more efficient.
    !___________________________________________________________________________
    complex(kind=dp), intent(in)  :: x, y
    complex(kind=dp), intent(out) :: s, r
    real(kind=dp), intent(out)    :: c

    call ZLARTG( x, y, c, s, r )
  end subroutine

  subroutine z_apply_ct_l(v1,v2,c,s)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Applies an elementary rotation from the left to two row
  ! vectors v1 and v2 of equal lenght :
  ! [ c  s ]    [ v1  ]
  ! [ _    ] *  [     ]
  ! [-s  c ]    [ v2  ]
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! v1        complex double array [INOUT]
  !             First row vector, on output equal to c * v1 + s * v2
  ! v2        complex double array [INOUT]             _        _
  !             Second row vector, on output equal to -s * v1 + c * v2
  ! c         double [IN]
  !             Cosine of rotation
  ! s         complex double [IN]
  !             Sine of rotation
  !___________________________________________________________________________
  ! last edit: June 7, 2018
    complex(kind=dp), intent(inout)   ::  v1(:), v2(:)
    complex(kind=dp), intent(in)      ::  s
    real(kind=dp), intent(in)         ::  c

    integer i, n
    complex(kind=dp) t

    n = size(v1)

    do i = 1, n
        t = c * v1(i) + s * v2(i)
        !v2(i) = -dconjg(s) * v1(i) + dconjg(c) * v2(i) ! For own implementation
        v2(i) = -dconjg(s) * v1(i) + c * v2(i)
        v1(i) = t
    end do

  end subroutine

  subroutine z_apply_ct_r(v1,v2,c,s)
    ! DESCRIPTION
    !___________________________________________________________________________
    ! Applies an elementary rotation from the right to
    ! two column vectors v1 and v2 of equal length:
    ! [     ]   [ c  s ]
    ! [v1 v2] * [ _  _ ]
    ! [     ]   [-s  c ]
    !
    ! ARGUMENTS
    !___________________________________________________________________________
    ! v1        complex double array [INOUT]                       _
    !             First column vector, on output equal to c * v1 - s * v2
    ! v2        complex double array [INOUT]                     _
    !             Second column vector, on output equal to s * v1 + c * v2
    ! c         double [IN]
    !             Cosine of rotation
    ! s         complex double [IN]
    !             Sine of rotation
    !___________________________________________________________________________
    ! last edit: June 7, 2018
    complex(kind=dp), intent(inout) ::  v1(:), v2(:)
    complex(kind=dp), intent(in)    ::  s
    real(kind=dp), intent(in)    ::  c

    integer i, n
    complex(kind=dp)  t

    n = size(v1)

    do i = 1, n
        t = c * v1(i) - dconjg(s) * v2(i)
        !v2(i) = s * v1(i) + dconjg(c) * v2(i) ! For own implementation
        v2(i) = s * v1(i) + c * v2(i)
        v1(i) = t
    end do
  end subroutine

  subroutine z_compute_ct_complexc(x,y,c,s,r)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Computes an elementary ctransformation that introduces a zero
  ! in a 2x1 vector :
  ! [ c  s ]    [ x  ]        [ r   ]
  ! [ _  _ ] *  [    ]    =   [     ]
  ! [-s  c ]    [ y  ]        [ 0   ]
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! x         complex double [IN]
  !             First element of 2x1 vector
  ! y         complex double [IN]
  !             Second element of 2x1 vector
  ! c         complex double [OUT]
  !             Cosine of the rotation matrix
  ! s         complex double [OUT]
  !             Sine of the rotation matrix
  ! r         complex double [OUT]
  !             Remainder of the vector after rotating (2-norm)
  !
  !___________________________________________________________________________
  ! last edit: June 7, 2018
    complex(kind=dp), intent(in) :: x,y
    complex(kind=dp), intent(out) :: c,s,r

    complex(kind=dp)  :: theta, t

    if (abs(y) .lt. sfmin) then
      c = cone
      s = czero
      r = x
    else
        if( abs(x) .gt. abs(y) ) then
          theta = dconjg(x/abs(x))
          t = y/x
          r = sqrt(1.0_dp + abs(t)**2)
          c = theta / r
          s = dconjg(t) * c
          r = theta * x * r
        else
          theta = dconjg(y/abs(y))
          t = x/y
          r = sqrt(1.0_dp + abs(t)**2)
          s = theta / r
          c = dconjg(t) * s
          r = theta * y * r
        end if
    end if
  end subroutine

  subroutine z_apply_ct_l_complexc(v1,v2,c,s)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Applies an elementary rotation from the left to two row
  ! vectors v1 and v2 of equal lenght :
  ! [ c  s ]    [ v1  ]
  ! [ _  _ ] *  [     ]
  ! [-s  c ]    [ v2  ]
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! v1        complex double array [INOUT]
  !             First row vector, on output equal to c * v1 + s * v2
  ! v2        complex double array [INOUT]             _        _
  !             Second row vector, on output equal to -s * v1 + c * v2
  ! c         double [IN]
  !             Cosine of rotation
  ! s         complex double [IN]
  !             Sine of rotation
  !___________________________________________________________________________
  ! last edit: June 7, 2018
    complex(kind=dp), intent(inout)   ::  v1(:), v2(:)
    complex(kind=dp), intent(in)      ::  c, s

    integer i, n
    complex(kind=dp) t

    n = size(v1)

    do i = 1, n
        t = c * v1(i) + s * v2(i)
        v2(i) = -dconjg(s) * v1(i) + dconjg(c) * v2(i)
        v1(i) = t
    end do

  end subroutine

  subroutine z_apply_ct_r_complexc(v1,v2,c,s)
    ! DESCRIPTION
    !___________________________________________________________________________
    ! Applies an elementary rotation from the right to
    ! two column vectors v1 and v2 of equal length:
    ! [     ]   [ c  s ]
    ! [v1 v2] * [ _  _ ]
    ! [     ]   [-s  c ]
    !
    ! ARGUMENTS
    !___________________________________________________________________________
    ! v1        complex double array [INOUT]                       _
    !             First column vector, on output equal to c * v1 - s * v2
    ! v2        complex double array [INOUT]                     _
    !             Second column vector, on output equal to s * v1 + c * v2
    ! c         double [IN]
    !             Cosine of rotation
    ! s         complex double [IN]
    !             Sine of rotation
    !___________________________________________________________________________
    ! last edit: June 7, 2018
    complex(kind=dp), intent(inout) ::  v1(:), v2(:)
    complex(kind=dp), intent(in)    ::  c, s

    integer i, n
    complex(kind=dp)  t

    n = size(v1)

    do i = 1, n
        t = c * v1(i) - dconjg(s) * v2(i)
        v2(i) = s * v1(i) + dconjg(c) * v2(i)
        v1(i) = t
    end do
  end subroutine
end module


    Program zptsv_example

!     ZPTSV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: zptsv
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: info, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: b(:), e(:)
      Real (Kind=dp), Allocatable :: d(:)
!     .. Executable Statements ..
      Write (nout, *) 'ZPTSV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (b(n), e(n-1), d(n))

!     Read the lower bidiagonal part of the tridiagonal matrix A and
!     the right hand side b from data file

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)
      Read (nin, *) b(1:n)

!     Solve the equations Ax = b for x
      Call zptsv(n, 1, d, e, b, n, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Solution'
        Write (nout, 100) b(1:n)

!       Print details of factorization

        Write (nout, *)
        Write (nout, *) 'Diagonal elements of the diagonal matrix D'
        Write (nout, 110) d(1:n)
        Write (nout, *)
        Write (nout, *) 'Subdiagonal elements of the Cholesky factor L'
        Write (nout, 100) e(1:n-1)

      Else
        Write (nout, 120) 'The leading minor of order ', info, &
          ' is not positive definite'
      End If

100   Format (4(' (',F8.4,',',F8.4,')',:))
110   Format ((2X,F7.4,3(11X,F7.4)))
120   Format (1X, A, I3, A)
    End Program


!> \file kronecker.f90
!! |brief Module defining Kronecker operations for matrix computation
!!
!! @author Innocent Souopgui
!!
!<

!> Module defining Kronecker product for matrix computation
!!
!<
module kronecker
  USE general_constant
  USE debug_tools

  private kron_product_check, kron_product_check_diag, kron_product_check_full
  !>Forms the Kronecker product of two matrices
  INTERFACE kron_product
    MODULE PROCEDURE kron_product_full
    MODULE PROCEDURE kron_product_diag
  END INTERFACE kron_product

  !>Check the input for the Kronecker product of two matrix
  INTERFACE kron_product_check
    MODULE PROCEDURE kron_product_check_full
    MODULE PROCEDURE kron_product_check_diag
  END INTERFACE kron_product_check

  !> matrix vector multiplication with the matrix given by a Kronecker product of 2/3 matrices
  INTERFACE kron_matvec
    MODULE PROCEDURE kron_matvec_full ! matrices are full and represented by 2d arrays
    MODULE PROCEDURE kron_matvec_diag ! matrices are diagonal and represented by vectors
    MODULE PROCEDURE kron_matvec_full3 ! matrices are full and represented by 2d arrays
    MODULE PROCEDURE kron_matvec_diag3 ! matrices are diagonal and represented by vectors
  END INTERFACE kron_matvec

CONTAINS

  !> \brief Computes the matrix vector product with the matrix given by a Kronecker product of two matrices.
  !! param[in] A first matrix of the kronecker product, size nrA x ncA
  !! param[in] B second matrix of the kronecker product, size nrB x ncB
  !! param[in] f input vector of size ncA*ncB
  !! param[out] g output vector of size nrA*nrB
  !! param[in] trans (optional) says if the transpose of the input matrices should be used instead of those matrices themselves.
  !! computes g = Kron(A,B)f if trans is not present or is set to TRUE, g = Kron(A,B)^Tf = (f^TKron(A,B) )^T if trans is present and set to TRUE
  !<
  SUBROUTINE kron_matvec_full(A, B, f, g, trans)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: A, B
    REAL(cp), DIMENSION(:), INTENT(IN)  :: f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    LOGICAL , INTENT(IN), OPTIONAL :: trans
    !local variables
    REAL(cp), DIMENSION(SIZE(B,1)) :: td!direct computation
    REAL(cp), DIMENSION(SIZE(B,2)) :: tt!transpose computation
    INTEGER :: nrA, ncA, nrB, ncB!number of row of X(nrX), !number of column of X(ncX)
    INTEGER :: iA, jA, if_start, if_end, ig_start, ig_end, nf_predicted, ng_predicted
    LOGICAL ll_trans

    IF( PRESENT(trans) )THEN
      ll_trans = trans
    ELSE
      ll_trans = .FALSE.
    END IF

    IF(ll_trans)THEN
      nf_predicted = SIZE(A,1)*SIZE(B,1)
      ng_predicted = SIZE(A,2)*SIZE(B,2)
    ELSE
      nf_predicted = SIZE(A,2)*SIZE(B,2)
      ng_predicted = SIZE(A,1)*SIZE(B,1)
    END IF
    IF( (SIZE(f)/=nf_predicted).OR.(SIZE(g)/=ng_predicted) )THEN
      CALL debug('Expecting data with following specification, based on the shape of A and B', tag=dALLWAYS)
      CALL debug(nf_predicted, 'f of size :', tag=dALLWAYS)
      CALL debug(ng_predicted, 'g of size :', tag=dALLWAYS)
      CALL debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
      CALL debug(SHAPE(A), 'SHAPE(A)', tag=dALLWAYS)
      CALL debug(SHAPE(B), 'SHAPE(B)', tag=dALLWAYS)
      CALL stop_program('stopped from kron_matvec (with full matrices)')
    END IF

    nrA = SIZE(A,1)
    ncA = SIZE(A,2)
    nrB = SIZE(B,1)
    ncB = SIZE(B,2)

    g=0.0_cp
    IF(ll_trans)THEN! used the transposed
      if_start = 1
      if_end   = nrB
      DO iA = 1, nrA
        tt = MATMUL(f(if_start:if_end), B)
        ig_start = 1
        ig_end   = ncB
        DO jA=1,ncA
          g(ig_start:ig_end) = g(ig_start:ig_end) + A(iA,jA)*tt
          ig_start = ig_start + ncB
          ig_end   = ig_end   + ncB
        END DO
        if_start = if_start + nrB
        if_end   = if_end   + nrB
      END DO
    ELSE
      if_start = 1
      if_end   = ncB
      DO jA = 1, ncA
        td = MATMUL(B, f(if_start:if_end))
        ig_start = 1
        ig_end   = nrB
        DO iA=1,nrA
          g(ig_start:ig_end) = g(ig_start:ig_end) + A(iA,jA)*td
          ig_start = ig_start + nrB
          ig_end   = ig_end   + nrB
        END DO
        if_start = if_start + ncB
        if_end   = if_end   + ncB
      END DO
    END IF
  END SUBROUTINE kron_matvec_full

  !> @brief Computes the matrix vector product with the matrix given
  !!   by a Kronecker product of 3 matrices.
  !! @param[in] A first matrix of the kronecker product, size nrA x ncA
  !! @param[in] B second matrix of the kronecker product, size nrB x ncB
  !! @param[in] C third matrix of the kronecker product, size nrC x ncC
  !! @param[in] f input vector of size ncA*ncB*ncC
  !! @param[out] g output vector of size nrA*nrB*nrC
  !! @param[in] trans (optional) says if the transpose of the input matrices
  !!   should be used instead of those matrices themselves.
  !! @details computes g = Kron(A,B,C)f if trans is not present or is set to TRUE,
  !!   g = Kron(A,B)^Tf = (f^TKron(A,B,C) )^T if trans is present and set to TRUE
  !<
  subroutine kron_matvec_full3(A, B, C, f, g, trans)
    real(cp), dimension(:,:), intent(in) :: A, B, C
    real(cp), dimension(:), intent(in)  :: f
    real(cp), dimension(:), intent(out) :: g
    logical , intent(in), optional :: trans
    !local variables
    real(cp), dimension(size(B,1)*size(C,1)) :: td!direct computation
    real(cp), dimension(size(B,2)*size(C,2)) :: tt!transpose computation
    integer :: nrA, ncA, nrB, ncB, nrC, ncC!number of row of X(nrX), !number of column of X(ncX)
    integer :: iA, jA, iB, jB, if_start, if_end, ig_start&
             , ig_end, nf_predicted, ng_predicted
    logical ll_trans

    if( present(trans) )then
      ll_trans = trans
    else
      ll_trans = .false.
    end if

    if(ll_trans)then
      nf_predicted = size(A,1)*size(B,1)*size(C,1)
      ng_predicted = size(A,2)*size(B,2)*size(C,2)
    else
      nf_predicted = size(A,2)*size(B,2)*size(C,2)
      ng_predicted = size(A,1)*size(B,1)*size(C,1)
    end if
    if( (size(f)/=nf_predicted).or.(size(g)/=ng_predicted) )then
      call debug('Expecting data with following specification, based on the shape of A, B, C', tag=dALLWAYS)
      call debug(nf_predicted, 'f of size :', tag=dALLWAYS)
      call debug(ng_predicted, 'g of size :', tag=dALLWAYS)
      call debug('For debuging purpose, here are the shapes of A, B, C', tag=dALLWAYS)
      call debug(shape(A), 'SHAPE(A)', tag=dALLWAYS)
      call debug(shape(B), 'SHAPE(B)', tag=dALLWAYS)
      call debug(shape(C), 'SHAPE(C)', tag=dALLWAYS)
      call stop_program('stopped from kron_matvec (with full matrices)')
    end if

    nrA = size(A,1)
    ncA = size(A,2)
    nrB = size(B,1)
    ncB = size(B,2)
    nrC = size(C,1)
    ncC = size(C,2)

    g=0.0_cp
    if(ll_trans)then! used the transposed
      if_start = 1
      if_end   = nrB*nrC
      do iA = 1, nrA
        call kron_matvec(B, C, f(if_start:if_end), tt, trans=.true.)
        ig_start = 1
        ig_end   = ncB*ncC
        do jA=1,ncA
          g(ig_start:ig_end) = g(ig_start:ig_end) + A(iA,jA)*tt
          ig_start = ig_start + ncB*ncC
          ig_end   = ig_end   + ncB*ncC
        end do
        if_start = if_start + nrB*nrC
        if_end   = if_end   + nrB*nrC
      end do
    else
      if_start = 1
      if_end   = ncB*ncC
      do jA = 1, ncA
        call kron_matvec(B, C, f(if_start:if_end), td, trans=.false.)
        ig_start = 1
        ig_end   = nrB*nrC
        do iA=1,nrA
          g(ig_start:ig_end) = g(ig_start:ig_end) + A(iA,jA)*td
          ig_start = ig_start + nrB*nrC
          ig_end   = ig_end   + nrB*nrC
        end do
        if_start = if_start + ncB*ncC
        if_end   = if_end   + ncB*ncC
      end do
    end if
  end subroutine kron_matvec_full3

  !> \brief Computes the matrix vector product with the matrix given by
  !!   a Kronecker product of two matrices
  !! the difference with kron_matvec_full is that the matrices are diagonal
  !!   and represented by vectors of diagonal elements.
  !! @see kron_matvec_full for the description of parameters
  !<
  SUBROUTINE kron_matvec_diag(A, B, f, g)
    REAL(cp), DIMENSION(:), INTENT(IN) :: A, B, f
    REAL(cp), DIMENSION(:), INTENT(OUT) :: g
    !local variables
    INTEGER :: nA, nB !number of elements of X
    INTEGER :: iA, i_start, i_end, n_predicted

    nA = SIZE(A)
    nB = SIZE(B)
    n_predicted = nA*nB
    IF( (SIZE(f)/=n_predicted).OR.(SIZE(g)/=n_predicted) )THEN
      CALL debug('Expecting data with following specification, based on the shape of A and B', tag=dALLWAYS)
      CALL debug(n_predicted, 'f and g of size :', tag=dALLWAYS)
      CALL debug('For debuging purpose, here are the SIZE of A and B', tag=dALLWAYS)
      CALL debug(SIZE(A), 'SIZE(A)', tag=dALLWAYS)
      CALL debug(SIZE(B), 'SIZE(B)', tag=dALLWAYS)
      CALL stop_program('stopped from kron_matvec_diag')
    END IF

    g=0.0_cp

    i_start = 1
    i_end   = nB
    DO iA = 1, nA
      g(i_start:i_end) = A(iA)*( B*f(i_start:i_end) )
      i_start = i_start + nB
      i_end   = i_end   + nB
    END DO
  END SUBROUTINE kron_matvec_diag

  !> \brief Computes the matrix vector product with the matrix given by
  !!   a Kronecker product of 3 matrices
  !! the difference with kron_matvec_full3 is that the matrices are diagonal
  !!   and represented by vectors of diagonal elements.
  !! @see kron_matvec_full3 for the description of parameters
  !<
  subroutine kron_matvec_diag3(A, B, C, f, g)
    real(cp), dimension(:), intent(in) :: A, B, C, f
    real(cp), dimension(:), intent(out) :: g
    !local variables
    integer :: nA, nB, nC !number of elements of X
    integer :: iA, iB, i_start, i_end, n_predicted

    nA = size(A)
    nB = size(B)
    nC = size(C)
    n_predicted = nA*nB*nC
    if( (size(f)/=n_predicted).or.(size(g)/=n_predicted) )then
      call debug('Expecting data with following specification, based on the shape of A, B, C', tag=dALLWAYS)
      call debug(n_predicted, 'f and g of size :', tag=dALLWAYS)
      call debug('For debuging purpose, here are the SIZE of A and B', tag=dALLWAYS)
      call debug(size(A), 'size(A)', tag=dALLWAYS)
      call debug(size(B), 'size(B)', tag=dALLWAYS)
      call debug(size(C), 'size(C)', tag=dALLWAYS)
      call stop_program('stopped from kron_matvec_diag3')
    end if

    g=0.0_cp

    i_start = 1
    i_end   = nC
    do iA = 1, nA
        do iB = 1, nB
            g(i_start:i_end) = A(iA)*B(iB)*( C*f(i_start:i_end) )
            i_start = i_start + nC
            i_end   = i_end   + nC
        end do
    end do
  end subroutine kron_matvec_diag3

  !> Checks parameters of the kronecker product
  !! @see kron_product_full
  SUBROUTINE kron_product_check_full(A, B, C)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: A, B, C
    !local variables
    INTEGER :: nrA, ncA, nrB, ncB!number of row of X(nrX), !number of column of X(ncX)

    nrA = SIZE(A,1)
    ncA = SIZE(A,2)
    nrB = SIZE(B,1)
    ncB = SIZE(B,2)
    IF( ( SIZE(C,1)/=nrA*nrB ).OR.( ( SIZE(C,2)/=ncA*ncB ) ) )THEN
      CALL debug('Expecting C with following specification, based on the shape of A and B', tag=dALLWAYS)
      CALL debug((/nrA*nrB, ncA*ncB/), 'expected SHAPE(C)', tag=dALLWAYS)
      CALL debug('Get the following, check and try aigain', tag=dALLWAYS)
      CALL debug(SHAPE(C), 'SHAPE(C)', tag=dALLWAYS)
      CALL debug('For debuging purpose, here are the shapes of A and B', tag=dALLWAYS)
      CALL debug(SHAPE(A), 'SHAPE(A)', tag=dALLWAYS)
      CALL debug(SHAPE(B), 'SHAPE(B)', tag=dALLWAYS)
      CALL stop_program('Bad shape for output matrix in kronecker product')
    END IF
  END SUBROUTINE kron_product_check_full

  !> Checks parameters of the kronecker product
  !! @see kron_product_full
  SUBROUTINE kron_product_check_diag(A, B, C)
    REAL(cp), DIMENSION(:), INTENT(IN) :: A, B, C
    !local variables
    INTEGER :: nA, nB

    nA = SIZE(A)
    nB = SIZE(B)
    IF( SIZE(C)/=nA*nB )THEN
      CALL debug('Expecting C with following specification, based on the SIZE of A and B', tag=dALLWAYS)
      CALL debug(nA*nB, 'expected SIZE(C)', tag=dALLWAYS)
      CALL debug('Get the following, check and try aigain', tag=dALLWAYS)
      CALL debug(SIZE(C), 'SIZE(C)', tag=dALLWAYS)
      CALL debug('For debuging purpose, here are the SIZEs of A and B', tag=dALLWAYS)
      CALL debug(SIZE(A), 'SIZE(A)', tag=dALLWAYS)
      CALL debug(SIZE(B), 'SIZE(B)', tag=dALLWAYS)
      CALL stop_program('Bad SIZE for output matrix in diagonal kronecker product')
    END IF
  END SUBROUTINE kron_product_check_diag

  !> \brief Forms the Kronecker product of two matrices
  !! \param[in] A first matrix in the Kronecker product
  !! \param[in] B second matrix in the Kronecker product
  !! \param[out] C resulting matrix
  !<
  SUBROUTINE kron_product_full(A, B, C)
    REAL(cp), DIMENSION(:,:), INTENT(IN) :: A, B
    REAL(cp), DIMENSION(:,:), INTENT(OUT) :: C
    !local variables
    INTEGER :: nrA, ncA, nrB, ncB, nrC, ncC!number of row of X(nrX), !number of column of X(ncX)
    INTEGER :: iA, jA, jB, iC_start, iC_end, jC

    !checking the input parameters
    CALL kron_product_check(A, B, C)
    nrA = SIZE(A,1)
    ncA = SIZE(A,2)
    nrB = SIZE(B,1)
    ncB = SIZE(B,2)
    nrC = SIZE(C,1)
    ncC = SIZE(C,2)

    DO jA=1,ncA
      !computing a bloc of columns of C
      jC = (jA-1)*ncB + 1
      DO jB=1,ncB
        !computing a column of C
        iC_start = 1
        iC_end   = nrB
        DO iA=1,nrA
          C(ic_start:ic_end, jC) = A(iA,jA)*B(:,jB)
          iC_start = iC_start + nrB
          iC_end   = iC_end   + nrB
        END DO
        jC = jC + 1
      END DO
    END DO
  END SUBROUTINE kron_product_full

  !> \brief Forms the Kronecker product of two matrices
  !! the difference with kron_matvec_full is that the matrices are diagonal and represented by vectors of diagonal elements.
  !! @see kron_product_full for the description of parameters
  !<
  SUBROUTINE kron_product_diag(A, B, C)
    REAL(cp), DIMENSION(:), INTENT(IN) :: A, B
    REAL(cp), DIMENSION(:), INTENT(OUT) :: C
    !local variables
    INTEGER :: nA, nB
    INTEGER :: iA, iC_start, iC_end

    !checking the input parameters
    CALL kron_product_check(A, B, C)
    nA = SIZE(A)
    nB = SIZE(B)

    iC_start = 1
    iC_end   = nB
    DO iA=1,nA
      C(ic_start:ic_end) = A(iA)*B
      iC_start = iC_start + nB
      iC_end   = iC_end   + nB
    END DO
  END SUBROUTINE kron_product_diag

end module kronecker


!=======================================================================
! Subroutine to find Gregorian date from julian day number
SUBROUTINE gregorian (julian, year, month, day, hour)

IMPLICIT NONE

real,    intent(in)  :: julian
integer, intent(out) :: year, month, day, hour

integer :: i, j, k, l, n

l = julian + 68569
n = 4*l/146097
l = l - (146097*n+3)/4
i = 4000*(l+1)/1461001
l = l - 1461*i/4 + 31
j = 80*l/2447
k = l - 2447*j/80
l = j/11
j = j+2-12*l
i = 100*(n-49) + i + l

year = i
month = j
day = k
hour = NINT((julian - INT(julian))*24)

RETURN

END SUBROUTINE gregorian


subroutine example
   ! implied do loop to initialize a to values: 1,2,3,4,5,6,7,8,9,10

   ! integer :: a(10)=(/(j,j=1,10)/)
     integer :: a(10)=(/(j,j=1,10)/)

end subroutine example


      !>@author
      !>Netlib 2019
      !>@copyright Public Domain
      !>@brief
      !> Find a minimum between bounds (single precision version)
      !>Downloaded from Netlib, 2019,
      !>@param[in] ax: lower bound
      !>@param[in] bx: upper bound
      !>@param[in] f: function to minimize
      !>@param[in] tol: tolerance
      !>@return sfmin: location of minimum
c  To get r1mach, mail netlib
c       send r1mach from core
      real function sfmin(ax,bx,f,tol)
      real ax,bx,f,tol
      external f
c
c      an approximation  x  to the point where  f  attains a minimum  on
c  the interval  (ax,bx)  is determined.
c
c  input..
c
c  ax    left endpoint of initial interval
c  bx    right endpoint of initial interval
c  f     function subprogram which evaluates  f(x)  for any  x
c        in the interval  (ax,bx)
c  tol   desired length of the interval of uncertainty of the final
c        result (.ge.0.)
c
c  output..
c
c  fmin  abcissa approximating the point where  f  attains a
c        minimum
c
c      the method used is a combination of  golden  section  search  and
c  successive parabolic interpolation.  convergence is never much slower
c  than  that  for  a  fibonacci search.  if  f  has a continuous second
c  derivative which is positive at the minimum (which is not  at  ax  or
c  bx),  then  convergence  is  superlinear, and usually of the order of
c  about  1.324....
c      the function  f  is never evaluated at two points closer together
c  than  eps*abs(sfmin)+(tol/3), where eps is  approximately  the  square
c  root  of  the  relative  machine  precision.   if   f   is a unimodal
c  function and the computed values of   f   are  always  unimodal  when
c  separated  by  at least  eps*abs(x)+(tol/3), then  sfmin  approximates
c  the abcissa of the global minimum of  f  on the interval  ax,bx  with
c  an error less than  3*eps*abs(sfmin)+tol.  if   f   is  not  unimodal,
c  then sfmin may approximate a local, but perhaps non-global, minimum to
c  the same accuracy.
c      this function subprogram is a slightly modified  version  of  the
c  algol  60 procedure  localmin  given in richard brent, algorithms for
c  minimization without derivatives, prentice-hall, inc. (1973).
c
c
      real  a,b,c,d,e,eps,xm,p,q,r,tol1,t2,u,v,w,fu,fv,fw,
     2    fx,x,tol3
      real   abs, sqrt,r1mach
c
c  c is the squared inverse of the golden ratio
      c=0.5e0*(3.0e0- sqrt(5.0e0))
c
c  eps is approximately the square root of the relative machine
c  precision.
c
   10 eps=r1mach(4)
      tol1=eps+1.0e0
      eps= sqrt(eps)
c
      a=ax
      b=bx
      v=a+c*(b-a)
      w=v
      x=v
      e=0.0e0
      fx=f(x)
      fv=fx
      fw=fx
      tol3=tol/3.0e0
c
c  main loop starts here
c
   20 xm=0.5e0*(a+b)
      tol1=eps* abs(x)+tol3
      t2=2.0e0*tol1
c
c  check stopping criterion
c
      if ( abs(x-xm).le.(t2-0.5e0*(b-a))) go to 190
      p=0.0e0
      q=0.0e0
      r=0.0e0
      if ( abs(e).le.tol1) go to 50
c
c  fit parabola
c
      r=(x-w)*(fx-fv)
      q=(x-v)*(fx-fw)
      p=(x-v)*q-(x-w)*r
      q=2.0e0*(q-r)
      if (q.le.0.0e0) go to 30
      p=-p
      go to 40
   30 q=-q
   40 r=e
      e=d
   50 if (( abs(p).ge. abs(0.5e0*q*r)).or.(p.le.q*(a-x))
     2          .or.(p.ge.q*(b-x))) go to 60
c
c  a parabolic-interpolation step
c
      d=p/q
      u=x+d
c
c  f must not be evaluated too close to ax or bx
c
      if (((u-a).ge.t2).and.((b-u).ge.t2)) go to 90
      d=tol1
      if (x.ge.xm) d=-d
      go to 90
c
c  a golden-section step
c
   60 if (x.ge.xm) go to 70
      e=b-x
      go to 80
   70 e=a-x
   80 d=c*e
c
c  f must not be evaluated too close to x
c
   90 if ( abs(d).lt.tol1) go to 100
      u=x+d
      go to 120
  100 if (d.le.0.0e0) go to 110
      u=x+tol1
      go to 120
  110 u=x-tol1
  120 fu=f(u)
c
c  update  a, b, v, w, and x
c
      if (fx.gt.fu) go to 140
      if (u.ge.x) go to 130
      a=u
      go to 140
  130 b=u
  140 if (fu.gt.fx) go to 170
      if (u.ge.x) go to 150
      b=x
      go to 160
  150 a=x
  160 v=w
      fv=fw
      w=x
      fw=fx
      x=u
      fx=fu
      go to 20
  170 if ((fu.gt.fw).and.(w.ne.x)) go to 180
      v=w
      fv=fw
      w=u
      fw=fu
      go to 20
  180 if ((fu.gt.fv).and.(v.ne.x).and.(v.ne.w)) go to 20
      v=u
      fv=fu
      go to 20
c
c  end of main loop
c
  190 sfmin=x
      return
      end


program realcomp
  ! This program tests and compares the performance
  ! of single and double precision real problems

  use flips
  use rand

  implicit none

  ! types
  type(flips_s) :: gs
  type(flips_d) :: gd

  ! data matrices
  real(sp), dimension(:,:), allocatable :: amat_s, smat_s, mmat_s
  real(dp), dimension(:,:), allocatable :: amat_d, smat_d, mmat_d

  ! Errors
  real(sp) :: maxerr_s,meanerr_s
  real(dp) :: maxerr_d,meanerr_d

  ! Residuals
  real(sp) :: res_s
  real(dp) :: res_d

  ! Clocks/times
  real(dp) :: cts,cte,ctime1,ctime2
  real(sp) :: wts,wte,wtime1,wtime2

  ! Aux variables
  integer :: ns,n,bs,id, j

!  verbose = .TRUE.

  id = 0

  ! Set random seed
  call set_rand_seed()

  ! Ask size
  write(*,*) 'Give matrix size:'
  read(*,*) ns
  write(*,*) 'Press 1 for binary files.'
  read(*,*) id

  bs = 10

  ! allocate things
  allocate(amat_s(ns,ns),amat_d(ns,ns),smat_s(ns,1),smat_d(ns,1),mmat_s(ns,1),mmat_d(ns,1))

  ! Single pprecision

  ! Create data (theory matrix random, soluton 1's)
  call random_number(amat_s)
  !call random_number(smat_s)
  amat_s = 2.0 * amat_s - 1.0
  smat_s = 1.0
  mmat_s = matmul(amat_s,smat_s)

  ! init flips
  if (id==1) then
     call flips_init(gs,ns,1,idnum=100,buffersize=bs)
  else
     call flips_init(gs,ns,1,buffersize=bs,bandwidth=1)
  end if

!write(*,*) 'FLIPS init'

  ! add data and solve with residual
  call cpu_time(cts)
  !call system_clock(wts)
  do n = 1,ns
     call flips_add(gs,1,amat_s(n,:),mmat_s(n,:))
     !write(*,*) 'n=',n
  end do

!write(*,*) 'FLIPS ADD ready'

  call flips_solve(gs)

!write(*,*) 'FLIPS solve'

  call cpu_time(cte)
  !call system_clock(wte)
  !wtime1 = wte-wts
  ctime1 = cte-cts

  ! Calculate diagonal of the covariance
  call cpu_time(cts)
  !call system_clock(wts)
  call flips_calc_cov(gs,full=.FALSE.)

!write(*,*) 'FLIPS cov'

  call cpu_time(cte)
  !call system_clock(wte)
  !wtime2 = wte-wts
  ctime2 = cte-cts

  if (id==1) then
     allocate(gs%solmat(ns))
  !   do j = 1,ns
  !      read(gs%idnum*100+13,REC=j) gs%solmat(j)
  !   end do
     call flips_get('solu',gs,gs%solmat)

!write(*,*) 'FLIPS sol'

  end if

  ! Errors
  !maxerr_s = maxval(abs(smat_s(:,1) - gs%solmat))
  maxerr_s = maxval(((smat_s(:,1) - gs%solmat)/smat_s(:,1)))
  meanerr_s = sum(smat_s(:,1) - gs%solmat)/ns

  ! Print results
  write(*,*) '----------------------------------'
  write(*,*) 'Single precision, size:',ns
  write(*,*) '----------------------------------'
  write(*,*) '  Solution, CPU time:',ctime1
  write(*,*) '          FLOP Count:',gs%fc
  write(*,*) '              GFLOPS:',gs%fc/ctime1/1.0E9
  !write(*,*) 'Solution, wall clock:',wtime1
  write(*,*) 'Covariance, CPU time:',ctime2
  !write(*,*) 'Covariance, wall clock:',wtime2
  write(*,*) '          Mean error:',meanerr_s
  write(*,*) '     Max. rel. error:',maxerr_s
  write(*,*) '            Residual:',gs%residual
  !write(*,*) gs%solmat(1:5)
  write(*,*) '----------------------------------\n'

  ! Double precision
  ! Create data (theory matrix random, soluton 1's)
  call random_number(amat_d)
  !call random_number(smat_d)
  amat_d = 2.0D0 * amat_d - 1.0D0
  smat_d = 1.0D0
  mmat_d = matmul(amat_d,smat_d)

  ! init flips
  if (id==1) then
     call flips_init(gd,ns,1,idnum=200,buffersize=bs)
  else
     call flips_init(gd,ns,1,buffersize=bs)
  end if
  ! add data and solve with residual
  call cpu_time(cts)
  !call system_clock(wts)
  do n = 1,ns
     call flips_add(gd,1,amat_d(n,:),mmat_d(n,:))
 !    write(*,*) 'n=',n
  end do
  call flips_solve(gd)
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime1 = wte-wts
  ctime1 = cte-cts

  ! Calculate diagonal of the covariance
  call cpu_time(cts)
  !call system_clock(wts)
  call flips_calc_cov(gd,full=.FALSE.)
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime2 = wte-wts
  ctime2 = cte-cts

  if (id==1) then
     allocate(gd%solmat(ns))
  !   do j = 1,ns
  !      read(gd%idnum*100+13,REC=j) gd%solmat(j)
  !   end do
  call flips_get('solu',gd,gd%solmat)
  end if

  ! Errors
  !maxerr_d = maxval(abs(smat_d(:,1) - gd%solmat))
  maxerr_d = maxval(((smat_d(:,1) - gd%solmat)/smat_d(:,1)))
  meanerr_d = sum(smat_d(:,1) - gd%solmat)/ns

  ! Print results
  write(*,*) '----------------------------------'
  write(*,*) 'Double precision, size:',ns
  write(*,*) '----------------------------------'
  write(*,*) '  Solution, CPU time:',ctime1
  write(*,*) '          FLOP Count:',gd%fc
  write(*,*) '              GFLOPS:',gd%fc/ctime1/1.0D9
  !write(*,*) 'Solution, wall clock:',wtime1
  write(*,*) 'Covariance, CPU time:',ctime2
  !write(*,*) 'Covariance, wall clock:',wtime2
  write(*,*) '          Mean error:',meanerr_d
  write(*,*) '     Max. rel. error:',maxerr_d
  write(*,*) '            Residual:',gd%residual
  !write(*,*) gd%solmat(1:5)
  write(*,*) '----------------------------------\n'

end program realcomp


program BVEGaussVort
!******************************************************************************
!	Peter A. Bosler
!	Department of Mathematics
!	University of Michigan
!	pbosler@umich.edu
!
!******************************************************************************
!
!	This program solves the barotropic vorticity equation for the case of single Gaussian vortex on the sphere.
!
!	Bosler, P.A., "Particle Methods for Geophysical Flow on the Sphere," PhD Thesis; the University of Michigan, 2013.
!
!----------------
use NumberKindsModule
use OutputWriterModule
use LoggerModule
use SphereMeshModule
use RefineRemeshModule
use TracerSetupModule
use VTKOutputModule
use BVESetupModule
use BVEDirectSumModule
use ReferenceSphereModule

implicit none

include 'mpif.h'

!
!	mesh variables
!
type(SphereMesh) :: sphere
integer(kint) :: panelKind, initNest, AMR, nTracer, problemKind
!
!	time stepping variables
!
type(BVERK4Data) :: bveRK4
real(kreal) :: t, dt, tfinal
integer(kint) :: timesteps, timeJ
!
!	tracer variables
!
type(tracerSetup) :: cosBell
real(kreal) :: h0, RR, lat0, lon0
integer(kint) :: tracerID
real(kreal), allocatable :: massIntegral(:)
!
!	vorticity variables
!
type(BVESetup) :: gaussVort
real(kreal) :: vortLat, vortLon, bb, maxVort
real(kreal), allocatable :: totalKE(:), totalEns(:)
!
!	refinement variables
!
type(RefinementSetup) :: tracerRefine
real(kreal) :: tracerMaxTol, tracerVarTol
integer(kint) :: refinementLimit

type(RefinementSetup) :: vortRefine
real(kreal) :: circMaxTol, vortVarTol

type(RefinementSetup) :: flowMapRefine
real(kreal) :: lagVarTol

!
!	remeshing variables
!
integer(kint) :: remeshInterval, remeshCounter, resetAlpha
type(ReferenceSphere) :: refSphere
logical(klog) :: refSphereReady
!
!	User input
!
character(len = 128) :: namelistInputFile = 'gaussianVortex.namelist'
integer(kint) :: readStat
!
!	Output variables
!
type(VTKSource) :: vtkOut
character(len = 128) :: vtkRoot, vtkFile, outputDir, jobPrefix
character(len = 128) :: conservedDataFile, summaryFile
character(len = 56 ) :: amrString
integer(kint) :: frameCounter, frameOut, writeStat1, writeStat2
type(OutputWriter) :: writer
!
!	logging
!
type(Logger) :: exeLog
character(len=28) :: logKey
character(len=128) :: logString
!
!	general and mpi variables
!
integer(kint) :: i, j, k
integer(kint) :: mpiErrCode
integer(kint), parameter  :: BROADCAST_INT_SIZE = 6, BROADCAST_REAL_SIZE = 11
integer(kint) :: broadcastIntegers(BROADCAST_INT_SIZE)
real(kreal) :: broadcastReals(BROADCAST_REAL_SIZE)
real(kreal) :: wallClock

namelist /sphereDefine/ panelKind, initNest, AMR, tracerMaxTol, tracerVarTol, &
						refineMentLimit, circMaxTol, vortVarTol, lagVarTol
namelist /vorticityDefine/ 	vortLat, vortLon, bb, maxVort
namelist /timeStepping/ tfinal, dt,  remeshInterval, resetAlpha
namelist /fileIO/ outputDir, jobPrefix, frameOut

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	PROGRAM START
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD,numProcs,mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD,procRank,mpiErrCode)

call InitLogger(exeLog,procRank)

wallClock = MPI_WTIME()

!
!	read user input from namelist file, broadcast to all processes
!
call ReadNameListFile(procRank)
call MPI_BCAST(broadcastIntegers,BROADCAST_INT_SIZE,MPI_INTEGER,0,MPI_COMM_WORLD,mpiErrCode)
panelKind = broadcastIntegers(1)
AMR = broadcastIntegers(2)
initNest = broadcastIntegers(3)
refinementLimit = broadcastIntegers(4)
remeshInterval = broadcastIntegers(5)
resetAlpha = broadcastIntegers(6)

call MPI_BCAST(broadcastReals,BROADCAST_REAL_SIZE,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,mpiErrCode)
tracermaxTol = broadcastReals(1)
tracerVarTol = broadcastReals(2)
tfinal = broadcastReals(3)*ONE_DAY ! convert tfinal to seconds
circMaxTol = broadcastReals(4)
vortVarTol = broadcastReals(5)
dt = broadcastReals(6) * ONE_DAY
lagVarTol = broadcastReals(7)
vortLat = broadcastReals(8)
vortLon = broadcastReals(9)
bb = broadcastReals(10)
maxVort = broadcastReals(11)*OMEGA

refSphereReady = .FALSE.

!
!	define test case
!
problemKind = BVE_SOLVER
nTracer = 3
h0 = 1000.0_kreal	! height of cosine bell center
lat0 = 0.0_kreal	! latitude of cosine bell center
lon0 = 0.0_kreal ! longitude of cosine bell center
RR = EARTH_RADIUS/3.0_kreal ! radius of cosine bell
tracerID = 1
call New(cosBell, COS_BELL_NINT, COS_BELL_NREAL)
call InitCosineBellTracer(cosBell,lat0,lon0,RR,h0,tracerID)

call New(gaussVort,SINGLE_VORTEX_NINT,SINGLE_VORTEX_NREAL)
call InitSingleGaussianVortex(gaussVort,vortLat,vortLon,bb,maxVort)

!
!	initialize sphere
!
call New(sphere,panelKind,initNest,AMR,nTracer,problemKind)
call SetCosineBellTracerOnMesh(sphere,cosBell)
call SetFlowMapLatitudeTracerOnMesh(sphere,2)
call SetFlowMapLatitudeTracerOnMesh(sphere,3)
call SetSingleGaussianVortexOnMesh(sphere,gaussVort)
if ( AMR > 0 ) then

	call New(tracerRefine,refinementLimit,tracermaxTol,tracerVarTol,TRACER_REFINE,tracerID)
	call SetRelativeTracerTols(sphere,tracerRefine)

	call New(vortRefine,refinementLimit,circMaxTol,vortVarTol,RELVORT_REFINE)
	call SetRelativeVorticityTols(sphere,vortRefine)

	call New(flowMapREfine,refinementLimit,100000.0_kreal,lagVarTol,FLOWMAP_REFINE)
	call SetRelativeFlowMapTol(sphere,flowMapRefine)

	!
	!	initial refinement
	!
	call InitialRefinement(sphere,tracerRefine,SetCosineBellTracerOnMesh, cosBell, &
						   vortRefine, SetSingleGaussianVortexOnMesh,gaussVort)

	call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,logKey,' initial refinement done.')

	if ( panelKind == QUAD_PANEL) then
		write(amrString,'(A,I1,A,I0.2,A)') 'quadAMR_',initNest,'to',initNest+refinementLimit,'_'
	endif
else ! uniform mesh
	! nullify AMR variables
	call New(tracerRefine)
	call New(vortRefine)
	call New(flowMapRefine)
	if ( panelKind == QUAD_PANEL ) then
		write(amrString,'(A,I1,A)') 'quadUnif',initNest,'_'
	endif
endif

call SetFlowMapLatitudeTracerOnMesh(sphere,2)
call SetFlowMapLatitudeTracerOnMesh(sphere,3)

!
!	initialize output, output t = 0 data
!
frameCounter = 0
if ( procRank == 0 ) then
	call LogStats(sphere,exeLog,'initial mesh :')
	write(vtkRoot,'(A,A,A,A,A)') trim(outputDir), '/vtkOut/',trim(jobPrefix),trim(amrString),'_'
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot),frameCounter,'.vtk'

	call New(vtkOut,sphere,vtkFile,'gaussVort')
	call VTKOutput(vtkOut,sphere)
	frameCounter = frameCounter + 1
endif
!
!	intialize timestepping
!
call New(bveRK4,sphere,numProcs)
timesteps = floor(tfinal/dt)
t = 0.0_kreal
remeshCounter = 0

allocate(totalKE(0:timesteps))
allocate(totalEns(0:timesteps))
allocate(massIntegral(0:timesteps))
totalKE = 0.0_kreal
totalEns = 0.0_kreal
massIntegral = 0.0_kreal

massIntegral(0) = TotalMass(sphere,1)
totalEns(0) = TotalEnstrophy(sphere)

call StartSection(exeLog,'initial setup complete:')
	call LogMessage(exeLog,TRACE_LOGGING_LEVEL,'initial Rossby number : ',GetRossbyNumber(sphere) )
call EndSection(exeLog)

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	RUN THE PROBLEM
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do timeJ = 0, timesteps - 1
	!
	!	remesh if necessary
	!
	if ( mod(timeJ+1,remeshInterval) == 0 ) then
		remeshCounter = remeshCounter + 1
		!
		!	delete objects associated with old mesh
		!
		call Delete(bveRK4)
		call Delete(vtkOut)
		!
		! build new mesh
		!
		if (remeshCounter < resetAlpha ) then
			call LagrangianRemesh(sphere, SetSingleGaussianVortexOnMesh, gaussVort, vortRefine, &
										  SetCosineBellTracerOnMesh, cosBell, tracerRefine, &
										  flowMapRefine)
			call SetFlowMapLatitudeTracerOnMesh(sphere,2)
			call SetFlowMapLatitudeTracerOnMesh(sphere,3)
		elseif ( mod(remeshCounter,resetAlpha) == 0 ) then

			call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,logKey,' developing new mapping time.')

			if ( refSphereReady ) then
				call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,logKey,' deleting reference sphere.')
				call Delete(refSphere)
				refSphereReady = .FALSE.
			endif

			call New(refSphere,sphere)
			refSphereReady = .TRUE.
			call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,logKey,' reference sphere returned.')

			flowMapRefine%type = NULL_REFINE
			call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,logKey,' flowMap refinement nullified.')

			call ResetLagrangianParameter(sphere)
			call LagrangianRemesh(sphere,refSphere,vortRefine,tracerRefine,flowMapRefine)

  		    call ResetLagrangianParameter(sphere)
  		    flowMapRefine%type = FLOWMAP_REFINE

!			if ( procRank == 0 .AND. mod(timeJ+1,frameOUt) == 0  ) then
!				call LogMessage(exeLog,TRACE_LOGGING_LEVEL,'day = ',t/ONE_DAY)
!				write(vtkFile,'(A,A,A)') trim(vtkRoot), 'NEW', '.vtk'
!				call UpdateFileName(vtkOut,vtkFile)
!				call VTKOutput(vtkOut,sphere)
!				frameCounter = frameCounter + 1
!			endif

			call SetFlowMapLatitudeTracerOnMesh(sphere,3)

		    call LogMessage(exeLog,TRACE_LOGGING_LEVEL,logkey,'RESET LAGRANGIAN PARAMETER')

		else
		    call LagrangianRemesh(sphere,refSphere,vortRefine,tracerRefine,flowMapRefine)
		    call SetFlowMapLatitudeTracerOnMesh(sphere,3)
		endif
		!
		!	create new associated objects
		!
		call New(bveRK4,sphere,numProcs)
		call New(vtkOut,sphere,vtkFile,'gaussVort')

		write(logString,'(A,I4)') 'remesh ', remeshCounter
		if ( procRank == 0 ) call LogStats(sphere,exelog,trim(logString))
	endif
	!
	!	advance timestep
	!
	call BVERK4Timestep(bveRK4, sphere, dt, procRank, numProcs)

	if ( timeJ == 0 ) totalKE(0) = sphere%totalE
	totalKE(timeJ+1) = sphere%totalE
	totalEns(timeJ+1) = TotalEnstrophy(sphere)
	massIntegral(timeJ+1) = TotalMass(sphere,1)

	t = real(timeJ+1,kreal)*dt
	!
	!	output timestep data
	!
	if ( procRank == 0 .AND. mod(timeJ+1,frameOUt) == 0  ) then
		call LogMessage(exeLog,TRACE_LOGGING_LEVEL,'day = ',t/ONE_DAY)
		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'
		call UpdateFileName(vtkOut,vtkFile)
		call VTKOutput(vtkOut,sphere)
		frameCounter = frameCounter + 1
	endif
enddo
!
!	output final data
!
if ( procRank == 0 ) then
	write(vtkRoot,'(A,A,A,A,A)') trim(outputDir), '/vtkOut/',trim(jobPrefix),trim(amrString),'_'
	write(conservedDataFile,'(6A)') trim(outputDir), '/',trim(jobPrefix), trim(amrString),'_conservedData', '.txt'
	write(summaryFile,'(6A)') trim(outputDir), '/',trim(jobPrefix), trim(amrString),'_summary', '.txt'

	open(unit=WRITE_UNIT_1,file=conservedDataFile,status='REPLACE',action='WRITE',iostat=writeStat1)
	if ( writeStat1 /= 0 ) then
		call LogMessage(exeLog,ERROR_LOGGING_LEVEL,trim(logKey),' ERROR writing final data.')
	else
		write(WRITE_UNIT_1,'(3A24)') 'totalMass', 'totalKE', 'totalEns'
		do j = 0, timesteps
			write(WRITE_UNIT_1,'(E24.8,E24.8, E24.8)') massIntegral(j), totalKE(j), totalEns(j)
		enddo
	endif
	close(WRITE_UNIT_1)

	call New(writer,WRITE_UNIT_2,summaryFile)
	call StartSection(writer,'JOB SUMMARY :',' SINGLE GAUSSIAN VORTEX')
	call Write(writer,'tfinal = ',tfinal)
	call Write(writer,'dt = ', dt )
	call Write(writer,'remeshInterval = ',remeshInterval)
	call Write(writer,'resetAlpha = ', resetAlpha)
	if (AMR > 0 ) then
		call Write(writer,'AMR, initNest = ', initNest)
		call Write(writer,'AMR, maxNest = ', maxval(sphere%panels%nest))
		call Write(writer,'AMR, refinementLimit = ', refinementLimit)
		call Write(writer,'circMaxTol = ', vortRefine%maxTol)
		call Write(writer,'relVortVarTol = ', vortRefine%varTol)
		call Write(writer,'tracer1 maxTol = ', tracerRefine%maxTol)
		call Write(writer,'tracer1 varTol = ', tracerRefine%maxTol)
		call Write(writer,'flowMap varTol = ', flowMapRefine%varTol)
	else
		call Write(writer,'uniformMesh, initNest = ', initNest)
	endif

	call Delete(writer)
endif
! TO DO : output final data

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	Clear memory and Finalize
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

write(logstring,'(A, F8.2,A)') 'elapsed time = ', (MPI_WTIME() - wallClock)/60.0, ' minutes.'
call LogMessage(exelog,TRACE_LOGGING_LEVEL,'PROGRAM COMPLETE : ',trim(logstring))

deallocate(totalKE)
deallocate(totalEns)
deallocate(massIntegral)
if ( refSphereReady ) call Delete(refSphere)
call Delete(bveRK4)
if ( procRank == 0 ) call Delete(vtkOut)
call Delete(vortRefine)
call Delete(tracerRefine)
call Delete(flowmapRefine)
call Delete(cosBell)
call Delete(gaussVort)
call Delete(exeLog)
call MPI_FINALIZE(mpiErrCode)

contains

subroutine ReadNamelistfile(rank)
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		open(unit = READ_UNIT, file = namelistInputFile, status = 'OLD', action = 'READ',iostat= readStat)
			if ( readstat /= 0 ) then
				stop 'cannot read namelist file.'
			endif
			read(READ_UNIT,nml=sphereDefine)
			rewind(READ_UNIT)
            read(READ_UNIT,nml=vorticityDefine)
            rewind(READ_UNIT)
			read(READ_UNIT,nml=timestepping)
			rewind(READ_UNIT)
			read(READ_UNIT,nml=fileIO)

			broadcastIntegers(1) = panelKind
			broadcastIntegers(2) = AMR
			broadcastIntegers(3) = initNest
			broadcastIntegers(4) = refinementLimit
			broadcastIntegers(5) = remeshInterval
                        broadcastIntegers(6) = resetAlpha

			broadcastReals(1) = tracerMaxTol
			broadcastReals(2) = tracerVarTol
			broadcastReals(3) = tfinal
			broadcastReals(4) = circMaxTol
			broadcastReals(5) = vortVarTol
			broadcastReals(6) = dt
			broadcastReals(7) = lagVarTol
			broadcastReals(8) = vortLat
			broadcastReals(9) = vortLon
			broadcastReals(10) = bb
			broadcastReals(11) = maxVort
	endif
end subroutine

subroutine InitLogger(alog,rank)
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		call New(aLog,DEBUG_LOGGING_LEVEL)
	else
		call New(aLog,DEBUG_LOGGING_LEVEL)
	endif
        write(logKey,'(A,I0.2,A)') 'EXE_LOG',procRank,' : '
end subroutine

end program


program test_set_activation_function

  ! This program will test whether per-network and per-layer
  ! setting of activation functions works as expected.
  ! First we create an array of random variables.
  ! Then we set different activation functions to different
  ! layers in the network.
  ! Finally, we test whether each function produces same
  ! values as the activation functions set in the layers.

  use mod_activation
  use mod_network, only: network_type
  use mod_random, only: randn

  implicit none
  type(network_type) :: net
  real, allocatable :: x(:)
  integer :: n
  logical, allocatable :: tests(:)

  tests = [logical ::]

  x = randn(100)

  ! the network will be created with
  ! sigmoid activation functions for all layers
  net = network_type([1, 1, 1, 1, 1])

  do n = 1, size(net % layers)
    tests = [tests, all(sigmoid(x) == net % layers(n) % activation(x))]
    tests = [tests, all(sigmoid_prime(x) == net % layers(n) % activation_prime(x))]
  end do

  ! now set the various functions for other layers
  call net % layers(2) % set_activation('gaussian')
  call net % layers(3) % set_activation('step')
  call net % layers(4) % set_activation('tanh')
  call net % layers(5) % set_activation('relu')

  tests = [tests, all(sigmoid(x) == net % layers(1) % activation(x))]
  tests = [tests, all(sigmoid_prime(x) == net % layers(1) % activation_prime(x))]

  tests = [tests, all(gaussian(x) == net % layers(2) % activation(x))]
  tests = [tests, all(gaussian_prime(x) == net % layers(2) % activation_prime(x))]

  tests = [tests, all(step(x) == net % layers(3) % activation(x))]
  tests = [tests, all(step_prime(x) == net % layers(3) % activation_prime(x))]

  tests = [tests, all(tanhf(x) == net % layers(4) % activation(x))]
  tests = [tests, all(tanh_prime(x) == net % layers(4) % activation_prime(x))]

  tests = [tests, all(relu(x) == net % layers(5) % activation(x))]
  tests = [tests, all(relu_prime(x) == net % layers(5) % activation_prime(x))]

  print *, tests

  if (all(tests)) then
    print *, 'All tests passed.'
  else
    error stop 'some tests failed.'
  end if

end program test_set_activation_function


program problem41
  use euler
  implicit none
  integer, parameter        :: limit=9
  integer, dimension(limit) :: c, A
  integer                   :: i,temp,n,answer=0

  do n=limit,2,-1

     ! Start of Heap's Algorithm
     ! Source: https://en.wikipedia.org/wiki/Heap%27s_algorithm
     do i=1,n
        c(i)=0
        A(i)=i
     end do

     temp=number(A,n)
     if (is_prime(int8(temp)) .and. temp>answer) answer=temp

     i=0
     do while (i<n)
        if (c(i+1)<i) then
           if (mod(i,2)==0) then
              temp=A(0+1)
              A(0+1)=A(i+1)
              A(i+1)=temp
           else
              temp=A(c(i+1)+1)
              A(c(i+1)+1)=A(i+1)
              A(i+1)=temp
           end if
           temp=number(A,n)
           if (is_prime(int8(temp)) .and. temp>answer) answer=temp
           c(i+1)=c(i+1)+1
           i=0
        else
           c(i+1)=0
           i=i+1
        end if

     end do
     ! End of Heap's Algorithm

     if (answer>0) exit

  end do

  print *, answer

contains
  pure function number(A,n)
    implicit none
    integer, dimension(limit), intent(in) :: A
    integer, intent(in)                   :: n
    integer                               :: number,i

    number=0

    do i=1,n
       number=number*10
       number=number+A(i)
    end do

  end function number

end program problem41


SUBROUTINE p81(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.1 One dimensional consolidation analysis using 2-node "rod"
!             elements. Implicit time integration using the "theta" method.
!-------------------------------------------------------------------------
 USE main
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,j,nels,neq,nlen,nod=2,npri,nprops=1,       &
   np_types,nres,nstep,ntime
 REAL(iwp)::at,a0,dtim,penalty=1.0e20_iwp,pt5=0.5_iwp,theta,time,         &
   zero=0.0_iwp
 CHARACTER(LEN=15)::argv
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),node(:),num(:),kdiag(:)
 REAL(iwp),ALLOCATABLE::bp(:),ell(:),kc(:,:),kv(:),loads(:),newlo(:),     &
   mm(:,:),press(:),prop(:,:),storbp(:),value(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,np_types
 neq=nels+1
 ALLOCATE(num(nod),etype(nels),kc(nod,nod),mm(nod,nod),press(0:neq),      &
   prop(nprops,np_types),ell(nels),kdiag(neq),loads(0:neq),newlo(0:neq))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell
 READ(10,*)dtim,nstep,theta,npri,nres,ntime
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   num=(/iel,iel+1/)
   CALL fkdiag(kdiag,num)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),bp(kdiag(neq)))
 bp=zero
 kv=zero
 WRITE(11,'(2(a,i5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------global conductivity and "mass" matrix assembly----
 elements_2: DO iel=1,nels
 num=(/iel,iel+1/)
   CALL rod_km(kc,prop(1,etype(iel)),ell(iel))
   CALL rod_mm(mm,ell(iel))
   CALL fsparv(kv,kc,num,kdiag)
   CALL fsparv(bp,mm,num,kdiag)
 END DO elements_2
 kv=kv*theta*dtim
 bp=bp+kv
 kv=bp-kv/theta
!-----------------------specify initial and boundary values---------------
 loads(0)=zero
 READ(10,*)loads(1:)
 a0=zero
 DO iel=1,nels
   a0=a0+pt5*ell(iel)*(loads(iel)+loads(iel+1))
 END DO
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)then
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms),                   &
            storbp(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   bp(kdiag(node))=bp(kdiag(node))+penalty
   storbp=bp(kdiag(node))
 END IF
!-----------------------factorise equations-------------------------------
 CALL sparin(bp,kdiag)
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/a,i3,a)')"    Time         Uav      Pressure (node",nres,")"
 WRITE(11,'(3e12.4)')0.0,0.0,loads(nres)
 timesteps: DO j=1,nstep
   time=j*dtim
   CALL linmul_sky(kv,loads,newlo,kdiag)
   IF(fixed_freedoms/=0)newlo(node)=storbp*value
   CALL spabac(bp,newlo,kdiag)
   loads=newlo
   at=zero
   DO iel=1,nels
     at=at+pt5*ell(iel)*(loads(iel)+loads(iel+1))
   END DO
   IF(j==ntime)press(1:)=loads(1:)
   IF(j/npri*npri==j)WRITE(11,'(3e12.4)')time,(a0-at)/a0,loads(nres)
 END DO timesteps
 WRITE(11,'(/a,e10.4,a)')"    Depth     Pressure (time=",ntime*dtim,")"
 WRITE(11,'(3e12.4)')0.0,press(1)
 WRITE(11,'(2e12.4)')(SUM(ell(1:i)),press(i+1),i=1,nels)

END SUBROUTINE p81


! The Functional Just System (FJS) has been invented by misotanni.
! For a complete description, see https://misotanni.github.io/fjs.
! Here, we only use the microtonal accidentals defined by the FSJ.

module fjs
   use constants
   implicit none
   private

   public :: accidentals, comma

contains

   function factorize(n) result(primes)
      integer, allocatable :: primes(:)
      integer, intent(in) :: n

      integer :: i, j

      allocate(primes(1:n))
      primes = 0

      i = n
      j = 2

      do while (i .gt. 1)
         if (modulo(i, j) .eq. 0) then
            primes(j) = primes(j) + 1
            i = i / j
         else
            j = j + 1
         end if
      end do
   end function factorize

   function accidentals(ratio)
      integer, allocatable :: accidentals(:)

      character(*), intent(in) :: ratio

      integer :: i, j, stat
      integer :: numerator, denominator
      integer, allocatable :: primes(:), tmp(:)

      numerator = 1
      denominator = 1

      i = scan(ratio, ':/')
      if (i .eq. 0) i = len(ratio) + 1

      read (ratio(:i - 1), *, iostat=stat) j
      if (stat .eq. 0) numerator = j

      read (ratio(i + 1:), *, iostat=stat) j
      if (stat .eq. 0) denominator = j

      allocate(primes(1:max(numerator, denominator)))
      primes = 0

      tmp = factorize(numerator)
      primes(:size(tmp)) = primes(:size(tmp)) + tmp

      tmp = factorize(denominator)
      primes(:size(tmp)) = primes(:size(tmp)) - tmp

      allocate(accidentals(sum(abs(primes))))

      j = 1
      do i = 1, size(primes)
         accidentals(j:) = sign(i, primes(i))
         j = j + abs(primes(i))
      end do
   end function accidentals

   elemental function red(d)
      real(dp) :: red
      real(dp), intent(in) :: d

      red = d / 2.0_dp ** floor(log(d) / log(2.0_dp))
   end function red

   elemental function reb(d)
      real(dp) :: reb
      real(dp), intent(in) :: d

      reb = red(sqrt(2.0_dp) * red(d)) / sqrt(2.0_dp)
   end function reb

   elemental function cents(d)
      real(dp) :: cents
      real(dp), intent(in) :: d

      cents = 1200.0_dp * log(d) / log(2.0_dp)
   end function cents

   elemental function error(d)
      real(dp) :: error
      real(dp), intent(in) :: d

      error = abs(cents(reb(d)))
   end function error

   elemental function master(d) result(f)
      integer :: f
      real(dp), intent(in) :: d

      real(dp) :: tol

      tol = error(65.0_dp / 63.0_dp)

      f = 0
      do while (error(d / 3.0_dp ** f) .ge. tol)
         f = -f
         if (f .ge. 0) f = f + 1
      end do
   end function master

   elemental function comma(p)
      real(dp) :: comma
      integer, intent(in) :: p

      real(dp), parameter :: Pyth_comma = 3.0_dp ** 12.0_dp / 2.0_dp ** 19.0_dp
      integer :: d

      d = abs(p)

      if (d .eq. 3) then
         comma = Pyth_comma
      else
         comma = reb(d / 3.0_dp ** master(real(d, dp)))
      end if

      if (p .lt. 0) comma = 1.0_dp / comma
   end function comma
end module fjs


*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLADIV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
*       .. Scalar Arguments ..
*       DOUBLE PRECISION   A, B, C, D, P, Q
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLADIV performs complex division in  real arithmetic
*>
*>                       a + i*b
*>            p + i*q = ---------
*>                       c + i*d
*>
*> The algorithm is due to Michael Baudin and Robert L. Smith
*> and can be found in the paper
*> "A Robust Complex Division in Scilab"
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] A
*> \verbatim
*>          A is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION
*>          The scalars a, b, c, and d in the above expression.
*> \endverbatim
*>
*> \param[out] P
*> \verbatim
*>          P is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is DOUBLE PRECISION
*>          The scalars p and q in the above expression.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date January 2013
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      SUBROUTINE DLADIV( A, B, C, D, P, Q )
*
*  -- LAPACK auxiliary routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     January 2013
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, D, P, Q
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   BS
      PARAMETER          ( BS = 2.0D0 )
      DOUBLE PRECISION   HALF
      PARAMETER          ( HALF = 0.5D0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D0 )
*
*     .. Local Scalars ..
      DOUBLE PRECISION   AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLADIV1
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. Executable Statements ..
*
      AA = A
      BB = B
      CC = C
      DD = D
      AB = MAX( ABS(A), ABS(B) )
      CD = MAX( ABS(C), ABS(D) )
      S = 1.0D0

      OV = DLAMCH( 'Overflow threshold' )
      UN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Epsilon' )
      BE = BS / (EPS*EPS)

      IF( AB >= HALF*OV ) THEN
         AA = HALF * AA
         BB = HALF * BB
         S  = TWO * S
      END IF
      IF( CD >= HALF*OV ) THEN
         CC = HALF * CC
         DD = HALF * DD
         S  = HALF * S
      END IF
      IF( AB <= UN*BS/EPS ) THEN
         AA = AA * BE
         BB = BB * BE
         S  = S / BE
      END IF
      IF( CD <= UN*BS/EPS ) THEN
         CC = CC * BE
         DD = DD * BE
         S  = S * BE
      END IF
      IF( ABS( D ).LE.ABS( C ) ) THEN
         CALL DLADIV1(AA, BB, CC, DD, P, Q)
      ELSE
         CALL DLADIV1(BB, AA, DD, CC, P, Q)
         Q = -Q
      END IF
      P = P * S
      Q = Q * S
*
      RETURN
*
*     End of DLADIV
*
      END

      SUBROUTINE DLADIV1( A, B, C, D, P, Q )
*
*  -- LAPACK auxiliary routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     January 2013
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, D, P, Q
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
*
*     .. Local Scalars ..
      DOUBLE PRECISION   R, T
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLADIV2
      EXTERNAL           DLADIV2
*     ..
*     .. Executable Statements ..
*
      R = D / C
      T = ONE / (C + D * R)
      P = DLADIV2(A, B, C, D, R, T)
      A = -A
      Q = DLADIV2(B, A, C, D, R, T)
*
      RETURN
*
*     End of DLADIV1
*
      END

      DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T )
*
*  -- LAPACK auxiliary routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     January 2013
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, D, R, T
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
*
*     .. Local Scalars ..
      DOUBLE PRECISION   BR
*     ..
*     .. Executable Statements ..
*
      IF( R.NE.ZERO ) THEN
         BR = B * R
         if( BR.NE.ZERO ) THEN
            DLADIV2 = (A + BR) * T
         ELSE
            DLADIV2 = A * T + (B * T) * R
         END IF
      ELSE
         DLADIV2 = (A + D * (B / C)) * T
      END IF
*
      RETURN
*
*     End of DLADIV12
*
      END


subroutine lmn_ComputeDensity(a)
   use typre
   use Mod_Element
   use Mod_LowMach
   implicit none
   class(LowMachProblem)  :: a
   real(rp)               :: aux1
   integer(ip)            :: npoin,ipoin

   !Initializations
   call a%Mesh%GetNpoin(npoin)

   select case (a%kfl_eqnst)
   case (1)     !Ideal gas
      aux1 = a%pther(1)/a%sgasc
      do ipoin=1,npoin
         a%densf(1:ipoin) = aux1/a%tempe(1:ipoin,1)
      end do
   case default !Constant density
   end select
end subroutine


MODULE Snowmeltmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_snowmelt(ps, &
        M, &
        Snowmelt)
        IMPLICIT NONE
        REAL, INTENT(IN) :: ps
        REAL, INTENT(IN) :: M
        REAL, INTENT(OUT) :: Snowmelt
        !- Name: SnowMelt -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: Snow Melt
    !            * Author: STICS
    !            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    !            * Institution: INRA
    !            * Abstract: Snow melt
        !- inputs:
    !            * name: ps
    !                          ** description : density of snow cover
    !                          ** inputtype : variable
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : kg/m**3
    !                          ** uri :
    !            * name: M
    !                          ** description : snow in the process of melting
    !                          ** inputtype : variable
    !                          ** variablecategory : rate
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min :
    !                          ** max :
    !                          ** unit : mmW/d
    !                          ** uri :
        !- outputs:
    !            * name: Snowmelt
    !                          ** description : Snow melt
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0.0
    !                          ** max : 500.0
    !                          ** unit : m
    !                          ** uri :
        Snowmelt = 0.0
        IF(ps .GT. 1e-8) THEN
            Snowmelt = M / ps
        END IF
    END SUBROUTINE model_snowmelt

END MODULE


  function sampleEnergy( gsmObj, centralValue, stdDev ) result(energy)

! ====================================================================
!
! Samples an energy around a central energy value (assumed normal distrbution)
! NOTE: Direct sampling is used!
!
! Formula from slide 93 of LA-UR-16-29043 (see normal dist.)
!
! ====================================================================

    use, intrinsic:: iso_fortran_env, only: real64
    use gsm_params, only: two, twpi

    implicit none
    class(GSM),   intent(in   ) :: gsmObj
    real(real64), intent(in   ) :: centralValue
    real(real64), intent(in   ) :: stdDev
    real(real64) :: energy

! ====================================================================

    real(real64), parameter :: sqrtTwPi = sqrt( twpi )

! ====================================================================

    ! Sample around some width, if desired:
    if( gsmObj%options%smoothTransition ) then
       energy = centralValue + stdDev * &
            & sqrt( -two * log( gsmObj%rang() ) ) * &
            & cos( twpi * gsmObj%rang() )
    else
       energy = centralValue
    end if

    return
! ====================================================================
  end function sampleEnergy


program cold_front
  ! This program calculates the temperature after nhours,
  ! given initial temperatures at two locations, distance
  ! between the two locations, and front speed.
  ! Listing 3.2 in the book.
  implicit none

  real :: temp1 = 12 ! temperature at origin in deg. C
  real :: temp2 = 24 ! temperature at destination in deg. C
  real :: dx = 960 ! distance in km
  real :: c = 20 ! front speed in km per hour
  real :: dt = 24 ! time interval in hours

  real :: res ! result in deg. C

  res = temp2 - c * (temp2 - temp1) / dx * dt

  print *, 'Temparature after ', dt, &
    'hours is ', res, 'degrees.'

end program cold_front


*DECK FMTSET
      SUBROUTINE FMTSET(KOP1,KOP2,KOP3)
C
C     ROUTINE TO PRE-SET CUTOFFS FOR FMTGEN.
C
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/FM/GA(17),RPITWO,FMZERO(17),TOL,CUT0S,CUTSM,CUTML
      COMMON/IO/IN,IOUT,IPUNCH
      COMMON/FMCONS/FOUR,ONE,HALF,TWO,ZERO,TEN,TENM9,F20,F42,F500
      DIMENSION F(15)
C
C     COMPUTE PI RELATED CONSTANTS.
      ZERO = DBLE(0)
      ONE = DBLE(1)
      TWO = ONE + ONE
      FOUR = TWO + TWO
      HALF = ONE / TWO
      TEN = FOUR + FOUR + TWO
      TENM9 = TEN**(-9)
      F20 = TWO * TEN
      F42 = TWO*F20 + TWO
      F500 = (FOUR+ONE)*TEN*TEN
      PI=FOUR*DATAN(ONE)
      GA(1)=DSQRT(PI)
      RPITWO=HALF*GA(1)
C
C     FILL GAMMA FUNCTION ARRAY.
      TOL=HALF
      DO 10 I=2,17
      GA(I)=GA(I-1)*TOL
   10 TOL=TOL+ONE
C
C     FILL FMZERO (FOR ARGUMENT OF ZERO).
      TOL=ONE
      FMZERO(1)=ONE
      DO 20 I=2,17
      TOL=TOL+TWO
   20 FMZERO(I)=ONE/TOL
C
C     OBTAIN CUTOFFS.
C
C        CUT0S = CUTOFF, ZERO TO SMALL.
C        CUTSM = CUTOFF, SMALL TO MEDIUM.
C        CUTML = CUTOFF, MEDIUM TO LARGE.
C
C     CUTOS IS OBTAINED FROM KOP1.
      CUT0S=ZERO
      IF(KOP1.NE.0)CUT0S=TEN**(-2*KOP1)
C
C     CUTSM IS OBTAINED FROM KOP2.
C     KOP2 SPECIFIES THE DESIRED ACCURACY OF THE ASSYMPTOTIC
C     EXPANSION.  ROUTINE FMTGEN IS CALLED TO CHECK THE VIABILITY
C     OF THE ASSYMPTOTIC EXPANSION FOR VARIOUS VALUES OF CUTSM.
      TOL=TENM9
      CUTSM=TEN
      CUTML=F42
      IF(KOP2.EQ.0)GO TO 90
      TOL=TEN**(-6-KOP2)
      T=F20
   60 CALL FMTGEN(F,T,1,ICK)
      IF(ICK)80,70,80
   70 T=T-ONE
      IF(T-TEN)90,60,60
   80 CUTSM=T+ONE
C
C     CUTML IS TAKEN FROM KOP3.
   90 CUTML=F42
      IF(KOP3.NE.0)CUTML=DBLE(KOP3)
      RETURN
      END


*DECK HSTCYL
      SUBROUTINE HSTCYL (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND,
     +   BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HSTCYL
C***PURPOSE  Solve the standard five-point finite difference
C            approximation on a staggered grid to the modified
C            Helmholtz equation in cylindrical coordinates.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HSTCYL-S)
C***KEYWORDS  CYLINDRICAL, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C      HSTCYL solves the standard five-point finite difference
C      approximation on a staggered grid to the modified Helmholtz
C      equation in cylindrical coordinates
C
C          (1/R)(d/dR)(R(dU/dR)) + (d/dZ)(dU/dZ)C
C                      + LAMBDA*(1/R**2)*U = F(R,Z)
C
C      This two-dimensional modified Helmholtz equation results
C      from the Fourier transform of a three-dimensional Poisson
C      equation.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C             * * * * * *   On Input    * * * * * *
C
C    A,B
C      The range of R, i.e. A .LE. R .LE. B.  A must be less than B and
C      A must be non-negative.
C
C    M
C      The number of grid points in the interval (A,B).  The grid points
C      in the R-direction are given by R(I) = A + (I-0.5)DR for
C      I=1,2,...,M where DR =(B-A)/M.  M must be greater than 2.
C
C    MBDCND
C      Indicates the type of boundary conditions at R = A and R = B.
C
C      = 1  If the solution is specified at R = A (see note below) and
C           R = B.
C
C      = 2  If the solution is specified at R = A (see note below) and
C           the derivative of the solution with respect to R is
C           specified at R = B.
C
C      = 3  If the derivative of the solution with respect to R is
C           specified at R = A (see note below) and R = B.
C
C      = 4  If the derivative of the solution with respect to R is
C           specified at R = A (see note below) and the solution is
C           specified at R = B.
C
C      = 5  If the solution is unspecified at R = A = 0 and the solution
C           is specified at R = B.
C
C      = 6  If the solution is unspecified at R = A = 0 and the
C           derivative of the solution with respect to R is specified at
C           R = B.
C
C      NOTE:  If A = 0, do not use MBDCND = 1,2,3, or 4, but instead
C             use MBDCND = 5 or 6.  The resulting approximation gives
C             the only meaningful boundary condition, i.e. dU/dR = 0.
C             (see D. Greenspan, 'Introductory Numerical Analysis Of
C             Elliptic Boundary Value Problems,' Harper and Row, 1965,
C             Chapter 5.)
C
C    BDA
C      A one-dimensional array of length N that specifies the boundary
C      values (if any) of the solution at R = A.  When MBDCND = 1 or 2,
C
C               BDA(J) = U(A,Z(J)) ,          J=1,2,...,N.
C
C      When MBDCND = 3 or 4,
C
C               BDA(J) = (d/dR)U(A,Z(J)) ,    J=1,2,...,N.
C
C      When MBDCND = 5 or 6, BDA is a dummy variable.
C
C    BDB
C      A one-dimensional array of length N that specifies the boundary
C      values of the solution at R = B.  When MBDCND = 1,4, or 5,
C
C               BDB(J) = U(B,Z(J)) ,          J=1,2,...,N.
C
C      When MBDCND = 2,3, or 6,
C
C               BDB(J) = (d/dR)U(B,Z(J)) ,    J=1,2,...,N.
C
C    C,D
C      The range of Z, i.e. C .LE. Z .LE. D.  C must be less
C      than D.
C
C    N
C      The number of unknowns in the interval (C,D).  The unknowns in
C      the Z-direction are given by Z(J) = C + (J-0.5)DZ,
C      J=1,2,...,N, where DZ = (D-C)/N.  N must be greater than 2.
C
C    NBDCND
C      Indicates the type of boundary conditions at Z = C
C      and Z = D.
C
C      = 0  If the solution is periodic in Z, i.e.
C           U(I,J) = U(I,N+J).
C
C      = 1  If the solution is specified at Z = C and Z = D.
C
C      = 2  If the solution is specified at Z = C and the derivative
C           of the solution with respect to Z is specified at
C           Z = D.
C
C      = 3  If the derivative of the solution with respect to Z is
C           specified at Z = C and Z = D.
C
C      = 4  If the derivative of the solution with respect to Z is
C           specified at Z = C and the solution is specified at
C           Z = D.
C
C    BDC
C      A one dimensional array of length M that specifies the boundary
C      values of the solution at Z = C.   When NBDCND = 1 or 2,
C
C               BDC(I) = U(R(I),C) ,              I=1,2,...,M.
C
C      When NBDCND = 3 or 4,
C
C               BDC(I) = (d/dZ)U(R(I),C),         I=1,2,...,M.
C
C      When NBDCND = 0, BDC is a dummy variable.
C
C    BDD
C      A one-dimensional array of length M that specifies the boundary
C      values of the solution at Z = D.  when NBDCND = 1 or 4,
C
C               BDD(I) = U(R(I),D) ,              I=1,2,...,M.
C
C      When NBDCND = 2 or 3,
C
C               BDD(I) = (d/dZ)U(R(I),D) ,        I=1,2,...,M.
C
C      When NBDCND = 0, BDD is a dummy variable.
C
C    ELMBDA
C      The constant LAMBDA in the modified Helmholtz equation.  If
C      LAMBDA is greater than 0, a solution may not exist.  However,
C      HSTCYL will attempt to find a solution.  LAMBDA must be zero
C      when MBDCND = 5 or 6.
C
C    F
C      A two-dimensional array that specifies the values of the right
C      side of the modified Helmholtz equation.  For I=1,2,...,M
C      and J=1,2,...,N
C
C               F(I,J) = F(R(I),Z(J)) .
C
C      F must be dimensioned at least M X N.
C
C    IDIMF
C      The row (or first) dimension of the array F as it appears in the
C      program calling HSTCYL.  This parameter is used to specify the
C      variable dimension of F.  IDIMF must be at least M.
C
C    W
C      A one-dimensional array that must be provided by the user for
C      work space.  W may require up to 13M + 4N + M*INT(log2(N))
C      locations.  The actual number of locations used is computed by
C      HSTCYL and is returned in the location W(1).
C
C
C             * * * * * *   On Output   * * * * * *
C
C    F
C      Contains the solution U(I,J) of the finite difference
C      approximation for the grid point (R(I),Z(J)) for
C      I=1,2,...,M, J=1,2,...,N.
C
C    PERTRB
C      If a combination of periodic, derivative, or unspecified
C      boundary conditions is specified for a Poisson equation
C      (LAMBDA = 0), a solution may not exist.  PERTRB is a con-
C      stant, calculated and subtracted from F, which ensures
C      that a solution exists.  HSTCYL then computes this
C      solution, which is a least squares solution to the
C      original approximation.  This solution plus any constant is also
C      a solution; hence, the solution is not unique.  The value of
C      PERTRB should be small compared to the right side F.
C      Otherwise, a solution is obtained to an essentially different
C      problem.  This comparison should always be made to insure that
C      a meaningful solution has been obtained.
C
C    IERROR
C      An error flag that indicates invalid input parameters.
C      Except for numbers 0 and 11, a solution is not attempted.
C
C      =  0  No error
C
C      =  1  A .LT. 0
C
C      =  2  A .GE. B
C
C      =  3  MBDCND .LT. 1 or MBDCND .GT. 6
C
C      =  4  C .GE. D
C
C      =  5  N .LE. 2
C
C      =  6  NBDCND .LT. 0 or NBDCND .GT. 4
C
C      =  7  A = 0 and MBDCND = 1,2,3, or 4
C
C      =  8  A .GT. 0 and MBDCND .GE. 5
C
C      =  9  M .LE. 2
C
C      = 10  IDIMF .LT. M
C
C      = 11  LAMBDA .GT. 0
C
C      = 12  A=0, MBDCND .GE. 5, ELMBDA .NE. 0
C
C      Since this is the only means of indicating a possibly
C      incorrect call to HSTCYL, the user should test IERROR after
C      the call.
C
C    W
C      W(1) contains the required length of W.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension OF   BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C     Arguments      W(see argument list)
C
C     Latest         June 1, 1977
C     Revision
C
C     Subprograms    HSTCYL,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2,
C     Required       COSGEN,MERGE,TRIX,TRI3,PIMACH
C
C     Special        NONE
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Roland Sweet
C
C     Language       FORTRAN
C
C     History        Written by Roland Sweet at NCAR in March, 1977
C
C     Algorithm      This subroutine defines the finite-difference
C                    equations, incorporates boundary data, adjusts the
C                    right side when the system is singular and calls
C                    either POISTG or GENBUN which solves the linear
C                    system of equations.
C
C     Space          8228(decimal) = 20044(octal) locations on the
C     Required       NCAR Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine HSTCYL is roughly proportional
C                    to M*N*log2(N).  Some typical values are listed in
C                    the table below.
C                       The solution process employed results in a loss
C                    of no more than four significant digits for N and M
C                    as large as 64.  More detailed information about
C                    accuracy can be found in the documentation for
C                    subroutine POISTG which is the routine that
C                    actually solves the finite difference equations.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32       1-6       1-4         56
C                        64       1-6       1-4        230
C
C     Portability    American National Standards Institute Fortran.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Required       COS
C     Resident
C     Routines
C
C     Reference      Schumann, U. and R. Sweet,'A Direct Method For
C                    The Solution of Poisson's Equation With Neumann
C                    Boundary Conditions On A Staggered Grid Of
C                    Arbitrary Size,' J. Comp. Phys. 20(1976),
C                    pp. 171-182.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  U. Schumann and R. Sweet, A direct method for the
C                 solution of Poisson's equation with Neumann boundary
C                 conditions on a staggered grid of arbitrary size,
C                 Journal of Computational Physics 20, (1976),
C                 pp. 171-182.
C***ROUTINES CALLED  GENBUN, POISTG
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HSTCYL
C
C
      DIMENSION       F(IDIMF,*) ,BDA(*)     ,BDB(*)     ,BDC(*)     ,
     1                BDD(*)     ,W(*)
C***FIRST EXECUTABLE STATEMENT  HSTCYL
      IERROR = 0
      IF (A .LT. 0.) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 2) IERROR = 5
      IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.EQ.0. .AND. MBDCND.NE.5 .AND. MBDCND.NE.6) IERROR = 7
      IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8
      IF (IDIMF .LT. M) IERROR = 10
      IF (M .LE. 2) IERROR = 9
      IF (A.EQ.0. .AND. MBDCND.GE.5 .AND. ELMBDA.NE.0.) IERROR = 12
      IF (IERROR .NE. 0) RETURN
      DELTAR = (B-A)/M
      DLRSQ = DELTAR**2
      DELTHT = (D-C)/N
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      IWB = M
      IWC = IWB+M
      IWR = IWC+M
      DO 101 I=1,M
         J = IWR+I
         W(J) = A+(I-0.5)*DELTAR
         W(I) = (A+(I-1)*DELTAR)/(DLRSQ*W(J))
         K = IWC+I
         W(K) = (A+I*DELTAR)/(DLRSQ*W(J))
         K = IWB+I
         W(K) = ELMBDA/W(J)**2-2./DLRSQ
  101 CONTINUE
C
C     ENTER BOUNDARY DATA FOR R-BOUNDARIES.
C
      GO TO (102,102,104,104,106,106),MBDCND
  102 A1 = 2.*W(1)
      W(IWB+1) = W(IWB+1)-W(1)
      DO 103 J=1,N
         F(1,J) = F(1,J)-A1*BDA(J)
  103 CONTINUE
      GO TO 106
  104 A1 = DELTAR*W(1)
      W(IWB+1) = W(IWB+1)+W(1)
      DO 105 J=1,N
         F(1,J) = F(1,J)+A1*BDA(J)
  105 CONTINUE
  106 CONTINUE
      GO TO (107,109,109,107,107,109),MBDCND
  107 W(IWC) = W(IWC)-W(IWR)
      A1 = 2.*W(IWR)
      DO 108 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  108 CONTINUE
      GO TO 111
  109 W(IWC) = W(IWC)+W(IWR)
      A1 = DELTAR*W(IWR)
      DO 110 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  110 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
  111 A1 = 2./DLTHSQ
      GO TO (121,112,112,114,114),NP
  112 DO 113 I=1,M
         F(I,1) = F(I,1)-A1*BDC(I)
  113 CONTINUE
      GO TO 116
  114 A1 = 1./DELTHT
      DO 115 I=1,M
         F(I,1) = F(I,1)+A1*BDC(I)
  115 CONTINUE
  116 A1 = 2./DLTHSQ
      GO TO (121,117,119,119,117),NP
  117 DO 118 I=1,M
         F(I,N) = F(I,N)-A1*BDD(I)
  118 CONTINUE
      GO TO 121
  119 A1 = 1./DELTHT
      DO 120 I=1,M
         F(I,N) = F(I,N)-A1*BDD(I)
  120 CONTINUE
  121 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 130,123,122
  122 IERROR = 11
      GO TO 130
  123 GO TO (130,130,124,130,130,124),MBDCND
  124 GO TO (125,130,130,125,130),NP
  125 CONTINUE
      DO 127 I=1,M
         A1 = 0.
         DO 126 J=1,N
            A1 = A1+F(I,J)
  126    CONTINUE
         J = IWR+I
         PERTRB = PERTRB+A1*W(J)
  127 CONTINUE
      PERTRB = PERTRB/(M*N*0.5*(A+B))
      DO 129 I=1,M
         DO 128 J=1,N
            F(I,J) = F(I,J)-PERTRB
  128    CONTINUE
  129 CONTINUE
  130 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY  DELTHT**2
C
      DO 132 I=1,M
         W(I) = W(I)*DLTHSQ
         J = IWC+I
         W(J) = W(J)*DLTHSQ
         J = IWB+I
         W(J) = W(J)*DLTHSQ
         DO 131 J=1,N
            F(I,J) = F(I,J)*DLTHSQ
  131    CONTINUE
  132 CONTINUE
      LP = NBDCND
      W(1) = 0.
      W(IWR) = 0.
C
C     CALL GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      IF (NBDCND .EQ. 0) GO TO 133
      CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
      GO TO 134
  133 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
  134 CONTINUE
      W(1) = W(IWR+1)+3*M
      RETURN
      END


      SUBROUTINE QGAUS(FUNC,A,B,SS)
      DIMENSION X(5),W(5)
      DATA X/.1488743389,.4333953941,.6794095682,.8650633666,.9739065285
     */
      DATA W/.2955242247,.2692667193,.2190863625,.1494513491,.0666713443
     */
      XM=0.5*(B+A)
      XR=0.5*(B-A)
      SS=0
      DO 11 J=1,5
        DX=XR*X(J)
        SS=SS+W(J)*(FUNC(XM+DX)+FUNC(XM-DX))
11    CONTINUE
      SS=XR*SS
      RETURN
      END


!    file:    euler003.f90
!    author:  Marvin Smith
!    date:    4/25/2015
!
!    Purpose:  Solves Project Euler 003 using Fortran 90
!

PROGRAM Euler003
    USE PrimeNumberModule
    IMPLICIT none
    INTEGER :: max_prime_factor, i
    LOGICAL, ALLOCATABLE, DIMENSION(:) :: prime_list

!  Set original
!max_prime_factor = 600851475143/2
max_prime_factor = 60

!  Allocate Memory
ALLOCATE( prime_list(2:max_prime_factor ))

!  Generate Prime Factors
prime_list = Prime_Sieve( max_prime_factor )

!  Start Iterating Over Prime Factors of the output

!  Exit Program
end


C
C**************************  NUDWZ  ************************************
C
C  calculate vertical weighting function W(z) for nudging
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION NUDWZ(WFLAG,ZZ,ZZO,RZ)
C
      IMPLICIT NONE
      INTEGER  WFLAG
      REAL*8   ZD
      REAL*8   ZZ,ZZO,RZ
C
      ZD=DABS(ZZ-ZZO)
      IF (WFLAG .EQ. 0) THEN
         IF (ZD .LE. RZ) THEN
            NUDWZ=1.0D0 - ZD/RZ
         ELSE
            NUDWZ=0.0D0
         END IF
      ELSE
         NUDWZ=DEXP(-1.0d0*(ZD/RZ)**2.0d0)
      END IF
C
      RETURN
      END


PROGRAM SUSHEEL
    REAL :: PIE = 0, START = 1

    DO I = 1, 2500
        PIE = START*1/(2*I - 1) + PIE
        START = -1*START
    END DO

    PRINT *, 4*PIE

END PROGRAM SUSHEEL


      SUBROUTINE TAVISPAK99(A,B,C,SOLN,KVISFLAG,LUERR,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE SOLVES FOR THE ZEROS OF THE FUNCTION
C        FCN = A*COS(EA) + B*SIN(EA) - C
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C A         1   R*8  I  THE 'A' COEFFICIENT IN THE EXPRESSION
C
C B         1   R*8  I  THE 'B' COEFFICIENT IN THE EXPRESSION
C
C C         1   R*8  I  THE 'C' COEFFICIENT IN THE EXPRESSION
C
C SOLN      2   R*8  O  TWO ECCENTRIC ANOMALY VALUES AT WHICH THE
C                       CURVE IS ZERO. THE CURVE IS INCREASING AT
C                       SOLN(1) AND DECREASING AT SOLN(2).
C
C                       IF THE CURVE HAS NO ZEROS, THE ECCENTRIC ANOMALY
C                       YIELDING THE VALUE NEAREST ZERO IS RETURNED IN
C                       SOLN(1) AND SOLN(2).
C
C KVISFLAG  1   I*4  O  FLAG INDICATING THE ZERO'S STATUS OF THE CURVE.
C                       = -1, CURVE IS ALWAYS NEGATIVE.
C                       =  0, CURVE HAS POSITIVE AND NEGATIVE SEGMENTS.
C                       =  1, CURVE IS ALWAYS POSITIVE.
C
C IERR      1   I*4  O  = 0, NO ERRORS.
C                       = OTHERWISE, NUMERICAL ERROR. NO SOLN RETURNED.
C
C***********************************************************************
C
C CODED BY C PETRUZZO GSFC/742 10/85.
C    MODIFIED....
C
C***********************************************************************
C
      REAL*8 SOLN(2)
      REAL*8 A13/-1.D0/, A23/-1.D0/, A33/-1.D0/
      REAL*8 HALFPI / 1.570796326794897D0 /
      REAL*8 PI     / 3.141592653589793D0 /
      REAL*8 TWOPI  / 6.283185307179586D0 /
      REAL*8 DEGRAD / 57.29577951308232D0 /
      REAL*8 TOLER/1.D-5/
C
      DET(A11,A21,A31,A12,A22,A32) =
     *   A11*A22*A33 + A12*A23*A31 + A13*A21*A32
     *  -A31*A22*A13 - A21*A12*A33 - A11*A32*A23
C
      IBUG = 0
      LUBUG = 19
C
      IF(IBUG.NE.0) WRITE(LUBUG,8501) A,B,C
 8501 FORMAT(' TAVISPAK99 DEBUG. INPUT. A,B,C=',3G15.7)
C
C THE FUNCTION DEFINES WHEN A TARGET SATISFIES THE AVAILABILITY
C REQUIREMENT.  WHEN THE FUNCTION IS POSITIVE, IT IS AVAILABLE.  WHEN
C NEGATIVE, IT IS NOT AVAILABLE.  THREE SITUATIONS ARE POSSIBLE:
C
C    1. THE FUNCTION IS ALWAYS POSITIVE. HENCE, TARGET IS ALWAYS
C       AVAILABLE.
C    2. THE FUNCTION IS SOMETIMES POSITIVE AND SOMETIMES NEGATIVE.
C       TRANSITION BETWEEN AVAILABILITY AND NON-AVAILABILITY OCCURS
C       WHEN THE FUNCTION CHANGES SIGN. IE, AT THE FCN'S ZEROS.
C    3. THE FUNCTION IS ALWAYS POSITIVE. HENCE, TARGET IS NEVER
C       AVAILABLE.
C
C
C INITIALIZE
C
      IERR = 0
C
C DETERMINE THE MAX AND MIN VALUES OF THE FCN TO SEE IF ZEROS EXIST.
C TO DO THIS, WE DIFFERENTIATE  FCN = A*COS(EA) + B*SIN(EA) - C,  SET
C THE DERIVATIVE TO ZERO, THEN FIND EA'S WHERE MAX AND MIN VALUES OCCUR.
C IE, FIND EA'S WHERE  -A * SIN(EA) + B * COS(EA) = 0.   SOLUTIONS ARE
C EA=DATAN(B/A) AND EA=PI+DATAN(B/A).
C
C    FIND THE EA'S(EA1 AND EA2) WHERE THE MIN AND MAX VALUES OF OCCUR.
      IF(DABS(A).GT.TOLER) THEN
        EA1 = DATAN( B/A )
      ELSE   ! B * COS(EA) = 0, SO WANT EA'S FOR COS(EA)=0.D0
        EA1 = HALFPI
        END IF
      SINEA1 = DSIN(EA1)
      COSEA1 = DCOS(EA1)
      VAL1 = A*COSEA1 + B*SINEA1 - C
      EA2 = EA1 + PI
      SINEA2 = -SINEA1
      COSEA2 = -COSEA1
      VAL2 = A*COSEA2 + B*SINEA2 - C
      IF(VAL1.LE.VAL2) THEN
        EAMIN = EA1
        EAMAX = EA2
      ELSE
        EAMIN = EA2
        EAMAX = EA1
        END IF
      VMIN = DMIN1(VAL1,VAL2)
      VMAX = DMAX1(VAL1,VAL2)
C
C    DETERMINE WHETHER THE CURVE IS ALWAYS NEGATIVE, ALWAYS POSITIVE, OR
C    A MIX.
      IF(VMIN.LT.-TOLER .AND. VMAX.GT.+TOLER) THEN
        KVISFLAG = 0   ! A MIX OF POSITIVE AND NEGATIVE
      ELSE
C      RETURN THE EA WHERE THE FUNCTION IS NEAREST TO THE FCN=0 AXIS.
        CONTINUE
        IF(VMIN.GE.-TOLER) THEN
          KVISFLAG = 1     ! ALWAYS POSITIVE
          SOLN(1) = EAMIN
          SOLN(2) = EAMIN
        ELSE
          KVISFLAG = -1    ! ALWAYS NEGATIVE
          SOLN(1) = EAMAX
          SOLN(2) = EAMAX
          END IF
        END IF
      IF(IBUG.NE.0) WRITE(LUBUG,5644) KVISFLAG,
     *     EA1*DEGRAD,VAL1,EA2*DEGRAD,VAL2
 5644 FORMAT(' TAVISPAK99 DEBUG 5644.  MIN/MAX INFO. KVISFLAG=',I3/,
     *       '   EA1,VAL1=',2G13.5,'   EA2,VAL2=',2G13.5)
C
C
      IF(KVISFLAG.EQ.0) THEN
C      CURVE CROSSES FCN=0 AXIS.  SOLVE FOR THE ECCENTRIC ANOMALIES
C      MAKING THE FUNCTION ZERO.
        ASINARG = C / DSQRT(A*A+B*B)
        IF(DABS(ASINARG).GT.1.D0) THEN
          IF(IBUG.NE.0) WRITE(LUBUG,8609) ASINARG*DEGRAD
 8609     FORMAT(' TAVISPAK99. BAD ASINARG. VALUE=',G23.16)
          IERR = 3
          GO TO 9999
          END IF
        IF(DABS(B).GT.TOLER) THEN
          TERM1 = DASIN( ASINARG )
          TERM2 = DATAN(-A/DABS(B))
          TEMP = DSIGN(1.D0,B)
          SOLN1 =      TEMP*(TERM1+TERM2)
          SOLN2 = PI - TEMP*(TERM1-TERM2)
          IF(IBUG.NE.0) WRITE(LUBUG,8787) TERM1*DEGRAD,TERM2*DEGRAD
 8787     FORMAT(' TAVISPAK99 DEBUG. B N/E 0. TERM1,TERM2(DEG)=',2G16.8)
        ELSE
          TEMP = C/A
          IF(DABS(TEMP).GT.1.D0) TEMP = DSIGN(1.D0,TEMP)
          SOLN1 = DACOS(C/A)
          SOLN2 = -SOLN1
          END IF
C      SET SOLN(1) TO THE ZERO FOR WHICH THE FUNCTION IS INCREASING AND
C      SOLN(2) TO THE ZERO FOR WHICH IT IS DECREASING.
        SLOPE1 = -A*DSIN(SOLN1) + B*DCOS(SOLN1)
        IF(IBUG.NE.0) THEN
          SLOPE2 = -A*DSIN(SOLN2) + B*DCOS(SOLN2)
          WRITE(LUBUG,8617) SOLN1*DEGRAD,SLOPE1,SOLN2*DEGRAD,SLOPE2
 8617     FORMAT(' TAVISPAK99. SOLN1,SLOPE1=',2G16.8/,
     *           '             SOLN2,SLOPE2=',2G16.8)
          END IF
        IF(SLOPE1.GT.0.D0) THEN
          SOLN(1) = SOLN1
          SOLN(2) = SOLN2
        ELSE
          SOLN(1) = SOLN2
          SOLN(2) = SOLN1
          END IF
        END IF
C
      IF(IBUG.NE.0) WRITE(LUBUG,8606) KVISFLAG,
     *      SOLN(1)*DEGRAD,SOLN(2)*DEGRAD
 8606 FORMAT(' TAVISPAK99 RETURNING.  KVISFLAG=',I3,
     *             '  SOLN=',2G25.16/)
C
 9999 CONTINUE
      RETURN
      END