sll_m_errors.F90

Go to the documentation of this file.

module sll_m_errors
 
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   use iso_fortran_env, only: &
      error_unit
 
   implicit none
 
   public :: &
      sll_s_error_handler, &
      sll_s_warning_handler
 
   private
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
   ! Instead of using the non-standard subroutine abort() provided by the compiler,
   ! use abort() from the C standard library "stdlib.h"
   interface
      subroutine c_abort() bind(C, name="abort")
      end subroutine
   end interface
 
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
contains
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
   !----------------------------------------------------------------------------
   !----------------------------------------------------------------------------
   subroutine sll_s_warning_handler(file_name, line_num, caller, message)
      character(len=*), intent(in) :: file_name
      integer, intent(in) :: line_num
      character(len=*), intent(in) :: caller
      character(len=*), intent(in) :: message
 
      call errout(error_unit, 'W', file_name, line_num, caller, message)
 
   end subroutine sll_s_warning_handler
 
   !----------------------------------------------------------------------------
   !----------------------------------------------------------------------------
   subroutine sll_s_error_handler(file_name, line_num, caller, message)
      character(len=*), intent(in) :: file_name
      integer, intent(in) :: line_num
      character(len=*), intent(in) :: caller
      character(len=*), intent(in) :: message
 
      call errout(error_unit, 'F', file_name, line_num, caller, message)
      call c_abort()
 
   end subroutine sll_s_error_handler
 
   !----------------------------------------------------------------------------
   !----------------------------------------------------------------------------
   subroutine errout(out_unit, severity, file_name, line_num, caller, message)
 
      integer, intent(in) :: out_unit
      character(len=1), intent(in) :: severity
      character(len=*), intent(in) :: file_name
      integer, intent(in) :: line_num
      character(len=*), intent(in) :: caller
      character(len=*), intent(in) :: message
 
      character(len=64) :: line_num_str
 
      write (out_unit, *)
      select case (severity)  !     *** Severity ***
      case ('W')!
         write (out_unit, "(/10x,a)") '*** WARNING ***'
      case ('F')
         write (out_unit, "(/10x,a)") '*** FATAL ERROR ***'
      case default
         write (out_unit, "(/10x,a)") '*** FATAL ERROR ***'
         write (out_unit, "(/10x,a)") &
            'Error handler (ERROUT) called with unknown severity level: ', severity
      end select
 
      write (line_num_str, *) line_num
      line_num_str = adjustl(line_num_str)
 
      write (out_unit, "(/10x,a)") &
         'Generated by program or subroutine: '//trim(caller)
      write (out_unit, "(/10x,a)") &
         'In '//trim(file_name)//':'//trim(line_num_str)
      write (out_unit, "(/10x,a)") trim(message)
      write (out_unit, *)
 
   end subroutine errout
   !----------------------------------------------------------------------------
 
end module sll_m_errors