exceptions.F90

Go to the documentation of this file.

module exceptions
 
  use iso_c_binding
  use iso_fortran_env, only : output_unit
  use logfiles, only : logs, log_general, log_all
  implicit none
 
  private
 
  public :: assert, die, warn, check_for_fatal_warnings, index_values_valid
 
  logical (c_bool), parameter :: true = .true._c_bool
  logical (c_bool), parameter :: false = .false._c_bool
 
  interface  assert
     module procedure :: assert_4bit
     module procedure :: assert_1bit
  end interface assert
 
  interface index_values_valid
    module procedure :: bounds_check_integer_1d
    module procedure :: bounds_check_float_1d
    module procedure :: bounds_check_double_1d
    module procedure :: bounds_check_integer_2d
    module procedure :: bounds_check_float_2d
    module procedure :: bounds_check_double_2d
  end interface index_values_valid
 
  integer (c_int), public     :: number_of_fatal_warnings = 0
  integer (c_int), parameter  :: max_fatal_warnings = 50
  character (len=256)         :: warning_text( max_fatal_warnings )
  logical (c_bool), public    :: halt_upon_fatal_error = true
 
contains
 
   function bounds_check_integer_1d( array_vals, array_index )   result(bounds_ok)
 
     integer (c_int), intent(in)  :: array_vals(:)
     integer (c_int), intent(in)  :: array_index
     logical (c_bool)             :: bounds_ok
 
     bounds_ok = false
 
     if (      lbound(array_vals,1) <= array_index                             &
         .and. ubound(array_vals,1) >= array_index ) bounds_ok = true
 
   end function bounds_check_integer_1d
 
!------------------------------------------------------------------------------------------------
 
   function bounds_check_float_1d( array_vals, array_index )   result(bounds_ok)
 
     real (c_float), intent(in)   :: array_vals(:)
     integer (c_int), intent(in)  :: array_index
     logical (c_bool)             :: bounds_ok
 
     bounds_ok = false
 
     if (      lbound(array_vals,1) <= array_index                             &
         .and. ubound(array_vals,1) >= array_index ) bounds_ok = true
 
   end function bounds_check_float_1d
 
!------------------------------------------------------------------------------------------------
 
   function bounds_check_double_1d( array_vals, array_index )   result(bounds_ok)
 
     real (c_double), intent(in)  :: array_vals(:)
     integer (c_int), intent(in)  :: array_index
     logical (c_bool)             :: bounds_ok
 
     bounds_ok = false
 
     if (      lbound(array_vals,1) <= array_index                             &
         .and. ubound(array_vals,1) >= array_index ) bounds_ok = true
 
   end function bounds_check_double_1d
 
!------------------------------------------------------------------------------------------------
 
   function bounds_check_integer_2d( array_vals, array_index1,                 &
                                                 array_index2 )  result(bounds_ok)
 
     integer (c_int), intent(in)  :: array_vals(:,:)
     integer (c_int), intent(in)  :: array_index1
     integer (c_int), intent(in)  :: array_index2
     logical (c_bool)             :: bounds_ok
 
     bounds_ok = false
 
     if (      lbound(array_vals,1) <= array_index1                            &
         .and. ubound(array_vals,1) >= array_index1                            &
         .and. lbound(array_vals,2) <= array_index2                            &
         .and. ubound(array_vals,2) >= array_index2 )  bounds_ok = true
 
   end function bounds_check_integer_2d
 
!------------------------------------------------------------------------------------------------
 
   function bounds_check_float_2d( array_vals, array_index1,                 &
                                               array_index2 )  result(bounds_ok)
 
     real (c_float), intent(in)   :: array_vals(:,:)
     integer (c_int), intent(in)  :: array_index1
     integer (c_int), intent(in)  :: array_index2
     logical (c_bool)             :: bounds_ok
 
     bounds_ok = false
 
     if (      lbound(array_vals,1) <= array_index1                            &
         .and. ubound(array_vals,1) >= array_index1                            &
         .and. lbound(array_vals,2) <= array_index2                            &
         .and. ubound(array_vals,2) >= array_index2 )  bounds_ok = true
 
   end function bounds_check_float_2d
 
!------------------------------------------------------------------------------------------------
 
   function bounds_check_double_2d( array_vals, array_index1,                 &
                                                array_index2 )  result(bounds_ok)
 
     real (c_double), intent(in)  :: array_vals(:,:)
     integer (c_int), intent(in)  :: array_index1
     integer (c_int), intent(in)  :: array_index2
     logical (c_bool)             :: bounds_ok
 
     bounds_ok = false
 
     if (      lbound(array_vals,1) <= array_index1                            &
         .and. ubound(array_vals,1) >= array_index1                            &
         .and. lbound(array_vals,2) <= array_index2                            &
         .and. ubound(array_vals,2) >= array_index2 )  bounds_ok = true
 
   end function bounds_check_double_2d
 
!------------------------------------------------------------------------------------------------
 
   subroutine die(sMessage, sModule, iLine, sHints, sCalledBy, iCalledByLine )
 
    character (len=*), intent(in)               :: smessage
    character (len=*), intent(in), optional     :: smodule
    integer (c_int), intent(in), optional       :: iline
    character (len=*), intent(in), optional     :: shints
    character (len=*), intent(in), optional     :: scalledby
    integer (c_int), intent(in), optional       :: icalledbyline
 
!    integer (c_int), intent(in), optional  :: iLU
 
    ! [ LOCALS ]
    character (len=6) :: slinenum
 
    call logs%set_loglevel( log_all )
 
    if (halt_upon_fatal_error)   call logs%set_echo( .true._c_bool )
 
    call logs%write( "error condition:  "//trim(smessage), itab=12, ilinesbefore=1 )
 
    if ( present( scalledby ) )  &
      call logs%write( "called by:  "//trim(scalledby), itab=18 )
 
    if (present(icalledbyline)) then
      write(slinenum, fmt="(i0)") icalledbyline
      call logs%write( "line number:  "//trim(slinenum), itab=16 )
    endif
 
    if (present(smodule))  &
      call logs%write( "module:  "//trim(smodule), itab=21 )
 
    if (present(iline)) then
      write(slinenum, fmt="(i0)") iline
      call logs%write( "line number:  "//trim(slinenum), itab=16 )
    endif
 
    if (present(shints)) then
      if ( len_trim(shints) > 0 )  &
        call logs%write( "==> "//trim(shints), itab=12 )
    endif
 
    call logs%write("", ilinesafter=1)
 
    if (halt_upon_fatal_error) then
      call logs%write( "** ERROR -- PROGRAM EXECUTION HALTED **", ilinesbefore=1, ilinesafter=1 )
      stop
    endif
 
  end subroutine die
 
!------------------------------------------------------------------------------------------------
 
  subroutine check_for_fatal_warnings()
 
    ! [ LOCALS ]
    character (len=6)     :: snumwarnings
    character (len=6)     :: smaxwarnings
    character (len=6)     :: sindex
    integer (c_int)  :: iindex
    character (len=10)    :: sbigs
    character (len=1)     :: slittles
 
    if ( number_of_fatal_warnings >= 1 ) then
 
      if ( number_of_fatal_warnings > 1 ) then
        sbigs = "S WERE"
        slittles = "s"
      else
        sbigs = " WAS"
        slittles = ""
      endif
 
      call logs%set_loglevel( log_all )
      call logs%set_echo( .true._c_bool )
 
      write(unit=snumwarnings, fmt="(i0)") number_of_fatal_warnings
      call logs%write( "** "//trim(adjustl(snumwarnings))//" FATAL WARNING"//trim(sbigs)     &
                       //" DETECTED IN INPUT **", ilinesbefore=1, ilinesafter=1 )
 
      call logs%write( "# Summary of fatal warning"//trim(slittles)//" #" )
      call logs%write( "-------------------------------", ilinesafter=1 )
 
      do iindex = 1, number_of_fatal_warnings
        if (iindex <= max_fatal_warnings ) then
          write(unit=sindex, fmt="(i0)") iindex
          call logs%write( trim(adjustl(sindex))//": "//trim(warning_text(iindex)), ilinesbefore=1)
        endif
      enddo
 
      if ( number_of_fatal_warnings >= max_fatal_warnings ) then
        write(unit=smaxwarnings, fmt="(i0)") max_fatal_warnings
        call logs%write( "*There were more than "//trim(adjustl(smaxwarnings))//" fatal warnings. " &
          //" Only a partial list of warnings is shown above.*", ilinesbefore=1, ilinesafter=1, itab=2 )
      endif
 
      call die( smessage="Fatal warning"//trim(slittles)//" associated with input.", &
                shints="Address the problem"//trim(slittles)//" listed above and try again." )
 
    endif
 
  end subroutine check_for_fatal_warnings
 
!------------------------------------------------------------------------------------------------
 
  subroutine warn(sMessage, sModule, iLine, sHints, lFatal, iLogLevel, lEcho)
 
    character (len=*), intent(in)               :: smessage
    character (len=*), intent(in), optional     :: smodule
    integer (c_int), intent(in), optional  :: iline
    character (len=*), intent(in), optional     :: shints
    logical (c_bool), intent(in), optional :: lfatal
    integer (c_int), intent(in), optional  :: iloglevel
    logical (c_bool), intent(in), optional :: lecho
!    integer (c_int), intent(in), optional  :: iLU
 
    ! [ LOCALS ]
    character (len=32)   :: sbuf
 
    if ( present( iloglevel ) )   call logs%set_loglevel( iloglevel )
    if ( present( lecho ) )       call logs%set_echo( lecho )
 
    if (present(lfatal)) then
      if (lfatal) then
        number_of_fatal_warnings = number_of_fatal_warnings + 1
        call logs%write(" ** WARNING fatal error: **", itab=6, ilinesbefore=1)
        call logs%write( trim(smessage), itab=16 )
 
        if (number_of_fatal_warnings <= ubound( warning_text,1 ) )     &
          warning_text( number_of_fatal_warnings ) = trim(smessage)
      else
        call logs%write(" ** WARNING **", itab=10, ilinesbefore=1)
        call logs%write( trim(smessage), itab=16 )
      endif
    else
      call logs%write(" ** WARNING **", itab=10, ilinesbefore=1)
      call logs%write( trim(smessage), itab=16 )
    endif
 
    if (present(smodule))  &
      call logs%write("module:  "//trim(smodule), itab=18 )
 
    if (present(iline)) then
      write(sbuf, fmt="(i0)") iline
      call logs%write("line no:  "//trim(sbuf), itab=18 )
    endif
 
    if (present(shints)) then
      if ( len_trim(shints) > 0 )  &
        call logs%write("   ==> "//trim(shints), itab=9, ilinesbefore=1 )
    endif
 
    call logs%write("", ilinesafter=1)
 
  end subroutine warn
 
!------------------------------------------------------------------------------------------------
 
  subroutine assert_1bit(lCondition, sMessage, sModule, iLine, sCalledBy, iCalledByLine, sHints )
 
    logical (c_bool), intent(in)                :: lCondition
    character (len=*), intent(in)               :: sMessage
    character (len=*), intent(in), optional     :: sHints
    character (len=*), intent(in), optional     :: sCalledBy
    integer (c_int), intent(in), optional       :: iCalledByLine
    character (len=*), intent(in), optional     :: sModule
    integer (c_int), intent(in), optional       :: iLine
 
    character (len=256) :: sHints_l
 
    if (.not. lcondition) then
 
      if ( present( shints ) ) then
        shints_l = trim( shints )
      else
        shints_l = ""
      endif
 
      if (present( scalledby ) .and. present( icalledbyline ) &
        .and. present(smodule) .and. present(iline) ) then
        call die( smessage=smessage, scalledby=scalledby, icalledbyline=icalledbyline, &
          smodule=smodule, iline=iline, shints=shints_l )
      elseif ( present(smodule) .and. present(iline) ) then
        call die( smessage=smessage, smodule=smodule, iline=iline, shints=shints_l )
      elseif ( present(smodule) ) then
        call die( smessage=smessage, smodule=smodule, shints=shints_l )
      else
        call die( smessage=smessage, shints=shints_l )
      endif
 
    endif
 
  end subroutine assert_1bit
 
!------------------------------------------------------------------------------------------------
 
subroutine assert_4bit(lCondition, sMessage, sModule, iLine, sCalledBy, iCalledByLine, sHints )
 
  logical (4), intent(in)                     :: lCondition
  character (len=*), intent(in)               :: sMessage
  character (len=*), intent(in), optional     :: sHints
  character (len=*), intent(in), optional     :: sCalledBy
  integer (c_int), intent(in), optional       :: iCalledByLine
  character (len=*), intent(in), optional     :: sModule
  integer (c_int), intent(in), optional       :: iLine
 
  character (len=256) :: sHints_l
 
  if (.not. lcondition) then
 
    if ( present( shints ) ) then
      shints_l = trim( shints )
    else
      shints_l = ""
    endif
 
    if (present( scalledby ) .and. present( icalledbyline ) &
      .and. present(smodule) .and. present(iline) ) then
      call die( smessage=smessage, scalledby=scalledby, icalledbyline=icalledbyline, &
        smodule=smodule, iline=iline, shints=shints_l )
    elseif ( present(smodule) .and. present(iline) ) then
      call die( smessage=smessage, smodule=smodule, iline=iline, shints=shints_l )
    elseif ( present(smodule) ) then
      call die( smessage=smessage, smodule=smodule, shints=shints_l )
    else
      call die( smessage=smessage, shints=shints_l )
    endif
 
  endif
 
end subroutine assert_4bit
 
!------------------------------------------------------------------------------------------------
 
end module exceptions