1module m_common_error 2 3#ifndef DUMMYLIB 4 use fox_m_fsys_abort_flush, only: pxfabort, pxfflush 5 use fox_m_fsys_array_str, only: vs_str_alloc 6 7 implicit none 8 private 9 10 integer, parameter :: ERR_NULL = 0 11 integer, parameter :: ERR_WARNING = 1 12 integer, parameter :: ERR_ERROR = 2 13 integer, parameter :: ERR_FATAL = 3 14#endif 15 logical, save :: errors_are_fatal = .false. 16 logical, save :: warnings_are_fatal = .false. 17 18#ifndef DUMMYLIB 19 type error_t 20 integer :: severity = ERR_NULL 21 integer :: error_code = 0 22 character, dimension(:), pointer :: msg => null() 23 end type error_t 24 25 type error_stack 26 type(error_t), dimension(:), pointer :: stack => null() 27 end type error_stack 28 29 interface FoX_warning 30 module procedure FoX_warning_base 31 end interface 32 33 interface FoX_error 34 module procedure FoX_error_base 35 end interface 36 37 interface FoX_fatal 38 module procedure FoX_fatal_base 39 end interface 40 41 public :: ERR_NULL 42 public :: ERR_WARNING 43 public :: ERR_ERROR 44 public :: ERR_FATAL 45 46 public :: error_t 47 public :: error_stack 48 49 public :: init_error_stack 50 public :: destroy_error_stack 51 52 public :: FoX_warning 53 public :: FoX_error 54 public :: FoX_fatal 55 56 public :: FoX_warning_base 57 public :: FoX_error_base 58 public :: FoX_fatal_base 59 60 public :: add_error 61 public :: in_error 62 63#endif 64 public :: FoX_set_fatal_errors 65 public :: FoX_get_fatal_errors 66 public :: FoX_set_fatal_warnings 67 public :: FoX_get_fatal_warnings 68 69contains 70#ifndef DUMMYLIB 71 72 subroutine FoX_warning_base(msg) 73 ! Emit warning, but carry on. 74 character(len=*), intent(in) :: msg 75 76 if (warnings_are_fatal) then 77 write(0,'(a)') 'FoX warning made fatal' 78 call FoX_fatal_base(msg) 79 endif 80 81 write(0,'(a)') 'WARNING(FoX)' 82 write(0,'(a)') msg 83 call pxfflush(0) 84 85 end subroutine FoX_warning_base 86 87 88 subroutine FoX_error_base(msg) 89 ! Emit error message and stop. 90 ! No clean up is done here, but this can 91 ! be overridden to include clean-up routines 92 character(len=*), intent(in) :: msg 93 94 if (errors_are_fatal) then 95 write(0,'(a)') 'FoX error made fatal' 96 call FoX_fatal_base(msg) 97 endif 98 99 write(0,'(a)') 'ERROR(FoX)' 100 write(0,'(a)') msg 101 call pxfflush(0) 102 103 stop 104 105 end subroutine FoX_error_base 106 107 subroutine FoX_fatal_base(msg) 108 !Emit error message and abort with coredump. 109 !No clean-up occurs 110 111 character(len=*), intent(in) :: msg 112 113 write(0,'(a)') 'ABORT(FOX)' 114 write(0,'(a)') msg 115 call pxfflush(0) 116 117 call pxfabort() 118 119 end subroutine FoX_fatal_base 120 121 122 subroutine init_error_stack(stack) 123 type(error_stack), intent(inout) :: stack 124 125 allocate(stack%stack(0)) 126 end subroutine init_error_stack 127 128 129 subroutine destroy_error_stack(stack) 130 type(error_stack), intent(inout) :: stack 131 132 integer :: i 133 134 do i = 1, size(stack%stack) 135 deallocate(stack%stack(i)%msg) 136 enddo 137 deallocate(stack%stack) 138 end subroutine destroy_error_stack 139 140 141 subroutine add_error(stack, msg, severity, error_code) 142 type(error_stack), intent(inout) :: stack 143 character(len=*), intent(in) :: msg 144 integer, intent(in), optional :: severity 145 integer, intent(in), optional :: error_code 146 147 integer :: i, n 148 type(error_t), dimension(:), pointer :: temp_stack 149 150 if (.not.associated(stack%stack)) & 151 call init_error_stack(stack) 152 153 n = size(stack%stack) 154 155 temp_stack => stack%stack 156 allocate(stack%stack(n+1)) 157 do i = 1, size(temp_stack) 158 stack%stack(i)%msg => temp_stack(i)%msg 159 stack%stack(i)%severity = temp_stack(i)%severity 160 stack%stack(i)%error_code = temp_stack(i)%error_code 161 enddo 162 deallocate(temp_stack) 163 164 stack%stack(n+1)%msg => vs_str_alloc(msg) 165 if (present(severity)) then 166 stack%stack(n+1)%severity = severity 167 else 168 stack%stack(n+1)%severity = ERR_ERROR 169 endif 170 if (present(error_code)) then 171 stack%stack(n+1)%error_code = error_code 172 else 173 stack%stack(n+1)%error_code = -1 174 endif 175 176 end subroutine add_error 177 178 179 function in_error(stack) result(p) 180 type(error_stack), intent(in) :: stack 181 logical :: p 182 183 if (associated(stack%stack)) then 184 p = (size(stack%stack) > 0) 185 else 186 p = .false. 187 endif 188 end function in_error 189 190#endif 191 subroutine FoX_set_fatal_errors(newvalue) 192 logical, intent(in) :: newvalue 193 errors_are_fatal = newvalue 194 end subroutine FoX_set_fatal_errors 195 196 function FoX_get_fatal_errors() 197 logical :: FoX_get_fatal_errors 198 FoX_get_fatal_errors = errors_are_fatal 199 end function FoX_get_fatal_errors 200 201 subroutine FoX_set_fatal_warnings(newvalue) 202 logical, intent(in) :: newvalue 203 warnings_are_fatal = newvalue 204 end subroutine FoX_set_fatal_warnings 205 206 function FoX_get_fatal_warnings() 207 logical :: FoX_get_fatal_warnings 208 FoX_get_fatal_warnings = warnings_are_fatal 209 end function FoX_get_fatal_warnings 210 211end module m_common_error 212