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