diff --git a/CMakeLists.txt b/CMakeLists.txt index a0eba12a0b..f5aa2b4a2d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -140,6 +140,7 @@ list(APPEND fms_fortran_src_files diag_manager/fms_diag_object_container.F90 diag_manager/fms_diag_buffer.F90 diag_manager/fms_diag_output_buffer.F90 + diag_manager/fms_diag_input_buffer.F90 diag_manager/fms_diag_time_reduction.F90 diag_manager/fms_diag_outfield.F90 diag_manager/fms_diag_elem_weight_procs.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 3e15f9b24a..e429531937 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -54,6 +54,7 @@ libdiag_manager_la_SOURCES = \ fms_diag_object_container.F90 \ fms_diag_dlinked_list.F90 \ fms_diag_output_buffer.F90 \ + fms_diag_input_buffer.F90 \ fms_diag_time_reduction.F90 \ fms_diag_outfield.F90 \ fms_diag_elem_weight_procs.F90 \ @@ -79,9 +80,11 @@ fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_objec fms_diag_time_utils_mod.$(FC_MODEXT) \ fms_diag_output_buffer_mod.$(FC_MODEXT) \ fms_diag_reduction_methods_mod.$(FC_MODEXT) \ - fms_diag_bbox_mod.$(FC_MODEXT) + fms_diag_bbox_mod.$(FC_MODEXT) \ + fms_diag_input_buffer_mod.$(FC_MODEXT) +fms_diag_input_buffer_mod.$(FC_MODEXT): fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \ - fms_diag_axis_object_mod.$(FC_MODEXT) + fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_input_buffer_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \ fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT) fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) @@ -133,6 +136,7 @@ MODFILES = \ fms_diag_dlinked_list_mod.$(FC_MODEXT) \ fms_diag_object_container_mod.$(FC_MODEXT) \ fms_diag_output_buffer_mod.$(FC_MODEXT) \ + fms_diag_input_buffer_mod.$(FC_MODEXT) \ diag_manager_mod.$(FC_MODEXT) \ fms_diag_time_reduction_mod.$(FC_MODEXT) \ fms_diag_outfield_mod.$(FC_MODEXT) \ diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index fb05d2b998..81c0a33d51 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -353,6 +353,10 @@ SUBROUTINE reset_bounds_from_array_4D(this, array) this%jmax = UBOUND(array,2) this%kmin = LBOUND(array,3) this%kmax = UBOUND(array,3) + + this%has_halos = .false. + this%nhalo_I = 0 + this%nhalo_J = 0 END SUBROUTINE reset_bounds_from_array_4D !> @brief Reset the instance bounding box with the bounds determined from the diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 index 08292df80f..58b830d36c 100644 --- a/diag_manager/fms_diag_field_object.F90 +++ b/diag_manager/fms_diag_field_object.F90 @@ -23,6 +23,7 @@ module fms_diag_field_object_mod use time_manager_mod, ONLY: time_type use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, register_field, & register_variable_attribute +use fms_diag_input_buffer_mod, only: fmsDiagInputBuffer_t !!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& !!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & !!! & get_ticks_per_second @@ -70,7 +71,8 @@ module fms_diag_field_object_mod integer, allocatable, private :: area, volume !< The Area and Volume class(*), allocatable, private :: missing_value !< The missing fill value class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data - class(*), allocatable, dimension(:,:,:,:), private :: data_buffer !< Buffer for field data + type(fmsDiagInputBuffer_t), allocatable :: input_data_buffer !< Input buffer object for when buffering + !! data logical, allocatable, private :: data_buffer_is_allocated !< True if the buffer has !! been allocated logical, allocatable, private :: math_needs_to_be_done !< If true, do math @@ -124,7 +126,7 @@ module fms_diag_field_object_mod procedure :: has_volume procedure :: has_missing_value procedure :: has_data_RANGE - procedure :: has_data_buffer + procedure :: has_input_data_buffer ! Get functions procedure :: get_attributes procedure :: get_static @@ -147,6 +149,8 @@ module fms_diag_field_object_mod procedure :: get_data_RANGE procedure :: get_axis_id procedure :: get_data_buffer + procedure :: get_mask + procedure :: get_weight procedure :: dump_field_obj procedure :: get_domain procedure :: get_type_of_domain @@ -388,42 +392,23 @@ subroutine set_vartype(objin , var) end subroutine set_vartype !> @brief Adds the input data to the buffered data. -subroutine set_data_buffer (this, input_data, is, js, ks, ie, je, ke) - class (fmsDiagField_type) , intent(inout):: this !< The field object - class(*), dimension(:,:,:,:), intent(in) :: input_data !< The input array - integer :: is, js, ks !< Starting indicies of the field_data relative to the global domain - integer :: ie, je, ke !< Ending indicies of the field_data relative to the global domain - +subroutine set_data_buffer (this, input_data, mask, weight, is, js, ks, ie, je, ke) + class (fmsDiagField_type) , intent(inout):: this !< The field object + class(*), intent(in) :: input_data(:,:,:,:) !< The input array + logical, intent(in) :: mask(:,:,:,:) !< The field mask + real(kind=r8_kind), intent(in) :: weight !< The field weight + integer, intent(in) :: is, js, ks !< Starting indicies of the field_data relative + !! to the compute domain (1 based) + integer, intent(in) :: ie, je, ke !< Ending indicies of the field_data relative + !! to the compute domain (1 based) + + character(len=128) :: err_msg !< Error msg if (.not.this%data_buffer_is_allocated) & call mpp_error ("set_data_buffer", "The data buffer for the field "//trim(this%varname)//" was unable to be "//& "allocated.", FATAL) + err_msg = this%input_data_buffer%set_input_buffer_object(input_data, weight, mask, is, js, ks, ie, je, ke) + if (trim(err_msg) .ne. "") call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg)) -!> Buffer a copy of the data - select type (input_data) - type is (real(kind=r4_kind)) - select type (db => this%data_buffer) - type is (real(kind=r4_kind)) - db(is:ie, js:je, ks:ke, :) = input_data - end select - type is (real(kind=r8_kind)) - select type (db => this%data_buffer) - type is (real(kind=r8_kind)) - db(is:ie, js:je, ks:ke, :) = input_data - end select - type is (integer(kind=i4_kind)) - select type (db => this%data_buffer) - type is (integer(kind=i4_kind)) - db(is:ie, js:je, ks:ke, :) = input_data - end select - type is (integer(kind=i8_kind)) - select type (db => this%data_buffer) - type is (integer(kind=i8_kind)) - db(is:ie, js:je, ks:ke, :) = input_data - end select - class default - call mpp_error ("set_data_buffer", "The data input to set_data_buffer for "//& - trim(this%varname)//" does not match the buffer for the field object", FATAL) - end select end subroutine set_data_buffer !> Allocates the global data buffer for a given field using a single thread. Returns true when the !! buffer is allocated @@ -431,55 +416,18 @@ logical function allocate_data_buffer(this, input_data, diag_axis) class (fmsDiagField_type), target, intent(inout):: this !< The field object class(*), dimension(:,:,:,:), intent(in) :: input_data !< The input array class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis - integer :: naxes !< The number of axes in the field - integer, parameter :: ndims = 4 - integer, dimension (ndims) :: length !< The length of an axis - integer :: a !< For looping through axes - integer, pointer :: axis_id !< The axis ID - -!! Use the axis to get the size -!> Initialize the axis lengths to 1. Any dimension that does not have an axis will have a length -!! of 1. - length = 1 - naxes = size(this%axis_ids) - axis_loop: do a = 1,naxes - axis_id => this%axis_ids(a) - select type (axis => diag_axis(axis_id)%axis) - type is (fmsDiagFullAxis_type) - length(a) = axis%axis_length() - end select - enddo axis_loop - select type (input_data) - type is (real(r4_kind)) - if (.not.allocated(this%data_buffer)) allocate(real(kind=r4_kind) :: this%data_buffer( & - length(1),& - length(2),& - length(3),& - length(4))) - type is (real(r8_kind)) - if (.not.allocated(this%data_buffer)) allocate(real(kind=r8_kind) :: this%data_buffer( & - length(1),& - length(2),& - length(3),& - length(4))) - type is (integer(i4_kind)) - if (.not.allocated(this%data_buffer)) allocate(integer(kind=i4_kind) :: this%data_buffer( & - length(1),& - length(2),& - length(3),& - length(4))) - type is (integer(i8_kind)) - if (.not.allocated(this%data_buffer)) allocate(integer(kind=i8_kind) :: this%data_buffer( & - length(1),& - length(2),& - length(3),& - length(4))) - class default - call mpp_error ("allocate_data_buffer","The data input to set_data_buffer for "//& - trim(this%varname)//" is not a supported type", FATAL) - end select - allocate_data_buffer = allocated(this%data_buffer) + character(len=128) :: err_msg !< Error msg + err_msg = "" + + allocate(this%input_data_buffer) + err_msg = this%input_data_buffer%init(input_data, this%axis_ids, diag_axis) + if (trim(err_msg) .ne. "") then + call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg)) + return + endif + + allocate_data_buffer = .true. end function allocate_data_buffer !> Sets the flag saying that the math functions need to be done subroutine set_math_needs_to_be_done (this, math_needs_to_be_done) @@ -1270,16 +1218,45 @@ end subroutine write_coordinate_attribute !> @brief Gets a fields data buffer !! @return a pointer to the data buffer function get_data_buffer (this) & -result(rslt) + result(rslt) class (fmsDiagField_type), target, intent(in) :: this !< diag field class(*),dimension(:,:,:,:), pointer :: rslt !< The field's data buffer - if (allocated(this%data_buffer)) then - rslt => this%data_buffer - else - rslt => null() - endif + if (.not. this%data_buffer_is_allocated) & + call mpp_error(FATAL, "The input data buffer for the field:"& + //trim(this%varname)//" was never allocated.") + + rslt => this%input_data_buffer%get_buffer() end function get_data_buffer + +!> @brief Gets a fields mask buffer +!! @return a pointer to the mask buffer +function get_mask (this) & + result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag field + logical, dimension(:,:,:,:), pointer :: rslt + + if (.not. this%data_buffer_is_allocated) & + call mpp_error(FATAL, "The input data buffer for the field:"& + //trim(this%varname)//" was never allocated.") + + rslt => this%input_data_buffer%get_mask() +end function get_mask + +!> @brief Gets a fields weight buffer +!! @return a pointer to the weight buffer +function get_weight (this) & + result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag field + type(real(kind=r8_kind)), pointer :: rslt + + if (.not. this%data_buffer_is_allocated) & + call mpp_error(FATAL, "The input data buffer for the field:"& + //trim(this%varname)//" was never allocated.") + + rslt => this%input_data_buffer%get_weight() +end function get_weight + !> Gets the flag telling if the math functions need to be done !! \return Copy of math_needs_to_be_done flag pure logical function get_math_needs_to_be_done(this) @@ -1442,12 +1419,14 @@ pure logical function has_data_RANGE (this) class (fmsDiagField_type), intent(in) :: this !< diag object has_data_RANGE = allocated(this%data_RANGE) end function has_data_RANGE -!> @brief Checks if obj%data_buffer is allocated -!! @return true if obj%data_buffer is allocated -pure logical function has_data_buffer (this) + +!> @brief Checks if obj%input_data_buffer is allocated +!! @return true if obj%input_data_buffer is allocated +pure logical function has_input_data_buffer (this) class (fmsDiagField_type), intent(in) :: this !< diag object - has_data_buffer = allocated(this%data_buffer) -end function has_data_buffer + has_input_data_buffer = allocated(this%input_data_buffer) +end function has_input_data_buffer + !> @brief Add a attribute to the diag_obj using the diag_field_id subroutine diag_field_add_attribute(this, att_name, att_value) class (fmsDiagField_type), intent (inout) :: this !< The field object diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index b33b9d0431..687f609252 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -67,10 +67,7 @@ module fms_diag_file_object_mod TYPE(time_type) :: next_output !< Time of the next write TYPE(time_type) :: next_next_output !< Time of the next next write TYPE(time_type) :: no_more_data !< Time to stop receiving data for this file - logical :: done_writing_data!< Set to .True. if finished writing data - !! This is be initialized to .false. and set to true for - !! static files after the first write and for - !! files that are using the file_duration functionality + logical :: done_writing_data!< .True. if finished writing data !< This will be used when using the new_file_freq keys in the diag_table.yaml TYPE(time_type) :: next_close !< Time to close the file diff --git a/diag_manager/fms_diag_input_buffer.F90 b/diag_manager/fms_diag_input_buffer.F90 new file mode 100644 index 0000000000..1428a229c7 --- /dev/null +++ b/diag_manager/fms_diag_input_buffer.F90 @@ -0,0 +1,206 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @defgroup fms_diag_input_buffer_mod fms_diag_input_buffer_mod +!> @ingroup diag_manager +!! @brief +!> @addtogroup fms_diag_input_buffer_mod +!> @{ +module fms_diag_input_buffer_mod +#ifdef use_yaml + use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind + use fms_diag_axis_object_mod, only: fmsDiagAxisContainer_type, fmsDiagFullAxis_type + implicit NONE + private + + !> @brief Type to hold the information needed for the input buffer + !! This is used when set_math_needs_to_be_done = .true. (i.e calling send_data + !! from an openmp region with multiple threads) + type fmsDiagInputBuffer_t + logical :: initialized !< .True. if the input buffer has been initialized + class(*), allocatable :: buffer(:,:,:,:) !< Input data passed in send_data + logical, allocatable :: mask(:,:,:,:) !< Mask passed in send_data + real(kind=r8_kind) :: weight !< Weight passed in send_data + + contains + procedure :: get_buffer + procedure :: get_mask + procedure :: get_weight + procedure :: init => init_input_buffer_object + procedure :: set_input_buffer_object + procedure :: is_initialized + end type fmsDiagInputBuffer_t + + public :: fmsDiagInputBuffer_t + + contains + + !> @brief Get the buffer from the input buffer object + !! @return a pointer to the buffer + function get_buffer(this) & + result(buffer) + class(fmsDiagInputBuffer_t), target, intent(in) :: this !< input buffer object + class(*), pointer :: buffer(:,:,:,:) + + buffer => this%buffer + end function get_buffer + + !> @brief Get the mask from the input buffer object + !! @return a pointer to the mask + function get_mask(this) & + result(mask) + class(fmsDiagInputBuffer_t), target, intent(in) :: this !< input buffer object + logical, pointer :: mask(:,:,:,:) + + mask => this%mask + end function get_mask + + !> @brief Get the weight from the input buffer object + !! @return a pointer to the weight + function get_weight(this) & + result(weight) + class(fmsDiagInputBuffer_t), target, intent(in) :: this !< input buffer object + real(kind=r8_kind), pointer :: weight + + weight => this%weight + end function get_weight + + !> @brief Initiliazes an input data buffer + !! @return Error message if something went wrong + function init_input_buffer_object(this, input_data, axis_ids, diag_axis) & + result(err_msg) + class(fmsDiagInputBuffer_t), intent(out) :: this !< input buffer object + class(*), intent(in) :: input_data(:,:,:,:) !< input data + integer, target, intent(in) :: axis_ids(:) !< axis ids for the field + class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Array of diag_axis + character(len=128) :: err_msg + + integer :: naxes !< The number of axes in the field + integer, parameter :: ndims = 4 !< Number of dimensions + integer :: length(ndims) !< The length of an axis + integer :: a !< For looping through axes + integer, pointer :: axis_id !< The axis ID + + err_msg = "" + + !! Use the axis to get the size + !> Initialize the axis lengths to 1. Any dimension that does not have an axis will have a length + !! of 1. + length = 1 + naxes = size(axis_ids) + axis_loop: do a = 1,naxes + axis_id => axis_ids(a) + select type (axis => diag_axis(axis_id)%axis) + type is (fmsDiagFullAxis_type) + length(a) = axis%axis_length() + end select + enddo axis_loop + + allocate(this%mask(length(1), length(2), length(3), length(4))) + select type (input_data) + type is (real(r4_kind)) + allocate(real(kind=r4_kind) :: this%buffer(length(1), length(2), length(3), length(4))) + type is (real(r8_kind)) + allocate(real(kind=r8_kind) :: this%buffer(length(1), length(2), length(3), length(4))) + type is (integer(i4_kind)) + allocate(integer(kind=i4_kind) :: this%buffer(length(1), length(2), length(3), length(4))) + type is (integer(i8_kind)) + allocate(integer(kind=i4_kind) :: this%buffer(length(1), length(2), length(3), length(4))) + class default + err_msg = "The data input is not one of the supported types."& + "Only r4, r8, i4, and i8 types are supported." + end select + + this%weight = 1.0_r8_kind + this%initialized = .true. + end function init_input_buffer_object + + !> @brief Sets the members of the input buffer object + !! @return Error message if something went wrong + function set_input_buffer_object(this, input_data, weight, mask, is, js, ks, ie, je, ke) & + result(err_msg) + + class(fmsDiagInputBuffer_t), intent(inout) :: this !< input buffer object + class(*), intent(in) :: input_data(:,:,:,:) !< Field data + real(kind=r8_kind), intent(in) :: weight !< Weight for the field + logical, intent(in) :: mask(:,:,:,:) !< Mask for the field + integer, intent(in) :: is, js, ks !< Starting index for each of the dimension + integer, intent(in) :: ie, je, ke !< Ending index for each of the dimensions + + character(len=128) :: err_msg + err_msg = "" + + if (.not. this%initialized) then + err_msg = "The data buffer was never initiliazed. This shouldn't happen." + return + endif + + this%mask(is:ie, js:je, ks:ke, :) = mask + this%weight = weight + + select type (input_data) + type is (real(kind=r4_kind)) + select type (db => this%buffer) + type is (real(kind=r4_kind)) + db(is:ie, js:je, ks:ke, :) = input_data + class default + err_msg = "The data buffer was not allocated to the correct type (r4_kind). This shouldn't happen" + return + end select + type is (real(kind=r8_kind)) + select type (db => this%buffer) + type is (real(kind=r8_kind)) + db(is:ie, js:je, ks:ke, :) = input_data + class default + err_msg = "The data buffer was not allocated to the correct type (r8_kind). This shouldn't happen" + return + end select + type is (integer(kind=i4_kind)) + select type (db => this%buffer) + type is (integer(kind=i4_kind)) + db(is:ie, js:je, ks:ke, :) = input_data + class default + err_msg = "The data buffer was not allocated to the correct type (i4_kind). This shouldn't happen" + return + end select + type is (integer(kind=i8_kind)) + select type (db => this%buffer) + type is (integer(kind=i8_kind)) + db(is:ie, js:je, ks:ke, :) = input_data + class default + err_msg = "The data buffer was not allocated to the correct type (i8_kind). This shouldn't happen" + return + end select + end select + end function set_input_buffer_object + + !> @brief Determine if an input buffer is initialized + !! @return .true. if the input buffer is initialized + pure logical function is_initialized(this) + class(fmsDiagInputBuffer_t), intent(in) :: this !< input buffer object + + is_initialized = .false. + if (this%initialized) then + is_initialized = .true. + else + if (allocated(this%buffer)) is_initialized = .true. + endif + end function is_initialized +#endif +end module fms_diag_input_buffer_mod +!> @} diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 0a3953a8bb..d846c97afa 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -602,8 +602,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.) !$omp end critical - !TODO Save the field_weight and the oor_mask to use later in the calculations - call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data,& + call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, oor_mask, field_weight, & is, js, ks, ie, je, ke) fms_diag_accept_data = .TRUE. return @@ -643,6 +642,9 @@ subroutine fms_diag_send_complete(this, time_step) logical :: math !< True if the math functions need to be called using the data buffer, !! False if the math functions were done in accept_data integer, dimension(:), allocatable :: file_field_ids !< Array of field IDs for a file + class(*), pointer :: input_data_buffer(:,:,:,:) + character(len=128) :: error_string + type(fmsDiagIbounds_type) :: bounds !< Update the current model time by adding the time_step this%current_model_time = this%current_model_time + time_step @@ -662,8 +664,14 @@ subroutine fms_diag_send_complete(this, time_step) !> Check if math needs to be done math = diag_field%get_math_needs_to_be_done() calling_math: if (math) then - call this%allocate_diag_field_output_buffers(diag_field%get_data_buffer(), file_field_ids(ifield)) - !!TODO: call math functions !! + input_data_buffer => diag_field%get_data_buffer() + call bounds%reset_bounds_from_array_4D(input_data_buffer) + call this%allocate_diag_field_output_buffers(input_data_buffer, file_field_ids(ifield)) + error_string = this%fms_diag_do_reduction(input_data_buffer, file_field_ids(ifield), & + diag_field%get_mask(), diag_field%get_weight(), & + bounds, .False., Time=this%current_model_time) + if (trim(error_string) .ne. "") call mpp_error(FATAL, "Field:"//trim(diag_field%get_varname()//& + " -"//trim(error_string))) endif calling_math !> Clean up, clean up, everybody everywhere if (associated(diag_field)) nullify(diag_field) diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90 index 3f85a043f0..5b57051065 100644 --- a/test_fms/diag_manager/test_reduction_methods.F90 +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -228,6 +228,16 @@ program test_reduction_methods mask=dlmask(:,:,:,1)) end select case (test_openmp) + select case(mask_case) + case (no_mask) + used=send_data(id_var1, cdata(:, 1, 1, 1), time) + case (logical_mask) + used=send_data(id_var1, cdata(:, 1, 1, 1), time, & + mask=clmask(:, 1, 1, 1)) + case (real_mask) + used=send_data(id_var1, cdata(:, 1, 1, 1), time, & + rmask=crmask(:, 1, 1, 1)) + end select !$OMP parallel do default(shared) private(iblock, isw, iew, jsw, jew, is1, ie1, js1, je1) do iblock=1, 4 isw = my_block%ibs(iblock) @@ -243,19 +253,14 @@ program test_reduction_methods select case (mask_case) case (no_mask) - used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1) used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1) used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1) case (real_mask) - used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1, & - rmask=crmask(is1:ie1, 1, 1, 1)) used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, & rmask=crmask(is1:ie1, js1:je1, 1, 1)) used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, & rmask=crmask(is1:ie1, js1:je1, :, 1)) case (logical_mask) - used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1, & - mask=clmask(is1:ie1, 1, 1, 1)) used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, & mask=clmask(is1:ie1, js1:je1, 1, 1)) used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, & @@ -263,7 +268,6 @@ program test_reduction_methods end select enddo end select - call diag_send_complete(Time_step) enddo diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh index 7e2597ee87..e9e444c5fb 100755 --- a/test_fms/diag_manager/test_time_none.sh +++ b/test_fms/diag_manager/test_time_none.sh @@ -109,8 +109,7 @@ test_expect_success "Checking answers for the "none" reduction method, real mask mpirun -n 1 ../check_time_none ' -TODO this needs to be set back to 2, once the set_math_needs_to_be_done=.true. portion of the code is implemented -export OMP_NUM_THREADS=1 +export OMP_NUM_THREADS=2 my_test_count=`expr $my_test_count + 1` printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml test_expect_success "Running diag_manager with "none" reduction method with openmp (test $my_test_count)" '