From bb7ada715df396638b08113248c4675a8f5e15ad Mon Sep 17 00:00:00 2001 From: Sean Bryan Date: Thu, 26 Feb 2026 14:40:56 +1100 Subject: [PATCH 1/3] Add new error handling capability --- CMakeLists.txt | 3 + src/offline/cable_mpi.F90 | 5 +- src/offline/cable_offline_driver.F90 | 7 +++ .../error_handler/cable_error_handler.F90 | 63 +++++++++++++++++++ .../cable_error_handler_base.F90 | 55 ++++++++++++++++ .../error_handler/cable_error_handler_mpi.F90 | 48 ++++++++++++++ 6 files changed, 179 insertions(+), 2 deletions(-) create mode 100644 src/util/error_handler/cable_error_handler.F90 create mode 100644 src/util/error_handler/cable_error_handler_base.F90 create mode 100644 src/util/error_handler/cable_error_handler_mpi.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 354051dd0..81d365496 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -241,6 +241,9 @@ else() src/params/cable_photo_constants_mod.F90 src/params/cable_other_constants_mod.F90 src/params/cable_maths_constants_mod.F90 + src/util/error_handler/cable_error_handler_base.F90 + src/util/error_handler/cable_error_handler_mpi.F90 + src/util/error_handler/cable_error_handler.F90 src/util/cable_runtime_opts_mod.F90 src/util/cable_common.F90 src/shared/casa_offline_inout.F90 diff --git a/src/offline/cable_mpi.F90 b/src/offline/cable_mpi.F90 index 034ecbb41..fcf431bc1 100644 --- a/src/offline/cable_mpi.F90 +++ b/src/offline/cable_mpi.F90 @@ -120,16 +120,17 @@ FUNCTION mpi_grp_constructor(comm) RESULT(mpi_grp) END FUNCTION mpi_grp_constructor - SUBROUTINE mpi_grp_abort(this) + SUBROUTINE mpi_grp_abort(this, error_code) !* Class method to abort execution of an MPI group. CLASS(mpi_grp_t), INTENT(IN) :: this + INTEGER, INTENT(IN) :: error_code INTEGER :: ierr IF (this%comm /= MPI_COMM_UNDEFINED) THEN ! Here we use an arbitrary error code #ifdef __MPI__ - call MPI_Abort(this%comm, 999, ierr) + call MPI_Abort(this%comm, error_code, ierr) #endif call mpi_check_error(ierr) END IF diff --git a/src/offline/cable_offline_driver.F90 b/src/offline/cable_offline_driver.F90 index d63e4fe13..e5398b730 100644 --- a/src/offline/cable_offline_driver.F90 +++ b/src/offline/cable_offline_driver.F90 @@ -4,6 +4,9 @@ PROGRAM cable_offline_driver USE iso_fortran_env, ONLY : error_unit USE cable_mpi_mod, ONLY : mpi_grp_t, mpi_mod_init, mpi_mod_end + USE cable_error_handler_mod, ONLY : cable_error_handler_set + USE cable_error_handler_mod, ONLY : cable_error_handler_free + USE cable_error_handler_mpi_mod, ONLY : cable_error_handler_mpi_t USE cable_driver_common_mod, ONLY: & cable_driver_init, & cable_driver_init_gswp, & @@ -35,6 +38,8 @@ PROGRAM cable_offline_driver call mpi_mod_init() mpi_grp = mpi_grp_t() + CALL cable_error_handler_set(cable_error_handler_mpi_t(mpi_grp)) + CALL cable_driver_init(mpi_grp, NRRRR) SELECT CASE(TRIM(cable_user%MetType)) @@ -68,6 +73,8 @@ PROGRAM cable_offline_driver END IF END IF + CALL cable_error_handler_free() + CALL mpi_mod_end() CALL CPU_TIME(etime) diff --git a/src/util/error_handler/cable_error_handler.F90 b/src/util/error_handler/cable_error_handler.F90 new file mode 100644 index 000000000..5c2f08275 --- /dev/null +++ b/src/util/error_handler/cable_error_handler.F90 @@ -0,0 +1,63 @@ +! CSIRO Open Source Software License Agreement (variation of the BSD / MIT License) +! Copyright (c) 2015, Commonwealth Scientific and Industrial Research Organisation +! (CSIRO) ABN 41 687 119 230. + +module cable_error_handler_mod + !* This module provides error handling functionality that can be used + ! throughout the CABLE codebase. + ! + ! Error handling behaviour is controlled internally by either the global error + ! handler instance (`error_handler_global`) or the fallback error handler + ! instance (`error_handler_fallback`). The global error handler instance can be + ! set via `cable_error_handler_set` to provide custom error handling behaviour, + ! while the fallback error handler instance provides a default implementation of + ! the error handling behaviour. The global error handler is polymorphic which + ! allows for customising the error handling behaviour dynamically at runtime. To + ! do this we can create a new type that extends `cable_error_handler_base_t` with + ! the new error handling behaviour and set the global error handler to an + ! instance of the extended type. + + use cable_error_handler_base_mod, only: cable_error_handler_base_t + + implicit none + private + + public :: cable_error_handler_base_t + public :: cable_error_handler_set + public :: cable_error_handler_free + public :: cable_abort + + type(cable_error_handler_base_t), target :: error_handler_fallback = cable_error_handler_base_t() + + class(cable_error_handler_base_t), allocatable, target :: error_handler_global + +contains + + subroutine cable_error_handler_set(new_error_handler) + !! Set the global error handler instance. + class(cable_error_handler_base_t), intent(in) :: new_error_handler + !! New error handler instance to set as the global error handler. + error_handler_global = new_error_handler + end subroutine + + subroutine cable_error_handler_free() + !! Free the global error handler instance. + if (allocated(error_handler_global)) deallocate(error_handler_global) + end subroutine + + subroutine cable_abort(message, file, line, error_code) + !! Abort CABLE with an error message. + character(len=*), intent(in) :: message !! Error message to display + character(len=*), intent(in) :: file !! Source file where the error occurred + integer, intent(in) :: line !! Line number where the error occurred + integer, intent(in), optional :: error_code !! Optional error code + class(cable_error_handler_base_t), pointer :: error_handler + + error_handler => error_handler_fallback + if (allocated(error_handler_global)) error_handler => error_handler_global + + call error_handler%abort(message, file, line, error_code) + + end subroutine + +end module diff --git a/src/util/error_handler/cable_error_handler_base.F90 b/src/util/error_handler/cable_error_handler_base.F90 new file mode 100644 index 000000000..48f850072 --- /dev/null +++ b/src/util/error_handler/cable_error_handler_base.F90 @@ -0,0 +1,55 @@ +! CSIRO Open Source Software License Agreement (variation of the BSD / MIT License) +! Copyright (c) 2015, Commonwealth Scientific and Industrial Research Organisation +! (CSIRO) ABN 41 687 119 230. + +module cable_error_handler_base_mod + !* This module defines the base error handler type for CABLE. + ! It provides a default implementation of the error handling behaviour, which + ! can be extended to provide custom error handling. + use iso_fortran_env, only: error_unit + implicit none + private + + public :: cable_error_handler_base_t + + integer, parameter, public :: DEFAULT_ERROR_CODE = 999 !! Default error code to use when none is provided + + type cable_error_handler_base_t + !* Base error handler type for CABLE. + ! This type provides a default implementation of the error handling behaviour. + contains + procedure :: build_error_message => cable_error_handler_base_build_error_message + procedure :: abort => cable_error_handler_base_abort + end type cable_error_handler_base_t + +contains + + function cable_error_handler_base_build_error_message(this, message, file, line, error_code) result(error_message) + !! Build an error message string. + class(cable_error_handler_base_t), intent(inout) :: this + character(len=*), intent(in) :: message !! Error message to display + character(len=*), intent(in) :: file !! Source file where the error occurred + integer, intent(in) :: line !! Line number where the error occurred + integer, intent(in), optional :: error_code !! Optional error code + character(len=:), allocatable :: error_message + character(5) :: line_string + + write (line_string, "(I5)") line + error_message = "Error: " // file // ":" // "L" // trim(adjustl(line_string)) // ": " // message + + end function cable_error_handler_base_build_error_message + + subroutine cable_error_handler_base_abort(this, message, file, line, error_code) + !! Default implementation of the abort procedure for the base error handler. + class(cable_error_handler_base_t), intent(inout) :: this + character(len=*), intent(in) :: message !! Error message to display + character(len=*), intent(in) :: file !! Source file where the error occurred + integer, intent(in) :: line !! Line number where the error occurred + integer, intent(in), optional :: error_code !! Optional error code + + write(unit=error_unit, fmt="(A)") this%build_error_message(message, file, line, DEFAULT_ERROR_CODE) + error stop DEFAULT_ERROR_CODE + + end subroutine + +end module diff --git a/src/util/error_handler/cable_error_handler_mpi.F90 b/src/util/error_handler/cable_error_handler_mpi.F90 new file mode 100644 index 000000000..f00c5cdb1 --- /dev/null +++ b/src/util/error_handler/cable_error_handler_mpi.F90 @@ -0,0 +1,48 @@ +! CSIRO Open Source Software License Agreement (variation of the BSD / MIT License) +! Copyright (c) 2015, Commonwealth Scientific and Industrial Research Organisation +! (CSIRO) ABN 41 687 119 230. + +module cable_error_handler_mpi_mod + !* This module defines an MPI-aware error handler for CABLE. + ! It extends the base error handler to provide functionality for aborting an MPI program. + use iso_fortran_env, only: error_unit + use cable_error_handler_base_mod, only: cable_error_handler_base_t + use cable_error_handler_base_mod, only: DEFAULT_ERROR_CODE + use cable_mpi_mod, only: mpi_grp_t + implicit none + private + + public :: cable_error_handler_mpi_t + + type, extends(cable_error_handler_base_t) :: cable_error_handler_mpi_t + !* MPI-aware error handler type for CABLE. + ! This type extends the base error handler to provide functionality for aborting an MPI program. + type(mpi_grp_t) :: mpi_grp + contains + procedure :: abort => cable_error_handler_mpi_abort + end type cable_error_handler_mpi_t + +contains + + subroutine cable_error_handler_mpi_abort(this, message, file, line, error_code) + !! Implementation of the abort procedure for the MPI-aware error handler. + class(cable_error_handler_mpi_t), intent(inout) :: this + character(len=*), intent(in) :: message !! Error message to display + character(len=*), intent(in) :: file !! Source file where the error occurred + integer, intent(in) :: line !! Line number where the error occurred + integer, intent(in), optional :: error_code !! Optional error code + + integer :: err_code + + if (present(error_code)) then + err_code = error_code + else + err_code = DEFAULT_ERROR_CODE + end if + + write(unit=error_unit, fmt="(A)") this%build_error_message(message, file, line, err_code) + call this%mpi_grp%abort(err_code) + + end subroutine + +end module From 28fd8a3a4f8ee25ff88b35a46d5340b44a7ceb59 Mon Sep 17 00:00:00 2001 From: Sean Bryan Date: Mon, 2 Mar 2026 19:27:22 +1100 Subject: [PATCH 2/3] src/offline/cable_mpi.F90: STOP when MPI is unavailable --- src/offline/cable_mpi.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/offline/cable_mpi.F90 b/src/offline/cable_mpi.F90 index fcf431bc1..f22afbcdc 100644 --- a/src/offline/cable_mpi.F90 +++ b/src/offline/cable_mpi.F90 @@ -127,13 +127,15 @@ SUBROUTINE mpi_grp_abort(this, error_code) INTEGER :: ierr - IF (this%comm /= MPI_COMM_UNDEFINED) THEN - ! Here we use an arbitrary error code #ifdef __MPI__ + IF (this%comm /= MPI_COMM_UNDEFINED) THEN call MPI_Abort(this%comm, error_code, ierr) -#endif call mpi_check_error(ierr) END IF +#else + ! Here we use an arbitrary error code + STOP 999 +#endif END SUBROUTINE mpi_grp_abort From 3b5d395614f6e5a396cd2e7e498ebd55b90e2159 Mon Sep 17 00:00:00 2001 From: Sean Bryan Date: Mon, 2 Mar 2026 19:09:00 +1100 Subject: [PATCH 3/3] src/offline/cable_mpi.F90: Replace fatal error handling with cable_abort --- src/offline/cable_mpi.F90 | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/offline/cable_mpi.F90 b/src/offline/cable_mpi.F90 index f22afbcdc..517a4b83f 100644 --- a/src/offline/cable_mpi.F90 +++ b/src/offline/cable_mpi.F90 @@ -4,6 +4,7 @@ MODULE cable_mpi_mod !! Module for handling some common MPI operations and MPI groups + USE cable_error_handler_mod, ONLY: cable_abort #ifdef __MPI__ USE mpi_f08 #else @@ -110,8 +111,7 @@ FUNCTION mpi_grp_constructor(comm) RESULT(mpi_grp) call MPI_Comm_size(mpi_grp%comm, mpi_grp%size, ierr) call mpi_check_error(ierr) #else - WRITE(error_unit,*) "Error initialising mpi group: CABLE was compiled without MPI support." - STOP + call cable_abort("Error initialising mpi group: CABLE was compiled without MPI support.", file=__FILE__, line=__LINE__) #endif ELSE mpi_grp%rank = 0 @@ -150,8 +150,7 @@ SUBROUTINE mpi_check_error(ierr) IF (ierr /= MPI_SUCCESS ) THEN CALL MPI_Error_String(ierr, msg, length, tmp) - WRITE(error_unit,*) msg(1:length) - CALL MPI_Abort(MPI_COMM_WORLD, 1 , tmp) + CALL cable_abort(msg(1:length), file=__FILE__, line=__LINE__) END if #endif