amun-code/sources/helpers.F90

!!******************************************************************************
!!
!!  This file is part of the AMUN source code, a program to perform
!!  Newtonian or relativistic magnetohydrodynamical simulations on uniform or
!!  adaptive mesh.
!!
!!  Copyright (C) 2019-2024 Grzegorz Kowal <grzegorz@amuncode.org>
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License as published by
!!  the Free Software Foundation, either version 3 of the License, or
!!  (at your option) any later version.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!!
!!******************************************************************************
!!
!! module: HELPERS
!!
!!  This module provides miscellaneous support subroutines.
!!
!!
!!******************************************************************************
!
module helpers

  implicit none

! MODULE INTERFACES:
! =================
!
  interface print_parameter
    module procedure print_parameter_logical
    module procedure print_parameter_integer
    module procedure print_parameter_double
    module procedure print_parameter_string
    module procedure print_parameter_integer_range
    module procedure print_parameter_double_range
    module procedure print_parameter_string_range
  end interface
  interface print_message
    module procedure print_message_loc
    module procedure print_message_msg
  end interface

  logical :: noflush = .true.

  private

  public :: print_welcome, print_section, print_parameter, print_message
  public :: uppercase, lowercase
  public :: enable_flush_and_sync, disable_flush_and_sync, flush_and_sync

!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
  contains
!
!===============================================================================
!!
!!***  PUBLIC SUBROUTINES  *****************************************************
!!
!===============================================================================
!
!===============================================================================
!
! subroutine PRINT_WELCOME:
! ------------------------
!
!   Subroutine prints welcome message.
!
!   Arguments:
!
!     verbose - the verbose flag;
!
!===============================================================================
!
  subroutine print_welcome(verbose)

    implicit none

    logical, intent(in) :: verbose

!-------------------------------------------------------------------------------
!
    if (.not. verbose) return

    write(*,"(1x,78('-'))")
    write(*,"(1x,18('='),17x,a,17x,19('='))") 'A M U N'
    write(*,"(1x,16('='),4x,a,4x,16('='))")                                    &
                                      'Copyright (C) 2008-2024 Grzegorz Kowal'
    write(*,"(1x,18('='),9x,a,9x,19('='))")                                    &
                                        'under GNU GPLv3 license'
    write(*,"(1x,78('-'))")

!-------------------------------------------------------------------------------
!
  end subroutine print_welcome
!
!===============================================================================
!
! subroutine PRINT_SECTION:
! ------------------------
!
!   Subroutine prints section lines.
!
!   Arguments:
!
!     verbose - the verbose flag;
!     title   - the section title;
!
!===============================================================================
!
  subroutine print_section(verbose, title)

    implicit none

    logical         , intent(in) :: verbose
    character(len=*), intent(in) :: title

!-------------------------------------------------------------------------------
!
    if (.not. verbose) return

    write(*,*)
    write(*,"(1x,a,':')") trim(adjustl(title))

!-------------------------------------------------------------------------------
!
  end subroutine print_section
!
!===============================================================================
!
! subroutine PRINT_PARAMETER_LOGICAL:
! ----------------------------------
!
!   Subroutine prints the value of a boolean parameter.
!
!   Arguments:
!
!     verbose - the verbose flag;
!     dsc     - the parameter description;
!     val     - the parameter value;
!
!===============================================================================
!
  subroutine print_parameter_logical(verbose, dsc, val, str)

    implicit none

    logical         , intent(in) :: verbose
    character(len=*), intent(in) :: dsc
    logical         , intent(in) :: val
    character(len=*), intent(in) :: str

    character(len=26) :: msg
    character(len=8)  :: t, f

!-------------------------------------------------------------------------------
!
    if (verbose) then
      select case(str)
      case("yes","no")
        t = "yes"
        f = "no"
      case("true","false")
        t = "true"
        f = "false"
      case default
        t = "on"
        f = "off"
      end select
      msg = trim(adjustl(dsc))
      if (val) then
        write(*,"(4x,a26,1x,'=',2x,a)") msg, trim(t)
      else
        write(*,"(4x,a26,1x,'=',2x,a)") msg, trim(f)
      end if
    end if

!-------------------------------------------------------------------------------
!
  end subroutine print_parameter_logical
!
!===============================================================================
!
! subroutine PRINT_PARAMETER_INTEGER:
! ----------------------------------
!
!   Subroutine prints integer parameter.
!
!   Arguments:
!
!     verbose - the verbose flag;
!     dsc     - the parameter description;
!     val     - the parameter value;
!
!===============================================================================
!
  subroutine print_parameter_integer(verbose, dsc, val)

    implicit none

    logical         , intent(in) :: verbose
    character(len=*), intent(in) :: dsc
    integer         , intent(in) :: val

    character(len=26) :: msg

!-------------------------------------------------------------------------------
!
    if (verbose) then
      msg = trim(adjustl(dsc))
      if (val >= 0) then
        write(*,"(4x,a26,1x,'=',2x,i0)") msg, val
      else
        write(*,"(4x,a26,1x,'=',1x,i0)") msg, val
      end if
    end if

!-------------------------------------------------------------------------------
!
  end subroutine print_parameter_integer
!
!===============================================================================
!
! subroutine PRINT_PARAMETER_DOUBLE:
! ----------------------------------
!
!   Subroutine prints double precision parameter.
!
!   Arguments:
!
!     verbose - the verbose flag;
!     dsc     - the parameter description;
!     val     - the parameter value;
!
!===============================================================================
!
  subroutine print_parameter_double(verbose, dsc, val)

    implicit none

    logical         , intent(in) :: verbose
    character(len=*), intent(in) :: dsc
    real(kind=8)    , intent(in) :: val

    character(len=26) :: msg

!-------------------------------------------------------------------------------
!
    if (verbose) then
      msg = trim(adjustl(dsc))
      write(*,"(4x,a26,1x,'=',1x,es12.5)") msg, val
    end if

!-------------------------------------------------------------------------------
!
  end subroutine print_parameter_double
!
!===============================================================================
!
! subroutine PRINT_PARAMETER_STRING:
! ---------------------------------
!
!   Subroutine prints string parameter.
!
!   Arguments:
!
!     verbose - the verbose flag;
!     dsc     - the parameter description;
!     val     - the parameter value;
!
!===============================================================================
!
  subroutine print_parameter_string(verbose, dsc, val)

    implicit none

    logical         , intent(in) :: verbose
    character(len=*), intent(in) :: dsc
    character(len=*), intent(in) :: val

    character(len=26) :: msg

!-------------------------------------------------------------------------------
!
    if (verbose) then
      msg = trim(adjustl(dsc))
      write(*,"(4x,a26,1x,'=',2x,a)") msg, trim(adjustl(val))
    end if

!-------------------------------------------------------------------------------
!
  end subroutine print_parameter_string
!
!===============================================================================
!
! subroutine PRINT_PARAMETER_INTEGER_RANGE:
! ----------------------------------------
!
!   Subroutine prints the range of integer parameter.
!
!   Arguments:
!
!     verbose - the verbose flag;
!     dsc     - the parameter description;
!     lo      - the range lower value;
!     hi      - the range higher value;
!
!===============================================================================
!
  subroutine print_parameter_integer_range(verbose, dsc, lo, hi)

    implicit none

    logical         , intent(in) :: verbose
    character(len=*), intent(in) :: dsc
    integer         , intent(in) :: lo, hi

    character(len=26) :: msg

!-------------------------------------------------------------------------------
!
    if (verbose) then
      msg = trim(adjustl(dsc))
      if (lo >= 0) then
        write(*,"(4x,a26,1x,'=',2x,i0,' ... ',i0)") msg, lo, hi
      else
        write(*,"(4x,a26,1x,'=',1x,i0,' ... ',i0)") msg, lo, hi
      end if
    end if

!-------------------------------------------------------------------------------
!
  end subroutine print_parameter_integer_range
!
!===============================================================================
!
! subroutine PRINT_PARAMETER_DOUBLE_RANGE:
! ---------------------------------------
!
!   Subroutine prints the range of double precision parameter.
!
!   Arguments:
!
!     verbose - the verbose flag;
!     dsc     - the parameter description;
!     lo      - the range lower value;
!     hi      - the range higher value;
!
!===============================================================================
!
  subroutine print_parameter_double_range(verbose, dsc, lo, hi)

    implicit none

    logical         , intent(in) :: verbose
    character(len=*), intent(in) :: dsc
    real(kind=8)    , intent(in) :: lo, hi

    character(len=26) :: msg

!-------------------------------------------------------------------------------
!
    if (verbose) then
      msg = trim(adjustl(dsc))
      write(*,"(4x,a26,1x,'=',1x,es12.5,' ... ',es12.5)") msg, lo, hi
    end if

!-------------------------------------------------------------------------------
!
  end subroutine print_parameter_double_range
!
!===============================================================================
!
! subroutine PRINT_PARAMETER_STRING_RANGE:
! ---------------------------------------
!
!   Subroutine prints two string parameters as a range.
!
!   Arguments:
!
!     verbose - the verbose flag;
!     dsc     - the parameter description;
!     lo      - the range lower value;
!     hi      - the range higher value;
!
!===============================================================================
!
  subroutine print_parameter_string_range(verbose, dsc, lo, hi, width)

    implicit none

    logical          , intent(in) :: verbose
    character(len=*) , intent(in) :: dsc
    character(len=*) , intent(in) :: lo, hi
    integer, optional, intent(in) :: width

    character(len=26) :: num, msg

!-------------------------------------------------------------------------------
!
    if (verbose) then
      msg = trim(adjustl(dsc))
      if (present(width)) then
        write(num,'(i0)') width
        write(*,"(4x,a26,1x,'=',2x,a" // num // ",' ... ',a)")                 &
                                                  msg, trim(lo), trim(hi)
      else
        write(*,"(4x,a26,1x,'=',2x,a,' ... ',a)") msg, trim(lo), trim(hi)
      end if
    end if

!-------------------------------------------------------------------------------
!
  end subroutine print_parameter_string_range
!
!===============================================================================
!
! subroutine PRINT_MESSAGE_LOC:
! ----------------------------
!
!   Subroutine prints a message for a given location.
!
!   Arguments:
!
!     loc - the warning location;
!     msg - the warning message;
!
!===============================================================================
!
  subroutine print_message_loc(loc, msg)

    use iso_fortran_env, only : error_unit

    implicit none

    character(len=*), intent(in) :: loc, msg

!-------------------------------------------------------------------------------
!
    write(error_unit,"('[',a,']:')") trim(loc)
    write(error_unit,"(4x,a)"      ) trim(msg)

!-------------------------------------------------------------------------------
!
  end subroutine print_message_loc
!
!===============================================================================
!
! subroutine PRINT_MESSAGE_LOC:
! ----------------------------
!
!   Subroutine prints just a message without the location.
!
!   Arguments:
!
!     msg - the warning message;
!
!===============================================================================
!
  subroutine print_message_msg(msg)

    use iso_fortran_env, only : error_unit

    implicit none

    character(len=*), intent(in) :: msg

!-------------------------------------------------------------------------------
!
    write(error_unit,"(4x,a)"      ) trim(msg)

!-------------------------------------------------------------------------------
!
  end subroutine print_message_msg
!
!===============================================================================
!
! function UPPERCASE:
! ------------------
!
!   Function converts string to the upper case.
!
!   Arguments:
!
!     str - the input string;
!
!===============================================================================
!
  pure function uppercase(str) result(string)

    implicit none

    character(*), intent(in) :: str
    character(len(str))      :: string

    integer :: ic, i

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

!-------------------------------------------------------------------------------
!
    string = str
    do i = 1, len_trim(str)
        ic = index(low, str(i:i))
        if (ic > 0) string(i:i) = cap(ic:ic)
    end do

  end function uppercase
!
!===============================================================================
!
! function LOWERCASE:
! ------------------
!
!   Function converts string to the lower case.
!
!   Arguments:
!
!     str - the input string;
!
!===============================================================================
!
  pure function lowercase(str) result(string)

    implicit none

    character(*), intent(in) :: str
    character(len(str))      :: string

    integer :: ic, i

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

!-------------------------------------------------------------------------------
!
    string = str
    do i = 1, len_trim(str)
        ic = index(cap, str(i:i))
        if (ic > 0) string(i:i) = low(ic:ic)
    end do

  end function lowercase
!
!===============================================================================
!
! subroutine ENABLE_FLUSH_AND_SYNC:
! --------------------------------
!
!   This function enables flushing and synchronization of I/O buffers.
!
!===============================================================================
!
  subroutine enable_flush_and_sync()

    implicit none

!-------------------------------------------------------------------------------
!
    noflush = .false.

!-------------------------------------------------------------------------------
!
  end subroutine enable_flush_and_sync
!
!===============================================================================
!
! subroutine DISABLE_FLUSH_AND_SYNC:
! ---------------------------------
!
!   This function disables flushing and synchronization of I/O buffers.
!
!===============================================================================
!
  subroutine disable_flush_and_sync()

    implicit none

!-------------------------------------------------------------------------------
!
    noflush = .true.

!-------------------------------------------------------------------------------
!
  end subroutine disable_flush_and_sync
!
!===============================================================================
!
! subroutine FLUSH_AND_SYNC:
! -------------------------
!
!   This function performs a flush of the I/O buffers and ensures that all
!   changes are synchronized to the storage device using fsync.
!
!   Arguments:
!
!     iounit - the I/O unit to flash;
!
!===============================================================================
!
  subroutine flush_and_sync(iounit)

    use iso_fortran_env, only : error_unit

    implicit none

#ifdef __GFORTRAN__
    interface
      function fsync (fd) bind(c,name="fsync")
      use iso_c_binding, only: c_int
        integer(c_int), value :: fd
        integer(c_int) :: fsync
      end function fsync
    end interface
#endif /* __GFORTRAN__ */

    integer, intent(in) :: iounit

    integer :: ret

!-------------------------------------------------------------------------------
!
    if (noflush) return

    call flush(iounit)

#ifdef __GFORTRAN__
    ret = fsync(fnum(iounit))

    if (ret /= 0) &
      write(error_unit,"('Error calling FSYNC for unit:',1i4)") iounit
#endif /* __GFORTRAN__ */

!-------------------------------------------------------------------------------
!
  end subroutine flush_and_sync

!===============================================================================
!
end module helpers