382 lines
9.0 KiB
Fortran
382 lines
9.0 KiB
Fortran
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)
|
|
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)
|
|
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)
|
|
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(array, value, locs, n, nlocs)
|
|
! Given an `array` of size `n` and a `value`, finds at most
|
|
! `n` locations `locs` such that `value` is between
|
|
! `array(locs(i))` and `array(locs(i+i))`, in whichever order.
|
|
|
|
! subroutine arguments
|
|
real(wp_), intent(in) :: array(:)
|
|
real(wp_), intent(in) :: value
|
|
integer, intent(inout) :: locs(n)
|
|
integer, intent(in) :: n
|
|
integer, intent(out) :: nlocs
|
|
|
|
! local variables
|
|
integer :: i
|
|
logical :: larger_than_last
|
|
|
|
nlocs = 0
|
|
if (size(array) < 2) return
|
|
|
|
larger_than_last = value > array(1)
|
|
do i = 2, size(array)
|
|
! Note: the condition is equivalent to
|
|
! (array(i-1) < value < array(i))
|
|
! .or. (array(i) < value < array(i-1))
|
|
if (array(i) < value .neqv. larger_than_last) then
|
|
larger_than_last = value > array(i)
|
|
nlocs = nlocs + 1
|
|
if (nlocs <= n) locs(nlocs) = i - 1
|
|
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
|
|
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)
|
|
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)
|
|
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)
|
|
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)
|
|
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)
|
|
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
|
|
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
|
|
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
|
|
|
|
|
|
subroutine range2rect(xmin, xmax, ymin, ymax, x, y)
|
|
! Given two ranges [xmin, xmax], [ymin, ymax] builds
|
|
! the x and y vertices of the following rectangle:
|
|
!
|
|
! (xmin, ymax)╔═════╗(xmax, ymax)
|
|
! ║4 3║
|
|
! ║ ║
|
|
! ║1 2║
|
|
! (xmin, ymin)╚═════╝(xmin, ymax)
|
|
!
|
|
|
|
! subroutine arguments
|
|
real(wp_), intent(in) :: xmin, xmax, ymin, ymax
|
|
real(wp_), intent(out), dimension(5) :: x, y
|
|
|
|
x = [xmin, xmax, xmax, xmin, xmin]
|
|
y = [ymin, ymin, ymax, ymax, ymin]
|
|
end subroutine range2rect
|
|
|
|
|
|
function inside(vertx, verty, x0, y0)
|
|
! Tests whether the point (`x0`, `y0`) lies inside the
|
|
! simple polygon of vertices `vertx`, `verty`.
|
|
|
|
|
|
! subroutine arguments
|
|
real(wp_), dimension(:), intent(in) :: vertx, verty
|
|
real(wp_), intent(in) :: x0, y0
|
|
logical :: inside
|
|
|
|
! local variables
|
|
integer :: seg(size(vertx))
|
|
real(wp_) :: x, vertx_(size(vertx)+1), verty_(size(vertx)+1)
|
|
integer :: i, nsegs, n
|
|
|
|
! Ensure the first and last point are the same
|
|
n = size(vertx)
|
|
vertx_(1:n) = vertx(1:n)
|
|
verty_(1:n) = verty(1:n)
|
|
vertx_(n+1) = vertx(1)
|
|
verty_(n+1) = verty(1)
|
|
|
|
inside = .false.
|
|
|
|
! Find the `nsegs` segments that intersect the horizontal
|
|
! line y=y0, i.e. `verty(seg(i)) < y < verty(seg(i)+1)`
|
|
call locate_unord(verty_, y0, seg, n, nsegs)
|
|
|
|
! No intersections, it must be outside (above or below)
|
|
if (nsegs == 0) return
|
|
|
|
! Count the number of intersections that lie to the left
|
|
! (equivalently, to the right) of the point. An even number
|
|
! means that the point is outside the polygon.
|
|
do i = 1, nsegs
|
|
! coordinate of the intersection between segment and y=y0
|
|
x = intlinf(verty_(seg(i)), vertx_(seg(i)), &
|
|
verty_(seg(i)+1), vertx_(seg(i)+1), y0)
|
|
if (x < x0) inside = .not. inside
|
|
end do
|
|
end function inside
|
|
|
|
|
|
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.
|
|
|
|
! 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
|