! ! MiMiC: A Framework for Multiscale Modeling in Computational Chemistry ! Copyright (C) 2015-2022 The MiMiC Contributors (see CONTRIBUTORS file for details). ! ! This file is part of MiMiC. ! ! MiMiC is free software: you can redistribute it and/or modify ! it under the terms of the GNU Lesser General Public License as ! published by the Free Software Foundation, either version 3 of ! the License, or (at your option) any later version. ! ! MiMiC 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 Lesser General Public License for more details. ! ! You should have received a copy of the GNU Lesser General Public License ! along with this program. If not, see <http://www.gnu.org/licenses/>. ! module mimic_errors #ifndef stderr use, intrinsic :: iso_fortran_env, only : stderr => error_unit #endif use mimic_config implicit none interface subroutine handle(err_type, message, source_file, line_num) !> Type of the error integer, intent(in) :: err_type !> Optional message character(len=*), intent(in) :: message !> Source file where the problem occurred character(len=*), intent(in) :: source_file !> Source line at which the error occurred integer, intent(in) :: line_num end subroutine handle end interface private !> Format for the error file name character(len=*), parameter :: ERROR_FILE = "('MiMiC_error-',i0,'.err')" !> Severity level of the error !> Warning is a recoverable condition with a fallback !> available integer, parameter, public :: SEVERITY_WARN = 1 !> Severity for unrecoverable condition in which, !> no fallback can be found integer, parameter, public :: SEVERITY_FATAL = 2 !> Error type associated with the memory allocation integer, parameter, public :: TYPE_MEM = 1 !> Error type associated with the incorrect argument passed integer, parameter, public :: TYPE_INCORRECT_ARG = 2 !> Generic error type integer, parameter, public :: TYPE_NONE = -1 integer, save :: process_id = -1 procedure(handle), pointer, save :: custom_handler => NULL() public :: handle_error public :: init_error_handling public :: handle contains !> initialiaze error handler subroutine init_error_handling(pid, error_handler) !> process ID (preferrably MPI rank) integer, intent(in) :: pid !> optional external error handler procedure(handle), pointer, optional :: error_handler process_id = pid if (present(error_handler)) then custom_handler => error_handler endif end subroutine init_error_handling !> Subroutine to print warning header subroutine print_warning(iounit, source_file, line_num) !> I/O unit to write warning to integer, intent(in) :: iounit !> Source file where the warning was issued character(len=*), intent(in) :: source_file !> Line number at which the warning was issued integer, intent(in) :: line_num integer :: ios write(unit=iounit, fmt=*) "--------------------------------------------------------------" write(unit=iounit, fmt=*, iostat=ios) "MiMiC Warning in: ", & source_file, " line: ", line_num write(unit=iounit, fmt=*) "--------------------------------------------------------------" end subroutine print_warning !> Subroutine to print error header subroutine write_error_header(iounit, source_file, line_num) !> I/O unit to write error to integer, intent(in) :: iounit !> Source file where the error was issued character(len=*), intent(in) :: source_file !> Line number at which the error was issued integer, intent(in) :: line_num integer :: ios write(unit=iounit, fmt=*) "--------------------------------------------------------------" write(unit=iounit, fmt=*, iostat=ios) "Program ", PROJECT_NAME, " version: ", PROJECT_VER write(unit=iounit, fmt=*, iostat=ios) "Process ID: ", process_id write(unit=iounit, fmt="('Encountered an error in file: ',A,' line: ',i0)", iostat=ios) & source_file, line_num write(unit=iounit, fmt=*) "--------------------------------------------------------------" write(unit=iounit, fmt=*) write(unit=iounit, fmt=*, iostat=ios) "Error message:" end subroutine write_error_header !> Handler to treat memory allocation issues subroutine handle_mem_error(iounit, message) !> I/O unit to write error to integer, intent(in) :: iounit !> Error message character(len=*), intent(in) :: message write(unit=iounit, fmt=*) "Memory allocation problem in ", message end subroutine handle_mem_error !> Handler to treat incorrect argument errors subroutine handle_inc_error(iounit, message) !> I/O unit to write error to integer, intent(in) :: iounit !> Error message character(len=*), intent(in) :: message write(unit=iounit, fmt=*) "Incorrect argument passed in ", message end subroutine handle_inc_error !> Handler to treat any other kind of errors subroutine handle_generic_error(iounit, message) !> I/O unit to write error to integer, intent(in) :: iounit !> Error message character(len=*), intent(in) :: message write(unit=iounit, fmt=*) "Unexpected problem!" write(unit=iounit, fmt=*) message end subroutine handle_generic_error !> Subroutine to handle errors subroutine handle_error(severity, err_type, message, source_file, line_num) !> Severity level of the error integer, intent(in) :: severity !> Type of the error integer, intent(in) :: err_type !> Optional message character(len=*), intent(in) :: message !> Source file where the problem occurred character(len=*), intent(in) :: source_file !> Source line at which the error occurred integer, intent(in) :: line_num integer :: iounit integer :: ios character(len=50) :: filename if (severity == SEVERITY_WARN) then iounit = stderr call print_warning(iounit, source_file, line_num) else write(filename, fmt=ERROR_FILE) process_id open(newunit=iounit, file=filename, iostat=ios, status="new", action="write") if ( ios /= 0 ) then write(unit=stderr, fmt=*) "File system I/O problem - reverting to terminal output" iounit = stderr endif call write_error_header(iounit, source_file, line_num) endif select case (err_type) case (TYPE_MEM) call handle_mem_error(iounit, message) case (TYPE_INCORRECT_ARG) call handle_inc_error(iounit, message) case default call handle_generic_error(iounit, message) end select if (iounit /= stderr) then close(unit=iounit) endif if (severity == SEVERITY_FATAL) then if (associated(custom_handler)) then call custom_handler(err_type, message, source_file, line_num) else stop "MiMiC has stopped with an error! See MiMiC_error file(s) for details" endif endif end subroutine handle_error end module mimic_errors