diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index d652ce22c6..c837f642ed 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -86,7 +86,7 @@ MODULE diag_util_mod & prepend_attribute, attribute_init, diag_util_init,& & fms_diag_check_out_of_bounds, & & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static,& - & get_time_string, real_copy_set, check_indices_order + & get_time_string, init_mask_3d, real_copy_set, check_indices_order !> @brief Prepend a value to a string attribute in the output field or output file. @@ -2499,6 +2499,58 @@ SUBROUTINE prepend_attribute_file(out_file, att_name, prepend_value, err_msg) END IF END SUBROUTINE prepend_attribute_file + !> @brief Allocates outmask(second argument) with sizes of the first three dimensions of field(first argument). + !! Initializes the outmask depending on presence/absence of inmask and rmask. + !! Uses and sets rmask_threshold. + subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg) + class(*), intent(in) :: field(:,:,:,:) !< Dummy variable whose sizes only in the first three dimensions are important + logical, allocatable, intent(inout) :: outmask(:,:,:) !< Output logical mask + real, intent(inout) :: rmask_threshold !< Holds the values 0.5_r4_kind or 0.5_r8_kind, or related threhold values + !! needed to be passed to the math/buffer update functions. + logical, intent(in), optional :: inmask(:,:,:) !< Input logical mask + class(*), intent(in), optional :: rmask(:,:,:) !< Floating point input mask value + character(len=*), intent(out), optional :: err_msg !< Error message to relay back to caller + + character(len=256) :: err_msg_local !< Stores locally generated error message + integer :: status !< Stores status of memory allocation call + + ! Initialize character strings + err_msg_local = '' + if (present(err_msg)) err_msg = '' + + ! Check if outmask is allocated + if (allocated(outmask)) deallocate(outmask) + ALLOCATE(outmask(SIZE(field, 1), SIZE(field, 2), SIZE(field, 3)), STAT=status) + IF ( status .NE. 0 ) THEN + WRITE (err_msg_local, FMT='("Unable to allocate outmask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')& + & SIZE(field, 1), SIZE(field, 2), SIZE(field, 3), status + if (fms_error_handler('diag_util_mod:init_mask_3d', trim(err_msg_local), err_msg)) then + return + end if + END IF + + IF ( PRESENT(inmask) ) THEN + outmask = inmask + ELSE + outmask = .TRUE. + END IF + + IF ( PRESENT(rmask) ) THEN + SELECT TYPE (rmask) + TYPE IS (real(kind=r4_kind)) + WHERE (rmask < real(rmask_threshold, kind=r4_kind)) outmask = .FALSE. + rmask_threshold = real(rmask_threshold, kind=r4_kind) + TYPE IS (real(kind=r8_kind)) + WHERE ( rmask < real(rmask_threshold, kind=r8_kind) ) outmask = .FALSE. + rmask_threshold = real(rmask_threshold, kind=r8_kind) + CLASS DEFAULT + if (fms_error_handler('diag_util_mod:init_mask_3d',& + & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) then + end if + END SELECT + END IF + end subroutine init_mask_3d + !> @brief Copies input data to output data with proper type if the input data is present !! else sets the output data to a given value val if it is present. !! If the value val and the input data are not present, the output data is untouched.