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(umin,umax) result(i)
    implicit none
    integer :: i
    integer, intent(in), optional :: umin, umax
    integer, parameter :: max_allowed = 999
    integer :: ierr, iend
    logical :: ex, op

    if (present(umin)) then
      i = max(0,umin)    ! start searching from unit min
    else
      i = 0
    end if
    if (present(umax)) then
      iend = min(max(0,umax),max_allowed)
    else
      iend = max_allowed
    end if
    do
      if (i>iend) then
        i=-1  ! no free units found
        exit
      end if
      inquire(unit=i,exist=ex,opened=op,iostat=ierr)
      if (ierr==0.and.ex.and..not.op) exit  ! unit i exists and is not open
      i = i + 1
    end do
  end function get_free_unit

end module utils