!!****************************************************************************** !! !! 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 !! !! 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 . !! !!****************************************************************************** !! !! 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