Update icepack_warnings to make it more thread safe

E3SM-Project · Jun 20, 2024 · 31ce422 · 31ce422
1 parent b3aa664
commit 31ce422
Showing 1 changed file with 24 additions and 10 deletions.
diff --git a/columnphysics/icepack_warnings.F90 b/columnphysics/icepack_warnings.F90
@@ -1,16 +1,28 @@
 
 module icepack_warnings
 
-      use icepack_kinds
+! Provides a logging and abort package for Icepack.
+! Icepack has no idea about MPI, OpenMP, or IO.
+! Store error message and provide methods for the driver
+! to write these messages to a Fortran unit number.
+! Needs to be thread safe.  This could be called within
+! a threaded or non-threaded region or both.  Need to make
+! sure multiple threads are not adding to the warnings
+! buffer at the same time.  Also need to make sure warnings
+! buffers are not added at the same time messages are
+! cleared by a different thread.  Use multiple critical
+! regions using the same ID to allow threads to block
+! each other during multiple operations.
 
+      use icepack_kinds
       implicit none
 
       private
 
       ! warning messages
       character(len=char_len_long), dimension(:), allocatable :: warnings
       integer :: nWarnings = 0
-      integer, parameter :: nWarningsBuffer = 10 ! incremental number of messages
+      integer :: nWarningsBuffer = 10 ! incremental number of messages
 
       ! abort flag, accessed via icepack_warnings_setabort and icepack_warnings_aborted
       logical :: warning_abort = .false.
@@ -30,6 +42,10 @@ module icepack_warnings
       private :: &
         icepack_warnings_getone
 
+! variables are shared by default
+! have warnstr be private
+!$OMP THREADPRIVATE(warnstr)
+
 !=======================================================================
 
 contains
@@ -133,14 +149,9 @@ subroutine icepack_warnings_print(iounit)
         integer :: iWarning
         character(len=*),parameter :: subname='(icepack_warnings_print)'
 
-! tcraig
-! this code intermittenly aborts on recursive IO errors with intel
-! not sure if it's OMP or something else causing this
-!$OMP MASTER
         do iWarning = 1, nWarnings
           write(iounit,*) trim(icepack_warnings_getone(iWarning))
         enddo
-!$OMP END MASTER
 
       end subroutine icepack_warnings_print
 
@@ -156,10 +167,12 @@ subroutine icepack_warnings_flush(iounit)
 
         character(len=*),parameter :: subname='(icepack_warnings_flush)'
 
+!$OMP CRITICAL (omp_warnings)
         if (nWarnings > 0) then
           call icepack_warnings_print(iounit)
         endif
         call icepack_warnings_clear()
+!$OMP END CRITICAL (omp_warnings)
 
       end subroutine icepack_warnings_flush
 
@@ -177,7 +190,7 @@ subroutine icepack_warnings_add(warning)
              iWarning ! warning index
         character(len=*),parameter :: subname='(icepack_warnings_add)'
 
-!$OMP CRITICAL (omp_warnings_add)
+!$OMP CRITICAL (omp_warnings)
         ! check if warnings array is not allocated
         if (.not. allocated(warnings)) then
 
@@ -187,7 +200,6 @@ subroutine icepack_warnings_add(warning)
            ! set initial number of nWarnings
            nWarnings = 0
 
-        ! already allocated
         else
 
            ! find the size of the warnings array at the start
@@ -216,16 +228,18 @@ subroutine icepack_warnings_add(warning)
               ! deallocate the temporary storage
               deallocate(warningsTmp)
 
+              ! increase nWarningsBuffer for next reallocation
+              nWarningsBuffer = nWarningsBuffer * 2
            endif
 
         endif
 
         ! increase warning number
         nWarnings = nWarnings + 1
-!$OMP END CRITICAL (omp_warnings_add)
 
         ! add the new warning
         warnings(nWarnings) = trim(warning)
+!$OMP END CRITICAL (omp_warnings)
 
       end subroutine icepack_warnings_add