From 424e7eca683acd011551c555b2761fac17f95675 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 10:03:26 -0400 Subject: [PATCH 01/61] Updates reduction method min/max --- diag_manager/Makefile.am | 2 + diag_manager/fms_diag_axis_object.F90 | 16 + diag_manager/fms_diag_bbox.F90 | 33 + diag_manager/fms_diag_object.F90 | 371 ++++++++--- diag_manager/fms_diag_reduction_methods.F90 | 676 ++++++++++++++++++++ 5 files changed, 999 insertions(+), 99 deletions(-) create mode 100644 diag_manager/fms_diag_reduction_methods.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index b5570cf5ff..e442955b33 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -52,6 +52,7 @@ libdiag_manager_la_SOURCES = \ fms_diag_elem_weight_procs.F90 \ fms_diag_fieldbuff_update.F90 \ fms_diag_bbox.F90 \ + fms_diag_reduction_methods_mod \ include/fms_diag_fieldbuff_update.inc \ include/fms_diag_fieldbuff_update.fh @@ -67,6 +68,7 @@ fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ fms_diag_time_utils_mod.$(FC_MODEXT) \ fms_diag_output_buffer_mod.$(FC_MODEXT) +# fms_diag_reduction_methods_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_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) \ diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 index 61555b52e6..62409a0fd0 100644 --- a/diag_manager/fms_diag_axis_object.F90 +++ b/diag_manager/fms_diag_axis_object.F90 @@ -118,6 +118,8 @@ module fms_diag_axis_object_mod real(kind=r4_kind), allocatable, private :: zbounds(:) !< Bounds of the Z axis contains procedure :: fill_subaxis + procedure :: get_starting_index + procedure :: get_ending_index END TYPE fmsDiagSubAxis_type !> @brief Type to hold the diurnal axis @@ -755,6 +757,20 @@ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, endif end subroutine fill_subaxis + !> @brief Accesses its member starting_index + !! @return Returns a copy of the starting_index + function get_starting_index(this) + class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object + get_starting_index = this%starting_index + end function get_starting_index + + !> @brief Accesses its member ending_index + !! @return Returns a copy of the ending_index + function get_ending_index(this) + class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object + get_ending_index = this%ending_index + end function get_ending_index + !> @brief Get the ntiles in a domain !> @return the number of tiles in a domain function get_ntiles(this) & diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index 956dabd31c..c5e2ec1150 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -57,6 +57,9 @@ MODULE fms_diag_bbox_mod procedure :: get_jmax procedure :: get_kmin procedure :: get_kmax + procedure :: set_ibounds + procedure :: set_jbounds + procedure :: set_kbounds END TYPE fmsDiagIbounds_type !> @brief Data structure holding starting and ending indices in the I, J, and @@ -128,6 +131,36 @@ pure integer function get_kmax (this) result(rslt) rslt = this%kmax end function get_kmax + !> @brief Sets bounds in the I dimensions + subroutine set_ibounds(this, lower, upper) + class(fmsDiagIbounds_type), intent(inout) :: this !< The calling object + integer, intent(in) :: lower !< The lower bound + integer, intent(in) :: upper !< The upper bound + + this%imin = lower + this%imax = upper + end subroutine set_ibounds + + !> @brief Sets bounds in the J dimensions + subroutine set_jbounds(this, lower, upper) + class(fmsDiagIbounds_type), intent(inout) :: this !< The calling object + integer, intent(in) :: lower !< The lower bound + integer, intent(in) :: upper !< The upper bound + + this%jmin = lower + this%jmax = upper + end subroutine set_jbounds + + !> @brief Sets bounds in the K dimensions + subroutine set_kbounds(this, lower, upper) + class(fmsDiagIbounds_type), intent(inout) :: this !< The calling object + integer, intent(in) :: lower !< The lower bound + integer, intent(in) :: upper !< The upper bound + + this%kmin = lower + this%kmax = upper + end subroutine set_kbounds + !> @brief Gets the halo size of fmsDiagBoundsHalos_type in the I dimension !! @return copy of integer member hi pure integer function get_hi (this) result(rslt) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 8bbe5b2266..b052717032 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -43,6 +43,8 @@ module fms_diag_object_mod #endif use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d use platform_mod +!use fms_diag_bbox_mod +!use fms_diag_reduction_methods_mod, only: fms_diag_update_extremum implicit none private @@ -86,6 +88,7 @@ module fms_diag_object_mod procedure :: fms_diag_field_add_cell_measures procedure :: allocate_diag_field_output_buffers procedure :: fms_diag_compare_window + procedure :: fms_diag_do_reduction #ifdef use_yaml procedure :: get_diag_buffer #endif @@ -493,28 +496,38 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is integer :: omp_level !< The openmp active level logical :: buffer_the_data !< True if the user selects to buffer the data and run the calculations !! later. \note This is experimental - !TODO logical, allocatable, dimension(:,:,:) :: oor_mask !< Out of range mask - integer :: sample !< Index along the diurnal time axis - integer :: day !< Number of days - integer :: second !< Number of seconds - integer :: tick !< Number of ticks representing fractional second - integer :: buffer_id !< Index of a buffer - !TODO: logical :: phys_window - character(len=128) :: error_string !< Store error text - integer :: i !< For looping #ifndef use_yaml CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else - class(diagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields - - !TODO: weight is for time averaging where each time level may have a different weight - ! call real_copy_set() + real :: weight2 !< Weight to be used in computation of sum, average, etc. + logical, allocatable, dimension(:,:,:) :: oor_mask !< Out of range mask + + !> Input weight is for time averaging where each time level may have a different weight. + !! The input weight is polymorphic in intrinsic real types. If it is present it will be + !! assigned to weight2 else weight2 gets val value. + call real_copy_set(weight2, in_data=weight, val=1., err_msg=err_msg) + + !> oor_mask is only used for checking out of range values. + if (present(rmask)) then + select type (rmask) + type is (real(kind=r4_kind)) + call init_mask_3d(field_data, oor_mask, rmask_threshold=0.5_r4_kind, inmask=mask, rmask=rmask) + type is (real(kind=r8_kind)) + call init_mask_3d(field_data, oor_mask, rmask_threshold=0.5_r8_kind, inmask=mask, rmask=rmask) + class default + call mpp_error(FATAL, "fms_diag_object_mod::fms_diag_accept_data unsupported type") + end select + end if - !TODO: oor_mask is only used for checking out of range values. - ! call init_mask_3d() + !> Check improper combinations of is, ie, js, and je. + if (check_indices_order(is_in, ie_in, js_in, je_in, err_msg)) then + if (associated(field_data)) deallocate(field_data) + if (allocated(oor_mask)) deallocate(oor_mask) + return + end if - !TODO: Check improper combinations of is, ie, js, and je. - ! if (check_indices_order()) deallocate(oor_mask) + !> Allocate buffers of this field variable + call allocate_diag_field_output_buffers(field_data, diag_field_id) !> Does the user want to push off calculations until send_diag_complete? buffer_the_data = .false. @@ -553,47 +566,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is return else !!TODO: Loop through fields and do averages/math functions - do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids) - buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(i) - - !!TODO: Check if the field is a physics window - !! phys_window = fms_diag_compare_window() - - !!TODO: Get local start and end indices on 3 axes for regional output - - !> Compute the diurnal index - sample = 1 - if (present(time)) then - call get_time(time, second, day, tick) !< Current time in days and seconds - ptr_diag_field_yaml => diag_yaml%get_diag_field_from_id(buffer_id) - sample = floor((second + real(tick) / get_ticks_per_second()) & - & * ptr_diag_field_yaml%get_n_diurnal() / SECONDS_PER_DAY) + 1 - end if - - !!TODO: Get the vertical layer start and end indices - - !!TODO: Initialize output time for fields output every time step - - !< Check if time should be present for this field - if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) then - write(error_string, '(a,"/",a)') trim(this%FMS_diag_fields(diag_field_id)%get_modname()),& - & trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) - if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& - &//trim(error_string)//', time must be present for nonstatic field', err_msg)) then - !!TODO: deallocate local pointers/allocatables if needed - return - end if - end if - - !!TODO: Is it time to output for this field? CAREFUL ABOUT > vs >= HERE - !--- The fields send out within openmp parallel region will be written out in - !--- diag_send_complete. - - !!TODO: Is check to bounds of current field necessary? - - !!TODO: Take care of submitted field data - - enddo + fms_diag_accept_data = fms_diag_do_reduction(field_data, diag_field_id, oor_mask, weight, & + time, is_in, js_in, ks_in, ie_in, je_in, ke_in, err_msg) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) fms_diag_accept_data = .TRUE. return @@ -1019,6 +993,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) ! Loop over a number of fields/buffers where this variable occurs do i = 1, size(this%FMS_diag_fields(field_id)%buffer_ids) + if (this%FMS_diag_fields(field_id)%buffer_allocated(i)) return !< The buffer is allocated before buffer_id = this%FMS_diag_fields(field_id)%buffer_ids(i) ndims = 0 @@ -1084,6 +1059,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) class default call mpp_error( FATAL, 'allocate_diag_field_output_buffers: invalid buffer type') end select + this%FMS_diag_fields(field_id)%buffer_allocated(i) = .true. !< The buffer is allocated. enddo #else call mpp_error( FATAL, "allocate_diag_field_output_buffers: "//& @@ -1091,49 +1067,246 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) #endif end subroutine allocate_diag_field_output_buffers -!> @brief Determines if the window defined by the input bounds is a physics window. -!> @return TRUE if the window size is less then the actual field size else FALSE. -function fms_diag_compare_window(this, field, field_id, & - is_in, ie_in, js_in, je_in, ks_in, ke_in) result(is_phys_win) - class(fmsDiagObject_type), intent(in) :: this !< Diag Object - class(*), intent(in) :: field(:,:,:,:) !< Field data - integer, intent(in) :: field_id !< ID of the input field - integer, intent(in) :: is_in, js_in !< Starting field indices for the first 2 dimensions; - !< pass reconditioned indices fis and fjs - !< which are computed elsewhere. - integer, intent(in) :: ie_in, je_in !< Ending field indices for the first 2 dimensions; - !< pass reconditioned indices fie and fje - !< which are computed elsewhere. - integer, intent(in) :: ks_in, ke_in !< Starting and ending indices of the field in 3rd dimension - logical :: is_phys_win !< Return flag + !> @brief Determines if the window defined by the input bounds is a physics window. + !> @return TRUE if the window size is less then the actual field size else FALSE. + function fms_diag_compare_window(this, field, field_id, & + is_in, ie_in, js_in, je_in, ks_in, ke_in) result(is_phys_win) + class(fmsDiagObject_type), intent(in) :: this !< Diag Object + class(*), intent(in) :: field(:,:,:,:) !< Field data + integer, intent(in) :: field_id !< ID of the input field + integer, intent(in) :: is_in, js_in !< Starting field indices for the first 2 dimensions; + !< pass reconditioned indices fis and fjs + !< which are computed elsewhere. + integer, intent(in) :: ie_in, je_in !< Ending field indices for the first 2 dimensions; + !< pass reconditioned indices fie and fje + !< which are computed elsewhere. + integer, intent(in) :: ks_in, ke_in !< Starting and ending indices of the field in 3rd dimension + logical :: is_phys_win !< Return flag #ifdef use_yaml - integer, pointer :: axis_ids(:) - integer :: total_elements - integer :: i !< For do loop - integer :: field_size - integer, allocatable :: field_shape(:) !< Shape of the field data - integer :: window_size - - !> Determine shape of the field defined by the input bounds - field_shape = shape(field(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)) - - window_size = field_shape(1) * field_shape(2) * field_shape(3) - - total_elements = 1 - axis_ids => this%FMS_diag_fields(field_id)%get_axis_id() - do i=1, size(axis_ids) - total_elements = total_elements * this%fms_get_axis_length(axis_ids(i)) - enddo + integer, pointer :: axis_ids(:) + integer :: total_elements + integer :: i !< For do loop + integer :: field_size + integer, allocatable :: field_shape(:) !< Shape of the field data + integer :: window_size + + !> Determine shape of the field defined by the input bounds + field_shape = shape(field(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)) + + window_size = field_shape(1) * field_shape(2) * field_shape(3) + + total_elements = 1 + axis_ids => this%FMS_diag_fields(field_id)%get_axis_id() + do i=1, size(axis_ids) + total_elements = total_elements * this%fms_get_axis_length(axis_ids(i)) + enddo - if (total_elements > window_size) then - is_phys_win = .true. - else - is_phys_win = .false. - end if + if (total_elements > window_size) then + is_phys_win = .true. + else + is_phys_win = .false. + end if #else - is_phys_win = .false. - call mpp_error( FATAL, "fms_diag_compare_window: "//& - "you can not use the modern diag manager without compiling with -Duse_yaml") + call mpp_error( FATAL, "fms_diag_compare_window: "//& + "you can not use the modern diag manager without compiling with -Duse_yaml") +#endif + end function fms_diag_compare_window + + !> @brief Computes average, min, max, rms error, etc. + !! based on the specified reduction method for the field. + !> @return .True. if no error occurs. + function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, & + time, is_in, js_in, ks_in, ie_in, je_in, ke_in, err_msg) result(redn_done) + class(fmsDiagObject_type), intent(in) :: this !< Diag Object + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + integer, intent(in) :: diag_field_id !< ID of the input field + logical, intent(in) :: oor_mask(:,:,:) !< Out of range mask + real, intent(in) :: weight !< Must be a updated weight + integer, intent(in), optional :: time !< Current time + integer, intent(in), optional :: is_in, js_in, ks_in !< Starting indices of the variable + integer, intent(in), optional :: ie_in, je_in, ke_in !< Ending indices of the variable + character(len=*), intent(out), optional :: err_msg !< An error message returned + logical :: redn_done !< Return flag: .TRUE. if no error occurs + + redn_done = .FALSE. +#ifdef use_yaml + integer :: buffer_id !< Index of a buffer + integer :: file_id !< File id where the field/buffer is in + integer, allocatable :: freq(:) !< Output frequency + integer :: reduction_method !< Integer representing a reduction method: none, average, min, max, ... etc. + integer :: pow_val !< Exponent used in calculation of time average + logical :: phys_window + logical :: reduced_k_range + logical :: is_regional !< Flag to indicate if the field is regional + logical :: this_pe_writes !< Flag to indicate if the data from the current PE need to be written + integer, allocatable :: l_start(:) !< local start indices on axes for regional output + integer, allocatable :: l_end(:) !< local end indices on axes for regional output + integer :: day !< Number of days + integer :: second !< Number of seconds + integer :: tick !< Number of ticks representing fractional second + integer :: sample !< Index along the diurnal time axis + class(diagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields + class(fmsDiagOutputBuffer_class), pointer :: ptr_diag_buffer_obj !< Pointer to the buffer class + character(len=128) :: error_string !< Store error text + integer :: updated_bounds(12) !< Adjusted starting and ending indices in the I, J, and K dimensions & + !! and halo sizes + logical :: has_diurnal_axis !< Flag to indicate if the field/buffer has a diurnal axis + character(len=128) :: field_name !< Field name for error reporting + type(fmsDiagBoundsHalos_type) :: bounds_with_halos !< Data structure that holds 3D bounds + !! in the I, J, and K dimensions and halo sizes + !! in the I, and J dimensions + integer :: i, j !< For looping + integer :: n_axis !< Number of axes + integer :: axis_id !< Axis id + type(fmsDiagAxis_type), pointer :: ptr_axis !< Pointer of type diag_axis%axis + + !> Recondition the input indices + call recondition_indices(bounds_with_halos, field_data, is_in, js_in, ks_in, & + ie_in, je_in, ke_in, err_msg=err_msg) + + do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids) + file_id = this%FMS_diag_fields(diag_field_id)%file_ids(i) + ! Is this field output on a local domain only? + this_pe_writes = this%FMS_diag_files(file_id)%writing_on_this_pe() + + ! If local_output, does the current PE take part in send_data? + is_regional = this%FMS_diag_files(file_id)%is_regional() + + ! Skip all PEs not participating in outputting this field + if (.not.this_pe_writes) cycle + + buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(i) + freq = this%FMS_diag_fields(diag_field_id)%get_frequency() + reduction_method = this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_reduction() + has_diurnal_axis = this%FMS_diag_fields(diag_field_id)%diag_field(i)%has_n_diurnal() + field_name = this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_fname() + + if (this%FMS_diag_fields(diag_field_id)%diag_field(i)%has_pow_value()) THEN + pow_val = this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_pow_value() + else + pow_val = 0 + end if + + !> Check if the field is a physics window + !! Pass fis, fie, fjs, fje, ks, and ke indices obtained from call to + !! recondition_indices() above as components of an array of indices output. + phys_window = this%fms_diag_compare_window(field_data, diag_field_id, & + bounds_with_halos%get_fis(), & + bounds_with_halos%get_fie(), & + bounds_with_halos%get_fjs(), & + bounds_with_halos%get_fje(), & + bounds_with_halos%bounds3D%get_kmin(), & + bounds_with_halos%bounds3D%get_kmax()) + + !> If sub regional output, get starting and ending indices + if (is_regional) then + if (allocated(this%FMS_diag_output_buffers(buffer_id)%axis_ids)) then + n_axis = size(this%FMS_diag_output_buffers(buffer_id)%axis_ids()) + allocate(l_start(n)) + allocate(l_end(n)) + do j = 1, n_axis + ptr_axis => this%diag_axis(this%FMS_diag_output_buffers(buffer_id)%axis_ids(j))%axis + select type (ptr_axis) + type is (fmsDiagSubAxis_type) + l_start(j) = ptr_axis%get_starting_index() + l_end(j) = ptr_axis%get_ending_index() + class default + call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_do_reduction non fmsDiagSubAxis_type axis') + end select + end do + else + call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_do_reduction '//& + 'member axis_ids of the current buffer is not allocated') + end if + end if + + !> Get the vertical layer starting and ending indices + if (reduced_k_range) then + if (.not.allocated(l_start)) allocate(l_start(3)) + if (.not.allocated(l_end)) allocate(l_end(3)) + ptr_axis => this%diag_axis(this%FMS_diag_output_buffers(buffer_id)%axis_ids(2))%axis !< Axis in the J dimension + select type (ptr_axis) + type is (fmsDiagSubAxis_type) + if (ptr_axis%is_unstructured_grid()) then + bounds_with_halos%bounds3D%jmin = ptr_axis%get_starting_index() + bounds_with_halos%bounds3D%jmin = ptr_axis%get_ending_index() + end if + l_start(3) = ptr_axis%get_starting_index() + l_end(3) = ptr_axis%get_ending_index() + class default + call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_do_reduction non fmsDiagSubAxis_type axis') + end select + end if + + ! Compute the diurnal index + sample = 1 + if (present(time)) then + call get_time(time, second, day, tick) !< Current time in days and seconds + ptr_diag_field_yaml => diag_yaml%get_diag_field_from_id(buffer_id) + sample = floor((second + real(tick) / get_ticks_per_second()) & + & * ptr_diag_field_yaml%get_n_diurnal() / SECONDS_PER_DAY) + 1 + end if + + ! Check if time is not present for fields output every time step + if (all(freq(:) == EVERY_TIME) .and. .not.this%FMS_diag_fields(diag_field_id)%is_static()) then + if (this%FMS_diag_files(file_id)%FMS_diag_file%get_next_output() == & + this%FMS_diag_files(file_id)%FMS_diag_file%get_last_output()) then + if (.not.present(time)) then + write (error_string,'(a,"/",a)') trim(this%FMS_diag_fields(diag_field_id)%get_modname()),& + trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) + if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& + &//trim(error_string)//', time must be present when output frequency = EVERY_TIME', err_msg)) then + if (associated(field_data)) deallocate(field_data) + end if + end if + end if + end if + + ! Check if time should be present for this field + if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) then + write(error_string, '(a,"/",a)') trim(this%FMS_diag_fields(diag_field_id)%get_modname()),& + & trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) + if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& + &//trim(error_string)//', time must be present for nonstatic field', err_msg)) then + if (associated(field_data)) deallocate(field_data) + return + end if + end if + + !!TODO: Is check to bounds of current field necessary? + + ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id)%diag_buffer_obj + + !!TODO: Take care of submitted field data + Reduction: select case (reduction_method) + case (time_none) + !! TODO: just copy field data to buffer + case (time_average) + !! TODO: average data over time + !! call fms_diag_sum(time_average, weight=weight, pow_val=power_val, .......) + case (time_rms) + !! TODO: root-mean-square error + case (time_max) + call fms_diag_update_extremum(1, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & + l_end, is_regional, reduced_k_range, sample, oor_mask, field_name, has_diurnal_axis, err_msg=err_msg) + case (time_min) + call fms_diag_update_extremum(0, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & + l_end, is_regional, reduced_k_range, sample, oor_mask, field_name, has_diurnal_axis, err_msg=err_msg) + case (time_sum) + !! TODO: sum for the interval + !! call fms_diag_sum(time_sum, .......) + case (time_diurnal) + !! TODO: diurnal calculation + case (time_power) + !! TODO: reduction is power + case default + call mpp_error(FATAL, "fms_diag_object_mod::fms_diag_accept_data unsupported reduction method!") + end select Reduction + enddo + redn_done = .TRUE. +#else + call mpp_error( FATAL, "fms_diag_object_mod::fms_diag_do_reduction "//& + "you can not use the modern diag manager without compiling with -Duse_yaml") #endif -end function fms_diag_compare_window + end function fms_diag_do_reduction end module fms_diag_object_mod diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 new file mode 100644 index 0000000000..5381500de3 --- /dev/null +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -0,0 +1,676 @@ +!> \author Ganga Purja Pun +!> \email gagna.purjapun@noaa.gov +!! \brief Contains routines for the modern diag_manager +!! +!! \description + +module fms_diag_reduction_methods_mod + use platform_mod + use fms_mod, only: fms_error_handler + !use fms_diag_bbox_mod + !use fms_diag_output_buffer_mod + + implicit none + private + +#ifdef use_yaml + public :: compare_two_sets_of_bounds, real_copy_set, check_indices_order, init_mask_3d + contains + + !> @brief Compares the corresponding bounding indices of the first set with the second set. + !> @return .TRUE. if any comparison returns true; i.e. the box bounded by the indices of the first set + !! is out side the box bounded by the indices of the second set. + LOGICAL FUNCTION compare_two_sets_of_bounds(bounds_a, bounds_b, error_str) + integer, intent(in) :: bounds_a(:) !< First array with order: (/imin, imax, jmin, jmax, kmin, kmax/) + integer, intent(in) :: bounds_b(:) !< Second array with the same order as the first + character(*), intent(out) :: error_str + + compare_two_sets_of_bounds = .FALSE. + + if (size(bounds_a) .ne. size(bounds_b)) then + compare_two_sets_of_bounds = .TRUE. + error_str = 'diag_util_mod::compare_two_sets_of_bounds Error: sizes of sets do not match' + else + if ((size(bounds_a) .ne. 6) .and. (size(bounds_b) .ne. 6)) then + compare_two_sets_of_bounds = .TRUE. + error_str = 'diag_util_mod::compare_two_sets_of_bounds Error: sizes of sets must be 6' + end if + end if + + IF (bounds_a(1) .lt. bounds_b(1) .OR. bounds_a(2) .gt. bounds_b(2) .OR. & + bounds_a(3) .lt. bounds_b(3) .OR. bounds_a(4) .gt. bounds_b(4) .OR. & + bounds_a(5) .lt. bounds_b(5) .OR. bounds_a(6) .gt. bounds_b(6)) THEN + compare_two_sets_of_bounds = .TRUE. + error_str ='First set of bounds= : , : , : Second set of bounds= : , : , : ' + WRITE(error_str(21:23),'(i3)') bounds_a(1) + WRITE(error_str(25:27),'(i3)') bounds_a(2) + WRITE(error_str(29:31),'(i3)') bounds_a(3) + WRITE(error_str(33:35),'(i3)') bounds_a(4) + WRITE(error_str(37:39),'(i3)') bounds_a(5) + WRITE(error_str(41:43),'(i3)') bounds_a(6) + WRITE(error_str(68:70),'(i3)') bounds_b(1) + WRITE(error_str(72:74),'(i3)') bounds_b(2) + WRITE(error_str(76:78),'(i3)') bounds_b(3) + WRITE(error_str(80:82),'(i3)') bounds_b(4) + WRITE(error_str(84:86),'(i3)') bounds_b(5) + WRITE(error_str(88:90),'(i3)') bounds_b(6) + ELSE + compare_two_sets_of_bounds = .FALSE. + error_str = '' + END IF + END FUNCTION compare_two_sets_of_bounds + + !> @brief Checks improper combinations of is, ie, js, and je. + !> @return Returns .false. if there is no error else .true. + !> @note send_data works in either one or another of two modes. + ! 1. Input field is a window (e.g. FMS physics) + ! 2. Input field includes halo data + ! It cannot handle a window of data that has halos. + ! (A field with no windows or halos can be thought of as a special case of either mode.) + ! The logic for indexing is quite different for these two modes, but is not clearly separated. + ! If both the beggining and ending indices are present, then field is assumed to have halos. + ! If only beggining indices are present, then field is assumed to be a window. + !> @par + ! There are a number of ways a user could mess up this logic, depending on the combination + ! of presence/absence of is,ie,js,je. The checks below should catch improper combinations. + function check_indices_order(is_in, ie_in, js_in, je_in, error_msg) result(rslt) + integer, intent(in), optional :: is_in, ie_in, js_in, je_in !< Indices passed to fms_diag_accept_data() + character(len=*), intent(inout), optional :: error_msg !< An error message used only for testing purpose!!! + + character(len=128) :: err_module_name !< Stores the module name to be used in error calls + logical :: rslt !< Return value + + rslt = .false. !< If no error occurs. + + err_module_name = 'diag_util_mod:check_indices_order' + + IF ( PRESENT(ie_in) ) THEN + IF ( .NOT.PRESENT(is_in) ) THEN + rslt = fms_error_handler(trim(err_module_name), 'ie_in present without is_in', error_msg) + IF (rslt) return + END IF + IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN + rslt = fms_error_handler(trim(err_module_name),& + & 'is_in and ie_in present, but js_in present without je_in', error_msg) + IF (rslt) return + END IF + END IF + + IF ( PRESENT(je_in) ) THEN + IF ( .NOT.PRESENT(js_in) ) THEN + rslt = fms_error_handler(trim(err_module_name), 'je_in present without js_in', error_msg) + IF (rslt) return + END IF + IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN + rslt = fms_error_handler(trim(err_module_name),& + & 'js_in and je_in present, but is_in present without ie_in', error_msg) + IF (rslt) return + END IF + END IF + end function check_indices_order + + !> @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. + subroutine real_copy_set(out_data, in_data, val, err_msg) + real, intent(out) :: out_data !< Proper type copy of in_data + class(*), intent(in), optional :: in_data !< Data to copy to out_data + real, intent(in), optional :: val !< Default value to assign to out_data if in_data is absent + character(len=*), intent(out), optional :: err_msg !< Error message to pass back to caller + + IF ( PRESENT(err_msg) ) err_msg = '' + + IF ( PRESENT(in_data) ) THEN + SELECT TYPE (in_data) + TYPE IS (real(kind=r4_kind)) + out_data = in_data + TYPE IS (real(kind=r8_kind)) + out_data = real(in_data) + CLASS DEFAULT + if (fms_error_handler('diag_util_mod:real_copy_set',& + & 'The in_data is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) THEN + return + end if + END SELECT + ELSE + if (present(val)) out_data = val + END IF + end subroutine real_copy_set + + !> @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 Updates the buffer with the field data based on the value of the flag passed: + !! 0 for minimum; 1 for maximum. + subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, l_start, & + l_end, is_regional, reduced_k_range, sample, mask, fieldName, hasDiurnalAxis, err_msg) + integer, intent(in) :: flag !< Flag to indicate what to update: 0 for minimum; 1 for maximum + class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Remapped buffer to update + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + type(fmsDiagBoundsHalos_type), intent(inout) :: recon_bounds !< Indices of bounds in the first three dimension + !! of the field data + integer, intent(in) :: l_start(:) !< Local starting indices for the first three dimensions + integer, intent(in) :: l_end(:) !< Local ending indices for the first three dimensions + logical, intent(in) :: is_regional + logical, intent(in) :: reduced_k_range + integer :: sample !< Index along the diurnal time axis + logical, intent(in) :: mask(:,:,:,:) !< Must be out of range mask + character(len=*), intent(in) :: fieldName !< Field name for error reporting + logical :: hasDiurnalAxis !< Flag to indicate if the buffer has a diurnal axis + character(len=*), intent(inout) :: err_msg + + integer :: is, js, ks !< Starting indices in the I, J, and K dimensions + integer :: ie, je, ke !< Ending indices in the I, J, and K dimensions + integer :: hi, hj !< Halo sizes in the I, and J dimensions + integer :: f1, f2 !< Updated starting and ending indices in the I dimension + integer :: f3, f4 !< Updated starting and ending indices in the J dimension + integer :: ksr, ker !< Reduced indices in the K dimension + integer :: i, j, k, i1, j1, k1 !< For loops + character(len=128) :: err_msg_local !< Stores local error message + class(*), pointer :: ptr_buffer(:,:,:,:,:) !< Pointer to 5D buffer for remapping + + !> Unpack recon_bounds + is = recon_bounds%bounds3D%get_imin() + js = recon_bounds%bounds3D%get_jmin() + ks = recon_bounds%bounds3D%get_kmin() + ie = recon_bounds%bounds3D%get_imax() + je = recon_bounds%bounds3D%get_jmax() + ke = recon_bounds%bounds3D%get_kmax() + hi = recon_bounds%get_hi() + f1 = recon_bounds%get_fis() + f2 = recon_bounds%get_fie() + hj = recon_bounds%get_hj() + f3 = recon_bounds%get_fjs() + f4 = recon_bounds%get_fje() + + if (flag .ne. 0 .and. flag .ne. 1) then + call mpp_error( FATAL, "fms_diag_object_mod::fms_diag_update_extremum: flag must be either 0 or 1.") + end if + + !! TODO: remap buffer before passing to subroutines update_scalar_extremum and update_array_extremum + ptr_buffer => buffer_obj%remap_buffer(fieldName, hasDiurnalAxis) + + ! Update buffer + IF (is_regional) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + select type (buffer_obj) + type is (outputBuffer0d_type) + call update_scalar_extremum(flag, field_data, ptr_buffer, mask, sample, & + recon_bounds, (/i,j,k/), (/i1,j1,k1/)) + type is (outputBuffer1d_type) + call update_scalar_extremum(flag, field_data, ptr_buffer, mask, sample, & + recon_bounds, (/i,j,k/), (/i1,j1,k1/)) + type is (outputBuffer2d_type) + call update_scalar_extremum(flag, field_data, ptr_buffer, mask, sample, & + recon_bounds, (/i,j,k/), (/i1,j1,k1/)) + type is (outputBuffer3d_type) + call update_scalar_extremum(flag, field_data, ptr_buffer, mask, sample, & + recon_bounds, (/i,j,k/), (/i1,j1,k1/)) + type is (outputBuffer4d_type) + call update_scalar_extremum(flag, field_data, ptr_buffer, mask, sample, & + recon_bounds, (/i,j,k/), (/i1,j1,k1/)) + type is (outputBuffer5d_type) + call update_scalar_extremum(flag, field_data, ptr_buffer, mask, sample, & + recon_bounds, (/i,j,k/), (/i1,j1,k1/)) + class default + call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_update_extremum unsupported buffer type') + end select + end if + END DO + END DO + END DO + ELSE + IF (reduced_k_range) THEN + recon_bounds%bounds3D%set_kbounds(l_start(3), l_end(3)) + select type (buffer_obj) + type is (outputBuffer0d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer1d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer2d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer3d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer4d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer5d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + class default + call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_update_extremum unsupported buffer type') + end select + ELSE + IF ( debug_diag_manager ) THEN + ! Compare bounds {is-hi, ie-hi, js-hj, je-hj, ks, ke} with the bounds of first three dimensions of the buffer + if (compare_two_sets_of_bounds((/is-hi, ie-hi, js-hj, je-hj, ks, ke/), & + (/LBOUND(ptr_buffer,1), UBOUND(ptr_buffer,1), LBOUND(ptr_buffer,2), UBOUND(ptr_buffer,2), & + LBOUND(ptr_buffer,3), UBOUND(ptr_buffer,3)/), err_msg_local)) THEN + IF ( fms_error_handler('fms_diag_object_mod::fms_diag_update_extremum', err_msg_local, err_msg) ) THEN + DEALLOCATE(field_data) + DEALLOCATE(mask) + RETURN + END IF + END IF + END IF + select type (buffer_obj) + type is (outputBuffer0d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer1d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer2d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer3d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer4d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + type is (outputBuffer5d_type) + call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) + class default + call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_update_extremum unsupported buffer type') + end select + END IF + end if + ! Reset counter count_0d of the buffer object + select type (buffer_obj) + type is (outputBuffer0d_type) + select type (outputBuffer0d_type%count_0d) + type is (real(kind=r4_kind)) + outputBuffer0d_type%count_0d(sample) = 1. + type is (real(kind=r8_kind)) + outputBuffer0d_type%count_0d(sample) = 1. + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + end select + type is (outputBuffer1d_type) + select type (outputBuffer1d_type%count_0d) + type is (real(kind=r4_kind)) + outputBuffer1d_type%count_0d(sample) = 1. + type is (real(kind=r8_kind)) + outputBuffer1d_type%count_0d(sample) = 1. + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + end select + type is (outputBuffer2d_type) + select type (outputBuffer2d_type%count_0d) + type is (real(kind=r4_kind)) + outputBuffer2d_type%count_0d(sample) = 1. + type is (real(kind=r8_kind)) + outputBuffer2d_type%count_0d(sample) = 1. + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + end select + type is (outputBuffer3d_type) + select type (outputBuffer3d_type%count_0d) + type is (real(kind=r4_kind)) + outputBuffer3d_type%count_0d(sample) = 1. + type is (real(kind=r8_kind)) + outputBuffer3d_type%count_0d(sample) = 1. + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + end select + type is (outputBuffer4d_type) + select type (outputBuffer4d_type%count_0d) + type is (real(kind=r4_kind)) + outputBuffer4d_type%count_0d(sample) = 1. + type is (real(kind=r8_kind)) + outputBuffer4d_type%count_0d(sample) = 1. + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + end select + type is (outputBuffer5d_type) + select type (outputBuffer5d_type%count_0d) + type is (real(kind=r4_kind)) + outputBuffer5d_type%count_0d(sample) = 1. + type is (real(kind=r8_kind)) + outputBuffer5d_type%count_0d(sample) = 1. + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + end select + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') + end select + end subroutine fms_diag_update_extremum + + !> @brief Updates individual element of buffer + subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_bounds, & + running_indx1, running_indx2) + integer, intent(in) :: flag !< 0 for minimum; 1 for maximum + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + class(*), intent(inout) :: buffer(:,:,:,:,:) !< Remapped output buffer + logical, intent(in) :: mask(:,:,:,:) !< Update mask + integer, intent(in) :: sample !< diurnal sample index + type(fmsDiagBoundsHalos_type), intent(in) :: recon_bounds !< Holds starting and ending indices in the + !! I, J, and K dimensions and + !! halo sizes in the I, and J dimensions + integer, intent(in) :: running_indx1(3) !< Holds indices i, j, and k + integer, intent(in) :: running_indx2(3) !< Holds indices i1, j1, and k1 + + integer :: i, j, k + integer :: i1, j1, k1 + integer :: is, js, ks + integer :: ie, je, ke + integer :: hi, hj + + ! Initialize i, j, and k + i = running_indx1(1) + j = running_indx1(2) + k = running_indx1(3) + + ! Initialize i1, j1, and k1 + i1 = running_indx2(1) + j1 = running_indx2(2) + k1 = running_indx2(3) + + !> Unpack bounds (/is, js, ks, ie, je, ke, hi, f1, f2, hj, f3, f4/) + is = recon_bounds%bounds3D%get_imin() + js = recon_bounds%bounds3D%get_jmin() + ks = recon_bounds%bounds3D%get_kmin() + ie = recon_bounds%bounds3D%get_imax() + je = recon_bounds%bounds3D%get_jmax() + ke = recon_bounds%bounds3D%get_kmax() + hi = recon_bounds%get_hi() + hj = recon_bounds%get_hj() + + ! Select proper type and update the buffer + select type (field_data) + type is (real(kind=r4_kind)) + select type (buffer) + type is (real(kind=r4_kind)) + if (flag .eq. 0) then + ! Update the buffer with the current minimum + where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& + buffer(i1,j1,k1,:,sample)) + buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) + end where + else + ! Update the buffer with the current maximum + where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) >& + buffer(i1,j1,k1,:,sample)) + buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) + end where + end if + class default + call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum type mismatch") + end select + type is (real(kind=r8_kind)) + select type (buffer) + type is (real(kind=r8_kind)) + if (flag .eq. 0) then + ! Update the buffer with the current minimum + where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& + buffer(i1,j1,k1,:,sample)) + buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) + end where + else + ! Update the buffer with the current maximum + where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) >& + buffer(i1,j1,k1,:,sample)) + buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) + end where + end if + class default + call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum type mismatch") + end select + type is (integer(kind=i4_kind)) + select type (buffer) + type is (integer(kind=i4_kind)) + if (flag .eq. 0) then + ! Update the buffer with the current minimum + where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& + buffer(i1,j1,k1,:,sample)) + buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) + end where + else + ! Update the buffer with the current maximum + where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) >& + buffer(i1,j1,k1,:,sample)) + buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) + end where + end if + class default + call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum type mismatch") + end select + type is (integer(kind=i8_kind)) + select type (buffer) + type is (integer(kind=i8_kind)) + if (flag .eq. 0) then + ! Update the buffer with the current minimum + where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& + buffer(i1,j1,k1,:,sample)) + buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) + end where + else + ! Update the buffer with the current maximum + where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) >& + buffer(i1,j1,k1,:,sample)) + buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) + end where + end if + class default + call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum type mismatch") + end select + class default + call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum unsupported field data type") + end select + end subroutine update_scalar_extremum + + !> @brief Updates a chunk of buffer + subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_bounds, reduced_k_range) + integer :: flag !< 0 for minimum; 1 for extremum + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + class(*), intent(inout) :: buffer(:,:,:,:,:) !< Remapped output buffer + logical, intent(in) :: mask(:,:,:,:) !< Updated mask + integer, intent(in) :: sample !< diurnal sample index + type(fmsDiagBoundsHalos_type), intent(in) :: recon_bounds !< Object to hold starting and ending indices + !! in the I, J, and K dimensions; also holds + !! halo sizes in the I, and J dimensions + logical, intent(in) :: reduced_k_range !< Flag indicating if the range in the K dimension is present + + integer :: is, js, ks !< Starting indices in the I, J, and K dimensions + integer :: ie, je, ke !< Ending indices in the I, J, and K dimensions + integer :: hi, hj !< Halo sizes in the I, and J dimensions + integer :: f1, f2 !< Updated starting and ending indices in the I dimension + integer :: f3, f4 !< Updated starting and ending indices in the J dimension + + !> Unpack bounds (/is, js, ks, ie, je, ke, hi, f1, f2, hj, f3, f4/) + is = recon_bounds%bounds3D%get_imin() + js = recon_bounds%bounds3D%get_jmin() + ks = recon_bounds%bounds3D%get_kmin() + ie = recon_bounds%bounds3D%get_imax() + je = recon_bounds%bounds3D%get_jmax() + ke = recon_bounds%bounds3D%get_kmax() + hi = recon_bounds%get_hi() + f1 = recon_bounds%get_fis() + f2 = recon_bounds%get_fie() + hj = recon_bounds%get_hj() + f3 = recon_bounds%get_fjs() + f4 = recon_bounds%get_fje() + + ! Select proper type and update the buffer + select type (field_data) + type is (real(kind=r4_kind)) + select type (buffer) + type is (real(kind=r4_kind)) + if (flag .eq. 0) then + !> Update the buffer with the current minimum + if (reduced_k_range) then + ! recon_bounds must have ks = ksr and ke = ker + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + else + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + end if + else + !> Update the buffer with the current maximum + if (reduced_k_range) then + ! recon_bounds must have ks = ksr and ke = ker + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + else + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:)>& + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + end if + end if + class default + call mpp_error( FATAL, "diag_util_mod::update_array_extremum type mismatch") + end select + type is (real(kind=r8_kind)) + select type (buffer) + type is (real(kind=r8_kind)) + if (flag .eq. 0) then + !> Update the buffer with the current minimum + if (reduced_k_range) then + ! recon_bounds must have ks = ksr and ke = ker + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + else + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + end if + else + !> Update the buffer with the current maximum + if (reduced_k_range) then + ! recon_bounds must have ks = ksr and ke = ker + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + else + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:)>& + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + end if + end if + class default + call mpp_error( FATAL, "diag_util_mod::update_array_extremum type mismatch") + end select + type is (integer(kind=i4_kind)) + select type (buffer) + type is (integer(kind=i4_kind)) + if (flag .eq. 0) then + !> Update the buffer with the current minimum + if (reduced_k_range) then + ! recon_bounds must have ks = ksr and ke = ker + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + else + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + end if + else + !> Update the buffer with the current maximum + if (reduced_k_range) then + ! recon_bounds must have ks = ksr and ke = ker + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + else + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:)>& + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + end if + end if + class default + call mpp_error( FATAL, "diag_util_mod::update_array_extremum type mismatch") + end select + type is (integer(kind=i8_kind)) + select type (buffer) + type is (integer(kind=i8_kind)) + if (flag .eq. 0) then + !> Update the buffer with the current minimum + if (reduced_k_range) then + ! recon_bounds must have ks = ksr and ke = ker + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + else + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + end if + else + !> Update the buffer with the current maximum + if (reduced_k_range) then + ! recon_bounds must have ks = ksr and ke = ker + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:) <& + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + else + WHERE (mask(f1:f2,f3:f4,ks:ke,:) .AND. field_data(f1:f2,f3:f4,ks:ke,:)>& + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & + buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) + end if + end if + class default + call mpp_error( FATAL, "diag_util_mod::update_array_extremum type mismatch") + end select + class default + call mpp_error( FATAL, "diag_util_mod::update_array_extremum unsupported field data type") + end select + end subroutine update_array_extremum +#endif +end module fms_diag_reduction_methods_mod \ No newline at end of file From e2b58e035fe8620ccdd1881653b45fa60507972c Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 10:57:34 -0400 Subject: [PATCH 02/61] Updates Makefile.am, fms_diag_axis_object.F90, and fms_diag_reduction_methods.F90 --- diag_manager/Makefile.am | 3 ++- diag_manager/fms_diag_axis_object.F90 | 10 ++++++---- diag_manager/fms_diag_reduction_methods.F90 | 2 +- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index e442955b33..2dbc7181f0 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -52,7 +52,7 @@ libdiag_manager_la_SOURCES = \ fms_diag_elem_weight_procs.F90 \ fms_diag_fieldbuff_update.F90 \ fms_diag_bbox.F90 \ - fms_diag_reduction_methods_mod \ + fms_diag_reduction_methods.F90 \ include/fms_diag_fieldbuff_update.inc \ include/fms_diag_fieldbuff_update.fh @@ -114,6 +114,7 @@ MODFILES = \ fms_diag_bbox_mod.$(FC_MODEXT) \ fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ + fms_diag_reduction_methods_mod.$(FC_MODEXT) \ include/fms_diag_fieldbuff_update.inc \ include/fms_diag_fieldbuff_update.fh diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 index 62409a0fd0..f83a99791d 100644 --- a/diag_manager/fms_diag_axis_object.F90 +++ b/diag_manager/fms_diag_axis_object.F90 @@ -759,16 +759,18 @@ end subroutine fill_subaxis !> @brief Accesses its member starting_index !! @return Returns a copy of the starting_index - function get_starting_index(this) + function get_starting_index(this) result(indx) class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object - get_starting_index = this%starting_index + integer :: indx !< Result to return + indx = this%starting_index end function get_starting_index !> @brief Accesses its member ending_index !! @return Returns a copy of the ending_index - function get_ending_index(this) + function get_ending_index(this) result(indx) class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object - get_ending_index = this%ending_index + integer :: indx !< Result to return + indx = this%ending_index end function get_ending_index !> @brief Get the ntiles in a domain diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 5381500de3..00c019d10e 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -210,7 +210,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, character(len=*), intent(inout) :: err_msg integer :: is, js, ks !< Starting indices in the I, J, and K dimensions - integer :: ie, je, ke !< Ending indices in the I, J, and K dimensions + integer :: ie, je, ke !< Ending indices in the I, J, and K dimensions integer :: hi, hj !< Halo sizes in the I, and J dimensions integer :: f1, f2 !< Updated starting and ending indices in the I dimension integer :: f3, f4 !< Updated starting and ending indices in the J dimension From dd496afd6eb4a4656d4c78f26bbd031354c28d47 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 11:17:21 -0400 Subject: [PATCH 03/61] Removed a data assignment statement before variable declarations in the routine fms_diag_do_reduction --- diag_manager/fms_diag_object.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index b052717032..3b0b4dbad1 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -1127,8 +1127,6 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight integer, intent(in), optional :: ie_in, je_in, ke_in !< Ending indices of the variable character(len=*), intent(out), optional :: err_msg !< An error message returned logical :: redn_done !< Return flag: .TRUE. if no error occurs - - redn_done = .FALSE. #ifdef use_yaml integer :: buffer_id !< Index of a buffer integer :: file_id !< File id where the field/buffer is in @@ -1160,6 +1158,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight integer :: axis_id !< Axis id type(fmsDiagAxis_type), pointer :: ptr_axis !< Pointer of type diag_axis%axis + redn_done = .FALSE. + !> Recondition the input indices call recondition_indices(bounds_with_halos, field_data, is_in, js_in, ks_in, & ie_in, je_in, ke_in, err_msg=err_msg) From a314839e1595053992eff95057bc195587ca4ae9 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 11:48:11 -0400 Subject: [PATCH 04/61] Updates fms_diag_file_object_mod and fms_diag_object_mod --- diag_manager/fms_diag_file_object.F90 | 36 +++++++++++++++++++++++++++ diag_manager/fms_diag_object.F90 | 3 ++- 2 files changed, 38 insertions(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index 62f01f7fe0..e145c7b192 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -127,6 +127,10 @@ module fms_diag_file_object_mod procedure, public :: get_file_duration_units procedure, public :: get_file_varlist procedure, public :: get_file_global_meta + procedure, public :: get_last_output + procedure, public :: get_next_output + procedure, public :: get_next_next_output + procedure, public :: get_no_more_data procedure, public :: has_file_fname procedure, public :: has_file_frequnit procedure, public :: has_file_freq @@ -543,6 +547,38 @@ pure function get_file_global_meta (this) result(res) res = this%diag_yaml_file%get_file_global_meta() end function get_file_global_meta +!> \brief Gets last_output time +!! \return Copy of last_output time +pure function get_last_output (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + type(time_type) :: res + res = this%last_output +end function get_last_output + +!> \brief Gets next_output time +!! \return Copy of next_output time +pure function get_next_output (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + type(time_type) :: res + res = this%next_output +end function get_next_output + +!> \brief Gets next_next_output time +!! \return Copy of next_next_output time +pure function get_next_next_output (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + type(time_type) :: res + res = this%next_next_output +end function get_next_next_output + +!> \brief Gets no_more_data time +!! \return Copy of no_more_data time +pure function get_no_more_data (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + type(time_type) :: res + res = this%no_more_data +end function get_no_more_data + !> \brief Checks if file_fname is allocated in the yaml object !! \return true if file_fname is allocated pure function has_file_fname (this) result(res) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 3b0b4dbad1..ce3db1d2e1 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -37,6 +37,7 @@ module fms_diag_object_mod use fms_diag_output_buffer_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY +use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type #endif #if defined(_OPENMP) use omp_lib @@ -1201,7 +1202,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight !> If sub regional output, get starting and ending indices if (is_regional) then if (allocated(this%FMS_diag_output_buffers(buffer_id)%axis_ids)) then - n_axis = size(this%FMS_diag_output_buffers(buffer_id)%axis_ids()) + n_axis = size(this%FMS_diag_output_buffers(buffer_id)%axis_ids) allocate(l_start(n)) allocate(l_end(n)) do j = 1, n_axis From b3b0e3c16d17209dc92c29c94e36ab2c9621f77f Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 12:04:33 -0400 Subject: [PATCH 05/61] Updates fms_diag_bbox_mod and fms_diag_object_mod --- diag_manager/fms_diag_bbox.F90 | 2 +- diag_manager/fms_diag_object.F90 | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index c5e2ec1150..c23e6ff0e7 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -67,7 +67,7 @@ MODULE fms_diag_bbox_mod !! in I and J dimensions. type, public :: fmsDiagBoundsHalos_type private - type(fmsDiagIbounds_type) :: bounds3D !< Holds starting and ending indices of + type(fmsDiagIbounds_type), public :: bounds3D !< Holds starting and ending indices of !! the I, J, and K dimensions integer :: hi !< Halo size in the I dimension integer :: hj !< Halo size in the J dimension diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index ce3db1d2e1..c9ba23bcac 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -20,7 +20,7 @@ module fms_diag_object_mod use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, & - &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered + &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered, EVERY_TIME USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & @@ -37,6 +37,8 @@ module fms_diag_object_mod use fms_diag_output_buffer_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY +use fms_diag_time_reduction_mod, only: time_none, time_average, time_min, time_max, time_rms, & + time_sum, time_diurnal, time_power use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type #endif #if defined(_OPENMP) From 773aca2b4c6dc6ab76d192649b5bc91a95fdd526 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 14:02:37 -0400 Subject: [PATCH 06/61] Updates Makefile.am and fms_diag_object_mod --- diag_manager/Makefile.am | 2 +- diag_manager/fms_diag_object.F90 | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 2dbc7181f0..28caf110f5 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -68,7 +68,7 @@ fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ fms_diag_time_utils_mod.$(FC_MODEXT) \ fms_diag_output_buffer_mod.$(FC_MODEXT) -# fms_diag_reduction_methods_mod.$(FC_MODEXT) + fms_diag_reduction_methods_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_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) \ diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index c9ba23bcac..854c8ade4e 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -39,7 +39,7 @@ module fms_diag_object_mod use constants_mod, only: SECONDS_PER_DAY use fms_diag_time_reduction_mod, only: time_none, time_average, time_min, time_max, time_rms, & time_sum, time_diurnal, time_power -use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type +use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices #endif #if defined(_OPENMP) use omp_lib @@ -1205,8 +1205,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight if (is_regional) then if (allocated(this%FMS_diag_output_buffers(buffer_id)%axis_ids)) then n_axis = size(this%FMS_diag_output_buffers(buffer_id)%axis_ids) - allocate(l_start(n)) - allocate(l_end(n)) + allocate(l_start(n_axis)) + allocate(l_end(n_axis)) do j = 1, n_axis ptr_axis => this%diag_axis(this%FMS_diag_output_buffers(buffer_id)%axis_ids(j))%axis select type (ptr_axis) @@ -1231,8 +1231,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight select type (ptr_axis) type is (fmsDiagSubAxis_type) if (ptr_axis%is_unstructured_grid()) then - bounds_with_halos%bounds3D%jmin = ptr_axis%get_starting_index() - bounds_with_halos%bounds3D%jmin = ptr_axis%get_ending_index() + bounds_with_halos%bounds3D%set_jbounds(ptr_axis%get_starting_index(), & + ptr_axis%get_ending_index()) end if l_start(3) = ptr_axis%get_starting_index() l_end(3) = ptr_axis%get_ending_index() From 0207a986b094192938e4107704e7c3366c12a201 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 14:15:09 -0400 Subject: [PATCH 07/61] Updates Makefile.am --- diag_manager/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 28caf110f5..898c0c7236 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -67,7 +67,7 @@ diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEX fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \ fms_diag_time_utils_mod.$(FC_MODEXT) \ - fms_diag_output_buffer_mod.$(FC_MODEXT) + fms_diag_output_buffer_mod.$(FC_MODEXT) \ fms_diag_reduction_methods_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) From ffec2bea24b3dedcd7138199662ebdfef5718907 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 14:22:44 -0400 Subject: [PATCH 08/61] Updates fms_diag_reduction_methods_mod --- diag_manager/fms_diag_reduction_methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 00c019d10e..ebac4649ef 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -7,8 +7,8 @@ module fms_diag_reduction_methods_mod use platform_mod use fms_mod, only: fms_error_handler - !use fms_diag_bbox_mod - !use fms_diag_output_buffer_mod + use fms_diag_bbox_mod + use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_class implicit none private From 0f79a5b75bf6165787204770c92d821abbbba46c Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 14:44:41 -0400 Subject: [PATCH 09/61] Updates fms_diag_object_mod and fms_diag_reduction_methods_mod --- diag_manager/fms_diag_object.F90 | 8 +++++--- diag_manager/fms_diag_reduction_methods.F90 | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 854c8ade4e..4443653a27 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,6 +40,7 @@ module fms_diag_object_mod use fms_diag_time_reduction_mod, only: time_none, time_average, time_min, time_max, time_rms, & time_sum, time_diurnal, time_power use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices +use fms_diag_reduction_methods_mod, only: check_indices_order #endif #if defined(_OPENMP) use omp_lib @@ -1160,11 +1161,12 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight integer :: n_axis !< Number of axes integer :: axis_id !< Axis id type(fmsDiagAxis_type), pointer :: ptr_axis !< Pointer of type diag_axis%axis + logical :: ierr !< Error flag redn_done = .FALSE. !> Recondition the input indices - call recondition_indices(bounds_with_halos, field_data, is_in, js_in, ks_in, & + ierr = recondition_indices(bounds_with_halos, field_data, is_in, js_in, ks_in, & ie_in, je_in, ke_in, err_msg=err_msg) do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids) @@ -1291,10 +1293,10 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight !! TODO: root-mean-square error case (time_max) call fms_diag_update_extremum(1, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & - l_end, is_regional, reduced_k_range, sample, oor_mask, field_name, has_diurnal_axis, err_msg=err_msg) + l_end, is_regional, reduced_k_range, sample, oor_mask, field_name, has_diurnal_axis, err_msg) case (time_min) call fms_diag_update_extremum(0, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & - l_end, is_regional, reduced_k_range, sample, oor_mask, field_name, has_diurnal_axis, err_msg=err_msg) + l_end, is_regional, reduced_k_range, sample, oor_mask, field_name, has_diurnal_axis, err_msg) case (time_sum) !! TODO: sum for the interval !! call fms_diag_sum(time_sum, .......) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index ebac4649ef..e2b82dc552 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -8,12 +8,12 @@ module fms_diag_reduction_methods_mod use platform_mod use fms_mod, only: fms_error_handler use fms_diag_bbox_mod - use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_class implicit none private #ifdef use_yaml + use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_class public :: compare_two_sets_of_bounds, real_copy_set, check_indices_order, init_mask_3d contains From a996ce234298eeb1acd80788b36a3a5da0dfb996 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 15:18:40 -0400 Subject: [PATCH 10/61] Updates fms_diag_reduction_methods_mod --- diag_manager/fms_diag_reduction_methods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index e2b82dc552..93cee49cf2 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -8,12 +8,12 @@ module fms_diag_reduction_methods_mod use platform_mod use fms_mod, only: fms_error_handler use fms_diag_bbox_mod + use fms_diag_output_buffer_mod implicit none private #ifdef use_yaml - use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_class public :: compare_two_sets_of_bounds, real_copy_set, check_indices_order, init_mask_3d contains From 24d664a8ffc2c04360eef12e66fe1497648cd8b0 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 15:24:16 -0400 Subject: [PATCH 11/61] Updates fms_diag_object.F90 --- diag_manager/fms_diag_object.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 4443653a27..d6af15a25b 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,7 +40,7 @@ module fms_diag_object_mod use fms_diag_time_reduction_mod, only: time_none, time_average, time_min, time_max, time_rms, & time_sum, time_diurnal, time_power use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices -use fms_diag_reduction_methods_mod, only: check_indices_order +use fms_diag_reduction_methods_mod #endif #if defined(_OPENMP) use omp_lib From 8cbab45af3591c124e73b5ee7582d67d0c4e65bc Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Tue, 18 Jul 2023 15:28:47 -0400 Subject: [PATCH 12/61] Update fms_diag_object.F90 and fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_object.F90 | 2 +- diag_manager/fms_diag_reduction_methods.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index d6af15a25b..ad9e8e912c 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -1233,7 +1233,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight select type (ptr_axis) type is (fmsDiagSubAxis_type) if (ptr_axis%is_unstructured_grid()) then - bounds_with_halos%bounds3D%set_jbounds(ptr_axis%get_starting_index(), & + call bounds_with_halos%bounds3D%set_jbounds(ptr_axis%get_starting_index(), & ptr_axis%get_ending_index()) end if l_start(3) = ptr_axis%get_starting_index() diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 93cee49cf2..7f328cbc20 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -278,7 +278,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, END DO ELSE IF (reduced_k_range) THEN - recon_bounds%bounds3D%set_kbounds(l_start(3), l_end(3)) + call recon_bounds%bounds3D%set_kbounds(l_start(3), l_end(3)) select type (buffer_obj) type is (outputBuffer0d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) From ab9c56ff988e52ad838863f142c748cae04463c4 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 09:50:03 -0400 Subject: [PATCH 13/61] Updates fms_diag_update_extremum_mod --- diag_manager/fms_diag_reduction_methods.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 7f328cbc20..64ee67cbe7 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -329,11 +329,11 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, ! Reset counter count_0d of the buffer object select type (buffer_obj) type is (outputBuffer0d_type) - select type (outputBuffer0d_type%count_0d) + select type (buffer_obj%count_0d) type is (real(kind=r4_kind)) - outputBuffer0d_type%count_0d(sample) = 1. + buffer_obj%count_0d(sample) = 1. type is (real(kind=r8_kind)) - outputBuffer0d_type%count_0d(sample) = 1. + buffer_obj%count_0d(sample) = 1. class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') end select From 24c62514d45fd3d3c588588e63b4218bbbc6aa2c Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 10:05:27 -0400 Subject: [PATCH 14/61] Updates fms_diag_update_extremum_mod --- diag_manager/fms_diag_reduction_methods.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 64ee67cbe7..d51d6f6f83 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -329,11 +329,11 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, ! Reset counter count_0d of the buffer object select type (buffer_obj) type is (outputBuffer0d_type) - select type (buffer_obj%count_0d) + select type (realtype => buffer_obj%count_0d) type is (real(kind=r4_kind)) - buffer_obj%count_0d(sample) = 1. + realtype(sample) = 1. type is (real(kind=r8_kind)) - buffer_obj%count_0d(sample) = 1. + realtype(sample) = 1. class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') end select From d74666cd445d3f06667e541daacde33015d8ae8c Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 10:21:17 -0400 Subject: [PATCH 15/61] Updates fms_diag_update_extremum_mod --- diag_manager/fms_diag_reduction_methods.F90 | 36 ++++++++++----------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index d51d6f6f83..9b4e15d78b 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -329,56 +329,56 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, ! Reset counter count_0d of the buffer object select type (buffer_obj) type is (outputBuffer0d_type) - select type (realtype => buffer_obj%count_0d) + select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - realtype(sample) = 1. + real_counter(sample) = 1.0_r4_kind type is (real(kind=r8_kind)) - realtype(sample) = 1. + real_counter(sample) = 1.0_r8_kind class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') end select type is (outputBuffer1d_type) - select type (outputBuffer1d_type%count_0d) + select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - outputBuffer1d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r4_kind type is (real(kind=r8_kind)) - outputBuffer1d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r8_kind class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') end select type is (outputBuffer2d_type) - select type (outputBuffer2d_type%count_0d) + select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - outputBuffer2d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r4_kind type is (real(kind=r8_kind)) - outputBuffer2d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r8_kind class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') end select type is (outputBuffer3d_type) - select type (outputBuffer3d_type%count_0d) + select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - outputBuffer3d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r4_kind type is (real(kind=r8_kind)) - outputBuffer3d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r8_kind class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') end select type is (outputBuffer4d_type) - select type (outputBuffer4d_type%count_0d) + select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - outputBuffer4d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r4_kind type is (real(kind=r8_kind)) - outputBuffer4d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r8_kind class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') end select type is (outputBuffer5d_type) - select type (outputBuffer5d_type%count_0d) + select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - outputBuffer5d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r4_kind type is (real(kind=r8_kind)) - outputBuffer5d_type%count_0d(sample) = 1. + real_counter(sample) = 1.0_r8_kind class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') end select From 158055e5eb017e3558ea24b7c5bc0292276eed05 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 11:06:49 -0400 Subject: [PATCH 16/61] Updates fms_diag_update_extremum_mod --- diag_manager/fms_diag_reduction_methods.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 9b4e15d78b..ce81f7d2e7 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -9,6 +9,7 @@ module fms_diag_reduction_methods_mod use fms_mod, only: fms_error_handler use fms_diag_bbox_mod use fms_diag_output_buffer_mod + use diag_util_mod, only: debug_diag_manager implicit none private @@ -302,8 +303,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, (/LBOUND(ptr_buffer,1), UBOUND(ptr_buffer,1), LBOUND(ptr_buffer,2), UBOUND(ptr_buffer,2), & LBOUND(ptr_buffer,3), UBOUND(ptr_buffer,3)/), err_msg_local)) THEN IF ( fms_error_handler('fms_diag_object_mod::fms_diag_update_extremum', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_data) - DEALLOCATE(mask) + if (associated(field_data)) deallocate(field_data) + if (allocated(mask)) deallocate(mask) RETURN END IF END IF From 345f2f9813d104fcb6a2746678fb23894c285f3d Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 11:42:43 -0400 Subject: [PATCH 17/61] Updates Makefile.am in diag_manager --- diag_manager/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 898c0c7236..7d061371ed 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -90,6 +90,7 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_reduction_methods_mod.$(FC_MODEXT): diag_util_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ From aeb95fec16511c583d2b82319f2937e8dc64e713 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 14:11:34 -0400 Subject: [PATCH 18/61] Updates CMakeLists.txt, diag_manager/Makefile.am, fms_diag_object.F90, fms_diag_reduction_methods.F90 --- CMakeLists.txt | 1 + diag_manager/Makefile.am | 3 ++- diag_manager/fms_diag_object.F90 | 12 ++++++++---- diag_manager/fms_diag_reduction_methods.F90 | 2 +- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 6f7c9ed261..3aa01dccdb 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -139,6 +139,7 @@ list(APPEND fms_fortran_src_files diag_manager/fms_diag_elem_weight_procs.F90 diag_manager/fms_diag_fieldbuff_update.F90 diag_manager/fms_diag_bbox.F90 + diag_manager/fms_diag_reduction_methods.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 7d061371ed..c14b64ee26 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -90,7 +90,8 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) -fms_diag_reduction_methods_mod.$(FC_MODEXT): diag_util_mod.$(FC_MODEXT) +fms_diag_reduction_methods_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT) \ + diag_data_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index ad9e8e912c..a437e71a81 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -530,9 +530,6 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is return end if - !> Allocate buffers of this field variable - call allocate_diag_field_output_buffers(field_data, diag_field_id) - !> Does the user want to push off calculations until send_diag_complete? buffer_the_data = .false. !> initialize the number of threads and level to be 0 @@ -569,7 +566,10 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is fms_diag_accept_data = .TRUE. return else -!!TODO: Loop through fields and do averages/math functions + !> Allocate buffers of this field variable + call allocate_diag_field_output_buffers(field_data, diag_field_id) + + !> Do time reductions (average, min, max, rms error, sum, etc.) fms_diag_accept_data = fms_diag_do_reduction(field_data, diag_field_id, oor_mask, weight, & time, is_in, js_in, ks_in, ie_in, je_in, ke_in, err_msg) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) @@ -1185,6 +1185,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight reduction_method = this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_reduction() has_diurnal_axis = this%FMS_diag_fields(diag_field_id)%diag_field(i)%has_n_diurnal() field_name = this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_fname() + reduced_k_range = this%FMS_diag_fields(diag_field_id)%diag_field(i)%has_var_zbounds() if (this%FMS_diag_fields(diag_field_id)%diag_field(i)%has_pow_value()) THEN pow_val = this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_pow_value() @@ -1215,6 +1216,9 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight type is (fmsDiagSubAxis_type) l_start(j) = ptr_axis%get_starting_index() l_end(j) = ptr_axis%get_ending_index() + type is (fmsDiagFullAxis_type) + l_start(j) = 1 + l_end(j) = ptr_axis%axis_length() class default call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_do_reduction non fmsDiagSubAxis_type axis') end select diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index ce81f7d2e7..090f739ba2 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -9,7 +9,7 @@ module fms_diag_reduction_methods_mod use fms_mod, only: fms_error_handler use fms_diag_bbox_mod use fms_diag_output_buffer_mod - use diag_util_mod, only: debug_diag_manager + use diag_data_mod, only: debug_diag_manager implicit none private From 2be3a657e8bb3196ff1c564ff7765c04cd5283eb Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 14:43:02 -0400 Subject: [PATCH 19/61] Updates error strings in fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 44 ++++++++++----------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 090f739ba2..4bda20ee04 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -30,11 +30,11 @@ LOGICAL FUNCTION compare_two_sets_of_bounds(bounds_a, bounds_b, error_str) if (size(bounds_a) .ne. size(bounds_b)) then compare_two_sets_of_bounds = .TRUE. - error_str = 'diag_util_mod::compare_two_sets_of_bounds Error: sizes of sets do not match' + error_str = 'fms_diag_reduction_methods_mod::compare_two_sets_of_bounds Error: sizes of sets do not match' else if ((size(bounds_a) .ne. 6) .and. (size(bounds_b) .ne. 6)) then compare_two_sets_of_bounds = .TRUE. - error_str = 'diag_util_mod::compare_two_sets_of_bounds Error: sizes of sets must be 6' + error_str = 'fms_diag_reduction_methods_mod::compare_two_sets_of_bounds Error: sizes of sets must be 6' end if end if @@ -83,7 +83,7 @@ function check_indices_order(is_in, ie_in, js_in, je_in, error_msg) result(rslt) rslt = .false. !< If no error occurs. - err_module_name = 'diag_util_mod:check_indices_order' + err_module_name = 'fms_diag_reduction_methods_mod::check_indices_order' IF ( PRESENT(ie_in) ) THEN IF ( .NOT.PRESENT(is_in) ) THEN @@ -128,7 +128,7 @@ subroutine real_copy_set(out_data, in_data, val, err_msg) TYPE IS (real(kind=r8_kind)) out_data = real(in_data) CLASS DEFAULT - if (fms_error_handler('diag_util_mod:real_copy_set',& + if (fms_error_handler('fms_diag_reduction_methods_mod::real_copy_set',& & 'The in_data is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) THEN return end if @@ -164,7 +164,7 @@ subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg) 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 + if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d', trim(err_msg_local), err_msg)) then return end if END IF @@ -184,7 +184,7 @@ subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg) 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',& + if (fms_error_handler('fms_diag_reduction_methods_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 @@ -235,7 +235,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, f4 = recon_bounds%get_fje() if (flag .ne. 0 .and. flag .ne. 1) then - call mpp_error( FATAL, "fms_diag_object_mod::fms_diag_update_extremum: flag must be either 0 or 1.") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::fms_diag_update_extremum: flag must be either 0 or 1.") end if !! TODO: remap buffer before passing to subroutines update_scalar_extremum and update_array_extremum @@ -271,7 +271,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, call update_scalar_extremum(flag, field_data, ptr_buffer, mask, sample, & recon_bounds, (/i,j,k/), (/i1,j1,k1/)) class default - call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_update_extremum unsupported buffer type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') end select end if END DO @@ -294,7 +294,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer5d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) class default - call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_update_extremum unsupported buffer type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') end select ELSE IF ( debug_diag_manager ) THEN @@ -303,8 +303,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, (/LBOUND(ptr_buffer,1), UBOUND(ptr_buffer,1), LBOUND(ptr_buffer,2), UBOUND(ptr_buffer,2), & LBOUND(ptr_buffer,3), UBOUND(ptr_buffer,3)/), err_msg_local)) THEN IF ( fms_error_handler('fms_diag_object_mod::fms_diag_update_extremum', err_msg_local, err_msg) ) THEN - if (associated(field_data)) deallocate(field_data) - if (allocated(mask)) deallocate(mask) + !if (associated(field_data)) deallocate(field_data) + !if (allocated(mask)) deallocate(mask) RETURN END IF END IF @@ -323,7 +323,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer5d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) class default - call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_update_extremum unsupported buffer type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') end select END IF end if @@ -447,7 +447,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ end where end if class default - call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum type mismatch") end select type is (real(kind=r8_kind)) select type (buffer) @@ -466,7 +466,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ end where end if class default - call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum type mismatch") end select type is (integer(kind=i4_kind)) select type (buffer) @@ -485,7 +485,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ end where end if class default - call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum type mismatch") end select type is (integer(kind=i8_kind)) select type (buffer) @@ -504,10 +504,10 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ end where end if class default - call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum type mismatch") end select class default - call mpp_error( FATAL, "diag_util_mod::update_scalar_extremum unsupported field data type") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum unsupported field data type") end select end subroutine update_scalar_extremum @@ -574,7 +574,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b end if end if class default - call mpp_error( FATAL, "diag_util_mod::update_array_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum type mismatch") end select type is (real(kind=r8_kind)) select type (buffer) @@ -605,7 +605,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b end if end if class default - call mpp_error( FATAL, "diag_util_mod::update_array_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum type mismatch") end select type is (integer(kind=i4_kind)) select type (buffer) @@ -636,7 +636,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b end if end if class default - call mpp_error( FATAL, "diag_util_mod::update_array_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum type mismatch") end select type is (integer(kind=i8_kind)) select type (buffer) @@ -667,10 +667,10 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b end if end if class default - call mpp_error( FATAL, "diag_util_mod::update_array_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum type mismatch") end select class default - call mpp_error( FATAL, "diag_util_mod::update_array_extremum unsupported field data type") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum unsupported field data type") end select end subroutine update_array_extremum #endif From 6f89cf1897745b43b39ce3858fb1438f4682d221 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 14:59:32 -0400 Subject: [PATCH 20/61] Update fms_diag_object.F90 and fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_object.F90 | 6 +++--- diag_manager/fms_diag_reduction_methods.F90 | 3 ++- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index a437e71a81..a86d436952 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -20,7 +20,9 @@ module fms_diag_object_mod use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, & - &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered, EVERY_TIME + &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered, EVERY_TIME, & + time_none, time_average, time_min, time_max, time_rms, time_sum, & + time_diurnal, time_power USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & @@ -37,8 +39,6 @@ module fms_diag_object_mod use fms_diag_output_buffer_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY -use fms_diag_time_reduction_mod, only: time_none, time_average, time_min, time_max, time_rms, & - time_sum, time_diurnal, time_power use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices use fms_diag_reduction_methods_mod #endif diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 4bda20ee04..322f4fc3a9 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -271,7 +271,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, call update_scalar_extremum(flag, field_data, ptr_buffer, mask, sample, & recon_bounds, (/i,j,k/), (/i1,j1,k1/)) class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum & + unsupported buffer type') end select end if END DO From 272180586473642fc2da5fa358a559ac1846b5f7 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 15:11:31 -0400 Subject: [PATCH 21/61] Updates fms_diag_object.F90 --- diag_manager/fms_diag_object.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index a86d436952..efefa2d92a 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -570,7 +570,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is call allocate_diag_field_output_buffers(field_data, diag_field_id) !> Do time reductions (average, min, max, rms error, sum, etc.) - fms_diag_accept_data = fms_diag_do_reduction(field_data, diag_field_id, oor_mask, weight, & + fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, weight, & time, is_in, js_in, ks_in, ie_in, je_in, ke_in, err_msg) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) fms_diag_accept_data = .TRUE. @@ -1265,7 +1265,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& &//trim(error_string)//', time must be present when output frequency = EVERY_TIME', err_msg)) then - if (associated(field_data)) deallocate(field_data) + !if (associated(field_data)) deallocate(field_data) end if end if end if @@ -1277,7 +1277,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight & trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& &//trim(error_string)//', time must be present for nonstatic field', err_msg)) then - if (associated(field_data)) deallocate(field_data) + !if (associated(field_data)) deallocate(field_data) return end if end if From a115651f888cde2d4db9d4f21101f32bf3d649bc Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 15:38:05 -0400 Subject: [PATCH 22/61] Updates fms_diag_object.F90 and fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_object.F90 | 10 +++++----- diag_manager/fms_diag_reduction_methods.F90 | 11 +++++------ 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index efefa2d92a..4c7ca4a9fa 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -515,9 +515,9 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is if (present(rmask)) then select type (rmask) type is (real(kind=r4_kind)) - call init_mask_3d(field_data, oor_mask, rmask_threshold=0.5_r4_kind, inmask=mask, rmask=rmask) + call init_mask_3d(field_data, oor_mask, 0.5_r4_kind, mask, rmask) type is (real(kind=r8_kind)) - call init_mask_3d(field_data, oor_mask, rmask_threshold=0.5_r8_kind, inmask=mask, rmask=rmask) + call init_mask_3d(field_data, oor_mask, 0.5_r8_kind, mask, rmask) class default call mpp_error(FATAL, "fms_diag_object_mod::fms_diag_accept_data unsupported type") end select @@ -567,7 +567,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is return else !> Allocate buffers of this field variable - call allocate_diag_field_output_buffers(field_data, diag_field_id) + call this%allocate_diag_field_output_buffers(field_data, diag_field_id) !> Do time reductions (average, min, max, rms error, sum, etc.) fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, weight, & @@ -1121,12 +1121,12 @@ end function fms_diag_compare_window !> @return .True. if no error occurs. function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, & time, is_in, js_in, ks_in, ie_in, je_in, ke_in, err_msg) result(redn_done) - class(fmsDiagObject_type), intent(in) :: this !< Diag Object + class(fmsDiagObject_type), intent(in), target :: this !< Diag Object class(*), intent(in) :: field_data(:,:,:,:) !< Field data integer, intent(in) :: diag_field_id !< ID of the input field logical, intent(in) :: oor_mask(:,:,:) !< Out of range mask real, intent(in) :: weight !< Must be a updated weight - integer, intent(in), optional :: time !< Current time + type(time_type), intent(in), optional :: time !< Current time integer, intent(in), optional :: is_in, js_in, ks_in !< Starting indices of the variable integer, intent(in), optional :: ie_in, je_in, ke_in !< Ending indices of the variable character(len=*), intent(out), optional :: err_msg !< An error message returned diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 322f4fc3a9..5627b84669 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -138,14 +138,15 @@ subroutine real_copy_set(out_data, in_data, val, err_msg) END IF end subroutine real_copy_set - !> @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. + !> @brief Allocates `outmask'(second argument) with sizes of the first three dimensions of + !! the field(first argument). + !! Initializes the `outmask' depending on presence/absence of `inmask' and `rmask'. + !! Uses `rmask_threshold' to set the `outmask'. 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 + real, intent(in) :: 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 @@ -179,10 +180,8 @@ subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg) 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('fms_diag_reduction_methods_mod::init_mask_3d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) then From da591056ca48b078a9eabff6744eb73e77f3f904 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 15:58:21 -0400 Subject: [PATCH 23/61] Updates fms_diag_object.F90 and fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_object.F90 | 6 +++--- diag_manager/fms_diag_reduction_methods.F90 | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 4c7ca4a9fa..df6282cb96 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -525,8 +525,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is !> Check improper combinations of is, ie, js, and je. if (check_indices_order(is_in, ie_in, js_in, je_in, err_msg)) then - if (associated(field_data)) deallocate(field_data) - if (allocated(oor_mask)) deallocate(oor_mask) + !if (associated(field_data)) deallocate(field_data) + !if (allocated(oor_mask)) deallocate(oor_mask) return end if @@ -1160,7 +1160,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight integer :: i, j !< For looping integer :: n_axis !< Number of axes integer :: axis_id !< Axis id - type(fmsDiagAxis_type), pointer :: ptr_axis !< Pointer of type diag_axis%axis + class(fmsDiagAxis_type), pointer :: ptr_axis !< Pointer of type diag_axis%axis logical :: ierr !< Error flag redn_done = .FALSE. diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 5627b84669..80b0744474 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -146,7 +146,7 @@ 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(in) :: rmask_threshold !< Holds the values 0.5_r4_kind or 0.5_r8_kind, or related threhold values + class(*), intent(in) :: 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 From 8c14131884ff1c7782305822bc8a047ddfc692bd Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 16:08:20 -0400 Subject: [PATCH 24/61] Updates fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 80b0744474..3fd8bbba7f 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -179,9 +179,9 @@ subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg) IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) - WHERE (rmask < real(rmask_threshold, kind=r4_kind)) outmask = .FALSE. + WHERE (rmask < rmask_threshold) outmask = .FALSE. TYPE IS (real(kind=r8_kind)) - WHERE ( rmask < real(rmask_threshold, kind=r8_kind) ) outmask = .FALSE. + WHERE (rmask < rmask_threshold) outmask = .FALSE. CLASS DEFAULT if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) then From 823a25c77aba6962a974e3c3e65077ed959cd6f7 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 17:21:14 -0400 Subject: [PATCH 25/61] Updates fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 3fd8bbba7f..cd14bfd8e9 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -179,9 +179,9 @@ subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg) IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) - WHERE (rmask < rmask_threshold) outmask = .FALSE. + WHERE (rmask < rmask_threshold(kind=r4_kind)) outmask = .FALSE. TYPE IS (real(kind=r8_kind)) - WHERE (rmask < rmask_threshold) outmask = .FALSE. + WHERE (rmask < rmask_threshold(kind=r8_kind)) outmask = .FALSE. CLASS DEFAULT if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) then From a473284088204094504cea1387fe0605d68d70f6 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 17:29:58 -0400 Subject: [PATCH 26/61] Updates fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index cd14bfd8e9..22fb24b39f 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -179,9 +179,9 @@ subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg) IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) - WHERE (rmask < rmask_threshold(kind=r4_kind)) outmask = .FALSE. + WHERE (rmask < real(rmask_threshold, king=r4_kind)) outmask = .FALSE. TYPE IS (real(kind=r8_kind)) - WHERE (rmask < rmask_threshold(kind=r8_kind)) outmask = .FALSE. + WHERE (rmask < real(rmask_threshold, kind=r8_kind)) outmask = .FALSE. CLASS DEFAULT if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) then From 5e029ab70598da42901d99145ffeafb5e5d46362 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 18:33:22 -0400 Subject: [PATCH 27/61] Updates fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 22fb24b39f..539c98bf58 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -179,12 +179,27 @@ subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg) IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) - WHERE (rmask < real(rmask_threshold, king=r4_kind)) outmask = .FALSE. + select type (rmask_threshold) + type is (real(kind=r4_kind)) + WHERE (rmask < rmask_threshold) outmask = .FALSE. + class default + if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d', 'type mismatch', err_msg)) then + return + end if + end select TYPE IS (real(kind=r8_kind)) - WHERE (rmask < real(rmask_threshold, kind=r8_kind)) outmask = .FALSE. + select type (rmask_threshold) + type is (real(kind=r8_kind)) + WHERE (rmask < rmask_threshold) outmask = .FALSE. + class default + if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d', 'type mismatch', err_msg)) then + return + end if + end select CLASS DEFAULT if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) then + return end if END SELECT END IF From 4fe328f1f892fc8ba4594b3459af53a831192ad5 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 18:54:24 -0400 Subject: [PATCH 28/61] Fixes mismatch argument type(weight) in routine fms_diag_do_reduction --- diag_manager/fms_diag_object.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index df6282cb96..23504ff3d1 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -570,7 +570,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is call this%allocate_diag_field_output_buffers(field_data, diag_field_id) !> Do time reductions (average, min, max, rms error, sum, etc.) - fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, weight, & + fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, weight2, & time, is_in, js_in, ks_in, ie_in, je_in, ke_in, err_msg) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) fms_diag_accept_data = .TRUE. From 9c024f830ddb697aedd3215fd72a87487033e76f Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 19:10:07 -0400 Subject: [PATCH 29/61] Updates fms_diag_object_mod --- diag_manager/fms_diag_object.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 23504ff3d1..4658ef1253 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,15 +40,13 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices -use fms_diag_reduction_methods_mod +use fms_diag_reduction_methods_mod, only: fms_diag_update_extremum #endif #if defined(_OPENMP) use omp_lib #endif use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d use platform_mod -!use fms_diag_bbox_mod -!use fms_diag_reduction_methods_mod, only: fms_diag_update_extremum implicit none private From d6f242d194fca15256ba60d2730e868f103455c0 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Wed, 19 Jul 2023 19:25:14 -0400 Subject: [PATCH 30/61] Updates fms_diag_object_mod --- diag_manager/fms_diag_object.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 4658ef1253..39dcad91a7 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,7 +40,7 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices -use fms_diag_reduction_methods_mod, only: fms_diag_update_extremum +use fms_diag_reduction_methods_mod #endif #if defined(_OPENMP) use omp_lib @@ -507,7 +507,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is !> Input weight is for time averaging where each time level may have a different weight. !! The input weight is polymorphic in intrinsic real types. If it is present it will be !! assigned to weight2 else weight2 gets val value. - call real_copy_set(weight2, in_data=weight, val=1., err_msg=err_msg) + call real_copy_set(weight2, weight, 1., err_msg) !> oor_mask is only used for checking out of range values. if (present(rmask)) then From 0e55996632e0225fe24d948fce2f2fd6ced3d036 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Thu, 20 Jul 2023 07:30:16 -0400 Subject: [PATCH 31/61] Updates fms_diag_reduction_methods_mod --- diag_manager/fms_diag_reduction_methods.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 539c98bf58..82efa1d5a0 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -16,6 +16,7 @@ module fms_diag_reduction_methods_mod #ifdef use_yaml public :: compare_two_sets_of_bounds, real_copy_set, check_indices_order, init_mask_3d + public :: fms_diag_update_extremum, update_scalar_extremum, update_array_extremum contains !> @brief Compares the corresponding bounding indices of the first set with the second set. From 4e69ad7c179bf627bff4b18d25397683879846ea Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Thu, 20 Jul 2023 07:57:36 -0400 Subject: [PATCH 32/61] Fixes mismatch rank of an argument passed to routine fms_diag_update_extremum in fms_diag_update_extremum --- diag_manager/fms_diag_object.F90 | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 39dcad91a7..9fb5ac4b34 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -1160,12 +1160,19 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight integer :: axis_id !< Axis id class(fmsDiagAxis_type), pointer :: ptr_axis !< Pointer of type diag_axis%axis logical :: ierr !< Error flag + logical, pointer :: oor_mask_4d(:,:,:,:) !< Remapped out-of-range mask oor_mask redn_done = .FALSE. !> Recondition the input indices ierr = recondition_indices(bounds_with_halos, field_data, is_in, js_in, ks_in, & - ie_in, je_in, ke_in, err_msg=err_msg) + ie_in, je_in, ke_in, err_msg) + if (ierr) return + + !> Remap oor_mask to 4D array + oor_mask_4d => null() + oor_mask_4d(LBOUND(oor_mask,1):UBOUND(oor_mask,1), LBOUND(oor_mask,2):UBOUND(oor_mask,2), & + LBOUND(oor_mask,3):UBOUND(oor_mask,3), 1:1) => oor_mask do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids) file_id = this%FMS_diag_fields(diag_field_id)%file_ids(i) @@ -1295,10 +1302,10 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight !! TODO: root-mean-square error case (time_max) call fms_diag_update_extremum(1, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & - l_end, is_regional, reduced_k_range, sample, oor_mask, field_name, has_diurnal_axis, err_msg) + l_end, is_regional, reduced_k_range, sample, oor_mask_4d, field_name, has_diurnal_axis, err_msg) case (time_min) call fms_diag_update_extremum(0, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & - l_end, is_regional, reduced_k_range, sample, oor_mask, field_name, has_diurnal_axis, err_msg) + l_end, is_regional, reduced_k_range, sample, oor_mask_4d, field_name, has_diurnal_axis, err_msg) case (time_sum) !! TODO: sum for the interval !! call fms_diag_sum(time_sum, .......) From 7a63654769d87e12e6aa6947c6dcff333e57aecf Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Thu, 20 Jul 2023 08:12:20 -0400 Subject: [PATCH 33/61] Declares oor_mask as contiguous target in routine fms_diag_do_reduction --- diag_manager/fms_diag_object.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 9fb5ac4b34..fa946d5771 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -1122,7 +1122,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight class(fmsDiagObject_type), intent(in), target :: this !< Diag Object class(*), intent(in) :: field_data(:,:,:,:) !< Field data integer, intent(in) :: diag_field_id !< ID of the input field - logical, intent(in) :: oor_mask(:,:,:) !< Out of range mask + logical, intent(in), target, contiguous :: oor_mask(:,:,:) !< Out of range mask real, intent(in) :: weight !< Must be a updated weight type(time_type), intent(in), optional :: time !< Current time integer, intent(in), optional :: is_in, js_in, ks_in !< Starting indices of the variable From 2b47d80f9eef74e699ab796abe0e90f125bba1cf Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Thu, 20 Jul 2023 08:27:09 -0400 Subject: [PATCH 34/61] Updates fms_diag_object.F90 and fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_object.F90 | 3 +-- diag_manager/fms_diag_reduction_methods.F90 | 1 + 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index fa946d5771..1ba2301072 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -1171,8 +1171,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight !> Remap oor_mask to 4D array oor_mask_4d => null() - oor_mask_4d(LBOUND(oor_mask,1):UBOUND(oor_mask,1), LBOUND(oor_mask,2):UBOUND(oor_mask,2), & - LBOUND(oor_mask,3):UBOUND(oor_mask,3), 1:1) => oor_mask + oor_mask_4d(1:size(oor_mask,1), 1:size(oor_mask,2), 1:size(oor_mask,3), 1:1) => oor_mask do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids) file_id = this%FMS_diag_fields(diag_field_id)%file_ids(i) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 82efa1d5a0..242bb5ea94 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -6,6 +6,7 @@ module fms_diag_reduction_methods_mod use platform_mod + use mpp_mod, only: mpp_error use fms_mod, only: fms_error_handler use fms_diag_bbox_mod use fms_diag_output_buffer_mod From b5454c4782cfb12836a9df67a5d42fa030aac433 Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Thu, 20 Jul 2023 09:45:54 -0400 Subject: [PATCH 35/61] Comments out allocate_diag_field_output_buffers and fms_diag_do_reduction from fms_diag_accept_data --- diag_manager/fms_diag_object.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 1ba2301072..fa763125d0 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -565,11 +565,11 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is return else !> Allocate buffers of this field variable - call this%allocate_diag_field_output_buffers(field_data, diag_field_id) + !call this%allocate_diag_field_output_buffers(field_data, diag_field_id) !> Do time reductions (average, min, max, rms error, sum, etc.) - fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, weight2, & - time, is_in, js_in, ks_in, ie_in, je_in, ke_in, err_msg) + !fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, weight2, & + !time, is_in, js_in, ks_in, ie_in, je_in, ke_in, err_msg) call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) fms_diag_accept_data = .TRUE. return From 77a66c505ded57d0542a87b47f87c5625a95174d Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Fri, 21 Jul 2023 15:09:49 -0400 Subject: [PATCH 36/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 242bb5ea94..a657f8c090 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -1,6 +1,7 @@ !> \author Ganga Purja Pun !> \email gagna.purjapun@noaa.gov -!! \brief Contains routines for the modern diag_manager +!! \brief Contains routines for the modern diag manager +!! These routines are meant to be used for reduction methods. !! !! \description @@ -218,13 +219,13 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, !! of the field data integer, intent(in) :: l_start(:) !< Local starting indices for the first three dimensions integer, intent(in) :: l_end(:) !< Local ending indices for the first three dimensions - logical, intent(in) :: is_regional - logical, intent(in) :: reduced_k_range - integer :: sample !< Index along the diurnal time axis + logical, intent(in) :: is_regional !< Flag indicating if the current PE takes part in send_data + logical, intent(in) :: reduced_k_range !< Flag indicating if the field has zbounds + integer, intent(in) :: sample !< Index along the diurnal time axis logical, intent(in) :: mask(:,:,:,:) !< Must be out of range mask character(len=*), intent(in) :: fieldName !< Field name for error reporting - logical :: hasDiurnalAxis !< Flag to indicate if the buffer has a diurnal axis - character(len=*), intent(inout) :: err_msg + logical, intent(in) :: hasDiurnalAxis !< Flag to indicate if the buffer has a diurnal axis + character(len=*), intent(inout), optional :: err_msg integer :: is, js, ks !< Starting indices in the I, J, and K dimensions integer :: ie, je, ke !< Ending indices in the I, J, and K dimensions @@ -691,4 +692,4 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b end select end subroutine update_array_extremum #endif -end module fms_diag_reduction_methods_mod \ No newline at end of file +end module fms_diag_reduction_methods_mod From 693c5295ca7ff36271c8ffcafc36735aa6d68965 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 13 Jul 2023 13:16:11 -0400 Subject: [PATCH 37/61] refactor: `monin_obukhov_stable_mix` calls from `stable_mix_1d` (#1268) --- monin_obukhov/monin_obukhov.F90 | 53 ++++++++++++++++----------------- 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/monin_obukhov/monin_obukhov.F90 b/monin_obukhov/monin_obukhov.F90 index 883e4cbe34..ac8a89075f 100644 --- a/monin_obukhov/monin_obukhov.F90 +++ b/monin_obukhov/monin_obukhov.F90 @@ -274,16 +274,18 @@ subroutine stable_mix_3d(rich, mix) real, intent(in) , dimension(:,:,:) :: rich real, intent(out), dimension(:,:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: n3 !< Size of dimension 3 of mix and rich +integer :: i, j !< Loop indices -integer :: n, ier - -if(.not.module_is_initialized) call error_mesg('stable_mix_3d in monin_obukhov_mod', & - 'monin_obukhov_init has not been called', FATAL) - -n = size(rich,1)*size(rich,2)*size(rich,3) -call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & - & n, rich, mix, ier) +n2 = size(mix, 2) +n3 = size(mix, 3) +do j=1, n3 + do i=1, n2 + call stable_mix(rich(:, i, j), mix(:, i, j)) + enddo +enddo end subroutine stable_mix_3d @@ -943,16 +945,15 @@ subroutine stable_mix_2d(rich, mix) real, intent(in) , dimension(:,:) :: rich real, intent(out), dimension(:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: i !< Loop index -real, dimension(size(rich,1),size(rich,2),1) :: rich_3d, mix_3d - -rich_3d(:,:,1) = rich +n2 = size(mix, 2) -call stable_mix_3d(rich_3d, mix_3d) - -mix = mix_3d(:,:,1) +do i=1, n2 + call stable_mix(rich(:, i), mix(:, i)) +enddo -return end subroutine stable_mix_2d @@ -962,16 +963,17 @@ subroutine stable_mix_1d(rich, mix) real, intent(in) , dimension(:) :: rich real, intent(out), dimension(:) :: mix +integer :: n !< Size of mix and rich +integer :: ierr !< Error code set by monin_obukhov_stable_mix -real, dimension(size(rich),1,1) :: rich_3d, mix_3d - -rich_3d(:,1,1) = rich +if (.not.module_is_initialized) call error_mesg('stable_mix in monin_obukhov_mod', & + 'monin_obukhov_init has not been called', FATAL) -call stable_mix_3d(rich_3d, mix_3d) +n = size(mix) -mix = mix_3d(:,1,1) +call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & + & n, rich, mix, ierr) -return end subroutine stable_mix_1d !======================================================================= @@ -981,15 +983,12 @@ subroutine stable_mix_0d(rich, mix) real, intent(in) :: rich real, intent(out) :: mix -real, dimension(1,1,1) :: rich_3d, mix_3d - -rich_3d(1,1,1) = rich +real, dimension(1) :: mix_1d !< Representation of mix as a dimension(1) array -call stable_mix_3d(rich_3d, mix_3d) +call stable_mix([rich], mix_1d) -mix = mix_3d(1,1,1) +mix = mix_1d(1) -return end subroutine stable_mix_0d !======================================================================= From 009be59e7b2466e9d917224885a394bf191d1969 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 13 Jul 2023 13:30:34 -0400 Subject: [PATCH 38/61] fix: out-of-bounds memory access in axis_utils2 (#1157) --- axis_utils/include/axis_utils2.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc index 21deca9fb4..3acd69b28c 100644 --- a/axis_utils/include/axis_utils2.inc +++ b/axis_utils/include/axis_utils2.inc @@ -213,7 +213,7 @@ endif lon_strt = lon(1) - do i=2,len+1 + do i=2,len lon(i) = lon_in_range(lon(i),lon_strt) lon_strt = lon(i) enddo From a2f30975b6fc35fc71eef79b2db1623fe2d5ef77 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 13 Jul 2023 13:44:53 -0400 Subject: [PATCH 39/61] fix: maximize system stacksize limit in fms_init (#1233) --- fms/Makefile.am | 1 + fms/fms.F90 | 9 +++++++++ fms/fms_stacksize.c | 33 +++++++++++++++++++++++++++++++++ 3 files changed, 43 insertions(+) create mode 100644 fms/fms_stacksize.c diff --git a/fms/Makefile.am b/fms/Makefile.am index 8f8c58525b..ca8b107941 100644 --- a/fms/Makefile.am +++ b/fms/Makefile.am @@ -32,6 +32,7 @@ noinst_LTLIBRARIES = libfms.la # Each convenience library depends on its source. libfms_la_SOURCES = \ fms.F90 \ + fms_stacksize.c \ include/fms.inc \ include/fms_r4.fh \ include/fms_r8.fh \ diff --git a/fms/fms.F90 b/fms/fms.F90 index 3ec8052148..2ac9393b48 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -336,6 +336,11 @@ subroutine fms_init (localcomm, alt_input_nml_path) use fms_io_mod, only: fms_io_version #endif + interface + subroutine maximize_system_stacksize_limit() bind(C) + end subroutine + end interface + integer, intent(in), optional :: localcomm character(len=*), intent(in), optional :: alt_input_nml_path integer :: ierr, io @@ -344,6 +349,10 @@ subroutine fms_init (localcomm, alt_input_nml_path) if (module_is_initialized) return ! return silently if already called module_is_initialized = .true. + +!---- Raise the system stack size limit to its maximum permissible value ---- + call maximize_system_stacksize_limit + !---- initialize mpp routines ---- if(present(localcomm)) then if(present(alt_input_nml_path)) then diff --git a/fms/fms_stacksize.c b/fms/fms_stacksize.c new file mode 100644 index 0000000000..7631656475 --- /dev/null +++ b/fms/fms_stacksize.c @@ -0,0 +1,33 @@ +/*********************************************************************** + * 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 . + **********************************************************************/ + +#include + +/* + * Set the stack size limit to its maximum permissible value + */ + +void maximize_system_stacksize_limit() +{ + struct rlimit stacksize; + + getrlimit(RLIMIT_STACK, &stacksize); + stacksize.rlim_cur = stacksize.rlim_max; + setrlimit(RLIMIT_STACK, &stacksize); +} From e13e83f3dea2c070ec8da42afcd9a23c9f0bd048 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 13 Jul 2023 14:14:55 -0400 Subject: [PATCH 40/61] test: remove stack limit checks in test scripts (#1280) --- test_fms/fms2_io/test_fms2_io.sh | 10 ---------- test_fms/mpp/test_mpp_chksum.sh | 5 ----- test_fms/test-lib.sh.in | 5 ----- 3 files changed, 20 deletions(-) diff --git a/test_fms/fms2_io/test_fms2_io.sh b/test_fms/fms2_io/test_fms2_io.sh index 8a604e6655..5e0bd31c0e 100755 --- a/test_fms/fms2_io/test_fms2_io.sh +++ b/test_fms/fms2_io/test_fms2_io.sh @@ -31,16 +31,6 @@ # Create and enter output directory output_dir -# use smaller arrays if system stack size is limited -if [ $STACK_LIMITED ]; then - cat <<_EOF > input.nml -&test_fms2_io_nml - nx = 32 - ny = 32 - nz = 10 -/ -_EOF -fi touch input.nml # run the tests diff --git a/test_fms/mpp/test_mpp_chksum.sh b/test_fms/mpp/test_mpp_chksum.sh index 03d252794b..bea691aa5f 100755 --- a/test_fms/mpp/test_mpp_chksum.sh +++ b/test_fms/mpp/test_mpp_chksum.sh @@ -29,11 +29,6 @@ echo "&test_mpp_chksum_nml" > input.nml echo "test_num = 1" >> input.nml -# replaces defaults with smaller sizes if stack size is limited -if [ $STACK_LIMITED ]; then - echo "nx = 64" >> input.nml - echo "ny = 64" >> input.nml -fi echo "/" >> input.nml test_expect_success "mpp_chksum simple functionality" ' diff --git a/test_fms/test-lib.sh.in b/test_fms/test-lib.sh.in index a2cfe8ebf8..b983b48d84 100644 --- a/test_fms/test-lib.sh.in +++ b/test_fms/test-lib.sh.in @@ -33,11 +33,6 @@ TEST_NAME="$(basename "$0" .sh)" TEST_NUMBER="${TEST_NAME%%-*}" TEST_NUMBER="${TEST_NUMBER#t}" -# if using intel with a limited stack size, sets to run smaller tests -if [ "$($FC --version | grep ifort)" -a "$(ulimit -s)" != "unlimited" 2> /dev/null ]; then - STACK_LIMITED=1 -fi - exec 7>&2 # For now, write all output #if test -n "$VERBOSE" From 340fce350e22b5715e920f971d3781b7404620ec Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 13 Jul 2023 14:37:47 -0400 Subject: [PATCH 41/61] fix: mpp global arrays test fixes (#1174) --- test_fms/mpp/test_global_arrays.F90 | 491 +++++++++++++--------------- test_fms/mpp/test_global_arrays.sh | 22 +- test_fms/mpp/test_mpp_domains.F90 | 117 ------- 3 files changed, 246 insertions(+), 384 deletions(-) diff --git a/test_fms/mpp/test_global_arrays.F90 b/test_fms/mpp/test_global_arrays.F90 index ce2b125cb4..4f27b0c666 100644 --- a/test_fms/mpp/test_global_arrays.F90 +++ b/test_fms/mpp/test_global_arrays.F90 @@ -34,21 +34,24 @@ program test_global_arrays use mpp_domains_mod, only: mpp_global_min, mpp_get_data_domain,mpp_get_compute_domain use mpp_domains_mod, only: mpp_domains_exit, mpp_update_domains use mpp_domains_mod, only: mpp_get_domain_shift, mpp_global_sum + use mpp_domains_mod, only: CYCLIC_GLOBAL_DOMAIN, NORTH, EAST, CENTER, CORNER, BITWISE_EXACT_SUM + use mpp_mod, only: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, mpp_clock_id, mpp_clock_begin, mpp_clock_end + use fms_mod, only: check_nml_error, input_nml_file implicit none integer, parameter :: length=64 - integer :: id, pe, npes, root, i, j, icount, jcount - integer(i4_kind) :: maxI4, minI4, ierr, sumI4, sumI4_5d - integer(i8_kind) :: maxI8, minI8, sumI8, sumI8_5d - integer(i4_kind), allocatable :: dataI4(:,:), dataI4_5d(:,:,:,:,:), dataI4_shuf(:,:) - integer(i8_kind), allocatable :: dataI8(:,:), dataI8_5d(:,:,:,:,:), dataI8_shuf(:,:) - real(r4_kind), allocatable :: dataR4(:,:), dataR4_5d(:,:,:,:,:), dataR4_shuf(:,:) - real(r8_kind), allocatable :: dataR8(:,:), dataR8_5d(:,:,:,:,:), dataR8_shuf(:,:) + integer :: id, pe, npes, root, i, j, icount, jcount, io + integer(i4_kind) :: maxI4, minI4, ierr, sumI4, sumI4_5d, sumI4_shuf + integer(i8_kind) :: maxI8, minI8, sumI8, sumI8_5d, sumI8_shuf + integer(i4_kind), allocatable :: dataI4(:,:), dataI4_shuf(:,:), recv_data_i4(:,:) + integer(i8_kind), allocatable :: dataI8(:,:), dataI8_shuf(:,:), recv_data_i8(:,:) + real(r4_kind), allocatable :: dataR4(:,:), dataR4_shuf(:,:), recv_data_r4(:,:) + real(r8_kind), allocatable :: dataR8(:,:), dataR8_shuf(:,:), recv_data_r8(:,:) real, allocatable :: rands(:) type(domain2D) :: domain - real(r8_kind) :: rcoef, maxR8, minR8, sumR8, sumR8_5d - real(r4_kind) :: maxR4, minR4, sumR4, sumR4_5d + real(r8_kind) :: rcoef, maxR8, minR8, sumR8, sumR8_shuf + real(r4_kind) :: maxR4, minR4, sumR4, sumR4_shuf integer :: isc, iec, jsc, jec integer :: isd, ied, jsd, jed character(len=32) :: strTmp1, strTmp2 @@ -56,22 +59,60 @@ program test_global_arrays integer(i8_kind), parameter :: randmaxI8 = 4096 real(r8_kind), parameter :: tol4 = 1e-4, tol8 = 1e-6!> tolerance for real comparisons - call mpp_init(mpp_init_test_init_true_only) + ! namelist variables - just logicals to enable individual tests + ! simple just does normal max/min + sums across a domain + ! full does max/min+sums with halos and symmetry + logical :: test_simple= .false. , test_full = .false. + namelist / test_global_arrays_nml / test_simple, test_full + + call mpp_init() + call mpp_domains_init() - call mpp_set_stack_size(3145746) - call mpp_domains_set_stack_size(3145746) + !call mpp_set_stack_size(3145746) + call mpp_domains_set_stack_size(4000000) + + read(input_nml_file, nml=test_global_arrays_nml, iostat=io) + ierr = check_nml_error(io, 'test_global_arrays_nml') pe = mpp_pe() npes = mpp_npes() call mpp_set_root_pe(0) root = mpp_root_pe() + if( test_simple) then + call test_mpp_global_simple() + deallocate(dataI4, dataI8, dataR4, dataR8, rands) + deallocate(dataR4_shuf, dataR8_shuf,dataI4_shuf, dataI8_shuf) + else if(test_full) then + call test_global_reduce( 'Simple') + call test_global_reduce( 'Simple symmetry center') + call test_global_reduce( 'Simple symmetry corner') + call test_global_reduce( 'Simple symmetry east') + call test_global_reduce( 'Simple symmetry north') + call test_global_reduce( 'Cyclic symmetry center') + call test_global_reduce( 'Cyclic symmetry corner') + call test_global_reduce( 'Cyclic symmetry east') + call test_global_reduce( 'Cyclic symmetry north') + else + call mpp_error(FATAL, "test_global_arrays: either test_sum or test_max_min must be true in input.nml") + endif + call mpp_sync() + + call mpp_domains_exit() + call MPI_FINALIZE(ierr) + + contains + +subroutine test_mpp_global_simple() + !> define domains and allocate - call mpp_define_domains( (/1,length,1,length/), (/4,2/), domain, xhalo=0) + call mpp_define_domains( (/1,length,1,length/), (/1,8/), domain, xhalo=0) call mpp_get_compute_domain(domain, jsc, jec, isc, iec) call mpp_get_data_domain(domain, jsd, jed, isd, ied) allocate(dataI4(jsd:jed, isd:ied),dataI8(jsd:jed, isd:ied), rands(length*length)) allocate(dataR4(jsd:jed, isd:ied), dataR8(jsd:jed, isd:ied)) allocate(dataR4_shuf(jsd:jed, isd:ied), dataR8_shuf(jsd:jed, isd:ied)) allocate(dataI4_shuf(jsd:jed, isd:ied), dataI8_shuf(jsd:jed, isd:ied)) + allocate(recv_data_r4(jsd:jed, isd:ied), recv_data_r8(jsd:jed, isd:ied)) + allocate(recv_data_i4(jsd:jed, isd:ied), recv_data_i8(jsd:jed, isd:ied)) dataI4 = 0; dataI8 = 0; dataR4 = 0.0; dataR8 = 0.0 dataR8_shuf=0.0; dataR4_shuf=0.0;dataI8_shuf=0; dataI4_shuf=0 @@ -166,97 +207,92 @@ program test_global_arrays NEW_LINE('a')//"Sum: "// strTmp1 ) endif - !> shuffle real data ordering and copy into array with 5 ranks - dataR4_shuf = dataR4 - dataR8_shuf = dataR8 - call shuffleDataR4(dataR4_shuf) - call shuffleDataR8(dataR8_shuf) - allocate(dataR4_5d(jsd:jed, isd:ied, 1, 1, 1), dataR8_5d(jsd:jed,isd:ied, 1, 1, 1)) - - dataR4_5d = 0.0 - dataR8_5d = 0.0 - - do i=isc,iec - do j=jsc,jec - dataR4_5d(j, i, 1, 1, 1) = dataR4_shuf(j, i) - dataR8_5d(j, i, 1, 1, 1) = dataR8_shuf(j, i) - end do - end do + !> moves the data into different pe's and checks the sum still matches + dataR4_shuf = dataR4 ; dataR8_shuf = dataR8 + dataI4_shuf = dataI4 ; dataI8_shuf = dataI8 + !! swap data with neighboring pe + if(modulo(pe, 2) .eq. 0) then + print *, pe, pe+1, SUM(dataR8_shuf) + call mpp_send(dataR4_shuf, SIZE(dataR4_shuf), pe+1) + call mpp_recv(recv_data_r4, SIZE(dataR4_shuf), pe+1) + call mpp_sync() + call mpp_send(dataR8_shuf, SIZE(dataR8_shuf), pe+1) + call mpp_recv(recv_data_r8, SIZE(dataR8_shuf), pe+1) + call mpp_sync() + call mpp_send(dataI4_shuf, SIZE(dataI4_shuf), pe+1) + call mpp_recv(recv_data_I4, SIZE(dataI4_shuf), pe+1) + call mpp_sync() + call mpp_send(dataI8_shuf, SIZE(dataI8_shuf), pe+1) + call mpp_recv(recv_data_I8, SIZE(dataI8_shuf), pe+1) + else + print *, pe, pe-1, SUM(dataR8_shuf) + call mpp_recv(recv_data_r4, SIZE(dataR4_shuf), pe-1) + call mpp_send(dataR4_shuf, SIZE(dataR4_shuf), pe-1) + call mpp_sync() + call mpp_recv(recv_data_r8, SIZE(dataR8_shuf), pe-1) + call mpp_send(dataR8_shuf, SIZE(dataR8_shuf), pe-1) + call mpp_sync() + call mpp_send(dataI4_shuf, SIZE(dataI4_shuf), pe-1) + call mpp_recv(recv_data_I4, SIZE(dataI4_shuf), pe-1) + call mpp_sync() + call mpp_send(dataI8_shuf, SIZE(dataI8_shuf), pe-1) + call mpp_recv(recv_data_I8, SIZE(dataI8_shuf), pe-1) + endif call mpp_sync() + dataR4_shuf = recv_data_r4 + dataR8_shuf = recv_data_r8 - call mpp_error(NOTE, "----------Testing 32-bit real mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataR4_5d, domain) - sumR4_5d = mpp_global_sum(domain, dataR4_5d) + call mpp_error(NOTE, "----------Testing 32-bit real mpp_global_sum with reordering----------") + call mpp_update_domains(dataR4_shuf, domain) + sumR4_shuf = mpp_global_sum(domain, dataR4_shuf) ! check that shuffled array results are approximately the same as the original array - if(abs(sumR4-sumR4_5d) .gt. 1E-4 ) then + if(abs(sumR4-sumR4_shuf) .gt. 1E-4 ) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumR4_5d + write(strTmp1,*) sumR4_shuf write(strTmp2,*) sumR4 call mpp_error(FATAL,"test_global_arrays: invalid 32-bit real answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - call mpp_error(NOTE, "----------Testing 64-bit real mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataR8_5d, domain) - sumR8_5d = mpp_global_sum(domain, dataR8_5d) + call mpp_sync() + call mpp_error(NOTE, "----------Testing 64-bit real mpp_global_sum with reordering----------") + call mpp_update_domains(dataR8_shuf, domain) + sumR8_shuf = mpp_global_sum(domain, dataR8_shuf) ! check that shuffled array results are approximately the same as the original array - if(abs(sumR8-sumR8_5d) .gt. 1E-7) then + if(abs(sumR8-sumR8_shuf) .gt. 1E-7) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumR8_5d + write(strTmp1,*) sumR8_shuf write(strTmp2,*) sumR8 call mpp_error(FATAL,"test_global_arrays: invalid 64-bit real answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - !> shuffle integer data ordering and copy into array with 5 ranks - dataI4_shuf = dataI4 - dataI8_shuf = dataI8 - call shuffleDataI4(dataI4_shuf) - call shuffleDataI8(dataI8_shuf) - allocate(dataI4_5d(jsd:jed, isd:ied, 1, 1, 1), dataI8_5d(jsd:jed,isd:ied, 1, 1, 1)) - - dataI4_5d = 0 - dataI8_5d = 0 - do i=isc,iec - do j=jsc,jec - dataI4_5d(j, i, 1, 1, 1) = dataI4_shuf(j, i) - dataI8_5d(j, i, 1, 1, 1) = dataI8_shuf(j, i) - end do - end do - call mpp_sync() - - call mpp_error(NOTE, "----------Testing 32-bit integer mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataI4_5d, domain) - sumI4_5d = mpp_global_sum(domain, dataI4_5d) + call mpp_error(NOTE, "----------Testing 32-bit integer mpp_global_sum with reordering----------") + call mpp_update_domains(dataI4_shuf, domain) + sumI4_shuf = mpp_global_sum(domain, dataI4_shuf) ! check that shuffled array results are approximately the same as the original array - if(sumI4 .ne. sumI4_5d) then + if(sumI4 .ne. sumI4_shuf) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumI4_5d + write(strTmp1,*) sumI4_shuf write(strTmp2,*) sumI4 call mpp_error(FATAL,"test_global_arrays: invalid 32-bit integer answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - call mpp_error(NOTE, "----------Testing 64-bit integer mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataI8_5d, domain) - sumI8_5d = mpp_global_sum(domain, dataI8_5d) + call mpp_error(NOTE, "----------Testing 64-bit integer mpp_global_sum with reordering----------") + call mpp_update_domains(dataI8_shuf, domain) + sumI8_shuf = mpp_global_sum(domain, dataI8_shuf) ! check that shuffled array results are approximately the same as the original array - if(sumI8 .ne. sumI8_5d) then + if(sumI8 .ne. sumI8_shuf) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumI8_5d + write(strTmp1,*) sumI8_shuf write(strTmp2,*) sumI8 call mpp_error(FATAL,"test_global_arrays: invalid 64-bit integer answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - - deallocate(dataI4, dataI8, dataR4, dataR8, rands, dataI4_5d, dataI8_5d, dataR4_5d, dataR8_5d) - deallocate(dataR4_shuf, dataR8_shuf,dataI4_shuf, dataI8_shuf) - call mpp_domains_exit() - call MPI_FINALIZE(ierr) - - contains +end subroutine test_mpp_global_simple !> true if all pes return the same result and have a lower/higher local max/min function checkResultInt4(res) @@ -368,7 +404,6 @@ function checkSumReal4(gsum) real(r4_kind),intent(in) :: gsum real(r4_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 real(r4_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -402,7 +437,6 @@ function checkSumReal8(gsum) real(r8_kind),intent(in) :: gsum real(r8_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 real(r8_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -436,7 +470,6 @@ function checkSumInt4(gsum) integer(i4_kind),intent(in) :: gsum integer(i4_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 integer(i4_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -470,7 +503,6 @@ function checkSumInt8(gsum) integer(i8_kind),intent(in) :: gsum integer(i8_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 integer(i8_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -497,192 +529,123 @@ function checkSumInt8(gsum) deallocate(recv) end function checkSumInt8 -!> aggregates data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataI4(dataI4) - integer(i4_kind), intent(INOUT) :: dataI4(:,:) - integer(i4_kind), allocatable :: trans(:,:), shuffled(:),tmp - integer :: rind - - allocate(trans(SIZE(dataI4,1), SIZE(dataI4,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataI4)) = RESHAPE(dataI4, (/SIZE(dataI4)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataI4) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataI4 = trans - endif - end do - else - call mpp_send(dataI4, SIZE(dataI4), root) - call mpp_recv(trans, SIZE(dataI4), root) - dataI4 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataI4 - -!> aggregates data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataI8(dataI8) - integer(i8_kind), intent(INOUT) :: dataI8(:,:) - integer(i8_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataI8,1), SIZE(dataI8,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataI8)) = RESHAPE(dataI8, (/SIZE(dataI8)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataI8) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataI8 = trans - endif - end do - else - call mpp_send(dataI8, SIZE(dataI8), root) - call mpp_recv(trans, SIZE(dataI8), root) - dataI8 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataI8 - -!> aggregates 32-bit real data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataR4(dataR4) - real(r4_kind), intent(INOUT) :: dataR4(:,:) - real(r4_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataR4,1), SIZE(dataR4,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataR4)) = RESHAPE(dataR4, (/SIZE(dataR4)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataR4) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataR4 = trans - endif - end do - else - call mpp_send(dataR4, SIZE(dataR4), root) - call mpp_recv(trans, SIZE(dataR4), root) - dataR4 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataR4 - -!> aggregates 64-bit real data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataR8(dataR8) - real(r8_kind), intent(INOUT) :: dataR8(:,:) - real(r8_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataR8,1), SIZE(dataR8,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataR8)) = RESHAPE(dataR8, (/SIZE(dataR8)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataR8) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataR8 = trans - endif - end do - else - call mpp_send(dataR8, SIZE(dataR8), root) - call mpp_recv(trans, SIZE(dataR8), root) - dataR8 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataR8 + !--- test mpp_global_sum, mpp_global_min and mpp_global_max + subroutine test_global_reduce (type) + character(len=*), intent(in) :: type + real :: lsum, gsum, lmax, gmax, lmin, gmin + integer :: ni, nj, ishift, jshift, position, k + integer :: is, ie, js, je !, isd, ied, jsd, jed + integer :: nx=128, ny=128, nz=40, stackmax=4000000 + integer :: layout(2) + integer :: whalo = 2, ehalo = 2, shalo = 2, nhalo = 2 + real, allocatable, dimension(:,:,:) :: global1, x + real, allocatable, dimension(:,:) :: global2D + !--- set up domain + call mpp_define_layout( (/1,nx,1,ny/), npes, layout ) + select case(type) + case( 'Simple' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & + shalo=shalo, nhalo=nhalo, name=type ) + case( 'Simple symmetry center', 'Simple symmetry corner', 'Simple symmetry east', 'Simple symmetry north' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & + shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. ) + case( 'Cyclic symmetry center', 'Cyclic symmetry corner', 'Cyclic symmetry east', 'Cyclic symmetry north' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,& + name=type, symmetry = .true., xflags=CYCLIC_GLOBAL_DOMAIN, & + & yflags=CYCLIC_GLOBAL_DOMAIN ) + case default + call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' ) + end select + call mpp_get_compute_domain( domain, is, ie, js, je ) + call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) + + !--- determine if an extra point is needed + ishift = 0; jshift = 0; position = CENTER + select case(type) + case ('Simple symmetry corner', 'Cyclic symmetry corner') + ishift = 1; jshift = 1; position = CORNER + case ('Simple symmetry east', 'Cyclic symmetry east' ) + ishift = 1; jshift = 0; position = EAST + case ('Simple symmetry north', 'Cyclic symmetry north') + ishift = 0; jshift = 1; position = NORTH + end select + + ie = ie+ishift; je = je+jshift + ied = ied+ishift; jed = jed+jshift + ni = nx+ishift; nj = ny+jshift + allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz)) + global1 = 0.0 + do k = 1,nz + do j = 1,nj + do i = 1,ni + global1(i,j,k) = k + i*1e-3 + j*1e-6 + end do + end do + enddo + + !--- NOTE: even though the domain is cyclic, no need to apply cyclic condition on the global data + + allocate( x (isd:ied,jsd:jed,nz) ) + allocate( global2D(ni,nj)) + + x(:,:,:) = global1(isd:ied,jsd:jed,:) + do j = 1, nj + do i = 1, ni + global2D(i,j) = sum(global1(i,j,:)) + enddo + enddo + !test mpp_global_sum + + if(type(1:6) == 'Simple') then + gsum = sum( global2D(1:ni,1:nj) ) + else + gsum = sum( global2D(1:nx, 1:ny) ) + endif + id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lsum = mpp_global_sum( domain, x, position = position ) + call mpp_clock_end (id) + if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum + + !test exact mpp_global_sum + id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM, position = position ) + call mpp_clock_end (id) + !--- The following check will fail on altix in normal mode, but it is ok + !--- in debugging mode. It is ok on irix. + call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum') + + !test mpp_global_min + gmin = minval(global1(1:ni, 1:nj, :)) + id = mpp_clock_id( type//' min', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lmin = mpp_global_min( domain, x, position = position ) + call mpp_clock_end (id) + call compare_data_scalar(lmin, gmin, FATAL, type//' mpp_global_min') + + !test mpp_global_max + gmax = maxval(global1(1:ni, 1:nj, :)) + id = mpp_clock_id( type//' max', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lmax = mpp_global_max( domain, x, position = position ) + call mpp_clock_end (id) + call compare_data_scalar(lmax, gmax, FATAL, type//' mpp_global_max' ) + + deallocate(global1, x) + + end subroutine test_global_reduce + + subroutine compare_data_scalar( a, b, action, string ) + real, intent(in) :: a, b + integer, intent(in) :: action + character(len=*), intent(in) :: string + if( a .EQ. b)then + if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(string)//': data comparison are OK.' ) + else + call mpp_error( action, trim(string)//': data comparison are not OK.' ) + end if + + end subroutine compare_data_scalar end program test_global_arrays diff --git a/test_fms/mpp/test_global_arrays.sh b/test_fms/mpp/test_global_arrays.sh index 596d1ecb0a..18390415e5 100755 --- a/test_fms/mpp/test_global_arrays.sh +++ b/test_fms/mpp/test_global_arrays.sh @@ -27,10 +27,26 @@ # Set common test settings. . ../test-lib.sh -# ensure input.nml file present -touch input.nml +cat <<_EOF > input.nml +&test_global_arrays_nml + test_simple = .true. + test_full = .false. +/ +_EOF -test_expect_success "global array functions with mixed precision" ' +test_expect_success "mpp_global_sum/max/min with simple domain" ' mpirun -n 8 ./test_global_arrays ' + +cat <<_EOF > input.nml +&test_global_arrays_nml + test_simple = .false. + test_full = .true. +/ +_EOF + +test_expect_success "mpp_global_sum/max/min with symmetry and halos" ' + mpirun -n 6 ./test_global_arrays +' + test_done diff --git a/test_fms/mpp/test_mpp_domains.F90 b/test_fms/mpp/test_mpp_domains.F90 index ab9ba1a447..1ae1d904da 100644 --- a/test_fms/mpp/test_mpp_domains.F90 +++ b/test_fms/mpp/test_mpp_domains.F90 @@ -250,17 +250,6 @@ program test_mpp_domains call test_uniform_mosaic('Cubic-Grid') ! 6 tiles. call test_nonuniform_mosaic('Five-Tile') - if(.not. wide_halo) then - call test_global_reduce( 'Simple') - call test_global_reduce( 'Simple symmetry center') - call test_global_reduce( 'Simple symmetry corner') - call test_global_reduce( 'Simple symmetry east') - call test_global_reduce( 'Simple symmetry north') - call test_global_reduce( 'Cyclic symmetry center') - call test_global_reduce( 'Cyclic symmetry corner') - call test_global_reduce( 'Cyclic symmetry east') - call test_global_reduce( 'Cyclic symmetry north') - endif call test_redistribute( 'Complete pelist' ) call test_redistribute( 'Overlap pelist' ) @@ -6057,112 +6046,6 @@ subroutine test_cyclic_offset( type ) end subroutine test_cyclic_offset - !--- test mpp_global_sum, mpp_global_min and mpp_global_max - subroutine test_global_reduce (type) - character(len=*), intent(in) :: type - real :: lsum, gsum, lmax, gmax, lmin, gmin - integer :: ni, nj, ishift, jshift, position - integer :: is, ie, js, je, isd, ied, jsd, jed - - type(domain2D) :: domain - real, allocatable, dimension(:,:,:) :: global1, x - real, allocatable, dimension(:,:) :: global2D - !--- set up domain - call mpp_define_layout( (/1,nx,1,ny/), npes, layout ) - select case(type) - case( 'Simple' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & - shalo=shalo, nhalo=nhalo, name=type ) - case( 'Simple symmetry center', 'Simple symmetry corner', 'Simple symmetry east', 'Simple symmetry north' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & - shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. ) - case( 'Cyclic symmetry center', 'Cyclic symmetry corner', 'Cyclic symmetry east', 'Cyclic symmetry north' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,& - name=type, symmetry = .true., xflags=CYCLIC_GLOBAL_DOMAIN, & - & yflags=CYCLIC_GLOBAL_DOMAIN ) - case default - call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' ) - end select - call mpp_get_compute_domain( domain, is, ie, js, je ) - call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) - - !--- determine if an extra point is needed - ishift = 0; jshift = 0; position = CENTER - select case(type) - case ('Simple symmetry corner', 'Cyclic symmetry corner') - ishift = 1; jshift = 1; position = CORNER - case ('Simple symmetry east', 'Cyclic symmetry east' ) - ishift = 1; jshift = 0; position = EAST - case ('Simple symmetry north', 'Cyclic symmetry north') - ishift = 0; jshift = 1; position = NORTH - end select - - ie = ie+ishift; je = je+jshift - ied = ied+ishift; jed = jed+jshift - ni = nx+ishift; nj = ny+jshift - allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz)) - global1 = 0.0 - do k = 1,nz - do j = 1,nj - do i = 1,ni - global1(i,j,k) = k + i*1e-3 + j*1e-6 - end do - end do - enddo - - !--- NOTE: even though the domain is cyclic, no need to apply cyclic condition on the global data - - allocate( x (isd:ied,jsd:jed,nz) ) - allocate( global2D(ni,nj)) - - x(:,:,:) = global1(isd:ied,jsd:jed,:) - do j = 1, nj - do i = 1, ni - global2D(i,j) = sum(global1(i,j,:)) - enddo - enddo - !test mpp_global_sum - - if(type(1:6) == 'Simple') then - gsum = sum( global2D(1:ni,1:nj) ) - else - gsum = sum( global2D(1:nx, 1:ny) ) - endif - id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lsum = mpp_global_sum( domain, x, position = position ) - call mpp_clock_end (id) - if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum - - !test exact mpp_global_sum - id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM, position = position ) - call mpp_clock_end (id) - !--- The following check will fail on altix in normal mode, but it is ok - !--- in debugging mode. It is ok on irix. - call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum') - - !test mpp_global_min - gmin = minval(global1(1:ni, 1:nj, :)) - id = mpp_clock_id( type//' min', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lmin = mpp_global_min( domain, x, position = position ) - call mpp_clock_end (id) - call compare_data_scalar(lmin, gmin, FATAL, type//' mpp_global_min') - - !test mpp_global_max - gmax = maxval(global1(1:ni, 1:nj, :)) - id = mpp_clock_id( type//' max', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lmax = mpp_global_max( domain, x, position = position ) - call mpp_clock_end (id) - call compare_data_scalar(lmax, gmax, FATAL, type//' mpp_global_max' ) - - deallocate(global1, x) - - end subroutine test_global_reduce - subroutine test_parallel_2D ( ) integer :: npes, layout(2), i, j, k,is, ie, js, je, isd, ied, jsd, jed From 59df93ae04365555c27967f08998658ffb016243 Mon Sep 17 00:00:00 2001 From: JONG KIM Date: Thu, 13 Jul 2023 14:53:04 -0400 Subject: [PATCH 42/61] feat: update mpp_do_update_ad.fh to resolve JEDI requirement (#1225) --- mpp/include/mpp_do_global_field_ad.fh | 4 +- mpp/include/mpp_do_updateV_ad.fh | 2 +- mpp/include/mpp_do_update_ad.fh | 173 ++++++++++++++++++------- mpp/include/mpp_get_boundary_ad.fh | 2 +- mpp/include/mpp_global_field_ad.fh | 4 +- mpp/include/mpp_sum_mpi_ad.fh | 2 +- mpp/include/mpp_sum_nocomm_ad.fh | 2 +- mpp/include/mpp_update_domains2D_ad.fh | 16 +-- 8 files changed, 143 insertions(+), 62 deletions(-) diff --git a/mpp/include/mpp_do_global_field_ad.fh b/mpp/include/mpp_do_global_field_ad.fh index 5c72b5adbf..d32e6aa4b8 100644 --- a/mpp/include/mpp_do_global_field_ad.fh +++ b/mpp/include/mpp_do_global_field_ad.fh @@ -22,8 +22,8 @@ !> @addtogroup mpp_domains_mod !> @{ - !> Gets a global field from a local field - !! local field may be on compute OR data domain + !> Gets a local ad field from a global field + !! global field may be on compute OR data domain subroutine MPP_DO_GLOBAL_FIELD_3D_AD_( domain, local, global, tile, ishift, jshift, flags, default_data) type(domain2D), intent(in) :: domain MPP_TYPE_, intent(inout) :: local(:,:,:) diff --git a/mpp/include/mpp_do_updateV_ad.fh b/mpp/include/mpp_do_updateV_ad.fh index d6cce14abf..8d230f501c 100644 --- a/mpp/include/mpp_do_updateV_ad.fh +++ b/mpp/include/mpp_do_updateV_ad.fh @@ -21,7 +21,7 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_DO_UPDATE_AD_3D_V_(f_addrsx,f_addrsy, domain, update_x, update_y, & d_type, ke, gridtype, flags) integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) diff --git a/mpp/include/mpp_do_update_ad.fh b/mpp/include/mpp_do_update_ad.fh index 7afbe8317d..7e7382dcb8 100644 --- a/mpp/include/mpp_do_update_ad.fh +++ b/mpp/include/mpp_do_update_ad.fh @@ -1,6 +1,4 @@ ! -*-f90-*- - - !*********************************************************************** !* GNU Lesser General Public License !* @@ -21,8 +19,12 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed + !! @brief Applies linear adjoint operation to 3D field based on duality of MPP_DO_UPDATE_3D_ + !! @note Adjoint duality exists between MPI SEND and MPI_RECV. + !! However, checkpoint is needed for forward buffer information. + !! ref: BN. Cheng, A Duality between Forward and Adjoint MPI Communication Routines + !! COMPUTATIONAL METHODS IN SCIENCE AND TECHNOLOGY Special Issue 2006, 23-24 subroutine MPP_DO_UPDATE_AD_3D_( f_addrs, domain, update, d_type, ke, flags) integer(i8_kind), intent(in) :: f_addrs(:,:) type(domain2D), intent(in) :: domain @@ -35,6 +37,7 @@ pointer(ptr_field, field) integer :: update_flags type(overlap_type), pointer :: overPtr => NULL() + character(len=8) :: text !equate to mpp_domains_stack MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) @@ -43,13 +46,16 @@ !receive domains saved here for unpacking !for non-blocking version, could be recomputed - integer, allocatable :: msg1(:), msg2(:) + integer, allocatable :: msg1(:), msg2(:), msg3(:) logical :: send(8), recv(8), update_edge_only - integer :: to_pe, from_pe, pos, msgsize, msgsize_send + integer :: to_pe, from_pe, pos, msgsize integer :: n, l_size, l, m, i, j, k integer :: is, ie, js, je, tMe, dir integer :: buffer_recv_size, nlist, outunit - + integer :: send_start_pos !>Send buffer start location + !!This serves as ad recv buffer start location + integer :: send_msgsize(MAXLIST) !>Send buffer msg size storage + !!This should be checkpointed for reverse ad communication outunit = stdout() ptr = LOC(mpp_domains_stack) @@ -80,9 +86,10 @@ if(debug_message_passing) then nlist = size(domain%list(:)) - allocate(msg1(0:nlist-1), msg2(0:nlist-1) ) + allocate(msg1(0:nlist-1), msg2(0:nlist-1), msg3(0:nlist-1) ) msg1 = 0 msg2 = 0 + msg3 = 0 do m = 1, update%nrecv overPtr => update%recv(m) msgsize = 0 @@ -96,7 +103,6 @@ end do from_pe = update%recv(m)%pe l = from_pe-mpp_root_pe() - call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1 ) msg2(l) = msgsize enddo @@ -111,9 +117,13 @@ msgsize = msgsize + (ie-is+1)*(je-js+1) end if end do - call mpp_send( msgsize, plen=1, to_pe=overPtr%pe, tag=COMM_TAG_1 ) + l = overPtr%pe - mpp_root_pe() + msg3(l) = msgsize enddo - call mpp_sync_self(check=EVENT_RECV) + ! mpp_sync_self is desirable but keep mpp_alltoall + ! to exactly follow the duality of mpp_do_update.fh + ! all-to-all may have scaling issues on very large systems + call mpp_alltoall(msg3, 1, msg1, 1) do m = 0, nlist-1 if(msg1(m) .NE. msg2(m)) then @@ -122,14 +132,16 @@ call mpp_error(FATAL, "mpp_do_update: mismatch on send and recv size") endif enddo - call mpp_sync_self() write(outunit,*)"NOTE from mpp_do_update: message sizes are matched between send and recv for domain " & //trim(domain%name) - deallocate(msg1, msg2) + deallocate(msg1, msg2, msg3) endif - !recv + ! Duality of ad code requires checkpoint info: buffer recv size and send pos and msgsize + ! from the forward recv portion of mpp_do_update.fh + ! ref above in line 26 buffer_pos = 0 + do m = 1, update%nrecv overPtr => update%recv(m) if( overPtr%count == 0 )cycle @@ -137,38 +149,24 @@ do n = 1, overPtr%count dir = overPtr%dir(n) if(recv(dir)) then - tMe = overPtr%tileMe(n) is = overPtr%is(n); ie = overPtr%ie(n) js = overPtr%js(n); je = overPtr%je(n) msgsize = msgsize + (ie-is+1)*(je-js+1) - msgsize_send = (ie-is+1)*(je-js+1)*ke*l_size - pos = buffer_pos + msgsize_send - do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) - do k = ke,1,-1 - do j = je, js, -1 - do i = ie, is, -1 - buffer(pos) = field(i,j,k) - field(i,j,k) = 0. - pos = pos - 1 - end do - end do - end do - end do end if end do msgsize = msgsize*ke*l_size if( msgsize.GT.0 )then - to_pe = overPtr%pe - call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=to_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do m = 1, update%nrecv + end do buffer_recv_size = buffer_pos + send_start_pos = buffer_pos - ! send + ! checkpoint send_msgsize + buffer_pos = buffer_recv_size do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -179,19 +177,99 @@ enddo if( msgsize.GT.0 )then msgsize = msgsize*ke*l_size - msgsize_send = msgsize + end if + + do n = 1, overPtr%count + dir = overPtr%dir(n) + if( send(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + pos = pos + (ie-is+1)*(je-js+1)*ke*l_size + endif + end do + + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do + + ! bufferize for backward communication + ! using pack procedures of recv in mpp_do_update.fh + buffer_pos = buffer_recv_size + do m = update%nrecv, 1, -1 + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + pos = buffer_pos + do n = overPtr%count, 1, -1 + dir = overPtr%dir(n) + if( recv(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = (ie-is+1)*(je-js+1)*ke*l_size + pos = buffer_pos - msgsize + buffer_pos = pos + do l=1,l_size ! loop over number of fields + ptr_field = f_addrs(l, tMe) + do k = 1,ke + do j = js, je + do i = is, ie + pos = pos + 1 + buffer(pos) = field(i,j,k) + end do + end do + end do + end do + endif + end do + end do + + ! for duality, mpp_send of mpp_do_update.sh becomes mpp_recv in adjoint + buffer_pos = send_start_pos + do m = 1, update%nsend + msgsize = send_msgsize(m) + if(msgsize == 0) cycle + to_pe = update%send(m)%pe + call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=to_pe, block=.FALSE., tag=COMM_TAG_2 ) + buffer_pos = buffer_pos + msgsize + end do + + ! for duality, mpp_recv of mpp_do_update.sh becomes mpp_send in adjoint + buffer_pos = 0 + do m = 1, update%nrecv + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + msgsize = 0 + do n = 1, overPtr%count + dir = overPtr%dir(n) + if(recv(dir)) then + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = msgsize + (ie-is+1)*(je-js+1) + end if + end do + + msgsize = msgsize*ke*l_size + if( msgsize.GT.0 )then from_pe = overPtr%pe - call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_2 ) + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize) ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_DO_UPDATE: mpp_domains_stack overflow, '// & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.' ) + end if + call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=from_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do ist = 0,nlist-1 + end do call mpp_sync_self(check=EVENT_RECV) + ! unpack and linear adjoint operation + ! in reverse order of pack process of mpp_do_update.fh buffer_pos = buffer_recv_size - - ! send do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -201,7 +279,13 @@ if( send(dir) ) msgsize = msgsize + overPtr%msgsize(n) enddo if( msgsize.GT.0 )then - buffer_pos = pos + msgsize = msgsize*ke*l_size + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos+msgsize ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_START_UPDATE_DOMAINS: mpp_domains_stack overflow, ' // & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.') + end if end if do n = 1, overPtr%count @@ -259,15 +343,12 @@ end do end do end do - end select + end select endif end do ! do n = 1, overPtr%count - - msgsize = pos - buffer_pos - if( msgsize.GT.0 )then - buffer_pos = pos - end if - end do ! end do ist = 0,nlist-1 + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do call mpp_sync_self() diff --git a/mpp/include/mpp_get_boundary_ad.fh b/mpp/include/mpp_get_boundary_ad.fh index 56a18120e6..6701d375dd 100644 --- a/mpp/include/mpp_get_boundary_ad.fh +++ b/mpp/include/mpp_get_boundary_ad.fh @@ -21,7 +21,7 @@ !> @addtogroup mpp_domains_mod !> @{ -!> This routine is used to retrieve scalar boundary data for symmetric domain. +!> This routine is used to retrieve scalar ad boundary data for symmetric domain. subroutine MPP_GET_BOUNDARY_AD_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, & position, complete, tile_count) type(domain2D), intent(in) :: domain diff --git a/mpp/include/mpp_global_field_ad.fh b/mpp/include/mpp_global_field_ad.fh index 7d948f9366..712d12e48e 100644 --- a/mpp/include/mpp_global_field_ad.fh +++ b/mpp/include/mpp_global_field_ad.fh @@ -21,8 +21,8 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Get a global field from a local field - !! local field may be on compute OR data domain + !> Get a local ad field from a global ad field + !! global field may be on compute OR data domain subroutine MPP_GLOBAL_FIELD_2D_AD_( domain, local, global, flags, position,tile_count, default_data) type(domain2D), intent(in) :: domain MPP_TYPE_, intent(out) :: local(:,:) diff --git a/mpp/include/mpp_sum_mpi_ad.fh b/mpp/include/mpp_sum_mpi_ad.fh index 9b61b9457b..ee28d6c4bf 100644 --- a/mpp/include/mpp_sum_mpi_ad.fh +++ b/mpp/include/mpp_sum_mpi_ad.fh @@ -20,7 +20,7 @@ !* License along with FMS. If not, see . !*********************************************************************** !> Sums array a over the PEs in pelist (all PEs if this argument is omitted) - !! result is also automatically broadcast: all PEs have the sum in a at the end + !! forward array is already summed and broadcasted: all PEs already have the ad sum !! we are using f77-style call: array passed by address and not descriptor; further, !! the f90 conformance check is avoided. !> @ingroup mpp_mod diff --git a/mpp/include/mpp_sum_nocomm_ad.fh b/mpp/include/mpp_sum_nocomm_ad.fh index 9a427aa9d0..263bfde8d6 100644 --- a/mpp/include/mpp_sum_nocomm_ad.fh +++ b/mpp/include/mpp_sum_nocomm_ad.fh @@ -21,7 +21,7 @@ !*********************************************************************** !> Sums array a over the PEs in pelist (all PEs if this argument is omitted) - !! result is also automatically broadcast: all PEs have the sum in a at the end + !! forward array is already summed and broadcasted: all PEs already have the ad sum !! we are using f77-style call: array passed by address and not descriptor; further, !! the f90 conformance check is avoided. subroutine MPP_SUM_AD_( a, length, pelist ) diff --git a/mpp/include/mpp_update_domains2D_ad.fh b/mpp/include/mpp_update_domains2D_ad.fh index e5fc6e7af3..8a876fdba5 100644 --- a/mpp/include/mpp_update_domains2D_ad.fh +++ b/mpp/include/mpp_update_domains2D_ad.fh @@ -19,7 +19,7 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Updates data domain of 2D field whose computational domains have been computed + !> Updates data domain of 2D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_2D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) MPP_TYPE_, intent(inout) :: field(:,:) @@ -39,7 +39,7 @@ return end subroutine MPP_UPDATE_DOMAINS_AD_2D_ - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_3D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) MPP_TYPE_, intent(inout) :: field(:,:,:) @@ -176,7 +176,7 @@ end subroutine MPP_UPDATE_DOMAINS_AD_3D_ - !> Updates data domain of 4D field whose computational domains have been computed + !> Updates data domain of 4D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_4D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) MPP_TYPE_, intent(inout) :: field(:,:,:,:) @@ -196,7 +196,7 @@ return end subroutine MPP_UPDATE_DOMAINS_AD_4D_ - !> Updates data domain of 5D field whose computational domains have been computed + !> Updates data domain of 5D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_5D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) MPP_TYPE_, intent(inout) :: field(:,:,:,:,:) @@ -224,7 +224,7 @@ !vector fields subroutine MPP_UPDATE_DOMAINS_AD_2D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) -!updates data domain of 2D field whose computational domains have been computed +!updates data domain of 2D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -247,7 +247,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_3D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) -!updates data domain of 3D field whose computational domains have been computed +!updates data domain of 3D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -422,7 +422,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_4D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) -!updates data domain of 4D field whose computational domains have been computed +!updates data domain of 4D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -445,7 +445,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_5D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) -!updates data domain of 5D field whose computational domains have been computed +!updates data domain of 5D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype From 78671e59b6bdeaa17c6737e3cede4b9bea955837 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 13 Jul 2023 14:57:40 -0400 Subject: [PATCH 43/61] chore: add prefixed aliases for libfms routines (#1262) BREAKING CHANGE: Any code using the global fms module (libFMS.F90) will break as this adds prefixes to all names in that module. --- libFMS.F90 | 947 +++++++++++++++------- test_fms/mpp/test_domains_utility_mod.F90 | 4 +- test_fms/mpp/test_mpp_chksum.F90 | 5 +- test_fms/mpp/test_mpp_domains.F90 | 2 +- test_fms/mpp/test_mpp_nesting.F90 | 4 +- 5 files changed, 682 insertions(+), 280 deletions(-) diff --git a/libFMS.F90 b/libFMS.F90 index 872c587a8c..02b54df82a 100644 --- a/libFMS.F90 +++ b/libFMS.F90 @@ -28,11 +28,18 @@ !! and routines. Overloaded type operators/assignments cannot be imported individually !! (ie. `use fms, only: OPERATOR(*)` includes any defined '*' operators within FMS). !! -!! Remappings due to conflicts: +!! Renaming scheme: +!! Routines and variables: fms__routine_name +!! Types: FmsModuleNameTypeName !! -!! get_mosaic_tile_grid from mosaic2(fms2_io) => mosaic2_get_mosaic_tile_grid +!! Exceptions (mainly for rep: +!! - Parameter values are kept their original names +!! - If module name is already included (like in init routines) only fms prefix will be added. +!! - Similarly if theres a redundant module name included already included it will not be repeated +!! (ie. mpp_update_domains => fms_mpp_domains_update_domains) +!! - Override interfaces for operators and assignment are provided !! -!! read_data from interpolator_mod(fms2_io) => interpolator_read_data +!! Remappings due to name conflicts: !! !! ZERO from interpolator_mod(mpp_parameter) => INTERPOLATOR_ZERO !! @@ -41,7 +48,7 @@ !! Not in this module: !! !! axis_utils_mod, fms_io_mod, time_interp_external_mod -!! get_grid_version_mpp_mod, mpp_io_mod, mosaic_mod, +!! get_grid_version_mpp_mod, mpp_io_mod, mosaic_mod, & !! fms_mod(partial, old io excluded), drifters modules !! constants_mod (FMSconstants should be used externally) !! grid_mod, mosaic_mod @@ -65,215 +72,458 @@ module fms fms_affinity_set !> amip_interp - use amip_interp_mod, only: amip_interp_init, get_amip_sst, get_amip_ice, & - amip_interp_new,amip_interp_del, amip_interp_type, & - assignment(=), i_sst, j_sst, sst_ncep, sst_anom, & - forecast_mode, use_ncep_sst + use amip_interp_mod, only: fms_amip_interp_init => amip_interp_init, & + fms_amip_interp_get_amip_sst => get_amip_sst, & + fms_amip_interp_get_amip_ice => get_amip_ice, & + fms_amip_interp_new => amip_interp_new, & + fms_amip_interp_del => amip_interp_del, & + FmsAmipInterp_type => amip_interp_type, & + assignment(=), & + fms_amip_interp_i_sst => i_sst, & + fms_amip_interp_j_sst => j_sst, & + fms_amip_interp_sst_ncep => sst_ncep, & + fms_amip_interp_sst_anom => sst_anom, & + fms_amip_interp_forecast_mode=> forecast_mode, & + fms_amip_interp_use_ncep_sst => use_ncep_sst !> astronomy - use astronomy_mod, only: astronomy_init, get_period, set_period, & - set_orbital_parameters, get_orbital_parameters, & - set_ref_date_of_ae, get_ref_date_of_ae, & - diurnal_solar, daily_mean_solar, annual_mean_solar, & - astronomy_end, universal_time, orbital_time + use astronomy_mod, only: fms_astronomy_init => astronomy_init, & + fms_astronomy_get_period => get_period, & + fms_astronomy_set_period => set_period, & + fms_astronomy_set_orbital_parameters => set_orbital_parameters, & + fms_astronomy_get_orbital_parameters => get_orbital_parameters, & + fms_astronomy_set_ref_date_of_ae => set_ref_date_of_ae, & + fms_astronomy_get_ref_date_of_ae => get_ref_date_of_ae, & + fms_astronomy_diurnal_solar => diurnal_solar, & + fms_astronomy_daily_mean_solar => daily_mean_solar, & + fms_astronomy_annual_mean_solar => annual_mean_solar, & + fms_astronomy_end => astronomy_end, & + fms_astronomy_universal_time => universal_time, & + fms_astronomy_orbital_time => orbital_time !> axis_utils - use axis_utils2_mod, only: get_axis_cart, get_axis_modulo, lon_in_range, & - tranlon, frac_index, nearest_index, interp_1d, & - get_axis_modulo_times, axis_edges + use axis_utils2_mod, only: fms_axis_utils2_get_axis_cart => get_axis_cart, & + fms_axis_utils2_get_axis_modulo => get_axis_modulo, & + fms_axis_utils2_lon_in_range => lon_in_range, & + fms_axis_utils2_tranlon => tranlon, & + fms_axis_utils2_frac_index => frac_index, & + fms_axis_utils2_nearest_index => nearest_index, & + fms_axis_utils2_interp_1d => interp_1d, & + fms_axis_utils2_get_axis_modulo_times => get_axis_modulo_times, & + fms_axis_utils2_axis_edges => axis_edges !>block_control - use block_control_mod, only: block_control_type, define_blocks, & - define_blocks_packed + use block_control_mod, only: FmsBlockControl_type => block_control_type, & + fms_block_control_define_blocks => define_blocks, & + fms_block_control_define_blocks_packed => define_blocks_packed !> column_diagnostics - use column_diagnostics_mod, only: column_diagnostics_init, & - initialize_diagnostic_columns, & - column_diagnostics_header, & - close_column_diagnostics_units + use column_diagnostics_mod, only: fms_column_diagnostics_init => column_diagnostics_init, & + fms_column_diagnostics_initialize_diagnostic_columns => & + initialize_diagnostic_columns, & + fms_column_diagnostics_header => column_diagnostics_header, & + fms_column_diagnostics_close_units => close_column_diagnostics_units !> coupler - use coupler_types_mod, only: coupler_types_init, coupler_type_copy, & - coupler_type_spawn, coupler_type_set_diags, & - coupler_type_write_chksums, coupler_type_send_data, & - coupler_type_data_override, coupler_type_register_restarts, & - coupler_type_restore_state, coupler_type_increment_data, & - coupler_type_rescale_data, coupler_type_copy_data, & - coupler_type_redistribute_data, coupler_type_destructor, & - coupler_type_initialized, coupler_type_extract_data, & - coupler_type_set_data,coupler_type_copy_1d_2d, & - coupler_type_copy_1d_3d, coupler_3d_values_type, & - coupler_3d_field_type, coupler_3d_bc_type, & - coupler_2d_values_type, coupler_2d_field_type, & - coupler_2d_bc_type, coupler_1d_values_type, & - coupler_1d_field_type, coupler_1d_bc_type, & - ind_pcair, ind_u10, ind_psurf, ind_alpha, ind_csurf, & - ind_sc_no, ind_flux, ind_deltap, ind_kw, ind_flux0, & - ind_deposition, ind_runoff - use ensemble_manager_mod, only: ensemble_manager_init, get_ensemble_id, get_ensemble_size, & - get_ensemble_pelist, ensemble_pelist_setup, & - get_ensemble_filter_pelist - use atmos_ocean_fluxes_mod, only: atmos_ocean_fluxes_init, atmos_ocean_type_fluxes_init, & - aof_set_coupler_flux + use coupler_types_mod, only: fms_coupler_types_init => coupler_types_init, & + fms_coupler_type_copy => coupler_type_copy, & + fms_coupler_type_spawn => coupler_type_spawn, & + fms_coupler_type_set_diags => coupler_type_set_diags, & + fms_coupler_type_write_chksums => coupler_type_write_chksums, & + fms_coupler_type_send_data => coupler_type_send_data, & + fms_coupler_type_data_override => coupler_type_data_override, & + fms_coupler_type_register_restarts => coupler_type_register_restarts, & + fms_coupler_type_restore_state => coupler_type_restore_state, & + fms_coupler_type_increment_data => coupler_type_increment_data, & + fms_coupler_type_rescale_data => coupler_type_rescale_data, & + fms_coupler_type_copy_data => coupler_type_copy_data, & + fms_coupler_type_redistribute_data => coupler_type_redistribute_data, & + fms_coupler_type_destructor => coupler_type_destructor, & + fms_coupler_type_initialized => coupler_type_initialized, & + fms_coupler_type_extract_data => coupler_type_extract_data, & + fms_coupler_type_set_data => coupler_type_set_data, & + fms_coupler_type_copy_1d_2d => coupler_type_copy_1d_2d, & + fms_coupler_type_copy_1d_3d => coupler_type_copy_1d_3d, & + FmsCoupler3dValues_type => coupler_3d_values_type, & + FmsCoupler3dField_type => coupler_3d_field_type, & + FmsCoupler3dBC_type => coupler_3d_bc_type, & + FmsCoupler2dValues_type => coupler_2d_values_type, & + FmsCoupler2dField_type => coupler_2d_field_type, & + FmsCoupler2dBC_type => coupler_2d_bc_type, & + FmsCoupler1dValues_type => coupler_1d_values_type, & + FmsCoupler1dField_type => coupler_1d_field_type, & + FmsCoupler1dBC_type => coupler_1d_bc_type, & + fms_coupler_ind_pcair => ind_pcair, & + fms_coupler_ind_u10 => ind_u10, & + fms_coupler_ind_psurf => ind_psurf, & + fms_coupler_ind_alpha => ind_alpha, & + fms_coupler_ind_csurf => ind_csurf, & + fms_coupler_ind_sc_no => ind_sc_no, & + fms_coupler_ind_flux => ind_flux, & + fms_coupler_ind_deltap => ind_deltap, & + fms_coupler_ind_kw => ind_kw, & + fms_coupler_ind_flux0 => ind_flux0, & + fms_coupler_ind_deposition => ind_deposition,& + fms_coupler_ind_runoff => ind_runoff + use ensemble_manager_mod, only: fms_ensemble_manager_init => ensemble_manager_init, & + fms_ensemble_manager_get_ensemble_id => get_ensemble_id, & + fms_ensemble_manager_get_ensemble_size => get_ensemble_size, & + fms_ensemble_manager_get_ensemble_pelist => get_ensemble_pelist, & + fms_ensemble_manager_ensemble_pelist_setup => ensemble_pelist_setup, & + fms_ensemble_manager_get_ensemble_filter_pelist => get_ensemble_filter_pelist + use atmos_ocean_fluxes_mod, only: fms_atmos_ocean_fluxes_init => atmos_ocean_fluxes_init, & + fms_atmos_ocean_type_fluxes_init => atmos_ocean_type_fluxes_init, & + fms_atmos_ocean_fluxes_set_coupler_flux => aof_set_coupler_flux !> data_override - use data_override_mod, only: data_override_init, data_override, & - data_override_unset_domains, data_override_UG + use data_override_mod, only: fms_data_override_init => data_override_init, & + fms_data_override => data_override, & + fms_data_override_unset_domains => data_override_unset_domains, & + fms_data_override_UG => data_override_UG !> diag_integral - use diag_integral_mod, only: diag_integral_init, diag_integral_field_init, & - sum_diag_integral_field, diag_integral_output, & - diag_integral_end + use diag_integral_mod, only: fms_diag_integral_init => diag_integral_init, & + fms_diag_integral_field_init => diag_integral_field_init, & + fms_sum_diag_integral_field => sum_diag_integral_field, & + fms_diag_integral_output => diag_integral_output, & + fms_diag_integral_end => diag_integral_end !> diag_manager !! includes imports from submodules made public - use diag_manager_mod, only: diag_manager_init, send_data, send_tile_averaged_data, & - diag_manager_end, register_diag_field, register_static_field, & - diag_axis_init, get_base_time, get_base_date, need_data, & - DIAG_ALL, DIAG_OCEAN, DIAG_OTHER, get_date_dif, DIAG_SECONDS,& - DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, & - get_diag_global_att, set_diag_global_att, diag_field_add_attribute, & - diag_field_add_cell_measures, get_diag_field_id, & - diag_axis_add_attribute, diag_grid_init, diag_grid_end, & - diag_manager_set_time_end, diag_send_complete, & - diag_send_complete_instant, DIAG_FIELD_NOT_FOUND, & - CMOR_MISSING_VALUE, null_axis_id + use diag_manager_mod, only: fms_diag_init => diag_manager_init, & + fms_diag_send_data => send_data, & + fms_diag_send_tile_averaged_data => send_tile_averaged_data, & + fms_diag_end => diag_manager_end, & + fms_diag_register_diag_field => register_diag_field, & + fms_diag_register_static_field => register_static_field, & + fms_diag_axis_init => diag_axis_init, & + fms_diag_get_base_time => get_base_time, & + fms_diag_get_base_date => get_base_date, & + fms_diag_need_data => need_data, & + DIAG_ALL, & + DIAG_OCEAN, & + DIAG_OTHER, & + fms_get_date_dif => get_date_dif, & + DIAG_SECONDS,& + DIAG_MINUTES, & + DIAG_HOURS, & + DIAG_DAYS, & + DIAG_MONTHS, & + DIAG_YEARS, & + fms_diag_get_global_att => get_diag_global_att, & + fms_diag_set_global_att => set_diag_global_att, & + fms_diag_field_add_attribute => diag_field_add_attribute, & + fms_diag_field_add_cell_measures => diag_field_add_cell_measures, & + fms_diag_get_field_id => get_diag_field_id, & + fms_diag_axis_add_attribute => diag_axis_add_attribute, & + fms_diag_grid_init => diag_grid_init, & + fms_diag_grid_end => diag_grid_end, & + fms_diag_set_time_end => diag_manager_set_time_end, & + fms_diag_send_complete => diag_send_complete, & + fms_diag_send_complete_instant => diag_send_complete_instant, & + DIAG_FIELD_NOT_FOUND, & + CMOR_MISSING_VALUE, & + null_axis_id !> exchange - use xgrid_mod, only: xmap_type, setup_xmap, set_frac_area, put_to_xgrid, & - get_from_xgrid, xgrid_count, some, conservation_check, & - xgrid_init, AREA_ATM_SPHERE, AREA_OCN_SPHERE, AREA_ATM_MODEL, & - AREA_OCN_MODEL, get_ocean_model_area_elements, grid_box_type, & - get_xmap_grid_area, put_to_xgrid_ug, get_from_xgrid_ug, & - set_frac_area_ug, FIRST_ORDER, SECOND_ORDER, stock_move_ug, & - stock_move, stock_type, stock_print, get_index_range, & - stock_integrate_2d + use xgrid_mod, only: FmsXgridXmap_type => xmap_type, & + fms_xgrid_setup_xmap => setup_xmap, & + fms_xgrid_set_frac_area => set_frac_area, & + fms_xgrid_put_to_xgrid => put_to_xgrid, & + fms_xgrid_get_from_xgrid => get_from_xgrid, & + fms_xgrid_count => xgrid_count, & + fms_xgrid_some => some, & + fms_xgrid_conservation_check => conservation_check, & + fms_xgrid_init => xgrid_init, & + AREA_ATM_SPHERE, AREA_OCN_SPHERE, AREA_ATM_MODEL, AREA_OCN_MODEL, & + fms_xgrid_get_ocean_model_area_elements => get_ocean_model_area_elements, & + FmsXgridGridBox_type => grid_box_type, & + fms_xgrid_get_xmap_grid_area => get_xmap_grid_area, & + fms_xgrid_put_to_xgrid_ug => put_to_xgrid_ug, & + fms_xgrid_get_from_xgrid_ug => get_from_xgrid_ug, & + fms_xgrid_set_frac_area_ug => set_frac_area_ug, & + FIRST_ORDER, SECOND_ORDER, & + fms_xgrid_stock_move_ug => stock_move_ug, & + fms_xgrid_stock_move => stock_move, & + FmsXgridStock_type => stock_type, & + fms_xgrid_stock_print => stock_print, & + fms_xgrid_get_index_range => get_index_range, & + fms_xgrid_stock_integrate_2d => stock_integrate_2d use stock_constants_mod, only: NELEMS, ISTOCK_WATER, ISTOCK_HEAT, ISTOCK_SALT, & - ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, stocks_file, & - stocks_report, stocks_report_init, stocks_set_init_time, & - atm_stock, ocn_stock, lnd_stock, ice_stock + ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, & + fms_stock_constants_stocks_file => stocks_file, & + fms_stock_constants_stocks_report => stocks_report, & + fms_stocks_report_init => stocks_report_init, & + fms_stocks_set_init_time => stocks_set_init_time, & + fms_stock_constants_atm_stock => atm_stock, & + fms_stock_constants_ocn_stock => ocn_stock, & + fms_stock_constants_lnd_stock => lnd_stock, & + fms_stock_constants_ice_stock => ice_stock !> field manager - use field_manager_mod, only: field_manager_init, field_manager_end, find_field_index, & - get_field_info, & - get_field_method, get_field_methods, parse, fm_change_list, & - fm_change_root, fm_dump_list, fm_exists, fm_get_index, & - fm_get_current_list, fm_get_length, fm_get_type, fm_get_value, & - fm_init_loop, & - fm_loop_over_list, fm_new_list, fm_new_value, & - fm_reset_loop, fm_return_root, & - fm_modify_name, fm_query_method, fm_find_methods, fm_copy_list, & - fm_field_name_len, fm_path_name_len, & - fm_string_len, fm_type_name_len, NUM_MODELS, NO_FIELD, & - MODEL_ATMOS, MODEL_OCEAN, MODEL_LAND, MODEL_ICE, MODEL_COUPLER, & - method_type, method_type_short, & - method_type_very_short, fm_list_iter_type, default_method - use fm_util_mod, only: fm_util_start_namelist, fm_util_end_namelist, & - fm_util_check_for_bad_fields, fm_util_set_caller, & - fm_util_reset_caller, fm_util_set_no_overwrite, & - fm_util_reset_no_overwrite, fm_util_set_good_name_list, & - fm_util_reset_good_name_list, fm_util_get_length, & - fm_util_get_integer, fm_util_get_logical, fm_util_get_real, & - fm_util_get_string, fm_util_get_integer_array, & - fm_util_get_logical_array, fm_util_get_real_array, & - fm_util_get_string_array, fm_util_set_value, & - fm_util_set_value_integer_array, fm_util_set_value_logical_array, & - fm_util_set_value_real_array, fm_util_set_value_string_array, & - fm_util_set_value_integer, fm_util_set_value_logical, & - fm_util_set_value_real, fm_util_set_value_string, & - fm_util_get_index_list, fm_util_get_index_string, & - fm_util_default_caller + use field_manager_mod, only: fms_field_manager_init => field_manager_init, & + fms_field_manager_end => field_manager_end, & + fms_field_manager_find_field_index => find_field_index, & + fms_field_manager_get_field_info => get_field_info, & + fms_field_manager_get_field_method => get_field_method, & + fms_field_manager_get_field_methods => get_field_methods, & + fms_field_manager_parse => parse, & + fms_field_manager_fm_change_list => fm_change_list, & + fms_field_manager_fm_change_root => fm_change_root, & + fms_field_manager_fm_dump_list => fm_dump_list, & + fms_field_manager_fm_exists => fm_exists, & + fms_field_manager_fm_get_index => fm_get_index, & + fms_field_manager_fm_get_current_list => fm_get_current_list, & + fms_field_manager_fm_get_length => fm_get_length, & + fms_field_manager_fm_get_type => fm_get_type, & + fms_field_manager_fm_get_value => fm_get_value, & + fms_field_manager_fm_init_loop => fm_init_loop, & + fms_field_manager_fm_loop_over_list => fm_loop_over_list, & + fms_field_manager_fm_new_list => fm_new_list, & + fms_field_manager_fm_new_value => fm_new_value, & + fms_field_manager_fm_reset_loop => fm_reset_loop, & + fms_field_manager_fm_return_root => fm_return_root, & + fms_field_manager_fm_modify_name => fm_modify_name, & + fms_field_manager_fm_query_method => fm_query_method, & + fms_field_manager_fm_find_methods => fm_find_methods, & + fms_field_manager_fm_copy_list => fm_copy_list, & + fms_field_manager_fm_field_name_len => fm_field_name_len, & + fms_field_manager_fm_path_name_len => fm_path_name_len, & + fms_field_manager_fm_string_len => fm_string_len, & + fms_field_manager_fm_type_name_len => fm_type_name_len, & + NUM_MODELS, NO_FIELD, MODEL_ATMOS, MODEL_OCEAN, MODEL_LAND, MODEL_ICE, MODEL_COUPLER, & + FmsFieldManagerMethod_type => method_type, & + FmsFieldManagerMethodShort_type => method_type_short, & + FmsFieldManagerMethodVeryShort_type => method_type_very_short, & + FmsFieldManagerListIterator_type => fm_list_iter_type, & + fms_field_manager_default_method => default_method + use fm_util_mod, only: fms_fm_util_start_namelist => fm_util_start_namelist, & + fms_fm_util_end_namelist => fm_util_end_namelist, & + fms_fm_util_check_for_bad_fields => fm_util_check_for_bad_fields, & + fms_fm_util_set_caller => fm_util_set_caller, & + fms_fm_util_reset_caller => fm_util_reset_caller, & + fms_fm_util_set_no_overwrite => fm_util_set_no_overwrite, & + fms_fm_util_reset_no_overwrite => fm_util_reset_no_overwrite, & + fms_fm_util_set_good_name_list => fm_util_set_good_name_list, & + fms_fm_util_reset_good_name_list => fm_util_reset_good_name_list, & + fms_fm_util_get_length => fm_util_get_length, & + fms_fm_util_get_integer => fm_util_get_integer, & + fms_fm_util_get_logical => fm_util_get_logical, & + fms_fm_util_get_real => fm_util_get_real, & + fms_fm_util_get_string => fm_util_get_string, & + fms_fm_util_get_integer_array => fm_util_get_integer_array, & + fms_fm_util_get_logical_array => fm_util_get_logical_array, & + fms_fm_util_get_real_array => fm_util_get_real_array, & + fms_fm_util_get_string_array => fm_util_get_string_array, & + fms_fm_util_set_value => fm_util_set_value, & + fms_fm_util_set_value_integer_array => fm_util_set_value_integer_array, & + fms_fm_util_set_value_logical_array => fm_util_set_value_logical_array, & + fms_fm_util_set_value_real_array => fm_util_set_value_real_array, & + fms_fm_util_set_value_string_array => fm_util_set_value_string_array, & + fms_fm_util_set_value_integer => fm_util_set_value_integer, & + fms_fm_util_set_value_logical => fm_util_set_value_logical, & + fms_fm_util_set_value_real => fm_util_set_value_real, & + fms_fm_util_set_value_string => fm_util_set_value_string, & + fms_fm_util_get_index_list => fm_util_get_index_list, & + fms_fm_util_get_index_string => fm_util_get_index_string, & + fms_fm_util_default_caller => fm_util_default_caller !> fms2_io + !! TODO need to see opinions on these + !! not sure if we need fms_ prefix for routines + !! types do not follow our typical naming convention(no _type and uses camel case instead of _ spacing) use fms2_io_mod, only: unlimited, FmsNetcdfFile_t, FmsNetcdfDomainFile_t, & - FmsNetcdfUnstructuredDomainFile_t, open_file, open_virtual_file, & - close_file, register_axis, register_field, register_restart_field, & - write_data, read_data, write_restart, write_new_restart, & - read_restart, read_new_restart, global_att_exists, & - variable_att_exists, register_global_attribute, & - register_variable_attribute, get_global_attribute, & - get_variable_attribute, get_num_dimensions, & - get_dimension_names, dimension_exists, is_dimension_unlimited, & - get_dimension_size, get_num_variables, get_variable_names, & - variable_exists, get_variable_num_dimensions, & - get_variable_dimension_names, get_variable_size, & - get_compute_domain_dimension_indices, & - get_global_io_domain_indices, Valid_t, get_valid, is_valid, & - get_unlimited_dimension_name, get_variable_unlimited_dimension_index, & - file_exists, compressed_start_and_count, get_variable_sense, & - get_variable_missing, get_variable_units, get_time_calendar, & - open_check, is_registered_to_restart, check_if_open, & - set_fileobj_time_name, is_dimension_registered, & - fms2_io_init, get_mosaic_tile_grid, & - write_restart_bc, read_restart_bc, get_filename_appendix, & !> 2021.02-a1 - set_filename_appendix, get_instance_filename, & - nullify_filename_appendix, ascii_read, get_mosaic_tile_file, & - parse_mask_table + FmsNetcdfUnstructuredDomainFile_t, & + Valid_t, & + fms2_io_open_file => open_file, & + fms2_io_open_virtual_file => open_virtual_file, & + fms2_io_close_file => close_file, & + fms2_io_register_axis => register_axis, & + fms2_io_register_field => register_field, & + fms2_io_register_restart_field => register_restart_field, & + fms2_io_write_data => write_data, & + fms2_io_read_data => read_data, & + fms2_io_write_restart => write_restart, & + fms2_io_write_new_restart => write_new_restart, & + fms2_io_read_restart => read_restart, & + fms2_io_read_new_restart => read_new_restart, & + fms2_io_global_att_exists => global_att_exists, & + fms2_io_variable_att_exists => variable_att_exists, & + fms2_io_register_global_attribute => register_global_attribute, & + fms2_io_register_variable_attribute => register_variable_attribute, & + fms2_io_get_global_attribute => get_global_attribute, & + fms2_io_get_variable_attribute => get_variable_attribute, & + fms2_io_get_num_dimensions => get_num_dimensions, & + fms2_io_get_dimension_names => get_dimension_names, & + fms2_io_dimension_exists => dimension_exists, & + fms2_io_is_dimension_unlimited => is_dimension_unlimited, & + fms2_io_get_dimension_size => get_dimension_size, & + fms2_io_get_num_variables => get_num_variables, & + fms2_io_get_variable_names => get_variable_names, & + fms2_io_variable_exists => variable_exists, & + fms2_io_get_variable_num_dimensions => get_variable_num_dimensions, & + fms2_io_get_variable_dimension_names => get_variable_dimension_names, & + fms2_io_get_variable_size => get_variable_size, & + fms2_io_get_compute_domain_dimension_indices => get_compute_domain_dimension_indices, & + fms2_io_get_global_io_domain_indices => get_global_io_domain_indices, & + fms2_io_get_valid => get_valid, & + fms2_io_is_valid => is_valid, & + fms2_io_get_unlimited_dimension_name => get_unlimited_dimension_name, & + fms2_io_get_variable_unlimited_dimension_index => get_variable_unlimited_dimension_index, & + fms2_io_file_exists => file_exists, & + fms2_io_compressed_start_and_count => compressed_start_and_count, & + fms2_io_get_variable_sense => get_variable_sense, & + fms2_io_get_variable_missing => get_variable_missing, & + fms2_io_get_variable_units => get_variable_units, & + fms2_io_get_time_calendar => get_time_calendar, & + fms2_io_open_check => open_check, & + fms2_io_is_registered_to_restart => is_registered_to_restart, & + fms2_io_check_if_open => check_if_open, & + fms2_io_set_fileobj_time_name => set_fileobj_time_name, & + fms2_io_is_dimension_registered => is_dimension_registered, & + fms2_io_fms2_io_init => fms2_io_init, & + fms2_io_get_mosaic_tile_grid => get_mosaic_tile_grid, & + fms2_io_write_restart_bc => write_restart_bc, & + fms2_io_read_restart_bc => read_restart_bc, & + fms2_io_get_filename_appendix => get_filename_appendix, & + fms2_io_set_filename_appendix => set_filename_appendix, & + fms2_io_get_instance_filename => get_instance_filename, & + fms2_io_nullify_filename_appendix => nullify_filename_appendix, & + fms2_io_ascii_read => ascii_read, & + fms2_io_get_mosaic_tile_file => get_mosaic_tile_file, & + fms2_io_parse_mask_table => parse_mask_table ! used via fms2_io - ! fms_io_utils_mod, fms_netcdf_domain_io_mod, netcdf_io_mod, + ! fms_io_utils_mod, fms_netcdf_domain_io_mod, netcdf_io_mod, & ! fms_netcdf_unstructured_domain_io_mod, blackboxio !> fms !! routines that don't conflict with fms2_io - use fms_mod, only: fms_init, fms_end, error_mesg, fms_error_handler, check_nml_error, & - monotonic_array, string_array_index, clock_flag_default, & - print_memory_usage, write_version_number + use fms_mod, only: fms_init, fms_end, error_mesg, fms_error_handler, & + check_nml_error, & + fms_monotonic_array => monotonic_array, fms_string_array_index => string_array_index, & + fms_clock_flag_default => clock_flag_default, fms_print_memory_usage => print_memory_usage, & + fms_write_version_number => write_version_number !> horiz_interp - use horiz_interp_mod, only: horiz_interp, horiz_interp_new, horiz_interp_del, & - horiz_interp_init, horiz_interp_end - use horiz_interp_type_mod, only: horiz_interp_type, assignment(=), CONSERVE, & - BILINEAR, SPHERICA, BICUBIC, stats + use horiz_interp_mod, only: fms_horiz_interp => horiz_interp, fms_horiz_interp_new => horiz_interp_new, & + fms_horiz_interp_del => horiz_interp_del, fms_horiz_interp_init => horiz_interp_init, & + fms_horiz_interp_end => horiz_interp_end + use horiz_interp_type_mod, only: FmsHorizInterp_type => horiz_interp_type, & + assignment(=), CONSERVE, BILINEAR, SPHERICA, BICUBIC, & + fms_horiz_interp_type_stats => stats !! used via horiz_interp ! horiz_interp_bicubic_mod, horiz_interp_bilinear_mod ! horiz_interp_conserve_mod, horiz_interp_spherical_mod !> interpolator - use interpolator_mod, only: interpolator_init, interpolator, interpolate_type_eq, & - obtain_interpolator_time_slices, unset_interpolator_time_flag, & - interpolator_end, init_clim_diag, query_interpolator, & - interpolate_type, CONSTANT, & - INTERP_WEIGHTED_P, INTERP_LINEAR_P, INTERP_LOG_P, & - INTERPOLATOR_ZERO=>ZERO, & !! conflicts with mpp_parameter's ZERO - interpolator_read_data=>read_data !! conflicts with fms2_io interface + use interpolator_mod, only: fms_interpolator_init => interpolator_init, & + fms_interpolator => interpolator, & + fms_interpolate_type_eq => interpolate_type_eq, & + fms_interpolator_obtain_interpolator_time_slices => obtain_interpolator_time_slices, & + fms_interpolator_unset_interpolator_time_flag => unset_interpolator_time_flag, & + fms_interpolator_end => interpolator_end, & + fms_interpolator_init_clim_diag => init_clim_diag, & + fms_interpolator_query_interpolator => query_interpolator, & + FmsInterpolate_type => interpolate_type, & + CONSTANT, INTERP_WEIGHTED_P, INTERP_LINEAR_P, INTERP_LOG_P, & + FMS_INTERPOLATOR_ZERO=>ZERO, & !! conflicts with mpp_parameter's ZERO + fms_interpolator_read_data=>read_data !> memutils - use memutils_mod, only: memutils_init, print_memuse_stats + use memutils_mod, only: fms_memutils_init => memutils_init, & + fms_memutils_print_memuse_stats => print_memuse_stats !> monin_obukhov - use monin_obukhov_mod, only: monin_obukhov_init, monin_obukhov_end, & - mo_drag, mo_profile, mo_diff, stable_mix - use monin_obukhov_inter, only: monin_obukhov_diff, monin_obukhov_drag_1d, & - monin_obukhov_solve_zeta, monin_obukhov_derivative_t, & - monin_obukhov_derivative_m, monin_obukhov_profile_1d, & - monin_obukhov_integral_m, monin_obukhov_integral_tq, & - monin_obukhov_stable_mix + use monin_obukhov_mod, only: fms_monin_obukhov_init => monin_obukhov_init, & + fms_monin_obukhov_end => monin_obukhov_end, & + fms_monin_obukhov_mo_drag => mo_drag, & + fms_monin_obukhov_mo_profile => mo_profile, & + fms_monin_obukhov_mo_diff => mo_diff, & + fms_monin_obukhov_stable_mix => stable_mix + use monin_obukhov_inter, only: fms_monin_obukhov_inter_diff => monin_obukhov_diff, & + fms_monin_obukhov_inter_drag_1d => monin_obukhov_drag_1d, & + fms_monin_obukhov_inter_solve_zeta => monin_obukhov_solve_zeta, & + fms_monin_obukhov_inter_derivative_t => monin_obukhov_derivative_t, & + fms_monin_obukhov_inter_derivative_m => monin_obukhov_derivative_m, & + fms_monin_obukhov_inter_profile_1d => monin_obukhov_profile_1d, & + fms_monin_obukhov_inter_integral_m => monin_obukhov_integral_m, & + fms_monin_obukhov_inter_integral_tq => monin_obukhov_integral_tq, & + fms_monin_obukhov_inter_stable_mix => monin_obukhov_stable_mix !> mosaic - use mosaic2_mod, only: get_mosaic_ntiles, get_mosaic_ncontacts, & - get_mosaic_grid_sizes, get_mosaic_contact, & - get_mosaic_xgrid_size, get_mosaic_xgrid, & - calc_mosaic_grid_area, calc_mosaic_grid_great_circle_area, & - is_inside_polygon, & - mosaic2_get_mosaic_tile_grid => get_mosaic_tile_grid !overloaded in fms2_io - use grid2_mod, only: get_grid_ntiles, get_grid_size, get_grid_cell_centers, & - get_grid_cell_vertices, get_grid_cell_Area, get_grid_comp_area, & - define_cube_mosaic, get_great_circle_algorithm, grid_init, grid_end - use gradient_mod, only: gradient_cubic, calc_cubic_grid_info + use mosaic2_mod, only: fms_mosaic2_get_mosaic_ntiles => get_mosaic_ntiles, & + fms_mosaic2_get_mosaic_ncontacts => get_mosaic_ncontacts, & + fms_mosaic2_get_mosaic_grid_sizes => get_mosaic_grid_sizes, & + fms_mosaic2_get_mosaic_contact => get_mosaic_contact, & + fms_mosaic2_get_mosaic_xgrid_size => get_mosaic_xgrid_size, & + fms_mosaic2_get_mosaic_xgrid => get_mosaic_xgrid, & + fms_mosaic2_calc_mosaic_grid_area => calc_mosaic_grid_area, & + fms_mosaic2_calc_mosaic_grid_great_circle_area => calc_mosaic_grid_great_circle_area, & + fms_mosaic2_is_inside_polygon => is_inside_polygon, & + fms_mosaic2_get_mosaic_tile_grid => get_mosaic_tile_grid !overloaded in fms2_io + use grid2_mod, only: fms_grid2_get_grid_ntiles => get_grid_ntiles, & + fms_grid2_get_grid_size => get_grid_size, & + fms_grid2_get_grid_cell_centers => get_grid_cell_centers, & + fms_grid2_get_grid_cell_vertices => get_grid_cell_vertices, & + fms_grid2_get_grid_cell_Area => get_grid_cell_Area, & + fms_grid2_get_grid_comp_area => get_grid_comp_area, & + fms_grid2_define_cube_mosaic => define_cube_mosaic, & + fms_grid2_get_great_circle_algorithm => get_great_circle_algorithm, & + fms_grid2_grid_init => grid_init, & + fms_grid2_end => grid_end + use gradient_mod, only: fms_gradient_cubic => gradient_cubic, & + fms_gradient_calc_cubic_grid_info => calc_cubic_grid_info !> mpp - use mpp_mod, only: stdin, stdout, stderr, & - stdlog, lowercase, uppercase, mpp_error, mpp_error_state, & - mpp_set_warn_level, mpp_sync, mpp_sync_self, mpp_set_stack_size, & - mpp_pe, mpp_npes, mpp_root_pe, mpp_set_root_pe, mpp_declare_pelist, & - mpp_get_current_pelist, mpp_set_current_pelist, & - mpp_get_current_pelist_name, mpp_clock_id, mpp_clock_set_grain, & - mpp_record_timing_data, get_unit, read_ascii_file, read_input_nml, & - mpp_clock_begin, mpp_clock_end, get_ascii_file_num_lines, & - mpp_record_time_start, mpp_record_time_end, mpp_chksum, & - mpp_max, mpp_min, mpp_sum, mpp_transmit, mpp_send, mpp_recv, & - mpp_sum_ad, mpp_broadcast, mpp_init, mpp_exit, mpp_gather, & - mpp_scatter, mpp_alltoall, mpp_type, mpp_byte, mpp_type_create, & - mpp_type_free, input_nml_file + use mpp_mod, only: fms_mpp_stdin => stdin, & + fms_mpp_stdout => stdout, & + fms_mpp_stderr => stderr, & + fms_mpp_stdlog => stdlog, & + fms_mpp_lowercase => lowercase, & + fms_mpp_uppercase => uppercase, & + fms_mpp_error => mpp_error, & + fms_mpp_error_state => mpp_error_state, & + fms_mpp_set_warn_level => mpp_set_warn_level, & + fms_mpp_sync => mpp_sync, & + fms_mpp_sync_self => mpp_sync_self, & + fms_mpp_set_stack_size => mpp_set_stack_size, & + fms_mpp_pe => mpp_pe, & + fms_mpp_npes => mpp_npes, & + fms_mpp_root_pe => mpp_root_pe, & + fms_mpp_set_root_pe => mpp_set_root_pe, & + fms_mpp_declare_pelist => mpp_declare_pelist, & + fms_mpp_get_current_pelist => mpp_get_current_pelist, & + fms_mpp_set_current_pelist => mpp_set_current_pelist, & + fms_mpp_get_current_pelist_name => mpp_get_current_pelist_name, & + fms_mpp_clock_id => mpp_clock_id, & + fms_mpp_clock_set_grain => mpp_clock_set_grain, & + fms_mpp_record_timing_data => mpp_record_timing_data, & + fms_mpp_get_unit => get_unit, & + fms_mpp_read_ascii_file => read_ascii_file, & + fms_mpp_read_input_nml => read_input_nml, & + fms_mpp_clock_begin => mpp_clock_begin, & + fms_mpp_clock_end => mpp_clock_end, & + fms_mpp_get_ascii_file_num_lines => get_ascii_file_num_lines, & + fms_mpp_record_time_start => mpp_record_time_start, & + fms_mpp_record_time_end => mpp_record_time_end, & + fms_mpp_chksum => mpp_chksum, & + fms_mpp_max => mpp_max, & + fms_mpp_min => mpp_min, & + fms_mpp_sum => mpp_sum, & + fms_mpp_transmit => mpp_transmit, & + fms_mpp_send => mpp_send, & + fms_mpp_recv => mpp_recv, & + fms_mpp_sum_ad => mpp_sum_ad, & + fms_mpp_broadcast => mpp_broadcast, & + fms_mpp_init => mpp_init, & + fms_mpp_exit => mpp_exit, & + fms_mpp_gather => mpp_gather, & + fms_mpp_scatter => mpp_scatter, & + fms_mpp_alltoall => mpp_alltoall, & + FmsMpp_type => mpp_type, & + FmsMpp_byte => mpp_byte, & + fms_mpp_type_create => mpp_type_create, & + fms_mpp_type_free => mpp_type_free, & + fms_mpp_input_nml_file => input_nml_file use mpp_parameter_mod,only:MAXPES, MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE, & NOTE, WARNING, FATAL, MPP_WAIT, MPP_READY, MAX_CLOCKS, & MAX_EVENT_TYPES, MAX_EVENTS, MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, & @@ -298,74 +548,161 @@ module fms MAX_DOMAIN_FIELDS, MAX_TILES, ZERO, NINETY, MINUS_NINETY, & ONE_HUNDRED_EIGHTY, NONBLOCK_UPDATE_TAG, EDGEUPDATE, EDGEONLY, & NONSYMEDGEUPDATE, NONSYMEDGE - use mpp_data_mod, only: stat, mpp_stack, ptr_stack, status, ptr_status, sync, & - ptr_sync, mpp_from_pe, ptr_from, remote_Data_loc, & - ptr_remote, mpp_domains_stack, ptr_domains_stack, & - mpp_domains_stack_nonblock, ptr_domains_stack_nonblock - use mpp_utilities_mod, only: mpp_array_global_min_max - use mpp_memutils_mod, only: mpp_print_memuse_stats, mpp_mem_dump, & - mpp_memuse_begin, mpp_memuse_end - use mpp_efp_mod, only: mpp_reproducing_sum, mpp_efp_list_sum_across_PEs, & - mpp_efp_plus, mpp_efp_minus, mpp_efp_to_real, & - mpp_real_to_efp, mpp_efp_real_diff, operator(+), & - operator(-), assignment(=), mpp_query_efp_overflow_error, & - mpp_reset_efp_overflow_error, mpp_efp_type - use mpp_domains_mod, only: domain_axis_spec, domain1D, domain2D, DomainCommunicator2D, & - nest_domain_type, mpp_group_update_type, & - mpp_domains_set_stack_size, mpp_get_compute_domain, & - mpp_get_compute_domains, mpp_get_data_domain, & - mpp_get_global_domain, mpp_get_domain_components, & - mpp_get_layout, mpp_get_pelist, operator(.EQ.), operator(.NE.), & - mpp_domain_is_symmetry, mpp_domain_is_initialized, & - mpp_get_neighbor_pe, mpp_nullify_domain_list, & - mpp_set_compute_domain, mpp_set_data_domain, mpp_set_global_domain, & - mpp_get_memory_domain, mpp_get_domain_shift, & - mpp_domain_is_tile_root_pe, mpp_get_tile_id, & - mpp_get_domain_extents, mpp_get_current_ntile, & - mpp_get_ntile_count, mpp_get_tile_list, mpp_get_tile_npes, & - mpp_get_domain_root_pe, mpp_get_tile_pelist, & - mpp_get_tile_compute_domains, mpp_get_num_overlap, & - mpp_get_overlap, mpp_get_io_domain, mpp_get_domain_pe, & - mpp_get_domain_tile_root_pe, mpp_get_domain_name, & - mpp_get_io_domain_layout, mpp_copy_domain, mpp_set_domain_symmetry, & - mpp_get_update_pelist, mpp_get_update_size, & - mpp_get_domain_npes, mpp_get_domain_pelist, & - mpp_clear_group_update, mpp_group_update_initialized, & - mpp_group_update_is_set, mpp_get_global_domains, & - mpp_global_field, mpp_global_max, mpp_global_min, mpp_global_sum, & - mpp_global_sum_tl, mpp_global_sum_ad, mpp_broadcast_domain, & - mpp_domains_init, mpp_domains_exit, mpp_redistribute, & - mpp_update_domains, mpp_check_field, mpp_start_update_domains, & - mpp_complete_update_domains, mpp_create_group_update, & - mpp_do_group_update, mpp_start_group_update, & - mpp_complete_group_update, mpp_reset_group_update_field, & - mpp_update_nest_fine, mpp_update_nest_coarse, mpp_get_boundary, & - mpp_update_domains_ad, mpp_get_boundary_ad, mpp_pass_SG_to_UG, & - mpp_pass_UG_to_SG, mpp_define_layout, mpp_define_domains, & - mpp_modify_domain, mpp_define_mosaic, mpp_define_mosaic_pelist, & - mpp_define_null_domain, mpp_mosaic_defined, & - mpp_define_io_domain, mpp_deallocate_domain, & - mpp_compute_extent, mpp_compute_block_extent, & - mpp_define_unstruct_domain, domainUG, mpp_get_UG_io_domain, & - mpp_get_UG_domain_npes, mpp_get_UG_compute_domain, & - mpp_get_UG_domain_tile_id, mpp_get_UG_domain_pelist, & - mpp_get_ug_domain_grid_index, mpp_get_UG_domain_ntiles, & - mpp_get_UG_global_domain, mpp_global_field_ug, & - mpp_get_ug_domain_tile_list, mpp_get_UG_compute_domains, & - mpp_define_null_UG_domain, NULL_DOMAINUG, mpp_get_UG_domains_index, & - mpp_get_UG_SG_domain, mpp_get_UG_domain_tile_pe_inf, & - mpp_define_nest_domains, mpp_get_C2F_index, mpp_get_F2C_index, & - mpp_get_nest_coarse_domain, mpp_get_nest_fine_domain, & - mpp_is_nest_coarse, mpp_is_nest_fine, & - mpp_get_nest_pelist, mpp_get_nest_npes, & - mpp_get_nest_fine_pelist, mpp_get_nest_fine_npes, & - mpp_domain_UG_is_tile_root_pe, mpp_deallocate_domainUG, & - mpp_get_io_domain_UG_layout, NULL_DOMAIN1D, NULL_DOMAIN2D, & - mpp_create_super_grid_domain, mpp_shift_nest_domains + ! this should really only be used internally + !use mpp_data_mod, only: stat, mpp_stack, ptr_stack, status, ptr_status, sync, & + ! ptr_sync, mpp_from_pe, ptr_from, remote_Data_loc, & + ! ptr_remote, mpp_domains_stack, ptr_domains_stack, & + ! mpp_domains_stack_nonblock, ptr_domains_stack_nonblock + use mpp_utilities_mod, only: fms_mpp_utilities_array_global_min_max => mpp_array_global_min_max + use mpp_memutils_mod, only: fms_mpp_memutils_print_memuse_stats => mpp_print_memuse_stats, & + fms_mpp_memutils_mem_dump => mpp_mem_dump, & + fms_mpp_memutils_memuse_begin => mpp_memuse_begin, & + fms_mpp_memutils_memuse_end => mpp_memuse_end + use mpp_efp_mod, only: fms_mpp_efp_reproducing_sum => mpp_reproducing_sum, & + fms_mpp_efp_list_sum_across_PEs => mpp_efp_list_sum_across_PEs, & + fms_mpp_efp_plus => mpp_efp_plus, & + fms_mpp_efp_minus => mpp_efp_minus, & + fms_mpp_efp_to_real => mpp_efp_to_real, & + fms_mpp_efp_real_to_efp => mpp_real_to_efp, & + fms_mpp_efp_real_diff => mpp_efp_real_diff, & + operator(+), operator(-), assignment(=), & + fms_mpp_efp_query_overflow_error => mpp_query_efp_overflow_error, & + fms_mpp_efp_reset_overflow_error => mpp_reset_efp_overflow_error, & + FmsMppEfp_type => mpp_efp_type + use mpp_domains_mod, only: FmsMppDomains_axis_spec => domain_axis_spec, & + FmsMppDomain1D => domain1D, & + FmsMppDomain2D => domain2D, & + FmsMppDomainCommunicator2D => DomainCommunicator2D, & + FmsMppDomainsNestDomain_type => nest_domain_type, & + FmsMppDomainsGroupUpdate_type => mpp_group_update_type, & + fms_mpp_domains_domains_set_stack_size => mpp_domains_set_stack_size, & + fms_mpp_domains_get_compute_domain => mpp_get_compute_domain, & + fms_mpp_domains_get_compute_domains => mpp_get_compute_domains, & + fms_mpp_domains_get_data_domain => mpp_get_data_domain, & + fms_mpp_domains_get_global_domain => mpp_get_global_domain, & + fms_mpp_domains_get_domain_components => mpp_get_domain_components, & + fms_mpp_domains_get_layout => mpp_get_layout, & + fms_mpp_domains_get_pelist => mpp_get_pelist, & + operator(.EQ.), operator(.NE.), & + fms_mpp_domains_domain_is_symmetry => mpp_domain_is_symmetry, & + fms_mpp_domains_domain_is_initialized => mpp_domain_is_initialized, & + fms_mpp_domains_get_neighbor_pe => mpp_get_neighbor_pe, & + fms_mpp_domains_nullify_domain_list => mpp_nullify_domain_list, & + fms_mpp_domains_set_compute_domain => mpp_set_compute_domain, & + fms_mpp_domains_set_data_domain => mpp_set_data_domain, & + fms_mpp_domains_set_global_domain => mpp_set_global_domain, & + fms_mpp_domains_get_memory_domain => mpp_get_memory_domain, & + fms_mpp_domains_get_domain_shift => mpp_get_domain_shift, & + fms_mpp_domains_domain_is_tile_root_pe => mpp_domain_is_tile_root_pe, & + fms_mpp_domains_get_tile_id => mpp_get_tile_id, & + fms_mpp_domains_get_domain_extents => mpp_get_domain_extents, & + fms_mpp_domains_get_current_ntile => mpp_get_current_ntile, & + fms_mpp_domains_get_ntile_count => mpp_get_ntile_count, & + fms_mpp_domains_get_tile_list => mpp_get_tile_list, & + fms_mpp_domains_get_tile_npes => mpp_get_tile_npes, & + fms_mpp_domains_get_domain_root_pe => mpp_get_domain_root_pe, & + fms_mpp_domains_get_tile_pelist => mpp_get_tile_pelist, & + fms_mpp_domains_get_tile_compute_domains => mpp_get_tile_compute_domains, & + fms_mpp_domains_get_num_overlap => mpp_get_num_overlap, & + fms_mpp_domains_get_overlap => mpp_get_overlap, & + fms_mpp_domains_get_io_domain => mpp_get_io_domain, & + fms_mpp_domains_get_domain_pe => mpp_get_domain_pe, & + fms_mpp_domains_get_domain_tile_root_pe => mpp_get_domain_tile_root_pe, & + fms_mpp_domains_get_domain_name => mpp_get_domain_name, & + fms_mpp_domains_get_io_domain_layout => mpp_get_io_domain_layout, & + fms_mpp_domains_copy_domain => mpp_copy_domain, & + fms_mpp_domains_set_domain_symmetry => mpp_set_domain_symmetry, & + fms_mpp_domains_get_update_pelist => mpp_get_update_pelist, & + fms_mpp_domains_get_update_size => mpp_get_update_size, & + fms_mpp_domains_get_domain_npes => mpp_get_domain_npes, & + fms_mpp_domains_get_domain_pelist => mpp_get_domain_pelist, & + fms_mpp_domains_clear_group_update => mpp_clear_group_update, & + fms_mpp_domains_group_update_initialized => mpp_group_update_initialized, & + fms_mpp_domains_group_update_is_set => mpp_group_update_is_set, & + fms_mpp_domains_get_global_domains => mpp_get_global_domains, & + fms_mpp_domains_global_field => mpp_global_field, & + fms_mpp_domains_global_max => mpp_global_max, & + fms_mpp_domains_global_min => mpp_global_min, & + fms_mpp_domains_global_sum => mpp_global_sum, & + fms_mpp_domains_global_sum_tl => mpp_global_sum_tl, & + fms_mpp_domains_global_sum_ad => mpp_global_sum_ad, & + fms_mpp_domains_broadcast_domain => mpp_broadcast_domain, & + fms_mpp_domains_init => mpp_domains_init, & + fms_mpp_domains_exit => mpp_domains_exit, & + fms_mpp_domains_redistribute => mpp_redistribute, & + fms_mpp_domains_update_domains => mpp_update_domains, & + fms_mpp_domains_check_field => mpp_check_field, & + fms_mpp_domains_start_update_domains => mpp_start_update_domains, & + fms_mpp_domains_complete_update_domains => mpp_complete_update_domains, & + fms_mpp_domains_create_group_update => mpp_create_group_update, & + fms_mpp_domains_do_group_update => mpp_do_group_update, & + fms_mpp_domains_start_group_update => mpp_start_group_update, & + fms_mpp_domains_complete_group_update => mpp_complete_group_update, & + fms_mpp_domains_reset_group_update_field => mpp_reset_group_update_field, & + fms_mpp_domains_update_nest_fine => mpp_update_nest_fine, & + fms_mpp_domains_update_nest_coarse => mpp_update_nest_coarse, & + fms_mpp_domains_get_boundary => mpp_get_boundary, & + fms_mpp_domains_update_domains_ad => mpp_update_domains_ad, & + fms_mpp_domains_get_boundary_ad => mpp_get_boundary_ad, & + fms_mpp_domains_pass_SG_to_UG => mpp_pass_SG_to_UG, & + fms_mpp_domains_pass_UG_to_SG => mpp_pass_UG_to_SG, & + fms_mpp_domains_define_layout => mpp_define_layout, & + fms_mpp_domains_define_domains => mpp_define_domains, & + fms_mpp_domains_modify_domain => mpp_modify_domain, & + fms_mpp_domains_define_mosaic => mpp_define_mosaic, & + fms_mpp_domains_define_mosaic_pelist => mpp_define_mosaic_pelist, & + fms_mpp_domains_define_null_domain => mpp_define_null_domain, & + fms_mpp_domains_mosaic_defined => mpp_mosaic_defined, & + fms_mpp_domains_define_io_domain => mpp_define_io_domain, & + fms_mpp_domains_deallocate_domain => mpp_deallocate_domain, & + fms_mpp_domains_compute_extent => mpp_compute_extent, & + fms_mpp_domains_compute_block_extent => mpp_compute_block_extent, & + fms_mpp_domains_define_unstruct_domain => mpp_define_unstruct_domain, & + fmsMppDomainUG => domainUG, & + fms_mpp_domains_get_UG_io_domain => mpp_get_UG_io_domain, & + fms_mpp_domains_get_UG_domain_npes => mpp_get_UG_domain_npes, & + fms_mpp_domains_get_UG_compute_domain => mpp_get_UG_compute_domain, & + fms_mpp_domains_get_UG_domain_tile_id => mpp_get_UG_domain_tile_id, & + fms_mpp_domains_get_UG_domain_pelist => mpp_get_UG_domain_pelist, & + fms_mpp_domains_get_ug_domain_grid_index => mpp_get_ug_domain_grid_index, & + fms_mpp_domains_get_UG_domain_ntiles => mpp_get_UG_domain_ntiles, & + fms_mpp_domains_get_UG_global_domain => mpp_get_UG_global_domain, & + fms_mpp_domains_global_field_ug => mpp_global_field_ug, & + fms_mpp_domains_get_ug_domain_tile_list => mpp_get_ug_domain_tile_list, & + fms_mpp_domains_get_UG_compute_domains => mpp_get_UG_compute_domains, & + fms_mpp_domains_define_null_UG_domain => mpp_define_null_UG_domain, & + fms_mpp_domains_NULL_DOMAINUG => NULL_DOMAINUG, & + fms_mpp_domains_get_UG_domains_index => mpp_get_UG_domains_index, & + fms_mpp_domains_get_UG_SG_domain => mpp_get_UG_SG_domain, & + fms_mpp_domains_get_UG_domain_tile_pe_inf => mpp_get_UG_domain_tile_pe_inf, & + fms_mpp_domains_define_nest_domains => mpp_define_nest_domains, & + fms_mpp_domains_get_C2F_index => mpp_get_C2F_index, & + fms_mpp_domains_get_F2C_index => mpp_get_F2C_index, & + fms_mpp_domains_get_nest_coarse_domain => mpp_get_nest_coarse_domain, & + fms_mpp_domains_get_nest_fine_domain => mpp_get_nest_fine_domain, & + fms_mpp_domains_is_nest_coarse => mpp_is_nest_coarse, & + fms_mpp_domains_is_nest_fine => mpp_is_nest_fine, & + fms_mpp_domains_get_nest_pelist => mpp_get_nest_pelist, & + fms_mpp_domains_get_nest_npes => mpp_get_nest_npes, & + fms_mpp_domains_get_nest_fine_pelist => mpp_get_nest_fine_pelist, & + fms_mpp_domains_get_nest_fine_npes => mpp_get_nest_fine_npes, & + fms_mpp_domains_domain_UG_is_tile_root_pe => mpp_domain_UG_is_tile_root_pe, & + fms_mpp_domains_deallocate_domainUG => mpp_deallocate_domainUG, & + fms_mpp_domains_get_io_domain_UG_layout => mpp_get_io_domain_UG_layout, & + NULL_DOMAIN1D, & + NULL_DOMAIN2D, & + fms_mpp_domains_create_super_grid_domain => mpp_create_super_grid_domain, & + fms_mpp_domains_shift_nest_domains => mpp_shift_nest_domains !> parser #ifdef use_yaml - use yaml_parser_mod, only: open_and_parse_file, get_num_blocks, get_block_ids, get_value_from_key, & - get_nkeys, get_key_ids, get_key_name, get_key_value + use yaml_parser_mod, only: fms_yaml_parser_open_and_parse_file => open_and_parse_file, & + fms_yaml_parser_get_num_blocks => get_num_blocks, & + fms_yaml_parser_get_block_ids => get_block_ids, & + fms_yaml_parser_get_value_from_key => get_value_from_key, & + fms_yaml_parser_get_nkeys => get_nkeys, & + fms_yaml_parser_get_key_ids => get_key_ids, & + fms_yaml_parser_get_key_name => get_key_name, & + fms_yaml_parser_get_key_value => get_key_value #endif !> platform @@ -373,64 +710,124 @@ module fms l8_kind, l4_kind, i2_kind, ptr_kind !> random_numbers - use random_numbers_mod, only: randomNumberStream, initializeRandomNumberStream, & - getRandomNumbers, constructSeed + use random_numbers_mod, only: fms_random_numbers_randomNumberStream => randomNumberStream, & + fms_random_numbers_initializeRandomNumbersStream => initializeRandomNumberStream, & + fms_random_numbers_getRandomNumbers => getRandomNumbers, & + fms_random_numbers_constructSeed => constructSeed !> sat_vapor_pres - use sat_vapor_pres_mod, only: lookup_es, lookup_des, sat_vapor_pres_init, & - lookup_es2, lookup_des2, lookup_es2_des2, & - lookup_es3, lookup_des3, lookup_es3_des3, & - lookup_es_des, compute_qs, compute_mrs, & - escomp, descomp + use sat_vapor_pres_mod, only: fms_sat_vapor_pres_lookup_es => lookup_es, & + fms_sat_vapor_pres_lookup_des => lookup_des, & + fms_sat_vapor_pres_init => sat_vapor_pres_init, & + fms_sat_vapor_pres_lookup_es2 => lookup_es2, & + fms_sat_vapor_pres_lookup_des2 => lookup_des2, & + fms_sat_vapor_pres_lookup_es2_des2 => lookup_es2_des2, & + fms_sat_vapor_pres_lookup_es3 => lookup_es3, & + fms_sat_vapor_pres_lookup_des3 => lookup_des3, & + fms_sat_vapor_pres_lookup_es3_des3 => lookup_es3_des3, & + fms_sat_vapor_pres_lookup_es_des => lookup_es_des, & + fms_sat_vapor_pres_compute_qs => compute_qs, & + fms_sat_vapor_pres_compute_mrs => compute_mrs, & + fms_sat_vapor_pres_escomp => escomp, & + fms_sat_vapor_pres_descomp => descomp !> string_utils - use fms_string_utils_mod, only: string, fms_array_to_pointer, fms_pointer_to_array, fms_sort_this, & - fms_find_my_string, fms_find_unique, fms_c2f_string, fms_cstring2cpointer, & - string_copy + use fms_string_utils_mod, only: fms_string_utils_string => string, & + fms_string_utils_array_to_pointer => fms_array_to_pointer, & + fms_string_utils_fms_pointer_to_array => fms_pointer_to_array, & + fms_string_utils_sort_this => fms_sort_this, & + fms_string_utils_find_my_string => fms_find_my_string, & + fms_string_utils_find_unique => fms_find_unique, & + fms_string_utils_c2f_string => fms_c2f_string, & + fms_string_utils_cstring2cpointer => fms_cstring2cpointer, & + fms_string_utils_copy => string_copy !> time_interp - use time_interp_mod, only: time_interp_init, time_interp, fraction_of_year, & + use time_interp_mod, only: fms_time_interp_init => time_interp_init, & + fms_time_interp => time_interp, fms_fraction_of_year=> fraction_of_year, & NONE, YEAR, MONTH, DAY - use time_interp_external2_mod, only: init_external_field, time_interp_external, & - time_interp_external_init, time_interp_external_exit, & - get_external_field_size, get_time_axis, & - get_external_field_missing, set_override_region, & - reset_src_data_region, get_external_fileobj, & + use time_interp_external2_mod, only: fms_time_interp_external_init_external_field => init_external_field, & + fms_time_interp_external => time_interp_external, & + fms_time_interp_external_init => time_interp_external_init, & + fms_time_interp_external_exit => time_interp_external_exit, & + fms_time_interp_external_get_external_field_size => get_external_field_size, & + fms_time_interp_external_get_time_axis => get_time_axis, & + fms_time_interp_external_get_external_field_missing => get_external_field_missing, & + fms_time_interp_external_set_override_region => set_override_region, & + fms_time_interp_external_reset_src_data_region => reset_src_data_region, & + fms_time_interp_external_get_external_fileobj => get_external_fileobj, & NO_REGION, INSIDE_REGION, OUTSIDE_REGION, & SUCCESS, ERR_FIELD_NOT_FOUND !> time_manager - use time_manager_mod, only: time_type, operator(+), operator(-), operator(*), & + use time_manager_mod, only: FmsTime_type => time_type, & + operator(+), operator(-), operator(*), assignment(=),& operator(/), operator(>), operator(>=), operator(==), & operator(/=), operator(<), operator(<=), operator(//), & - assignment(=), set_time, increment_time, decrement_time, & - get_time, interval_alarm, repeat_alarm, time_type_to_real, & - real_to_time_type, time_list_error, THIRTY_DAY_MONTHS, & - JULIAN, GREGORIAN, NOLEAP, NO_CALENDAR, INVALID_CALENDAR, & - set_calendar_type, get_calendar_type, set_ticks_per_second, & - get_ticks_per_second, set_date, get_date, increment_date, & - decrement_date, days_in_month, leap_year, length_of_year, & - days_in_year, day_of_year, month_name, valid_calendar_types, & - time_manager_init, print_time, print_date, set_date_julian, & - get_date_julian, get_date_no_leap, date_to_string - use get_cal_time_mod, only: get_cal_time + fms_time_manager_set_time => set_time, & + fms_time_manager_increment_time => increment_time, & + fms_time_manager_decrement_time => decrement_time, & + fms_time_manager_get_time => get_time, & + fms_time_manager_interval_alarm => interval_alarm, & + fms_time_manager_repeat_alarm => repeat_alarm, & + fms_time_manager_time_type_to_real => time_type_to_real, & + fms_time_manager_real_to_time_type => real_to_time_type, & + fms_time_manager_time_list_error => time_list_error, & + THIRTY_DAY_MONTHS, JULIAN, GREGORIAN, NOLEAP, NO_CALENDAR, INVALID_CALENDAR, & + fms_time_manager_set_calendar_type => set_calendar_type, & + fms_time_manager_get_calendar_type => get_calendar_type, & + fms_time_manager_set_ticks_per_second => set_ticks_per_second, & + fms_time_manager_get_ticks_per_second => get_ticks_per_second, & + fms_time_manager_set_date => set_date, & + fms_time_manager_get_date => get_date, & + fms_time_manager_increment_date => increment_date, & + fms_time_manager_decrement_date => decrement_date, & + fms_time_manager_days_in_month => days_in_month, & + fms_time_manager_leap_year => leap_year, & + fms_time_manager_length_of_year => length_of_year, & + fms_time_manager_days_in_year => days_in_year, & + fms_time_manager_day_of_year => day_of_year, & + fms_time_manager_month_name => month_name, & + fms_time_manager_valid_calendar_types => valid_calendar_types, & + fms_time_manager_init => time_manager_init, & + fms_time_manager_print_time => print_time, & + fms_time_manager_print_date => print_date, & + fms_time_manager_set_date_julian => set_date_julian, & + fms_time_manager_get_date_julian => get_date_julian, & + fms_time_manager_get_date_no_leap => get_date_no_leap, & + fms_time_manager_date_to_string => date_to_string + use get_cal_time_mod, only: fms_get_cal_time => get_cal_time !> topography - use gaussian_topog_mod, only: gaussian_topog_init, get_gaussian_topog - use topography_mod, only: topography_init, get_topog_mean, get_topog_stdev, & - get_ocean_frac, get_ocean_mask, get_water_frac, & - get_water_mask + use gaussian_topog_mod, only: fms_gaussian_topog_init => gaussian_topog_init, & + fms_get_gaussian_topog => get_gaussian_topog + use topography_mod, only: fms_topography_init => topography_init, & + fms_topography_get_topog_mean => get_topog_mean, & + fms_topography_get_topog_stdev => get_topog_stdev, & + fms_topography_get_ocean_frac => get_ocean_frac, & + fms_topography_get_ocean_mask => get_ocean_mask, & + fms_topography_get_water_frac => get_water_frac, & + fms_topography_get_water_mask => get_water_mask !> tracer_manager - use tracer_manager_mod, only: tracer_manager_init, tracer_manager_end, & - check_if_prognostic, get_tracer_indices, & - get_tracer_index, get_tracer_names, & - get_tracer_name, query_method, & - set_tracer_atts, set_tracer_profile, & - register_tracers, get_number_tracers, & - adjust_mass, adjust_positive_def, NO_TRACER, MAX_TRACER_FIELDS + use tracer_manager_mod, only: fms_tracer_manager_init => tracer_manager_init, & + fms_tracer_manager_end => tracer_manager_end, & + fms_tracer_manager_check_if_prognostic => check_if_prognostic, & + fms_tracer_manager_get_tracer_indices => get_tracer_indices, & + fms_tracer_manager_get_tracer_index => get_tracer_index, & + fms_tracer_manager_get_tracer_names => get_tracer_names, & + fms_tracer_manager_get_tracer_name => get_tracer_name, & + fms_tracer_manager_query_method => query_method, & + fms_tracer_manager_set_tracer_atts => set_tracer_atts, & + fms_tracer_manager_set_tracer_profile => set_tracer_profile, & + fms_tracer_manager_register_tracers => register_tracers, & + fms_tracer_manager_get_number_tracers => get_number_tracers, & + fms_tracer_manager_adjust_mass => adjust_mass, & + fms_tracer_manager_adjust_positive_def => adjust_positive_def, & + NO_TRACER, MAX_TRACER_FIELDS !> tridiagonal - use tridiagonal_mod, only: tri_invert, close_tridiagonal + use tridiagonal_mod, only: fms_tridiagonal_tri_invert => tri_invert, & + fms_tridiagonal_close_tridiagonal => close_tridiagonal implicit none diff --git a/test_fms/mpp/test_domains_utility_mod.F90 b/test_fms/mpp/test_domains_utility_mod.F90 index 43271e053f..f88054b9f5 100644 --- a/test_fms/mpp/test_domains_utility_mod.F90 +++ b/test_fms/mpp/test_domains_utility_mod.F90 @@ -22,9 +22,9 @@ module test_domains_utility_mod use mpp_mod, only : FATAL, WARNING, MPP_DEBUG, NOTE use mpp_mod, only : mpp_error - use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY + use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY, & + domain2d, mpp_define_mosaic use platform_mod, only: r4_kind, r8_kind - use fms interface fill_coarse_data module procedure fill_coarse_data_r8 diff --git a/test_fms/mpp/test_mpp_chksum.F90 b/test_fms/mpp/test_mpp_chksum.F90 index a63ee7d22e..5810e42cab 100644 --- a/test_fms/mpp/test_mpp_chksum.F90 +++ b/test_fms/mpp/test_mpp_chksum.F90 @@ -23,7 +23,10 @@ !> single pe and distributed checksums program test_mpp_chksum - use fms + use mpp_mod + use mpp_domains_mod + use fms_mod + use platform_mod implicit none diff --git a/test_fms/mpp/test_mpp_domains.F90 b/test_fms/mpp/test_mpp_domains.F90 index 1ae1d904da..3ca557788f 100644 --- a/test_fms/mpp/test_mpp_domains.F90 +++ b/test_fms/mpp/test_mpp_domains.F90 @@ -54,7 +54,7 @@ program test_mpp_domains NONSYMEDGEUPDATE use mpp_domains_mod, only : domainUG, mpp_define_unstruct_domain, mpp_get_UG_domain_tile_id use mpp_domains_mod, only : mpp_get_UG_compute_domain, mpp_pass_SG_to_UG, mpp_pass_UG_to_SG - use mpp_domains_mod, only : mpp_global_field_ug + use mpp_domains_mod, only : mpp_global_field_ug, mpp_get_ug_global_domain use compare_data_checksums use test_domains_utility_mod diff --git a/test_fms/mpp/test_mpp_nesting.F90 b/test_fms/mpp/test_mpp_nesting.F90 index 201fd217f0..833c580bf5 100644 --- a/test_fms/mpp/test_mpp_nesting.F90 +++ b/test_fms/mpp/test_mpp_nesting.F90 @@ -19,7 +19,9 @@ !> Tests nested domain operations and routines in mpp_domains program test_mpp_nesting - use fms + use fms_mod + use mpp_domains_mod + use mpp_mod use compare_data_checksums use test_domains_utility_mod use platform_mod From 4a5ad151c7603a5d2234de1cf38615ccc976b239 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Mon, 24 Jul 2023 15:11:18 -0400 Subject: [PATCH 44/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index a657f8c090..916da5433f 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -1,7 +1,7 @@ !> \author Ganga Purja Pun -!> \email gagna.purjapun@noaa.gov +!> \email GFDL.Climate.Model.Info@noaa.gov !! \brief Contains routines for the modern diag manager -!! These routines are meant to be used for reduction methods. +!! These routines are meant to be used for checks and in reduction methods. !! !! \description From 731486bcce0218772b3e4370e1eae556bbeadf55 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Mon, 24 Jul 2023 15:38:06 -0400 Subject: [PATCH 45/61] Update fms_diag_bbox.F90 Public member _bounds3D_ of the fmsDiagBoundsHalos_type is changed to private and adds a getter function _get_bounds3D_ to access the memter. --- diag_manager/fms_diag_bbox.F90 | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index c23e6ff0e7..74a715aadb 100644 --- a/diag_manager/fms_diag_bbox.F90 +++ b/diag_manager/fms_diag_bbox.F90 @@ -67,7 +67,7 @@ MODULE fms_diag_bbox_mod !! in I and J dimensions. type, public :: fmsDiagBoundsHalos_type private - type(fmsDiagIbounds_type), public :: bounds3D !< Holds starting and ending indices of + type(fmsDiagIbounds_type) :: bounds3D !< Holds starting and ending indices of !! the I, J, and K dimensions integer :: hi !< Halo size in the I dimension integer :: hj !< Halo size in the J dimension @@ -82,6 +82,7 @@ MODULE fms_diag_bbox_mod procedure :: get_fie procedure :: get_fjs procedure :: get_fje + procedure :: get_bounds3D end type fmsDiagBoundsHalos_type public :: recondition_indices @@ -175,34 +176,42 @@ pure integer function get_hj (this) result(rslt) rslt = this%hj end function get_hj - !> @brief Gets the updated index `fis' of fmsDiagBoundsHalos_type in the I dimension + !> @brief Gets the updated starting index `fis' of fmsDiagBoundsHalos_type in the I dimension !! @return copy of integer member `fis' pure integer function get_fis (this) result(rslt) class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object rslt = this%fis end function get_fis - !> @brief Gets the updated index `fie' of fmsDiagBoundsHalos_type in the I dimension + !> @brief Gets the updated ending index `fie' of fmsDiagBoundsHalos_type in the I dimension !! @return copy of integer member `fie' pure integer function get_fie (this) result(rslt) class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object rslt = this%fie end function get_fie - !> @brief Gets the updated index `fjs' of fmsDiagBoundsHalos_type in the I dimension + !> @brief Gets the updated starting index `fjs' of fmsDiagBoundsHalos_type in the J dimension !! @return copy of integer member `fjs' pure integer function get_fjs (this) result(rslt) class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object rslt = this%fjs end function get_fjs - !> @brief Gets the updated index `fje' of fmsDiagBoundsHalos_type in the I dimension + !> @brief Gets the updated ending index `fje' of fmsDiagBoundsHalos_type in the J dimension !! @return copy of integer member `fje' pure integer function get_fje (this) result(rslt) class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object rslt = this%fje end function get_fje + !> @brief Gets a member of fmsDiagIbounds_type, `bounds3D`, of calling fmsDiagBoundsHalos_type object. + !! @return Returns a copy of fmsDiagIbounds_type member `bounds3D` + pure function get_bounds3D(this) result(bounds_obj) + class(fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object + type(fmsDiagIbounds_type) :: bounds_obj !< Object copy to return + bounds_obj = this%bounds3D + end function + !> @brief Reset the instance bounding lower and upper bounds to lower_val and upper_val, respectively. SUBROUTINE reset_bounds (this, lower_val, upper_val) class (fmsDiagIbounds_type), target, intent(inout) :: this !< ibounds instance From 151c992b5075750b7cb8784132e468f2885b8b52 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Mon, 24 Jul 2023 15:43:38 -0400 Subject: [PATCH 46/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 36 ++++++++++----------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 916da5433f..2d04a51f11 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -238,12 +238,12 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, class(*), pointer :: ptr_buffer(:,:,:,:,:) !< Pointer to 5D buffer for remapping !> Unpack recon_bounds - is = recon_bounds%bounds3D%get_imin() - js = recon_bounds%bounds3D%get_jmin() - ks = recon_bounds%bounds3D%get_kmin() - ie = recon_bounds%bounds3D%get_imax() - je = recon_bounds%bounds3D%get_jmax() - ke = recon_bounds%bounds3D%get_kmax() + is = recon_bounds%get_bounds3D()%get_imin() + js = recon_bounds%get_bounds3D()%get_jmin() + ks = recon_bounds%get_bounds3D()%get_kmin() + ie = recon_bounds%get_bounds3D()%get_imax() + je = recon_bounds%get_bounds3D()%get_jmax() + ke = recon_bounds%get_bounds3D()%get_kmax() hi = recon_bounds%get_hi() f1 = recon_bounds%get_fis() f2 = recon_bounds%get_fie() @@ -437,12 +437,12 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ k1 = running_indx2(3) !> Unpack bounds (/is, js, ks, ie, je, ke, hi, f1, f2, hj, f3, f4/) - is = recon_bounds%bounds3D%get_imin() - js = recon_bounds%bounds3D%get_jmin() - ks = recon_bounds%bounds3D%get_kmin() - ie = recon_bounds%bounds3D%get_imax() - je = recon_bounds%bounds3D%get_jmax() - ke = recon_bounds%bounds3D%get_kmax() + is = recon_bounds%get_bounds3D()%get_imin() + js = recon_bounds%get_bounds3D()%get_jmin() + ks = recon_bounds%get_bounds3D()%get_kmin() + ie = recon_bounds%get_bounds3D()%get_imax() + je = recon_bounds%get_bounds3D()%get_jmax() + ke = recon_bounds%get_bounds3D()%get_kmax() hi = recon_bounds%get_hi() hj = recon_bounds%get_hj() @@ -548,12 +548,12 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b integer :: f3, f4 !< Updated starting and ending indices in the J dimension !> Unpack bounds (/is, js, ks, ie, je, ke, hi, f1, f2, hj, f3, f4/) - is = recon_bounds%bounds3D%get_imin() - js = recon_bounds%bounds3D%get_jmin() - ks = recon_bounds%bounds3D%get_kmin() - ie = recon_bounds%bounds3D%get_imax() - je = recon_bounds%bounds3D%get_jmax() - ke = recon_bounds%bounds3D%get_kmax() + is = recon_bounds%get_bounds3D()%get_imin() + js = recon_bounds%get_bounds3D()%get_jmin() + ks = recon_bounds%get_bounds3D()%get_kmin() + ie = recon_bounds%get_bounds3D()%get_imax() + je = recon_bounds%get_bounds3D()%get_jmax() + ke = recon_bounds%get_bounds3D()%get_kmax() hi = recon_bounds%get_hi() f1 = recon_bounds%get_fis() f2 = recon_bounds%get_fie() From 2a7e54c223c1cf8b4cfa7033afafdcd100b6952a Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Mon, 24 Jul 2023 16:01:19 -0400 Subject: [PATCH 47/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 2d04a51f11..20ac9866a7 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -297,7 +297,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, END DO ELSE IF (reduced_k_range) THEN - call recon_bounds%bounds3D%set_kbounds(l_start(3), l_end(3)) + call recon_bounds%get_bounds3D()%set_kbounds(l_start(3), l_end(3)) select type (buffer_obj) type is (outputBuffer0d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) From 96287fd7c30e7104bb0f9684b1d67452796f2f02 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 09:44:06 -0400 Subject: [PATCH 48/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 49 +++++++++++++-------- 1 file changed, 31 insertions(+), 18 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 20ac9866a7..e6005c5939 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -236,14 +236,18 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, integer :: i, j, k, i1, j1, k1 !< For loops character(len=128) :: err_msg_local !< Stores local error message class(*), pointer :: ptr_buffer(:,:,:,:,:) !< Pointer to 5D buffer for remapping + type(fmsDiagIbounds_type) :: IJKBounds !< Bounding object for the I, J, and K indices + + !> Get the `bounds3D` member of the `recon_bounds` + IJKBounds = recon_bounds%get_bounds3D() !< Assignment of data structure with intrinsic type members may work!!! !> Unpack recon_bounds - is = recon_bounds%get_bounds3D()%get_imin() - js = recon_bounds%get_bounds3D()%get_jmin() - ks = recon_bounds%get_bounds3D()%get_kmin() - ie = recon_bounds%get_bounds3D()%get_imax() - je = recon_bounds%get_bounds3D()%get_jmax() - ke = recon_bounds%get_bounds3D()%get_kmax() + is = IJKBounds%get_imin() + js = IJKBounds%get_jmin() + ks = IJKBounds%get_kmin() + ie = IJKBounds%get_imax() + je = IJKBounds%get_jmax() + ke = IJKBounds%get_kmax() hi = recon_bounds%get_hi() f1 = recon_bounds%get_fis() f2 = recon_bounds%get_fie() @@ -420,6 +424,11 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ integer, intent(in) :: running_indx1(3) !< Holds indices i, j, and k integer, intent(in) :: running_indx2(3) !< Holds indices i1, j1, and k1 + type(fmsDiagIbounds_type) :: IJKBounds !< Bounding object for the I, J, and K indices + + !> Get the `bounds3D` member of the `recon_bounds` + IJKBounds = recon_bounds%get_bounds3D() !< Assignment of data structure with intrinsic type members may work!!! + integer :: i, j, k integer :: i1, j1, k1 integer :: is, js, ks @@ -437,12 +446,12 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ k1 = running_indx2(3) !> Unpack bounds (/is, js, ks, ie, je, ke, hi, f1, f2, hj, f3, f4/) - is = recon_bounds%get_bounds3D()%get_imin() - js = recon_bounds%get_bounds3D()%get_jmin() - ks = recon_bounds%get_bounds3D()%get_kmin() - ie = recon_bounds%get_bounds3D()%get_imax() - je = recon_bounds%get_bounds3D()%get_jmax() - ke = recon_bounds%get_bounds3D()%get_kmax() + is = IJKBounds%get_imin() + js = IJKBounds%get_jmin() + ks = IJKBounds%get_kmin() + ie = IJKBounds%get_imax() + je = IJKBounds%get_jmax() + ke = IJKBounds%get_kmax() hi = recon_bounds%get_hi() hj = recon_bounds%get_hj() @@ -546,14 +555,18 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b integer :: hi, hj !< Halo sizes in the I, and J dimensions integer :: f1, f2 !< Updated starting and ending indices in the I dimension integer :: f3, f4 !< Updated starting and ending indices in the J dimension + type(fmsDiagIbounds_type) :: IJKBounds !< Bounding object for the I, J, and K indices + + !> Get the `bounds3D` member of the `recon_bounds` + IJKBounds = recon_bounds%get_bounds3D() !< Assignment of data structure with intrinsic type members may work!!! !> Unpack bounds (/is, js, ks, ie, je, ke, hi, f1, f2, hj, f3, f4/) - is = recon_bounds%get_bounds3D()%get_imin() - js = recon_bounds%get_bounds3D()%get_jmin() - ks = recon_bounds%get_bounds3D()%get_kmin() - ie = recon_bounds%get_bounds3D()%get_imax() - je = recon_bounds%get_bounds3D()%get_jmax() - ke = recon_bounds%get_bounds3D()%get_kmax() + is = IJKBounds%get_imin() + js = IJKBounds%get_jmin() + ks = IJKBounds%get_kmin() + ie = IJKBounds%get_imax() + je = IJKBounds%get_jmax() + ke = IJKBounds%get_kmax() hi = recon_bounds%get_hi() f1 = recon_bounds%get_fis() f2 = recon_bounds%get_fie() From d200e1cb5ba23b825c1e4703dd5963381716a3f8 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 09:54:25 -0400 Subject: [PATCH 49/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index e6005c5939..9abaffb216 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -301,7 +301,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, END DO ELSE IF (reduced_k_range) THEN - call recon_bounds%get_bounds3D()%set_kbounds(l_start(3), l_end(3)) + call IJKBounds%set_kbounds(l_start(3), l_end(3)) select type (buffer_obj) type is (outputBuffer0d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) @@ -426,9 +426,6 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ type(fmsDiagIbounds_type) :: IJKBounds !< Bounding object for the I, J, and K indices - !> Get the `bounds3D` member of the `recon_bounds` - IJKBounds = recon_bounds%get_bounds3D() !< Assignment of data structure with intrinsic type members may work!!! - integer :: i, j, k integer :: i1, j1, k1 integer :: is, js, ks @@ -445,6 +442,9 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ j1 = running_indx2(2) k1 = running_indx2(3) + !> Get the `bounds3D` member of the `recon_bounds` + IJKBounds = recon_bounds%get_bounds3D() !< Assignment of data structure with intrinsic type members may work!!! + !> Unpack bounds (/is, js, ks, ie, je, ke, hi, f1, f2, hj, f3, f4/) is = IJKBounds%get_imin() js = IJKBounds%get_jmin() From de75dadfa619a538049abf60e732f6513f6d243c Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 10:07:10 -0400 Subject: [PATCH 50/61] Update fms_diag_object.F90 --- diag_manager/fms_diag_object.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index fa763125d0..a579491d7b 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -1161,6 +1161,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight class(fmsDiagAxis_type), pointer :: ptr_axis !< Pointer of type diag_axis%axis logical :: ierr !< Error flag logical, pointer :: oor_mask_4d(:,:,:,:) !< Remapped out-of-range mask oor_mask + type(fmsDiagIbounds_type) :: IJKBounds !< Bounding object for the I, J, and K indices redn_done = .FALSE. @@ -1169,6 +1170,9 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight ie_in, je_in, ke_in, err_msg) if (ierr) return + !> Get the `bounds3D` member of the `recon_bounds` + IJKBounds = bounds_with_halos%get_bounds3D() !< Assignment of data structure with intrinsic type members may work!!! + !> Remap oor_mask to 4D array oor_mask_4d => null() oor_mask_4d(1:size(oor_mask,1), 1:size(oor_mask,2), 1:size(oor_mask,3), 1:1) => oor_mask @@ -1205,8 +1209,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight bounds_with_halos%get_fie(), & bounds_with_halos%get_fjs(), & bounds_with_halos%get_fje(), & - bounds_with_halos%bounds3D%get_kmin(), & - bounds_with_halos%bounds3D%get_kmax()) + IJKBounds%get_kmin(), & + IJKBounds%get_kmax()) !> If sub regional output, get starting and ending indices if (is_regional) then @@ -1241,7 +1245,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight select type (ptr_axis) type is (fmsDiagSubAxis_type) if (ptr_axis%is_unstructured_grid()) then - call bounds_with_halos%bounds3D%set_jbounds(ptr_axis%get_starting_index(), & + call IJKBounds%set_jbounds(ptr_axis%get_starting_index(), & ptr_axis%get_ending_index()) end if l_start(3) = ptr_axis%get_starting_index() From 2a55ad971b173b908d6d4b743636cfa0ca52bb3c Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 10:18:13 -0400 Subject: [PATCH 51/61] Update fms_diag_object.F90 --- diag_manager/fms_diag_object.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index a579491d7b..50e108d430 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -39,7 +39,7 @@ module fms_diag_object_mod use fms_diag_output_buffer_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY -use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices +use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices, fmsDiagIbounds_type use fms_diag_reduction_methods_mod #endif #if defined(_OPENMP) From 7361947aeaec5452a274a1bc00dc76adc980f63c Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 10:54:00 -0400 Subject: [PATCH 52/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 42 ++++++++++++++------- 1 file changed, 28 insertions(+), 14 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 9abaffb216..2d789fe372 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -358,7 +358,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (real(kind=r8_kind)) real_counter(sample) = 1.0_r8_kind class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') end select type is (outputBuffer1d_type) select type (real_counter => buffer_obj%count_0d) @@ -367,7 +368,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (real(kind=r8_kind)) real_counter(sample) = 1.0_r8_kind class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') end select type is (outputBuffer2d_type) select type (real_counter => buffer_obj%count_0d) @@ -376,7 +378,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (real(kind=r8_kind)) real_counter(sample) = 1.0_r8_kind class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') end select type is (outputBuffer3d_type) select type (real_counter => buffer_obj%count_0d) @@ -385,7 +388,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (real(kind=r8_kind)) real_counter(sample) = 1.0_r8_kind class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') end select type is (outputBuffer4d_type) select type (real_counter => buffer_obj%count_0d) @@ -394,7 +398,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (real(kind=r8_kind)) real_counter(sample) = 1.0_r8_kind class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') end select type is (outputBuffer5d_type) select type (real_counter => buffer_obj%count_0d) @@ -403,7 +408,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (real(kind=r8_kind)) real_counter(sample) = 1.0_r8_kind class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported intrinsic type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') end select class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') @@ -474,7 +480,8 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ end where end if class default - call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum"//& + " buffer type does not match with field_data type.") end select type is (real(kind=r8_kind)) select type (buffer) @@ -493,7 +500,8 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ end where end if class default - call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum"//& + " buffer type does not match with field_data type.") end select type is (integer(kind=i4_kind)) select type (buffer) @@ -512,7 +520,8 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ end where end if class default - call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum"//& + " buffer type does not match with field_data type.") end select type is (integer(kind=i8_kind)) select type (buffer) @@ -531,7 +540,8 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ end where end if class default - call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum"//& + " buffer type does not match with field_data type.") end select class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum unsupported field data type") @@ -605,7 +615,8 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b end if end if class default - call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum"//& + " buffer type does not match with field_data type.") end select type is (real(kind=r8_kind)) select type (buffer) @@ -636,7 +647,8 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b end if end if class default - call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum"//& + " buffer type does not match with field_data type.") end select type is (integer(kind=i4_kind)) select type (buffer) @@ -667,7 +679,8 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b end if end if class default - call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum"//& + " buffer type does not match with field_data type.") end select type is (integer(kind=i8_kind)) select type (buffer) @@ -698,7 +711,8 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b end if end if class default - call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum type mismatch") + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum"//& + " buffer type does not match with field_data type.") end select class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum unsupported field data type") From cd7beeb0e44c8f4823d3ae86aefc34523c40d72b Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 11:43:16 -0400 Subject: [PATCH 53/61] Update fms_diag_object.F90 --- diag_manager/fms_diag_object.F90 | 55 ++++++++++++++++---------------- 1 file changed, 28 insertions(+), 27 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 50e108d430..a0b964a9cb 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,7 +40,7 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices, fmsDiagIbounds_type -use fms_diag_reduction_methods_mod +use fms_diag_reduction_methods_mod, only: fms_diag_update_extremum #endif #if defined(_OPENMP) use omp_lib @@ -1155,7 +1155,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight type(fmsDiagBoundsHalos_type) :: bounds_with_halos !< Data structure that holds 3D bounds !! in the I, J, and K dimensions and halo sizes !! in the I, and J dimensions - integer :: i, j !< For looping + integer :: id, ax !< For looping integer :: n_axis !< Number of axes integer :: axis_id !< Axis id class(fmsDiagAxis_type), pointer :: ptr_axis !< Pointer of type diag_axis%axis @@ -1177,28 +1177,30 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight oor_mask_4d => null() oor_mask_4d(1:size(oor_mask,1), 1:size(oor_mask,2), 1:size(oor_mask,3), 1:1) => oor_mask - do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids) - file_id = this%FMS_diag_fields(diag_field_id)%file_ids(i) - ! Is this field output on a local domain only? + loop_over_buffer_id: do id = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids) + file_id = this%FMS_diag_fields(diag_field_id)%file_ids(id) + !> Is this field output on a local domain only? this_pe_writes = this%FMS_diag_files(file_id)%writing_on_this_pe() - ! If local_output, does the current PE take part in send_data? + !> If local_output, does the current PE take part in send_data? is_regional = this%FMS_diag_files(file_id)%is_regional() - ! Skip all PEs not participating in outputting this field + !> Skip all PEs not participating in outputting this field if (.not.this_pe_writes) cycle - buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(i) - freq = this%FMS_diag_fields(diag_field_id)%get_frequency() - reduction_method = this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_reduction() - has_diurnal_axis = this%FMS_diag_fields(diag_field_id)%diag_field(i)%has_n_diurnal() - field_name = this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_fname() - reduced_k_range = this%FMS_diag_fields(diag_field_id)%diag_field(i)%has_var_zbounds() + !> Store buffer ID of the i-th element of the buffer_ids(:) + buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(id) - if (this%FMS_diag_fields(diag_field_id)%diag_field(i)%has_pow_value()) THEN - pow_val = this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_pow_value() + !> Make locak copies of field information + freq = this%FMS_diag_fields(diag_field_id)%get_frequency() + reduction_method = this%FMS_diag_fields(diag_field_id)%diag_field(id)%get_var_reduction() + has_diurnal_axis = this%FMS_diag_fields(diag_field_id)%diag_field(id)%has_n_diurnal() + field_name = this%FMS_diag_fields(diag_field_id)%diag_field(id)%get_var_fname() + reduced_k_range = this%FMS_diag_fields(diag_field_id)%diag_field(id)%has_var_zbounds() + if (this%FMS_diag_fields(diag_field_id)%diag_field(id)%has_pow_value()) THEN + pow_val = this%FMS_diag_fields(diag_field_id)%diag_field(id)%get_pow_value() else - pow_val = 0 + pow_val = 1 !< Default value, if not explicitly set, that guarantees simple weighted arithmetic mean end if !> Check if the field is a physics window @@ -1218,15 +1220,15 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight n_axis = size(this%FMS_diag_output_buffers(buffer_id)%axis_ids) allocate(l_start(n_axis)) allocate(l_end(n_axis)) - do j = 1, n_axis - ptr_axis => this%diag_axis(this%FMS_diag_output_buffers(buffer_id)%axis_ids(j))%axis + do ax = 1, n_axis + ptr_axis => this%diag_axis(this%FMS_diag_output_buffers(buffer_id)%axis_ids(ax))%axis select type (ptr_axis) type is (fmsDiagSubAxis_type) - l_start(j) = ptr_axis%get_starting_index() - l_end(j) = ptr_axis%get_ending_index() + l_start(ax) = ptr_axis%get_starting_index() + l_end(ax) = ptr_axis%get_ending_index() type is (fmsDiagFullAxis_type) - l_start(j) = 1 - l_end(j) = ptr_axis%axis_length() + l_start(ax) = 1 + l_end(ax) = ptr_axis%axis_length() class default call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_do_reduction non fmsDiagSubAxis_type axis') end select @@ -1273,7 +1275,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& &//trim(error_string)//', time must be present when output frequency = EVERY_TIME', err_msg)) then - !if (associated(field_data)) deallocate(field_data) + return end if end if end if @@ -1285,7 +1287,6 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight & trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& &//trim(error_string)//', time must be present for nonstatic field', err_msg)) then - !if (associated(field_data)) deallocate(field_data) return end if end if @@ -1304,10 +1305,10 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight case (time_rms) !! TODO: root-mean-square error case (time_max) - call fms_diag_update_extremum(1, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & + call fms_diag_update_extremum(time_max, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & l_end, is_regional, reduced_k_range, sample, oor_mask_4d, field_name, has_diurnal_axis, err_msg) case (time_min) - call fms_diag_update_extremum(0, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & + call fms_diag_update_extremum(time_min, ptr_diag_buffer_obj, field_data, bounds_with_halos, l_start, & l_end, is_regional, reduced_k_range, sample, oor_mask_4d, field_name, has_diurnal_axis, err_msg) case (time_sum) !! TODO: sum for the interval @@ -1319,7 +1320,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight case default call mpp_error(FATAL, "fms_diag_object_mod::fms_diag_accept_data unsupported reduction method!") end select Reduction - enddo + enddo !< End of label:loop_over_buffer_id redn_done = .TRUE. #else call mpp_error( FATAL, "fms_diag_object_mod::fms_diag_do_reduction "//& From 10f0891f9f3567c52c00f1c053751ea6570f3311 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 11:57:51 -0400 Subject: [PATCH 54/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 24 ++++++++++----------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 2d789fe372..6b0ebd7b6e 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -255,8 +255,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, f3 = recon_bounds%get_fjs() f4 = recon_bounds%get_fje() - if (flag .ne. 0 .and. flag .ne. 1) then - call mpp_error( FATAL, "fms_diag_reduction_methods_mod::fms_diag_update_extremum: flag must be either 0 or 1.") + if (flag .ne. 3 .and. flag .ne. 4) then + call mpp_error( FATAL, "fms_diag_reduction_methods_mod::fms_diag_update_extremum: flag must be either 3 or 4.") end if !! TODO: remap buffer before passing to subroutines update_scalar_extremum and update_array_extremum @@ -419,7 +419,7 @@ end subroutine fms_diag_update_extremum !> @brief Updates individual element of buffer subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_bounds, & running_indx1, running_indx2) - integer, intent(in) :: flag !< 0 for minimum; 1 for maximum + integer, intent(in) :: flag !< Flag indicating maximum(time_max) or minimum(time_min) class(*), intent(in) :: field_data(:,:,:,:) !< Field data class(*), intent(inout) :: buffer(:,:,:,:,:) !< Remapped output buffer logical, intent(in) :: mask(:,:,:,:) !< Update mask @@ -466,7 +466,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ type is (real(kind=r4_kind)) select type (buffer) type is (real(kind=r4_kind)) - if (flag .eq. 0) then + if (flag .eq. time_min) then ! Update the buffer with the current minimum where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& buffer(i1,j1,k1,:,sample)) @@ -486,7 +486,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ type is (real(kind=r8_kind)) select type (buffer) type is (real(kind=r8_kind)) - if (flag .eq. 0) then + if (flag .eq. time_min) then ! Update the buffer with the current minimum where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& buffer(i1,j1,k1,:,sample)) @@ -506,7 +506,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ type is (integer(kind=i4_kind)) select type (buffer) type is (integer(kind=i4_kind)) - if (flag .eq. 0) then + if (flag .eq. time_min) then ! Update the buffer with the current minimum where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& buffer(i1,j1,k1,:,sample)) @@ -526,7 +526,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ type is (integer(kind=i8_kind)) select type (buffer) type is (integer(kind=i8_kind)) - if (flag .eq. 0) then + if (flag .eq. time_min) then ! Update the buffer with the current minimum where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& buffer(i1,j1,k1,:,sample)) @@ -550,7 +550,7 @@ end subroutine update_scalar_extremum !> @brief Updates a chunk of buffer subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_bounds, reduced_k_range) - integer :: flag !< 0 for minimum; 1 for extremum + integer :: flag !< Flag indicating maximum(time_max) or minimum(time_min) class(*), intent(in) :: field_data(:,:,:,:) !< Field data class(*), intent(inout) :: buffer(:,:,:,:,:) !< Remapped output buffer logical, intent(in) :: mask(:,:,:,:) !< Updated mask @@ -589,7 +589,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b type is (real(kind=r4_kind)) select type (buffer) type is (real(kind=r4_kind)) - if (flag .eq. 0) then + if (flag .eq. time_min) then !> Update the buffer with the current minimum if (reduced_k_range) then ! recon_bounds must have ks = ksr and ke = ker @@ -621,7 +621,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b type is (real(kind=r8_kind)) select type (buffer) type is (real(kind=r8_kind)) - if (flag .eq. 0) then + if (flag .eq. time_min) then !> Update the buffer with the current minimum if (reduced_k_range) then ! recon_bounds must have ks = ksr and ke = ker @@ -653,7 +653,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b type is (integer(kind=i4_kind)) select type (buffer) type is (integer(kind=i4_kind)) - if (flag .eq. 0) then + if (flag .eq. time_min) then !> Update the buffer with the current minimum if (reduced_k_range) then ! recon_bounds must have ks = ksr and ke = ker @@ -685,7 +685,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b type is (integer(kind=i8_kind)) select type (buffer) type is (integer(kind=i8_kind)) - if (flag .eq. 0) then + if (flag .eq. time_min) then !> Update the buffer with the current minimum if (reduced_k_range) then ! recon_bounds must have ks = ksr and ke = ker From 840c3c3685db97b9f8155d7b9898f456b78e8ce5 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 11:59:16 -0400 Subject: [PATCH 55/61] Update fms_diag_object.F90 --- diag_manager/fms_diag_object.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index a0b964a9cb..443b10a467 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -1320,7 +1320,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight case default call mpp_error(FATAL, "fms_diag_object_mod::fms_diag_accept_data unsupported reduction method!") end select Reduction - enddo !< End of label:loop_over_buffer_id + enddo loop_over_buffer_id redn_done = .TRUE. #else call mpp_error( FATAL, "fms_diag_object_mod::fms_diag_do_reduction "//& From 4cdff6d0bf500fd416a3099db175030cdf749026 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 12:02:27 -0400 Subject: [PATCH 56/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 6b0ebd7b6e..6baaa4d120 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -2,8 +2,6 @@ !> \email GFDL.Climate.Model.Info@noaa.gov !! \brief Contains routines for the modern diag manager !! These routines are meant to be used for checks and in reduction methods. -!! -!! \description module fms_diag_reduction_methods_mod use platform_mod @@ -11,7 +9,7 @@ module fms_diag_reduction_methods_mod use fms_mod, only: fms_error_handler use fms_diag_bbox_mod use fms_diag_output_buffer_mod - use diag_data_mod, only: debug_diag_manager + use diag_data_mod, only: debug_diag_manager, time_max, time_min implicit none private From ddaec5f835c18119e0ded525403eae96d43559a8 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 12:21:12 -0400 Subject: [PATCH 57/61] Update fms_diag_object.F90 --- diag_manager/fms_diag_object.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 443b10a467..17de68e4e8 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,7 +40,7 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices, fmsDiagIbounds_type -use fms_diag_reduction_methods_mod, only: fms_diag_update_extremum +use fms_diag_reduction_methods_mod, only: check_indices_order, fms_diag_update_extremum #endif #if defined(_OPENMP) use omp_lib @@ -1272,7 +1272,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight this%FMS_diag_files(file_id)%FMS_diag_file%get_last_output()) then if (.not.present(time)) then write (error_string,'(a,"/",a)') trim(this%FMS_diag_fields(diag_field_id)%get_modname()),& - trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) + trim(this%FMS_diag_fields(diag_field_id)%diag_field(id)%get_var_outname()) if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& &//trim(error_string)//', time must be present when output frequency = EVERY_TIME', err_msg)) then return @@ -1284,7 +1284,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight ! Check if time should be present for this field if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) then write(error_string, '(a,"/",a)') trim(this%FMS_diag_fields(diag_field_id)%get_modname()),& - & trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname()) + & trim(this%FMS_diag_fields(diag_field_id)%diag_field(id)%get_var_outname()) if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '& &//trim(error_string)//', time must be present for nonstatic field', err_msg)) then return From f7f4a40c45fa4d627801ae41feda12ac51e28cea Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 12:32:26 -0400 Subject: [PATCH 58/61] Update fms_diag_object.F90 --- diag_manager/fms_diag_object.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 17de68e4e8..0a7ebee402 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,7 +40,7 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices, fmsDiagIbounds_type -use fms_diag_reduction_methods_mod, only: check_indices_order, fms_diag_update_extremum +use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask_3d, real_copy_set, fms_diag_update_extremum #endif #if defined(_OPENMP) use omp_lib From fd3b88f533d9966a3d943c7fb8dd2fbf611ae680 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 14:48:14 -0400 Subject: [PATCH 59/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 121 +++++++++++--------- 1 file changed, 68 insertions(+), 53 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 6baaa4d120..3bff996bca 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -25,7 +25,7 @@ module fms_diag_reduction_methods_mod LOGICAL FUNCTION compare_two_sets_of_bounds(bounds_a, bounds_b, error_str) integer, intent(in) :: bounds_a(:) !< First array with order: (/imin, imax, jmin, jmax, kmin, kmax/) integer, intent(in) :: bounds_b(:) !< Second array with the same order as the first - character(*), intent(out) :: error_str + character(*), intent(out) :: error_str !< Error message to report back compare_two_sets_of_bounds = .FALSE. @@ -64,22 +64,22 @@ END FUNCTION compare_two_sets_of_bounds !> @brief Checks improper combinations of is, ie, js, and je. !> @return Returns .false. if there is no error else .true. - !> @note send_data works in either one or another of two modes. - ! 1. Input field is a window (e.g. FMS physics) - ! 2. Input field includes halo data - ! It cannot handle a window of data that has halos. - ! (A field with no windows or halos can be thought of as a special case of either mode.) - ! The logic for indexing is quite different for these two modes, but is not clearly separated. - ! If both the beggining and ending indices are present, then field is assumed to have halos. - ! If only beggining indices are present, then field is assumed to be a window. + !> @note accept_data works in either one or another of two modes. + !! 1. Input field is a window (e.g. FMS physics) + !! 2. Input field includes halo data + !! It cannot handle a window of data that has halos. + !! (A field with no windows or halos can be thought of as a special case of either mode.) + !! The logic for indexing is quite different for these two modes, but is not clearly separated. + !! If both the beggining and ending indices are present, then field is assumed to have halos. + !! If only beggining indices are present, then field is assumed to be a window. !> @par - ! There are a number of ways a user could mess up this logic, depending on the combination - ! of presence/absence of is,ie,js,je. The checks below should catch improper combinations. + !! There are a number of ways a user could mess up this logic, depending on the combination + !! of presence/absence of is,ie,js,je. The checks below should catch improper combinations. function check_indices_order(is_in, ie_in, js_in, je_in, error_msg) result(rslt) integer, intent(in), optional :: is_in, ie_in, js_in, je_in !< Indices passed to fms_diag_accept_data() character(len=*), intent(inout), optional :: error_msg !< An error message used only for testing purpose!!! - character(len=128) :: err_module_name !< Stores the module name to be used in error calls + character(len=52) :: err_module_name !< Stores the module name to be used in error calls logical :: rslt !< Return value rslt = .false. !< If no error occurs. @@ -111,8 +111,8 @@ function check_indices_order(is_in, ie_in, js_in, je_in, error_msg) result(rslt) END IF end function check_indices_order - !> @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. + !> @brief Copies input data to output data with specific type and precision + !! 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. subroutine real_copy_set(out_data, in_data, val, err_msg) real, intent(out) :: out_data !< Proper type copy of in_data @@ -135,7 +135,11 @@ subroutine real_copy_set(out_data, in_data, val, err_msg) end if END SELECT ELSE - if (present(val)) out_data = val + if (present(val)) then + out_data = val + else + call mpp_error(FATL, 'fms_diag_reduction_methods_mod::real_copy_set both in_data and val can be absent') + end if END IF end subroutine real_copy_set @@ -184,33 +188,29 @@ subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg) type is (real(kind=r4_kind)) WHERE (rmask < rmask_threshold) outmask = .FALSE. class default - if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d', 'type mismatch', err_msg)) then - return - end if + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::init_mask_3d'//& + ' types of rmask and rmask_threshold do not match') end select TYPE IS (real(kind=r8_kind)) select type (rmask_threshold) type is (real(kind=r8_kind)) WHERE (rmask < rmask_threshold) outmask = .FALSE. class default - if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d', 'type mismatch', err_msg)) then - return - end if + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::init_mask_3d'//& + ' types of rmask and rmask_threshold do not match') end select CLASS DEFAULT - if (fms_error_handler('fms_diag_reduction_methods_mod::init_mask_3d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) then - return - end if + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::init_mask_3d'//& + & ' The rmask is not one of the supported types of real(kind=4) or real(kind=8)') END SELECT END IF end subroutine init_mask_3d !> @brief Updates the buffer with the field data based on the value of the flag passed: - !! 0 for minimum; 1 for maximum. + !! time_min for minimum; time_max for maximum. subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, l_start, & l_end, is_regional, reduced_k_range, sample, mask, fieldName, hasDiurnalAxis, err_msg) - integer, intent(in) :: flag !< Flag to indicate what to update: 0 for minimum; 1 for maximum + integer, intent(in) :: flag !< Flag to indicate what to update: time_min for minimum; time_max for maximum class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Remapped buffer to update class(*), intent(in) :: field_data(:,:,:,:) !< Field data type(fmsDiagBoundsHalos_type), intent(inout) :: recon_bounds !< Indices of bounds in the first three dimension @@ -223,7 +223,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, logical, intent(in) :: mask(:,:,:,:) !< Must be out of range mask character(len=*), intent(in) :: fieldName !< Field name for error reporting logical, intent(in) :: hasDiurnalAxis !< Flag to indicate if the buffer has a diurnal axis - character(len=*), intent(inout), optional :: err_msg + character(len=*), intent(inout), optional :: err_msg !< Error mesage to report back integer :: is, js, ks !< Starting indices in the I, J, and K dimensions integer :: ie, je, ke !< Ending indices in the I, J, and K dimensions @@ -231,7 +231,8 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, integer :: f1, f2 !< Updated starting and ending indices in the I dimension integer :: f3, f4 !< Updated starting and ending indices in the J dimension integer :: ksr, ker !< Reduced indices in the K dimension - integer :: i, j, k, i1, j1, k1 !< For loops + integer :: i, j, k !< For loops + integer :: i1, j1, k1 !< Intermediate computed indices character(len=128) :: err_msg_local !< Stores local error message class(*), pointer :: ptr_buffer(:,:,:,:,:) !< Pointer to 5D buffer for remapping type(fmsDiagIbounds_type) :: IJKBounds !< Bounding object for the I, J, and K indices @@ -261,7 +262,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, ptr_buffer => buffer_obj%remap_buffer(fieldName, hasDiurnalAxis) ! Update buffer - IF (is_regional) THEN + regional_if: IF (is_regional) THEN DO k = l_start(3), l_end(3) k1 = k - l_start(3) + 1 DO j = js, je @@ -291,14 +292,16 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, recon_bounds, (/i,j,k/), (/i1,j1,k1/)) class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum & - unsupported buffer type') + regional buffer_obj is not one of the support buffer types: outputBuffer0d_type & + outputBuffer1d_type outputBuffer2d_type outputBuffer3d_type & + outputBuffer4d_type outputBuffer5d_type') end select end if END DO END DO END DO - ELSE - IF (reduced_k_range) THEN + ELSE !< if not regional + reduced_k_range_if: IF (reduced_k_range) THEN call IJKBounds%set_kbounds(l_start(3), l_end(3)) select type (buffer_obj) type is (outputBuffer0d_type) @@ -314,21 +317,24 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer5d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum in reduced_k_range_if & + regional buffer_obj is not one of the support buffer types: outputBuffer0d_type & + outputBuffer1d_type outputBuffer2d_type outputBuffer3d_type & + outputBuffer4d_type outputBuffer5d_type') end select - ELSE - IF ( debug_diag_manager ) THEN + ELSE !< does not have reduced_k_range + debug_diag_if: IF ( debug_diag_manager ) THEN ! Compare bounds {is-hi, ie-hi, js-hj, je-hj, ks, ke} with the bounds of first three dimensions of the buffer if (compare_two_sets_of_bounds((/is-hi, ie-hi, js-hj, je-hj, ks, ke/), & (/LBOUND(ptr_buffer,1), UBOUND(ptr_buffer,1), LBOUND(ptr_buffer,2), UBOUND(ptr_buffer,2), & LBOUND(ptr_buffer,3), UBOUND(ptr_buffer,3)/), err_msg_local)) THEN IF ( fms_error_handler('fms_diag_object_mod::fms_diag_update_extremum', err_msg_local, err_msg) ) THEN - !if (associated(field_data)) deallocate(field_data) - !if (allocated(mask)) deallocate(mask) RETURN END IF END IF - END IF + END IF debug_diag_if + + !> If no error above, do update the buffer select type (buffer_obj) type is (outputBuffer0d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) @@ -343,10 +349,14 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer5d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum & + regional buffer_obj is not one of the support buffer types: outputBuffer0d_type & + outputBuffer1d_type outputBuffer2d_type outputBuffer3d_type & + outputBuffer4d_type outputBuffer5d_type') end select - END IF - end if + END IF reduced_k_range_if + end if regional_if + ! Reset counter count_0d of the buffer object select type (buffer_obj) type is (outputBuffer0d_type) @@ -429,12 +439,17 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ integer, intent(in) :: running_indx2(3) !< Holds indices i1, j1, and k1 type(fmsDiagIbounds_type) :: IJKBounds !< Bounding object for the I, J, and K indices + integer :: i, j, k !< Unpack running_indx1 to + integer :: i1, j1, k1 !< Unpack running_indx2 to + integer :: is, js, ks !< Starting indices in the I, J, and K dimensions + integer :: ie, je, ke !< Ending indices in the I, J, and K dimensiions + integer :: hi, hj !< Halo sizes in the I, and J dimensions - integer :: i, j, k - integer :: i1, j1, k1 - integer :: is, js, ks - integer :: ie, je, ke - integer :: hi, hj + !> Check flag for unsupported operation + if (flag .ne. time_max .and. flag .ne. time_min) then + call mpp_error(FATAL, "fms_diag_reduction_methods_mod::fms_diag_scalar_extremum & + unsupported reduction method") + endif ! Initialize i, j, and k i = running_indx1(1) @@ -449,7 +464,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ !> Get the `bounds3D` member of the `recon_bounds` IJKBounds = recon_bounds%get_bounds3D() !< Assignment of data structure with intrinsic type members may work!!! - !> Unpack bounds (/is, js, ks, ie, je, ke, hi, f1, f2, hj, f3, f4/) + !> Unpack index bounds is = IJKBounds%get_imin() js = IJKBounds%get_jmin() ks = IJKBounds%get_kmin() @@ -464,19 +479,19 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ type is (real(kind=r4_kind)) select type (buffer) type is (real(kind=r4_kind)) - if (flag .eq. time_min) then - ! Update the buffer with the current minimum + minimum_if: if (flag .eq. time_min) then + !> Update the buffer with the current minimum where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& buffer(i1,j1,k1,:,sample)) buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) end where - else - ! Update the buffer with the current maximum + else !< if not minimum, check for maximum + !> Update the buffer with the current maximum where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) >& buffer(i1,j1,k1,:,sample)) buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) end where - end if + end if minimum_if class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum"//& " buffer type does not match with field_data type.") From 0825006d95b95228ee16a9d4186720d66e3dbf1d Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 25 Jul 2023 15:21:44 -0400 Subject: [PATCH 60/61] Update fms_diag_reduction_methods.F90 --- diag_manager/fms_diag_reduction_methods.F90 | 64 +++++++++++---------- 1 file changed, 35 insertions(+), 29 deletions(-) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 3bff996bca..67b942748f 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -138,7 +138,7 @@ subroutine real_copy_set(out_data, in_data, val, err_msg) if (present(val)) then out_data = val else - call mpp_error(FATL, 'fms_diag_reduction_methods_mod::real_copy_set both in_data and val can be absent') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::real_copy_set both in_data and val can be absent') end if END IF end subroutine real_copy_set @@ -291,10 +291,10 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, call update_scalar_extremum(flag, field_data, ptr_buffer, mask, sample, & recon_bounds, (/i,j,k/), (/i1,j1,k1/)) class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum & - regional buffer_obj is not one of the support buffer types: outputBuffer0d_type & - outputBuffer1d_type outputBuffer2d_type outputBuffer3d_type & - outputBuffer4d_type outputBuffer5d_type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' regional buffer_obj is not one of the support buffer types: outputBuffer0d_type'//& + ' outputBuffer1d_type outputBuffer2d_type outputBuffer3d_type'//& + ' outputBuffer4d_type outputBuffer5d_type') end select end if END DO @@ -317,10 +317,10 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer5d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum in reduced_k_range_if & - regional buffer_obj is not one of the support buffer types: outputBuffer0d_type & - outputBuffer1d_type outputBuffer2d_type outputBuffer3d_type & - outputBuffer4d_type outputBuffer5d_type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum in reduced_k_range_if'//& + ' regional buffer_obj is not one of the support buffer types: outputBuffer0d_type'//& + ' outputBuffer1d_type outputBuffer2d_type outputBuffer3d_type'//& + ' outputBuffer4d_type outputBuffer5d_type') end select ELSE !< does not have reduced_k_range debug_diag_if: IF ( debug_diag_manager ) THEN @@ -349,10 +349,10 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer5d_type) call update_array_extremum(flag, field_data, ptr_buffer, mask, sample, recon_bounds, reduced_k_range) class default - call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum & - regional buffer_obj is not one of the support buffer types: outputBuffer0d_type & - outputBuffer1d_type outputBuffer2d_type outputBuffer3d_type & - outputBuffer4d_type outputBuffer5d_type') + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' regional buffer_obj is not one of the support buffer types: outputBuffer0d_type'//& + ' outputBuffer1d_type outputBuffer2d_type outputBuffer3d_type'//& + ' outputBuffer4d_type outputBuffer5d_type') end select END IF reduced_k_range_if end if regional_if @@ -424,7 +424,7 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, end select end subroutine fms_diag_update_extremum - !> @brief Updates individual element of buffer + !> @brief Updates individual element of the buffer associated with indices in running_indx1 and running_indx2 subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_bounds, & running_indx1, running_indx2) integer, intent(in) :: flag !< Flag indicating maximum(time_max) or minimum(time_min) @@ -499,7 +499,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ type is (real(kind=r8_kind)) select type (buffer) type is (real(kind=r8_kind)) - if (flag .eq. time_min) then + minimum_if: if (flag .eq. time_min) then ! Update the buffer with the current minimum where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& buffer(i1,j1,k1,:,sample)) @@ -511,7 +511,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ buffer(i1,j1,k1,:,sample)) buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) end where - end if + endif minimum_if class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum"//& " buffer type does not match with field_data type.") @@ -519,7 +519,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ type is (integer(kind=i4_kind)) select type (buffer) type is (integer(kind=i4_kind)) - if (flag .eq. time_min) then + minimum_if: if (flag .eq. time_min) then ! Update the buffer with the current minimum where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& buffer(i1,j1,k1,:,sample)) @@ -531,7 +531,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ buffer(i1,j1,k1,:,sample)) buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) end where - end if + endif minimum_if class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum"//& " buffer type does not match with field_data type.") @@ -539,7 +539,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ type is (integer(kind=i8_kind)) select type (buffer) type is (integer(kind=i8_kind)) - if (flag .eq. time_min) then + minimum_if: if (flag .eq. time_min) then ! Update the buffer with the current minimum where (mask(i-is+1+hi,j-js+1+hj,k,:) .AND. field_data(i-is+1+hi,j-js+1+hj,k,:) <& buffer(i1,j1,k1,:,sample)) @@ -551,7 +551,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ buffer(i1,j1,k1,:,sample)) buffer(i1,j1,k1,:,sample) = field_data(i-is+1+hi,j-js+1+hj,k,:) end where - end if + end if minimum_if class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_scalar_extremum"//& " buffer type does not match with field_data type.") @@ -561,7 +561,7 @@ subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_ end select end subroutine update_scalar_extremum - !> @brief Updates a chunk of buffer + !> @brief Updates a chunk of the buffer defined by the bounds in recon_bounds subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_bounds, reduced_k_range) integer :: flag !< Flag indicating maximum(time_max) or minimum(time_min) class(*), intent(in) :: field_data(:,:,:,:) !< Field data @@ -580,6 +580,12 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b integer :: f3, f4 !< Updated starting and ending indices in the J dimension type(fmsDiagIbounds_type) :: IJKBounds !< Bounding object for the I, J, and K indices + !> Check flag for unsupported operation + if (flag .ne. time_max .and. flag .ne. time_min) then + call mpp_error(FATAL, "fms_diag_reduction_methods_mod::fms_diag_scalar_extremum & + unsupported reduction method") + endif + !> Get the `bounds3D` member of the `recon_bounds` IJKBounds = recon_bounds%get_bounds3D() !< Assignment of data structure with intrinsic type members may work!!! @@ -602,7 +608,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b type is (real(kind=r4_kind)) select type (buffer) type is (real(kind=r4_kind)) - if (flag .eq. time_min) then + minimum_if: if (flag .eq. time_min) then !> Update the buffer with the current minimum if (reduced_k_range) then ! recon_bounds must have ks = ksr and ke = ker @@ -626,7 +632,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) end if - end if + end if minimum_if class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum"//& " buffer type does not match with field_data type.") @@ -634,7 +640,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b type is (real(kind=r8_kind)) select type (buffer) type is (real(kind=r8_kind)) - if (flag .eq. time_min) then + minimum_if: if (flag .eq. time_min) then !> Update the buffer with the current minimum if (reduced_k_range) then ! recon_bounds must have ks = ksr and ke = ker @@ -658,7 +664,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) end if - end if + end if minimum_if class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum"//& " buffer type does not match with field_data type.") @@ -666,7 +672,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b type is (integer(kind=i4_kind)) select type (buffer) type is (integer(kind=i4_kind)) - if (flag .eq. time_min) then + minimum_if: if (flag .eq. time_min) then !> Update the buffer with the current minimum if (reduced_k_range) then ! recon_bounds must have ks = ksr and ke = ker @@ -690,7 +696,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) end if - end if + end if minimum_if class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum"//& " buffer type does not match with field_data type.") @@ -698,7 +704,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b type is (integer(kind=i8_kind)) select type (buffer) type is (integer(kind=i8_kind)) - if (flag .eq. time_min) then + minimum_if: if (flag .eq. time_min) then !> Update the buffer with the current minimum if (reduced_k_range) then ! recon_bounds must have ks = ksr and ke = ker @@ -722,7 +728,7 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample)) & buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field_data(f1:f2,f3:f4,ks:ke,:) end if - end if + end if minimum_if class default call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum"//& " buffer type does not match with field_data type.") From 5d8a4ce19d849fdbf35ad0760cf5c0f969f8314d Mon Sep 17 00:00:00 2001 From: Ganga P Purja Pun Date: Thu, 27 Jul 2023 16:07:25 -0400 Subject: [PATCH 61/61] Incomplete time average reduction for future updates --- diag_manager/fms_diag_object.F90 | 37 +- diag_manager/fms_diag_reduction_methods.F90 | 1418 ++++++++++++++++++- 2 files changed, 1431 insertions(+), 24 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 0a7ebee402..83b92efb66 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -40,7 +40,8 @@ module fms_diag_object_mod use fms_mod, only: fms_error_handler use constants_mod, only: SECONDS_PER_DAY use fms_diag_bbox_mod, only: fmsDiagBoundsHalos_type, recondition_indices, fmsDiagIbounds_type -use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask_3d, real_copy_set, fms_diag_update_extremum +use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask_3d, real_copy_set, fms_diag_update_extremum, & + fms_diag_time_average #endif #if defined(_OPENMP) use omp_lib @@ -1135,8 +1136,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight integer, allocatable :: freq(:) !< Output frequency integer :: reduction_method !< Integer representing a reduction method: none, average, min, max, ... etc. integer :: pow_val !< Exponent used in calculation of time average - logical :: phys_window - logical :: reduced_k_range + logical :: phys_window !< Flag indicating if the field is a physics window + logical :: reduced_k_range !< Flag indicating if the field has zbounds logical :: is_regional !< Flag to indicate if the field is regional logical :: this_pe_writes !< Flag to indicate if the data from the current PE need to be written integer, allocatable :: l_start(:) !< local start indices on axes for regional output @@ -1191,7 +1192,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight !> Store buffer ID of the i-th element of the buffer_ids(:) buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(id) - !> Make locak copies of field information + !> Make local copies of field information freq = this%FMS_diag_fields(diag_field_id)%get_frequency() reduction_method = this%FMS_diag_fields(diag_field_id)%diag_field(id)%get_var_reduction() has_diurnal_axis = this%FMS_diag_fields(diag_field_id)%diag_field(id)%has_n_diurnal() @@ -1220,6 +1221,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight n_axis = size(this%FMS_diag_output_buffers(buffer_id)%axis_ids) allocate(l_start(n_axis)) allocate(l_end(n_axis)) + l_start = 1 + l_end = 1 do ax = 1, n_axis ptr_axis => this%diag_axis(this%FMS_diag_output_buffers(buffer_id)%axis_ids(ax))%axis select type (ptr_axis) @@ -1241,8 +1244,14 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight !> Get the vertical layer starting and ending indices if (reduced_k_range) then - if (.not.allocated(l_start)) allocate(l_start(3)) - if (.not.allocated(l_end)) allocate(l_end(3)) + if (.not.allocated(l_start)) then + allocate(l_start(3)) + l_start = 1 + endif + if (.not.allocated(l_end)) then + allocate(l_end(3)) + l_end = 1 + endif ptr_axis => this%diag_axis(this%FMS_diag_output_buffers(buffer_id)%axis_ids(2))%axis !< Axis in the J dimension select type (ptr_axis) type is (fmsDiagSubAxis_type) @@ -1253,7 +1262,16 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight l_start(3) = ptr_axis%get_starting_index() l_end(3) = ptr_axis%get_ending_index() class default - call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_do_reduction non fmsDiagSubAxis_type axis') + call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_do_reduction Not a fmsDiagSubAxis_type axis') + end select + + ptr_axis => this%diag_axis(this%FMS_diag_output_buffers(buffer_id)%axis_ids(3))%axis !< Axis in the K dimension + select type (ptr_axis) + type is (fmsDiagSubAxis_type) + l_start(3) = ptr_axis%get_starting_index() + l_end(3) = ptr_axis%get_ending_index() + class default + call mpp_error(FATAL, 'fms_diag_object_mod::fms_diag_do_reduction Not a fmsDiagSubAxis_type axis') end select end if @@ -1300,8 +1318,9 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight case (time_none) !! TODO: just copy field data to buffer case (time_average) - !! TODO: average data over time - !! call fms_diag_sum(time_average, weight=weight, pow_val=power_val, .......) + call fms_diag_time_average(time_average, this%FMS_diag_fields(diag_field_id), ptr_diag_buffer_obj, & + field_data, bounds_with_halos, l_start, l_end, is_regional, reduced_k_range, sample, & + oor_mask_4d, field_name, has_diurnal_axis, phys_window, weight, pow_val, err_msg) case (time_rms) !! TODO: root-mean-square error case (time_max) diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90 index 67b942748f..8a8efd1011 100644 --- a/diag_manager/fms_diag_reduction_methods.F90 +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -9,7 +9,8 @@ module fms_diag_reduction_methods_mod use fms_mod, only: fms_error_handler use fms_diag_bbox_mod use fms_diag_output_buffer_mod - use diag_data_mod, only: debug_diag_manager, time_max, time_min + use diag_data_mod, only: debug_diag_manager, time_max, time_min, time_average, time_sum + use fms_diag_field_object_mod, only: fmsDiagField_type implicit none private @@ -17,6 +18,9 @@ module fms_diag_reduction_methods_mod #ifdef use_yaml public :: compare_two_sets_of_bounds, real_copy_set, check_indices_order, init_mask_3d public :: fms_diag_update_extremum, update_scalar_extremum, update_array_extremum + public :: fms_diag_time_average, fms_diag_mask_variant_do_sum, sum_scalar_field_data + public :: fms_diag_no_mask_variant_do_sum, update_buffer_obj_num_elements, set_buffer_obj_count_0d + public :: update_buffer_obj_count_0d contains !> @brief Compares the corresponding bounding indices of the first set with the second set. @@ -211,7 +215,7 @@ end subroutine init_mask_3d subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, l_start, & l_end, is_regional, reduced_k_range, sample, mask, fieldName, hasDiurnalAxis, err_msg) integer, intent(in) :: flag !< Flag to indicate what to update: time_min for minimum; time_max for maximum - class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Remapped buffer to update + class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Buffer object class(*), intent(in) :: field_data(:,:,:,:) !< Field data type(fmsDiagBoundsHalos_type), intent(inout) :: recon_bounds !< Indices of bounds in the first three dimension !! of the field data @@ -358,13 +362,21 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, end if regional_if ! Reset counter count_0d of the buffer object + call set_buffer_obj_count_0d(buffer_obj, 1.0) + end subroutine fms_diag_update_extremum + + !> @brief Sets the counter `count_0d` of a buffer object to a given value + subroutine set_buffer_obj_count_0d(buffer_obj, val) + class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Buffer object + class(*) intent(in) :: val !< Reset value + select type (buffer_obj) type is (outputBuffer0d_type) select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - real_counter(sample) = 1.0_r4_kind + real_counter(sample) = real(val, kind=r4_kind) type is (real(kind=r8_kind)) - real_counter(sample) = 1.0_r8_kind + real_counter(sample) = real(val, kind=r8_kind) class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& ' Unsupported type of buffer_obj%count_0d') @@ -372,9 +384,9 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer1d_type) select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - real_counter(sample) = 1.0_r4_kind + real_counter(sample) = real(val, kind=r4_kind) type is (real(kind=r8_kind)) - real_counter(sample) = 1.0_r8_kind + real_counter(sample) = real(val, kind=r8_kind) class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& ' Unsupported type of buffer_obj%count_0d') @@ -382,9 +394,9 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer2d_type) select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - real_counter(sample) = 1.0_r4_kind + real_counter(sample) = real(val, kind=r4_kind) type is (real(kind=r8_kind)) - real_counter(sample) = 1.0_r8_kind + real_counter(sample) = real(val, kind=r8_kind) class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& ' Unsupported type of buffer_obj%count_0d') @@ -392,9 +404,9 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer3d_type) select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - real_counter(sample) = 1.0_r4_kind + real_counter(sample) = real(val, kind=r4_kind) type is (real(kind=r8_kind)) - real_counter(sample) = 1.0_r8_kind + real_counter(sample) = real(val, kind=r8_kind) class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& ' Unsupported type of buffer_obj%count_0d') @@ -402,9 +414,9 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer4d_type) select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - real_counter(sample) = 1.0_r4_kind + real_counter(sample) = real(val, kind=r4_kind) type is (real(kind=r8_kind)) - real_counter(sample) = 1.0_r8_kind + real_counter(sample) = real(val, kind=r8_kind) class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& ' Unsupported type of buffer_obj%count_0d') @@ -412,9 +424,9 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, type is (outputBuffer5d_type) select type (real_counter => buffer_obj%count_0d) type is (real(kind=r4_kind)) - real_counter(sample) = 1.0_r4_kind + real_counter(sample) = real(val, kind=r4_kind) type is (real(kind=r8_kind)) - real_counter(sample) = 1.0_r8_kind + real_counter(sample) = real(val, kind=r8_kind) class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& ' Unsupported type of buffer_obj%count_0d') @@ -422,8 +434,79 @@ subroutine fms_diag_update_extremum(flag, buffer_obj, field_data, recon_bounds, class default call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') end select - end subroutine fms_diag_update_extremum + end subroutine set_buffer_obj_count_0d + !> @brief Increments the counter `count_0d` of a buffer object by a given value + subroutine update_buffer_obj_count_0d(buffer_obj, val) + class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Buffer object + class(*) intent(in) :: val !< Increment value + + select type (buffer_obj) + type is (outputBuffer0d_type) + select type (real_counter => buffer_obj%count_0d) + type is (real(kind=r4_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r4_kind) + type is (real(kind=r8_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r8_kind) + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') + end select + type is (outputBuffer1d_type) + select type (real_counter => buffer_obj%count_0d) + type is (real(kind=r4_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r4_kind) + type is (real(kind=r8_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r8_kind) + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') + end select + type is (outputBuffer2d_type) + select type (real_counter => buffer_obj%count_0d) + type is (real(kind=r4_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r4_kind) + type is (real(kind=r8_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r8_kind) + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') + end select + type is (outputBuffer3d_type) + select type (real_counter => buffer_obj%count_0d) + type is (real(kind=r4_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r4_kind) + type is (real(kind=r8_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r8_kind) + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') + end select + type is (outputBuffer4d_type) + select type (real_counter => buffer_obj%count_0d) + type is (real(kind=r4_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r4_kind) + type is (real(kind=r8_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r8_kind) + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') + end select + type is (outputBuffer5d_type) + select type (real_counter => buffer_obj%count_0d) + type is (real(kind=r4_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r4_kind) + type is (real(kind=r8_kind)) + real_counter(sample) = real_counter(sample) + real(val, kind=r8_kind) + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum'//& + ' Unsupported type of buffer_obj%count_0d') + end select + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::fms_diag_update_extremum unsupported buffer type') + end select + end subroutine update_buffer_obj_count_0d + !> @brief Updates individual element of the buffer associated with indices in running_indx1 and running_indx2 subroutine update_scalar_extremum(flag, field_data, buffer, mask, sample, recon_bounds, & running_indx1, running_indx2) @@ -737,5 +820,1310 @@ subroutine update_array_extremum(flag, field_data, buffer, mask, sample, recon_b call mpp_error( FATAL, "fms_diag_reduction_methods_mod::update_array_extremum unsupported field data type") end select end subroutine update_array_extremum + + !> @brief Performs actual computation for sum or average for mask variant field depending + !! on the flag value passed: time_sum for sum; time_average for average + subroutine fms_diag_mask_variant_do_sum(flag, field_data, buffer_obj, recon_bounds, kr_start, kr_end, & + reduced_k_range, pow_val, mask, weight, hasDiurnalAxis, field_name, sample) + integer, intent(in) :: flag !< Flag indicating a reduction method: sum(time_sum) or average(time_average) + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Buffer object + type(fmsDiagBoundsHalos_type), intent(inout) :: recon_bounds !< Indices of bounds in the first three dimensions + !! of the field data + integer, intent(in) :: kr_start(:) !< Local starting indices for the first three dimensions + integer, intent(in) :: kr_end(:) !< Local ending indices for the first three dimensions + logical, intent(in) :: reduced_k_range !< Flag indicating if the field has zbounds + integer, intent(in) :: pow_val !< Power value as an exponent + logical, intent(in) :: mask(:,:,:,:) !< Must be out of range mask + real, intent(in) :: weight !< Must be a updated weight + logical, intent(in) :: hasDiurnalAxis !< Flag to indicate if the buffer has a diurnal axis + character(len=*), intent(in) :: field_name !< Field name for error reporting + integer, intent(in) :: sample !< Index along the diurnal time axis + + integer :: is, js, ks !< Starting indices in the I, J, and K dimensions + integer :: ie, je, ke !< Ending indices in the I, J, and K dimensions + integer :: hi, hj !< Halo sizes in the I, and J dimensions + integer :: f1, f2 !< Updated starting and ending indices in the I dimension + integer :: f3, f4 !< Updated starting and ending indices in the J dimension + integer :: ksr, ker !< Reduced indices in the K dimension + integer :: i, j, k !< Running indices for looping + integer :: k1 !< Secondary running index + class(*), pointer :: ptr_buffer(:,:,:,:,:) !< Pointer to 5D buffer for remapping + character(len=52) :: code_module_name !< String to hold module and routine names + type(fmsDiagIbounds_type) :: IJKBounds !< Index bounds in the I, J, and K dimensions + + !> Check flag for time_sum and time_average + if (flag /= time_sum .and. flag /= time_average) then + call mpp_error( FATAL, TRIM(str_modname)//" flag must be a parameter either time_sum or time_average.") + endif + + !> Initialize code_module_name + code_module_name = "fms_diag_reduction_methods_mod::fms_diag_mask_do_sum" + + !> Remap buffer + ptr_buffer => buffer_obj%remap_buffer(fieldName, hasDiurnalAxis) + + !> Unpack bounds to individual indices + IJKBounds = recon_bounds%get_bounds3D() + is = IJKBounds%get_imin() + js = IJKBounds%get_jmin() + ks = IJKBounds%get_kmin() + ie = IJKBounds%get_imax() + je = IJKBounds%get_jmax() + ke = IJKBounds%get_kmax() + hi = recon_bounds%get_hi() + hj = recon_bounds%get_hj() + + if (reduced_k_range) then + ksr = kr_start(3) + ker = kr_end(3) + else + ksr = ks + ker = ke + end if + + DO k= ksr, ker + if (reduced_k_range) then + k1= k - ksr + 1 + else + k1 = k + end if + DO j=js, je + DO i=is, ie + IF (mask(i-is+1+hi, j-js+1+hj, k, :)) THEN + select type (buffer_obj) + type is (outputBuffer0d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i-hi, j-hj, k1, 1/), weight, pow_val, sample) + if (flag == time_average) then + select type (counter_type => buffer_obj%counter) + type is (real(kind=r4_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + type is (real(kind=r8_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + class default + call mpp_error(FATAL, TRIM(code_module_name)//' Unsupported type and must be either & + r4 or r8 type') + end select + endif + type is (outputBuffer1d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i-hi, j-hj, k1, 1/), weight, pow_val, sample) + if (flag == time_average) then + select type (counter_type => buffer_obj%counter) + type is (real(kind=r4_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + type is (real(kind=r8_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + class default + call mpp_error(FATAL, TRIM(code_module_name)//' Unsupported type and must be either & + r4 or r8 type') + end select + endif + type is (outputBuffer2d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i-hi, j-hj, k1, 1/), weight, pow_val, sample) + if (flag == time_average) then + select type (counter_type => buffer_obj%counter) + type is (real(kind=r4_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + type is (real(kind=r8_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + class default + call mpp_error(FATAL, TRIM(code_module_name)//' Unsupported type and must be either & + r4 or r8 type') + end select + endif + type is (outputBuffer3d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i-hi, j-hj, k1, 1/), weight, pow_val, sample) + if (flag == time_average) then + select type (counter_type => buffer_obj%counter) + type is (real(kind=r4_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + type is (real(kind=r8_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + class default + call mpp_error(FATAL, TRIM(code_module_name)//' Unsupported type and must be either & + r4 or r8 type') + end select + endif + type is (outputBuffer4d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i-hi, j-hj, k1, 1/), weight, pow_val, sample) + if (flag == time_average) then + select type (counter_type => buffer_obj%counter) + type is (real(kind=r4_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + type is (real(kind=r8_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + class default + call mpp_error(FATAL, TRIM(code_module_name)//' Unsupported type and must be either & + r4 or r8 type') + end select + endif + type is (outputBuffer5d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i-hi, j-hj, k1, 1/), weight, pow_val, sample) + if (flag == time_average) then + select type (counter_type => buffer_obj%counter) + type is (real(kind=r4_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + type is (real(kind=r8_kind)) + counter_type(i-hi, j-hj, k1, :, sample) = counter_type(i-hi, j-hj, k1, :, sample) + weight + class default + call mpp_error(FATAL, TRIM(code_module_name)//' Unsupported type and must be either & + r4 or r8 type') + end select + endif + class default + call mpp_error(FATAL, TRIM(code_module_name)//' Unsupported dimensional buffer type') + end select + END IF + END DO + END DO + END DO + end subroutine fms_diag_mask_variant_do_sum + + !> @brief Updates the counter `num_elements` of buffer object + !! which is polymorphic in dimensionality + subroutine update_buffer_obj_num_elements(buffer_obj, incr, sample) + class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Buffer object + integer, intent(in) :: incr !< Value to increment by + integer, intent(in) :: sample !< Index along the diurnal time axis + + select type (buffer_obj) + type is (outputBuffer0d_type) + buffer_obj%num_elements(sample) = buffer_obj%num_elements(sample) + incr + type is (outputBuffer1d_type) + buffer_obj%num_elements(sample) = buffer_obj%num_elements(sample) + incr + type is (outputBuffer2d_type) + buffer_obj%num_elements(sample) = buffer_obj%num_elements(sample) + incr + type is (outputBuffer3d_type) + buffer_obj%num_elements(sample) = buffer_obj%num_elements(sample) + incr + type is (outputBuffer4d_type) + buffer_obj%num_elements(sample) = buffer_obj%num_elements(sample) + incr + type is (outputBuffer5d_type) + buffer_obj%num_elements(sample) = buffer_obj%num_elements(sample) + incr + class default + call mpp_error(FATAL, 'fms_diag_reduction_methods_mod::update_buffer_num_elemets & + Unsupported dimensional buffer type') + end select + end subroutine update_buffer_obj_num_elements + + !> @brief Computes sum for the non mask variant case in time averaging. + subroutine fms_diag_no_mask_variant_do_sum(field_data, buffer_obj, recon_bounds, l_start, l_end, & + pow_val, mask, weight, field_name, hasDiurnalAxis, sample, missing_value) + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Buffer object + type(fmsDiagBoundsHalos_type), intent(inout) :: recon_bounds !< Indices of bounds in the first three dimensions + !! of the field data + integer, intent(in) :: l_start(:) !< Local starting indices for the first three dimensions + integer, intent(in) :: l_end(:) !< Local ending indices for the first three dimensions + integer, intent(in) :: pow_val !< Power value as an exponent + logical, intent(in) :: mask(:,:,:,:) !< Must be out of range mask + real, intent(in) :: weight !< Must be a updated weight + character(len=*), intent(in) :: field_name !< Field name for error reporting + logical, intent(in) :: hasDiurnalAxis !< Flag to indicate if the buffer has a diurnal axis + integer, intent(in) :: sample !< Index along the diurnal time axis + class(*), intent(in) :: missing_value !< Missing value of the field data + + integer :: is, js, ks !< Starting indices in the I, J, and K dimensions + integer :: ie, je, ke !< Ending indices in the I, J, and K dimensions + integer :: hi, hj !< Halo sizes in the I, and J dimensions + integer :: f1, f2 !< Updated starting and ending indices in the I dimension + integer :: f3, f4 !< Updated starting and ending indices in the J dimension + integer :: ksr, ker !< Reduced indices in the K dimension + integer :: i, j, k !< Running indices for looping + integer :: i1, j1, k1 !< Secondary running indices + class(*), pointer :: ptr_buffer(:,:,:,:,:) !< Pointer to 5D buffer for remapping + type(fmsDiagIbounds_type) :: IJKBounds !< Index bounds in the I, J, and K dimensions + character(len=64) :: code_module_name !< Holds module and routine names for error reporting + + code_module_name = "fms_diag_reduction_methods_mod::fms_diag_no_mask_variant_do_sum" + + !> Remap buffer + ptr_buffer => buffer_obj%remap_buffer(field_name, hasDiurnalAxis) + + !> Unpack bounds to individual indices + IJKBounds = recon_bounds%get_bounds3D() + is = IJKBounds%get_imin() + js = IJKBounds%get_jmin() + ks = IJKBounds%get_kmin() + ie = IJKBounds%get_imax() + je = IJKBounds%get_jmax() + ke = IJKBounds%get_kmax() + hi = recon_bounds%get_hi() + hj = recon_bounds%get_hj() + + DO k = l_start(3), l_end(3) + k1 = k-l_start(3)+1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN + select type (buffer_obj) + type is (outputBuffer0d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i1, j1, k1, 1/), weight, pow_val, sample) + type is (outputBuffer1d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i1, j1, k1, 1/), weight, pow_val, sample) + type is (outputBuffer2d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i1, j1, k1, 1/), weight, pow_val, sample) + type is (outputBuffer3d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i1, j1, k1, 1/), weight, pow_val, sample) + type is (outputBuffer4d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i1, j1, k1, 1/), weight, pow_val, sample) + type is (outputBuffer5d_type) + call sum_scalar_field_data(field_data, (/i-is+1+hi, j-js+1+hj, k, 1/), & + ptr_buffer, (/i1, j1, k1, 1/), weight, pow_val, sample) + class default + call mpp_error(FATAL, TRIM(code_module_name)//' Unsupported dimensional buffer type') + end select + ELSE + select type (buffer_obj) !< Select dimensional buffer type + type is (outputBuffer0d_type) !< Scalar buffer + select type (ptr_buffer) !< Select type of scalar buffer + type is (real(kind=r4_kind)) + select type (missing_value) + type is (real(kind=r4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r4') + end select + type is (real(kind=r8_kind)) + select type (missing_value) + type is (real(kind=r8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r8') + end select + type is (integer(kind=i4_kind)) + select type (missing_value) + type is (integer(kind=i4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i4') + end select + type is (integer(kind=i8_kind)) + select type (missing_value) + type is (integer(kind=i8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i8') + end select + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported buffer type; must be either i4, i8, r4 or r8') + end select !< End of selection of scalar buffer type + type is (outputBuffer1d_type) !< 1D buffer + select type (ptr_buffer) !< Select type of 1D buffer + type is (real(kind=r4_kind)) + select type (missing_value) + type is (real(kind=r4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r4') + end select + type is (real(kind=r8_kind)) + select type (missing_value) + type is (real(kind=r8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r8') + end select + type is (integer(kind=i4_kind)) + select type (missing_value) + type is (integer(kind=i4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i4') + end select + type is (integer(kind=i8_kind)) + select type (missing_value) + type is (integer(kind=i8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i8') + end select + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported buffer type; must be either i4, i8, r4 or r8') + end select !< End of selection of 1D buffer type + type is (outputBuffer2d_type) !< 2D buffer + select type (ptr_buffer) !< Select type of 2D buffer + type is (real(kind=r4_kind)) + select type (missing_value) + type is (real(kind=r4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r4') + end select + type is (real(kind=r8_kind)) + select type (missing_value) + type is (real(kind=r8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r8') + end select + type is (integer(kind=i4_kind)) + select type (missing_value) + type is (integer(kind=i4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i4') + end select + type is (integer(kind=i8_kind)) + select type (missing_value) + type is (integer(kind=i8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i8') + end select + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported buffer type; must be either i4, i8, r4 or r8') + end select !< End of selection of 2D buffer type + type is (outputBuffer3d_type) !< 3D buffer + select type (ptr_buffer) !< Select type of 3D buffer + type is (real(kind=r4_kind)) + select type (missing_value) + type is (real(kind=r4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r4') + end select + type is (real(kind=r8_kind)) + select type (missing_value) + type is (real(kind=r8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r8') + end select + type is (integer(kind=i4_kind)) + select type (missing_value) + type is (integer(kind=i4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i4') + end select + type is (integer(kind=i8_kind)) + select type (missing_value) + type is (integer(kind=i8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i8') + end select + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported buffer type; must be either i4, i8, r4 or r8') + end select !< End of selection of 3D buffer type + type is (outputBuffer4d_type) !< 4D buffer + select type (ptr_buffer) !< Select type of 4D buffer + type is (real(kind=r4_kind)) + select type (missing_value) + type is (real(kind=r4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r4') + end select + type is (real(kind=r8_kind)) + select type (missing_value) + type is (real(kind=r8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r8') + end select + type is (integer(kind=i4_kind)) + select type (missing_value) + type is (integer(kind=i4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i4') + end select + type is (integer(kind=i8_kind)) + select type (missing_value) + type is (integer(kind=i8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i8') + end select + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported buffer type; must be either i4, i8, r4 or r8') + end select !< End of selection of 4D buffer type + type is (outputBuffer5d_type) !< 5D buffer + select type (ptr_buffer) !< Select type of 5D buffer + type is (real(kind=r4_kind)) + select type (missing_value) + type is (real(kind=r4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r4') + end select + type is (real(kind=r8_kind)) + select type (missing_value) + type is (real(kind=r8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be r8') + end select + type is (integer(kind=i4_kind)) + select type (missing_value) + type is (integer(kind=i4_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i4') + end select + type is (integer(kind=i8_kind)) + select type (missing_value) + type is (integer(kind=i8_kind)) + ptr_buffer(i1, j1, k1, 1, sample) = missing_value + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported type in missing value; must be i8') + end select + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported buffer type; must be either i4, i8, r4 or r8') + end select !< End of selection of 5D buffer type + class default + call mpp_error(FATAL, TRIM(code_module_name)//& + ' Unsupported dimensional buffer type') + end select !< End of selection of dimensional buffer + END IF + END IF + END DO + END DO + END DO + end subroutine + + !> @brief Adds single field data to output buffer element. + !! Order of indices in field_indices and buf_indices must be in (/i, j, k, l/) + !! The argument `weight` is not involved in any calculations related to buffer type i4 or i8 + subroutine sum_scalar_field_data(field_data, field_indices, buffer, buf_indices, weight, power_val, sample) + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + integer, intent(in) :: field_indices(4) !< Indices of field data + class(*), intent(inout) :: buffer(:,:,:,:,:) !< Remapped output buffer + integer, intent(in) :: buf_indices(4) !< Indices of buffer data + real, intent(in) :: weight !< Must be a updated weight + integer, intent(in) :: power_val !< Power value as an exponent + integer, intent(in) :: sample !< Index along the diurnal time axis + + character(len=48) :: mod_info !< Holds code module information + + mod_info = 'fms_diag_reduction_methods_mod::sum_scalar_field_data' + + !> Add field data to buffer; if `weight` is not equal to 1.0, it is a weighted sum/average. + select type (field_data) + type is (real(kind=r4_kind)) + select type (buffer) + type is (real(kind=r4_kind)) + select case (power_val) + case (1) + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) * weight + case (2) + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) * weight *& + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) * weight + case default + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + (field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) * weight)**(power_val) + end select + class default + call mpp_error(FATAL, TRIM(mod_info)//' Buffer type not supported and must be either r4, r8, i4 or i8') + end select + type is (real(kind=r8_kind)) + select type (buffer) + type is (real(kind=r8_kind)) + select case (power_val) + case (1) + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) * weight + case (2) + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) * weight *& + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) * weight + case default + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + (field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) * weight)**(power_val) + end select + class default + call mpp_error(FATAL, TRIM(mod_info)//' Buffer type not supported and must be either r4, r8, i4 or i8') + end select + type is (integer(kind=i4_kind)) + select type (buffer) + type is (integer(kind=i4_kind)) + select case (power_val) + case (1) + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) + case (2) + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) *& + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) + case default + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + (field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)))**(power_val) + end select + class default + call mpp_error(FATAL, TRIM(mod_info)//' Buffer type not supported and must be either r4, r8, i4 or i8') + end select + type is (integer(kind=i8_kind)) + select type (buffer) + type is (integer(kind=i8_kind)) + select case (power_val) + case (1) + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) + case (2) + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) *& + field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)) + case default + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) = & + buffer(buf_indices(1), buf_indices(2), buf_indices(3), buf_indices(4), sample) + & + (field_data(field_indices(1), field_indices(2), field_indices(3), field_indices(4)))**(power_val) + end select + class default + call mpp_error(FATAL, TRIM(mod_info)//' Buffer type not supported and must be either r4, r8, i4 or i8') + end select + class default + call mpp_error(FATAL, TRIM(mod_info)//' Unsupported field data type and must be either r4, r8, i4 or i8') + end select + end subroutine sum_scalar_field_data + + !> @brief A wrapper to perform time average or sum of the input field data + !! depending on the flag value passed: time_sum for sum; time_average for average + subroutine fms_diag_time_average(flag, field, buffer_obj, field_data, recon_bounds, l_start, & + l_end, is_regional, reduced_k_range, sample, mask, fieldName, has_diurnal_axis, phys_win, & + weight, pow_val, err_msg) + integer, intent(in) :: flag !< Flag indicating reduction method: sum(time_sum) or average(time_average) + type(fmsDiagField_type), intent(in) :: field !< Field object + class(fmsDiagOutputBuffer_class), intent(inout) :: buffer_obj !< Buffer object + class(*), intent(in) :: field_data(:,:,:,:) !< Field data + type(fmsDiagBoundsHalos_type), intent(inout) :: recon_bounds !< Holds indices of bounds in the I, J, and K + !! dimensions and halo sizes in the I and + !! J dimensions + integer, intent(in) :: l_start(:) !< Local starting indices for the first three dimensions + integer, intent(in) :: l_end(:) !< Local ending indices for the first three dimensions + logical, intent(in) :: is_regional !< Flag indicating if the current PE takes part in send_data + logical, intent(in) :: reduced_k_range !< Flag indicating if the field has zbounds + integer, intent(in) :: sample !< Index along the diurnal time axis + logical, intent(in) :: mask(:,:,:,:) !< Must be out of range mask + character(len=*), intent(in) :: fieldName !< Field name for error reporting + logical, intent(in) :: has_diurnal_axis !< Flag to indicate if the buffer has a diurnal axis + logical, intent(in) :: phys_win !< Flag indicating if the field is a physics window + real, intent(in) :: weight !< Must be a updated weight + integer, intent(in) :: pow_val !< Power value as an exponent + character(len=*), intent(inout), optional :: err_msg !< Error message + + integer :: is, js, ks !< Starting indices in the I, J, and K dimensions + integer :: ie, je, ke !< Ending indices in the I, J, and K dimensions + integer :: hi, hj !< Halo sizes in the I, and J dimensions + integer :: f1, f2 !< Updated starting and ending indices in the I dimension + integer :: f3, f4 !< Updated starting and ending indices in the J dimension + integer :: ksr, ker !< Reduced indices in the K dimension + integer :: i, j, k, i1, j1, k1 !< For loops + class(*), pointer :: ptr_buffer(:,:,:,:,:) !< Pointer to 5D buffer for remapping + character(len=128) :: err_msg_local !< Stores local error message + character(len=128) :: error_string !< Holds partial error text + character(len=52) :: str_modname !< Holds names of this subroutine and the module it is in + type(fmsDiagIbounds_type) :: IJKBounds !< Index bounds in the I, J, and K dimensions + + !> Initialize the local error reporting strings + error_string = '' + str_modname = "fms_diag_reduction_methods_mod::fms_diag_update_sum" + + !> Unpack recon_bounds to respective indices + IJKBounds = recon_bounds%get_bounds3D() + is = IJKBounds%get_imin() + js = IJKBounds%get_jmin() + ks = IJKBounds%get_kmin() + ie = IJKBounds%get_imax() + je = IJKBounds%get_jmax() + ke = IJKBounds%get_kmax() + hi = recon_bounds%get_hi() + f1 = recon_bounds%get_fis() + f2 = recon_bounds%get_fie() + hj = recon_bounds%get_hj() + f3 = recon_bounds%get_fjs() + f4 = recon_bounds%get_fje() + + if (flag /= time_average .and. flag /= time_sum) then + call mpp_error( FATAL, TRIM(str_modname)//" flag must be a parameter either time_sum or time_average.") + end if + + IF (field%is_mask_variant()) THEN + IF (is_regional) THEN + WRITE (error_string,'(a,"/",a)') & + & TRIM(field%get_modname()), & + & TRIM(fieldName) + IF (fms_error_handler(TRIM(str_modname), 'module/field_name '//TRIM(error_string)//& + & ', regional output NOT supported with mask_variant', err_msg)) THEN + RETURN + END IF + END IF + + ! Should reduced_k_range data be supported with the mask_variant option ????? + ! If not, error message should be produced and the reduced_k_range loop below eliminated + IF (PRESENT(mask)) THEN + IF (field%has_missing_value()) THEN + IF (debug_diag_manager) THEN + ! Compare bounds {is-hi, ie-hi, js-hj, je-hj, ks, ke} with the bounds of first three dimensions of the buffer + if (compare_two_sets_of_bounds((/is-hi, ie-hi, js-hj, je-hj, ks, ke/), & + (/LBOUND(ptr_buffer,1), UBOUND(ptr_buffer,1), LBOUND(ptr_buffer,2), UBOUND(ptr_buffer,2), & + LBOUND(ptr_buffer,3), UBOUND(ptr_buffer,3)/), err_msg_local)) THEN + IF (fms_error_handler(TRIM(str_modname), err_msg_local, err_msg)) THEN + RETURN + END IF + END IF + END IF + IF(phys_win) then + call fms_diag_mask_variant_do_sum(flag, field_data, buffer_obj, recon_bounds, l_start, l_end, & + reduced_k_range, pow_val, mask, weight, has_diurnal_axis, fieldName, sample) + ELSE + call fms_diag_mask_variant_do_sum(flag, field_data, buffer_obj, recon_bounds, l_start, l_end, & + reduced_k_range, pow_val, mask, weight, has_diurnal_axis, fieldName, sample) + END IF + ELSE + WRITE (error_string,'(a,"/",a)')& + & TRIM(field%get_modname()), & + & TRIM(fieldName) + IF(fms_error_handler(TRIM(str_modname), 'module/field_name '//TRIM(error_string)//& + & ', variable mask but no missing value defined', err_msg)) THEN + RETURN + END IF + END IF + ELSE ! no mask present + WRITE (error_string,'(a,"/",a)')& + & TRIM(field%get_modname()), & + & TRIM(fieldName) + IF(fms_error_handler(TRIM(str_modname),'module/field_name'//TRIM(error_string)//& + & ', variable mask but no mask given', err_msg)) THEN + RETURN + END IF + END IF + ELSE ! mask_variant=false + IF ( PRESENT(mask) ) THEN + IF (field%has_missing_value()) THEN + IF (is_regional) THEN + IF (phys_window) then + call fms_diag_no_mask_variant_do_sum(field_data, buffer_obj, recon_bounds, & + l_start, l_end, pow_val, mask, weight, fieldName, has_diurnal_axis, & + sample, field%get_missing_value()) + ELSE + call fms_diag_no_mask_variant_do_sum(field_data, buffer_obj, recon_bounds, & + l_start, l_end, pow_val, mask, weight, fieldName, has_diurnal_axis, & + sample, field%get_missing_value()) + ENDIF + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + call update_buffer_obj_num_elements(buffer_obj, (l_end(3)-l_start(3)+1), sample) + END IF + END DO + END DO +!====================================================================================================== + !!TODO: everything below has not been refactored/updated + ELSE IF ( reduced_k_range ) THEN + IF (numthreads>1 .AND. phys_window) then + DO k=ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue + END IF + END DO + END DO + END DO + ELSE + DO k=ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue + END IF + END DO + END DO + END DO + END IF + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + IF (numthreads>1 .AND. phys_window) then + DO k=ks, ke + DO j=js, je + DO i=is, ie + IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue + END IF + END DO + END DO + END DO + ELSE + DO k=ks, ke + DO j=js, je + DO i=is, ie + IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue + END IF + END DO + END DO + END DO + END IF + END IF + IF ( need_compute .AND. .NOT.phys_window ) THEN + IF ( ANY(mask(l_start(1)+hi:l_end(1)+hi,l_start(2)+hj:l_end(2)+hj,l_start(3):l_end(3))) ) & + & output_fields(out_num)%count_0d(sample) =& + & output_fields(out_num)%count_0d(sample) + weight1 + ELSE + IF ( ANY(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =& + & output_fields(out_num)%count_0d(sample)+weight1 + END IF + ELSE ! missing value NOT present + IF ( (.NOT.ALL(mask(f1:f2,f3:f4,ks:ke)) .AND. mpp_pe() .EQ. mpp_root_pe()).AND.& + & .NOT.input_fields(diag_field_id)%issued_mask_ignore_warning ) THEN + ! + ! Mask will be ignored since missing values were not specified for field + ! in module + ! + CALL error_mesg('diag_manager_mod::send_data_3d',& + & 'Mask will be ignored since missing values were not specified for field '//& + & trim(input_fields(diag_field_id)%field_name)//' in module '//& + & trim(input_fields(diag_field_id)%module_name), WARNING) + input_fields(diag_field_id)%issued_mask_ignore_warning = .TRUE. + END IF + IF ( need_compute ) THEN + IF (numthreads>1 .AND. phys_window) then + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i1,j1,:,sample)= & + & output_fields(out_num)%buffer(i1,j1,:,sample)+ & + & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i1,j1,:,sample)= & + & output_fields(out_num)%buffer(i1,j1,:,sample)+ & + & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + END IF + END IF + END DO + END DO + ELSE + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i1,j1,:,sample)= & + & output_fields(out_num)%buffer(i1,j1,:,sample)+ & + & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i1,j1,:,sample)= & + & output_fields(out_num)%buffer(i1,j1,:,sample)+ & + & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + END IF + END IF + END DO + END DO + END IF + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + output_fields(out_num)%num_elements(sample)=& + & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1 + + END IF + END DO + END DO + ELSE IF ( reduced_k_range ) THEN + IF (numthreads>1 .AND. phys_window) then + ksr= l_start(3) + ker= l_end(3) + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +& + & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +& + & field_out(f1:f2,f3:f4,ksr:ker)*weight1 + END IF + ELSE + ksr= l_start(3) + ker= l_end(3) + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +& + & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +& + & field_out(f1:f2,f3:f4,ksr:ker)*weight1 + END IF + END IF + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) + IF ( err_msg_local /= '') THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + IF (numthreads>1 .AND. phys_window) then + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& + & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& + & field_out(f1:f2,f3:f4,ks:ke)*weight1 + END IF + ELSE + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& + & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& + & field_out(f1:f2,f3:f4,ks:ke)*weight1 + END IF + END IF + END IF + IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =& + & output_fields(out_num)%count_0d(sample) + weight1 + END IF + ELSE ! mask NOT present + IF ( missvalue_present ) THEN + IF ( need_compute ) THEN + if( numthreads>1 .AND. phys_window ) then + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i1,j1,k1,sample) =& + & output_fields(out_num)%buffer(i1,j1,k1,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i1,j1,k1,sample) =& + & output_fields(out_num)%buffer(i1,j1,k1,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue + END IF + END IF + END DO + END DO + END DO + ELSE + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i1,j1,k1,sample) =& + & output_fields(out_num)%buffer(i1,j1,k1,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i1,j1,k1,sample) =& + & output_fields(out_num)%buffer(i1,j1,k1,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue + END IF + END IF + END DO + END DO + END DO + END IF + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj) THEN + output_fields(out_num)%num_elements(sample) =& + & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1 + END IF + END DO + END DO + IF ( .NOT.phys_window ) THEN + outer0: DO k = l_start(3), l_end(3) + DO j=l_start(2)+hj, l_end(2)+hj + DO i=l_start(1)+hi, l_end(1)+hi + IF ( field_out(i,j,k) /= missvalue ) THEN + output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample)& + & + weight1 + EXIT outer0 + END IF + END DO + END DO + END DO outer0 + END IF + ELSE IF ( reduced_k_range ) THEN + if( numthreads>1 .AND. phys_window ) then + ksr= l_start(3) + ker= l_end(3) + DO k = ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue + END IF + END DO + END DO + END DO + else + ksr= l_start(3) + ker= l_end(3) + DO k = ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue + END IF + END DO + END DO + END DO + END IF + outer3: DO k = ksr, ker + k1=k-ksr+1 + DO j=f3, f4 + DO i=f1, f2 + IF ( field_out(i,j,k) /= missvalue ) THEN + output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) & + & + weight1 + EXIT outer3 + END IF + END DO + END DO + END DO outer3 + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + IF( numthreads > 1 .AND. phys_window ) then + DO k=ks, ke + DO j=js, je + DO i=is, ie + IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue + END IF + END DO + END DO + END DO + ELSE + DO k=ks, ke + DO j=js, je + DO i=is, ie + IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + END IF + ELSE + output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue + END IF + END DO + END DO + END DO + END IF + outer1: DO k=ks, ke + DO j=f3, f4 + DO i=f1, f2 + IF ( field_out(i,j,k) /= missvalue ) THEN + output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) & + & + weight1 + EXIT outer1 + END IF + END DO + END DO + END DO outer1 + END IF + ELSE ! no missing value defined, No mask + IF ( need_compute ) THEN + IF( numthreads > 1 .AND. phys_window ) then + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i1,j1,:,sample)= & + & output_fields(out_num)%buffer(i1,j1,:,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i1,j1,:,sample)= & + & output_fields(out_num)%buffer(i1,j1,:,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + END IF + END IF + END DO + END DO + ELSE + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(i1,j1,:,sample)= & + & output_fields(out_num)%buffer(i1,j1,:,sample) +& + & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(i1,j1,:,sample)= & + & output_fields(out_num)%buffer(i1,j1,:,sample) +& + & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + END IF + END IF + END DO + END DO + END IF + + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + output_fields(out_num)%num_elements(sample) =& + & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1 + END IF + END DO + END DO + ! Accumulate time average + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + IF( numthreads > 1 .AND. phys_window ) then + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & + & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & + & field_out(f1:f2,f3:f4,ksr:ker)*weight1 + END IF + ELSE + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & + & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & + & field_out(f1:f2,f3:f4,ksr:ker)*weight1 + END IF + END IF + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + IF( numthreads > 1 .AND. phys_window ) then + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& + & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& + & field_out(f1:f2,f3:f4,ks:ke)*weight1 + END IF + ELSE + IF ( pow_value /= 1 ) THEN + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& + & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) + ELSE + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& + & field_out(f1:f2,f3:f4,ks:ke)*weight1 + END IF + END IF + END IF + IF ( .NOT.phys_win ) call update_buffer_obj_count_0d(buffer_obj, weight) + END IF + END IF ! if mask present + END IF !if mask_variant + IF ( .NOT.is_regional .AND. .NOT.reduced_k_range )& + call update_buffer_obj_num_elements(buffer_obj, (ie-is+1)*(je-js+1)*(ke-ks+1), sample) + IF ( reduced_k_range ) & + call update_buffer_obj_num_elements(buffer_obj, (ie-is+1)*(je-js+1)*(ker-ksr+1), sample) + + + end subroutine fms_diag_time_average #endif end module fms_diag_reduction_methods_mod