portedportable, not yet portedexecuted, not portableexecutable, not hit by this run
| 1 | ! This file is part of MOM6, the Modular Ocean Model version 6. | |
| 2 | ! See the LICENSE file for licensing information. | |
| 3 | ! SPDX-License-Identifier: Apache-2.0 | |
| 4 | ||
| 5 | !> Routines for error handling and I/O management | |
| 6 | module MOM_error_handler | |
| 7 | ||
| 8 | use MOM_coms_infra, only : num_PEs | |
| 9 | use MOM_error_infra, only : MOM_err, is_root_pe, stdlog, stdout, NOTE, WARNING, FATAL | |
| 10 | use posix, only : getpid, getppid, handler_interface | |
| 11 | use posix, only : signal, kill, SIGUSR1 | |
| 12 | use posix, only : sigjmp_buf, siglongjmp | |
| 13 | use posix, only : sleep | |
| 14 | ||
| 15 | ! MOM_error_infra does not provide stderr . We only use stderr in this module | |
| 16 | ! *IF* FMS has not been initialized. Further, stderr is only used internally and | |
| 17 | ! not made public. Other modules should obtain stderr from MOM_io. | |
| 18 | use iso_fortran_env, only : stderr=>error_unit | |
| 19 | ||
| 20 | implicit none ; private | |
| 21 | ||
| 22 | ! These routines are found in this module. | |
| 23 | public :: MOM_error, MOM_mesg, assert | |
| 24 | public :: MOM_set_verbosity, MOM_get_verbosity, MOM_verbose_enough | |
| 25 | public :: callTree_showQuery, callTree_enter, callTree_leave, callTree_waypoint | |
| 26 | ! These routines are simply passed-through from MOM_error_infra | |
| 27 | public :: is_root_pe, stdlog, stdout | |
| 28 | !> Integer parameters encoding the severity of an error message | |
| 29 | public :: NOTE, WARNING, FATAL | |
| 30 | public :: disable_fatal_errors, enable_fatal_errors, set_skip_mpi | |
| 31 | ||
| 32 | integer :: verbosity = 6 | |
| 33 | !< Verbosity level: | |
| 34 | !! 0 - FATAL messages only | |
| 35 | !! 1 - FATAL + WARNING messages only | |
| 36 | !! 2 - FATAL + WARNING + NOTE messages only [default] | |
| 37 | !! 3 - above + informational | |
| 38 | !! 4 - | |
| 39 | !! 5 - | |
| 40 | !! 6 - above + call tree | |
| 41 | !! 7 - | |
| 42 | !! 8 - | |
| 43 | !! 9 - anything and everything (also set with DEBUG=True) | |
| 44 | ||
| 45 | ! Note that this module default will only hold until the | |
| 46 | ! VERBOSITY parameter is parsed and the given default imposed. | |
| 47 | ! We set it to 6 here so that the call tree will print before | |
| 48 | ! the parser has been initialized | |
| 49 | ! Also note that this is a module variable rather than contained in | |
| 50 | ! a type passed by argument (preferred for most data) for convenience | |
| 51 | ! and to reduce obfuscation of code | |
| 52 | ||
| 53 | integer :: callTreeIndentLevel = 0 | |
| 54 | !< The level of calling within the call tree | |
| 55 | ||
| 56 | ! Error handling | |
| 57 | ||
| 58 | logical :: ignore_fatal = .false. | |
| 59 | !< If true, ignore FATAL errors and jump to a prior state. | |
| 60 | integer, parameter :: err_signal = SIGUSR1 | |
| 61 | !< Signal used to trigger the error handler | |
| 62 | integer :: err_pid | |
| 63 | !< Process ID for the error handler (either self or MPI launcher) | |
| 64 | procedure(handler_interface), pointer :: prior_handler | |
| 65 | !< The default signal handler used before signal() setup (usually SIG_DFT) | |
| 66 | type(sigjmp_buf) :: prior_env | |
| 67 | !< Buffer containing the program state to be recovered by longjmp | |
| 68 | logical :: skip_mpi_dep = .false. | |
| 69 | !< If true, bypass any calls that require FMS (MPI) to have been initialized. | |
| 70 | !! Use s/r set_skip_mpi() to change this flag. By default, set_skip_mpi() does not | |
| 71 | !! need to be called and this flag is false so that FMS (and MPI) should be | |
| 72 | !! initialized. | |
| 73 | ||
| 74 | contains | |
| 75 | ||
| 76 | !> This provides a convenient interface for writing an informative comment, depending | |
| 77 | !! on the model's current verbosity setting and the verbosity level for this message. | |
| 78 | 13 | subroutine MOM_mesg(message, verb, all_print) |
| 79 | character(len=*), intent(in) :: message !< A message to write out | |
| 80 | integer, optional, intent(in) :: verb !< A level of verbosity for this message | |
| 81 | logical, optional, intent(in) :: all_print !< If present and true, any PEs are | |
| 82 | !! able to write this message. | |
| 83 | ! This provides a convenient interface for writing an informative comment. | |
| 84 | integer :: verb_msg | |
| 85 | logical :: write_msg | |
| 86 | ||
| 87 | 13 | if (skip_mpi_dep) then |
| 88 | 0 | write_msg = .true. |
| 89 | else | |
| 90 | 13 | write_msg = is_root_pe() |
| 91 | endif | |
| 92 | 13 | if (present(all_print)) write_msg = write_msg .or. all_print |
| 93 | ||
| 94 | 13 | verb_msg = 2 ; if (present(verb)) verb_msg = verb |
| 95 | 13 | if (write_msg .and. (verbosity >= verb_msg)) call loc_MOM_err(NOTE, message) |
| 96 | ||
| 97 | 13 | end subroutine MOM_mesg |
| 98 | ||
| 99 | !> Enable error handling, replacing FATALs in MOM_error with err_handler. | |
| 100 | 0 | subroutine disable_fatal_errors(env) |
| 101 | type(sigjmp_buf), intent(in) :: env | |
| 102 | !> Process recovery state after FATAL errors | |
| 103 | ||
| 104 | integer :: sig | |
| 105 | ||
| 106 | 0 | ignore_fatal = .true. |
| 107 | ||
| 108 | ! TODO: Only need to call this once; move to an init() function? | |
| 109 | 0 | if (num_PEs() > 1) then |
| 110 | 0 | err_pid = getppid() |
| 111 | else | |
| 112 | 0 | err_pid = getpid() |
| 113 | endif | |
| 114 | ||
| 115 | ! Store the program state | |
| 116 | 0 | prior_env = env |
| 117 | ||
| 118 | ! Setup the signal handler | |
| 119 | ! NOTE: Passing parameters to signal() in GFortran causes a compiler error. | |
| 120 | ! We avert this by copying err_signal to a variable. | |
| 121 | 0 | sig = err_signal |
| 122 | ! TODO: Use sigaction() in place of signal() | |
| 123 | 0 | prior_handler => signal(sig, err_handler) |
| 124 | 0 | end subroutine disable_fatal_errors |
| 125 | ||
| 126 | !> Disable the error handler and abort on FATAL | |
| 127 | 0 | subroutine enable_fatal_errors() |
| 128 | integer :: sig | |
| 129 | procedure(handler_interface), pointer :: dummy | |
| 130 | ||
| 131 | 0 | ignore_fatal = .false. |
| 132 | 0 | err_pid = -1 ! NOTE: 0 might be safer, since it's unusable. |
| 133 | ||
| 134 | ! Restore the original signal handler (usually SIG_DFT). | |
| 135 | 0 | sig = err_signal |
| 136 | ! NOTE: As above, we copy the err_signal to accommodate GFortran. | |
| 137 | 0 | dummy => signal(sig, prior_handler) |
| 138 | 0 | end subroutine enable_fatal_errors |
| 139 | ||
| 140 | !> Enable/disable skipping MPI dependent behaviors | |
| 141 | 0 | subroutine set_skip_mpi(skip) |
| 142 | logical, intent(in) :: skip !< State to assign | |
| 143 | ||
| 144 | 0 | skip_mpi_dep = skip |
| 145 | ||
| 146 | 0 | end subroutine set_skip_mpi |
| 147 | ||
| 148 | !> This provides a convenient interface for writing an error message | |
| 149 | !! with run-time filter based on a verbosity and the severity of the error. | |
| 150 | 2 | subroutine MOM_error(level, message, all_print) |
| 151 | integer, intent(in) :: level !< The severity level of this message | |
| 152 | character(len=*), intent(in) :: message !< A message to write out | |
| 153 | logical, optional, intent(in) :: all_print !< If present and true, any PEs are | |
| 154 | !! able to write this message. | |
| 155 | logical :: write_msg | |
| 156 | integer :: rc | |
| 157 | ||
| 158 | 2 | if (skip_mpi_dep) then |
| 159 | 0 | write_msg = .true. |
| 160 | else | |
| 161 | 2 | write_msg = is_root_pe() |
| 162 | endif | |
| 163 | 2 | if (present(all_print)) write_msg = write_msg .or. all_print |
| 164 | ||
| 165 | 2 | select case (level) |
| 166 | case (NOTE) | |
| 167 | 0 | if (write_msg.and.verbosity>=2) call loc_MOM_err(NOTE, message) |
| 168 | case (WARNING) | |
| 169 | 2 | if (write_msg.and.verbosity>=1) call loc_MOM_err(WARNING, message) |
| 170 | case (FATAL) | |
| 171 | 0 | if (ignore_fatal) then |
| 172 | 0 | print *, "(FATAL): " // message |
| 173 | 0 | rc = kill(err_pid, err_signal) |
| 174 | ! NOTE: MPI launchers require, in their words, "a few seconds" to | |
| 175 | ! propagate the signal to the nodes, so we wait here to avoid | |
| 176 | ! anomalous FATAL calls. | |
| 177 | ! In practice, the signal will take control before sleep() completes. | |
| 178 | 0 | rc = sleep(3) |
| 179 | endif | |
| 180 | 0 | if (verbosity>=0) call loc_MOM_err(FATAL, message) |
| 181 | case default | |
| 182 | 2 | call loc_MOM_err(level, message) |
| 183 | end select | |
| 184 | 2 | end subroutine MOM_error |
| 185 | ||
| 186 | !> A private routine through which all error/warning/note messages are written | |
| 187 | !! by this module. | |
| 188 | 6 | subroutine loc_MOM_err(level, message) |
| 189 | integer, intent(in) :: level !< The severity level of this message | |
| 190 | character(len=*), intent(in) :: message !< A message to write out | |
| 191 | ||
| 192 | 6 | if (.not. skip_mpi_dep) then |
| 193 | 6 | call MOM_err(level, message) |
| 194 | else | |
| 195 | ! FMS (and therefore MPI) have not been initialized | |
| 196 | 0 | write(stdout(),'(a)') trim(message) ! Send message to stdout |
| 197 | 0 | select case (level) |
| 198 | case (WARNING) | |
| 199 | 0 | write(stderr,'("WARNING ",a)') trim(message) ! Additionally send message to stderr |
| 200 | case (FATAL) | |
| 201 | 0 | write(stderr,'("ERROR: ",a)') trim(message) ! Additionally send message to stderr |
| 202 | end select | |
| 203 | endif | |
| 204 | ||
| 205 | 6 | end subroutine loc_MOM_err |
| 206 | ||
| 207 | !> This subroutine sets the level of verbosity filtering MOM error messages | |
| 208 | 1 | subroutine MOM_set_verbosity(verb) |
| 209 | integer, intent(in) :: verb !< A level of verbosity to set | |
| 210 | character(len=80) :: msg | |
| 211 | 1 | if (verb>0 .and. verb<10) then |
| 212 | 1 | verbosity=verb |
| 213 | else | |
| 214 | 0 | write(msg(1:80),'("Attempt to set verbosity outside of range (0-9). verb=",I0)') verb |
| 215 | 0 | call MOM_error(FATAL,msg) |
| 216 | endif | |
| 217 | 1 | end subroutine MOM_set_verbosity |
| 218 | ||
| 219 | !> This subroutine gets the level of verbosity filtering MOM error messages | |
| 220 | 2 | function MOM_get_verbosity() |
| 221 | integer :: MOM_get_verbosity | |
| 222 | 2 | MOM_get_verbosity = verbosity |
| 223 | 2 | end function MOM_get_verbosity |
| 224 | ||
| 225 | !> This tests whether the level of verbosity filtering MOM error messages is | |
| 226 | !! sufficient to write a message of verbosity level verb | |
| 227 | 0 | function MOM_verbose_enough(verb) |
| 228 | integer, intent(in) :: verb !< A level of verbosity to test | |
| 229 | logical :: MOM_verbose_enough | |
| 230 | 0 | MOM_verbose_enough = (verbosity >= verb) |
| 231 | 0 | end function MOM_verbose_enough |
| 232 | ||
| 233 | !> Returns True, if the verbosity>=6 indicating to show the call tree | |
| 234 | 162 | function callTree_showQuery() |
| 235 | ! Local variables | |
| 236 | logical :: callTree_showQuery | |
| 237 | 162 | callTree_showQuery = (verbosity >= 6) |
| 238 | 162 | end function callTree_showQuery |
| 239 | ||
| 240 | !> Writes a message about entering a subroutine if call tree reporting is active | |
| 241 | 78 | subroutine callTree_enter(mesg,n) |
| 242 | character(len=*), intent(in) :: mesg !< Message to write | |
| 243 | integer, optional, intent(in) :: n !< An optional integer to write at end of message | |
| 244 | ! Local variables | |
| 245 | character(len=8) :: nAsString | |
| 246 | 78 | callTreeIndentLevel = callTreeIndentLevel + 1 |
| 247 | 78 | if (verbosity<6) return |
| 248 | 0 | if (is_root_pe()) then |
| 249 | 0 | nAsString = '' |
| 250 | 0 | if (present(n)) then |
| 251 | 0 | write(nAsString(1:8),'(i8)') n |
| 252 | 0 | call loc_MOM_err(NOTE, 'callTree: '// & |
| 253 | 0 | repeat(' ',callTreeIndentLevel-1)//'loop '//trim(mesg)//trim(nAsString)) |
| 254 | else | |
| 255 | 0 | call loc_MOM_err(NOTE, 'callTree: '// & |
| 256 | 0 | repeat(' ',callTreeIndentLevel-1)//'---> '//trim(mesg)) |
| 257 | endif | |
| 258 | endif | |
| 259 | 78 | end subroutine callTree_enter |
| 260 | ||
| 261 | !> Writes a message about leaving a subroutine if call tree reporting is active | |
| 262 | 78 | subroutine callTree_leave(mesg) |
| 263 | character(len=*) :: mesg !< Message to write | |
| 264 | 0 | if (callTreeIndentLevel<1) write(0,*) 'callTree_leave: error callTreeIndentLevel=',callTreeIndentLevel,trim(mesg) |
| 265 | 78 | callTreeIndentLevel = callTreeIndentLevel - 1 |
| 266 | 78 | if (verbosity<6) return |
| 267 | 0 | if (is_root_pe()) call loc_MOM_err(NOTE, 'callTree: '// & |
| 268 | 0 | repeat(' ',callTreeIndentLevel)//'<--- '//trim(mesg)) |
| 269 | 78 | end subroutine callTree_leave |
| 270 | ||
| 271 | !> Writes a message about reaching a milestone if call tree reporting is active | |
| 272 | 20 | subroutine callTree_waypoint(mesg,n) |
| 273 | character(len=*), intent(in) :: mesg !< Message to write | |
| 274 | integer, optional, intent(in) :: n !< An optional integer to write at end of message | |
| 275 | ! Local variables | |
| 276 | character(len=8) :: nAsString | |
| 277 | 0 | if (callTreeIndentLevel<0) write(0,*) 'callTree_waypoint: error callTreeIndentLevel=',callTreeIndentLevel,trim(mesg) |
| 278 | 20 | if (verbosity<6) return |
| 279 | 1 | if (is_root_pe()) then |
| 280 | 1 | nAsString = '' |
| 281 | 1 | if (present(n)) then |
| 282 | 0 | write(nAsString(1:8),'(i8)') n |
| 283 | 0 | call loc_MOM_err(NOTE, 'callTree: '// & |
| 284 | 0 | repeat(' ',callTreeIndentLevel)//'loop '//trim(mesg)//trim(nAsString)) |
| 285 | else | |
| 286 | 0 | call loc_MOM_err(NOTE, 'callTree: '// & |
| 287 | 1 | repeat(' ',callTreeIndentLevel)//'o '//trim(mesg)) |
| 288 | endif | |
| 289 | endif | |
| 290 | 20 | end subroutine callTree_waypoint |
| 291 | ||
| 292 | !> Issues a FATAL error if the assertion fails, i.e. the first argument is false. | |
| 293 | 629 | subroutine assert(logical_arg, msg) |
| 294 | logical, intent(in) :: logical_arg !< If false causes a FATAL error | |
| 295 | character(len=*), intent(in) :: msg !< Message to issue in case of failed assertion | |
| 296 | ||
| 297 | 629 | if (.not. logical_arg) then |
| 298 | 0 | call MOM_error(FATAL, msg) |
| 299 | endif | |
| 300 | 629 | end subroutine assert |
| 301 | ||
| 302 | !> Restore the process state via longjmp after receiving a signal. | |
| 303 | 0 | subroutine err_handler(sig) |
| 304 | integer, intent(in) :: sig | |
| 305 | !< Signal passed to the handler (unused) | |
| 306 | 0 | call siglongjmp(prior_env, 1) |
| 307 | 0 | end subroutine |
| 308 | ||
| 309 | end module MOM_error_handler |