error_handler_s.f90 Source File

submodule (error_handling_m) error_handler_s
    !! Contains functionality of the error handler type
    implicit none
contains

    module subroutine error_handler_set_error_mode(this, err_mode)
        class(error_handler_t), intent(inout) :: this
        integer, intent(in) :: err_mode

        if(err_mode == ERRORS_RETURN &
           .or. err_mode == ERRORS_ARE_FATAL) this%error_mode = err_mode
    end subroutine

    module subroutine error_handler_handle_error(this, message, status_code, &
                                                 line_number, file_name, &
                                                 additional_info)
        class(error_handler_t), intent(inout) :: this
        character(len=*), intent(in) :: message
        integer, intent(in) :: status_code
        integer, intent(in) :: line_number
        character(len=*), intent(in) :: file_name
        type(error_info_t), optional, intent(in) :: additional_info

        integer :: channel, isize, irank, ierr
        logical :: mpi_is_initialized
        character(len=:), allocatable :: fname, message_type

        character(len=:), allocatable :: rank_str
        ! Prefix printed when multiple MPI processes are involved to indicate
        ! which process prints which messages
        character(len=64) :: rank_str_buffer
        ! Buffer needed to convert rank prefix to a string

        ! Check if MPI has been initialized before performing MPI calls,
        ! otherwise this leads to unverbose MPI error messages instead of the
        ! one we want to display here
        call MPI_Initialized(mpi_is_initialized, ierr)
        if(mpi_is_initialized) then
            call MPI_Comm_size(get_communicator(), isize, ierr)
            call MPI_Comm_rank(get_communicator(), irank, ierr)
        else
            isize = 0
            irank = 0
        endif

        ! Strip-off directory which may be given in file_name for some compilers
        fname = strip_filename(file_name)

        if(status_code == 0) return

        ! Decide if error or warning message should be given
        if(status_code < 0) then
            message_type = "Error"
            channel = get_stderr()
        else
            message_type = "Warning"
            channel = get_stdout()

            ! Because warnings only write to stdout, we print a general message
            ! to stderr to notify the user.
            if(this%first_time_warning) then
                this%first_time_warning = .false.
                if(irank == 0) then
                    write(get_stderr(), "(A)") &
                        trim(this%handler_name)//" encountered warnings!"
                    write(get_stderr(), "(A)") ""
                endif
            endif
        endif

        ! Check if there is more than 1 MPI process. If yes, create a prefix
        ! string to put before all messages to uniquely identify the messages
        ! with MPI processes.
        if(isize > 1) then
            write(rank_str_buffer, "(A, I0, A, I0, A)") &
                "(", irank, "/", (isize - 1), ")"
            rank_str = trim(rank_str_buffer)//" "
        else
            rank_str = ""
        endif

        ! Main message
        write(channel, "(X, A, I0)") &
            rank_str//trim(this%handler_name)//" "//message_type//": code ", &
            status_code
        write(channel, "(X, A)") &
            rank_str//message
        if(present(additional_info)) &
            call additional_info%print(channel, prefix=rank_str)
        write(channel, "(X, A, I0, A, A)") &
            rank_str//"On line ", line_number, " in file ", fname

        call flush(channel)

        ! We only terminate if status_code is in range of the allowed
        ! error codes. I.e. it can be unambiguously be recognized as an error.
        if(status_code < 0 .and. this%error_mode == ERRORS_ARE_FATAL) then
            ! Finalize MPI before exiting to avoid MPI crashing with unhelpful error messages. 
            ! Instead the code will be terminated in a controlled way
            if(mpi_is_initialized) then
                call MPI_Finalize(ierr)
            end if

            ! We return -1 so that a stopped job will be recognized as stopped
            ! with error (default = 0 = no error)
            error stop -1
        endif
    end subroutine

    module subroutine error_handler_handle_error_netcdf(this, istatus, &
                                                        line_number, file_name)
        !! Wrapper of handle error for calls of NetCDF functions.
        !! Checks for NetCDF errors and prints a standardized error message.
        class(error_handler_t), intent(inout) :: this
        !! Instance of the type
        integer, intent(in) :: istatus
        !! Status integer returned by the NetCDF function
        integer, intent(in) :: line_number
        !! Line number where error or warning occured, i.e. __LINE__
        character(len=*), intent(in) :: file_name
        !! File name where error or warning occured, i.e. __FILE__

        type(error_info_t) :: additional_info

        if(istatus /= nf90_noerr) then
            additional_info%c_info = trim(nf90_strerror(istatus))
            additional_info%i_info = [istatus]

            call this%handle_error("NetCDF returned with error!", &
                                   this%netcdf_error_code, &
                                   line_number, file_name, additional_info)

        end if

    end subroutine

    function strip_filename(string) result(res)
        !! Strips of the name of a file from a directory path. If the string
        !! does not contain a directory path, it will not be changed.
        character(len=*), intent(in) :: string
        !! String to process
        character(len=:), allocatable :: res

        ! Check if file name is given by a path (contains "/")
        ! Extract name of the file if yes
        if(index(string, "/") > 0) then
            res = string((index(string, "/", back=.true.) + 1):len(string))
        else
            res = string
        endif
    end function

end submodule