gray/src/utils.f90

module utils

  use const_and_precisions, only : wp_
  implicit none

contains

  function locatef(a,n,x) result(j)
! Given an array a(n), and a value x, with a(n) monotonic, either
! increasing or decreasing, returns a value j such that
! a(j) < x <= a(j+1) for a increasing, and such that
! a(j+1) < x <= a(j) for a decreasing.
! j=0 or j=n  indicate that x is out of range  (Numerical Recipes)
    implicit none
    integer, intent(in) :: n
    real(wp_), dimension(n), intent(in) :: a
    real(wp_), intent(in) :: x
    integer :: j
    integer :: jl,ju,jm
    logical :: incr
    jl=0
    ju=n+1
    incr=a(n)>a(1)
    do while ((ju-jl)>1)
      jm=(ju+jl)/2
      if(incr.eqv.(x>a(jm))) then
        jl=jm
      else
        ju=jm
      endif
    end do
    j=jl
  end function locatef

  subroutine locate(xx,n,x,j)
    implicit none
    integer, intent(in) :: n
    real(wp_), intent(in) :: xx(n), x
    integer, intent(out) :: j
    integer :: jl,ju,jm
    logical :: incr
!
! Given an array xx(n), and a value x
! returns a value j such that xx(j) < x < xx(j+1)
! xx(n) must be monotonic, either increasing or decreasing.
! j=0 or j=n  indicate that x is out of range  (Numerical Recipes)
!
    jl=0
    ju=n+1
    incr=xx(n)>xx(1)
    do while ((ju-jl)>1)
      jm=(ju+jl)/2
      if(incr .eqv. (x>xx(jm))) then
        jl=jm
      else
        ju=jm
      endif
    end do
    j=jl
  end subroutine locate

  subroutine locatex(xx,n,n1,n2,x,j)
    implicit none
    integer, intent(in) :: n,n1,n2
    real(wp_), intent(in) :: xx(n), x
    integer, intent(out) :: j
    integer :: jl,ju,jm
!
! Given an array xx(n), and a value x
! returns a value j such that xx(j) < x < xx(j+1)
! xx(n) must be monotonic, either increasing or decreasing.
! j=n1-1or j=n2+1 indicate that x is out of range
! modified from subr. locate (Numerical Recipes)
!
    jl=n1-1
    ju=n2+1
    do while ((ju-jl)>1)
      jm=(ju+jl)/2
      if((xx(n2)>xx(n1)) .eqv. (x>xx(jm))) then
        jl=jm
      else
        ju=jm
      endif
    end do
    j=jl
  end subroutine locatex

  subroutine locate_unord(a,n,x,j,m,nj)
    implicit none
    integer, intent(in) :: n,m
    integer, intent(out) :: nj
    real(wp_), dimension(n), intent(in) :: a
    real(wp_), intent(in) :: x
    integer, dimension(m), intent(inout) :: j
    integer :: i
    nj=0
    do i=1,n-1
      if (x>a(i).neqv.x>a(i+1)) then
        nj=nj+1
        if (nj<=m) j(nj)=i
      end if
    end do
  end subroutine locate_unord

  function intlinf(x1,y1,x2,y2,x) result(y)
    !linear interpolation
    !must be x1 != x2
    use const_and_precisions, only : one
    implicit none
    real(wp_),intent(in) :: x1,y1,x2,y2,x
    real(wp_) :: y
    real(wp_) :: a
    a=(x2-x)/(x2-x1)
    y=a*y1+(one-a)*y2
  end function intlinf

  subroutine intlin(x1,y1,x2,y2,x,y)
    implicit none
    real(wp_), intent(in) :: x1,y1,x2,y2,x
    real(wp_), intent(out) :: y
    real(wp_) :: dx,aa,bb
!
! linear interpolation
! (x1,y1) < (x,y) < (x2,y2)
!
    dx=x2-x1
    aa=(x2-x)/dx
    bb=1.0_wp_-aa
    y=aa*y1+bb*y2
  end subroutine intlin

  subroutine vmax(x,n,xmax,imx)
    implicit none
    integer, intent(in) :: n
    real(wp_), intent(in) :: x(n)
    real(wp_), intent(out) :: xmax
    integer, intent(out) :: imx
    integer :: i

    if (n<1) then
      imx=0
      return
    end if
    imx=1
    xmax=x(1)
    do i=2,n
      if(x(i)>xmax) then
        xmax=x(i)
        imx=i
      end if
    end do
  end subroutine vmax

  subroutine vmin(x,n,xmin,imn)
    implicit none
    integer, intent(in) :: n
    real(wp_), intent(in) :: x(n)
    real(wp_), intent(out) :: xmin
    integer, intent(out) :: imn
    integer :: i

    if (n<1) then
      imn=0
      return
    end if
    imn=1
    xmin=x(1)
    do i=2,n
      if(x(i)<xmin) then
        xmin=x(i)
        imn=i
      end if
    end do
  end subroutine vmin

  subroutine vmaxmini(x,n,xmin,xmax,imn,imx)
    implicit none
    integer, intent(in) :: n
    real(wp_), intent(in) :: x(n)
    real(wp_), intent(out) :: xmin, xmax
    integer, intent(out) :: imn, imx
    integer :: i
    if (n<1) then
      imn=0
      imx=0
      return
    end if
    imn=1
    imx=1
    xmin=x(1)
    xmax=x(1)
    do i=2,n
      if(x(i)<xmin) then
        xmin=x(i)
        imn=i
      else if(x(i)>xmax) then
        xmax=x(i)
        imx=i
      end if
    end do
  end subroutine vmaxmini

  subroutine vmaxmin(x,n,xmin,xmax)
    implicit none
    integer, intent(in) :: n
    real(wp_), intent(in) :: x(n)
    real(wp_), intent(out) :: xmin, xmax
    integer :: i

    if (n<1) then
      return
    end if
    xmin=x(1)
    xmax=x(1)
    do i=2,n
      if(x(i)<xmin) then
        xmin=x(i)
      else if(x(i)>xmax) then
        xmax=x(i)
      end if
    end do
  end subroutine vmaxmin

  subroutine order(p,q)
! returns p,q in ascending order
    implicit none
    real(wp_), intent(inout) :: p,q
    real(wp_) :: temp
    if (p>q) then
      temp=p
      p=q
      q=temp
    end if
  end subroutine order

  subroutine bubble(a,n)
! bubble sorting of array a
    implicit none
    integer, intent(in) :: n
    real(wp_), dimension(n), intent(inout) :: a
    integer :: i, j
    do i=1,n
      do j=n,i+1,-1
        call order(a(j-1), a(j))
      end do
    end do
  end subroutine bubble


  function get_free_unit(unit) result(i)
    ! Returns `unit` back or the first free unit
    ! number `i` if `unit` is absent.
    ! When no unit is available, returns -1.

    implicit none

    ! function arguments
    integer :: i
    integer, intent(in), optional :: unit

    ! local variables
    integer, parameter :: max_allowed = 999
    integer :: error
    logical :: ex, op

    if (present(unit)) then
      i = unit
      return
    end if

    do i=0,max_allowed
      inquire(unit=i, exist=ex, opened=op, iostat=error)
      ! if unit i exists and is free
      if (error == 0 .and. ex .and. .not. op) return
    end do
    i = -1

  end function get_free_unit


  function dirname(filepath) result(directory)
    ! Get the parent `directory` of `filepath`

    ! function arguments
    character(*), intent(in)  :: filepath
    character(:), allocatable :: directory

    ! local variables
    character(255) :: cwd
    integer :: last_sep

    last_sep = scan(filepath, '/', back=.true.)
    directory = filepath(1:last_sep)

    ! append the cwd to relative paths
    if (isrelative(filepath)) then
      call getcwd(cwd)
      directory = trim(cwd) // '/' // directory
    end if
  end function dirname

  function isrelative(filepath)
    ! Check if `filepath` is a relative or an absolute path

    ! function arguments
    character(*), intent(in)  :: filepath
    logical :: isrelative

    isrelative = (filepath(1:1) /= '/')
  end function isrelative

end module utils