From fcffe4babe7c5d82e6ccbbcc17e40df4567d87e1 Mon Sep 17 00:00:00 2001
From: Jerome Jackson <jerome@neuroplug.net>
Date: Wed, 26 Jun 2024 12:06:19 +0100
Subject: [PATCH] Deallocate error in prterr subroutine.

Previously error was intent(in), error remained allocated after prterr
returns and may trigger 'untrapped error' if W90DEV defined (see
io.F90).

Deallocating the error without triggering the 'untrapped error' case
is done by setting the error code to a special value (neutralising the
error).

prterr() now has error variable to intent(inout) and is deallocated.
---
 src/error_base.F90 | 2 ++
 src/io.F90         | 7 +++++--
 2 files changed, 7 insertions(+), 2 deletions(-)

diff --git a/src/error_base.F90 b/src/error_base.F90
index 9229a602..b0348bac 100644
--- a/src/error_base.F90
+++ b/src/error_base.F90
@@ -30,12 +30,14 @@ module w90_error_base
   end type w90_error_type
 
   integer, parameter :: code_remote = -99 ! special code for error triggered by other mpi rank
+  integer, parameter :: code_deactivated = -888 ! special code for error triggered by other mpi rank
 
 contains
 
   subroutine untrapped_error(err)
     type(w90_error_type), intent(in) :: err
     ! this routine should never be called, so write to stderr and call "stop" in desparation
+    if (err%code == code_deactivated) return
     write (0, *) "UNTRAPPED ERROR: ", err%code
     write (0, *) "UNTRAPPED ERROR: ", err%message
     stop
diff --git a/src/io.F90 b/src/io.F90
index 58fb6e92..12a271f2 100644
--- a/src/io.F90
+++ b/src/io.F90
@@ -394,13 +394,13 @@ end function io_wallclocktime
 
   subroutine prterr(error, ie, istdout, istderr, comm)
     use w90_comms, only: comms_no_sync_send, comms_no_sync_recv, w90_comm_type, mpirank, mpisize
-    use w90_error_base, only: code_remote, w90_error_type
+    use w90_error_base, only: code_deactivated, code_remote, w90_error_type
 
     ! arguments
     integer, intent(inout) :: ie ! global error value to be returned
     integer, intent(in) :: istderr, istdout
     type(w90_comm_type), intent(in) :: comm
-    type(w90_error_type), allocatable, intent(in) :: error
+    type(w90_error_type), allocatable, intent(inout) :: error
 
     ! local variables
     type(w90_error_type), allocatable :: le ! unchecked error state for calls made in this routine
@@ -449,6 +449,9 @@ subroutine prterr(error, ie, istdout, istderr, comm)
     endif
     call flush(istdout)
     call flush(istderr)
+
+    error%code = code_deactivated
+    deallocate (error) ! else allocated error trips uncaught error mechanism (ifdef W90DEV, see io.F90)
   end subroutine prterr
 
 end module w90_io