SELF_SupportRoutines.f90 Source File

! //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// !
!
! Maintainers : support@fluidnumerics.com
! Official Repository : https://github.com/FluidNumerics/self/
!
! Copyright © 2024 Fluid Numerics LLC
!
! Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in
!    the documentation and/or other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
! HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
! THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// !

!> \file SELF_SupportRoutines.f90
!! Contains the \ref SELF_SupportRoutines module

!> \defgroup SELF_SupportRoutines SELF_SupportRoutines
!! This module defines a set of general purpose routines.

module SELF_SupportRoutines

  use iso_fortran_env
  use SELF_Constants

  implicit none

  interface AlmostEqual
    module procedure AlmostEqual_r64
  endinterface AlmostEqual

  real(prec),private,parameter :: tolerance = 10.0**(-10)

contains

!> \addtogroup SELF_SupportRoutines
!! @{
! ================================================================================================ !
! Function AlmostEqual
!
!> \fn AlmostEqual
!! Compares two floating point numbers and determines if they are equal (to machine precision).
!!
!!   This function is from Alg. 139 on pg. 359 of D.A. Kopriva, 2009, "Implementing Spectral Element
!!    Methods for Scientists and Engineers"
!!
!! <H2> Usage : </H2>
!! <B>Logical</B> :: AisB <BR>
!! <B>REAL</B>(prec) :: a, b <BR>
!!         .... <BR>
!!     AisB = AlmostEqual( a, b ) <BR>
!!
!!  <H2> Parameters : </H2>
!!  <table>
!!   <tr> <td> in <th> a <td> REAL(prec) <td> scalar
!!   <tr> <td> in <th> b <td> REAL(prec) <td> scalar
!!   <tr> <td> in <th> AisB <td> Logical <td>
!!                     <B>.TRUE.</B> IF a=b to machine precision <BR>
!!                     <B>.FALSE.</B> otherwise
!!  </table>
!!
! ================================================================================================ !
!>@}

  function AlmostEqual_r64(a,b) result(AisB)

    implicit none
    real(real64) :: a,b
    logical :: AisB

    if(a == 0.0_real64 .or. b == 0.0_real64) then
      if(abs(a-b) <= epsilon(1.0_real64)) then
        AisB = .true.
      else
        AisB = .false.
      endif
    else
      if((abs(a-b) <= epsilon(1.0_real64)*abs(a)) .or. (abs(a-b) <= epsilon(1.0_real64)*abs(b))) then
        AisB = .true.
      else
        AisB = .false.
      endif
    endif

  endfunction AlmostEqual_r64

!> \addtogroup SELF_SupportRoutines
!! @{
! ================================================================================================ !
! S/R ForwardShift
!
!> \fn ForwardShift
!! Shift an array integers by one index forward, moving the last index to the first.
!!
!! Shifts the array entries as follows : <BR>
!!  myArray(1) <-- myArray(N) <BR>
!!  myArray(2) <-- myArray(1) <BR>
!!  myArray(3) <-- myArray(2) <BR>
!!
!! <H2> Usage : </H2>
!! <B>INTEGER</B> :: N
!! <B>INTEGER</B> :: myArray(1:N) <BR>
!!         .... <BR>
!!     <B>CALL</B> ForwardShift( myArray, N ) <BR>
!!
!!  <H2> Parameters : </H2>
!!  <table>
!!   <tr> <td> in/out <th> myArray(1:N) <td> INTEGER <td>
!!                         On <B>output</B>, the input array with elements shifted forward by
!!                         one index.
!!   <tr> <td> in <th> N <td> INTEGER <td>
!!                     The number of elements in the array
!!  </table>
!!
! ================================================================================================ !
!>@}
  subroutine ForwardShift(myArray,N)

    implicit none
    integer,intent(in)    :: N
    integer,intent(inout) :: myArray(1:N)
    ! LOCAL
    integer :: temp(1:N)

    temp = myArray
    myArray(1) = temp(N)
    myArray(2:N) = temp(1:N-1)

  endsubroutine ForwardShift
!
!> \addtogroup SELF_SupportRoutines
!! @{
! ================================================================================================ !
! S/R CompareArray
!
!> \fn CompareArray
!! Compares to INTEGER arrays and determines if they are identical.
!!
!! A logical is returned that specifies whether or not two arrays are identical. To determine
!! if the two arrays are identical, the sum of the difference between each element in the input
!! array is calculated. If the arrays are identical, each contribution to the sum is zero and hence
!! the sum is zero. If the sum is non-zero, the arrays are distinct.
!!
!! This routine is used in the \ref HexMeshClass module. A face of an element in an unstructured
!! mesh is identified by its four corner nodes. When identifying unique faces in an unstructured
!! mesh, we need to determine if two elements share a face. This can be accomplished by comparing
!! the four corner nodes (from each element) that define each face.
!!
!! <H2> Usage : </H2>
!! <B>INTEGER</B> :: N <BR>
!! <B>INTEGER</B> :: arrayOne(1:N) <BR>
!! <B>INTEGER</B> :: arrayTwo(1:N) <BR>
!! <B>LOGICAL</B> :: arraysMatch <BR>
!!         .... <BR>
!!     arraysMatch = CompareArray( arrayOne, arrayTwo, N ) <BR>
!!  <H2> Parameters : </H2>
!!  <table>
!!   <tr> <td> in <th> arrayOne(1:N) <td> INTEGER <td>
!!   <tr> <td> in <th> arrayTwo(1:N) <td> INTEGER <td>
!!   <tr> <td> in <th> N <td> INTEGER <td>
!!   <tr> <td> out <th> arraysMatch <td> INTEGER <td>
!!
!!  </table>
!!
! ================================================================================================ !
!>@}

  function CompareArray(arrayOne,arrayTwo,N) result(arraysMatch)

    implicit none
    integer :: N
    integer :: arrayOne(1:N),arrayTwo(1:N)
    logical :: arraysMatch
    ! LOCAL
    integer :: i,theSumOfDiffs

    theSumOfDiffs = 0

    do i = 1,N
      theSumOfDiffs = theSumOfDiffs+abs(arrayOne(i)-arrayTwo(i))
    enddo

    if(theSumOfDiffs == 0) then
      arraysMatch = .true.
    else
      arraysMatch = .false.
    endif

  endfunction CompareArray
!
!> \addtogroup SELF_SupportRoutines
!! @{
! ================================================================================================ !
! S/R UniformPoints
!
!> \fn UniformPoints
!! Generates a REAL(prec) array of N points evenly spaced between two points.
!!
!!
!! <H2> Usage : </H2>
!! <B>REAL</B>(prec) :: a <BR>
!! <B>REAL</B>(prec) :: b <BR>
!! <B>REAL</B>(prec) :: xU(0:N) <BR>
!! <B>INTEGER</B> :: N <BR>
!!         .... <BR>
!!     xU = UniformPoints( a, b, N ) <BR>
!!
!!  <H2> Parameters : </H2>
!!  <table>
!!   <tr> <td> in <th> a <td> REAL(prec) <td> Starting point of the interval
!!   <tr> <td> in <th> b <td> REAL(prec) <td> Ending point of the interval
!!   <tr> <td> in <th> N <td> INTEGER <td> The number of points in the interval \f$[a,b]\f$
!!   <tr> <td> in <th> xU(0:N) <td> REAL(prec) <td>
!!                     Array of evenly spaced points in the interval \f$[a,b]\f$
!!  </table>
!!
! ================================================================================================ !
!>@}

  function UniformPoints(a,b,firstInd,lastInd) result(xU)

    implicit none
    real(prec) :: a,b
    integer    :: firstInd,lastInd
    real(prec) :: xU(firstInd:lastInd)
    ! LOCAL
    real(prec)    :: dx
    integer :: i

    dx = (b-a)/real((lastInd-firstInd),prec)

    do i = firstInd,lastInd

      xU(i) = a+dx*real(i-firstInd,prec)

    enddo

  endfunction UniformPoints

  integer function newunit(unit)
    !  https://fortranwiki.org/fortran/show/newunit
    integer,intent(out),optional :: unit
! local
    integer,parameter :: LUN_MIN = 10,LUN_MAX = 1000
    logical :: opened
    integer :: lun
! begin
    newunit = -1
    do lun = LUN_MIN,LUN_MAX
      inquire(unit=lun,opened=opened)
      if(.not. opened) then
        newunit = lun
        exit
      endif
    enddo
    if(present(unit)) unit = newunit
  endfunction newunit

  function UpperCase(str) result(upper)

    implicit none
    character(*),intent(In) :: str
    character(len(str))      :: Upper

    integer :: ic,i

    character(27),parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ '
    character(27),parameter :: low = 'abcdefghijklmnopqrstuvwxyz '

    do i = 1,len(str)
      ic = index(low,str(i:i))
      if(ic > 0) then
        Upper(i:i) = cap(ic:ic)
      else
        Upper(i:i) = str(i:i)
      endif
    enddo

  endfunction UpperCase

endmodule SELF_SupportRoutines