diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90 index ffecfc650..e723ce841 100644 --- a/diag_manager/fms_diag_field_object.F90 +++ b/diag_manager/fms_diag_field_object.F90 @@ -80,6 +80,7 @@ module fms_diag_field_object_mod logical, allocatable :: buffer_allocated !< True if a buffer pointed by !! the corresponding index in !! buffer_ids(:) is allocated. + logical, allocatable :: mask(:,:,:,:) !< Mask passed in send_data contains ! procedure :: send_data => fms_send_data !!TODO ! Get ID functions @@ -165,6 +166,8 @@ module fms_diag_field_object_mod procedure :: add_area_volume procedure :: append_time_cell_methods procedure :: get_file_ids + procedure :: set_mask + procedure :: allocate_mask end type fmsDiagField_type !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! type(fmsDiagField_type) :: null_ob @@ -394,10 +397,9 @@ 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, mask, weight, is, js, ks, ie, je, ke) +subroutine set_data_buffer (this, input_data, 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) @@ -408,7 +410,7 @@ subroutine set_data_buffer (this, input_data, mask, weight, is, js, ks, ie, je, 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) + err_msg = this%input_data_buffer%set_input_buffer_object(input_data, weight, is, js, ks, ie, je, ke) if (trim(err_msg) .ne. "") call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg)) end subroutine set_data_buffer @@ -1239,19 +1241,6 @@ function get_data_buffer (this) & 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 @@ -1647,5 +1636,61 @@ pure function get_file_ids(this) get_file_ids = this%file_ids end function +!> @brief Get the mask from the input buffer object +!! @return a pointer to the mask +function get_mask(this) + class(fmsDiagField_type), target, intent(in) :: this !< input buffer object + logical, pointer :: get_mask(:,:,:,:) + get_mask => this%mask +end function get_mask + +!> @brief If in openmp region, omp_axis should be provided in order to allocate to the given axis lengths. +!! Otherwise mask will be allocated to the size of mask_in +subroutine allocate_mask(this, mask_in, omp_axis) + class(fmsDiagField_type), target, intent(inout) :: this !< input buffer object + logical, intent(in) :: mask_in(:,:,:,:) + class(fmsDiagAxisContainer_type), intent(in), optional :: omp_axis(:) !< true if calling from omp region + integer :: axis_num, length(4) + integer, pointer :: id_num + if(allocated(this%mask)) then + call mpp_error(NOTE,"set_mask:: mask already allocated for field"//this%longname) + deallocate(this%mask) + endif + ! if not omp just allocate to whatever is given + if(.not. present(omp_axis)) then + allocate(this%mask(size(mask_in,1), size(mask_in,2), size(mask_in,3), & + size(mask_in,4))) + ! otherwise loop through axis and get sizes + else + length = 1 + do axis_num=1, size(this%axis_ids) + id_num => this%axis_ids(axis_num) + select type(axis => omp_axis(id_num)%axis) + type is (fmsDiagFullAxis_type) + length(axis_num) = axis%axis_length() + end select + enddo + allocate(this%mask(length(1), length(2), length(3), length(4))) + endif +end subroutine allocate_mask + +!> Sets previously allocated mask to mask_in at given index ranges +subroutine set_mask(this, mask_in, is, js, ks, ie, je, ke) + class(fmsDiagField_type), intent(inout) :: this + logical, intent(in) :: mask_in(:,:,:,:) + integer, optional, intent(in) :: is, js, ks, ie, je, ke + if(present(is)) then + if(is .lt. lbound(this%mask,1) .or. ie .gt. ubound(this%mask,1) .or. & + js .lt. lbound(this%mask,2) .or. je .gt. ubound(this%mask,2) .or. & + ks .lt. lbound(this%mask,3) .or. ke .gt. ubound(this%mask,3)) then + print *, mpp_pe(), "alloc'd", SHAPE(this%mask), "passed:", is,ie,js,je,ks,ke + call mpp_error(FATAL,"set_mask:: given indices out of bounds for allocated mask") + endif + this%mask(is:ie, js:je, ks:ke, :) = mask_in + else + this%mask = mask_in + endif +end subroutine set_mask + #endif end module fms_diag_field_object_mod diff --git a/diag_manager/fms_diag_input_buffer.F90 b/diag_manager/fms_diag_input_buffer.F90 index 1428a229c..12257734c 100644 --- a/diag_manager/fms_diag_input_buffer.F90 +++ b/diag_manager/fms_diag_input_buffer.F90 @@ -34,12 +34,10 @@ module fms_diag_input_buffer_mod 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 @@ -60,15 +58,6 @@ function get_buffer(this) & 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 @@ -111,7 +100,6 @@ function init_input_buffer_object(this, input_data, axis_ids, diag_axis) & 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))) @@ -132,13 +120,12 @@ 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) & + function set_input_buffer_object(this, input_data, weight, 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 @@ -150,7 +137,6 @@ function set_input_buffer_object(this, input_data, weight, mask, is, js, ks, ie, return endif - this%mask(is:ie, js:je, ks:ke, :) = mask this%weight = weight select type (input_data) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index ea651e725..d92d6a9cf 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -602,12 +602,14 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm if (.not. this%FMS_diag_fields(diag_field_id)%is_data_buffer_allocated()) then data_buffer_is_allocated = & this%FMS_diag_fields(diag_field_id)%allocate_data_buffer(field_data, this%diag_axis) + call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask, this%diag_axis) endif 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 - call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, oor_mask, field_weight, & + call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, field_weight, & is, js, ks, ie, je, ke) + call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask, is, js, ks, ie, je, ke) fms_diag_accept_data = .TRUE. return else @@ -619,6 +621,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm bounds, using_blocking, Time=Time) if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info)) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) + call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask) + call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask) return end if main_if !> Return false if nothing is done