diff --git a/CMakeLists.txt b/CMakeLists.txt index 719e6228dd..a986c6c5e0 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -122,6 +122,11 @@ list(APPEND fms_fortran_src_files diag_manager/diag_output.F90 diag_manager/diag_table.F90 diag_manager/diag_util.F90 + diag_manager/fms_diag_time_reduction.F90 + diag_manager/fms_diag_outfield.F90 + diag_manager/fms_diag_elem_weight_procs.F90 + diag_manager/fms_diag_fieldbuff_update.F90 + diag_manager/fms_diag_bbox.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 @@ -288,12 +293,16 @@ foreach(kind ${kinds}) target_include_directories(${libTgt}_f PRIVATE include fms + fms/include fms2_io/include + string_utils/include mpp/include + sat_vapor_pres/include + horiz_interp/include + diag_manager/include constants4 constants axis_utils/include) - target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") target_compile_definitions(${libTgt}_f PRIVATE "${${kind}_defs}") @@ -327,9 +336,13 @@ foreach(kind ${kinds}) target_include_directories(${libTgt} PUBLIC $ $ + $ $ + $ + $ + $ $ - $) + $) target_include_directories(${libTgt} INTERFACE $ diff --git a/amip_interp/include/amip_interp.inc b/amip_interp/include/amip_interp.inc index 931a16a745..98914feaa3 100644 --- a/amip_interp/include/amip_interp.inc +++ b/amip_interp/include/amip_interp.inc @@ -277,8 +277,7 @@ end interface type amip_interp_type private type (horiz_interp_type) :: Hintrp, Hintrp2 ! add by JHC - real, pointer :: data1(:,:) =>NULL(), & - data2(:,:) =>NULL() + real, allocatable :: data1(:,:), data2(:,:) type (date_type) :: Date1, Date2 logical :: use_climo, use_annual logical :: I_am_initialized=.false. @@ -1003,8 +1002,8 @@ endif !! when calling get_amip_sst and get_amip_ice. subroutine amip_interp_del (Interp) type (amip_interp_type), intent(inout) :: Interp - if(associated(Interp%data1)) deallocate(Interp%data1) - if(associated(Interp%data2)) deallocate(Interp%data2) + if(allocated(Interp%data1)) deallocate(Interp%data1) + if(allocated(Interp%data2)) deallocate(Interp%data2) if(allocated(lon_bnd)) deallocate(lon_bnd) if(allocated(lat_bnd)) deallocate(lat_bnd) call horiz_interp_del ( Interp%Hintrp ) @@ -1536,8 +1535,9 @@ subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in) endif amip_interp_out%Hintrp = amip_interp_in%Hintrp - amip_interp_out%data1 => amip_interp_in%data1 - amip_interp_out%data2 => amip_interp_in%data2 + amip_interp_out%Hintrp2 = amip_interp_in%Hintrp2 !< missing assignment statement; added by GPP + amip_interp_out%data1 = amip_interp_in%data1 + amip_interp_out%data2 = amip_interp_in%data2 amip_interp_out%Date1 = amip_interp_in%Date1 amip_interp_out%Date2 = amip_interp_in%Date2 amip_interp_out%Date1 = amip_interp_in%Date1 diff --git a/axis_utils/axis_utils2.F90 b/axis_utils/axis_utils2.F90 index 3bb4b77327..bbc7611a77 100644 --- a/axis_utils/axis_utils2.F90 +++ b/axis_utils/axis_utils2.F90 @@ -40,7 +40,7 @@ module axis_utils2_mod private integer, parameter :: maxatts = 100 - real(r8_kind), parameter :: epsln = real(1.d-10, kind=r8_kind) + real(r8_kind), parameter :: epsln = 1.e-10_r8_kind real(r8_kind), parameter :: fp5 = 0.5_r8_kind, f360 = 360.0_r8_kind !> @} diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc index fa5bd117f4..53707fcf78 100644 --- a/axis_utils/include/axis_utils2.inc +++ b/axis_utils/include/axis_utils2.inc @@ -123,7 +123,7 @@ edge_data(i) = r_var(i-1) + 0.5_lkind*(r_var(i) - r_var(i-1)) enddo edge_data(1) = r_var(1) - 0.5_lkind*(r_var(2) - r_var(1)) - if (abs(edge_data(1)) .lt. real(1.d-10, FMS_AU_KIND_)) then + if (abs(edge_data(1)) .lt. 1.e-10_lkind) then edge_data(1) = 0.0_lkind endif edge_data(n+1) = r_var(n) + 0.5_lkind*(r_var(n) - r_var(n-1)) @@ -143,12 +143,12 @@ LON_IN_RANGE_ = lon l_end = l_strt + 360.0_lkind - if (abs(LON_IN_RANGE_ - l_strt) < real(1.d-4, FMS_AU_KIND_)) then + if (abs(LON_IN_RANGE_ - l_strt) < 1.e-4_lkind) then LON_IN_RANGE_ = l_strt return endif - if (abs(LON_IN_RANGE_ - l_end) < real(1.d-4, FMS_AU_KIND_)) then + if (abs(LON_IN_RANGE_ - l_end) < 1.e-4_lkind) then LON_IN_RANGE_ = l_strt return endif @@ -223,41 +223,6 @@ return end subroutine TRANLON_ - !> nearest_index = index of nearest data point within "array" corresponding to - !! "value". - !! - !! inputs: - !! - !! value = arbitrary data...same units as elements in "array" - !! array = array of data points (must be monotonically increasing) - !! - !! output: - !! - !! nearest_index = index of nearest data point to "value" - !! if "value" is outside the domain of "array" then nearest_index = 1 - !! or "ia" depending on whether array(1) or array(ia) is - !! closest to "value" - !! - !! note: if "array" is dimensioned array(0:ia) in the calling - !! program, then the returned index should be reduced - !! by one to account for the zero base. - !! - !! example: - !! - !! let model depths be defined by the following: - !! parameter (km=5) - !! dimension z(km) - !! data z /5.0, 10.0, 50.0, 100.0, 250.0/ - !! - !! k1 = nearest_index (12.5, z, km) - !! k2 = nearest_index (0.0, z, km) - !! - !! k1 would be set to 2, and k2 would be set to 1 so that - !! z(k1) would be the nearest data point to 12.5 and z(k2) would - !! be the nearest data point to 0.0 - !! - !! @return real frac_index - function FRAC_INDEX_(value, array) @@ -293,8 +258,7 @@ do while (i <= ia .and. keep_going) i = i+1 if (value <= array(i)) then - FRAC_INDEX_ = real((i-1), FMS_AU_KIND_) + (real(value-array(i-1), FMS_AU_KIND_)) & - /(real(array(i), FMS_AU_KIND_)-real(array(i-1), FMS_AU_KIND_)) + FRAC_INDEX_ = real((i-1), lkind) + (value-array(i-1)) / (array(i) - array(i-1)) keep_going = .false. endif enddo @@ -455,7 +419,7 @@ if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') if (grid1(n) < grid2(m) ) call mpp_error(FATAL, 'grid2 lies outside grid1') -if (yp1>real(0.99d30, FMS_AU_KIND_)) then +if (yp1>0.99e30_lkind) then y2(1) = 0.0_lkind u(1) = 0.0_lkind else @@ -471,7 +435,7 @@ if (yp1>real(0.99d30, FMS_AU_KIND_)) then /(grid1(i)-grid1(i-1)))/(grid1(i+1)-grid1(i-1))-sig*u(i-1))/p enddo - if (ypn>real(.99d30, FMS_AU_KIND_)) then + if (ypn>0.99e30_lkind) then qn = 0.0_lkind un = 0.0_lkind else @@ -520,15 +484,16 @@ if (yp1>real(0.99d30, FMS_AU_KIND_)) then real(kind=FMS_AU_KIND_) :: y1, y2 character(len=32) :: interp_method integer :: k2, ks, ke + integer, parameter :: lkind = FMS_AU_KIND_ k2 = size(grid2(:)) interp_method = "linear" if(present(method)) interp_method = method - y1 = real(1.0d30, FMS_AU_KIND_) + y1 = 1.0e30_lkind if(present(yp1)) y1 = yp1 - y2 = real(1.0d30, FMS_AU_KIND_) + y2 = 1.0e30_lkind if(present(yp2)) y2 = yp2 call find_index(grid1, grid2(1), grid2(k2), ks, ke) @@ -583,6 +548,7 @@ if (yp1>real(0.99d30, FMS_AU_KIND_)) then real(kind=FMS_AU_KIND_) :: y1, y2 character(len=32) :: interp_method integer :: ks, ke + integer, parameter :: lkind = FMS_AU_KIND_ n1 = size(grid1,1) n2 = size(grid2,1) @@ -592,10 +558,10 @@ if (yp1>real(0.99d30, FMS_AU_KIND_)) then interp_method = "linear" if(present(method)) interp_method = method - y1 = real(1.0d30, FMS_AU_KIND_) + y1 = 1.0e30_lkind if(present(yp1)) y1 = yp1 - y2 = real(1.0d30, FMS_AU_KIND_) + y2 = 1.0e30_lkind if(present(yp2)) y2 = yp2 if (n1 /= n2 .or. m1 /= m2) call mpp_error(FATAL,'grid size mismatch') diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 295b4e3bb5..37759e838f 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager/include -I$(top_srcdir)/diag_manager AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -37,15 +37,33 @@ libdiag_manager_la_SOURCES = \ diag_manager.F90 \ diag_output.F90 \ diag_table.F90 \ - diag_util.F90 + diag_util.F90 \ + fms_diag_time_reduction.F90 \ + fms_diag_outfield.F90 \ + fms_diag_elem_weight_procs.F90 \ + fms_diag_fieldbuff_update.F90 \ + fms_diag_bbox.F90 \ + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh # Some mods are dependant on other mods in this dir. +diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) -diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) +diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \ + diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) +fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) +fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) +fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ - diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) + diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ + fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) + # Mod files are built and then installed as headers. MODFILES = \ @@ -55,8 +73,16 @@ MODFILES = \ diag_output_mod.$(FC_MODEXT) \ diag_util_mod.$(FC_MODEXT) \ diag_table_mod.$(FC_MODEXT) \ - diag_manager_mod.$(FC_MODEXT) -nodist_include_HEADERS = $(MODFILES) + fms_diag_time_reduction_mod.$(FC_MODEXT) \ + fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) \ + fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ + diag_manager_mod.$(FC_MODEXT) \ + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh + + nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) include $(top_srcdir)/mkmods.mk diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 486930940d..a1f5947098 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -51,6 +51,8 @@ MODULE diag_data_mod USE time_manager_mod, ONLY: time_type USE mpp_domains_mod, ONLY: domain1d, domain2d, domainUG USE fms_mod, ONLY: WARNING, write_version_number + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type + #ifdef use_netCDF ! NF90_FILL_REAL has value of 9.9692099683868690e+36. USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL @@ -115,6 +117,8 @@ MODULE diag_data_mod INTEGER, allocatable, DIMENSION(:) :: iatt !< INTEGER array to hold value of INTEGER attributes END TYPE diag_atttype + !!TODO: coord_type deserves a better name, like coord_interval_type or coord_bbox_type. + !! additionally, consider using a 2D array. !> @brief Define the region for field output !> @ingroup diag_data_mod TYPE coord_type @@ -240,7 +244,7 @@ MODULE diag_data_mod TYPE(diag_grid) :: output_grid LOGICAL :: local_output, need_compute, phys_window, written_once LOGICAL :: reduced_k_range - INTEGER :: imin, imax, jmin, jmax, kmin, kmax + TYPE(fmsDiagIbounds_type) :: buff_bounds TYPE(time_type) :: Time_of_prev_field_data TYPE(diag_atttype), allocatable, dimension(:) :: attributes INTEGER :: num_attributes @@ -327,6 +331,7 @@ MODULE diag_data_mod !! .TRUE. is only supported if the diag_manager_init !! routine is called with the optional time_init parameter. LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io + LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons. ! @@ -384,6 +389,8 @@ SUBROUTINE diag_data_init() call write_version_number("DIAG_DATA_MOD", version) END SUBROUTINE diag_data_init + + END MODULE diag_data_mod !> @} ! close documentation grouping diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index c726b109f3..92fdf0e122 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -230,12 +230,15 @@ MODULE diag_manager_mod & use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,& & max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,& & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time, diag_data_init,& - & use_mpp_io + & use_mpp_io, use_refactored_send USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND USE diag_table_mod, ONLY: parse_diag_table USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end USE constants_mod, ONLY: SECONDS_PER_DAY + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type + USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & + & fieldbuff_copy_fieldvals #ifdef use_netCDF USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR @@ -698,13 +701,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, ! only writes log if do_diag_field_log is true in the namelist (default false) ! if do_diag_field_log is true and do_not_log arg is present as well, it will only print if do_not_log = false IF ( do_diag_field_log.AND.allow_log ) THEN - axes_list='' - DO i = 1, SIZE(axes) - CALL get_diag_axis_name(axes(i),axis_name) - IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' - axes_list = TRIM(axes_list)//TRIM(axis_name) - END DO - CALL log_diag_field_info (module_name, field_name, axes, axes_list, & + CALL log_diag_field_info (module_name, field_name, axes, & & long_name, units, missing_value=missing_value, range=range, & & DYNAMIC=dynamic1) END IF @@ -1318,7 +1315,7 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT - send_data_0d = send_data_3d(diag_field_id, field_out, time, err_msg=err_msg) + send_data_0d = diag_send_data(diag_field_id, field_out, time, err_msg=err_msg) END FUNCTION send_data_0d !> @return true if send is successful @@ -1373,18 +1370,18 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN - send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_1d = send_data_3d(diag_field_id, field_out, time, mask=mask_out,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, mask=mask_out,& & weight=weight, err_msg=err_msg) END IF ELSE IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN - send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_1d = send_data_3d(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) + send_data_1d = diag_send_data(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) END IF END IF END FUNCTION send_data_1d @@ -1441,10 +1438,10 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & END IF IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN - send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1, mask=mask_out,& - & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) + send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& + & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& + send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) END IF END FUNCTION send_data_2d @@ -1461,6 +1458,33 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + if (present(mask) .and. present(rmask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, & + err_msg=err_msg) + elseif (present(rmask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + elseif (present(mask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + else + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + endif + END FUNCTION send_data_3d + !> @return true if send is successful + LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, & + & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) + INTEGER, INTENT(in) :: diag_field_id + CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field + CLASS(*), INTENT(in), OPTIONAL :: weight + TYPE (time_type), INTENT(in), OPTIONAL :: time + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + REAL :: weight1 REAL :: missvalue INTEGER :: pow_value @@ -1494,12 +1518,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field + REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask + REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! null() + rmask_ptr_r8 => null() IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) WHERE ( rmask < 0.5_r4_kind ) oor_mask = .FALSE. + rmask_threshold = 0.5_r4_kind + rmask_ptr_r4 => rmask TYPE IS (real(kind=r8_kind)) WHERE ( rmask < 0.5_r8_kind ) oor_mask = .FALSE. + rmask_threshold = 0.5_r8_kind + rmask_ptr_r8 => rmask CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_3d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1882,6 +1922,85 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF END IF + IF (USE_REFACTORED_SEND) THEN + ALLOCATE( ofield_index_cfg ) + CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, & + & hi, hj, f1, f2, f3, f4) + + ALLOCATE( ofield_cfg ) + CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num), PRESENT(mask), freq) + + IF ( average ) THEN + !!TODO (Future work): the copy that is filed_out should not be necessary + mf_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & + & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,& + & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & + & mask, weight1 ,missvalue, & + & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& + & input_fields(diag_field_id)%issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) + IF (mf_result .eqv. .FALSE.) THEN + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + ELSE !!NOT AVERAGE + mf_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_out, sample, & + & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , & + & output_fields(out_num)%count_0d(sample), & + & mask, missvalue, l_start, l_end, err_msg, err_msg_local) + IF (mf_result .eqv. .FALSE.) THEN + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + + IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN + CALL check_bounds_are_exact_static(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 + + !!TODO: (Discusssion) One of the calls below will not compile depending + !! on the value of REAL. This is to the mixed use of REAL, R4, R8 and CLASS(*) + !! in send_data_3d. A copy of rmask can be made to avoid but it would be wasteful. + !! The option used for now is that the original code to copy missing values is + !! is used at the end of this procedure. + !IF ( PRESENT(rmask) .AND. missvalue_present ) THEN + ! SELECT TYPE (rmask) + ! TYPE IS (real(kind=r4_kind)) + ! call fieldbuff_copy_missvals(ofield_cfg, ofield_index_cfg, & + ! & output_fields(out_num)%buffer, sample, & + ! & l_start, l_end, rmask_ptr_r4, rmask_threshold, missvalue) + ! TYPE IS (real(kind=r8_kind)) + ! call fieldbuff_copy_missvals(ofield_cfg, ofield_index_cfg, & + ! & output_fields(out_num)%buffer, sample, & + ! & l_start, l_end, rmask_ptr_r8, rmask_threshold, missvalue) + ! CLASS DEFAULT + ! CALL error_mesg ('diag_manager_mod::send_data_3d',& + ! & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + ! END SELECT + !END IF + + IF(ALLOCATED(ofield_index_cfg)) THEN + DEALLOCATE(ofield_index_cfg) + ENDIF + IF(ALLOCATED(ofield_cfg)) THEN + DEALLOCATE(ofield_cfg) + ENDIF + + ELSE !! END USE_REFACTORED_SEND; Don''t use CYCLE option. + ! Take care of submitted field data IF ( average ) THEN IF ( input_fields(diag_field_id)%mask_variant ) THEN @@ -3028,6 +3147,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF END IF + END IF !! END OF IS_USE_REFACTORED SEND + ! If rmask and missing value present, then insert missing value IF ( PRESENT(rmask) .AND. missvalue_present ) THEN IF ( need_compute ) THEN @@ -3125,7 +3246,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & DEALLOCATE(field_out) DEALLOCATE(oor_mask) - END FUNCTION send_data_3d + END FUNCTION diag_send_data !> @return true if send is successful LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask ) @@ -3667,7 +3788,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,& & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,& & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,& - & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io, field_log_separator + & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io, field_log_separator,& + & use_refactored_send ! If the module was already initialized do nothing IF ( module_is_initialized ) RETURN diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index ad9e9ef0ab..9956c2d9c4 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -71,17 +71,20 @@ MODULE diag_util_mod USE mpp_mod, ONLY: mpp_npes USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE USE fms2_io_mod + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type #ifdef use_netCDF USE netcdf, ONLY: NF90_CHAR #endif IMPLICIT NONE PRIVATE - PUBLIC get_subfield_size, log_diag_field_info, update_bounds, check_out_of_bounds,& - & check_bounds_are_exact_dynamic, check_bounds_are_exact_static, init_file, diag_time_inc,& + PUBLIC get_subfield_size, log_diag_field_info, init_file, diag_time_inc,& & find_input_field, init_input_field, init_output_field, diag_data_out, write_static,& & check_duplicate_output_fields, get_date_dif, get_subfield_vert_size, sync_file_times,& - & prepend_attribute, attribute_init, diag_util_init + & prepend_attribute, attribute_init, diag_util_init,& + & update_bounds, check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,& + & fms_diag_check_out_of_bounds, & + & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static !> @brief Prepend a value to a string attribute in the output field or output file. @@ -98,9 +101,14 @@ MODULE diag_util_mod MODULE PROCEDURE attribute_init_file END INTERFACE attribute_init + INTERFACE fms_diag_check_out_of_bounds + module procedure fms_diag_check_out_of_bounds_r4 + module procedure fms_diag_check_out_of_bounds_r8 + END INTERFACE fms_diag_check_out_of_bounds + + !> @addtogroup diag_util_mod !> @{ - ! Include variable "version" to be written to log file. #include @@ -624,12 +632,11 @@ END FUNCTION get_index !! code uses a do_not_log parameter in the registration calls, !! and subsequently calls this subroutine to log field information !! under a generic name. - SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_name, units,& + SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& & missing_value, range, dynamic ) CHARACTER(len=*), INTENT(in) :: module_name !< Module name CHARACTER(len=*), INTENT(in) :: field_name !< Field name INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs - CHARACTER(len=*), INTENT(in) :: axes_list !< Comma seperated list of axes names CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. @@ -643,6 +650,9 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na INTEGER :: i REAL :: missing_value_use !< Local copy of missing_value REAL, DIMENSION(2) :: range_use !< Local copy of range + CHARACTER(len=256) :: axis_name, axes_list + + IF ( .NOT.do_diag_field_log ) RETURN IF ( mpp_pe().NE.mpp_root_pe() ) RETURN ! Fatal error if range is present and its extent is not 2. @@ -715,6 +725,13 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na timeaxis = '' END IF + axes_list='' + DO i = 1, SIZE(axes) + CALL get_diag_axis_name(axes(i),axis_name) + IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' + axes_list = TRIM(axes_list)//TRIM(axis_name) + END DO + WRITE (diag_log_unit,'(777a)') & & TRIM(lmodule), field_log_separator, TRIM(lfield), field_log_separator, TRIM(lname), field_log_separator,& & TRIM(lunits), field_log_separator, TRIM(numaxis), field_log_separator, TRIM(timeaxis), field_log_separator,& @@ -722,7 +739,10 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na & TRIM(axes_list) END SUBROUTINE log_diag_field_info - !> @brief Update the output_fields x, y, and z min and max boundaries (array indices). + + + !> @brief Update the output_fields x, y, and z min and max boundaries (array indices) + !! with the six specified bounds values. SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) INTEGER, INTENT(in) :: out_num !< output field ID INTEGER, INTENT(in) :: lower_i !< Lower i bound. @@ -731,173 +751,312 @@ SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, u INTEGER, INTENT(in) :: upper_j !< Upper j bound. INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. - - output_fields(out_num)%imin = MIN(output_fields(out_num)%imin, lower_i) - output_fields(out_num)%imax = MAX(output_fields(out_num)%imax, upper_i) - output_fields(out_num)%jmin = MIN(output_fields(out_num)%jmin, lower_j) - output_fields(out_num)%jmax = MAX(output_fields(out_num)%jmax, upper_j) - output_fields(out_num)%kmin = MIN(output_fields(out_num)%kmin, lower_k) - output_fields(out_num)%kmax = MAX(output_fields(out_num)%kmax, upper_k) + CALL output_fields(out_num)%buff_bounds%update_bounds & + & ( lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) END SUBROUTINE update_bounds - !> @brief Checks if the array indices for output_fields(out_num) are outside the - !! output_fields(out_num)%buffer upper - !! and lower bounds. - SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) - INTEGER, INTENT(in) :: out_num !< Output field ID number. - INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty - !! error string indicates the x, y, and z indices are not outside the - !! buffer array boundaries. - - CHARACTER(len=128) :: error_string1, error_string2 - - IF ( output_fields(out_num)%imin < LBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%imax > UBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%jmin < LBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%jmax > UBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%kmin < LBOUND(output_fields(out_num)%buffer,3) .OR.& - & output_fields(out_num)%kmax > UBOUND(output_fields(out_num)%buffer,3) ) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin - WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax - WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin - WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax - WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin - WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax - err_msg = 'module/output_field='//TRIM(error_string1)//& - & ' Bounds of buffer exceeded. '//TRIM(error_string2) - ! imax, imin, etc need to be reset in case the program is not terminated. - output_fields(out_num)%imax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmax = 0 - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmax = 0 - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH - ELSE - err_msg = '' - END IF - END SUBROUTINE check_out_of_bounds - !> @brief Check if the array indices for output_fields(out_num) are equal to the - !! output_fields(out_num)%buffer - !! upper and lower bounds. - SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) - INTEGER, INTENT(in) :: out_num !< Output field ID number. - INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if - !! output_fields(out_num)%Time_of_prev_field_data is not - !! equal to Time or Time_zero. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. - !! An empty error string indicates the x, y, and z indices are - !! equal to the buffer array boundaries. - - CHARACTER(len=128) :: error_string1, error_string2 - LOGICAL :: do_check - - err_msg = '' + !> @brief Compares the bounding indices of an array specified in "current_bounds" +!! to the corresponding lower and upper bounds specified in "bounds" +!! Comparison is done by the two user specified input functions lowerb_comp and upperb_comp. +!! If any compariosn function returns true, then, after filling error_str, this routine also returns +!! true. The suplied comparison functions should return true for errors : for indices out of bounds, +!! or indices are not equal when expected to be equal. +LOGICAL FUNCTION compare_buffer_bounds_to_size(current_bounds, bounds, error_str, lowerb_comp, upperb_comp) + TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds ! @brief Interface lowerb_comp should be used for comparison to lower bounds of buffer. + INTERFACE + LOGICAL FUNCTION lowerb_comp(a , b) + INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other. + END FUNCTION lowerb_comp + END INTERFACE + + !> @brief Interface lowerb_comp should be used for comparison to upper bounds of buffer. + INTERFACE + LOGICAL FUNCTION upperb_comp(a, b) + INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other. + END FUNCTION upperb_comp + END INTERFACE + + compare_buffer_bounds_to_size = .FALSE. + + IF (lowerb_comp( bounds%get_imin() , current_bounds%get_imin()) .OR. & + upperb_comp( bounds%get_imax() , current_bounds%get_imax()).OR.& + lowerb_comp( bounds%get_jmin() , current_bounds%get_jmin()) .OR.& + upperb_comp( bounds%get_jmax() , current_bounds%get_jmax()) .OR.& + lowerb_comp( bounds%get_kmin() , current_bounds%get_kmin()) .OR.& + upperb_comp( bounds%get_kmax() , current_bounds%get_kmax())) THEN + compare_buffer_bounds_to_size = .TRUE. + error_str ='Buffer bounds= : , : , : Actual bounds= : , : , : ' + WRITE(error_str(15:17),'(i3)') current_bounds%get_imin() + WRITE(error_str(19:21),'(i3)') current_bounds%get_imax() + WRITE(error_str(23:25),'(i3)') current_bounds%get_jmin() + WRITE(error_str(27:29),'(i3)') current_bounds%get_jmax() + WRITE(error_str(31:33),'(i3)') current_bounds%get_kmin() + WRITE(error_str(35:37),'(i3)') current_bounds%get_kmax() + WRITE(error_str(54:56),'(i3)') bounds%get_imin() + WRITE(error_str(58:60),'(i3)') bounds%get_imax() + WRITE(error_str(62:64),'(i3)') bounds%get_jmin() + WRITE(error_str(66:68),'(i3)') bounds%get_jmax() + WRITE(error_str(70:72),'(i3)') bounds%get_kmin() + WRITE(error_str(74:76),'(i3)') bounds%get_kmax() + ELSE + compare_buffer_bounds_to_size = .FALSE. + error_str = '' + END IF +END FUNCTION compare_buffer_bounds_to_size + +!> @brief return true iff a @brief return true iff a>b. +LOGICAL FUNCTION a_greaterthan_b(a, b) + INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other. + a_greaterthan_b = A > B +END FUNCTION a_greaterthan_b + +!> @brief return true iff a /= b +LOGICAL FUNCTION a_noteq_b(a, b) +INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other. +INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other. +a_noteq_b = a /= b +END FUNCTION a_noteq_b - ! Check bounds only when the value of Time changes. When windows are used, - ! a change in Time indicates that a new loop through the windows has begun, - ! so a check of the previous loop can be done. - IF ( Time == output_fields(out_num)%Time_of_prev_field_data ) THEN - do_check = .FALSE. + !> @brief Checks if the array indices for output_fields(out_num) are outside the + !! output_fields(out_num)%buffer upper and lower bounds. + !! If there is an error then error message will be filled. +SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) + INTEGER, INTENT(in) :: out_num !< Output field ID number. + INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fmsDiagIbounds_type) :: array_bounds + associate (buff_bounds => output_fields(out_num)%buff_bounds) + + CALL array_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) + + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & + & error_string2, a_lessthan_b, a_greaterthan_b) + + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name), & + & TRIM(output_fields(out_num)%output_name) + err_msg = 'module/output_field='//TRIM(error_string1)//& + & ' Bounds of buffer exceeded. '//TRIM(error_string2) + ! imax, imin, etc need to be reset in case the program is not terminated. + call buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) ELSE - IF ( output_fields(out_num)%Time_of_prev_field_data == Time_zero ) THEN - ! It may or may not be OK to check, I don't know how to tell. - ! Check will be done on subsequent calls anyway. - do_check = .FALSE. - ELSE - do_check = .TRUE. - END IF - output_fields(out_num)%Time_of_prev_field_data = Time - END IF - - IF ( do_check ) THEN - IF ( output_fields(out_num)%imin /= LBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%imax /= UBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%jmin /= LBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%jmax /= UBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%kmin /= LBOUND(output_fields(out_num)%buffer,3) .OR.& - & output_fields(out_num)%kmax /= UBOUND(output_fields(out_num)%buffer,3) ) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin - WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax - WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin - WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax - WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin - WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax - err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) - END IF - output_fields(out_num)%imax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmax = 0 - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmax = 0 - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH - END IF - END SUBROUTINE check_bounds_are_exact_dynamic + err_msg = '' + END IF + end associate +END SUBROUTINE check_out_of_bounds + + !> @brief Checks if the array indices for output_fields(out_num) are outside the + !! output_fields(out_num)%buffer upper and lower bounds. + !! If there is an error then error message will be filled. +SUBROUTINE fms_diag_check_out_of_bounds_r4(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message + CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fmsDiagIbounds_type) :: array_bounds + + CALL array_bounds%reset_bounds_from_array_5D(ofb) + + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, bounds, & + & error_string2, a_lessthan_b, a_greaterthan_b) + + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + err_msg = 'module/output_field='//TRIM(error_string1)//& + & ' Bounds of buffer exceeded. '//TRIM(error_string2) + ! imax, imin, etc need to be reset in case the program is not terminated. + call bounds%reset(VERY_LARGE_AXIS_LENGTH,0) + ELSE + err_msg = '' + END IF +END SUBROUTINE fms_diag_check_out_of_bounds_r4 + + !> @brief Checks if the array indices for output_field buffer (ofb) are outside the + !! are outside the bounding box (bounds). + !! If there is an error then error message will be filled. + +SUBROUTINE fms_diag_check_out_of_bounds_r8(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fmsDiagIbounds_type) :: array_bounds ! @brief Checks that array indices specified in the bounding box "current_bounds" +!! are identical to those in the bounding box "bounds" match exactly. The check +!! occurs only when the time changed. +!! If there is an error then error message will be filled. +SUBROUTINE fms_diag_check_bounds_are_exact_dynamic(current_bounds, bounds, output_name, module_name, & + & Time, field_prev_Time, err_msg) + TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds !output_fields(out_num)%Time_of_prev_field_data is not + !! equal to Time or Time_zero. + TYPE(time_type), INTENT(inout) :: field_prev_Time !< output_fields(out_num)%Time_of_prev_field_data + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + !! An empty error string indicates the x, y, and z indices are + !! equal to the buffer array boundaries. + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: do_check + LOGICAL :: lims_not_exact + + err_msg = '' + + ! Check bounds only when the value of Time changes. When windows are used, + ! a change in Time indicates that a new loop through the windows has begun, + ! so a check of the previous loop can be done. + IF ( Time == field_prev_Time ) THEN + do_check = .FALSE. + ELSE + IF ( field_prev_Time == Time_zero ) THEN + ! It may or may not be OK to check, I don't know how to tell. + ! Check will be done on subsequent calls anyway. + do_check = .FALSE. + ELSE + do_check = .TRUE. + END IF + field_prev_Time = Time + END IF + + IF ( do_check ) THEN + lims_not_exact = compare_buffer_bounds_to_size(current_bounds, bounds, & + & error_string2, a_noteq_b, a_noteq_b) + IF( lims_not_exact .eqv. .TRUE.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) + END IF + call bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) + END IF +END SUBROUTINE fms_diag_check_bounds_are_exact_dynamic + + +!> @brief This is an adaptor to the check_bounds_are_exact_dynamic_modern function to +!! maintain an interface servicing the legacy diag_manager. +SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) + INTEGER, INTENT(in) :: out_num !< Output field ID number. + INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. + TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if + !! output_fields(out_num)%Time_of_prev_field_data is not + !! equal to Time or Time_zero. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + !! An empty error string indicates the x, y, and z indices are + !! equal to the buffer array boundaries. + CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE :: module_name !< module name for placing in error message + TYPE (fmsDiagIbounds_type) :: current_bounds !< a bounding box to store the current bounds of the array. + + output_name = output_fields(out_num)%output_name + module_name = input_fields(diag_field_id)%module_name + + CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) + + CALL fms_diag_check_bounds_are_exact_dynamic(current_bounds, output_fields(out_num)%buff_bounds, & + & output_name, module_name, & + & Time, output_fields(out_num)%Time_of_prev_field_data, err_msg) + +END SUBROUTINE check_bounds_are_exact_dynamic + !> @brief Check if the array indices for output_fields(out_num) are equal to the - !! output_fields(out_num)%buffer - !! upper and lower bounds. + !! output_fields(out_num)%buffer upper and lower bounds. SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID INTEGER, INTENT(in) :: diag_field_id !< Input field ID. - CHARACTER(len=*), INTENT(out) :: err_msg + CHARACTER(len=*), INTENT(out) :: err_msg !< The return status, which is set to non-empty message + !! if the check fails. + CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE :: module_name !< output name for placing in error message + TYPE (fmsDiagIbounds_type) :: current_bounds !< a bounding box to store the current bounds of the array. + + output_name = output_fields(out_num)%output_name + module_name = input_fields(diag_field_id)%module_name + + CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) + + CALL fms_diag_check_bounds_are_exact_static(current_bounds, output_fields(out_num)%buff_bounds, & + & output_name, module_name, err_msg) + END SUBROUTINE check_bounds_are_exact_static + + + !> @brief Check if the array indices specified in the bounding box "current_bounds" are equal to those + !! specified in the bounding box "bounds" output_fields are equal to the buffer upper and lower bounds. + !! If there is an error then error message will be filled. + SUBROUTINE fms_diag_check_bounds_are_exact_static(current_bounds, bounds, output_name, module_name, err_msg) + TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds ! @brief Initialize the output file. SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_name, tile_count,& @@ -1382,12 +1541,8 @@ SUBROUTINE init_output_field(module_name, field_name, output_name, output_file,& output_fields(out_num)%num_axes = 0 output_fields(out_num)%total_elements = 0 output_fields(out_num)%region_elements = 0 - output_fields(out_num)%imax = 0 - output_fields(out_num)%jmax = 0 - output_fields(out_num)%kmax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH + + call output_fields(out_num)%buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) ! initialize the size of the diurnal axis to 1 output_fields(out_num)%n_diurnal_samples = 1 diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 new file mode 100644 index 0000000000..7fa331258a --- /dev/null +++ b/diag_manager/fms_diag_bbox.F90 @@ -0,0 +1,167 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_bbox_mod fms_diag_bbox_mod +!> @ingroup diag_manager +!> @brief fms_diag_bbox_mod defines classes encapsulating bounding boxes +!! and interval bounds. +!! +!> @author Miguel Zuniga +!! +!> @file +!> @brief File for @ref fms_diag_bbox_mod +!> @addtogroup fms_diag_bbox_mod +!> @{ +MODULE fms_diag_bbox_mod + + USE fms_mod, ONLY: error_mesg, FATAL + + implicit none + +!> @brief Data structure holding a 3D bounding box. It is commonlyused to +!! represent the interval bounds or limits of a 3D sub-array such as the +!! array index bounds of the spatial component a diag_manager field output +!! buffer array. + TYPE, public :: fmsDiagIbounds_type + PRIVATE + INTEGER :: imin !< Lower i bound. + INTEGER :: imax !< Upper i bound. + INTEGER :: jmin !< Lower j bound. + INTEGER :: jmax !< Upper j bound. + INTEGER :: kmin !< Lower k bound. + INTEGER :: kmax !< Upper k bound. + contains + procedure :: reset => reset_bounds + procedure :: reset_bounds_from_array_4D + procedure :: reset_bounds_from_array_5D + procedure :: update_bounds + procedure :: get_imin + procedure :: get_imax + procedure :: get_jmin + procedure :: get_jmax + procedure :: get_kmin + procedure :: get_kmax + END TYPE fmsDiagIbounds_type + +CONTAINS + + !> @brief Gets imin of fmsDiagIbounds_type + !! @return copy of integer member imin + pure integer function get_imin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%imin + end function get_imin + + !> @brief Gets imax of fmsDiagIbounds_type + !! @return copy of integer member imax + pure integer function get_imax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%imax + end function get_imax + + !> @brief Gets jmin of fmsDiagIbounds_type + !! @return copy of integer member jmin + pure integer function get_jmin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%jmin + end function get_jmin + + !> @brief Gets jmax of fmsDiagIbounds_type + !! @return copy of integer member jmax + pure integer function get_jmax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%jmax + end function get_jmax + + + !> @brief Gets kmin of fmsDiagIbounds_type + !! @return copy of integer member kmin + pure integer function get_kmin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%kmin + end function get_kmin + + !> @brief Gets kmax of fmsDiagIbounds_type + !! @return copy of integer member kmax + pure integer function get_kmax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%kmax + end function get_kmax + + !> @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 + integer, intent(in) :: lower_val !< value for the lower bounds in each dimension + integer, intent(in) :: upper_val !< value for the upper bounds in each dimension + this%imin = lower_val + this%jmin = lower_val + this%kmin = lower_val + this%imax = upper_val + this%jmax = upper_val + this%kmax = upper_val + END SUBROUTINE reset_bounds + + !> @brief Update the the first three (normally x, y, and z) min and + !! max boundaries (array indices) of the instance bounding box + !! the six specified bounds values. + SUBROUTINE update_bounds(this, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) + CLASS (fmsDiagIbounds_type), intent(inout) :: this ! @brief Reset the instance bounding box with the bounds determined from the + !! first three dimensions of the 5D "array" argument + SUBROUTINE reset_bounds_from_array_4D(this, array) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. + REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. + this%imin = LBOUND(array,1) + this%imax = UBOUND(array,1) + this%jmin = LBOUND(array,2) + this%jmax = UBOUND(array,2) + this%kmin = LBOUND(array,3) + this%kmax = UBOUND(array,3) + END SUBROUTINE reset_bounds_from_array_4D + + !> @brief Reset the instance bounding box with the bounds determined from the + !! first three dimensions of the 5D "array" argument + SUBROUTINE reset_bounds_from_array_5D(this, array) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. + CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 5D input array. + this%imin = LBOUND(array,1) + this%imax = UBOUND(array,1) + this%jmin = LBOUND(array,2) + this%jmax = UBOUND(array,2) + this%kmin = LBOUND(array,3) + this%kmax = UBOUND(array,3) + END SUBROUTINE reset_bounds_from_array_5D + + END MODULE fms_diag_bbox_mod + !> @} + ! close documentation grouping diff --git a/diag_manager/fms_diag_elem_weight_procs.F90 b/diag_manager/fms_diag_elem_weight_procs.F90 new file mode 100644 index 0000000000..0a07d47327 --- /dev/null +++ b/diag_manager/fms_diag_elem_weight_procs.F90 @@ -0,0 +1,136 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_elem_weight_procs_mod fms_diag_elem_weight_procs_mod +!> @ingroup diag_manager +!> @brief fms_diag_elem_weight_procs_mod Contains elemental functions for uddating +!! one element of a buffer array with field data. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_elem_weight_procs_mod Contains elemental functions for uddating +!! one element of a buffer array with field data, +!! +!> @file +!> @brief File for @ref fms_diag_elem_weight_procs_mod +!> @addtogroup fms_diag_elem_weight_procs_mod +!> @{ +MODULE fms_diag_elem_weight_procs_mod + USE platform_mod + + implicit none + + !> @brief Interface for the elemental function addwf, which + !! Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !> @ingroup fms_diag_elem_weight_procs_mod + INTERFACE addwf + module procedure addwf_r4 + module procedure addwf_r8 + module procedure addwf_i4 + module procedure addwf_i8 + END INTERFACE + +CONTAINS + + !!TODO: Note that in the functions below, the case for pow_value == 2 was + !! not in the original send_data_3d code and the power function was used. + !! So this case may need to be deleted if reproducability is an issue. + + !!TODO: (MDM) Discuss whether or not the pow_value should be allowed to + !! also be real though legacy interface has it satic. + + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. + ELEMENTAL REAL(r4_kind) FUNCTION addwf_r4(buff, field, weight, pow_value ) + REAL(r4_kind), INTENT(in) :: buff !< The buffer cell (point) value + REAL(r4_kind), INTENT(IN) :: field !< The field value + REAL(r4_kind), INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function + + SELECT CASE(pow_value) + CASE (1) + addwf_r4 = buff + weight * field + CASE (2) + addwf_r4 = buff + (weight * field) * (weight * field) + CASE default + addwf_r4 = buff + (weight * field) ** pow_value + END SELECT + END FUNCTION addwf_r4 + + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. + ELEMENTAL REAL(r8_kind) FUNCTION addwf_r8(buff, field, weight, pow_value ) + REAL(r8_kind), INTENT(in) :: buff !< The buffer cell (point) value + REAL(r8_kind) ,INTENT(IN) :: field !< The field value + REAL(r8_kind), INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function + + SELECT CASE(pow_value) + CASE (1) + addwf_r8 = buff + weight * field + CASE (2) + addwf_r8 = buff + (weight * field) * (weight * field) + CASE default + addwf_r8 = buff + (weight * field) ** pow_value + END SELECT + END FUNCTION addwf_r8 + + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. + ELEMENTAL INTEGER(i4_kind) FUNCTION addwf_i4(buff, field, weight, pow_value ) + INTEGER(i4_kind), INTENT(in) :: buff !< The buffer cell (point) value + INTEGER(i4_kind), INTENT(IN) :: field !< The field value + INTEGER, INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function + SELECT CASE(pow_value) + CASE (1) + addwf_i4 = buff + weight * field + CASE (2) + addwf_i4 = buff + (weight * field) * (weight * field) + CASE default + addwf_i4 = buff + (weight * field) ** pow_value + END SELECT + END FUNCTION addwf_i4 + + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. + ELEMENTAL INTEGER(i8_kind) FUNCTION addwf_i8(buff, field, weight, pow_value ) + INTEGER(i8_kind), INTENT(in) :: buff !< The buffer cell (point) value + INTEGER(i8_kind) ,INTENT(IN) :: field !< The field value + INTEGER, INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function + + SELECT CASE(pow_value) + CASE (1) + addwf_i8 = buff + weight * field + CASE (2) + addwf_i8 = buff + (weight * field) * (weight * field) + CASE default + addwf_i8 = buff + (weight * field) ** pow_value + END SELECT + END FUNCTION addwf_i8 +END MODULE fms_diag_elem_weight_procs_mod +!> @} +! close documentation grouping + diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 new file mode 100644 index 0000000000..0e3783dcef --- /dev/null +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -0,0 +1,110 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_fieldbuff_update_mod fms_diag_fieldbuff_update_mod +!> @ingroup diag_manager +!> @brief fms_diag_fieldbuff_update_mod Contains routines for updating the +!! buffer (array) of field data statistics (e.g. average, rms) with new field data. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_fieldbuff_update_mod contains routines for updating the buffer +!!(array) of field data statistics (e.g. average, rms) with new field data. These +!! routines are called by the send_data routines in the diag_manager. +!! +!> @file +!> @brief File for @ref fms_diag_fieldbuff_update_mod +!> @addtogroup fms_diag_fieldbuff_update_mod +!> @{ +MODULE fms_diag_fieldbuff_update_mod + USE platform_mod + USE mpp_mod, ONLY: mpp_pe, mpp_root_pe + USE time_manager_mod, ONLY: time_type + USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,fms_error_handler + USE diag_data_mod, ONLY: debug_diag_manager + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type + USE diag_util_mod, ONLY: fms_diag_check_out_of_bounds + USE fms_diag_time_reduction_mod, ONLY: fmsDiagTimeReduction_type + USE fms_diag_elem_weight_procs_mod, ONLY: addwf + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type + + implicit none + + !!TODO: (MDM) Remove commented integer versions. + + !> @brief Interface fieldbuff_update updates elements of field output buffer based on input field + !! data and mathematical operations on the field data. + !> @ingroup fms_diag_fieldbuff_update_mod + interface fieldbuff_update + !< r4 version of the interface + module procedure fieldbuff_update_r4 + !< r8 version of the interface + module procedure fieldbuff_update_r8 + !< r4 version of the interface, where the field is 3D + module procedure fieldbuff_update_3d_r4 + !< r8 version of the interface + module procedure fieldbuff_update_3d_r8 + !< i4 version of the interface, , where the field is 3D + !module procedure fieldbuff_update_i4 + !< i8 version of the interface + ! module procedure fieldbuff_update_i8 + end interface + + !> @brief Interface fieldbuff_copy_missvals updates elements of the field output buffer with + !! the missvalue input argument. + !> @ingroup fms_diag_fieldbuff_update_mod + interface fieldbuff_copy_missvals + !< r4 version of the interface + module procedure fieldbuff_copy_missvals_r4 + !< r8 version of the interface + module procedure fieldbuff_copy_missvals_r8 + !< r4 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_missvals_3d_r4 + !< r8 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_missvals_3d_r8 + !< i4 version of the interface + !module procedure fieldbuff_copy_missvals_i4 + !< i8 version of the interface + !module procedure fieldbuff_copy_missvals_i8 + end interface + + !> @brief Interface fieldbuff_copy_fieldvals updates elements of the field output buffer with + !! copies of corresponding element values in the input field data. + !> @ingroup fms_diag_fieldbuff_update_mod + interface fieldbuff_copy_fieldvals + !< r4 version of the interface + module procedure fieldbuff_copy_fieldvals_r4 + !< r8 version of the interface + module procedure fieldbuff_copy_fieldvals_r8 + !< r4 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_fieldvals_3d_r4 + !< r8 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_fieldvals_3d_r8 + !< i4 version of the interface + !module procedure fieldbuff_copy_fieldvals_i4 + !< i8 version of the interface + !module procedure fieldbuff_copy_fieldvals_i8 + end interface +contains + +#include "fms_diag_fieldbuff_update.inc" + +END MODULE fms_diag_fieldbuff_update_mod +!> @} +! close documentation grouping diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 new file mode 100644 index 0000000000..88c07880cc --- /dev/null +++ b/diag_manager/fms_diag_outfield.F90 @@ -0,0 +1,450 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_outfield_mod fms_diag_outfield_mod +!> @ingroup diag_manager +!> @brief fms_diag_outfield_mod defines data types and utility or auxiliary routines +!! useful in updating the output buffer. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_outfield_mod The output buffer updating routines are passed configuration +!! and control data with types defined in this module; and some utility functions called by the +!! updating routines are +!! defined here. +!! +!> @file +!> @brief File for @ref fms_diag_outfield_mod +!> @addtogroup fms_diag_outfield_mod +!> @{ +MODULE fms_diag_outfield_mod + USE platform_mod + USE mpp_mod, only :FATAL, WARNING + USE fms_mod, only :lowercase, uppercase, error_mesg, fms_error_handler + + + !! TODO: these might need removal or replacement + USE diag_data_mod, only:Time_zero + USE diag_data_mod, only: GLO_REG_VAL, GLO_REG_VAL_ALT, region_out_use_alt_value, VERY_LARGE_AXIS_LENGTH, coord_type + USE diag_data_mod, only: fmsDiagIbounds_type, input_field_type, output_field_type + USE fms_diag_time_reduction_mod, only: fmsDiagTimeReduction_type, time_none , time_average, time_rms + USE fms_diag_time_reduction_mod, only: time_max, time_min, time_sum, time_power + + implicit none + + !> @brief Class fmsDiagOutfield_type (along with class ms_diag_outfield_index_type ) + !! contain information used in updating the output buffers by the diag_manager + !! send_data routines. In some sense they can be seen as encapsulating related + !! information in a convenient way (e.g. to pass to functions and for do loop + !! controls.) + !! + !! Class fmsDiagOutfield_type also contains a significant subset of the fields + !! and routines of of the legacy class output_field_type + !! TODO: (MDM) This class will need further development for the modern_diag effort. + !! For its development, consider the legacy diag_util::init_output_field already + !! in place. Fields added so are used the the field buffer math/dmUpdate functions. + !! TODO (MDM) : Should the MDM have pow_value be type REAL? + !> @ingroup fms_diag_outfield_mod + TYPE, public :: fmsDiagOutfield_type + PRIVATE + CHARACTER(len=:), ALLOCATABLE :: module_name !< Module name. + CHARACTER(len=:), ALLOCATABLE :: field_name !< Output field name. + CHARACTER(len=:), ALLOCATABLE :: output_name !< Output name written to file. + CHARACTER(len=:), ALLOCATABLE :: output_file !< File where field should be written. + + !!Major outer loop controls in send_data functions. + INTEGER :: pow_value !< Power value for rms or pow(x) calculations + LOGICAL :: phys_window !< TODO: Rename? OMP subsetted data, See output_fields + LOGICAL :: need_compute !< True iff is local_output and current PE take part in send_data. + LOGICAL :: reduced_k_range !< If true, the local start and end indecies are used in k (i.e. 3rd) dim. + LOGICAL :: missvalue_present !< + LOGICAL :: mask_variant + LOGICAL :: mask_present !< True iff mask argument is present in user-facing send function call. + !< Note this field exists since the actual mask argument in the send + !< function call may be downstream replaced by a null pointer which + !< is considered present. + + TYPE(fmsDiagTimeReduction_type) :: time_reduction !< Instance of the fmsDiagTimeTeduction_type. + + !!TODO (Future effort? ) : a pointer for time_min and time_max comparison function + !! If possible, this can remove the innermost if/then/else construct in the buffer update loops. + !! min_max_f_ptr => (should point to < or > operators) + + !! gcc error: Interface ‘addwf’ at (1) must be explicit + ! procedure (addwf), pointer, nopass :: f_ptr => null () !!A pointer to the field weighing procedure + + CONTAINS + procedure :: get_module_name + procedure :: get_field_name + procedure :: get_output_name + procedure :: get_output_file + procedure :: get_pow_value + procedure :: get_phys_window + procedure :: get_need_compute + procedure :: get_reduced_k_range + procedure :: get_missvalue_present + procedure :: get_mask_variant + procedure :: get_mask_present + procedure :: get_time_reduction + procedure, public :: initialize => initialize_outfield_imp + procedure :: initialize_for_ut + + END TYPE fmsDiagOutfield_type + + !> @brief Class fms_diag_outfield_index_type which (along with class fmsDiagOutfield_type) + !! encapsulate related information used in updating the output buffers by the diag_manager + !! send_data routines. This class in particular focuses on do loop index controls or settings. + !! Note that the index names in this class should be indentical to the names used in the + !! diag_manager send_data functions and in the "math" buffer update functions. The purpose + !! of this class is also to allow for a smaller call function signature for the math/buffer + !! update functions. + !> @ingroup fms_diag_outfield_mod + TYPE, public :: fmsDiagOutfieldIndex_type + PRIVATE + INTEGER :: f1,f2 !< Indecies used specify 1st dim bounds of field, mask and rmask. + INTEGER :: f3,f4 !< Indecies used specify 2st dim bounds of field, mask and rmask. + INTEGER :: is, js, ks !< Start indecies in each spatial dim of the field_data; and + !! may be user provided in send_data + Integer :: ie, je, ke !< End indecies in each spatial dim of the field_data; and + !! may be user provided in send_data + INTEGER :: hi !< halo size in x direction. Same name as in send_data + INTEGER :: hj !< halo size in y direction. Same + CONTAINS + procedure :: initialize => initialize_outfield_index_type + procedure :: get_f1 + procedure :: get_f2 + procedure :: get_f3 + procedure :: get_f4 + procedure :: get_is + procedure :: get_js + procedure :: get_ks + procedure :: get_ie + procedure :: get_je + procedure :: get_ke + procedure :: get_hi + procedure :: get_hj + END TYPE fmsDiagOutfieldIndex_type + +CONTAINS + + !> @brief Gets module_name + !! @return copy of the module_name character array + pure function get_module_name (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%module_name + end function get_module_name + + !> @brief Gets field_name + !! @return copy of the field_name character array + pure function get_field_name (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%field_name + end function get_field_name + + !> @brief Gets output_name + !! @return copy of the output_name character array + pure function get_output_name (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%output_name + end function get_output_name + + !> @brief Gets output_file + !! @return copy of the output_file character array + pure function get_output_file (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%output_file + end function get_output_file + + !> @brief Gets pow_value + !! @return copy of integer member pow_value + pure integer function get_pow_value (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%pow_value + end function get_pow_value + + !> @brief Gets phys_window + !! @return copy of integer member phys_window + pure logical function get_phys_window (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%phys_window + end function get_phys_window + + !> @brief Gets need_compute + !! @return copy of integer member need_compute + pure logical function get_need_compute (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%need_compute + end function get_need_compute + + !> @brief Gets reduced_k_range + !! @return copy of integer member reduced_k_range + pure logical function get_reduced_k_range (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%reduced_k_range + end function get_reduced_k_range + + !> @brief Gets missvalue_present + !! @return copy of integer member missvalue_present + pure logical function get_missvalue_present (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%missvalue_present + end function get_missvalue_present + + !> @brief Gets mask_variant + !! @return copy of integer member mask_variant + pure logical function get_mask_variant (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%mask_variant + end function get_mask_variant + + !> @brief Gets mask_present + !! @return copy of integer member mask_present + pure logical function get_mask_present (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%mask_present + end function get_mask_present + + !> @brief Gets the time_reduction object + !! @return copy of the memeber object time_reduction + function get_time_reduction (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + TYPE(fmsDiagTimeReduction_type), allocatable :: rslt + allocate( rslt ) + call rslt%copy(this%time_reduction) + end function get_time_reduction + + !> @brief Gets f1 + !! @return copy of integer member f1 + pure integer function get_f1 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f1 + end function get_f1 + + !> @brief Gets f2 + !! @return copy of integer member f2 + pure integer function get_f2 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f2 + end function get_f2 + + !> @brief Gets f3 + !! @return copy of integer member f3 + pure integer function get_f3 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f3 + end function get_f3 + + !> @brief Gets f4 + !! @return copy of integer member f4 + pure integer function get_f4 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f4 + end function get_f4 + + !> @brief Gets is + !! @return copy of integer member is + pure integer function get_is (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%is + end function get_is + + !> @brief Gets js + !! @return copy of integer member js + pure integer function get_js (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%js + end function get_js + + !> @brief Gets ks + !! @return copy of integer member ks + pure integer function get_ks (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%ks + end function get_ks + + !> @brief Gets ie + !! @return copy of integer member ie + pure integer function get_ie (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%ie + end function get_ie + + !> @brief Gets je + !! @return copy of integer member je + pure integer function get_je (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%je + end function get_je + + !> @brief Gets ke + !! @return copy of integer member ke + pure integer function get_ke (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%ke + end function get_ke + + !> @brief Gets hi + !! @return copy of integer member hi + pure integer function get_hi (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%hi + end function get_hi + + !> @brief Gets hj + !! @return copy of integer member hj + pure integer function get_hj (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%hj + end function get_hj + + + !> #brief initialize all the members of the class. + SUBROUTINE initialize_outfield_index_type(this, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + CLASS(fmsDiagOutfieldIndex_type), INTENT(inout) :: this + INTEGER, INTENT(in) :: is, js, ks !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: ie, je, ke !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: hi, hj !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: f1, f2, f3, f4 !< Variable used to update class member of same names. + + this%is = is + this%js = js + this%ks = ks + this%ie = ie + this%je = je + this%ke = ke + + this%hi = hi + this%hj = hj + + this%f1 = f1 + this%f2 = f2 + this%f3 = f3 + this%f4 = f4 + END SUBROUTINE initialize_outfield_index_type + + + !> @brief Update the fmsDiagOutfield_type instance with those fields used in the legacy diag manager. + !! Note that this is initializing from the legacy structures. + !! Note that output_frequency came from file_type; + SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_present, freq) + CLASS(fmsDiagOutfield_type), INTENT(inout) :: this !< An instance of the fmsDiagOutfield_type + TYPE(input_field_type), INTENT(in) :: input_field !< An instance of the input_field_type + TYPE(output_field_type), INTENT(in) :: output_field !< An instance of the output_field_type + LOGICAL, INTENT(in) :: mask_present !< Was the mask present in the call to send_data? + INTEGER, INTENT(in) :: freq !< The output frequency. + INTEGER :: time_redux !< The time reduction type integer. + + this%module_name = input_field%module_name + this%field_name = input_field%field_name + this%output_name = output_field%output_name + + this%pow_value = output_field%pow_value + this%phys_window = output_field%phys_window + this%need_compute = output_field%need_compute + this%reduced_k_range = output_field%reduced_k_range + this%mask_variant = input_field%mask_variant + !!Note: in legacy diag manager, presence of missing value vs presence of mask + !! is determined in different ways (diag table vs send function call) + this%missvalue_present = input_field%missing_value_present + this%mask_present = mask_present + + time_redux = get_output_field_time_reduction (output_field) + call this%time_reduction%initialize( time_redux , freq) + + !!TODO: the time_min and time_max buffer update code is almost the exact same src code, except + !! for the compariosn function. Simplify code and set comparison function: + !!TODO: If possible add to the power function. See issue with pointers and elemental functions + + END SUBROUTINE initialize_outfield_imp + + !> @brief Initialized an fmsDiagOutfield_type as needed for unit tests. + subroutine initialize_for_ut(this, module_name, field_name, output_name, & + & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & + & time_reduction_type,output_freq) + CLASS(fmsDiagOutfield_type), intent(inout) :: this + CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fmsDiagOutfield_type + CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fmsDiagOutfield_type + CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: power_val !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: phys_window !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: need_compute !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: num_elems !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type + + this%module_name = module_name + this%field_name = field_name + this%output_name = output_name + this%pow_value = power_val + this%phys_window = phys_window + this%need_compute = need_compute + this%reduced_k_range = reduced_k_range + this%mask_variant = mask_variant + call this%time_reduction%initialize(time_reduction_type, output_freq) + end subroutine initialize_for_ut + + !> @brief Reset the time reduction member field. Intended for use in unit tests only. + SUBROUTINE reset_time_reduction_ut(this, source ) + CLASS(fmsDiagOutfield_type), INTENT(inout) :: this !< An instance of the fmsDiagOutfield_type + TYPE(fmsDiagTimeReduction_type) :: source !< The fmsDiagTimeReduction_type to copy from + call this%time_reduction%copy(source) + END SUBROUTINE reset_time_reduction_ut + + + + !> \brief Get the time reduction from a legacy output field. + !\note Note we do not place this in the time_reduction class to avoid circular dependencies. + function get_output_field_time_reduction(ofield) result (rslt) + TYPE(output_field_type), INTENT(in) :: ofield !< An instance of the output_field_type + INTEGER :: rslt !< The result integer which is the time reduction. + if(ofield%time_max) then + rslt = time_max + elseif(ofield%time_min)then + rslt = time_min + else if (ofield%time_sum) then + rslt = time_sum + else if (ofield%time_rms) then + rslt = time_rms + else if (ofield%time_average) then + rslt = time_average + else + rslt = time_none + !if(.NOT. ofield%static) then + !!TODO: Set error to FATAL. When legacy diag_manager is removed? + ! CALL error_mesg('fms_diag_outfield:get_output_field_time_reduction', & + ! & 'result is time_none but out_field%static is not true', WARNING) + !end if + endif + end function get_output_field_time_reduction + +END MODULE fms_diag_outfield_mod +!> @} +! close documentation grouping + + diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 new file mode 100644 index 0000000000..78de19a25a --- /dev/null +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -0,0 +1,227 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_time_reduction_mod fms_diag_time_reduction_mod +!> @ingroup diag_manager +!> @brief fms_diag_time_reduction_mod defines classes encapsulating the diag_manager +!! time redution types. +!! +!> @author Miguel Zuniga +!! +!> @file +!> @brief File for @ref fms_diag_time_reduction_mod +!> @addtogroup fms_diag_time_reduction_mod +!> @{ +MODULE fms_diag_time_reduction_mod + + USE diag_data_mod, only: EVERY_TIME + USE fms_mod, ONLY: error_mesg, FATAL + + implicit none + + !!TODO: (Future effort) Note that time_diurnal processing is a little different + !! and more complex than the other reduction methods, and therefore refactoring its + !! processing may simplify the overall related codebase. The refactoring, + !! if possible, may be done elsewhere in the diag_manager. + + !!These parametes are the possible kinds of time reduction operations. + INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method + INTEGER, PARAMETER :: time_average = 1 !< The reduction method is average + INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms + INTEGER, PARAMETER :: time_max = 3 !< The reduction method is max + INTEGER, PARAMETER :: time_min = 4 !< The reduction method is min + INTEGER, PARAMETER :: time_sum = 5 !< The reudction method is sum + INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal + INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power + + !> @brief Class fmsDiagTimeReduction_type has an encapsulation of the "Fortran enum" time + !! reduction integer parameters, plus an encapsulation of the groupings of + !! the time reduction types. It is intended to provide some of the functionality + !! that was coded in the legacy function diag_data.F90:init_output_fields. + !! The functionality in the end is used by send_data in (EFFICIENT) do loops calling + !! the weighting or math functions to update buffers. + !! The integer parameters above are the legal time reduction types, + !! but they are not necessarily mutually exclusive in some contexts. + !! + !> @addtogroup fms_diag_time_reduction_mod + TYPE fmsDiagTimeReduction_type + integer , private :: the_time_reduction !< The time reduction type, as an integer defined above. + logical , private :: time_averaging !< Set true iff time_average, time_rms, time_power or time_diurnal is true + logical , private :: time_ops !< Set true iff time_min, time_max, time_rms or time_average is true. + CONTAINS + procedure, public :: do_time_averaging => do_time_averaging_imp + procedure, public :: has_time_ops => has_time_ops_imp + procedure, public :: is_time_none => is_time_none_imp + procedure, public :: is_time_average => is_time_average_imp + procedure, public :: is_time_rms => is_time_rms_imp + procedure, public :: is_time_max => is_time_max_imp + procedure, public :: is_time_min => is_time_min_imp + procedure, public :: is_time_sum => is_time_sum_imp + procedure, public :: is_time_diurnal => is_time_diurnal_imp + procedure, public :: is_time_power => is_time_power_imp + procedure, public :: initialize + procedure, public :: copy + END TYPE fmsDiagTimeReduction_type + + !> @brief This interface is for the class constructor. + !> @addtogroup fms_diag_time_reduction_mod + interface fmsDiagTimeReduction_type + procedure :: fmsDiagTimeReduction_type_constructor + end interface fmsDiagTimeReduction_type + +CONTAINS + + !> @brief The class contructors. Just allocates the class and calls an initializer + !! @return An allocated instance of fmsDiagTimeReduction_type, which is nitialized using + !! provided values for arguments dt and out_freqeuncy. + function fmsDiagTimeReduction_type_constructor(dt, out_frequency) result(time_redux) + integer, intent(in) :: dt !< The redution type (time_rms, time_power, etc) + integer, intent(in) :: out_frequency !< The output frequency. + class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type + !!class allocated and returned by this constructor. + allocate(time_redux) + call time_redux%initialize(dt, out_frequency) + end function fmsDiagTimeReduction_type_constructor + + !> @brief Initialize the object. As an alternative to the constructor, one can + !! allocate an fmsDiagTimeReduction_type instance, then call its initialize function. + subroutine initialize(this, dt, out_frequency) + class (fmsDiagTimeReduction_type), intent(inout) :: this !< The fmsDiagTimeReduction_type object + integer, intent(in) :: dt !< The redution type (time_rms, time_porer, etc) + integer, intent(in) :: out_frequency !< The output frequency. + + this%the_time_reduction = dt + + !! Set the time_averaging flag + !! See legacy init_ouput_fields function, lines 1470ff + IF(( dt .EQ. time_average) .OR. (dt .EQ. time_rms) .OR. (dt .EQ. time_power) .OR. & + & (dt .EQ. time_diurnal)) THEN + this%time_averaging = .true. + ELSE + this%time_averaging= .false. + IF((dt .NE. time_max) .AND. (dt .ne. time_min) .AND. (dt .NE. time_sum) & + & .AND. (dt .NE. time_none)) THEN + CALL error_mesg('fmsDiagTimeReduction_type: initialize', & + & 'time_averaging=.false. but reduction type not compatible', FATAL) + ENDIF + END IF + + !!TODO: (MDM) Add other checks? E.g. If time_averaging == .false., then + !! out_frequency == EVERY_TIME + + IF((dt .EQ. time_min) .OR. (dt .EQ. time_max) .OR. & + & ( dt .EQ. time_average) .OR. (dt .EQ. time_sum) ) THEN + this%time_ops = .true. + ELSE + this%time_ops = .false. + END IF + end subroutine initialize + + !> @brief Copy the source time reduction object into the this object. + subroutine copy(this, source) + class (fmsDiagTimeReduction_type),intent(inout):: this !< The fmsDiagTimeReduction_type object + class (fmsDiagTimeReduction_type),intent(in):: source !< The fmsDiagTimeReduction_type object + this%the_time_reduction = source%the_time_reduction + this%time_averaging = source%time_averaging + this%time_ops = source%time_ops + end subroutine copy + + !> \brief Returns true if any of time_min, time_max, time_rms or time_average is true. + !! @return true if any of time_min, time_max, time_rms or time_average is true. + pure function has_time_ops_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff time_averaging is true. + !! @return true iff time_averaging is true. + pure function do_time_averaging_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_average + !! @return true iff the_time_reduction is time_average + pure function is_time_average_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_none + !! @return true iff the_time_reduction is time_none + pure function is_time_none_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_rms + !! @return true iff the_time_reduction is time_rms + pure function is_time_rms_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_max + !! @return true iff the_time_reduction is time_max + pure function is_time_max_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_min + !! @return true iff the_time_reduction is time_min + pure function is_time_min_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_sum + !! @return true iff the_time_reduction is time_sum + pure function is_time_sum_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_diurnal + !! @return true iff the_time_reduction is time_diurnal + pure function is_time_diurnal_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_power + !! @return true iff the_time_reduction is time_power + pure function is_time_power_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! @} +! close documentation grouping diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh new file mode 100644 index 0000000000..ae1bb0038c --- /dev/null +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -0,0 +1,1370 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_update interface. The + !! generated function is a wrapper calling 4D field/5D buffer version of the same. +FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & + & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & + & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) result( succeded ) + TYPE(fmsDiagOutfield_type), INTENT(in):: ofield_cfg !< The fmsDiagOutfield_type object, + !! where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg ! A target for ofc_ptr, in case ofc is not allocated + LOGICAL, DIMENSION(1), target :: mask_dummy !> A target for mask_ptr, in case mask is not present + + !! For pointer bounds remapping + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr !< Pointer to the field + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr !< Pointer to the outfield buffer. + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr !< Pointer to the outfield counter. + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< Pointer to the mask. + + !!Set all the pointers! + field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3),1:1, 1:size(ofb,4)) => ofb + + !!Note that diag manager does not allocate the ofc in all situations + if(allocated(ofc)) then + ofc_ptr(1:size(ofc,1),1:size(ofc,2),1:size(ofc,3), 1:1, 1:size(ofc,4)) => ofc + else + ofc_ptr(1:1,1:1,1:1,1:1,1:1) => ofc_dummy + endif + + IF (PRESENT (mask)) THEN + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ELSE + mask_ptr(1:1,1:1,1:1,1:1) => mask_dummy + ENDIF + + succeded = FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & + & ofb_ptr, ofc_ptr, bbounds, count_0d, num_elements, mask_ptr, weight1, missvalue, & + & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local) + END FUNCTION FMS_DIAG_FBU_3D_PNAME_ + + +!> @brief This code will be used by the preprocessor to generate an implementation +!! of the module procedure for the fieldbuff_update interface. +!! Updates elements of the running field output buffer (argument ofb) +!! and counter (argument ofc) based on the input field data array (argument field_d). +!! In general the formulas are : +!! A) ofb(l) = ofb(l) + (weight * field(l))**pow_value +!! B) ofc(l) = ofc(l) + weight +!! where l is a standing for some set of indices in multiple dimensions. +!! Note this function may set field object members active_omp_level and num_threads. +!! TODO: (MDM) revisit passing in and need of field_num_threads and field_active_omp_level +!> @addtogroup fms_diag_fieldbuff_update_mod +!> @{ + FUNCTION FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_d, sample, & + & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & + & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) result( succeded ) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !!where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !! where "cfg" is short for configuration + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< Output Field Buffer + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofc !< Output Field Counter + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< The array bounds of the ofb argument. + INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. + INTEGER, INTENT(inout):: num_elements !< Used in counting updated buffer elements; Other functions (e.g. wrting + !!field) may nprmalize output buffer elements with the same. + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL:: mask !< The mask of the corresponding field. + FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight + FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. + + INTEGER, INTENT(inout) :: field_num_threads !< Number of OMP threads used processing the input field; + !! expected 1 if no OMP. + INTEGER, INTENT(inout)::field_active_omp_level !1 .AND. phys_window ) then + REDU_KR1_IF: IF ( reduced_k_range ) THEN + DO k= ksr, ker + k1= k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample), & + & field_d(i-is+1+hi, j-js+1+hj, k, :), weight1, pow_value) + ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 + END where + END DO + END DO + END DO + ELSE REDU_KR1_IF + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + ofc(i-hi,j-hj,k,:,sample) = ofc(i-hi,j-hj,k,:,sample) + weight1 + END where + END DO + END DO + END DO + END IF REDU_KR1_IF + ELSE +!$OMP CRITICAL + REDU_KR2_IF: IF ( reduced_k_range ) THEN + DO k= ksr, ker + k1= k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi, j-js+1+hj, k, :) , weight1, pow_value) + ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 + END where + END DO + END DO + END DO + ELSE REDU_KR2_IF + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + ofc(i-hi,j-hj,k,:,sample) = ofc(i-hi,j-hj,k,:,sample) + weight1 + END where + END DO + END DO + END DO + END IF REDU_KR2_IF +!$OMP END CRITICAL + END IF + ELSE MISSVAL_PR_1_IF + WRITE (error_string,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + IF(fms_error_handler('diag_manager_mod::send_data_3d', & + & 'module/output_field '//TRIM(error_string)//', variable mask but no missing value defined', & + & err_msg)) THEN + succeded = .FALSE. + RETURN + END IF + END IF MISSVAL_PR_1_IF + ELSE MASK_PR_1_IF ! no mask present + WRITE (error_string,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//TRIM(error_string)//& + & ', variable mask but no mask given', err_msg)) THEN + succeded = .FALSE. + RETURN + END IF + END IF MASK_PR_1_IF + ELSE MASK_VAR_IF + MASK_PR_2_IF: IF (mask_present ) THEN + MISSVAL_PR_2_IF: IF ( missvalue_present ) THEN !!section:(mask_var false +mask present +missval prsnt) + NDCMP_RKR_1_IF: 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 + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + 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 + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ENDIF +!$OMP CRITICAL + DO l = ls, le + 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 + num_elements = num_elements + l_end(3) - l_start(3) + 1 + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_1_IF + IF (numthreads>1 .AND. phys_window) then + DO k=ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k1,:,sample)= missvalue + END where + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k=ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k1,:,sample)= missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF + ELSE NDCMP_RKR_1_IF + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + 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 + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k,:,sample)= missvalue + END where + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k,:,sample)= missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF + END IF NDCMP_RKR_1_IF +!$OMP CRITICAL + 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), :)) ) & + count_0d = count_0d + weight1 + ELSE + IF ( ANY(mask(f1:f2,f3:f4,ks:ke,:)) ) count_0d = count_0d + weight1 + END IF +!$OMP END CRITICAL + ELSE MISSVAL_PR_2_IF !! (section: mask_varian .eq. false + mask present + miss value not present) + IF ( (.NOT.ALL(mask(f1:f2,f3:f4,ks:ke,:)) .AND. mpp_pe() .EQ. mpp_root_pe()).AND.& + & .NOT. 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(field_name)//' in module '//& + & trim(module_name), WARNING) + issued_mask_ignore_warning = .TRUE. + END IF + NDCMP_RKR_2_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 + ofb(i1,j1,:,:,sample)= addwf(ofb(i1,j1,:,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) , weight1, pow_value) + END IF + END DO + END DO + ELSE +!$OMP CRITICAL + 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 + ofb(i1,j1,:,:,sample) = addwf( ofb(i1,j1,:,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) , weight1, pow_value) + END IF + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO l = ls, le + 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 + num_elements = num_elements + l_end(3)-l_start(3)+1 + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_2_IF + IF (numthreads>1 .AND. phys_window) then + ksr= l_start(3) + ker= l_end(3) + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker, :) , weight1, pow_value) + ELSE +!$OMP CRITICAL + ksr= l_start(3) + ker= l_end(3) + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker,:) , weight1, pow_value) +!$OMP END CRITICAL + END IF + ELSE NDCMP_RKR_2_IF + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '') THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF (numthreads>1 .AND. phys_window) then + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke,:) , weight1, pow_value) + ELSE +!$OMP CRITICAL + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & addwf(ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke,:) , weight1, pow_value) +!$OMP END CRITICAL + END IF + END IF NDCMP_RKR_2_IF +!$OMP CRITICAL + IF ( .NOT.phys_window ) count_0d = count_0d + weight1 +!$OMP END CRITICAL + END IF MISSVAL_PR_2_IF + ELSE MASK_PR_2_IF !!(section: mask_variant .eq. false + mask not present + missvalue) + MISSVAL_PR_3_IF: IF (missvalue_present ) THEN + NDCMP_RKR_3_IF: IF ( need_compute ) THEN + NTAPW_IF: 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 + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO + ELSE NTAPW_IF +!$OMP CRITICAL + 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 + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + END IF NTAPW_IF +!$OMP CRITICAL + DO l = ls, le + 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 + num_elements = num_elements + l_end(3) - l_start(3) + 1 + END IF + END DO + END DO + END DO + IF ( .NOT.phys_window ) THEN + outer0: DO l = ls, le + 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_d(i,j, k, l) /= missvalue ) THEN + count_0d = count_0d + weight1 + EXIT outer0 + END IF + END DO + END DO + END DO + END DO outer0 + END IF +!$OMP END CRITICAL + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_3_IF + 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 + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k1,:,sample) = addwf(ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k1,:,sample) = missvalue + END where + END DO + END DO + END DO + else +!$OMP CRITICAL + ksr= l_start(3) + ker= l_end(3) + DO k = ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k1,:,sample) = missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + outer3: DO l = ls, le + DO k = ksr, ker + k1=k-ksr+1 + DO j=f3, f4 + DO i=f1, f2 + IF ( field_d(i,j, k, l) /= missvalue ) THEN + count_0d = count_0d + weight1 + EXIT outer3 + END IF + END DO + END DO + END DO + END DO outer3 +!$OMP END CRITICAL + ELSE NDCMP_RKR_3_IF + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + 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 + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k,:,sample) = missvalue + END where + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k,:,sample) = missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + outer1: DO l = ls, le + DO k=ks, ke + DO j=f3, f4 + DO i=f1, f2 + IF ( field_d(i,j, k, l) /= missvalue ) THEN + count_0d = count_0d + weight1 + EXIT outer1 + END IF + END DO + END DO + END DO + END DO outer1 +!$OMP END CRITICAL + END IF NDCMP_RKR_3_IF + ELSE MISSVAL_PR_3_IF !!(section: mask_variant .eq. false + mask not present + missvalue not present) + NDCMP_RKR_4_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 + ofb(i1,j1,:,:,sample) = addwf( ofb(i1,j1,:,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) , weight1, pow_value) + END IF + END DO + END DO + ELSE +!$OMP CRITICAL + 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 + ofb(i1,j1,:,:,sample) = addwf(ofb(i1,j1,:,:,sample), & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :), weight1, pow_value) + END IF + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO l = ls, le + 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 + num_elements = num_elements + l_end(3)-l_start(3)+1 + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ! Accumulate time average + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_4_IF + ksr= l_start(3) + ker= l_end(3) + IF( numthreads > 1 .AND. phys_window ) then + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker, :) , weight1, pow_value) + ELSE +!$OMP CRITICAL + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker, :) , weight1, pow_value) +!$OMP END CRITICAL + END IF + + ELSE NDCMP_RKR_4_IF + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF (fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF( numthreads > 1 .AND. phys_window ) then + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke, :) , weight1, pow_value) + ELSE +!$OMP CRITICAL + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke, :) , weight1, pow_value) + !! +!$OMP END CRITICAL + END IF + END IF NDCMP_RKR_4_IF +!$OMP CRITICAL + IF ( .NOT.phys_window ) count_0d = count_0d + weight1 +!$OMP END CRITICAL + END IF MISSVAL_PR_3_IF + END IF MASK_PR_2_IF ! if mask present + END IF MASK_VAR_IF + +!$OMP CRITICAL + IF ( .NOT.need_compute .AND. .NOT.reduced_k_range ) num_elements = num_elements + & + & (ie-is+1)*(je-js+1)*(ke-ks+1)*(le-ls+1) + IF ( reduced_k_range ) num_elements = num_elements + & + & (ie-is+1)*(je-js+1)*(ker-ksr+1)*(le-ls+1) +!$OMP END CRITICAL + + succeded = .TRUE. + RETURN + + END FUNCTION FMS_DIAG_FBU_PNAME_ + + + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_copy_fieldvals interface. The + !! generated function is a wrapper calling 4D field/5D buffer version of the same. + FUNCTION FMS_DIAG_FBCF_3D_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & + & bbounds, count_0d, mask, missvalue, & + & l_start, l_end, err_msg, err_msg_local) result( succeded ) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !!where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !! where "cfg" is short for configuration + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. + INTEGER, INTENT(in) :: sample !< index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),INTENT(inout),target::ofb ! A target for mask_ptr, in case mask is not present + + !! For pointer bounds remapping: + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr!< Pointer to the field + FMS_DIAG_FBU_DATA_TYPE_ , pointer,DIMENSION(:,:,:,:,:):: ofb_ptr!< Pointer to the outfield buffer. + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< Pointer to the mask. + + !Initialize all the pointers + field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field(:,:,:) + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:1, 1:size(ofb,4)) => ofb + IF (PRESENT (mask)) THEN + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ELSE + mask_ptr(1:1,1:1,1:1,1:1) => mask_dummy + ENDIF + + succeded = FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & + & ofb_ptr, bbounds, count_0d, mask_ptr, missvalue, & + & l_start, l_end, err_msg, err_msg_local) + END FUNCTION FMS_DIAG_FBCF_3D_PNAME_ + +!> @brief This code will be used by the preprocessor to generate an implementation +!! of the module procedure for the fieldbuff_copy_fieldvals interface. +!! The function may set or add to the output field buffer (argument ofb) with the input +!! field data array (argument field) +FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & + & bbounds, count_0d, mask, missvalue, & + & l_start, l_end, err_msg, err_msg_local) result( succeded ) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !! where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !!where "cfg" is short for configuration + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field !< The field value array. + INTEGER, INTENT(in) :: sample !< index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< The Output Field Buffer + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< The array bounds of the ofb argument. + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !< Normally the member of the buffer of same name, + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask !< The mask of the corresponding field. + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. + INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output + INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output + CHARACTER(len=*), INTENT(out),OPTIONAL::err_msg !< Possibly passed in by the caller, and sent to handler + CHARACTER(len=256), INTENT(out) :: err_msg_local !< Possibly set by bounds checker, and sent to handler + LOGICAL :: succeded !< Return true iff errors are not encounterd. + !! + !! + !< The indices copied directly from the ofield_index_cfg + INTEGER :: is, js, ks, ie, je, ke, hi, hj, f1, f2, f3, f4 + + CHARACTER(:), ALLOCATABLE :: output_name !< A copy of same variable in ofield_cfg + CHARACTER(:), ALLOCATABLE :: module_name !< A copy of same variable in ofield_cfg + LOGICAL :: need_compute !< A copy of same variable in ofield_cfg + LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg + LOGICAL :: mask_present !< A copy of same variable in ofield_cfg + LOGICAL :: missvalue_present !< A copy of same variable in ofield_cfg + class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type + + INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations + INTEGER :: i, j, k, i1, j1, k1 !< Looping indices, derived from ofield_index_cfg: + LOGICAL :: time_max, time_min, time_sum !< A copies of same variables in ofield_cfg%time_reduction + + ksr= l_start(3) + ker= l_end(3) + + is = ofield_index_cfg%get_is() + js = ofield_index_cfg%get_js() + ks = ofield_index_cfg%get_ks() + ie = ofield_index_cfg%get_ie() + je = ofield_index_cfg%get_je() + ke = ofield_index_cfg%get_ke() + hi = ofield_index_cfg%get_hi() + hj = ofield_index_cfg%get_hj() + f1 = ofield_index_cfg%get_f1() + f2 = ofield_index_cfg%get_f2() + f3 = ofield_index_cfg%get_f3() + f4 = ofield_index_cfg%get_f4() + + allocate(time_redux) + call time_redux%copy(ofield_cfg%get_time_reduction()) + time_max = time_redux%is_time_max() + time_min = time_redux%is_time_min() + time_sum = time_redux%is_time_sum() + + output_name = trim(ofield_cfg%get_output_name()) + module_name = trim(ofield_cfg%get_module_name()) + reduced_k_range = ofield_cfg%get_reduced_k_range() + need_compute = ofield_cfg%get_need_compute() + mask_present = ofield_cfg%get_mask_present() + missvalue_present = ofield_cfg%get_missvalue_present() + + ! Add processing for Max and Min + TIME_IF: IF ( time_max ) THEN + MASK_PRSNT_1_IF: IF (mask_present ) THEN + IF ( need_compute ) 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 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .AND.& + & field(i-is+1+hi,j-js+1+hj,k,:)>OFB(i1,j1,k1,:,sample)) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Maximum time value with masking + ELSE IF ( reduced_k_range ) THEN + ksr = l_start(3) + ker = l_end(3) + WHERE ( mask(f1:f2,f3:f4,ksr:ker,:) .AND. & + & field(f1:f2,f3:f4,ksr:ker,:) > OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE ( mask(f1:f2,f3:f4,ks:ke,:) .AND.& + & field(f1:f2,f3:f4,ks:ke,:)>OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + ELSE MASK_PRSNT_1_IF + IF ( need_compute ) 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 + WHERE ( field(i-is+1+hi,j-js+1+hj,k,:) > OFB(i1,j1,k1,:,sample) ) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Maximum time value + ELSE IF ( reduced_k_range ) THEN + ksr = l_start(3) + ker = l_end(3) + WHERE ( field(f1:f2,f3:f4,ksr:ker,:) > OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) )& + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE (field(f1:f2,f3:f4,ks:ke,:) > OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + END IF MASK_PRSNT_1_IF + count_0d = 1 + !END TIME MAX + ELSE IF ( time_min ) THEN TiME_IF + MASK_PRSNT_2_IF: IF (mask_present ) THEN + IF ( need_compute ) 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 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .AND.& + & field(i-is+1+hi,j-js+1+hj,k,:) < OFB(i1,j1,k1,:,sample) ) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Minimum time value with masking + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + WHERE ( mask(f1:f2,f3:f4,ksr:ker,:) .AND.& + & field(f1:f2,f3:f4,ksr:ker,:) < OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE ( mask(f1:f2,f3:f4,ks:ke,:) .AND.& + & field(f1:f2,f3:f4,ks:ke,:) < OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + ELSE MASK_PRSNT_2_IF + IF ( need_compute ) 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 + WHERE ( field(i-is+1+hi,j-js+1+hj,k,:) < OFB(i1,j1,k1,:,sample) ) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Minimum time value + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + WHERE ( field(f1:f2,f3:f4,ksr:ker,:) < OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) )& + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE (field(f1:f2,f3:f4,ks:ke,:) < OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + END IF MASK_PRSNT_2_IF + count_0d = 1 + + !! END_TIME_MIN + ELSE IF ( time_sum ) THEN TIME_IF + MASK_PRSNT_3_IF: IF (mask_present ) THEN + IF ( need_compute ) 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 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) ) + OFB(i1,j1,k1,:,sample) = OFB(i1,j1,k1,:,sample) + field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Minimum time value with masking + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = & + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & + & field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE ( mask(f1:f2,f3:f4,ks:ke,:) ) & + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = & + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) + & + & field(f1:f2,f3:f4,ks:ke,:) + END IF + ELSE MASK_PRSNT_3_IF + IF ( need_compute ) 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 + OFB(i1,j1,k1,:,sample) = OFB(i1,j1,k1,:,sample) + field(i-is+1+hi,j-js+1+hj,k,:) + END IF + END DO + END DO + END DO + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & + & field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) + & + & field(f1:f2,f3:f4,ks:ke, :) + END IF + END IF MASK_PRSNT_3_IF + count_0d = 1 + !END time_sum + ELSE TIME_IF !! ( not average, not min, not max, not sum ) + count_0d = 1 + IF ( need_compute ) 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 + OFB(i1,j1,:,:,sample) = field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3),:) + END IF + END DO + END DO + ! instantaneous output + ELSE IF ( reduced_k_range ) THEN + ksr = l_start(3) + ker = l_end(3) + OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + + IF (mask_present .AND. missvalue_present ) THEN + IF ( need_compute ) 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 + WHERE ( .NOT.mask(i-is+1+hi,j-js+1+hj,k,:) ) & + & OFB(i1,j1,k1,:,sample) = missvalue + END IF + END DO + END DO + END DO + ELSE IF ( reduced_k_range ) 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 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .eqv. .false.) & + & OFB(i-hi,j-hj,k1,:,sample)= missvalue + END DO + END DO + END DO + ELSE + DO k=ks, ke + DO j=js, je + DO i=is, ie + WHERE ( .NOT. mask(i-is+1+hi,j-js+1+hj,k,:) )& + & OFB(i-hi,j-hj,k,:,sample)= missvalue + END DO + END DO + END DO + END IF + END IF + END IF TIME_IF + succeded = .TRUE. + RETURN + + END FUNCTION FMS_DIAG_FBCF_PNAME_ + + + + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_copy_misvals interface. The + !! generated function is a wrapper calling 4D field/5D buffer version of the same. + !! TODO (MDM) the meaning of an integer rmask has to be studied. + SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ (ofield_cfg, ofield_index_cfg, ofb, sample, & + & l_start, l_end, rmask, rmask_thresh, missvalue) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS,DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! ofb + rmask_ptr(1:size(rmask,1),1:size(rmask,2),1:size(rmask,3),1:1) => rmask + + call FMS_DIAG_FBCM_PNAME_ (ofield_cfg, ofield_index_cfg, ofb_ptr, sample, & + & l_start, l_end, rmask_ptr, rmask_thresh, missvalue) + END SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ + + + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_copy_misvals interface. + !! The function updates where appropriate and depending on the rmask argument, + !! elements of the running field output buffer (argument buffer) with value missvalue. + !! NOTE: It appears these OFB updates were introcuded by EMC MM into the tail end of the + !! legacy send_data_3d. + SUBROUTINE FMS_DIAG_FBCM_PNAME_ (ofield_cfg, ofield_index_cfg, buffer, sample, & + & l_start, l_end, rmask, rmask_thresh, missvalue) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !! where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !!where "cfg" is short for configuration + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout), DIMENSION(:,:,:,:,:) :: buffer !< the buffer to update + INTEGER, INTENT(in) :: sample !< index along the diurnal time axis + INTEGER, INTENT(in), DIMENSION(3):: l_start !< local start indices on 3 axes for regional output + INTEGER, INTENT(in), DIMENSION(3):: l_end !< local end indices on 3 axes for regional output + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in), DIMENSION(:,:,:,:):: rmask !< Updates where rmask < rmask_thresh + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: rmask_thresh !< Updates where rmask < rmask_thresh + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< Value used to update the buffer. + + !< Looping indices copied from corresponding one in ofield_index_cfg info: + INTEGER :: is, js, ks, ie, je, ke, hi, hj + !< Floags copied from corresponding one in ofield_cfg info: + LOGICAL :: need_compute !< A copy of same variable in ofield_cfg + LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg + INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations + !< Looping indices, derived from ofield_index_cfg info: + INTEGER :: i, j, k, i1, j1, k1 + + is = ofield_index_cfg%get_is() + js = ofield_index_cfg%get_js() + ks = ofield_index_cfg%get_ks() + ie = ofield_index_cfg%get_ie() + je = ofield_index_cfg%get_je() + ke = ofield_index_cfg%get_ke() + hi = ofield_index_cfg%get_hi() + hj = ofield_index_cfg%get_hj() + + reduced_k_range = ofield_cfg%get_reduced_k_range() + need_compute = ofield_cfg%get_need_compute() + + associate(ofb => buffer) + + ! If rmask and missing value present, then insert missing value + IF ( need_compute ) 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 + where ( rmask(i-is+1+hi,j-js+1+hj,k,:) <= rmask_thresh ) + ofb(i1,j1,k1,:,sample) = missvalue + end where + END IF + END DO + END DO + END DO + ELSE IF ( reduced_k_range ) 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 + where ( rmask(i-is+1+hi,j-js+1+hj,k,:) <= rmask_thresh ) + ofb(i-hi,j-hj,k1,:,sample)= missvalue + endwhere + END DO + END DO + END DO + ELSE + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( rmask(i-is+1+hi,j-js+1+hj,k,:) <= rmask_thresh ) + ofb(i-hi,j-hj,k,:,sample)= missvalue + endwhere + END DO + END DO + END DO + END IF + end associate + END SUBROUTINE FMS_DIAG_FBCM_PNAME_ + !> @} diff --git a/diag_manager/include/fms_diag_fieldbuff_update.inc b/diag_manager/include/fms_diag_fieldbuff_update.inc new file mode 100644 index 0000000000..be6f51d0f1 --- /dev/null +++ b/diag_manager/include/fms_diag_fieldbuff_update.inc @@ -0,0 +1,50 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +#undef FMS_DIAG_FBU_DATA_TYPE_ +#define FMS_DIAG_FBU_DATA_TYPE_ REAL(r4_kind) +#undef FMS_DIAG_FBU_PNAME_ +#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r4 +#undef FMS_DIAG_FBU_3D_PNAME_ +#define FMS_DIAG_FBU_3D_PNAME_ fieldbuff_update_3d_r4 +#undef FMS_DIAG_FBCF_PNAME_ +#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r4 +#undef FMS_DIAG_FBCF_3D_PNAME_ +#define FMS_DIAG_FBCF_3D_PNAME_ fieldbuff_copy_fieldvals_3d_r4 +#undef FMS_DIAG_FBCM_PNAME_ +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_missvals_r4 +#undef FMS_DIAG_FBCM_3D_PNAME_ +#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_missvals_3d_r4 +#include + +#undef FMS_DIAG_FBU_DATA_TYPE_ +#define FMS_DIAG_FBU_DATA_TYPE_ REAL(r8_kind) +#undef FMS_DIAG_FBU_PNAME_ +#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r8 +#undef FMS_DIAG_FBU_3D_PNAME_ +#define FMS_DIAG_FBU_3D_PNAME_ fieldbuff_update_3d_r8 +#undef FMS_DIAG_FBCF_PNAME_ +#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r8 +#undef FMS_DIAG_FBCF_3D_PNAME_ +#define FMS_DIAG_FBCF_3D_PNAME_ fieldbuff_copy_fieldvals_3d_r8 +#undef FMS_DIAG_FBCM_PNAME_ +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_missvals_r8 +#undef FMS_DIAG_FBCM_3D_PNAME_ +#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_missvals_3d_r8 +#include diff --git a/drifters/include/cloud_interpolator.inc b/drifters/include/cloud_interpolator.inc new file mode 100644 index 0000000000..f83f66274e --- /dev/null +++ b/drifters/include/cloud_interpolator.inc @@ -0,0 +1,290 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** +#define _FLATTEN(A) reshape((A), (/size((A))/) ) + +!> @defgroup cloud_interpolator_mod cloud_interpolator_mod +!> @ingroup drifters +!! @brief Cloud interpolation routines for use in @ref drifters_mod + +!> @addtogroup cloud_interpolator_mod +!> @{ +MODULE cloud_interpolator_mod + implicit none + private + + public :: cld_ntrp_linear_cell_interp, cld_ntrp_locate_cell, cld_ntrp_get_cell_values + public :: cld_ntrp_expand_index, cld_ntrp_contract_indices + +! Include variable "version" to be written to log file. +#include +real, parameter :: tol = 10.0*epsilon(1.) + +CONTAINS + +!............................................................................... +!> Get expanded list of indices from contracted index +!> @param Ic contracted index +!> @param[out] ie(:) expanded list of indices +!> @param[out] ier error flag, non zero if operation unsuccessful +pure subroutine cld_ntrp_expand_index(Ic, ie, ier) + integer, intent(in) :: Ic + integer, intent(out) :: ie(:) + integer, intent(out) :: ier + + integer j, nd + + ier = 0 + nd = size(ie) ! dimension + + if(Ic >= 2**nd) then + ie = -1 + ier = 1 ! error + return + endif + + do j = 1, nd + ie(j) = mod(Ic/2**(j-1), 2) + end do + + end subroutine cld_ntrp_expand_index + +!............................................................................... +!> Contract list of indices to an single integer +!> @param ie(:) expanded list of indices +!> @param[out] Ic contracted index +!> @param[out] ier error flag, non zero if operation unsuccessful +pure subroutine cld_ntrp_contract_indices(ie, Ic, ier) + integer, intent(in) :: ie(:) + integer, intent(out) :: Ic + integer, intent(out) :: ier + + integer j, nd + + ier = 0 + nd = size(ie) ! dimension + + Ic = ie(nd) + do j = nd-1, 1, -1 + Ic = Ic * 2 + Ic = Ic + ie(j) + end do + + if(Ic >= 2**nd) ier = 1 + + end subroutine cld_ntrp_contract_indices + + +!............................................................................... +!............................................................................... +!> Cloud interpolation for linear cells +!> @param fvals values at the cell nodes +!> @param ts normalized [0,1]^nd cell coordinates +!> @param[out] interpolated value +!> @param[out] error flag, non zero if unsucessful +pure subroutine cld_ntrp_linear_cell_interp(fvals, ts, f, ier) + real, intent(in) :: fvals(0:) + real, intent(in) :: ts(:) + real, intent(out):: f + integer, intent(out) :: ier + + integer j, nd, Ic, iflag + integer ie(size(fvals)) + real basis + + ier = 0 + f = 0. + nd = size(ts) + if(size(fvals) /= 2**nd) then + ier = 1 + return + endif + + do Ic = 0, 2**nd - 1 + basis = 1. + call cld_ntrp_expand_index(Ic, ie, iflag) + do j = 1, nd + basis = basis * ( (1.0-real(ie(j)))*(1.0-ts(j)) + real(ie(j))*ts(j) ) + end do + f = f + fvals(Ic)*basis + end do + + end subroutine cld_ntrp_linear_cell_interp + +!............................................................................... +!............................................................................... +pure subroutine cld_ntrp_locate_cell(axis, x, index, ier) + real, intent(in) :: axis(:) !< axis + real, intent(in) :: x !< abscissae + integer, intent(out) :: index !< lower-left corner index + integer, intent(out) :: ier !< error flag (0=ok) + + logical down + integer n, index1, is + real axis_1, axis_n, axis_min, axis_max + ier = 0 + index = -1 + down = .FALSE. + n = size(axis) + if(n < 2) then + ier = 3 + return + endif + axis_1 = axis(1) + axis_n = axis(n) + axis_min = axis_1 + axis_max = axis_n + if(axis_1 > axis_n) then + down = .TRUE. + axis_min = axis_n + axis_max = axis_1 + endif + + if(x < axis_min-tol) then + ier = 1 + return + endif + if(x > axis_max+tol) then + ier = 2 + return + endif + + index = floor(real(n-1)*(x - axis_1)/(axis_n-axis_1)) + 1 + index = min(n-1, index) + index1 = index+1 + + if(.NOT. down) then + if(axis(index) <= x+tol) then + if(x <= axis(index1)+tol) then + ! axis is uniform, or nearly so. Done! + return + else + ! increase index + is = index+1 + do index = is, n-1 + index1 = index+1 + if(axis(index1) >= x-tol) return + enddo + endif + else + ! decrease index + is = index - 1 + do index = is, 1, -1 + if(axis(index) <= x+tol) return + enddo + endif + else + ! axis is pointing down + if(axis(index) >= x-tol) then + if(x >= axis(index1)-tol) then + ! axis is uniform, or nearly so. Done! + return + else + ! increase index + is = index + 1 + do index = is, n-1 + index1 = index+1 + if(axis(index1) <= x+tol) return + enddo + endif + else + ! decrease index + is = index - 1 + do index = is, 1, -1 + if(axis(index) >= x-tol) return + enddo + endif + endif + + end subroutine cld_ntrp_locate_cell + +!............................................................................... +!............................................................................... +pure subroutine cld_ntrp_get_flat_index(nsizes, indices, flat_index, ier) + integer, intent(in) :: nsizes(:) !< size of array along each axis + integer, intent(in) :: indices(:) !< cell indices + integer, intent(out) :: flat_index !< index into flattened array + integer, intent(out) :: ier !< error flag (0=ok) + + integer nd, id + + ier = 0 + flat_index = -1 + nd = size(nsizes) + if(nd /= size(indices)) then + ! size mismatch + ier = 1 + return + endif + + flat_index = indices(nd)-1 + do id = nd-1, 1, -1 + flat_index = flat_index*nsizes(id) + indices(id)-1 + enddo + flat_index = flat_index + 1 + + end subroutine cld_ntrp_get_flat_index + +!............................................................................... +!............................................................................... +pure subroutine cld_ntrp_get_cell_values(nsizes, fnodes, indices, fvals, ier) + integer, intent(in) :: nsizes(:) !< size of fnodes along each axis + real, intent(in) :: fnodes(:) !< flattened array of node values + integer, intent(in) :: indices(:) !< cell indices + real, intent(out) :: fvals(0:) !< returned array values in the cell + integer, intent(out) :: ier !< error flag (0=ok) + + integer id, nt, nd, flat_index, Ic, iflag + integer, dimension(size(nsizes)) :: cell_indices, node_indices + ier = 0 + fvals = 0. + + nd = size(nsizes) + if(nd /= size(indices)) then + ! size mismatch + ier = 1 + return + endif + if(2**nd > size(fvals)) then + ! not enough elements to hold result + ier = 2 + return + endif + nt = 1 + do id = 1, nd + nt = nt * nsizes(id) + enddo + if(nt /= size(fnodes)) then + ! not enough node values + ier = 3 + return + endif + + do Ic = 0, 2**nd-1 + call cld_ntrp_expand_index(Ic, cell_indices, iflag) + node_indices = indices + cell_indices + call cld_ntrp_get_flat_index(nsizes, node_indices, flat_index, iflag) + fvals(Ic) = fnodes(flat_index) + enddo + + end subroutine cld_ntrp_get_cell_values + +end MODULE cloud_interpolator_mod +!=============================================================================== +!> @} +! close documentation grouping diff --git a/drifters/include/drifters.inc b/drifters/include/drifters.inc new file mode 100644 index 0000000000..eac1d6cbd8 --- /dev/null +++ b/drifters/include/drifters.inc @@ -0,0 +1,953 @@ +!*********************************************************************** +!* 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 "fms_switches.h" +#define _FLATTEN(A) reshape((A), (/size((A))/) ) + +!> @defgroup drifters_mod drifters_mod +!> @ingroup drifters +!! @brief Drifters_modis a module designed to advect a set of particles, in parallel or +!! sequentially, given an prescribed velocity field. +!! @author Alexander Pletzer +!! +!> Drifters are idealized point particles with positions that evolve in time according +!! to a prescribed velocity field, starting from some initial conditions. Drifters have +!! no mass, no energy, no size, and no friction and therefore have no impact on the +!! dynamics of the underlying system. The only feature that distinguishes a drifter +!! from another is its trajectory. This makes drifters ideal for tracking pollution +!! clouds and probing fields (e.g. temperature, salinity) along ocean currents, to name +!! a few applications. +!! Drifters can mimic real experiments such as the Argo floats +!! http://www.metoffice.com/research/ocean/argo/ukfloats.html. +!! +!! When run in parallel, on a 2d decomposed domain, drifters_mod will handle all the +!! bookkeeping and communication transparently for the user. This involves adding/removing +!! drifters as they enter/leave a processor element (PE) domain. Note that the number of drifters +!! can vary greatly both between PE domains and within a PE domain in the course of a simulation; the drifters' +!! module will also manage dynamically the memory for the user. +!! +!! There are a number of basic assumptions which could make the drifters' module +!! ill-suited for some tasks. First and foremost, it is assumed that the motion of +!! drifters is not erratic but follows deterministic trajectories. Furthermore, +!! drifters should not cross both compute and data domain boundaries within less +!! than a time step. This limitation is imposed by the Runge-Kutta integration +!! scheme, which must be able to complete, within a time step, a trajectory +!! calculation that starts inside the compute domain and ends inside the data domain. Therefore, the drifters, +!! as they are presently modelled, are unlikely to work for very fast objects. +!! This constraint also puts a upper limit to the domain decomposition, although +!! it can often be remedied by increasing the number of ghost nodes. +!! +!! Another fundamental assumption is that the (e.g. velocity) fields are structured, +!! on a per PE domain basis. There is no support for locally nested or unstrucured +!! meshes. Meshes need not be smooth and continuous across PE domains, however. + +!> @addtogroup drifters_mod +!> @{ +module drifters_mod + +#ifdef _SERIAL + +! serial code +#define _MPP_PE 0 +#define _MPP_ROOT 0 +#define _MPP_NPES 1 +#define _TYPE_DOMAIN2D integer + +#else + +! parallel code + use mpp_mod , only : mpp_pe, mpp_npes + use mpp_domains_mod, only : domain2d +#define _MPP_PE mpp_pe() +#define _MPP_ROOT mpp_root_pe() +#define _MPP_NPES mpp_npes() +#define _TYPE_DOMAIN2D type(domain2d) + +#endif + + use drifters_core_mod, only: drifters_core_type, drifters_core_new, drifters_core_del, assignment(=) + + use drifters_input_mod, only: drifters_input_type, drifters_input_new, drifters_input_del, assignment(=) + + use drifters_io_mod, only: drifters_io_type, drifters_io_new, drifters_io_del, drifters_io_set_time_units, & + drifters_io_set_position_names, drifters_io_set_position_units, & + drifters_io_set_field_names, drifters_io_set_field_units, drifters_io_write + + use drifters_comm_mod, only: drifters_comm_type,drifters_comm_new,drifters_comm_del, & + drifters_comm_set_pe_neighbors, drifters_comm_set_domain, & + drifters_comm_gather, drifters_comm_update + + use cloud_interpolator_mod, only: cld_ntrp_linear_cell_interp, cld_ntrp_locate_cell, cld_ntrp_get_cell_values + implicit none + private + + public :: drifters_type, assignment(=), drifters_push, drifters_compute_k, drifters_set_field + public :: drifters_new, drifters_del, drifters_set_domain, drifters_set_pe_neighbors + public :: drifters_set_v_axes, drifters_set_domain_bounds, drifters_positions2lonlat + public :: drifters_print_checksums, drifters_save, drifters_write_restart, drifters_distribute + + integer, parameter, private :: MAX_STR_LEN = 128 +! Include variable "version" to be written to log file. +#include + !> @} + + !> @brief Holds all data needed for drifters communication, io, and input. + !> @ingroup drifters_mod + type drifters_type + ! Be sure to update drifters_new, drifters_del and drifters_copy_new + ! when adding members + type(drifters_core_type) :: core + type(drifters_input_type) :: input + type(drifters_io_type) :: io + type(drifters_comm_type) :: comm + real :: dt !< total dt, over a complete step + real :: time + ! fields + real, allocatable :: fields(:,:) + ! velocity field axes + real, allocatable :: xu(:) !< velocity field axes + real, allocatable :: yu(:) !< velocity field axes + real, allocatable :: zu(:) !< velocity field axes + real, allocatable :: xv(:) !< velocity field axes + real, allocatable :: yv(:) !< velocity field axes + real, allocatable :: zv(:) !< velocity field axes + real, allocatable :: xw(:) !< velocity field axes + real, allocatable :: yw(:) !< velocity field axes + real, allocatable :: zw(:) !< velocity field axes + ! Runge Kutta coefficients holding intermediate results (positions) + real, allocatable :: temp_pos(:,:) !< Runge Kutta coefficients holding + !! intermediate results (positions) + real, allocatable :: rk4_k1(:,:) !< Runge Kutta coefficients holding + !! intermediate results (positions) + real, allocatable :: rk4_k2(:,:) !< Runge Kutta coefficients holding + !! intermediate results (positions) + real, allocatable :: rk4_k3(:,:) !< Runge Kutta coefficients holding + !! intermediate results (positions) + real, allocatable :: rk4_k4(:,:) !< Runge Kutta coefficients holding + !! intermediate results (positions) + ! store filenames for convenience + character(len=MAX_STR_LEN) :: input_file !< store filenames for convenience + character(len=MAX_STR_LEN) :: output_file !< store filenames for convenience + ! Runge Kutta stuff + integer :: rk4_step !< Runge Kutta stuff + logical :: rk4_completed !< Runge Kutta stuff + integer :: nx, ny + logical, allocatable :: remove(:) + end type drifters_type + + !> @brief Assignment override for @ref drifters_type + !> @ingroup drifters_mod + interface assignment(=) + module procedure drifters_copy_new + end interface + + !> @brief "Push" a given drifter at a given velocity for either 2D or 3D data + !> @ingroup drifters_mod + interface drifters_push + module procedure drifters_push_2 + module procedure drifters_push_3 + end interface + + !> @ingroup drifters_mod + interface drifters_compute_k + module procedure drifters_computek2d + module procedure drifters_computek3d + end interface + + !> @brief Set the value of a given drifter field + !> @ingroup drifters_mod + interface drifters_set_field + module procedure drifters_set_field_2d + module procedure drifters_set_field_3d + end interface + +!> @addtogroup drifters_mod +!> @{ + +contains + + !> @brief Will read positions stored in the netCDF file input_file. + !! + !> The trajectories will be saved in files output_file.PE, + !! one file per PE domain. + subroutine drifters_new(self, input_file, output_file, ermesg) + + type(drifters_type) :: self !< Opaque data structure. + character(len=*), intent(in) :: input_file !< NetCDF input file name containing initial positions. + character(len=*), intent(in) :: output_file !< NetCDF output file. Will contain trajectory + !! positions and interpolated fields. + character(len=*), intent(out) :: ermesg !< Error message (if any). + + integer nd, nf, npdim, i + character(len=6) :: pe_str + + ermesg = '' + + self%input_file = input_file + self%output_file = output_file + + call drifters_input_new(self%input, input_file, ermesg) + if(ermesg/='') return + + ! number of dimensions + nd = size(self%input%velocity_names) + ! estimate for the max number of particles (will resize if exceeded) + npdim = int(1.3*size(self%input%positions, 2)) + call drifters_core_new(self%core, nd=nd, npdim=npdim, ermesg=ermesg) + if(ermesg/='') return + + ! number of fields + nf = size(self%input%field_names) + + ! one output file per PE + pe_str = ' ' + write(pe_str, '(i6)') _MPP_PE + pe_str = adjustr(pe_str) + do i = 1, 5 + if(pe_str(i:i)==' ') pe_str(i:i)='0' + enddo + call drifters_io_new(self%io, output_file//'.'//pe_str, nd, nf, ermesg) + if(ermesg/='') return + + call drifters_comm_new(self%comm) + if(ermesg/='') return + + ! Set meta data + call drifters_io_set_time_units(self%io, name=self%input%time_units, & + & ermesg=ermesg) + + call drifters_io_set_position_names(self%io, names=self%input%position_names, & + & ermesg=ermesg) + if(ermesg/='') return + call drifters_io_set_position_units(self%io, names=self%input%position_units, & + & ermesg=ermesg) + if(ermesg/='') return + + call drifters_io_set_field_names(self%io, names=self%input%field_names, & + & ermesg=ermesg) + if(ermesg/='') return + call drifters_io_set_field_units(self%io, names=self%input%field_units, & + & ermesg=ermesg) + if(ermesg/='') return + + self%dt = -1 + self%time = -1 + self%rk4_step = 0 + self%nx = 0 + self%ny = 0 + self%rk4_completed = .FALSE. + + allocate(self%rk4_k1(self%core%nd, self%core%npdim)) + self%rk4_k1 = -huge(1.) + allocate(self%rk4_k2(self%core%nd, self%core%npdim)) + self%rk4_k2 = -huge(1.) + allocate(self%rk4_k3(self%core%nd, self%core%npdim)) + self%rk4_k3 = -huge(1.) + allocate(self%rk4_k4(self%core%nd, self%core%npdim)) + self%rk4_k4 = -huge(1.) + allocate(self%remove(self%core%npdim)) + self%remove = .FALSE. + allocate(self%temp_pos(nd, self%core%npdim)) + self%temp_pos = -huge(1.) + + allocate(self%fields(nf, self%core%npdim)) + self%fields = -huge(1.) + + end subroutine drifters_new + + !============================================================================ + + !> @brief Destructor, call this to reclaim memory from data used for drifters. + subroutine drifters_del(self, ermesg) + type(drifters_type) :: self !< Opaque data structure. + character(len=*), intent(out) :: ermesg !< Error message (if any). + + integer flag + ermesg = '' + deallocate(self%fields, stat=flag) + deallocate(self%xu, stat=flag) + deallocate(self%yu, stat=flag) + deallocate(self%zu, stat=flag) + deallocate(self%xv, stat=flag) + deallocate(self%yv, stat=flag) + deallocate(self%zv, stat=flag) + deallocate(self%xw, stat=flag) + deallocate(self%yw, stat=flag) + deallocate(self%zw, stat=flag) + deallocate(self%temp_pos, stat=flag) + deallocate(self%rk4_k1, stat=flag) + deallocate(self%rk4_k2, stat=flag) + deallocate(self%rk4_k3, stat=flag) + deallocate(self%rk4_k4, stat=flag) + deallocate(self%remove, stat=flag) + + call drifters_core_del(self%core, ermesg) + if(ermesg/='') return + call drifters_input_del(self%input, ermesg) + if(ermesg/='') return + call drifters_io_del(self%io, ermesg) + if(ermesg/='') return + call drifters_comm_del(self%comm) + if(ermesg/='') return + + end subroutine drifters_del + + !============================================================================ + !> @brief Copy a drifter state into a new state. Note: this will not open new files; this will + !! copy all members into a new container. + subroutine drifters_copy_new(new_instance, old_instance) + + type(drifters_type), intent(in) :: old_instance !< Old data structure. + type(drifters_type), intent(inout) :: new_instance !< New data structure. + + character(len=MAX_STR_LEN) :: ermesg + + ermesg = '' + + ! make sure new_instance is empty + call drifters_del(new_instance, ermesg) + if(ermesg/='') return + + new_instance%core = old_instance%core + new_instance%input = old_instance%input + new_instance%io = old_instance%io + new_instance%comm = old_instance%comm + + new_instance%dt = old_instance%dt + new_instance%time = old_instance%time + + allocate(new_instance%fields( size(old_instance%fields, 1), & + & size(old_instance%fields, 2) )) + new_instance%fields = old_instance%fields + + allocate(new_instance%xu( size(old_instance%xu) )) + allocate(new_instance%yu( size(old_instance%yu) )) + allocate(new_instance%zu( size(old_instance%zu) )) + new_instance%xu = old_instance%xu + new_instance%yu = old_instance%yu + new_instance%zu = old_instance%zu + allocate(new_instance%xv( size(old_instance%xv) )) + allocate(new_instance%yv( size(old_instance%yv) )) + allocate(new_instance%zv( size(old_instance%zv) )) + new_instance%xv = old_instance%xv + new_instance%yv = old_instance%yv + new_instance%zv = old_instance%zv + allocate(new_instance%xw( size(old_instance%xw) )) + allocate(new_instance%yw( size(old_instance%yw) )) + allocate(new_instance%zw( size(old_instance%zw) )) + new_instance%xw = old_instance%xw + new_instance%yw = old_instance%yw + new_instance%zw = old_instance%zw + + allocate(new_instance%temp_pos( size(old_instance%temp_pos,1), & + & size(old_instance%temp_pos,2) )) + new_instance%temp_pos = old_instance%temp_pos + allocate(new_instance%rk4_k1( size(old_instance%rk4_k1,1), & + & size(old_instance%rk4_k1,2) )) + allocate(new_instance%rk4_k2( size(old_instance%rk4_k2,1), & + & size(old_instance%rk4_k2,2) )) + allocate(new_instance%rk4_k3( size(old_instance%rk4_k3,1), & + & size(old_instance%rk4_k3,2) )) + allocate(new_instance%rk4_k4( size(old_instance%rk4_k4,1), & + & size(old_instance%rk4_k4,2) )) + new_instance%rk4_k1 = old_instance%rk4_k1 + new_instance%rk4_k2 = old_instance%rk4_k2 + new_instance%rk4_k3 = old_instance%rk4_k3 + new_instance%rk4_k4 = old_instance%rk4_k4 + + new_instance%rk4_step = old_instance%rk4_step + new_instance%rk4_completed = old_instance%rk4_completed + new_instance%nx = old_instance%nx + new_instance%ny = old_instance%ny + + allocate(new_instance%remove(size(old_instance%remove))) + new_instance%remove = old_instance%remove + + + end subroutine drifters_copy_new + + !============================================================================ + !> @brief Set the compute, data, and global domain boundaries. + !! @details The data domain extends beyond the compute domain and is shared between + !! two or more PE domains. A particle crossing the compute domain boundary + !! will trigger a communication with one or more neighboring domains. A particle + !! leaving the data domain will be removed from the list of particles. + !! + !!
Example usage: + !! @code{.F90} + !! call drifters_set_domain(self, & + !! & xmin_comp, xmax_comp, ymin_comp, ymax_comp, & + !! & xmin_data, xmax_data, ymin_data, ymax_data, & + !! & xmin_glob, xmax_glob, ymin_glob, ymax_glob, & + !! & ermesg) + !! @endcode + subroutine drifters_set_domain(self, & + & xmin_comp, xmax_comp, ymin_comp, ymax_comp, & + & xmin_data, xmax_data, ymin_data, ymax_data, & + & xmin_glob, xmax_glob, ymin_glob, ymax_glob, & + & ermesg) + type(drifters_type) :: self !< Opaque data structure. + ! compute domain boundaries + real, optional, intent(in) :: xmin_comp !< Min of longitude-like axis on compute domain. + real, optional, intent(in) :: xmax_comp !< Max of longitude-like axis on compute domain. + real, optional, intent(in) :: ymin_comp !< Min of latitude-like axis on compute domain. + real, optional, intent(in) :: ymax_comp !< Max of latitude-like axis on compute domain. + ! data domain boundaries + real, optional, intent(in) :: xmin_data !< Min of longitude-like axis on data domain. + real, optional, intent(in) :: xmax_data !< Max of longitude-like axis on data domain. + real, optional, intent(in) :: ymin_data !< Min of latitude-like axis on data domain. + real, optional, intent(in) :: ymax_data !< Max of latitude-like axis on data domain. + ! global boundaries (only specify those if domain is periodic) + real, optional, intent(in) :: xmin_glob !< Min of longitude-like axis on global domain. + real, optional, intent(in) :: xmax_glob !< Max of longitude-like axis on global domain. + real, optional, intent(in) :: ymin_glob !< Min of latitude-like axis on global domain. + real, optional, intent(in) :: ymax_glob !< Max of latitude-like axis on global domain. + character(len=*), intent(out) :: ermesg !< Error message (if any). + + ermesg = '' + if(present(xmin_comp)) self%comm%xcmin = xmin_comp + if(present(xmax_comp)) self%comm%xcmax = xmax_comp + if(present(ymin_comp)) self%comm%ycmin = ymin_comp + if(present(ymax_comp)) self%comm%ycmax = ymax_comp + + if(present(xmin_data)) self%comm%xdmin = xmin_data + if(present(xmax_data)) self%comm%xdmax = xmax_data + if(present(ymin_data)) self%comm%ydmin = ymin_data + if(present(ymax_data)) self%comm%ydmax = ymax_data + + if(present(xmin_glob)) self%comm%xgmin = xmin_glob + if(present(xmax_glob)) self%comm%xgmax = xmax_glob + if(present(ymin_glob)) self%comm%ygmin = ymin_glob + if(present(ymax_glob)) self%comm%ygmax = ymax_glob + + ! Note: the presence of both xgmin/xgmax will automatically set the + ! periodicity flag + if(present(xmin_glob) .and. present(xmax_glob)) self%comm%xperiodic = .TRUE. + if(present(ymin_glob) .and. present(ymax_glob)) self%comm%yperiodic = .TRUE. + + end subroutine drifters_set_domain + + !============================================================================ + !> @brief Given an MPP based deomposition, set the PE numbers that are adjacent to this + !! processor. + !! + !> This will allow several PEs to track the trajectories of particles in the buffer regions. + subroutine drifters_set_pe_neighbors(self, domain, ermesg) + + type(drifters_type) :: self !< Opaque data structure. + _TYPE_DOMAIN2D :: domain !< MPP domain. + character(len=*), intent(out) :: ermesg !< Error message (if any). + + ermesg = '' + + call drifters_comm_set_pe_neighbors(self%comm, domain) + + end subroutine drifters_set_pe_neighbors + + !============================================================================ +#define _DIMS 2 +#define drifters_push_XXX drifters_push_2 +#include "drifters_push.fh" +#undef _DIMS +#undef drifters_push_XXX + + !============================================================================ +#define _DIMS 3 +#define drifters_push_XXX drifters_push_3 +#include "drifters_push.fh" +#undef _DIMS +#undef drifters_push_XXX + + !============================================================================ + subroutine drifters_modulo(self, positions, ermesg) + type(drifters_type) :: self + real, intent(inout) :: positions(:,:) + character(len=*), intent(out) :: ermesg + + integer ip, np + real x, y + + ermesg = '' + np = self%core%np + + if(self%comm%xperiodic) then + do ip = 1, np + x = positions(1, ip) + positions(1, ip) = self%comm%xgmin + & + & modulo(x - self%comm%xgmin, self%comm%xgmax-self%comm%xgmin) + enddo + endif + + if(self%comm%yperiodic) then + do ip = 1, np + y = positions(2, ip) + positions(2, ip) = self%comm%ygmin + & + & modulo(y - self%comm%ygmin, self%comm%ygmax-self%comm%ygmin) + enddo + endif + + end subroutine drifters_modulo + + !============================================================================ +#define _DIMS 2 +#define drifters_set_field_XXX drifters_set_field_2d +#include "drifters_set_field.fh" +#undef _DIMS +#undef drifters_set_field_XXX + + !============================================================================ +#define _DIMS 3 +#define drifters_set_field_XXX drifters_set_field_3d +#include "drifters_set_field.fh" +#undef _DIMS +#undef drifters_set_field_XXX + !============================================================================ + !> @brief Append new positions to NetCDF file. + !! + !> Use this method to append the new trajectory positions and the interpolated + !! probe fields to a netCDF file. + subroutine drifters_save(self, ermesg) + type(drifters_type) :: self !< Opaque daata structure. + character(len=*), intent(out) :: ermesg !< Error message (if any). + + integer nf, np + + ermesg = '' + nf = size(self%input%field_names) + np = self%core%np + + ! save to disk + call drifters_io_write(self%io, self%time, np, self%core%nd, nf, & + & self%core%ids, self%core%positions, & + & fields=self%fields(:,1:np), ermesg=ermesg) + + end subroutine drifters_save + !============================================================================ + + !> @brief Distribute particles across PEs. + !! + !> Use this method after setting the domain boundaries + !! (drifters_set_domain) to spread the particles across PE domains. + subroutine drifters_distribute(self, ermesg) + type(drifters_type) :: self !< Opaque handle. + character(len=*), intent(out) :: ermesg !< Error message (if any). + + real x, y + integer i, nptot, nd + + ermesg = '' + nd = self%core%nd + if(nd < 2) then + ermesg = 'drifters_distribute: dimension must be >=2' + return + endif + + nptot = size(self%input%positions, 2) + do i = 1, nptot + x = self%input%positions(1,i) + y = self%input%positions(2,i) + if(x >= self%comm%xdmin .and. x <= self%comm%xdmax .and. & + & y >= self%comm%ydmin .and. y <= self%comm%ydmax) then + + self%core%np = self%core%np + 1 + self%core%positions(1:nd, self%core%np) = self%input%positions(1:nd, i) + self%core%ids(self%core%np) = i + + endif + enddo + + end subroutine drifters_distribute + + !============================================================================ + !> @brief Write restart file for drifters. + !! + !> Gather all the particle positions distributed + !! across PE domains on root PE and save the data in netCDF file. + subroutine drifters_write_restart(self, filename, & + & x1, y1, geolon1, & + & x2, y2, geolat2, & + & root, mycomm, ermesg) + ! gather all positions and ids and save the result in + ! self%input data structure on PE "root", then write restart file + + type(drifters_type) :: self !< Opaque data structure. + character(len=*), intent(in) :: filename !< Restart file name. + + ! if these optional arguments are passed, the positions will + ! mapped to lon/lat degrees and saved in the file. + real, intent(in), optional :: x1(:) !< Pseudo-longitude axis supporting longitudes. + real, intent(in), optional :: y1(:) !< Pseudo-latitude axis supporting longitudes. + real, intent(in), optional :: geolon1(:,:) !< Longitude array (x1, y1). + real, intent(in), optional :: x2(:) !< Pseudo-longitude axis supporting latitudes. + real, intent(in), optional :: y2(:) !< Pseudo-latitude axis supporting latitudes. + real, intent(in), optional :: geolat2(:,:) !< Latitudes array (x2, y2) + + + integer, intent(in), optional :: root !< root pe + integer, intent(in), optional :: mycomm !< MPI communicator + character(len=*), intent(out) :: ermesg !< Error message (if any). + + integer :: np + logical :: do_save_lonlat + real, allocatable :: lons(:), lats(:) + + ermesg = '' + + np = self%core%np + + allocate(lons(np), lats(np)) + lons = -huge(1.) + lats = -huge(1.) + + ! get lon/lat if asking for + if(present(x1) .and. present(y1) .and. present(geolon1) .and. & + & present(x2) .and. present(y2) .and. present(geolat2)) then + do_save_lonlat = .TRUE. + else + do_save_lonlat = .FALSE. + endif + + if(do_save_lonlat) then + + ! Interpolate positions onto geo longitudes/latitudes + call drifters_positions2lonlat(self, & + & positions=self%core%positions(:,1:np), & + & x1=x1, y1=y1, geolon1=geolon1, & + & x2=x2, y2=y2, geolat2=geolat2, & + & lons=lons, lats=lats, ermesg=ermesg) + if(ermesg/='') return ! problems, bail off + + endif + + call drifters_comm_gather(self%comm, self%core, self%input, & + & lons, lats, do_save_lonlat, & + & filename, & + & root, mycomm) + + end subroutine drifters_write_restart + + !============================================================================ +#define _DIMS 2 +#define drifters_compute_k_XXX drifters_computek2d +#include "drifters_compute_k.fh" +#undef _DIMS +#undef drifters_compute_k_XXX + + !============================================================================ +#define _DIMS 3 +#define drifters_compute_k_XXX drifters_computek3d +#include "drifters_compute_k.fh" +#undef _DIMS +#undef drifters_compute_k_XXX + + + !============================================================================ + !> @brief Set velocity field axes. + !! @details Velocity axis components may be located on different grids or cell faces. For instance, zonal (u) + !! and meridional (v) velcity components are staggered by half a cell size in Arakawa's C and D grids. + !! This call will set individual axes for each components do as to allow interpolation of the velocity + !! field on arbitrary positions. + subroutine drifters_set_v_axes(self, component, x, y, z, ermesg) + type(drifters_type) :: self !< Opaque data structure. + character(len=*), intent(in) :: component !< Velocity component: either 'u', 'v', or 'w'. + real, intent(in) :: x(:) !< X-axis. + real, intent(in) :: y(:) !< Y-axis. + real, intent(in) :: z(:) !< Z-axis. + character(len=*), intent(out) :: ermesg !< Error message (if any). + + integer ier, nx, ny, nz + + ermesg = '' + nx = size(x) + ny = size(y) + nz = size(z) + select case (component(1:1)) + case ('u', 'U') + if(nx > 0) then + deallocate(self%xu, stat=ier) + allocate(self%xu(nx)) + self%xu = x + self%nx = max(self%nx, size(x)) + endif + if(ny > 0) then + deallocate(self%yu, stat=ier) + allocate(self%yu(ny)) + self%yu = y + self%ny = max(self%ny, size(y)) + endif + if(nz > 0) then + deallocate(self%zu, stat=ier) + allocate(self%zu(nz)) + self%zu = z + endif + case ('v', 'V') + if(nx > 0) then + deallocate(self%xv, stat=ier) + allocate(self%xv(nx)) + self%xv = x + self%nx = max(self%nx, size(x)) + endif + if(ny > 0) then + deallocate(self%yv, stat=ier) + allocate(self%yv(ny)) + self%yv = y + self%ny = max(self%ny, size(y)) + endif + if(nz > 0) then + deallocate(self%zv, stat=ier) + allocate(self%zv(nz)) + self%zv = z + endif + case ('w', 'W') + if(nx > 0) then + deallocate(self%xw, stat=ier) + allocate(self%xw(nx)) + self%xw = x + self%nx = max(self%nx, size(x)) + endif + if(ny > 0) then + deallocate(self%yw, stat=ier) + allocate(self%yw(ny)) + self%yw = y + self%ny = max(self%ny, size(y)) + endif + if(nz > 0) then + deallocate(self%zw, stat=ier) + allocate(self%zw(nz)) + self%zw = z + endif + case default + ermesg = 'drifters_set_v_axes: ERROR component must be "u", "v" or "w"' + end select + end subroutine drifters_set_v_axes + + !============================================================================ + !> @brief Set boundaries of "data" and "compute" domains + !! @details Each particle will be tracked sol long is it is located in the data domain. + subroutine drifters_set_domain_bounds(self, domain, backoff_x, backoff_y, ermesg) + type(drifters_type) :: self !< Opaque data structure. + _TYPE_DOMAIN2D :: domain !< Instance of Domain2D (see mpp_domain) + integer, intent(in) :: backoff_x !< particles leaves domain when crossing ied-backoff_x + integer, intent(in) :: backoff_y !< particles leaves domain when crossing jed-backoff_y + character(len=*), intent(out) :: ermesg !< Error message (if any). + + ermesg = '' + + if(.not.allocated(self%xu) .or. .not.allocated(self%yu)) then + ermesg = 'drifters_set_domain_bounds: ERROR "u"-component axes not set' + return + endif + call drifters_comm_set_domain(self%comm, domain, self%xu, self%yu, backoff_x, backoff_y) + if(.not.allocated(self%xv) .or. .not.allocated(self%yv)) then + ermesg = 'drifters_set_domain_bounds: ERROR "v"-component axes not set' + return + endif + if(allocated(self%xw) .and. allocated(self%yw)) then + call drifters_comm_set_domain(self%comm, domain, self%xv, self%yv, backoff_x, backoff_y) + endif + + + end subroutine drifters_set_domain_bounds + + !============================================================================ + !> @brief Interpolates positions onto longitude/latitude grid. + !! @details In many cases, the integrated positions will not be longitudes or latitudes. This call + !! can be ionvoked to recover the longitude/latitude positions from the "logical" positions. + subroutine drifters_positions2lonlat(self, positions, & + & x1, y1, geolon1, & + & x2, y2, geolat2, & + & lons, lats, & + & ermesg) + + type(drifters_type) :: self !< Opaque data structure. + ! Input positions + real, intent(in) :: positions(:,:) !< Logical positions. + ! Input mesh + real, intent(in) :: x1(:) !< X-axis of "geolon1" field. + real, intent(in) :: y1(:) !< Y-axis of "geolon1" field. + real, intent(in) :: geolon1(:,:) !< Y-axis of "geolon1" field. + real, intent(in) :: x2(:) !< X-axis of "geolat2" field. + real, intent(in) :: y2(:) !< Y-axis of "geolat2" field. + real, intent(in) :: geolat2(:,:) !< Latitude field as an array of (x2, y2) + ! Output lon/lat + real, intent(out) :: lons(:) !< Returned longitudes. + real, intent(out) :: lats(:) !< Returned latitudes. + character(len=*), intent(out) :: ermesg !< Error message (if any). + + real fvals(2**self%core%nd), ts(self%core%nd) + integer np, ij(2), ip, ier, n1s(2), n2s(2), i, j, iertot + character(len=10) :: n1_str, n2_str, np_str, iertot_str + + ermesg = '' + lons = -huge(1.) + lats = -huge(1.) + + ! check dimensions + n1s = (/size(x1), size(y1)/) + n2s = (/size(x2), size(y2)/) + if(n1s(1) /= size(geolon1, 1) .or. n1s(2) /= size(geolon1, 2)) then + ermesg = 'drifters_positions2geolonlat: ERROR incompatibles dims between (x1, y1, geolon1)' + return + endif + if(n2s(1) /= size(geolat2, 1) .or. n2s(2) /= size(geolat2, 2)) then + ermesg = 'drifters_positions2geolonlat: ERROR incompatibles dims between (x2, y2, geolat2)' + return + endif + + np = size(positions, 2) + if(size(lons) < np .or. size(lats) < np) then + write(np_str, '(i10)') np + write(n1_str, '(i10)') size(lons) + write(n2_str, '(i10)') size(lats) + ermesg = 'drifters_positions2geolonlat: ERROR size of "lons" ('//trim(n1_str)// & + & ') or "lats" ('//trim(n2_str)//') < '//trim(np_str) + return + endif + + ! Interpolate + iertot = 0 + do ip = 1, np + + ! get longitude + call cld_ntrp_locate_cell(x1, positions(1,ip), i, ier) + iertot = iertot + ier + call cld_ntrp_locate_cell(y1, positions(2,ip), j, ier) + iertot = iertot + ier + ij(1) = i; ij(2) = j; + call cld_ntrp_get_cell_values(n1s, _FLATTEN(geolon1), ij, fvals, ier) + iertot = iertot + ier + ts(1) = (positions(1,ip) - x1(i))/(x1(i+1) - x1(i)) + ts(2) = (positions(2,ip) - y1(j))/(y1(j+1) - y1(j)) + call cld_ntrp_linear_cell_interp(fvals, ts, lons(ip), ier) + iertot = iertot + ier + + ! get latitude + call cld_ntrp_locate_cell(x2, positions(1,ip), i, ier) + iertot = iertot + ier + call cld_ntrp_locate_cell(y2, positions(2,ip), j, ier) + iertot = iertot + ier + ij(1) = i; ij(2) = j; + call cld_ntrp_get_cell_values(n2s, _FLATTEN(geolat2), ij, fvals, ier) + iertot = iertot + ier + ts(1) = (positions(1,ip) - x2(i))/(x2(i+1) - x2(i)) + ts(2) = (positions(2,ip) - y2(j))/(y2(j+1) - y2(j)) + call cld_ntrp_linear_cell_interp(fvals, ts, lats(ip), ier) + iertot = iertot + ier + + enddo + + if(iertot /= 0) then + write(iertot_str, '(i10)') iertot + ermesg = 'drifters_positions2geolonlat: ERROR '//trim(iertot_str)// & + & ' interpolation errors (domain out of bounds?)' + endif + + end subroutine drifters_positions2lonlat + + !============================================================================ + !> @brief Print Runge-Kutta check sums. Useful for debugging only. + subroutine drifters_print_checksums(self, pe, ermesg) + + type(drifters_type) :: self !< Opaque handle. + integer, intent(in), optional :: pe !< Processor element. + character(len=*), intent(out) :: ermesg !< Error message (if any). + + integer, parameter :: i8 = selected_int_kind(13) + integer(i8) :: mold, chksum_pos, chksum_k1, chksum_k2, chksum_k3, chksum_k4 + integer(i8) :: chksum_tot + integer nd, np, me + + ermesg = '' + + if(.not. present(pe)) then + me = _MPP_PE + else + me = pe + endif + + if(me == _MPP_PE) then + + nd = self%core%nd + np = self%core%np + chksum_pos = transfer(sum(sum(self%core%positions(1:nd,1:np),1)), mold) + chksum_k1 = transfer(sum(sum(self%rk4_k1(1:nd,1:np),1)), mold) + chksum_k2 = transfer(sum(sum(self%rk4_k2(1:nd,1:np),1)), mold) + chksum_k3 = transfer(sum(sum(self%rk4_k3(1:nd,1:np),1)), mold) + chksum_k4 = transfer(sum(sum(self%rk4_k4(1:nd,1:np),1)), mold) + chksum_tot = chksum_pos + chksum_k1 + chksum_k2 + chksum_k3 +chksum_k4 + + print *,'==============drifters checksums==========================' + print '(a,i25,a,i6,a,e15.7)','==positions: ', chksum_pos, ' PE=', me, ' time = ', self%time + print '(a,i25,a,i6,a,e15.7)','==k1 : ', chksum_k1, ' PE=', me, ' time = ', self%time + print '(a,i25,a,i6,a,e15.7)','==k2 : ', chksum_k2, ' PE=', me, ' time = ', self%time + print '(a,i25,a,i6,a,e15.7)','==k3 : ', chksum_k3, ' PE=', me, ' time = ', self%time + print '(a,i25,a,i6,a,e15.7)','==k4 : ', chksum_k4, ' PE=', me, ' time = ', self%time + print '(a,i25,a,i6,a,e15.7)','==total : ', chksum_tot, ' PE=', me, ' time = ', self%time + + endif + + end subroutine drifters_print_checksums + + subroutine drifters_reset_rk4(self, ermesg) + type(drifters_type) :: self + character(len=*), intent(out) :: ermesg + + integer ier, nd + + ermesg = '' + + if(size(self%rk4_k1, 2) < self%core%np) then + deallocate(self%rk4_k1, stat=ier) + allocate(self%rk4_k1(self%core%nd, self%core%npdim)) + self%rk4_k1 = 0 + endif + if(size(self%rk4_k2, 2) < self%core%np) then + deallocate(self%rk4_k2, stat=ier) + allocate(self%rk4_k2(self%core%nd, self%core%npdim)) + self%rk4_k2 = 0 + endif + if(size(self%rk4_k3, 2) < self%core%np) then + deallocate(self%rk4_k3, stat=ier) + allocate(self%rk4_k3(self%core%nd, self%core%npdim)) + self%rk4_k3 = 0 + endif + if(size(self%rk4_k4, 2) < self%core%np) then + deallocate(self%rk4_k4, stat=ier) + allocate(self%rk4_k4(self%core%nd, self%core%npdim)) + self%rk4_k4 = 0 + endif + + if(size(self%remove) < self%core%np) then + deallocate(self%remove, stat=ier) + allocate(self%remove(self%core%npdim)) + self%remove = .FALSE. + endif + + if(size(self%temp_pos, 2) < self%core%np) then + deallocate(self%temp_pos, stat=ier) + nd = size(self%input%velocity_names) + allocate(self%temp_pos(nd, self%core%npdim)) + self%temp_pos = -huge(1.) + endif + + end subroutine drifters_reset_rk4 + +end module drifters_mod +!> @} +! close documentation grouping diff --git a/drifters/include/drifters_comm.inc b/drifters/include/drifters_comm.inc new file mode 100644 index 0000000000..5319e19934 --- /dev/null +++ b/drifters/include/drifters_comm.inc @@ -0,0 +1,776 @@ +!*********************************************************************** +!* 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 "fms_switches.h" + +!> @defgroup drifters_comm_mod drifters_comm_mod +!> @ingroup drifters +!> @brief Routines and types to update drifter positions across processor domains + +module drifters_comm_mod + +#ifdef _SERIAL + +#define _TYPE_DOMAIN2D integer +#define _NULL_PE 0 + +#else + + use mpp_mod, only : NULL_PE, FATAL, NOTE, mpp_error, mpp_pe, mpp_npes + use mpp_mod, only : mpp_root_pe + use mpp_mod, only : mpp_send, mpp_recv, mpp_sync_self + use mpp_mod, only : COMM_TAG_1, COMM_TAG_2, COMM_TAG_3, COMM_TAG_4 + use mpp_domains_mod, only : domain2D + use mpp_domains_mod, only : mpp_get_neighbor_pe, mpp_define_domains, mpp_get_layout + use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain + use mpp_domains_mod, only : NORTH, SOUTH, EAST, WEST, CYCLIC_GLOBAL_DOMAIN + use mpp_domains_mod, only : NORTH_EAST, SOUTH_EAST, SOUTH_WEST, NORTH_WEST + +#define _TYPE_DOMAIN2D type(domain2d) +#define _NULL_PE NULL_PE + +#endif + + use drifters_core_mod, only: drifters_core_type, drifters_core_remove_and_add, drifters_core_set_positions + + implicit none + private + + public :: drifters_comm_type, drifters_comm_new, drifters_comm_del, drifters_comm_set_pe_neighbors + public :: drifters_comm_set_domain, drifters_comm_update, drifters_comm_gather + + !> Type for drifter communication between PE's + !> @ingroup drifters_comm_mod + type :: drifters_comm_type + real :: xcmin !< compute domain + real :: xcmax !< compute domain + real :: ycmin !< compute domain + real :: ycmax !< compute domain + real :: xdmin !< data domain + real :: xdmax !< data domain + real :: ydmin !< data domain + real :: ydmax !< data domain + real :: xgmin !< global valid min/max + real :: xgmax !< global valid min/max + real :: ygmin !< global valid min/max + real :: ygmax !< global valid min/max + logical :: xperiodic !< x/y period (can be be nearly infinite) + logical :: yperiodic !< x/y period (can be be nearly infinite) + integer :: pe_N !< neighbor domains + integer :: pe_S !< neighbor domains + integer :: pe_E !< neighbor domains + integer :: pe_W !< neighbor domains + integer :: pe_NE !< neighbor domains + integer :: pe_SE !< neighbor domains + integer :: pe_SW !< neighbor domains + integer :: pe_NW !< neighbor domains + integer :: pe_beg !< starting/ending pe, set this to a value /= 0 if running concurrently + integer :: pe_end !< starting/ending pe, set this to a value /= 0 if running concurrently + end type drifters_comm_type + +contains + +!> @addtogroup drifters_comm_mod +!> @{ +!=============================================================================== + !> @brief Initializes default values for @ref drifters_comm_type in self + subroutine drifters_comm_new(self) + type(drifters_comm_type) :: self !< A new @ref drifters_comm_type + + self%xcmin = -huge(1.); self%xcmax = +huge(1.) + self%ycmin = -huge(1.); self%ycmax = +huge(1.) + + self%xdmin = -huge(1.); self%xdmax = +huge(1.) + self%ydmin = -huge(1.); self%ydmax = +huge(1.) + + self%xgmin = -huge(1.); self%xgmax = +huge(1.) + self%ygmin = -huge(1.); self%ygmax = +huge(1.) + + self%xperiodic = .FALSE.; self%yperiodic = .FALSE. + + self%pe_N = _NULL_PE + self%pe_S = _NULL_PE + self%pe_E = _NULL_PE + self%pe_W = _NULL_PE + self%pe_NE = _NULL_PE + self%pe_SE = _NULL_PE + self%pe_SW = _NULL_PE + self%pe_NW = _NULL_PE + + self%pe_beg = 0 + self%pe_end = -1 + + + end subroutine drifters_comm_new + +!=============================================================================== + !> @brief Reset data in a given @ref drifters_comm_type to defaults + subroutine drifters_comm_del(self) + type(drifters_comm_type) :: self !< A @ref drifters_comm_type to reset + + ! nothing to deallocate + call drifters_comm_new(self) + + end subroutine drifters_comm_del + +!=============================================================================== + !> @brief Set data domain bounds. + subroutine drifters_comm_set_data_bounds(self, xmin, ymin, xmax, ymax) + ! Set data domain bounds. + type(drifters_comm_type) :: self + real, intent(in) :: xmin, ymin, xmax, ymax + + self%xdmin = max(xmin, self%xdmin) + self%xdmax = min(xmax, self%xdmax) + self%ydmin = max(ymin, self%ydmin) + self%ydmax = min(ymax, self%ydmax) + + end subroutine drifters_comm_set_data_bounds + +!=============================================================================== + !> @brief Set compute domain bounds. + subroutine drifters_comm_set_comp_bounds(self, xmin, ymin, xmax, ymax) + ! Set compute domain bounds. + type(drifters_comm_type) :: self + real, intent(in) :: xmin, ymin, xmax, ymax + + self%xcmin = max(xmin, self%xcmin) + self%xcmax = min(xmax, self%xcmax) + self%ycmin = max(ymin, self%ycmin) + self%ycmax = min(ymax, self%ycmax) + + end subroutine drifters_comm_set_comp_bounds + +!=============================================================================== + !> @brief Set neighboring pe numbers. + subroutine drifters_comm_set_pe_neighbors(self, domain) + ! Set neighboring pe numbers. + type(drifters_comm_type) :: self !< Drifters communication type to set pe numbers for + _TYPE_DOMAIN2D, intent(inout) :: domain !< domain to get neighboring PE's from + +#ifndef _SERIAL +! parallel code + + integer :: pe_N, pe_S, pe_E, pe_W, pe_NE, pe_SE, pe_SW, pe_NW + + call mpp_get_neighbor_pe(domain, NORTH , pe_N ) + call mpp_get_neighbor_pe(domain, NORTH_EAST, pe_NE) + call mpp_get_neighbor_pe(domain, EAST , pe_E ) + call mpp_get_neighbor_pe(domain, SOUTH_EAST, pe_SE) + call mpp_get_neighbor_pe(domain, SOUTH , pe_S ) + call mpp_get_neighbor_pe(domain, SOUTH_WEST, pe_SW) + call mpp_get_neighbor_pe(domain, WEST , pe_W ) + call mpp_get_neighbor_pe(domain, NORTH_WEST, pe_NW) + + if(pe_N /= self%pe_N .and. self%pe_N == _NULL_PE) then + self%pe_N = pe_N + else if(pe_N /= self%pe_N ) then + call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: NORTH PE changed!.') + endif + if(pe_NE /= self%pe_NE .and. self%pe_NE == _NULL_PE) then + self%pe_NE = pe_NE + else if(pe_NE /= self%pe_NE) then + call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: NORTH-EAST PE changed!.') + endif + if(pe_E /= self%pe_E .and. self%pe_E == _NULL_PE) then + self%pe_E = pe_E + else if(pe_E /= self%pe_E ) then + call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: EAST PE changed!.') + endif + if(pe_SE /= self%pe_SE .and. self%pe_SE == _NULL_PE) then + self%pe_SE = pe_SE + else if(pe_SE /= self%pe_SE) then + call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: SOUTH-EAST PE changed!.') + endif + if(pe_S /= self%pe_S .and. self%pe_S == _NULL_PE) then + self%pe_S = pe_S + else if(pe_S /= self%pe_S ) then + call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: SOUTH PE changed!.') + endif + if(pe_SW /= self%pe_SW .and. self%pe_SW == _NULL_PE) then + self%pe_SW = pe_SW + else if(pe_SW /= self%pe_SW) then + call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: SOUTH-WEST PE changed!.') + endif + if(pe_W /= self%pe_W .and. self%pe_W == _NULL_PE) then + self%pe_W = pe_W + else if(pe_W /= self%pe_W ) then + call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: WEST PE changed!.') + endif + if(pe_NW /= self%pe_NW .and. self%pe_NW == _NULL_PE) then + self%pe_NW = pe_NW + else if(pe_NW /= self%pe_NW) then + call mpp_error( FATAL, 'drifters_comm_set_pe_neighbors: NORTH-WEST PE changed!.') + endif + +#endif +! end of parallel code + + end subroutine drifters_comm_set_pe_neighbors + +!=============================================================================== + !> @brief Set boundaries of domain and compute neighbors. This method can be called + !! multiple times; the data domain will just be the intersection (overlap) of + !! all domains (e.g domain_u, domain_v, etc). + subroutine drifters_comm_set_domain(self, domain, x, y, backoff_x, backoff_y) + ! Set boundaries of domain and compute neighbors. This method can be called + ! multiple times; the data domain will just be the intersection (overlap) of + ! all domains (e.g domain_u, domain_v, etc). + type(drifters_comm_type) :: self + _TYPE_DOMAIN2D, intent(inout) :: domain + real, intent(in) :: x(:) !< global axes + real, intent(in) :: y(:) !< global axes + integer, intent(in) :: backoff_x !< >=0, data domain is reduced by "backoff_x,y" indices in x, resp. y + integer, intent(in) :: backoff_y !< >=0, data domain is reduced by "backoff_x,y" indices in x, resp. y + + ! compute/data domain start/end indices + integer :: isc !< compute domain start/end indices + integer :: iec !< compute domain start/end indices + integer :: jsc !< compute domain start/end indices + integer :: jec !< compute domain start/end indices + integer :: isd !< data domain start/end indices + integer :: ied !< data domain start/end indices + integer :: jsd !< data domain start/end indices + integer :: jed !< data domain start/end indices + integer nx, ny, hx, hy, bckf_x, bckf_y, halox, haloy + real dx, dy, xdmin, xdmax, ydmin, ydmax + +#ifdef _SERIAL + integer :: ibnds(1) + + ibnds = lbound(x); isc = ibnds(1) + ibnds = ubound(x); iec = ibnds(1) - 1 + ibnds = lbound(y); jsc = ibnds(1) + ibnds = ubound(y); jec = ibnds(1) - 1 +#else + call mpp_get_compute_domain( domain, isc, iec, jsc, jec ) +#endif + + self%xcmin = max(x(isc), self%xcmin) + self%xcmax = min(x(iec), self%xcmax) + self%ycmin = max(y(jsc), self%ycmin) + self%ycmax = min(y(jec), self%ycmax) + + nx = iec - isc + 1 + ny = jec - jsc + 1 + +#ifdef _SERIAL + isd = 1; ied = size(x); jsd = 1; jed = size(y) +#else + call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) +#endif + + hx = max(ied-iec, isc-isd) + hy = max(jed-jec, jsc-jsd) + bckf_x = min(backoff_x, hx) + bckf_y = min(backoff_y, hy) + + halox = max(0, hx - bckf_x) + haloy = max(0, hy - bckf_y) + + if(isd < 1) then + dx = x(2) - x(1) + xdmin = self%xcmin - dx*halox + else + xdmin = x(isd+bckf_x) + endif + + if(ied > nx) then + dx = x(nx) - x(nx-1) + xdmax = self%xcmax + dx*halox + else + xdmax = x(ied-bckf_x) + endif + + if(jsd < 1) then + dy = y(2) - y(1) + ydmin = self%ycmin - dy*haloy + else + ydmin = y(jsd+bckf_y) + endif + + if(jed > ny) then + dy = y(ny) - y(ny-1) + ydmax = self%ycmax + dy*haloy + else + ydmax = y(jed-bckf_y) + endif + + self%xdmin = max(xdmin, self%xdmin) + self%ydmin = max(ydmin, self%ydmin) + self%xdmax = min(xdmax, self%xdmax) + self%ydmax = min(ydmax, self%ydmax) + + call drifters_comm_set_pe_neighbors(self, domain) + + end subroutine drifters_comm_set_domain + +!=============================================================================== + !> Updates drifter communication + subroutine drifters_comm_update(self, drfts, new_positions, & + & comm, remove, max_add_remove) +#ifndef _SERIAL + use mpi +#endif + + type(drifters_comm_type) :: self + type(drifters_core_type) :: drfts + real, intent(inout) :: new_positions(:,:) + integer, intent(in), optional :: comm !< MPI communicator + logical, intent(in), optional :: remove(:) !< Set to True for particles that should be removed + integer, intent(in), optional :: max_add_remove !< max no of particles to add/remove + +#ifdef _SERIAL +! serial code + + drfts%positions(:, 1:drfts%np) = new_positions(:, 1:drfts%np) + return + +#else +! parallel code + integer nd, np, nar_est, ip, neigh_pe, irem, pe, npes, ntuples + integer ntuples_tot, ndata, mycomm +#ifdef _USE_MPI + integer ier +#endif + integer, allocatable :: iadd(:) + integer, allocatable :: table_recv(:), table_send(:) + real , allocatable :: data_recv(:,:), data_send(:,:) + integer, allocatable :: indices_to_remove(:) + integer, allocatable :: ids_to_add(:) + real , allocatable :: positions_to_add(:,:) + real :: x, y, xold, yold + character(len=128) :: ermsg, notemsg + logical :: is_present + integer :: id, j, k, m, n, el + logical :: crossed_W, crossed_E, crossed_S, crossed_N + logical :: was_in_compute_domain, left_domain + + mycomm = MPI_COMM_WORLD + if( present(comm) ) mycomm = comm + + nd = drfts%nd + np = size(new_positions,2) + if(np > 0 .and. nd < 2) call mpp_error( FATAL, & + & 'drifters_comm_update: number of dimensions must be 2 or higher.' ) + + nar_est = 100 + if(present(max_add_remove)) nar_est = max(1, max_add_remove) + + pe = mpp_pe() + npes = mpp_npes() + + ! assume pe list is contiguous, self%pe_beg...self%pe_end + allocate(iadd(self%pe_beg:self%pe_end)) + allocate(table_recv(self%pe_beg:self%pe_end)) + allocate(table_send(self%pe_beg:self%pe_end)) + allocate(data_recv(nar_est*(1+nd), self%pe_beg:self%pe_end)) + allocate(data_send(nar_est*(1+nd), self%pe_beg:self%pe_end)) + allocate(indices_to_remove(nar_est)) + + table_send = 0 + table_recv = 0 + data_send = 0 + data_recv = 0 + + iadd = 0 + irem = 0 + do ip = 1, np + x = new_positions(1, ip) + y = new_positions(2, ip) + xold = drfts%positions(1, ip) + yold = drfts%positions(2, ip) + + if( xoldself%xcmax .or. & + & yoldself%ycmax ) then + was_in_compute_domain = .FALSE. + else + was_in_compute_domain = .TRUE. + endif + + ! check if drifters crossed compute domain boundary + + crossed_W = .FALSE. + crossed_E = .FALSE. + crossed_S = .FALSE. + crossed_N = .FALSE. + if( was_in_compute_domain .and. & + & (xself%xcmin) ) crossed_W = .TRUE. + if( was_in_compute_domain .and. & + & (x>self%xcmax) .and. (xoldself%ycmin) ) crossed_S = .TRUE. + if( was_in_compute_domain .and. & + & (y>self%ycmax) .and. (yold nar_est) then + write(notemsg, '(a,i4,a,i4,a)') 'drifters_comm_update: exceeded nar_est (', & + & iadd(neigh_pe),'>',nar_est,').' + call mpp_error( FATAL, notemsg) + endif + table_send(neigh_pe) = table_send(neigh_pe) + 1 + k = ( iadd(neigh_pe)-1 )*(1+nd) + 1 + data_send(k , neigh_pe) = drfts%ids(ip) + data_send(k+1:k+nd, neigh_pe) = new_positions(:,ip) + endif + + ! check if drifters left data domain + + left_domain = .FALSE. + if( (xself%xdmax .and. (self%pe_E/=pe)) .or. & + & (yself%ydmax .and. (self%pe_N/=pe)) ) then + left_domain = .TRUE. + endif + + ! remove if particle was tagged as such + + if(present(remove)) then + if(remove(ip)) left_domain = .TRUE. + endif + + if(left_domain) then + irem = irem + 1 + if(irem > nar_est) then + write(notemsg, '(a,i4,a,i4,a)') 'drifters_comm_update: exceeded nar_est (',& + & irem,'>',nar_est,').' + call mpp_error( FATAL, notemsg) + endif + indices_to_remove(irem) = ip + endif + + enddo + + + ! update drifters' positions (remove whatever needs to be removed later) + call drifters_core_set_positions(drfts, new_positions, ermsg) + if(ermsg/='') call mpp_error( FATAL, ermsg) + + ! fill in table_recv from table_send. table_send contains the + ! number of tuples that will be sent to another pe. table_recv + ! will contain the number of tuples to be received. The indices + ! of table_send refer to the pe where the tuples should be sent to; + ! the indices of table_recv refer to the pe number + ! (self%pe_beg..self%pe_end) from + ! which the tuple should be received from. + ! + ! table_send(to_pe) = ntuples; table_recv(from_pe) = ntuples + + ! the following is a transpose operation + ! table_send(m)[pe] -> table_recv(pe)[m] + do m = self%pe_beg, self%pe_end +#ifdef _USE_MPI + call MPI_Scatter (table_send , 1, MPI_INTEGER, & + & table_recv(m), 1, MPI_INTEGER, & + & m, mycomm, ier ) +#else + if(pe==m) then + do k = self%pe_beg, self%pe_end + call mpp_send(table_send(k), plen=1, to_pe=k, tag=COMM_TAG_1) + enddo + endif + call mpp_recv(table_recv(m), glen=1, from_pe=m, tag=COMM_TAG_1) +#endif + enddo + + ! communicate new positions. data_send is an array of size n*(nd+1) times npes. + ! Each column j of data_send contains the tuple (id, x, y, ..) to be sent to pe=j. + ! Inversely, data_recv's column j contains tuples (id, x, y,..) received from pe=j. + do m = self%pe_beg, self%pe_end + ntuples = table_send(m) + ndata = ntuples*(nd+1) + ! should be able to send ndata? +#ifdef _USE_MPI + call MPI_Scatter (data_send , nar_est*(1+nd), MPI_REAL8, & + & data_recv(1,m), nar_est*(1+nd), MPI_REAL8, & + & m, mycomm, ier ) +#else + if(pe==m) then + do k = self%pe_beg, self%pe_end + call mpp_send(data_send(1,k), plen=nar_est*(1+nd), to_pe=k, tag=COMM_TAG_2) + enddo + endif + call mpp_recv(data_recv(1,m), glen=nar_est*(1+nd), from_pe=m, tag=COMM_TAG_2) +#endif + enddo + + ! total number of tuples will determine size of ids_to_add/positions_to_add + ntuples_tot = 0 + do m = self%pe_beg, self%pe_end + ntuples_tot = ntuples_tot + table_recv(m) + enddo + + allocate(positions_to_add(nd, ntuples_tot)) + allocate( ids_to_add( ntuples_tot)) + + ! fill positions_to_add and ids_to_add. + k = 0 + do m = self%pe_beg, self%pe_end + ! get ids/positions coming from all pes + do n = 1, table_recv(m) + ! iterate over all ids/positions coming from pe=m + el = (n-1)*(nd+1) + 1 + id = int(data_recv(el, m)) + ! only add if id not already present in drfts + ! this can happen if a drifter meanders about + ! the compute domain boundary + is_present = .false. + do j = 1, drfts%np + if(id == drfts%ids(j)) then + is_present = .true. + write(notemsg, '(a,i4,a)') 'Drifter ', id, ' already advected (will not be added).' + call mpp_error(NOTE, notemsg) + exit + endif + enddo + if(.not. is_present) then + k = k + 1 + ids_to_add(k) = id + + positions_to_add(1:nd, k) = data_recv(el+1:el+nd, m) + + endif + enddo + enddo + + ! remove and add + if(irem > 0 .or. k > 0) then + write(notemsg, '(i4,a,i4,a)') irem, ' drifter(s) will be removed, ', k,' will be added' + call mpp_error(NOTE, notemsg) +!!$ if(k>0) print *,'positions to add ', positions_to_add(:,1:k) +!!$ if(irem>0) print *,'ids to remove: ', indices_to_remove(1:irem) + endif + call drifters_core_remove_and_add(drfts, indices_to_remove(1:irem), & + & ids_to_add(1:k), positions_to_add(:,1:k), ermsg) + if(ermsg/='') call mpp_error( FATAL, ermsg) + +#ifndef _USE_MPI + ! make sure unbuffered mpp_isend call returned before deallocating + call mpp_sync_self() +#endif + + deallocate(ids_to_add) + deallocate(positions_to_add) + + deallocate(iadd) + deallocate(table_recv) + deallocate(table_send) + deallocate(data_recv) + deallocate(data_send) + deallocate(indices_to_remove) + +#endif +! end of parallel code + + end subroutine drifters_comm_update + +!=============================================================================== + subroutine drifters_comm_gather(self, drfts, dinp, & + & lons, lats, do_save_lonlat, & + & filename, & + & root, mycomm) + +#ifndef _SERIAL + use mpi +#endif + use drifters_input_mod, only : drifters_input_type, drifters_input_save + + type(drifters_comm_type) :: self + type(drifters_core_type) :: drfts + type(drifters_input_type) :: dinp + real, intent(in) :: lons(:), lats(:) + logical, intent(in) :: do_save_lonlat + character(len=*), intent(in) :: filename + integer, intent(in), optional :: root !< root pe + integer, intent(in), optional :: mycomm !< MPI communicator + + character(len=128) :: ermesg + +#ifdef _SERIAL +! serial code + + dinp%ids(1:drfts%np) = drfts%ids(1:drfts%np) + dinp%positions(:, 1:drfts%np) = drfts%positions(:, 1:drfts%np) + + if(do_save_lonlat) then + + call drifters_input_save(dinp, filename=filename, & + & geolon=lons, geolat=lats, ermesg=ermesg) + + else + + call drifters_input_save(dinp, filename=filename, ermesg=ermesg) + + endif + +#else +! parallel code + + + integer :: npf, ip, comm, root_pe, pe, npes, nd, np, npdim, npmax, ier, nptot + integer :: i, j, k, kk + integer, allocatable :: nps(:) + real :: x, y + real, allocatable :: lons0(:), lats0(:), recvbuf(:,:) + real :: data(drfts%nd+3, drfts%np) + + comm = MPI_COMM_WORLD + if(present(mycomm)) comm = mycomm + + root_pe = mpp_root_pe() + if(present(root)) root_pe = root + + pe = mpp_pe() + npes = mpp_npes() + + nd = drfts%nd + np = drfts%np + npdim = drfts%npdim + + allocate(nps(self%pe_beg:self%pe_end)) + nps = 0 + + ! npf= number of drifters in compute domain + + npf = 0 + do ip = 1, np + x = drfts%positions(1, ip) + y = drfts%positions(2, ip) + if( x <= self%xcmax .and. x >= self%xcmin .and. & + & y <= self%ycmax .and. y >= self%ycmin) then + npf = npf + 1 + data(1 , npf) = real(drfts%ids(ip)) + data(1+1:1+nd, npf) = drfts%positions(:, ip) + data( 2+nd, npf) = lons(ip) + data( 3+nd, npf) = lats(ip) + endif + enddo + + ! gather number of drifters +#ifdef _USE_MPI + call mpi_gather(npf, 1, MPI_INT, & + & nps, 1, MPI_INT, & + & root_pe, comm, ier) + !!if(ier/=0) ermesg = 'drifters_write_restart: ERROR while gathering "npf"' +#else + call mpp_send(npf, plen=1, to_pe=root_pe, tag=COMM_TAG_3) + if(pe==root_pe) then + do i = self%pe_beg, self%pe_end + call mpp_recv(nps(i), glen=1, from_pe=i, tag=COMM_TAG_3) + enddo + endif +#endif + + ! Now we know the max number of drifters to expect from each PE, so allocate + ! recvbuf (first dim will be zero on all PEs except root). + + ! allocate recvbuf to receive all the data on root PE, strided by npmax*(nd+3) + npmax = maxval(nps) + allocate(recvbuf(npmax*(nd+3), self%pe_beg:self%pe_end)) + recvbuf = -1 + + ! Each PE sends data to recvbuf on root_pe. +#ifdef _USE_MPI + call mpi_gather( data , npf*(nd+3), MPI_REAL8, & + & recvbuf, npmax*(nd+3), MPI_REAL8, & + & root_pe, comm, ier) + !!if(ier/=0) ermesg = 'drifters_write_restart: ERROR while gathering "data"' +#else + if(npf > 0) call mpp_send(data(1,1), plen=npf*(nd+3), to_pe=root_pe, tag=COMM_TAG_4) + if(pe==root_pe) then + do i = self%pe_beg, self%pe_end + if(nps(i) > 0) call mpp_recv(recvbuf(1, i), glen=nps(i)*(nd+3), from_pe=i, tag=COMM_TAG_4) + enddo + endif +#endif + + ! Set positions and ids + if(pe == root_pe) then + ! check dims + nptot = sum(nps) ! total number of drifters, across al PEs + if(nptot /= size(dinp%ids)) then + deallocate(dinp%ids , stat=ier) + deallocate(dinp%positions, stat=ier) + allocate(dinp%ids(nptot)) + allocate(dinp%positions(nd, nptot)) + dinp%ids = -1 + dinp%positions = -huge(1.) + endif + + allocate(lons0(nptot), lats0(nptot)) + + ! Set the new positions/ids in dinp, on PE=root. Also set + ! lons/lats, these arrays will hold garbage if x1, y1, etc. were + ! not passed as subroutine arguments, that's ok 'cause we won't + ! save them. + j = 1 + do i = self%pe_beg, self%pe_end + do k = 1, nps(i) + kk = (nd+3)*(k-1) + dinp%ids(j) = int(recvbuf(kk+1 , i)) + dinp%positions(1:nd, j) = recvbuf(kk+1+1:kk+1+nd, i) + lons0(j) = recvbuf(kk+2+nd, i) + lats0(j) = recvbuf(kk+3+nd, i) + j = j + 1 + enddo + enddo + + if(do_save_lonlat) then + + call drifters_input_save(dinp, filename=filename, & + & geolon=lons0, geolat=lats0, ermesg=ermesg) + + else + + call drifters_input_save(dinp, filename=filename, ermesg=ermesg) + + endif + + deallocate(lons0, lats0) + + endif + +#ifndef _USE_MPI + call mpp_sync_self() +#endif + deallocate(nps , stat=ier) + deallocate(recvbuf, stat=ier) + +#endif +! _end of parallel code + + end subroutine drifters_comm_gather + + +end module drifters_comm_mod + +!=============================================================================== +!=============================================================================== diff --git a/drifters/include/drifters_core.inc b/drifters/include/drifters_core.inc new file mode 100644 index 0000000000..c25dd85e54 --- /dev/null +++ b/drifters/include/drifters_core.inc @@ -0,0 +1,279 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @defgroup drifters_core_mod drifters_core_mod +!> @ingroup drifters +!> @brief Handles the mechanics for adding and removing drifters + +module drifters_core_mod + use platform_mod + implicit none + private + + public :: drifters_core_type, drifters_core_new, drifters_core_del, drifters_core_set_ids + public :: drifters_core_remove_and_add, drifters_core_set_positions, assignment(=) + public :: drifters_core_print, drifters_core_resize + + ! Globals + integer, parameter, private :: MAX_STR_LEN = 128 +! Include variable "version" to be written to log file. +#include + + !> @brief Core data needed for drifters. + !! Be sure to update drifters_core_new, drifters_core_del and drifters_core_copy_new + !! when adding members. + !> @ingroup drifters_core_mod + type drifters_core_type + integer(kind=i8_kind) :: it !< time index + integer :: nd !< number of dimensions + integer :: np !< number of particles (drifters) + integer :: npdim !< max number of particles (drifters) + integer, allocatable :: ids(:) !< particle id number + real , allocatable :: positions(:,:) + end type drifters_core_type + + !> @brief Assignment override for @ref drifters_core_type + !> @ingroup drifters_core_mod + interface assignment(=) + module procedure drifters_core_copy_new + end interface + +contains + +!> @addtogroup drifters_core_mod +!> @{ +!############################################################################### + !> Create a new @ref drifters_core_type + subroutine drifters_core_new(self, nd, npdim, ermesg) + type(drifters_core_type) :: self !< @ref drifters_core_type to create + integer, intent(in) :: nd + integer, intent(in) :: npdim + character(*), intent(out) :: ermesg !< Error message string + integer ier, iflag, i + ermesg = '' + ier = 0 + + call drifters_core_del(self, ermesg) + + allocate(self%positions(nd, npdim), stat=iflag) + if(iflag/=0) ier = ier + 1 + self%positions = 0. + + allocate(self%ids(npdim), stat=iflag) + if(iflag/=0) ier = ier + 1 + self%ids = (/(i, i=1,npdim)/) + + self%nd = nd + self%npdim = npdim + + if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_new' + end subroutine drifters_core_new + + !############################################################################### + !> Deallocates the given @ref drifters_core_type + subroutine drifters_core_del(self, ermesg) + type(drifters_core_type) :: self !< @ref drifters_core_type to delete + character(*), intent(out) :: ermesg !< Error message string + integer ier, iflag + ermesg = '' + ier = 0 + self%it = 0 + self%nd = 0 + self%np = 0 + iflag = 0 + if(allocated(self%positions)) deallocate(self%positions, stat=iflag) + if(iflag/=0) ier = ier + 1 + if(allocated(self%ids)) deallocate(self%ids, stat=iflag) + if(iflag/=0) ier = ier + 1 + + if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_del' + end subroutine drifters_core_del + + !############################################################################### + subroutine drifters_core_copy_new(new_instance, old_instance) + + type(drifters_core_type), intent(inout) :: new_instance + type(drifters_core_type), intent(in) :: old_instance + + character(len=MAX_STR_LEN) :: ermesg + + ermesg = '' + call drifters_core_del(new_instance, ermesg) + if(ermesg/='') return + ! this should provide the right behavior for both pointers and allocatables + new_instance%it = old_instance%it + new_instance%nd = old_instance%nd + new_instance%np = old_instance%np + new_instance%npdim = old_instance%npdim + allocate(new_instance%ids( size(old_instance%ids) )) + new_instance%ids = old_instance%ids + allocate(new_instance%positions( size(old_instance%positions,1), & + & size(old_instance%positions,2) )) + new_instance%positions = old_instance%positions + + end subroutine drifters_core_copy_new + !############################################################################### + subroutine drifters_core_resize(self, npdim, ermesg) + type(drifters_core_type) :: self + integer, intent(in) :: npdim !< new max value + character(*), intent(out) :: ermesg + integer ier, iflag, i + + real , allocatable :: positions(:,:) + integer, allocatable :: ids(:) + + ermesg = '' + ier = 0 + if(npdim <= self%npdim) return + + ! temps + allocate(positions(self%nd, self%np), stat=iflag) + allocate( ids(self%np), stat=iflag) + + positions = self%positions(:, 1:self%np) + ids = self%ids(1:self%np) + + deallocate(self%positions, stat=iflag) + deallocate(self%ids , stat=iflag) + + allocate(self%positions(self%nd, npdim), stat=iflag) + allocate(self%ids(npdim), stat=iflag) + self%positions = 0.0 + ! default id numbers + self%ids = (/ (i, i=1,npdim) /) + self%positions(:, 1:self%np) = positions + self%npdim = npdim + + if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_resize' + end subroutine drifters_core_resize + +!############################################################################### + subroutine drifters_core_set_positions(self, positions, ermesg) + type(drifters_core_type) :: self + real, intent(in) :: positions(:,:) + character(*), intent(out) :: ermesg + integer ier !, iflag + ermesg = '' + ier = 0 + self%np = min(self%npdim, size(positions, 2)) + self%positions(:,1:self%np) = positions(:,1:self%np) + self%it = self%it + 1 + if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_set_positions' + end subroutine drifters_core_set_positions + +!############################################################################### + subroutine drifters_core_set_ids(self1, ids1, ermesg1) + type(drifters_core_type) :: self1 + integer, intent(in) :: ids1(:) + character(*), intent(out) :: ermesg1 + integer ier, np !, iflag + ermesg1 = '' + ier = 0 + np = min(self1%npdim, size(ids1)) + self1%ids(1:np) = ids1(1:np) + if(ier/=0) ermesg1 = 'drifters::ERROR in drifters_core_set_ids' + end subroutine drifters_core_set_ids + +!############################################################################### +subroutine drifters_core_remove_and_add(self, indices_to_remove_in, & + & ids_to_add, positions_to_add, & + & ermesg) + type(drifters_core_type) :: self + integer, intent(in ) :: indices_to_remove_in(:) + integer, intent(in ) :: ids_to_add(:) + real , intent(in ) :: positions_to_add(:,:) + character(*), intent(out) :: ermesg + integer ier, np_add, np_remove, i, j, n_diff !, iflag + integer indices_to_remove(size(indices_to_remove_in)) + external qksrt_quicksort + ermesg = '' + ier = 0 + + ! copy, required so we can have indices_to_remove_in intent(in) + indices_to_remove = indices_to_remove_in + np_remove = size(indices_to_remove) + np_add = size(ids_to_add, 1) + n_diff = np_add - np_remove + + ! cannot remove more than there are elements + if(self%np + n_diff < 0) then + ermesg = 'drifters::ERROR attempting to remove more elements than there are elements in '// & + &'drifters_core_remove_and_add' + return + endif + + ! check for overflow, and resize if necessary + if(self%np + n_diff > self%npdim) & + & call drifters_core_resize(self, int(1.2*(self%np + n_diff))+1, ermesg) + + do i = 1, min(np_add, np_remove) + j = indices_to_remove(i) + self%ids(j) = ids_to_add(i) + self%positions(:,j) = positions_to_add(:,i) + enddo + + if(n_diff > 0) then + ! all the particles to remove were removed and replaced. Just need to append + ! remaining particles to end of list + self%ids( self%np+1:self%np+n_diff) = ids_to_add( np_remove+1:np_add) + self%positions(:, self%np+1:self%np+n_diff) = positions_to_add(:,np_remove+1:np_add) + + self%np = self%np + n_diff + + else if(n_diff < 0) then + ! all the particles were added by filling in holes left by particles that + ! were previously removed. Now remove remaining particles, starting from the end, + ! by replacing the missing particle with a copy from the end. + + ! sort remaining indices in ascending order + call qksrt_quicksort(size(indices_to_remove), indices_to_remove, np_add+1, np_remove) + + do i = np_remove, np_add+1, -1 + if(self%np <= 0) exit + j = indices_to_remove(i) + self%ids ( j) = self%ids ( self%np) + self%positions(:,j) = self%positions(:,self%np) + self%np = self%np - 1 + enddo + endif + + if(ier/=0) ermesg = 'drifters::ERROR in drifters_core_remove_and_add' + end subroutine drifters_core_remove_and_add + +!############################################################################### + subroutine drifters_core_print(self1, ermesg1) + type(drifters_core_type) :: self1 + character(*), intent(out) :: ermesg1 + integer j + ermesg1 = '' + + print '(a,i10,a,i6,a,i6,a,i4,a,i4,a,i4)','it=',self1%it, & + & ' np=', self1%np, ' npdim=', self1%npdim + + print *,'ids and positions:' + do j = 1, self1%np + print *,self1%ids(j), self1%positions(:,j) + enddo + + end subroutine drifters_core_print + + +end module drifters_core_mod +!############################################################################### +!> @} +! close documentation grouping diff --git a/drifters/include/drifters_input.inc b/drifters/include/drifters_input.inc new file mode 100644 index 0000000000..0327f67053 --- /dev/null +++ b/drifters/include/drifters_input.inc @@ -0,0 +1,450 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @defgroup drifters_input_mod drifters_input_mod +!> @ingroup drifters +!> @brief Imports initial drifter positions from a netCDF file + +!> @addtogroup drifters_input_mod +!> @{ +module drifters_input_mod + implicit none + private + + public :: drifters_input_type, drifters_input_new, drifters_input_del, drifters_input_save, assignment(=) + + ! Globals + integer, parameter, private :: MAX_STR_LEN = 128 + ! Include variable "version" to be written to log file. +#include + character, parameter, private :: SEPARATOR = ' ' + !> @} + + !> @brief Input data type for drifters. + !! + !> @note Be sure to update drifters_input_new, drifters_input_del and drifters_input_copy_new + !! when adding members + !> @ingroup drifters_input_mod + type drifters_input_type + ! Be sure to update drifters_input_new, drifters_input_del and drifters_input_copy_new + ! when adding members + character(len=MAX_STR_LEN), allocatable :: position_names(:) + character(len=MAX_STR_LEN), allocatable :: position_units(:) + character(len=MAX_STR_LEN), allocatable :: field_names(:) + character(len=MAX_STR_LEN), allocatable :: field_units(:) + character(len=MAX_STR_LEN), allocatable :: velocity_names(:) + real , allocatable :: positions(:,:) + integer , allocatable :: ids(:) + character(len=MAX_STR_LEN) :: time_units + character(len=MAX_STR_LEN) :: title + character(len=MAX_STR_LEN) :: version + end type drifters_input_type + + !> @brief Assignment override for @ref drifters_input_type + !> @ingroup drifters_input_mod + interface assignment(=) + module procedure drifters_input_copy_new + end interface + +!> @addtogroup drifters_input_mod +!> @{ + + contains + +!=============================================================================== + + subroutine drifters_input_new(self, filename, ermesg) + use netcdf + use netcdf_nf_data + use netcdf_nf_interfaces + type(drifters_input_type) :: self + character(len=*), intent(in) :: filename + character(len=*), intent(out):: ermesg + + ! Local + integer :: ier, ncid, nd, nf, np, ipos, j, id, i, isz + character(len=MAX_STR_LEN) :: attribute + + ermesg = '' + + ier = nf_open(filename, NF_NOWRITE, ncid) + if(ier/=NF_NOERR) then + ermesg = 'drifters_input: ERROR could not open netcdf file '//filename + return + endif + + ! version + ier = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'version', len(version), version) + + ier = NF_INQ_DIMID(NCID, 'nd', id) + if(ier/=NF_NOERR) then + ermesg = 'drifters_input: ERROR could not find "nd" (number of dimensions)' + ier = nf_close(ncid) + return + endif + ier = NF_INQ_DIMLEN(NCID, id, nd) + + ! determine number of fields (nf) + attribute = '' + ier = nf_get_att_text(ncid, NF_GLOBAL, 'field_names', attribute) + isz = min(len(attribute), len(trim(attribute))+1) + attribute(isz:isz) = ' ' + ipos = 1 + nf = 0 + do i = 1, isz + if(attribute(i:i)==SEPARATOR) then + nf = nf + 1 + endif + enddo + + ier = NF_INQ_DIMID(NCID, 'np', id) + if(ier/=NF_NOERR) then + ermesg = 'drifters_input: ERROR could not find "np" (number of particles)' + ier = nf_close(ncid) + return + endif + ier = NF_INQ_DIMLEN(NCID, id, np) + + allocate(self%position_names(nd)) + allocate(self%position_units(nd)) + allocate(self%field_names(nf)) + allocate(self%field_units(nf)) + allocate(self%velocity_names(nd)) + allocate(self%ids(np)) + allocate(self%positions(nd, np)) + + ier = NF_INQ_VARID(NCID, 'ids', id) + if(ier/=NF_NOERR) then + ermesg = 'drifters_input: ERROR could not find "ids"' + ier = nf_close(ncid) + return + endif + ier = NF_GET_VAR_INT(NCID, id, self%ids) + + ier = NF_INQ_VARID(NCID, 'positions', id) + if(ier/=NF_NOERR) then + ermesg = 'drifters_input: ERROR could not find "positions"' + ier = nf_close(ncid) + return + endif + ier = NF90_GET_VAR(NCID, id, self%positions) + + attribute = '' + ier = nf_get_att_text(ncid, NF_GLOBAL, 'version', attribute) + self%version = trim(attribute) + + attribute = '' + ier = nf_get_att_text(ncid, NF_GLOBAL, 'time_units', attribute) + self%time_units = trim(attribute) + + attribute = '' + ier = nf_get_att_text(ncid, NF_GLOBAL, 'title', attribute) + self%title = trim(attribute) + + attribute = '' + ier = nf_get_att_text(ncid, id, 'names', attribute) + isz = min(len(attribute), len(trim(attribute))+1) + attribute(isz:isz) = ' ' + ipos = 1 + j = 1 + do i = 1, isz + if(attribute(i:i)==SEPARATOR) then + self%position_names(j) = trim(adjustl(attribute(ipos:i-1))) + ipos = i+1 + j = j + 1 + if(j > nd) exit + endif + enddo + + attribute = '' + ier = nf_get_att_text(ncid, id, 'units', attribute) + isz = min(len(attribute), len(trim(attribute))+1) + attribute(isz:isz) = ' ' + ipos = 1 + j = 1 + do i = 1, isz + if(attribute(i:i)==SEPARATOR) then + self%position_units(j) = trim(adjustl(attribute(ipos:i-1))) + ipos = i+1 + j = j + 1 + if(j > nd) exit + endif + enddo + + attribute = '' + ier = nf_get_att_text(ncid, NF_GLOBAL, 'field_names', attribute) + isz = min(len(attribute), len(trim(attribute))+1) + attribute(isz:isz) = ' ' + ipos = 1 + j = 1 + do i = 1, isz + if(attribute(i:i)==SEPARATOR) then + self%field_names(j) = trim(adjustl(attribute(ipos:i-1))) + ipos = i+1 + j = j + 1 + if(j > nf) exit + endif + enddo + + attribute = '' + ier = nf_get_att_text(ncid, NF_GLOBAL, 'field_units', attribute) + isz = min(len(attribute), len(trim(attribute))+1) + attribute(isz:isz) = ' ' + ipos = 1 + j = 1 + do i = 1, isz + if(attribute(i:i)==SEPARATOR) then + self%field_units(j) = trim(adjustl(attribute(ipos:i-1))) + ipos = i+1 + j = j + 1 + if(j > nf) exit + endif + enddo + + attribute = '' + ier = nf_get_att_text(ncid, NF_GLOBAL, 'velocity_names', attribute) + isz = min(len(attribute), len(trim(attribute))+1) + attribute(isz:isz) = ' ' + ipos = 1 + j = 1 + do i = 1, isz + if(attribute(i:i)==SEPARATOR) then + self%velocity_names(j) = trim(adjustl(attribute(ipos:i-1))) + ipos = i+1 + j = j + 1 + if(j > nd) exit + endif + enddo + + end subroutine drifters_input_new + +!=============================================================================== + subroutine drifters_input_del(self, ermesg) + type(drifters_input_type) :: self + character(len=*), intent(out):: ermesg + + integer :: iflag + + ermesg = '' + + deallocate(self%position_names, stat=iflag) + deallocate(self%position_units, stat=iflag) + deallocate(self%field_names, stat=iflag) + deallocate(self%field_units, stat=iflag) + deallocate(self%velocity_names, stat=iflag) + deallocate(self%ids, stat=iflag) + deallocate(self%positions, stat=iflag) + + end subroutine drifters_input_del + +!=============================================================================== + subroutine drifters_input_copy_new(new_instance, old_instance) + + type(drifters_input_type), intent(inout) :: new_instance + type(drifters_input_type), intent(in) :: old_instance + + allocate(new_instance%position_names( size(old_instance%position_names) )) + allocate(new_instance%position_units( size(old_instance%position_units) )) + allocate(new_instance%field_names( size(old_instance%field_names) )) + allocate(new_instance%field_units( size(old_instance%field_units) )) + allocate(new_instance%velocity_names( size(old_instance%velocity_names) )) + new_instance%position_names = old_instance%position_names + new_instance%position_units = old_instance%position_units + new_instance%field_names = old_instance%field_names + new_instance%field_units = old_instance%field_units + new_instance%velocity_names = old_instance%velocity_names + new_instance%time_units = old_instance%time_units + new_instance%title = old_instance%title + new_instance%version = old_instance%version + allocate(new_instance%positions( size(old_instance%positions,1),size(old_instance%positions,2) )) + new_instance%positions = old_instance%positions + allocate(new_instance%ids(size(old_instance%ids))) + new_instance%ids = old_instance%ids + + end subroutine drifters_input_copy_new + +!=============================================================================== + !> @brief save state in netcdf file. can be used as restart file. + subroutine drifters_input_save(self, filename, geolon, geolat, ermesg) + ! save state in netcdf file. can be used as restart file. + use netcdf + use netcdf_nf_data + use netcdf_nf_interfaces + type(drifters_input_type) :: self + character(len=*), intent(in ):: filename + real, intent(in), optional :: geolon(:), geolat(:) + character(len=*), intent(out):: ermesg + + + integer ncid, nc_nd, nc_np, ier, nd, np, nf, nc_pos, nc_ids, i, j, n + integer nc_lon, nc_lat + character(len=MAX_STR_LEN) :: att + + + ermesg = '' + + ier = nf_create(filename, NF_CLOBBER, ncid) + if(ier/=NF_NOERR) then + ermesg = 'drifters_input: ERROR cannot create '//filename + return + endif + + nd = size(self%positions, 1) + np = size(self%positions, 2) + nf = size(self%field_names) + + ! dimensions + ier = nf_def_dim(ncid, 'nd', nd, nc_nd) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating dim "nd" '//nf_strerror(ier) + + ier = nf_def_dim(ncid, 'np', np, nc_np) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating dim "np" '//nf_strerror(ier) + + ! global attributes + ier = nf_put_att_text(ncid, NF_GLOBAL, 'title', len_trim(self%title), self%title) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "title" ' & + & //nf_strerror(ier) + + ier = nf_put_att_text(ncid, NF_GLOBAL, 'time_units', len_trim(self%time_units), self%time_units) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "time_units" ' & + & //nf_strerror(ier) + + att = '' + j = 1 + do i = 1, nf + n = len_trim(self%field_units(i)) + att(j:j+n+1) = trim(self%field_units(i)) // ' ' + j = j + n + 1 + enddo + ier = nf_put_att_text(ncid, NF_GLOBAL, 'field_units', len_trim(att), & + & att) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "field_units" ' & + & //nf_strerror(ier) + + att = '' + j = 1 + do i = 1, nf + n = len_trim(self%field_names(i)) + att(j:j+n+1) = trim(self%field_names(i)) // ' ' + j = j + n + 1 + enddo + ier = nf_put_att_text(ncid, NF_GLOBAL, 'field_names', len_trim(att), & + & att) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "field_names" ' & + & //nf_strerror(ier) + + att = '' + j = 1 + do i = 1, nd + n = len_trim(self%velocity_names(i)) + att(j:j+n+1) = trim(self%velocity_names(i)) // ' ' + j = j + n + 1 + enddo + ier = nf_put_att_text(ncid, NF_GLOBAL, 'velocity_names', len_trim(att), & + & att) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting global att "velocity_names" ' & + & //nf_strerror(ier) + + ! variables + ier = nf_def_var(ncid, 'positions', NF_DOUBLE, 2, (/nc_nd, nc_np/), nc_pos) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating var "positions" '//nf_strerror(ier) + + ier = nf_def_var(ncid, 'ids', NF_INT, 1, (/nc_np/), nc_ids) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating var "ids" '//nf_strerror(ier) + + ! optional: longitudes/latitudes in deg + if(present(geolon)) then + ier = nf_def_var(ncid, 'longitude', NF_DOUBLE, 1, (/nc_np/), nc_lon) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating var "longitude" ' & + & //nf_strerror(ier) + att = 'degrees_east' + ier = nf_put_att_text(ncid, nc_lon, 'units', len(trim(att)), trim(att)) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting att "units" to "longitude" ' & + & //nf_strerror(ier) + endif + if(present(geolat)) then + ier = nf_def_var(ncid, 'latitude', NF_DOUBLE, 1, (/nc_np/), nc_lat) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR creating var "latitude" ' & + & //nf_strerror(ier) + att = 'degrees_north' + ier = nf_put_att_text(ncid, nc_lat, 'units', len(trim(att)), trim(att)) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting att "units" to "latitude" ' & + & //nf_strerror(ier) + endif + + ! variable attributes + + att = '' + j = 1 + do i = 1, nd + n = len_trim(self%position_units(i)) + att(j:j+n+1) = trim(self%position_units(i)) // ' ' + j = j + n + 1 + enddo + ier = nf_put_att_text(ncid, nc_pos, 'units', len_trim(att), & + & att) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting att "units" to "positions" ' & + & //nf_strerror(ier) + + att = '' + j = 1 + do i = 1, nd + n = len_trim(self%position_names(i)) + att(j:j+n+1) = trim(self%position_names(i)) // ' ' + j = j + n + 1 + enddo + ier = nf_put_att_text(ncid, nc_pos, 'names', len_trim(att), & + & att) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR setting att "names" to "positions" ' & + & //nf_strerror(ier) + + ! end of define mode + ier = nf_enddef(ncid) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not end define mode ' & + & //nf_strerror(ier) + + ! data + ier = nf90_put_var(ncid, nc_pos, self%positions) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not write "positions" ' & + & //nf_strerror(ier) + + ier = nf90_put_var(ncid, nc_ids, self%ids) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not write "ids" ' & + & //nf_strerror(ier) + + if(present(geolon)) then + ier = nf90_put_var(ncid, nc_lon, geolon) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not write "geolon" ' & + & //nf_strerror(ier) + endif + if(present(geolat)) then + ier = nf90_put_var(ncid, nc_lat, geolat) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not write "geolat" ' & + & //nf_strerror(ier) + endif + + + ier = nf_close(ncid) + if(ier/=NF_NOERR) ermesg = 'drifters_input_save: ERROR could not close file ' & + & //nf_strerror(ier) + + end subroutine drifters_input_save + +end module drifters_input_mod +!> @} +! close documentation grouping diff --git a/drifters/include/drifters_io.inc b/drifters/include/drifters_io.inc new file mode 100644 index 0000000000..3592da9603 --- /dev/null +++ b/drifters/include/drifters_io.inc @@ -0,0 +1,313 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @defgroup drifters_io_mod drifters_io_mod +!> @ingroup drifters +!> @brief Saves drifter data for postprocessing and restarts + +!> @addtogroup drifters_io_mod +!> @{ +module drifters_io_mod + + use netcdf + use netcdf_nf_data + use netcdf_nf_interfaces + use netcdf4_nf_interfaces + + implicit none + private + + public :: drifters_io_type, drifters_io_new, drifters_io_del, drifters_io_set_time_units + public :: drifters_io_set_position_names, drifters_io_set_position_units, drifters_io_set_field_names + public :: drifters_io_set_field_units, drifters_io_write + + ! Globals + integer, parameter, private :: MAX_STR_LEN = 128 + ! Include variable "version" to be written to log file. +#include + + real :: drfts_eps_t = 10.*epsilon(1.) + +!> @} + !> @brief IO data for drifters. + !> @ingroup drifters_input_mod + type drifters_io_type + real :: time + integer :: it !< time index + integer :: it_id !< infinite axis index + integer :: ncid + integer :: nc_positions, nc_fields, nc_ids, nc_time, nc_index_time + logical :: enddef + end type drifters_io_type +!> @addtogroup drifters_io_mod +!> @{ +contains + +!############################################################################### + subroutine drifters_io_new(self, filename, nd, nf, ermesg) + type(drifters_io_type) :: self + character(len=*), intent(in) :: filename + integer, intent(in) :: nd !< number of dims + integer, intent(in) :: nf !< number of fields + character(len=*), intent(out) :: ermesg + + integer ier, nc_it_id, nc_nd, nc_nf + integer :: size1(1), size2(2) + + ermesg='' + self%enddef = .FALSE. + + ier = nf_create(filename, NF_CLOBBER, self%ncid) + if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_create ('//filename//') '//nf_strerror(ier) + + ! global attributes + ier = nf_put_att_text(self%ncid, NF_GLOBAL, 'version', len_trim(version), trim(version)) + + + ! dimensions + ier = nf_def_dim(self%ncid, 'np', NF_UNLIMITED, nc_it_id) + if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_dim (it_id) '//nf_strerror(ier) + + ier = nf_def_dim(self%ncid, 'nf', nf, nc_nf) + if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_dim (nf) '//nf_strerror(ier) + + ier = nf_def_dim(self%ncid, 'nd', nd, nc_nd) + if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_dim (nd) '//nf_strerror(ier) + + ! variables + size1 = (/nc_it_id/) + ier = nf_def_var(self%ncid, 'index_time', NF_INT, 1, size1, self%nc_index_time) + if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (index_time)'//nf_strerror(ier) + + ier = nf_def_var(self%ncid, 'time', NF_DOUBLE, 1, size1, self%nc_time) + if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (time)'//nf_strerror(ier) + + ier = nf_def_var(self%ncid, 'ids', NF_INT, 1, size1, self%nc_ids) + if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (ids)'//nf_strerror(ier) + + size2 = (/nc_nd, nc_it_id/) + ier = nf_def_var(self%ncid, 'positions', NF_DOUBLE, 2, size2, self%nc_positions) + if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (positions)'//nf_strerror(ier) + + size2 = (/nc_nf, nc_it_id/) + ier = nf_def_var(self%ncid, 'fields', NF_DOUBLE, 2, size2, self%nc_fields) + if(ier/=NF_NOERR) ermesg = 'drifters_io_new::nf_def_var (fields)'//nf_strerror(ier) + + self%time = -huge(1.) + self%it = -1 + self%it_id = 1 + + end subroutine drifters_io_new + +!############################################################################### + subroutine drifters_io_del(self, ermesg) + type(drifters_io_type) :: self + character(len=*), intent(out) :: ermesg + + integer ier + + ermesg = '' + + ier = nf_close(self%ncid) + if(ier/=NF_NOERR) ermesg = 'drifters_io_del::nf_close '//nf_strerror(ier) + + end subroutine drifters_io_del + +!############################################################################### + subroutine drifters_io_set_time_units(self, name, ermesg) + type(drifters_io_type) :: self + character(len=*), intent(in) :: name + character(len=*), intent(out) :: ermesg + + integer ier + + ermesg = '' + ier = nf_put_att_text(self%ncid, NF_GLOBAL, & + & 'time_units', len_trim(name), trim(name)) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_set_time_units::failed to add time_units attribute ' & + & //nf_strerror(ier) + + end subroutine drifters_io_set_time_units + +!############################################################################### + subroutine drifters_io_set_position_names(self, names, ermesg) + type(drifters_io_type) :: self + character(len=*), intent(in) :: names(:) + character(len=*), intent(out) :: ermesg + + integer n, ier, i + character(len=128) :: attname + + n = size(names) + ermesg = '' + + do i = 1, n + write(attname, '(i6)' ) i + attname = 'name_'//adjustl(attname) + ier = nf_put_att_text(self%ncid, self%nc_positions, & + & trim(attname), len_trim(names(i)), trim(names(i))) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_set_position_names::failed to add name attribute to positions '//nf_strerror(ier) + enddo + + end subroutine drifters_io_set_position_names + +!############################################################################### + subroutine drifters_io_set_position_units(self, names, ermesg) + type(drifters_io_type) :: self + character(len=*), intent(in) :: names(:) + character(len=*), intent(out) :: ermesg + + integer n, ier, i + character(len=128) :: attname + + n = size(names) + ermesg = '' + + do i = 1, n + write(attname, '(i6)' ) i + attname = 'unit_'//adjustl(attname) + ier = nf_put_att_text(self%ncid, self%nc_positions, & + & trim(attname), len_trim(names(i)), trim(names(i))) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_set_position_names::failed to add unit attribute to positions '//nf_strerror(ier) + enddo + + end subroutine drifters_io_set_position_units + +!############################################################################### + subroutine drifters_io_set_field_names(self, names, ermesg) + type(drifters_io_type) :: self + character(len=*), intent(in) :: names(:) + character(len=*), intent(out) :: ermesg + + integer n, ier, i + character(len=128) :: attname + + n = size(names) + ermesg = '' + + do i = 1, n + write(attname, '(i6)' ) i + attname = 'name_'//adjustl(attname) + ier = nf_put_att_text(self%ncid, self%nc_fields, & + & trim(attname), len_trim(names(i)), trim(names(i))) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_set_field_names::failed to add name attribute to fields '//nf_strerror(ier) + enddo + + end subroutine drifters_io_set_field_names + +!############################################################################### + subroutine drifters_io_set_field_units(self, names, ermesg) + type(drifters_io_type) :: self + character(len=*), intent(in) :: names(:) + character(len=*), intent(out) :: ermesg + + integer n, ier, i + character(len=128) :: attname + + n = size(names) + ermesg = '' + + do i = 1, n + write(attname, '(i6)' ) i + attname = 'unit_'//adjustl(attname) + ier = nf_put_att_text(self%ncid, self%nc_fields, & + & trim(attname), len_trim(names(i)), trim(names(i))) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_set_field_units::failed to add unit attribute to fields '//nf_strerror(ier) + enddo + + end subroutine drifters_io_set_field_units +!############################################################################### + + subroutine drifters_io_write(self, time, np, nd, nf, ids, positions, fields, ermesg) + type(drifters_io_type) :: self + real, intent(in) :: time + integer, intent(in) :: np !< number of dirfters + integer, intent(in) :: nd !< number of dimensions + integer, intent(in) :: nf !< number of fields + integer, intent(in) :: ids(np) !< of size np + real, intent(in) :: positions(nd,np) !< nd times np + real, intent(in) :: fields(nf,np) !< nf times np + character(len=*), intent(out) :: ermesg + + integer ier, i + integer :: start1(1), len1(1), start2(2), len2(2) + integer :: it_indices(np) + real :: time_array(np) + + ermesg = '' + + if(.not. self%enddef) then + ier = nf_enddef(self%ncid) + if(ier/=NF_NOERR) then + ermesg = 'drifters_io_write::nf_enddef failure. No data will be written. '//nf_strerror(ier) + return + endif + self%enddef = .TRUE. + endif + + if(abs(time - self%time) > drfts_eps_t) then + self%it = self%it + 1 + self%time = time + endif + + start1(1) = self%it_id + len1(1) = np + + it_indices = (/(self%it,i=1,np)/) + ier = nf_put_vara_int( self%ncid, self%nc_index_time, start1, len1, it_indices ) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_write::failed to write index_time: ' //nf_strerror(ier) + + time_array = (/(time,i=1,np)/) + ier = nf90_put_var( self%ncid, self%nc_time, time_array, start1, len1 ) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_write::failed to write time: ' //nf_strerror(ier) + + ier = nf_put_vara_int(self%ncid, self%nc_ids, start1, len1, ids) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_write::failed to write ids: '//nf_strerror(ier) + + start2(1) = 1 + start2(2) = self%it_id + + len2(1) = nd + len2(2) = np + + ier = nf90_put_var(self%ncid, self%nc_positions, positions, start2, len2) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_write::failed to write positions: '//nf_strerror(ier) + + len2(1) = nf + len2(2) = np + + ier = nf90_put_var(self%ncid, self%nc_fields, fields, start2, len2) + if(ier/=NF_NOERR) & + & ermesg = 'drifters_io_write::failed to write fields: '//nf_strerror(ier) + + self%it_id = self%it_id + np + + end subroutine drifters_io_write + +end module drifters_io_mod +!> @} +! close documentation grouping diff --git a/drifters/include/quicksort.inc b/drifters/include/quicksort.inc new file mode 100644 index 0000000000..6f751858d1 --- /dev/null +++ b/drifters/include/quicksort.inc @@ -0,0 +1,94 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** +!> @cond +#undef _TYP +#define _TYP integer +!> @endcond + +!> @defgroup quicksort quicksort +!> @ingroup drifters +!> @brief Fortran implementation of quicksort to be used in @ref drifters_core +!! +!> @author Magnus Lie Hetland + +!> Create array partitions for quicksort +function qksrt_partition(n, list, start, end) result(top) + implicit none + integer, intent(in) :: n + _TYP, intent(inout) :: list(n) + integer, intent(in) :: start, end + + integer pivot, bottom, top + logical done + + pivot = list(end) ! Partition around the last value + bottom = start-1 ! Start outside the area to be partitioned + top = end ! Ditto + + done = .false. + do while (.not. done) ! Until all elements are partitioned... + + do while (.not. done) ! Until we find an out of place element... + bottom = bottom+1 ! ... move the bottom up. + + if(bottom == top) then ! If we hit the top... + done = .true. ! ... we are done. + exit + endif + + if(list(bottom) > pivot) then ! Is the bottom out of place? + list(top) = list(bottom) ! Then put it at the top... + exit ! ... and start searching from the top. + endif + enddo + + do while (.not. done) ! Until we find an out of place element... + top = top-1 ! ... move the top down. + + if(top == bottom) then ! If we hit the bottom... + done = .true. ! ... we are done. + exit + endif + + if(list(top) < pivot) then ! Is the top out of place? + list(bottom) = list(top) ! Then put it at the bottom... + exit ! ...and start searching from the bottom. + endif + enddo + enddo + + list(top) = pivot ! Put the pivot in its place. + ! Return the split point + +end function qksrt_partition + +!> quicksort a given list +recursive subroutine qksrt_quicksort(n, list, start, end) + implicit none + integer, intent(in) :: n + _TYP, intent(inout) :: list(n) + integer, intent(in) :: start, end + integer :: split, qksrt_partition + external :: qksrt_partition + if(start < end) then ! If there are two or more elements... + split = qksrt_partition(n, list, start, end) ! ... partition the sublist... + call qksrt_quicksort(n, list, start, split-1) ! ... and sort both halves. + call qksrt_quicksort(n, list, split+1, end) + endif +end subroutine qksrt_quicksort diff --git a/string_utils/Makefile.am b/string_utils/Makefile.am index ca0c3ab5ef..408c5eea7a 100644 --- a/string_utils/Makefile.am +++ b/string_utils/Makefile.am @@ -21,7 +21,7 @@ # package. # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/string_utils/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. @@ -30,6 +30,9 @@ noinst_LTLIBRARIES = libstring_utils.la # The convenience library depends on its source. libstring_utils_la_SOURCES = \ fms_string_utils.F90 \ + include/fms_string_utils.inc \ + include/fms_string_utils_r4.fh \ + include/fms_string_utils_r8.fh \ fms_string_utils_binding.c MODFILES = \ diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index cf2dcd0376..78d086f571 100644 --- a/string_utils/fms_string_utils.F90 +++ b/string_utils/fms_string_utils.F90 @@ -28,6 +28,7 @@ !> @{ module fms_string_utils_mod use, intrinsic :: iso_c_binding + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind use mpp_mod implicit none @@ -43,6 +44,7 @@ module fms_string_utils_mod public :: fms_cstring2cpointer public :: string public :: string_copy + public :: stringify !> @} interface @@ -112,11 +114,12 @@ subroutine c_free(ptr) bind(c,name="free") module procedure cpointer_fortran_conversion end interface -!> Converts a number to a string +!> Converts an array of real numbers to a string !> @ingroup fms_mod -interface string - module procedure string_from_integer - module procedure string_from_real +interface stringify + module procedure stringify_1d_r4, stringify_1d_r8 + module procedure stringify_2d_r4, stringify_2d_r8 + module procedure stringify_3d_r4, stringify_3d_r8 end interface !> @addtogroup fms_string_utils_mod @@ -237,31 +240,65 @@ subroutine fms_f2c_string (dest, str_in) enddo end subroutine fms_f2c_string - - !> @brief Converts an integer to a string - !> @return The integer as a string - function string_from_integer(i) result (res) - integer, intent(in) :: i !< Integer to be converted to a string - character(:),allocatable :: res !< String converted frominteger - character(range(i)+2) :: tmp !< Temp string that is set to correct size - write(tmp,'(i0)') i - res = trim(tmp) - return - - end function string_from_integer - - !####################################################################### - !> @brief Converts a real to a string - !> @return The real number as a string - function string_from_real(r) - real, intent(in) :: r !< Real number to be converted to a string - character(len=32) :: string_from_real - - write(string_from_real,*) r - - return - - end function string_from_real + !> @brief Converts a number or a Boolean value to a string + !> @return The argument as a string + function string(v, fmt) + class(*), intent(in) :: v !< Value to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for a real or integral argument + character(:), allocatable :: string + + select type(v) + type is (logical) + if (present(fmt)) then + call mpp_error(WARNING, "string(): Ignoring `fmt` argument for type `logical`") + endif + if (v) then + string = "True" + else + string = "False" + endif + + type is (integer(i4_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, '(i0)') v + endif + string = trim(adjustl(string)) + + type is (integer(i8_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, '(i0)') v + endif + string = trim(adjustl(string)) + + type is (real(r4_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, *) v + endif + string = trim(adjustl(string)) + + type is (real(r8_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, *) v + endif + string = trim(adjustl(string)) + + class default + call mpp_error(FATAL, "string(): Called with incompatible argument type. Possible types & + &include integer(4), integer(8), real(4), real(8), or logical.") + end select + end function string !> @brief Safely copy a string from one buffer to another. subroutine string_copy(dest, source, check_for_null) @@ -290,6 +327,9 @@ subroutine string_copy(dest, source, check_for_null) dest = adjustl(trim(source(1:i))) end subroutine string_copy +#include "fms_string_utils_r4.fh" +#include "fms_string_utils_r8.fh" + end module fms_string_utils_mod !> @} ! close documentation grouping diff --git a/string_utils/include/fms_string_utils.inc b/string_utils/include/fms_string_utils.inc new file mode 100644 index 0000000000..db6e067c4f --- /dev/null +++ b/string_utils/include/fms_string_utils.inc @@ -0,0 +1,87 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @brief Converts a 1D array of real numbers to a string +!> @return The 1D array as a string +function STRINGIFY_1D_(arr, fmt) + real(STRING_UTILS_KIND_), dimension(:), intent(in) :: arr !< Real array to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real array entries + character(:), allocatable :: STRINGIFY_1D_ + integer :: i, n + + n = size(arr) + + if (n .gt. 0) then + STRINGIFY_1D_ = "[" // string(arr(1), fmt) + else + STRINGIFY_1D_ = "[" + endif + + do i = 2,n + STRINGIFY_1D_ = STRINGIFY_1D_ // ", " // string(arr(i), fmt) + enddo + + STRINGIFY_1D_ = STRINGIFY_1D_ // "]" +end function + +!> @brief Converts a 2D array of real numbers to a string +!> @return The 2D array as a string +function STRINGIFY_2D_(arr, fmt) + real(STRING_UTILS_KIND_), dimension(:,:), intent(in) :: arr !< Real array to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real array entries + character(:), allocatable :: STRINGIFY_2D_ + integer :: i, n + + n = size(arr, 2) + + if (n .gt. 0) then + STRINGIFY_2D_ = "[" // STRINGIFY_1D_(arr(:,1), fmt) + else + STRINGIFY_2D_ = "[" + endif + + do i = 2,n + STRINGIFY_2D_ = STRINGIFY_2D_ // ", " // STRINGIFY_1D_(arr(:,i), fmt) + enddo + + STRINGIFY_2D_ = STRINGIFY_2D_ // "]" +end function + +!> @brief Converts a 3D array of real numbers to a string +!> @return The 3D array as a string +function STRINGIFY_3D_(arr, fmt) + real(STRING_UTILS_KIND_), dimension(:,:,:), intent(in) :: arr !< Real array to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real array entries + character(:), allocatable :: STRINGIFY_3D_ + integer :: i, n + + n = size(arr, 3) + + if (n .gt. 0) then + STRINGIFY_3D_ = "[" // STRINGIFY_2D_(arr(:,:,1), fmt) + else + STRINGIFY_3D_ = "[" + endif + + do i = 2,n + STRINGIFY_3D_ = STRINGIFY_3D_ // ", " // STRINGIFY_2D_(arr(:,:,i), fmt) + enddo + + STRINGIFY_3D_ = STRINGIFY_3D_ // "]" +end function diff --git a/string_utils/include/fms_string_utils_r4.fh b/string_utils/include/fms_string_utils_r4.fh new file mode 100644 index 0000000000..c12cb7e001 --- /dev/null +++ b/string_utils/include/fms_string_utils_r4.fh @@ -0,0 +1,30 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +#define STRING_UTILS_KIND_ r4_kind +#define STRINGIFY_1D_ stringify_1d_r4 +#define STRINGIFY_2D_ stringify_2d_r4 +#define STRINGIFY_3D_ stringify_3d_r4 + +#include "fms_string_utils.inc" + +#undef STRING_UTILS_KIND_ +#undef STRINGIFY_1D_ +#undef STRINGIFY_2D_ +#undef STRINGIFY_3D_ diff --git a/string_utils/include/fms_string_utils_r8.fh b/string_utils/include/fms_string_utils_r8.fh new file mode 100644 index 0000000000..4e40b1264a --- /dev/null +++ b/string_utils/include/fms_string_utils_r8.fh @@ -0,0 +1,30 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +#define STRING_UTILS_KIND_ r8_kind +#define STRINGIFY_1D_ stringify_1d_r8 +#define STRINGIFY_2D_ stringify_2d_r8 +#define STRINGIFY_3D_ stringify_3d_r8 + +#include "fms_string_utils.inc" + +#undef STRING_UTILS_KIND_ +#undef STRINGIFY_1D_ +#undef STRINGIFY_2D_ +#undef STRINGIFY_3D_ diff --git a/test_fms/axis_utils/Makefile.am b/test_fms/axis_utils/Makefile.am index 169f201740..3db495ecd6 100644 --- a/test_fms/axis_utils/Makefile.am +++ b/test_fms/axis_utils/Makefile.am @@ -30,15 +30,15 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = \ -test_axis_utils_r4 \ -test_axis_utils_r8 + test_axis_utils_r4 \ + test_axis_utils_r8 # This is the source code for the test. -test_axis_utils_r4_SOURCES = \ -test_axis_utils_r4.F90 +test_axis_utils_r4_SOURCES = test_axis_utils.F90 +test_axis_utils_r8_SOURCES = test_axis_utils.F90 -test_axis_utils_r8_SOURCES = \ -test_axis_utils_r8.F90 +test_axis_utils_r4_CPPFLAGS = $(AM_CPPFLAGS) -DAU_TEST_KIND_=r4_kind +test_axis_utils_r8_CPPFLAGS = $(AM_CPPFLAGS) -DAU_TEST_KIND_=r8_kind TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/axis_utils/test_axis_utils.F90 b/test_fms/axis_utils/test_axis_utils.F90 new file mode 100644 index 0000000000..aac74de010 --- /dev/null +++ b/test_fms/axis_utils/test_axis_utils.F90 @@ -0,0 +1,794 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +program test_axis_utils + +use fms_mod, only : fms_init, fms_end, lowercase +use fms2_io_mod, only: FmsNetcdfFile_t, open_file, close_file, register_axis, register_field, & + & register_variable_attribute, write_data +use platform_mod, only: r4_kind, r8_kind +use mpp_mod, only: mpp_error, fatal, stderr +use fms_string_utils_mod, only: string, stringify +use axis_utils2_mod + +implicit none + +type GetAxisCartTest_t + type(FmsNetcdfFile_t) :: fileobj + type(GetAxisCartTestCase_t), pointer :: test0, test1 +end type + +type GetAxisCartTestCase_t + character(:), allocatable :: var + character(1) :: cart + type(GetAxisCartTestCase_t), pointer :: next => NULL() +end type + +integer, parameter :: k = AU_TEST_KIND_ +real(k), parameter :: pi = 4._k * atan(1._k) + +integer :: i +character(100) :: arg + +call fms_init + +do i=1,command_argument_count() + call get_command_argument(i, arg) + + select case (arg) + case ('--get-axis-modulo') + print "(A)", "Testing get_axis_modulo" + call test_get_axis_modulo + + case ('--get-axis-modulo-times') + print "(A)", "Testing get_axis_modulo_times" + call test_get_axis_modulo_times + + case ('--get-axis-cart') + print "(A)", "Testing get_axis_cart" + call test_get_axis_cart + + case ('--lon-in-range') + print "(A)", "Testing lon_in_range" + call test_lon_in_range + + case ('--frac-index') + print "(A)", "Testing frac_index" + call test_frac_index + + case ('--frac-index-fail') + print "(A)", "Testing frac_index (FAILURE)" + call test_frac_index_fail + + case ('--nearest-index') + print "(A)", "Testing nearest_index" + call test_nearest_index + + case ('--nearest-index-fail') + print "(A)", "Testing nearest_index (FAILURE)" + call test_nearest_index_fail + + case ('--axis-edges') + print "(A)", "Testing axis_edges" + call test_axis_edges + + case ('--tranlon') + print "(A)", "Testing tranlon" + call test_tranlon + + case ('--interp-1d-1d') + print "(A)", "Testing interp_1d_1d" + call test_interp_1d_1d + + case ('--interp-1d-2d') + print "(A)", "Testing interp_1d_2d" + call test_interp_1d_2d + + case ('--interp-1d-3d') + print "(A)", "Testing interp_1d_3d" + call test_interp_1d_3d + + case default + write(stderr(),"(A)") "Unrecognized command line option: " // trim(arg) + end select +enddo + +call fms_end + +contains + +! Status: TODO +! function get_axis_modulo(fileobj, axisname) +subroutine test_get_axis_modulo + type(FmsNetcdfFile_t) :: fileobj + + write(stderr(), "(A)") "Warning: get_axis_modulo unit test not yet implemented" +end subroutine + +! Status: TODO +! function get_axis_modulo_times(fileobj, axisname, tbeg, tend) +subroutine test_get_axis_modulo_times + type(FmsNetcdfFile_t) :: fileobj + + write(stderr(), "(A)") "Warning: get_axis_modulo_times unit test not yet implemented" +end subroutine + +subroutine test_get_axis_cart + type(GetAxisCartTest_t) :: test + type(GetAxisCartTestCase_t), pointer :: test_nonexistent_var + character(:), allocatable :: var_name, attr_name, attr_value + integer :: i, j + + character(*), parameter, dimension(*) :: & + & special_axis_names_x = [character(12) :: "lon", "x", "degrees_e", "degrees_east", "degreese"], & + & special_axis_names_y = [character(13) :: "lat", "y", "degrees_n", "degrees_north", "degreesn"], & + & special_axis_names_z = [character(6) :: "depth", "height", "z", "cm", "m", "pa", "hpa"], & + & special_axis_names_t = [character(4) :: "time", "t", "sec", "min", "hou", "day", "mon", "yea"], & + & attr_names = [character(14) :: "cartesian_axis", "axis"], & + & xyzt_uc = ["X", "Y", "Z", "T"] + + call open_netcdf_w(test%fileobj) + call register_axis(test%fileobj, "dim1", 1) + + ! Check a variable which does not exist + + allocate(test_nonexistent_var) + test_nonexistent_var%var = "does_not_exist" + test_nonexistent_var%cart = "N" + + test%test0 => test_nonexistent_var + test%test1 => test_nonexistent_var + + ! Check a variable which exists, but which has neither a "cartesian_axis" nor an "axis" attribute. + var_name = "exists_no_attributes" + call get_axis_cart_test_add(test, var_name, "N") + + do i=1,size(attr_names) + attr_name = trim(attr_names(i)) + + ! Check an unknown value on a "cartesian_axis" or "axis" attribute. + ! TODO: This test fails. It should be uncommented if/when get_axis_cart's behavior is fixed. + + !attr_value = "unexpected" + !var_name = attr_name // "_attr_value_" // attr_value + !call get_axis_cart_test_add(test, var_name, "N") + !call register_variable_attribute(test%fileobj, var_name, attr_name, attr_value, str_len=len(attr_value)) + + do j=1,size(xyzt_uc) + ! Check upper-case "axis" attributes" + attr_value = xyzt_uc(j) + var_name = attr_name // "_attr_value_" // attr_value + call get_axis_cart_test_add(test, var_name, xyzt_uc(j)) + call register_variable_attribute(test%fileobj, var_name, attr_name, attr_value, str_len=len(attr_value)) + + ! Check lower-case "axis" attributes" + attr_value = lowercase(xyzt_uc(j)) + var_name = attr_name // "_attr_value_" // attr_value + call get_axis_cart_test_add(test, var_name, xyzt_uc(j)) + call register_variable_attribute(test%fileobj, var_name, attr_name, attr_value, str_len=len(attr_value)) + enddo + enddo + + call test_special_axis_names(test, special_axis_names_x, "X") + call test_special_axis_names(test, special_axis_names_y, "Y") + call test_special_axis_names(test, special_axis_names_z, "Z") + call test_special_axis_names(test, special_axis_names_t, "T") + + call close_file(test%fileobj) + + call get_axis_cart_tests_run(test) +end subroutine + +subroutine get_axis_cart_test_add(test, var_name, cart) + type(GetAxisCartTest_t), intent(inout) :: test + type(GetAxisCartTestCase_t), pointer :: test_case + character(*), intent(in) :: var_name + character(1), intent(in) :: cart + character(:), allocatable :: kind_str + + if (k .eq. r4_kind) then + kind_str = "float" + else + kind_str = "double" + endif + + call register_field(test%fileobj, var_name, kind_str, dimensions=["dim1"]) + + allocate(test_case) + test_case%var = var_name + test_case%cart = cart + + test%test1%next => test_case + test%test1 => test_case +end subroutine + +subroutine get_axis_cart_tests_run(test) + type(GetAxisCartTest_t), intent(inout) :: test + type(GetAxisCartTestCase_t), pointer :: test_case, next + character(1) :: cart_test + integer :: i + + call open_netcdf_r(test%fileobj) + + test_case => test%test0 + + do while (associated(test_case)) + cart_test = " " + call get_axis_cart(test%fileobj, test_case%var, cart_test) + + if (cart_test .ne. test_case%cart) then + write(stderr(), "(A)") "get_axis_cart result for variable '" // test_case%var // "': " // cart_test + write(stderr(), "(A)") "Expected result: " // test_case%cart + call mpp_error(FATAL, "get_axis_cart unit test failed") + endif + + next => test_case%next + deallocate(test_case) + test_case => next + enddo + + call close_file(test%fileobj) +end subroutine + +subroutine test_special_axis_names(test, special_axis_names, ret_expected) + type(GetAxisCartTest_t), intent(inout) :: test + character(*), intent(in) :: special_axis_names(:), ret_expected + character(:), allocatable :: var_name + integer :: i + + do i=1,size(special_axis_names) + var_name = trim(special_axis_names(i)) + call get_axis_cart_test_add(test, var_name, ret_expected) + enddo +end subroutine + +subroutine test_lon_in_range + real(k), parameter :: eps_big = 1e-3_k, eps_tiny = 1e-5_k + real(k), parameter :: pi_plus_360 = 360._k + pi + + ! Test some cases where no translation is needed + call lon_in_range_assert(0._k, 0._k, 0._k) + call lon_in_range_assert(1._k, 0._k, 1._k) + call lon_in_range_assert(350._k, 0._k, 350._k) + call lon_in_range_assert(1._k, 1._k, 1._k) + call lon_in_range_assert(350._k, 1._k, 350._k) + call lon_in_range_assert(359._k, 0._k, 359._k) + call lon_in_range_assert(359._k, 1._k, 359._k) + call lon_in_range_assert(pi, 0._k, pi) + + ! Test up-translation + call lon_in_range_assert(-2._k, -1._k, 358._k) + call lon_in_range_assert(-2._k, 0._k, 358._k) + call lon_in_range_assert(-2._k, 5._k, 358._k) + call lon_in_range_assert(-1._k, 0._k, 359._k) + call lon_in_range_assert(-1._k, 5._k, 359._k) + call lon_in_range_assert(0._k, 5._k, 360._k) + call lon_in_range_assert(1._k, 5._k, 361._k) + call lon_in_range_assert(-pi, 0._k, 360._k - pi) + + ! Test down-translation + call lon_in_range_assert(359._k, -1._k, -1._k) + call lon_in_range_assert(360._k, -1._k, 0._k) + call lon_in_range_assert(360._k, 0._k, 0._k) + call lon_in_range_assert(361._k, -1._k, 1._k) + call lon_in_range_assert(361._k, 0._k, 1._k) + call lon_in_range_assert(362._k, -1._k, 2._k) + call lon_in_range_assert(362._k, 0._k, 2._k) + call lon_in_range_assert(pi_plus_360, 0._k, pi_plus_360 - 360._k) + + ! Test rounding behavior + call lon_in_range_assert(eps_tiny, 0._k, 0._k) + call lon_in_range_assert(eps_big, 0._k, eps_big) + call lon_in_range_assert(360._k - eps_tiny, 0._k, 0._k) + call lon_in_range_assert(360._k - eps_big, 0._k, 360._k - eps_big) +end subroutine + +subroutine lon_in_range_assert(lon, l_start, ret_expected) + real(k), intent(in) :: lon, l_start, ret_expected + real(k) :: ret_test + + ret_test = lon_in_range(lon, l_start) + + if (ret_test /= ret_expected) then + write(stderr(), "(A)") "lon_in_range(" // string(lon) // ", " // string(l_start) // & + & ") returned erroneous value: " // string(ret_test) + write(stderr(), "(A)") "Expected return value: " // string(ret_expected) + call mpp_error(FATAL, "lon_in_range unit test failed") + endif +end subroutine + +#define CALC_FRAC_INDEX_(i, v, values) real(i, k) + (v - values(i)) / (values(i + 1) - values(i)) + +subroutine test_frac_index + real(k) :: values(6), v, fi + integer :: i, n + real(k), parameter :: f10=.1_k, f25=.25_k, f50=.5_k, f99=.99_k + + values = [1._k, 2._k, 3._k, 5._k, 10._k, 11._k] + n = size(values) + + ! Test values outside of the input array + call frac_index_assert(real(values(1), k) - f50, values, -1._k) + call frac_index_assert(real(values(n), k) + f50, values, -1._k) + + ! Test the actual indices + do i=1,n + v = values(i) + call frac_index_assert(v, values, real(i, k)) + enddo + + ! Test the 10% point + do i=1,n-1 + v = values(i) + f10*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo + + ! Test the 25% point + do i=1,n-1 + v = values(i) + f25*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo + + ! Test the mid-point + do i=1,n-1 + v = values(i) + f50*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo + + ! Test the 99% point + do i=1,n-1 + v = values(i) + f99*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo +end subroutine + +subroutine frac_index_assert(fval, arr, ret_expected) + real(k), intent(in) :: fval, arr(:), ret_expected + real(k) :: ret_test + + ret_test = frac_index(fval, arr) + + if (ret_test /= ret_expected) then + write(stderr(), "(A)") "frac_index(" // string(fval) // ", " // stringify(arr) // & + & ") returned erroneous value: " // string(ret_test) + write(stderr(), "(A)") "Expected return value: " // string(ret_expected) + call mpp_error(FATAL, "frac_index unit test failed") + endif +end subroutine + +! Test that frac_index fails with a non-monotonic array +subroutine test_frac_index_fail + real(k) :: values(5) + real(k) :: ret_test + + values = [1._k, 2._k, 4._k, 3._k, 5._k] + ret_test = frac_index(1.5_k, values) +end subroutine + +subroutine test_nearest_index + real(k) :: arr(5) + + arr = [5._k, 12._k, 20._k, 40._k, 100._k] + + ! Test values beyond array boundaries + call nearest_index_assert(4._k, arr, 1) + call nearest_index_assert(1000._k, arr, size(arr)) + + ! Test values actually in the array + call nearest_index_assert(5._k, arr, 1) + call nearest_index_assert(12._k, arr, 2) + call nearest_index_assert(20._k, arr, 3) + call nearest_index_assert(40._k, arr, 4) + call nearest_index_assert(100._k, arr, 5) + + ! Test the intervals between array values + call nearest_index_assert(6._k, arr, 1) + call nearest_index_assert(11._k, arr, 2) + call nearest_index_assert(15._k, arr, 2) + call nearest_index_assert(18._k, arr, 3) + call nearest_index_assert(29._k, arr, 3) +end subroutine + +subroutine nearest_index_assert(val, arr, ret_expected) + real(k), intent(in) :: val, arr(:) + integer, intent(in) :: ret_expected + integer :: ret_test + + ret_test = nearest_index(val, arr) + + if (ret_test /= ret_expected) then + write(stderr(), "(A)") "nearest_index(" // string(val) // ", " // stringify(arr) // & + & ") returned erroneous value: " // string(ret_test) + write(stderr(), "(A)") "Expected return value: " // string(ret_expected) + call mpp_error(FATAL, "nearest_index unit test failed") + endif +end subroutine + +! Test that nearest_index fails with a non-monotonic array +subroutine test_nearest_index_fail + real(k) :: arr(5) + integer :: ret_test + + arr=[5._k, 12._k, 40._k, 20._k, 100._k] + ret_test = nearest_index(5._k, arr) +end subroutine + +subroutine test_axis_edges + real(k) :: data_in_var(10) + real(k) :: data_in_var_edges(2,10) + real(k) :: data_in_answers(11) + type(FmsNetcdfFile_t) :: fileobj + real(k) :: answers(11) + integer :: i + + do i=1,10 + data_in_var(i) = real(i, k) - 0.5_k + + data_in_var_edges(1,i) = real(i-1, k) + data_in_var_edges(2,i) = real(i, k) + + data_in_answers(i) = real(i-1, k) + enddo + + data_in_answers(11) = 10._k + + call open_netcdf_w(fileobj) + + call register_axis(fileobj, "dim1", 10) + call register_axis(fileobj, "dim2", 2) + + call register_field(fileobj, "axis", "double", dimensions=["dim1"]) + + call register_field(fileobj, "axis_with_bounds", "double", dimensions=["dim1"]) + call register_variable_attribute(fileobj, "axis_with_bounds", "bounds", "bounds", str_len=6) + call register_field(fileobj, "bounds", "double", dimensions=["dim2", "dim1"]) + + call register_field(fileobj, "axis_with_edges", "double", dimensions=["dim1"]) + call register_variable_attribute(fileobj, "axis_with_edges", "edges", "edges"//char(0), str_len=6) + call register_field(fileobj, "edges", "double", dimensions=["dim2", "dim1"]) + + call write_data(fileobj, "axis", data_in_var) + call write_data(fileobj, "axis_with_bounds", data_in_var) + call write_data(fileobj, "axis_with_edges", data_in_var) + call write_data(fileobj, "bounds", data_in_var_edges) + call write_data(fileobj, "edges", data_in_var_edges) + + call close_file(fileobj) + + call open_netcdf_r(fileobj) + + !< Case 1: Here the variable "axis" in the file does not have the attribute "bounds" or "edges", so + !! it calculates them from the data in "axis" + answers = 0._k + call axis_edges(fileobj, "axis", answers) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 1)") + + !< Case 2: Here the variable "axis_with_bounds" in the file has the attribute + !! "bounds", so the data is read from the variable "bounds" + answers = 0._k + call axis_edges(fileobj, "axis_with_bounds", answers) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 2)") + + !< Case 3: Here the variable "axis_with_edges" in the file has the attribute + !"edges", so the data is read from the variable "edges" + answers = 0._k + call axis_edges(fileobj, "axis_with_edges", answers) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 3)") + + !< Case 4: Here the flag "reproduce_null_char_bug_flag" is turned on, so the + !! edges are calculated from the data in axis because edges has a null character + !! in the end + answers = 0._k + call axis_edges(fileobj, "axis_with_edges", answers, reproduce_null_char_bug_flag=.true.) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 4)") + + call close_file(fileobj) +end subroutine + +subroutine test_tranlon + real(k), dimension(5) :: lon1, lon2, lon3 + + lon1 = [1._k, 2._k, 3._k, 4._k, 5._k] + lon2 = [2._k, 3._k, 4._k, 5._k, 361._k] + lon3 = [3._k, 4._k, 5._k, 361._k, 362._k] + + ! The first two cases fail due to tranlon's unexpected behavior when no elements are translated. + ! TODO: Uncomment these tests if/when tranlon's behavior is fixed. + + !call tranlon_assert(lon1, lon1, 0.0_k, 1) + !call tranlon_assert(lon1, lon1, 1.0_k, 1) + + call tranlon_assert(lon1, lon2, 1.5_k, 2) + call tranlon_assert(lon1, lon2, 2.0_k, 2) + call tranlon_assert(lon1, lon3, 2.001_k, 3) +end subroutine + +subroutine tranlon_assert(lon0, lon_expected, lon_start, istrt_expected) + real(k), intent(in) :: lon0(:), lon_expected(:), lon_start + integer, intent(in) :: istrt_expected + integer :: istrt_test, i + real(k) :: lon_test(size(lon0)) + character(:), allocatable :: test_name + + test_name = "tranlon(" // stringify(lon0) // ", " // string(lon_start) // ", istrt)" + + lon_test = lon0 + call tranlon(lon_test, lon_start, istrt_test) + call array_compare_1d(lon_test, lon_expected, test_name // " unit test failed") + + if (istrt_test.ne.istrt_expected) then + write(stderr(), "(A)") test_name // " returned erroneous istrt value: " // string(istrt_test) + write(stderr(), "(A)") "Expected istrt value: " // string(istrt_expected) + call mpp_error(FATAL, "tranlon unit test failed") + endif +end subroutine + +! Status: SKELETAL +! TODO: More comprehensive interp_1d_1d test +subroutine test_interp_1d_1d + real(k) :: grid1(8), grid2(5), data1(8), data2(5) + + grid1 = [1._k, 2._k, 3._k, 4._k, 5._k, 6._k, 7._k, 8._k] + grid2 = [2._k, 3._k, 4._k, 5._k, 6._k] + data1 = [101._k, 102._k, 103._k, 104._k, 105._k, 106._k, 107._k, 108._k] + data2 = [102._k, 103._k, 104._k, 105._k, 106._k] + + call interp_1d_1d_assert(grid1, grid2, data1, data2, "linear") + call interp_1d_1d_assert(grid1, grid2, data1, data2, "cubic_spline") +end subroutine + +subroutine interp_1d_1d_assert(grid1, grid2, data1, data2_expected, method, yp1, yp2) + real(k), intent(in), dimension(:) :: grid1, grid2, data1, data2_expected + character(*), intent(in), optional :: method + real(k), intent(in), optional :: yp1, yp2 + real(k) :: data2_test(size(data2_expected)) + character(:), allocatable :: test_name + + test_name = "interp_1d_1d(" // & + stringify(grid1) // ", " // & + stringify(grid2) // ", " // & + stringify(data1) // ", data2" + + if (present(method)) then + test_name = test_name // ", method=" // method + endif + + if (present(yp1)) then + test_name = test_name // ", yp1=" // string(yp1) + endif + + if (present(yp2)) then + test_name = test_name // ", yp2=" // string(yp2) + endif + + test_name = test_name // ")" + + call interp_1d(grid1, grid2, data1, data2_test, method, yp1, yp2) + call array_compare_1d(data2_test, data2_expected, test_name // " unit test failed") +end subroutine + +! Status: SKELETAL +! TODO: More comprehensive interp_1d_2d test +subroutine test_interp_1d_2d + real(k) :: grid1(2,4), grid2(2,2), data1(2,4), data2(2,2) + + grid1(1,:) = [1._k, 2._k, 3._k, 4._k] + grid1(2,:) = [5._k, 6._k, 7._k, 8._k] + + grid2(1,:) = [2._k, 3._k] + grid2(2,:) = [6._k, 7._k] + + data1(1,:) = [101._k, 102._k, 103._k, 104._k] + data1(2,:) = [105._k, 106._k, 107._k, 108._k] + + data2(1,:) = [102._k, 103._k] + data2(2,:) = [106._k, 107._k] + + call interp_1d_2d_assert(grid1, grid2, data1, data2) +end subroutine + +subroutine interp_1d_2d_assert(grid1, grid2, data1, data2_expected) + real(k), intent(in), dimension(:,:) :: grid1, grid2, data1, data2_expected + real(k) :: data2_test(size(data2_expected,1), size(data2_expected,2)) + character(:), allocatable :: test_name + + test_name = "interp_1d_2d(" // & + stringify(grid1) // ", " // & + stringify(grid2) // ", " // & + stringify(data1) // ", data2)" + + call interp_1d(grid1, grid2, data1, data2_test) + call array_compare_2d(data2_test, data2_expected, test_name // " unit test failed") +end subroutine + +! Status: SKELETAL +! TODO: More comprehensive interp_1d_3d test +subroutine test_interp_1d_3d + real(k) :: grid1(2,2,4), grid2(2,2,2), data1(2,2,4), data2(2,2,2) + + grid1(1,1,:) = [1._k, 2._k, 3._k, 4._k] + grid1(1,2,:) = [5._k, 6._k, 7._k, 8._k] + grid1(2,1,:) = [21._k, 22._k, 23._k, 24._k] + grid1(2,2,:) = [25._k, 26._k, 27._k, 28._k] + + grid2(1,1,:) = [2._k, 3._k] + grid2(1,2,:) = [6._k, 7._k] + grid2(2,1,:) = [22._k, 23._k] + grid2(2,2,:) = [26._k, 27._k] + + data1(1,1,:) = [101._k, 102._k, 103._k, 104._k] + data1(1,2,:) = [105._k, 106._k, 107._k, 108._k] + data1(2,1,:) = [201._k, 202._k, 203._k, 204._k] + data1(2,2,:) = [205._k, 206._k, 207._k, 208._k] + + data2(1,1,:) = [102._k, 103._k] + data2(1,2,:) = [106._k, 107._k] + data2(2,1,:) = [202._k, 203._k] + data2(2,2,:) = [206._k, 207._k] + + call interp_1d_3d_assert(grid1, grid2, data1, data2) + call interp_1d_3d_assert(grid1, grid2, data1, data2, "linear") + call interp_1d_3d_assert(grid1, grid2, data1, data2, "cubic_spline") +end subroutine + +subroutine interp_1d_3d_assert(grid1, grid2, data1, data2_expected, method, yp1, yp2) + real(k), intent(in), dimension(:,:,:) :: grid1, grid2, data1, data2_expected + character(*), intent(in), optional :: method + real(k), intent(in), optional :: yp1, yp2 + real(k) :: data2_test(size(data2_expected,1), size(data2_expected,2), size(data2_expected,3)) + integer :: i,i2,i3 + character(:), allocatable :: test_name + + test_name = "interp_1d_3d(" // & + stringify(grid1) // ", " // & + stringify(grid2) // ", " // & + stringify(data1) // ", data2" + + if (present(method)) then + test_name = test_name // ", method=" // method + endif + + if (present(yp1)) then + test_name = test_name // ", yp1=" // string(yp1) + endif + + if (present(yp2)) then + test_name = test_name // ", yp2=" // string(yp2) + endif + + test_name = test_name // ")" + + call interp_1d(grid1, grid2, data1, data2_test, method, yp1, yp2) + call array_compare_3d(data2_test, data2_expected, test_name // " unit test failed") +end subroutine + +! +! Supporting utilities +! + +subroutine open_netcdf_w(fileobj) + type(FmsNetcdfFile_t), intent(out) :: fileobj + + if (.not.open_file(fileobj, "test_axis_utils.nc", "overwrite")) then + call mpp_error(FATAL, "Error opening test_axis_utils.nc to write") + endif +end subroutine + +subroutine open_netcdf_r(fileobj) + type(FmsNetcdfFile_t), intent(out) :: fileobj + + if (.not.open_file(fileobj, "test_axis_utils.nc", "read")) then + call mpp_error(FATAL, "Error opening test_axis_utils.nc to read") + endif +end subroutine + +subroutine array_compare_1d(arr1, arr2, msg) + real(k), intent(in), dimension(:) :: arr1, arr2 + character(*), intent(in) :: msg + integer :: i, m, n + + m = size(arr1) + n = size(arr2) + + if (m.ne.n) then + write(stderr(), "(A)") "1D array comparison failed due to incompatible array sizes" + write(stderr(), "(A)") "Array 1 has size " // string(m) // " and array 2 has size " // string(n) + call mpp_error(FATAL, msg) + endif + + do i=1,m + if (arr1(i).ne.arr2(i)) then + write(stderr(), "(A)") "1D array comparison failed due to element " // string(i) + write(stderr(), "(A)") "Array 1 has value " // string(arr1(i)) // & + & " and array 2 has value " // string(arr2(i)) + call mpp_error(FATAL, msg) + endif + enddo +end subroutine + +subroutine array_compare_2d(arr1, arr2, msg) + real(k), intent(in), dimension(:,:) :: arr1, arr2 + character(*), intent(in) :: msg + integer :: i1, i2, m1, m2, n1, n2 + + m1 = size(arr1, 1) + m2 = size(arr1, 2) + + n1 = size(arr2, 1) + n2 = size(arr2, 2) + + if (m1.ne.n1 .or. m2.ne.n2) then + write(stderr(), "(A)") "2D array comparison failed due to incompatible array sizes" + write(stderr(), "(A)") "Array 1 has size " // string(m1) // "x" // string(m2) // & + & " and array 2 has size " // string(n1) // "x" // string(n2) + call mpp_error(FATAL, msg) + endif + + do i2=1,m2 + do i1=1,m1 + if (arr1(i1,i2).ne.arr2(i1,i2)) then + write(stderr(), "(A)") "2D array comparison failed due to element " // string(i1) // "," // string(i2) + write(stderr(), "(A)") "Array 1 has value " // string(arr1(i1,i2)) // & + & " and array 2 has value " // string(arr2(i1,i2)) + call mpp_error(FATAL, msg) + endif + enddo + enddo +end subroutine + +subroutine array_compare_3d(arr1, arr2, msg) + real(k), intent(in), dimension(:,:,:) :: arr1, arr2 + character(*), intent(in) :: msg + integer :: i1, i2, i3, m1, m2, m3, n1, n2, n3 + + m1 = size(arr1, 1) + m2 = size(arr1, 2) + m3 = size(arr1, 3) + + n1 = size(arr2, 1) + n2 = size(arr2, 2) + n3 = size(arr2, 3) + + if (m1.ne.n1 .or. m2.ne.n2 .or. m3.ne.n3) then + write(stderr(), "(A)") "3D array comparison failed due to incompatible array sizes" + write(stderr(), "(A)") "Array 1 has size " // string(m1) // "x" // string(m2) // "x" // string(m3) // & + & " and array 2 has size " // string(n1) // "x" // string(n2) // "x" // string(n3) + call mpp_error(FATAL, msg) + endif + + do i3=1,m3 + do i2=1,m2 + do i1=1,m1 + if (arr1(i1,i2,i3).ne.arr2(i1,i2,i3)) then + write(stderr(), "(A)") "3D array comparison failed due to element " // & + & string(i1) // "," // string(i2) // "," // string(i3) + write(stderr(), "(A)") "Array 1 has value " // string(arr1(i1,i2,i3)) // & + & " and array 2 has value " // string(arr2(i1,i2,i3)) + call mpp_error(FATAL, msg) + endif + enddo + enddo + enddo +end subroutine + +end program test_axis_utils diff --git a/test_fms/axis_utils/test_axis_utils2.sh b/test_fms/axis_utils/test_axis_utils2.sh index 746a7add8d..bf6b0cfbee 100755 --- a/test_fms/axis_utils/test_axis_utils2.sh +++ b/test_fms/axis_utils/test_axis_utils2.sh @@ -27,11 +27,27 @@ # Prepare the directory to run the tests. touch input.nml -# Run the test. -test_expect_success "Test AXIS utils r4_kind" ' - mpirun -n 2 ./test_axis_utils_r4 -' -test_expect_success "Test AXIS utils r8_kind" ' - mpirun -n 2 ./test_axis_utils_r8 -' +TESTS_SUCCESS='--get-axis-modulo --get-axis-modulo-times --get-axis-cart --lon-in-range --frac-index --nearest-index --axis-edges --tranlon --interp-1d-1d --interp-1d-2d --interp-1d-3d' +TESTS_FAIL='--frac-index-fail --nearest-index-fail' + +# Run the tests + +for t in $TESTS_SUCCESS +do + r4cmd="./test_axis_utils_r4 $t" + r8cmd="./test_axis_utils_r8 $t" + + test_expect_success "Testing axis utils: $r4cmd" "mpirun -n 1 $r4cmd" + test_expect_success "Testing axis utils: $r8cmd" "mpirun -n 1 $r8cmd" +done + +for t in $TESTS_FAIL +do + r4cmd="./test_axis_utils_r4 $t" + r8cmd="./test_axis_utils_r8 $t" + + test_expect_failure "Testing axis utils: $r4cmd" "mpirun -n 1 $r4cmd" + test_expect_failure "Testing axis utils: $r8cmd" "mpirun -n 1 $r8cmd" +done + test_done diff --git a/test_fms/axis_utils/test_axis_utils_r4.F90 b/test_fms/axis_utils/test_axis_utils_r4.F90 deleted file mode 100644 index 61816b591a..0000000000 --- a/test_fms/axis_utils/test_axis_utils_r4.F90 +++ /dev/null @@ -1,166 +0,0 @@ -!*********************************************************************** -!* 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 . -!*********************************************************************** - -program test_axis_utils_r4 - - use fms_mod, only : fms_init, fms_end, check_nml_error - use mpp_mod, only : mpp_sync, mpp_pe, mpp_root_pe, mpp_error, FATAL, stdout, & - mpp_get_current_pelist, mpp_npes - use mpp_mod, only : input_nml_file - use axis_utils2_mod, only : axis_edges - use fms2_io_mod, only : open_file, close_file, write_data, register_axis, register_field, & - FmsNetcdfFile_t, register_variable_attribute - use platform_mod, only : r4_kind - - implicit none - - type data_type - real(kind=r4_kind) :: var(10) !< Axis data - real(kind=r4_kind) :: var_edges(2,10) !< The boundaries of the axis data - real(kind=r4_kind) :: answers(11) !< The expected result - end type data_type - - type(data_type) :: data_in !< Data used to create the netcdf file - integer, allocatable :: pes(:) !< List of pes - type(FmsNetcdfFile_t) :: fileobj !< FMS2_io fileobj - - real(kind=r4_kind) :: answers(11) !< Results obtained from the axis_edges call - - call fms_init - - !< Get the current pelist - allocate(pes(mpp_npes())) - call mpp_get_current_pelist(pes) - - call set_data(data_in) - call create_input_files(data_in) - - !< Test calls to axis_edges - if ( .not. open_file(fileobj, "test_axis_utils.nc", "read", pelist=pes)) then - call mpp_error(FATAL, "Error opening test_axis_utils.nc to read") - endif - - !< Case 1: Here the variable "axis" in the file does not have the attribute "bounds" or "edges", so - !! it calculates them from the data in "axis" - answers = 0.0_r4_kind - call axis_edges(fileobj, "axis", answers) - call compare_answers(answers, data_in%answers, "1") - - !< Case 2: Here the variable "axis_with_bounds" in the file has the attribute - !! "bounds", so the data is read from the variable "bounds" - answers = 0.0_r4_kind - call axis_edges(fileobj, "axis_with_bounds", answers) - call compare_answers(answers, data_in%answers, "2") - - !< Case 3: Here the variable "axis_with_edges" in the file has the attribute - !"edges", so the data is read from the variable "edges" - answers = 0.0_r4_kind - call axis_edges(fileobj, "axis_with_edges", answers) - call compare_answers(answers, data_in%answers, "3") - - !< Case 4: Here the flag "reproduce_null_char_bug_flag" is turned on, so the - !! edges are calculated from the data in axis because edges has a null character - !! in the end - answers = 0.0_r4_kind - call axis_edges(fileobj, "axis_with_edges", answers, reproduce_null_char_bug_flag=.true.) - call compare_answers(answers, data_in%answers, "4") - - call close_file(fileobj) - deallocate(pes) - - call fms_end - - contains - - !> @brief Compares the values of two arrays - subroutine compare_answers(answers_in, answers_expected, test_case) - real(kind=r4_kind), intent(in) :: answers_in(:) !< Answer calculated - real(kind=r4_kind), intent(in) :: answers_expected(:) !< Answer expected - character(1), intent(in) :: test_case !< String indicating the case number - - integer :: i !< For do loop - - do i = 1, size(answers_expected,1) - if(answers_in(i) .ne. answers_expected(i)) then - print *, "i=", i, " Answer in: ", answers_in(i), " Answer expected ", answers_expected(i) - call mpp_error(FATAL, "axis_edges case"//trim(test_case)//": Answers are not correct") - endif - enddo - end subroutine compare_answers - - !> @brief Sets the values of the data_type to be use to write the file, and to - !! compare answers - subroutine set_data(data_in) - type(data_type), intent(out) :: data_in !< data_type to set the expected values to - - integer :: i !< For do loop - - do i=1,10 - data_in%var(i) = real(i, kind=r4_kind)-0.5_r4_kind - - data_in%var_edges(1,i) = real(i-1, kind=r4_kind) - data_in%var_edges(2,i) = real(i, kind=r4_kind) - - data_in%answers(i) = real(i-1, kind=r4_kind) - enddo - - data_in%answers(11) = real(10, kind=r4_kind) - - end subroutine - - !> @brief Creates a netcdf file to test the different test cases of - !!"axis_edges" - subroutine create_input_files(data_in) - type(data_type), intent(in) :: data_in !< data_type containing the values to be added to the file - - type(FmsNetcdfFile_t) :: fileobj !< FMS2_io fileobj - - if (mpp_pe() .eq. mpp_root_pe()) then - if ( .not. open_file(fileobj, "test_axis_utils.nc", "overwrite")) then - call mpp_error(FATAL, "Error opening test_axis_utils.nc to write") - endif - - call register_axis(fileobj, "dim1", 10) - call register_axis(fileobj, "dim2", 2) - - call register_field(fileobj, "axis", "double", dimensions=(/"dim1"/)) - - call register_field(fileobj, "axis_with_bounds", "double", dimensions=(/"dim1"/)) - call register_variable_attribute(fileobj, "axis_with_bounds", "bounds", "bounds", str_len=6) - call register_field(fileobj, "bounds", "double", dimensions=(/"dim2", "dim1"/)) - - call register_field(fileobj, "axis_with_edges", "double", dimensions=(/"dim1"/)) - call register_variable_attribute(fileobj, "axis_with_edges", "edges", "edges"//char(0), str_len=6) - call register_field(fileobj, "edges", "double", dimensions=(/"dim2", "dim1"/)) - - call write_data(fileobj, "axis", data_in%var) - call write_data(fileobj, "axis_with_bounds", data_in%var) - call write_data(fileobj, "axis_with_edges", data_in%var) - call write_data(fileobj, "bounds", data_in%var_edges) - call write_data(fileobj, "edges", data_in%var_edges) - - call close_file(fileobj) - endif - - !< Wait for root_pe to catch up! - call mpp_sync() - - end subroutine create_input_files - - end program test_axis_utils_r4 \ No newline at end of file diff --git a/test_fms/axis_utils/test_axis_utils_r8.F90 b/test_fms/axis_utils/test_axis_utils_r8.F90 deleted file mode 100644 index de06c77733..0000000000 --- a/test_fms/axis_utils/test_axis_utils_r8.F90 +++ /dev/null @@ -1,166 +0,0 @@ -!*********************************************************************** -!* 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 . -!*********************************************************************** - -program test_axis_utils_r8 - -use fms_mod, only : fms_init, fms_end, check_nml_error -use mpp_mod, only : mpp_sync, mpp_pe, mpp_root_pe, mpp_error, FATAL, stdout, & - mpp_get_current_pelist, mpp_npes -use mpp_mod, only : input_nml_file -use axis_utils2_mod, only : axis_edges -use fms2_io_mod, only : open_file, close_file, write_data, register_axis, register_field, & - FmsNetcdfFile_t, register_variable_attribute -use platform_mod, only : r8_kind - -implicit none - -type data_type - real(kind=r8_kind) :: var(10) !< Axis data - real(kind=r8_kind) :: var_edges(2,10) !< The boundaries of the axis data - real(kind=r8_kind) :: answers(11) !< The expected result -end type data_type - -type(data_type) :: data_in !< Data used to create the netcdf file -integer, allocatable :: pes(:) !< List of pes -type(FmsNetcdfFile_t) :: fileobj !< FMS2_io fileobj - -real(kind=r8_kind) :: answers(11) !< Results obtained from the axis_edges call - -call fms_init - -!< Get the current pelist -allocate(pes(mpp_npes())) -call mpp_get_current_pelist(pes) - -call set_data(data_in) -call create_input_files(data_in) - -!< Test calls to axis_edges -if ( .not. open_file(fileobj, "test_axis_utils.nc", "read", pelist=pes)) then - call mpp_error(FATAL, "Error opening test_axis_utils.nc to read") -endif - -!< Case 1: Here the variable "axis" in the file does not have the attribute "bounds" or "edges", so -!! it calculates them from the data in "axis" -answers = 0.0_r8_kind -call axis_edges(fileobj, "axis", answers) -call compare_answers(answers, data_in%answers, "1") - -!< Case 2: Here the variable "axis_with_bounds" in the file has the attribute -!! "bounds", so the data is read from the variable "bounds" -answers = 0.0_r8_kind -call axis_edges(fileobj, "axis_with_bounds", answers) -call compare_answers(answers, data_in%answers, "2") - -!< Case 3: Here the variable "axis_with_edges" in the file has the attribute -!"edges", so the data is read from the variable "edges" -answers = 0.0_r8_kind -call axis_edges(fileobj, "axis_with_edges", answers) -call compare_answers(answers, data_in%answers, "3") - -!< Case 4: Here the flag "reproduce_null_char_bug_flag" is turned on, so the -!! edges are calculated from the data in axis because edges has a null character -!! in the end -answers = 0.0_r8_kind -call axis_edges(fileobj, "axis_with_edges", answers, reproduce_null_char_bug_flag=.true.) -call compare_answers(answers, data_in%answers, "4") - -call close_file(fileobj) -deallocate(pes) - -call fms_end - -contains - -!> @brief Compares the values of two arrays -subroutine compare_answers(answers_in, answers_expected, test_case) -real(kind=r8_kind), intent(in) :: answers_in(:) !< Answer calculated -real(kind=r8_kind), intent(in) :: answers_expected(:) !< Answer expected -character(1), intent(in) :: test_case !< String indicating the case number - -integer :: i !< For do loop - -do i = 1, size(answers_expected,1) - if(answers_in(i) .ne. answers_expected(i)) then - print *, "i=", i, " Answer in: ", answers_in(i), " Answer expected ", answers_expected(i) - call mpp_error(FATAL, "axis_edges case"//trim(test_case)//": Answers are not correct") - endif -enddo -end subroutine compare_answers - -!> @brief Sets the values of the data_type to be use to write the file, and to -!! compare answers -subroutine set_data(data_in) -type(data_type), intent(out) :: data_in !< data_type to set the expected values to - -integer :: i !< For do loop - -do i=1,10 - data_in%var(i) = real(i, kind=r8_kind)-0.5_r8_kind - - data_in%var_edges(1,i) = real(i-1, kind=r8_kind) - data_in%var_edges(2,i) = real(i, kind=r8_kind) - - data_in%answers(i) = real(i-1, kind=r8_kind) -enddo - -data_in%answers(11) = real(10, kind=r8_kind) - -end subroutine - -!> @brief Creates a netcdf file to test the different test cases of -!!"axis_edges" -subroutine create_input_files(data_in) -type(data_type), intent(in) :: data_in !< data_type containing the values to be added to the file - -type(FmsNetcdfFile_t) :: fileobj !< FMS2_io fileobj - -if (mpp_pe() .eq. mpp_root_pe()) then - if ( .not. open_file(fileobj, "test_axis_utils.nc", "overwrite")) then - call mpp_error(FATAL, "Error opening test_axis_utils.nc to write") - endif - - call register_axis(fileobj, "dim1", 10) - call register_axis(fileobj, "dim2", 2) - - call register_field(fileobj, "axis", "double", dimensions=(/"dim1"/)) - - call register_field(fileobj, "axis_with_bounds", "double", dimensions=(/"dim1"/)) - call register_variable_attribute(fileobj, "axis_with_bounds", "bounds", "bounds", str_len=6) - call register_field(fileobj, "bounds", "double", dimensions=(/"dim2", "dim1"/)) - - call register_field(fileobj, "axis_with_edges", "double", dimensions=(/"dim1"/)) - call register_variable_attribute(fileobj, "axis_with_edges", "edges", "edges"//char(0), str_len=6) - call register_field(fileobj, "edges", "double", dimensions=(/"dim2", "dim1"/)) - - call write_data(fileobj, "axis", data_in%var) - call write_data(fileobj, "axis_with_bounds", data_in%var) - call write_data(fileobj, "axis_with_edges", data_in%var) - call write_data(fileobj, "bounds", data_in%var_edges) - call write_data(fileobj, "edges", data_in%var_edges) - - call close_file(fileobj) -endif - -!< Wait for root_pe to catch up! -call mpp_sync() - -end subroutine create_input_files - -end program test_axis_utils_r8 diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index ed45102f7f..f5e646cd27 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -22,17 +22,18 @@ # uramirez, Ed Hartnett # Find the needed mod and .inc files. -AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager/include -I$(MODDIR) # Link to the FMS library. LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_diag_manager test_diag_manager_time +check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_update_buffer # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 test_diag_manager_time_SOURCES = test_diag_manager_time.F90 +test_diag_update_buffer_SOURCES= test_diag_update_buffer.F90 TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index a4d36cf52b..747be8e691 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -500,5 +500,9 @@ _EOF test_expect_success "diurnal test (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager_time ' - -test_done +setup_test +my_test_count=`expr $my_test_count + 1` +test_expect_success "Test the diag update_buffer (test $my_test_count)" ' + mpirun -n 1 ../test_diag_update_buffer +' + test_done diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 new file mode 100644 index 0000000000..67de3ec665 --- /dev/null +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -0,0 +1,491 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @brief This programs tests the update of field data buffers with +!! the "math" functions in module fms_diag_fieldbuff_update_mod. It mimics +!! the daig_manager::send_4d operation of calling those functions. +program test_diag_update_buffer + use platform_mod + use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated + use fms_mod, ONLY: fms_init, fms_end, error_mesg, FATAL,NOTE + use diag_data_mod, ONLY: VERY_LARGE_AXIS_LENGTH + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfield_type, fmsDiagOutfieldIndex_type + USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & + & fieldbuff_copy_fieldvals + USE fms_diag_time_reduction_mod, ONLY: fmsDiagTimeReduction_type, time_average, time_rms + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type + + implicit none + + !! Class diag_buffer_type is here only for temporary use for modern diag_manager + !! development until the real buffer class is sufficiently ready and merged. + TYPE diagTestBuffer_type + CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: buffer + CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: counter + CLASS(*), ALLOCATABLE, DIMENSION(:) :: count_0d + INTEGER, ALLOCATABLE, dimension(:) :: num_elements + END TYPE diagTestBuffer_type + + integer,parameter :: SZ=10 !< Field data this size in all spatiall dims. + integer,parameter :: SL=2 !< Field data this size in 4th dim + integer,parameter :: NDI=1 !< Number of diurnal elemes + CLASS(*), ALLOCATABLE :: r4_datapoint, i8_datapoint !< to be allocated of rype data (e.g. r4. i8) + !! to be used thought. + + TYPE(fmsDiagIbounds_type) :: buff_bounds + + !!Diag_manager::send_data uses CLASS(*) in function signature, SO + !! we mimic the resulting operations. The set of ClASS(*) data needs to be allocated of same + !! type in order to be able to call the math/buffer update funtions. + CLASS(*), ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: field_data + CLASS(*), ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: rmask + CLASS(*), ALLOCATABLE, TARGET :: missvalue + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: mask + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: oor_mask + TYPE(diagTestBuffer_type), ALLOCATABLE, TARGET :: buff_obj + + !! In principle, the field_data can be r4,r8,i4,i8,but we will only rest r4,i8 + !!These belwo will be pointers to the data + REAL (kind=r4_kind),dimension (:,:,:,:),pointer::field_r4_ptr => null() !< Ptr to r4 field data array + REAL (kind=r4_kind),dimension (:,:,:,:),pointer::rmask_r4_ptr => null() !< Ptr to r4 field data rmask array + REAL (kind=r4_kind),pointer::missval_r4_ptr => null() !< Ptr to r4 missing value data. + INTEGER (kind=i8_kind),dimension (:,:,:,:),pointer::field_i8_ptr => null() !< Ptr to i8 field data array + INTEGER (kind=i8_kind),dimension (:,:,:,:),pointer::rmask_i8_ptr => null() !< Ptr to i8 field data rmask array + INTEGER (kind=i8_kind),pointer::missval_i8_ptr => null() !< Ptr to i8 missing value data. + + !! Typed pointers to buffer class(*) data will be needed + REAL (kind=r4_kind),dimension (:,:,:,:,:),pointer::ofb_r4_ptr => null() ! null() ! null() !< Ptr to r4 count0d member of buffer obj. + !! Typed pointers to buffer class(*) data will be needed + INTEGER (kind=i8_kind),dimension (:,:,:,:,:),pointer::ofb_i8_ptr => null() ! null() ! null() ! field_data + rmask_r4_ptr => rmask + missval_r4_ptr => missvalue + END SELECT + END SELECT + TYPE IS (integer(kind=i8_kind)) + SELECT TYPE ( rmask ) + TYPE IS (INTEGER(kind=i8_kind)) + SELECT TYPE ( missvalue ) + TYPE IS (INTEGER(kind=i8_kind)) + field_i8_ptr => field_data + rmask_i8_ptr => rmask + missval_i8_ptr => missvalue + END SELECT + END SELECT + CLASS DEFAULT + CALL error_mesg ('test_update_buffers_with_field','ptr assignemnt unsupported type', FATAL) + END SELECT + + SELECT TYPE ( ofb => buff_obj%buffer ) + TYPE IS (real(kind=r4_kind)) + SELECT TYPE ( ofc => buff_obj%counter ) + TYPE IS (real(kind=r4_kind)) + SELECT TYPE ( ofb0d => buff_obj%count_0d ) + TYPE IS (real(kind=r4_kind)) + ofb_r4_ptr => ofb + ofc_r4_ptr => ofc + ofb0d_r4_ptr => ofb0d + END SELECT + END SELECT + TYPE IS (integer(kind=i8_kind)) + SELECT TYPE ( ofc => buff_obj%counter ) + TYPE IS (INTEGER(kind=i8_kind)) + SELECT TYPE ( ofb0d => buff_obj%count_0d ) + TYPE IS (INTEGER(kind=i8_kind)) + ofb_i8_ptr => ofb + ofc_i8_ptr => ofc + ofb0d_i8_ptr => ofb0d + END SELECT + END SELECT + CLASS DEFAULT + CALL error_mesg ('diag_manager_mod::send_data_4d', 'ptr assigenment error', FATAL) + END SELECT + + + diag_field_id = 1 + sample = 1 + weight = 1.0 + missvalue = 1.0e-5 + pow_value = 1 + phys_window = .false. + need_compute = .false. + mask_variant = .false. + reduced_k_range = .false. + num_elems = 0 + num_threads = 1 + active_omp_level = 0 + issued_mask_ignore_warning = .false. + mask = .true. + + + call init_buff_values_1 (buff_obj%buffer, buff_obj%counter, buff_obj%count_0d, buff_obj%num_elements) + + hi = 0 !!halo size i + hj = 0 !!halo size j + l_start(1) = 1 !!local (to PE) start inddex + l_start(2) = 1 + l_start(3) = 1 + l_end(1) = SZ + l_end(2) = SZ + l_end(3) = SZ + + + ALLOCATE( ofield_cfg ) + call ofield_cfg%initialize_for_ut(module_name1, field_name1, output_name1, pow_value, & + & phys_window, need_compute, mask_variant, reduced_k_range , & + & num_elems, time_reduction_type1, output_freq1 ) + ALLOCATE( ofield_index_cfg ) + CALL init_ofield_index_cfg(ofield_index_cfg, 1+hi, 1+hj, 1, SZ - hi, SZ - hj, SZ,& + & hi, hj, 1 + hi, SZ - hi, 1 + hj, SZ - hj) + + !!First make sure buffer vals are all zero + call check_results_2(ofb_r4_ptr, 1, 0) + + !! Update the buffer values with the fieldbuff_update function. + !! Case: mask_var=false & missval not present & mask not present & not_reduced_k_range + test_passed = .true. !! will be set to false if there are any issues. + + temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_r4_ptr, sample, & + & ofb_r4_ptr, ofc_r4_ptr, buff_bounds, & + & ofb0d_r4_ptr (sample), buff_obj%num_elements(sample), & + & mask, weight, missval_r4_ptr, & + & num_threads, active_omp_level, & + & issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) + + call check_results_1(ofb_r4_ptr, 1, "Buffer_update_test01") + call print_output_field_values( buff_obj%buffer, 1 ) + + !! ************ 2ND TEST: ********************** + !!First make sure buffer vals are all zero + ofb_r4_ptr = 0 + call check_results_2(ofb_r4_ptr, 1, 0) + + !! Update the buffer values with the copy_fieldvals function. + ! missvalue_present = .true. TBD + !!call print_output_field_values( buff_obj%buffer, 1 ) + temp_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_r4_ptr, sample, & + & ofb_r4_ptr, buff_bounds, & + & ofb0d_r4_ptr(sample), mask, missval_r4_ptr, & + & l_start, l_end, err_msg, err_msg_local ) + + !!call print_output_field_values( buff_obj%buffer, 1 ) + + call check_results_1(ofb_r4_ptr, 1, "Buffer_update_test02") + + call error_mesg('test_diag_update_buffer', 'Test has finished',NOTE) + + call fms_end + +CONTAINS + + !> @brief Initialized an fms_diag_outfield_index_type by calling member funtion of + !! fms_diag_outfield_index_type input object. + SUBROUTINE init_ofield_index_cfg(idx_cfg, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + type(fmsDiagOutfieldIndex_type), INTENT(inout) :: idx_cfg !< The object to initialize. + INTEGER, INTENT(in) :: is, js, ks !< Var with same name in fms_diag_outfield_index_type + INTEGER, INTENT(in) :: ie, je, ke !< Var with same name in fms_diag_outfield_index_type + INTEGER, INTENT(in) :: hi, hj !< Var with same name in fms_diag_outfield_index_type + INTEGER, INTENT(in) :: f1, f2, f3, f4 !< Var with same name in fms_diag_outfield_index_type + call idx_cfg%initialize ( is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + end subroutine init_ofield_index_cfg + + SUBROUTINE init_field_values (field) + CLASS(*), DIMENSION(:,:,:,:), INTENT(INOUT) :: field + INTEGER :: NX,NY,NZ, NL + INTEGER :: i,j,k,l + INTEGER :: itemp + NX = size(field,1) + NY= size(field,2) + NZ= size(field,3) + NL= size(field,4) + DO l = 1, NL + DO k = 1, NZ + DO j = 1, NY + DO i = 1, NX + SELECT TYPE ( field) + TYPE IS (real(kind=r4_kind)) + itemp = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) +1 TYPE IS (integer(kind=i8_kind)) + field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + END SELECT + END DO + END DO + END DO + END DO + END SUBROUTINE init_field_values + + !> @brief Init to zero the buffer, counter , an + SUBROUTINE init_buff_values_1 (buffer, counter, count_0d, num_elems) + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: buffer !< The actual buffer array of the buffer class. + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: counter !< The actual buffer array of the buffer class. + CLASS(*), DIMENSION(:), INTENT(INOUT) :: count_0d !< A counter used in time averaging. + INTEGER, DIMENSION(:), INTENT(INOUT) :: num_elems !< A counter used in time averaging. + INTEGER, PARAMETER :: sample = 1 !< The diurnal sample. + + SELECT TYPE ( buffer) + TYPE IS (real(kind=r4_kind)) + buffer = 0 + TYPE IS (integer(kind=i8_kind)) + buffer = 0 + END SELECT + + SELECT TYPE ( counter) + TYPE IS (real(kind=r4_kind)) + counter = 0 + TYPE IS (integer(kind=i8_kind)) + counter = 0 + END SELECT + + SELECT TYPE ( count_0d) + TYPE IS (real(kind=r4_kind)) + count_0d = 0 + TYPE IS (integer(kind=i8_kind)) + count_0d = 0 + end select + + num_elems = 0 + END SUBROUTINE init_buff_values_1 + + + SUBROUTINE print_output_field_values (buffer, onum) + CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,: ) :: buffer + INTEGER, INTENT(IN) :: onum + INTEGER :: i,j,k + INTEGER :: ti + REAL :: tr + print *, "Start of print_output_field_values" + k = 1 + DO j =1 ,10 + DO i = 1,10 + SELECT TYPE ( buffer) + TYPE IS (real(kind=r4_kind)) + !print "(10f10.1)", buffer(:,j,k,1,1) + tr = buffer(i,j,k,1,1) + print "(f10.1)", tr + TYPE IS (integer(kind=i8_kind)) + !print "(10I10)", buffer(:,j,k,1,1) + !print "(I8))", buffer(i,j,k,1,1) + print "(I8)", ti + END SELECT + end do + print *, "************************" + end do + print *, "End of print_output_field_values" + END SUBROUTINE print_output_field_values + +!> @brief Verify that the buffer data is equal to the expected index value + SUBROUTINE check_results_1(buff, sample, test_name) + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(IN) :: buff !< The 5D buffer + INTEGER, INTENT(in) :: sample !< The diurnal sample + CHARACTER(*), INTENT(in) :: test_name !< The test name + INTEGER :: NX,NY,NZ, NL + INTEGER :: i,j,k,l + LOGICAL :: pass + integer :: idx + real :: bv + pass = .true. + NX = size(buff,1) + NY= size(buff,2) + NZ= size(buff,3) + NL= size(buff,4) + + DO l = 1, NL + DO k = 1, NZ + DO j = 1, NY + DO i = 1, NX + SELECT TYPE ( buff) + TYPE IS (real(kind=r4_kind)) + idx = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + bv = buff(i,j,k,l,sample) + if ( get_array_index_from_4D(i,j,k,l,NX,NY,NZ) /= buff(i,j,k,l,sample) ) then + pass = .false. + endif + TYPE IS (integer(kind=i8_kind)) + if ( get_array_index_from_4D(i,j,k,l,NX,NY,NZ) /= buff(i,j,k,l,sample) ) then + pass = .false. + endif + END SELECT + END DO + END DO + END DO + END DO + if ( pass .eqv. .false.) then + call error_mesg('check_results_1', test_name//" has failed.",FATAL) + end if + end subroutine check_results_1 + + SUBROUTINE check_results_2(buff, sample, val) + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(IN) :: buff + INTEGER, INTENT(in) :: sample + INTEGER, INTENT(in) :: val + INTEGER :: NX,NY,NZ, NL + INTEGER :: i,j,k,l + LOGICAL :: pass + + pass = .true. + NX = size(buff,1) + NY= size(buff,2) + NZ= size(buff,3) + NL= size(buff,4) + DO l = 1, NL + DO k = 1, NZ + DO j = 1, NY + DO i = 1, NX + SELECT TYPE ( buff) + TYPE IS (real(kind=r4_kind)) + if ( buff(i,j,k,l,sample) /= val ) then + pass = .false. + endif + TYPE IS (integer(kind=i8_kind)) + if ( buff(i,j,k,l,sample) /= val ) then + pass = .false. + endif + END SELECT + END DO + END DO + END DO + END DO + if ( pass .eqv. .false.) then + call error_mesg('check_results_2', 'Test has failed',FATAL) + end if + end subroutine check_results_2 + + !> @brief Calculate the unique index into a 4D array given the first four indecies + !! i,j,k,l and the with in the fist three dimensions. + pure integer function get_array_index_from_4D(i,j,k, l, NX,NY,NZ) + INTEGER, INTENT(IN) :: i, j, k, l !< The three spatial dimentsions plus another + INTEGER, INTENT(IN) :: NX, NY, NZ !< The size of the spatial dimentions. + get_array_index_from_4D = (l-1)* (NX * NY * NZ) + (k-1) * NX * NY + (j-1) * NX + i + end function get_array_index_from_4D + + subroutine allocate_input_data_and_ptrs(datapoint, field_data, rmask, missvalue, mask, NX,NY,NZ, NL) + CLASS(*), INTENT(in) :: datapoint !!The type of data we want + CLASS(*), ALLOCATABLE, INTENT(inout), DIMENSION(:,:,:,:) :: field_data + CLASS(*), ALLOCATABLE, INTENT(inout), DIMENSION(:,:,:,:) :: rmask + CLASS(*), ALLOCATABLE, INTENT(inout) :: missvalue + LOGICAL, ALLOCATABLE, INTENT(inout), DIMENSION(:,:,:,:) :: mask + INTEGER , INTENT(in) :: NX,NY,NZ, NL + select type (datapoint) + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: field_data(NX,NY,NZ,NL)) + allocate(integer(kind=i8_kind) :: rmask(NX,NY,NZ,NL)) + allocate(integer(kind=i8_kind) :: missvalue) + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: field_data(NX,NY,NZ,NL)) + allocate(real(kind=r4_kind) :: rmask(NX,NY,NZ,NL)) + allocate(real(kind=r4_kind) :: missvalue) + class default + call error_mesg("allocate input data", "The input data type is not a r4 or i8", FATAL) + end select + + allocate(mask(NX,NY,NZ,NL)) + END subroutine allocate_input_data_and_ptrs + + + subroutine allocate_buffer_obj( data_point, bo, NX,NY,NZ, NL, NDI) + TYPE(diagTestBuffer_type), INTENT(inout), allocatable :: bo + CLASS(*), INTENT(in) :: data_point !< Sample point allocated to the type being tested. + INTEGER, INTENT(IN) :: NX, NY, NZ !< The three spatial dimensions. + INTEGER, INTENT(IN) :: NL !< Size of the 4th dimentions + INTEGER, INTENT(IN) :: NDI !< Diurnal axis length, + allocate (bo) + select type (data_point) + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: bo%buffer(NX,NY,NZ,NL, NDI)) + allocate(integer(kind=i8_kind) :: bo%counter(NX,NY,NZ,NL, NDI)) + allocate(integer(kind=i8_kind) :: bo%count_0d(NDI)) + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: bo%buffer(NX,NY,NZ,NL,NDI)) + allocate(real(kind=r4_kind) :: bo%counter(NX,NY,NZ,NL,NDI)) + allocate(real(kind=r4_kind) :: bo%count_0d(NDI)) + class default + call error_mesg("allocate buffer obj", "The input data type is not a r4 or i8", FATAL) + end select + + allocate( bo%num_elements(NDI)) + + END subroutine allocate_buffer_obj +end program test_diag_update_buffer + + diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 index ff9f51ec4e..41d4923c71 100644 --- a/test_fms/string_utils/test_string_utils.F90 +++ b/test_fms/string_utils/test_string_utils.F90 @@ -22,6 +22,7 @@ program test_fms_string_utils use fms_string_utils_mod use fms_mod, only: fms_init, fms_end + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind use mpp_mod use, intrinsic :: iso_c_binding @@ -110,6 +111,9 @@ program test_fms_string_utils print *, "Checking if fms_find_unique determines the correct number of unique strings" if (nunique .ne. 7) call mpp_error(FATAL, "The number of unique strings in your array is not correct") + call check_string + call check_stringify + call fms_end() deallocate(my_array) @@ -165,4 +169,93 @@ subroutine check_my_indices(indices, ans, string) end do end subroutine check_my_indices + subroutine check_string + if (string(.true.) .ne. "True") then + call mpp_error(FATAL, "string() unit test failed for Boolean true value") + endif + + if (string(.false.) .ne. "False") then + call mpp_error(FATAL, "string() unit test failed for Boolean false value") + endif + + if (string(12345_i4_kind) .ne. "12345") then + call mpp_error(FATAL, "string() unit test failed for positive integer(4)") + endif + + if (string(-12345_i4_kind) .ne. "-12345") then + call mpp_error(FATAL, "string() unit test failed for negative integer(4)") + endif + + if (string(12345_i8_kind) .ne. "12345") then + call mpp_error(FATAL, "string() unit test failed for positive integer(8)") + endif + + if (string(-12345_i8_kind) .ne. "-12345") then + call mpp_error(FATAL, "string() unit test failed for negative integer(8)") + endif + + if (string(1._r4_kind, "F15.7") .ne. "1.0000000") then + call mpp_error(FATAL, "string() unit test failed for positive real(4)") + endif + + if (string(-1._r4_kind, "F15.7") .ne. "-1.0000000") then + call mpp_error(FATAL, "string() unit test failed for negative real(4)") + endif + + if (string(1._r8_kind, "F25.16") .ne. "1.0000000000000000") then + call mpp_error(FATAL, "string() unit test failed for positive real(8)") + endif + + if (string(-1._r8_kind, "F25.16") .ne. "-1.0000000000000000") then + call mpp_error(FATAL, "string() unit test failed for negative real(8)") + endif + end subroutine + + subroutine check_stringify + real(r4_kind) :: arr_1d_r4(3), arr_2d_r4(2, 2), arr_3d_r4(2, 2, 2) + real(r8_kind) :: arr_1d_r8(3), arr_2d_r8(2, 2), arr_3d_r8(2, 2, 2) + + arr_1d_r4 = [0._r4_kind, 1._r4_kind, 2._r4_kind] + if (stringify(arr_1d_r4, "F15.7") .ne. "[0.0000000, 1.0000000, 2.0000000]") then + call mpp_error(FATAL, "stringify() unit test failed for 1D r4 array") + endif + + arr_1d_r8 = [0._r8_kind, 1._r8_kind, 2._r8_kind] + if (stringify(arr_1d_r8, "F25.16") .ne. "[0.0000000000000000, 1.0000000000000000, 2.0000000000000000]") then + call mpp_error(FATAL, "stringify() unit test failed for 1D r8 array") + endif + + arr_2d_r4 = reshape([[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], [2, 2]) + if (stringify(arr_2d_r4, "F15.7") .ne. & + & "[[0.0000000, 1.0000000], [2.0000000, 3.0000000]]") then + call mpp_error(FATAL, "stringify() unit test failed for 2D r4 array") + endif + + arr_2d_r8 = reshape([[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], [2, 2]) + if (stringify(arr_2d_r8, "F25.16") .ne. & + & "[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]]") then + call mpp_error(FATAL, "stringify() unit test failed for 2D r8 array") + endif + + arr_3d_r4 = reshape([ & + & [[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], & + & [[4._r4_kind, 5._r4_kind], [6._r4_kind, 7._r4_kind]] & + & ], [2, 2, 2]) + if (stringify(arr_3d_r4, "F15.7") .ne. & + & "[[[0.0000000, 1.0000000], [2.0000000, 3.0000000]],& + & [[4.0000000, 5.0000000], [6.0000000, 7.0000000]]]") then + call mpp_error(FATAL, "stringify() unit test failed for 3D r4 array") + endif + + arr_3d_r8 = reshape([ & + & [[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], & + & [[4._r8_kind, 5._r8_kind], [6._r8_kind, 7._r8_kind]] & + & ], [2, 2, 2]) + if (stringify(arr_3d_r8, "F25.16") .ne. & + & "[[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]],& + & [[4.0000000000000000, 5.0000000000000000], [6.0000000000000000, 7.0000000000000000]]]") then + call mpp_error(FATAL, "stringify() unit test failed for 3D r8 array") + endif + end subroutine + end program test_fms_string_utils diff --git a/time_interp/include/time_interp.inc b/time_interp/include/time_interp.inc index a6a31c0425..83cacec3f4 100644 --- a/time_interp/include/time_interp.inc +++ b/time_interp/include/time_interp.inc @@ -287,7 +287,7 @@ contains type(time_type), intent(in) :: Time real , intent(out) :: weight !< fractional time - integer :: year, month, day, hour, minute, second + integer :: yr, mo, dy, hour, minute, second type(time_type) :: Year_beg, Year_end @@ -295,10 +295,10 @@ contains ! ---- compute fractional time of year ----- - call get_date (Time, year, month, day, hour, minute, second) + call get_date (Time, yr, mo, dy, hour, minute, second) - Year_beg = set_date(year , 1, 1) - Year_end = set_date(year+1, 1, 1) + Year_beg = set_date(yr , 1, 1) + Year_end = set_date(yr+1, 1, 1) weight = real( (Time - Year_beg) // (Year_end - Year_beg) ) @@ -338,27 +338,27 @@ contains real , intent(out) :: weight !< fractional time between midpoints of year1 and year2 integer , intent(out) :: year1, year2 - integer :: year, month, day, hour, minute, second + integer :: yr, mo, dy, hour, minute, second type (time_type) :: Mid_year, Mid_year1, Mid_year2 if ( .not. module_is_initialized ) call time_interp_init() - call get_date (Time, year, month, day, hour, minute, second) + call get_date (Time, yr, mo, dy, hour, minute, second) ! mid point of current year - Mid_year = year_midpt(year) + Mid_year = year_midpt(yr) if ( Time >= Mid_year ) then ! current time is after mid point of current year - year1 = year - year2 = year+1 + year1 = yr + year2 = yr+1 Mid_year2 = year_midpt(year2) weight = real( (Time - Mid_year) // (Mid_year2 - Mid_year) ) else ! current time is before mid point of current year - year2 = year - year1 = year-1 + year2 = yr + year1 = yr-1 Mid_year1 = year_midpt(year1) weight = real( (Time - Mid_year1) // (Mid_year - Mid_year1) ) endif @@ -381,12 +381,12 @@ contains real , intent(out) :: weight integer , intent(out) :: year1, year2, month1, month2 - integer :: year, month, day, hour, minute, second, & + integer :: yr, mo, dy, hour, minute, second, & mid_month, cur_month, mid1, mid2 if ( .not. module_is_initialized ) call time_interp_init() - call get_date (Time, year, month, day, hour, minute, second) + call get_date (Time, yr, mo, dy, hour, minute, second) ! mid point of current month in seconds mid_month = days_in_month(Time) * halfday @@ -395,8 +395,8 @@ contains if ( cur_month >= mid_month ) then ! current time is after mid point of current month - year1 = year; month1 = month - year2 = year; month2 = month+1 + year1 = yr; month1 = mo + year2 = yr; month2 = mo+1 if (month2 > monyear) then year2 = year2+1; month2 = 1 endif @@ -405,8 +405,8 @@ contains weight = real(cur_month - mid1) / real(mid1+mid2) else ! current time is before mid point of current month - year2 = year; month2 = month - year1 = year; month1 = month-1 + year2 = yr; month2 = mo + year1 = yr; month1 = mo-1 if (month1 < 1) then year1 = year1-1; month1 = monyear endif @@ -442,19 +442,19 @@ contains real , intent(out) :: weight integer , intent(out) :: year1, year2, month1, month2, day1, day2 - integer :: year, month, day, hour, minute, second, sday + integer :: yr, mo, dy, hour, minute, second, sday if ( .not. module_is_initialized ) call time_interp_init() - call get_date (Time, year, month, day, hour, minute, second) + call get_date (Time, yr, mo, dy, hour, minute, second) ! time into current day in seconds sday = second + secmin*minute + sechour*hour if ( sday >= halfday ) then ! current time is after mid point of day - year1 = year; month1 = month; day1 = day - year2 = year; month2 = month; day2 = day + 1 + year1 = yr; month1 = mo; day1 = dy + year2 = yr; month2 = mo; day2 = dy + 1 weight = real(sday - halfday) / real(secday) if (day2 > days_in_month(Time)) then @@ -841,14 +841,14 @@ end subroutine time_interp_list ! private routines !####################################################################### - function year_midpt (year) + function year_midpt (yr) - integer, intent(in) :: year + integer, intent(in) :: yr type (time_type) :: year_midpt, year_beg, year_end - year_beg = set_date(year , 1, 1) - year_end = set_date(year+1, 1, 1) + year_beg = set_date(yr , 1, 1) + year_end = set_date(yr+1, 1, 1) year_midpt = (year_beg + year_end) / 2 @@ -856,19 +856,19 @@ end subroutine time_interp_list !####################################################################### - function month_midpt (year, month) + function month_midpt (yr, mo) - integer, intent(in) :: year, month + integer, intent(in) :: yr, mo type (time_type) :: month_midpt, month_beg, month_end ! --- beginning of this month --- - month_beg = set_date(year, month, 1) + month_beg = set_date(yr, mo, 1) ! --- start of next month --- - if (month < 12) then - month_end = set_date(year, month+1, 1) + if (mo < 12) then + month_end = set_date(yr, mo+1, 1) else - month_end = set_date(year+1, 1, 1) + month_end = set_date(yr+1, 1, 1) endif month_midpt = (month_beg + month_end) / 2 diff --git a/time_interp/include/time_interp_external.inc b/time_interp/include/time_interp_external.inc new file mode 100644 index 0000000000..c25f694dea --- /dev/null +++ b/time_interp/include/time_interp_external.inc @@ -0,0 +1,1423 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @defgroup time_interp_external_mod time_interp_external_mod +!> @ingroup time_interp +!> @brief Perform I/O and time interpolation of external fields (contained in a file). +!> @author M.J. Harrison +!! +!! Perform I/O and time interpolation for external fields. +!! Uses udunits library to calculate calendar dates and +!! convert units. Allows for reading data decomposed across +!! model horizontal grid using optional domain2d argument +!! +!! data are defined over data domain for domain2d data +!! (halo values are NOT updated by this module) + +!> @addtogroup time_interp_external_mod +!> @{ +module time_interp_external_mod +#include +! +!M.J. Harrison +! +!Harper Simmons +! +! +! + +! +! +! +! +! +! +! size of record dimension for internal buffer. This is useful for tuning i/o performance +! particularly for large datasets (e.g. daily flux fields) +! +! + + use fms_mod, only : write_version_number + use mpp_mod, only : mpp_error,FATAL,WARNING,mpp_pe, stdout, stdlog, NOTE + use mpp_mod, only : input_nml_file + use mpp_io_mod, only : mpp_open, mpp_get_atts, mpp_get_info, MPP_NETCDF, MPP_MULTI, MPP_SINGLE,& + mpp_get_times, MPP_RDONLY, MPP_ASCII, default_axis,axistype,fieldtype,atttype, & + mpp_get_axes, mpp_get_fields, mpp_read, default_field, mpp_close, & + mpp_get_tavg_info, validtype, mpp_is_valid, mpp_get_file_name + use time_manager_mod, only : time_type, get_date, set_date, operator ( >= ) , operator ( + ) , days_in_month, & + operator( - ), operator ( / ) , days_in_year, increment_time, & + set_time, get_time, operator( > ), get_calendar_type, NO_CALENDAR + use get_cal_time_mod, only : get_cal_time + use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, mpp_get_data_domain, & + mpp_get_global_domain, NULL_DOMAIN2D + use time_interp_mod, only : time_interp, time_interp_init + use axis_utils_mod, only : get_axis_cart, get_axis_modulo, get_axis_modulo_times + use fms_mod, only : lowercase, open_namelist_file, check_nml_error, close_file + use platform_mod, only: r8_kind + use horiz_interp_mod, only : horiz_interp, horiz_interp_type + + implicit none + private + +! Include variable "version" to be written to log file. +#include + + integer, parameter, public :: NO_REGION=0, INSIDE_REGION=1, OUTSIDE_REGION=2 + integer, parameter, private :: modulo_year= 0001 + integer, parameter, private :: LINEAR_TIME_INTERP = 1 ! not used currently + integer, parameter, public :: SUCCESS = 0, ERR_FIELD_NOT_FOUND = 1 + integer, private :: max_fields = 100, max_files= 40 + integer, private :: num_fields = 0, num_files=0 + ! denotes time intervals in file (interpreted from metadata) + integer, private :: num_io_buffers = 2 ! set -1 to read all records from disk into memory + logical, private :: module_initialized = .false. + logical, private :: debug_this_module = .false. + + public 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 + public set_override_region, reset_src_data_region, get_external_field_axes + + private find_buf_index,& + set_time_modulo + + !> @} + + !> @ingroup time_interp_external_mod + type, private :: ext_fieldtype + integer :: unit ! keep unit open when not reading all records + character(len=128) :: name, units + integer :: siz(4), ndim + type(domain2d) :: domain + type(axistype) :: axes(4) + type(time_type), dimension(:), pointer :: time =>NULL() ! midpoint of time interval + type(time_type), dimension(:), pointer :: start_time =>NULL(), end_time =>NULL() + type(fieldtype) :: field ! mpp_io type + type(time_type), dimension(:), pointer :: period =>NULL() + logical :: modulo_time ! denote climatological time axis + real, dimension(:,:,:,:), pointer :: data =>NULL() ! defined over data domain or global domain + logical, dimension(:,:,:,:), pointer :: mask =>NULL() ! defined over data domain or global domain + integer, dimension(:), pointer :: ibuf =>NULL() ! record numbers associated with buffers + real, dimension(:,:,:,:), pointer :: src_data =>NULL() ! input data buffer + type(validtype) :: valid ! data validator + integer :: nbuf + logical :: domain_present + real(DOUBLE_KIND) :: slope, intercept + integer :: isc,iec,jsc,jec + type(time_type) :: modulo_time_beg, modulo_time_end + logical :: have_modulo_times, correct_leap_year_inconsistency + integer :: region_type + integer :: is_region, ie_region, js_region, je_region + integer :: is_src, ie_src, js_src, je_src + integer :: tdim + integer :: numwindows + logical, dimension(:,:), pointer :: need_compute=>NULL() + real :: missing ! missing value + end type ext_fieldtype + + !> @ingroup time_interp_external_mod + type, private :: filetype + character(len=128) :: filename = '' + integer :: unit = -1 + end type filetype + + !> Provide data from external file interpolated to current model time. + !! Data may be local to current processor or global, depending on + !! "init_external_field" flags. Uses @ref mpp_io_mod for I/O. + !! + !! @param index index of external field from previous call to init_external_field + !! @param time target time for data + !! @param [inout] data global or local data array + !! @param interp time_interp_external defined interpolation method (optional). Currently + !! this module only supports LINEAR_TIME_INTERP. + !! @param verbose verbose flag for debugging (optional). + !! + !> @ingroup time_interp_external_mod + interface time_interp_external + module procedure time_interp_external_0d + module procedure time_interp_external_2d + module procedure time_interp_external_3d + end interface + + !> @addtogroup time_interp_external_mod + !> @{ + + integer :: outunit + + type(ext_fieldtype), save, private, pointer :: field(:) => NULL() + type(filetype), save, private, pointer :: opened_files(:) => NULL() +!Balaji: really should use field%missing + integer, private, parameter :: dk = DOUBLE_KIND + real(DOUBLE_KIND), private, parameter :: time_interp_missing=-1e99_dk + contains + +! +! +! +! Initialize the time_interp_external module +! +! + subroutine time_interp_external_init() + + integer :: ioun, io_status, logunit, ierr + + namelist /time_interp_external_nml/ num_io_buffers, debug_this_module, & + max_fields, max_files + + ! open and read namelist + + if(module_initialized) return + + logunit = stdlog() + outunit = stdout() + call write_version_number("TIME_INTERP_EXTERNAL_MOD", version) + +#ifdef INTERNAL_FILE_NML + read (input_nml_file, time_interp_external_nml, iostat=io_status) + ierr = check_nml_error(io_status, 'time_interp_external_nml') +#else + ioun = open_namelist_file () + ierr=1; do while (ierr /= 0) + read (ioun, nml=time_interp_external_nml, iostat=io_status, end=10) + ierr = check_nml_error(io_status, 'time_interp_external_nml') + enddo +10 call close_file (ioun) +#endif + + write(logunit,time_interp_external_nml) + call realloc_fields(max_fields) + call realloc_files(max_files) + + module_initialized = .true. + + call time_interp_init() + + return + + end subroutine time_interp_external_init +! NAME="time_interp_external_init" + + +! +! +! +! initialize an external field. Buffer "num_io_buffers" (default=2) in memory to reduce memory allocations. +! distributed reads are supported using the optional "domain" flag. +! Units conversion via the optional "desired_units" flag using udunits_mod. +! +! Return integer id of field for future calls to time_interp_external. +! +! +! +! +! filename +! +! +! fieldname (in file) +! +! +! mpp_io flag for format of file (optional). Currently only "MPP_NETCDF" supported +! +! +! mpp_io flag for threading (optional). "MPP_SINGLE" means root pe reads global field and distributes to other PEs +! "MPP_MULTI" means all PEs read data +! +! +! domain flag (optional) +! +! +! Target units for data (optional), e.g. convert from deg_K to deg_C. +! Failure to convert using udunits will result in failure of this module. +! +! +! verbose flag for debugging (optional). +! +! +! MPP_IO axistype array for grid centers ordered X-Y-Z-T (optional). +! +! +! array of axis lengths ordered X-Y-Z-T (optional). +! + + + !> Initialize an external field. Buffer "num_io_buffers" (default=2) in memory to reduce memory allocations. + !! distributed reads are supported using the optional "domain" flag. + !! Units conversion via the optional "desired_units" flag using udunits_mod. + !! + !> @return integer id of field for future calls to time_interp_external. + !> @param file filename + !> @param fieldname fieldname (in file) + !> @param format mpp_io flag for format of file(optional). Currently only "MPP_NETCDF" supported + !> @param threading mpp_io flag for threading (optional). "MPP_SINGLE" means root pe reads + !! global field and distributes to other PEs. "MPP_MULTI" means all PEs read data + !> @param domain domain flag (optional) + !> @param desired_units Target units for data (optional), e.g. convert from deg_K to deg_C. + !! Failure to convert using udunits will result in failure of this module. + !> @param verbose verbose flag for debugging (optional). + !> @param [out] axis_names List of axis names (optional). + !> @param [inout] axis_sizes array of axis lengths ordered X-Y-Z-T (optional). + function init_external_field(file,fieldname,format,threading,domain,desired_units,& + verbose,axis_centers,axis_sizes,override,correct_leap_year_inconsistency,& + permit_calendar_conversion,use_comp_domain,ierr, nwindows, ignore_axis_atts ) + + character(len=*), intent(in) :: file,fieldname + integer, intent(in), optional :: format, threading + logical, intent(in), optional :: verbose + character(len=*), intent(in), optional :: desired_units + type(domain2d), intent(in), optional :: domain + type(axistype), intent(inout), optional :: axis_centers(4) + integer, intent(inout), optional :: axis_sizes(4) + logical, intent(in), optional :: override, correct_leap_year_inconsistency,& + permit_calendar_conversion,use_comp_domain + integer, intent(out), optional :: ierr + integer, intent(in), optional :: nwindows + logical, optional :: ignore_axis_atts + real :: missing + + integer :: init_external_field + + type(fieldtype), dimension(:), allocatable :: flds + type(axistype), dimension(:), allocatable :: axes, fld_axes + type(axistype) :: time_axis + type(atttype), allocatable, dimension(:) :: global_atts + + real(DOUBLE_KIND) :: slope, intercept + integer :: form, thread, fset, unit,ndim,nvar,natt,ntime,i,j + integer :: iscomp,iecomp,jscomp,jecomp,isglobal,ieglobal,jsglobal,jeglobal + integer :: isdata,iedata,jsdata,jedata, dxsize, dysize,dxsize_max,dysize_max + logical :: verb, transpose_xy,use_comp_domain1 + real, dimension(:), allocatable :: tstamp, tstart, tend, tavg + character(len=1) :: cart + character(len=1), dimension(4) :: cart_dir + character(len=128) :: units, fld_units + character(len=128) :: name, msg, calendar_type, timebeg, timeend + integer :: siz(4), siz_in(4), gxsize, gysize,gxsize_max, gysize_max + type(time_type) :: tdiff + integer :: yr, mon, day, hr, minu, sec + integer :: len, nfile, nfields_orig, nbuf, nx,ny + integer :: numwindows + logical :: ignore_axatts + + + if (.not. module_initialized) call mpp_error(FATAL,'Must call time_interp_external_init first') + if(present(ierr)) ierr = SUCCESS + ignore_axatts=.false. + cart_dir(1)='X';cart_dir(2)='Y';cart_dir(3)='Z';cart_dir(4)='T' + if(present(ignore_axis_atts)) ignore_axatts = ignore_axis_atts + use_comp_domain1 = .false. + if(PRESENT(use_comp_domain)) use_comp_domain1 = use_comp_domain + form=MPP_NETCDF + if (PRESENT(format)) form = format + thread = MPP_MULTI + if (PRESENT(threading)) thread = threading + fset = MPP_SINGLE + verb=.false. + if (PRESENT(verbose)) verb=verbose + if (debug_this_module) verb = .true. + numwindows = 1 + if(present(nwindows)) numwindows = nwindows + + units = 'same' + if (PRESENT(desired_units)) then + units = desired_units + call mpp_error(FATAL,'==> Unit conversion via time_interp_external & + &has been temporarily deprecated. Previous versions of& + &this module used udunits_mod to perform unit conversion.& + & Udunits_mod is in the process of being replaced since & + &there were portability issues associated with this code.& + & Please remove the desired_units argument from calls to & + &this routine.') + endif + nfile = 0 + do i=1,num_files + if(trim(opened_files(i)%filename) == trim(file)) then + nfile = i + exit ! file is already opened + endif + enddo + if(nfile == 0) then + call mpp_open(unit,trim(file),MPP_RDONLY,form,threading=thread,& + fileset=fset) + num_files = num_files + 1 + if(num_files > max_files) then ! not enough space in the file table, reallocate it + !--- z1l: For the case of multiple thread, realoc_files will cause memory leak. + !--- If multiple threads are working on file A. One of the thread finished first and + !--- begin to work on file B, the realloc_files will cause problem for + !--- other threads are working on the file A. + ! call realloc_files(2*size(opened_files)) + call mpp_error(FATAL, "time_interp_external: num_files is greater than max_files, "// & + "increase time_interp_external_nml max_files") + endif + opened_files(num_files)%filename = trim(file) + opened_files(num_files)%unit = unit + else + unit = opened_files(nfile)%unit + endif + + call mpp_get_info(unit,ndim,nvar,natt,ntime) + + if (ntime < 1) then + write(msg,'(a15,a,a58)') 'external field ',trim(fieldname),& + ' does not have an associated record dimension (REQUIRED) ' + call mpp_error(FATAL,trim(msg)) + endif + allocate(global_atts(natt)) + call mpp_get_atts(unit, global_atts) + allocate(axes(ndim)) + call mpp_get_axes(unit, axes, time_axis) + allocate(flds(nvar)) + call mpp_get_fields(unit,flds) + allocate(tstamp(ntime),tstart(ntime),tend(ntime),tavg(ntime)) + call mpp_get_times(unit,tstamp) + transpose_xy = .false. + isdata=1; iedata=1; jsdata=1; jedata=1 + gxsize=1; gysize=1 + siz_in = 1 + + if (PRESENT(domain)) then + call mpp_get_compute_domain(domain,iscomp,iecomp,jscomp,jecomp) + nx = iecomp-iscomp+1; ny = jecomp-jscomp+1 + call mpp_get_data_domain(domain,isdata,iedata,jsdata,jedata,dxsize,dxsize_max,dysize,dysize_max) + call mpp_get_global_domain(domain,isglobal,ieglobal,jsglobal,jeglobal,gxsize,gxsize_max,gysize,gysize_max) + elseif(use_comp_domain1) then + call mpp_error(FATAL,"init_external_field:"//& + " use_comp_domain=true but domain is not present") + endif + + init_external_field = -1 + nfields_orig = num_fields + + do i=1,nvar + call mpp_get_atts(flds(i),name=name,units=fld_units,ndim=ndim,siz=siz_in) + call mpp_get_tavg_info(unit,flds(i),flds,tstamp,tstart,tend,tavg) + call mpp_get_atts(flds(i),missing=missing) + ! why does it convert case of the field name? + if (trim(lowercase(name)) /= trim(lowercase(fieldname))) cycle + + if (verb) write(outunit,*) 'found field ',trim(fieldname), ' in file !!' + num_fields = num_fields + 1 + if(num_fields > max_fields) then + !--- z1l: For the case of multiple thread, realoc_fields will cause memory leak. + !--- If multiple threads are working on field A. One of the thread finished first and + !--- begin to work on field B, the realloc_files will cause problem for + !--- other threads are working on the field A. + !call realloc_fields(size(field)*2) + call mpp_error(FATAL, "time_interp_external: num_fields is greater than max_fields, "// & + "increase time_interp_external_nml max_fields") + endif + + init_external_field = num_fields + field(num_fields)%unit = unit + field(num_fields)%name = trim(name) + field(num_fields)%units = trim(fld_units) + field(num_fields)%field = flds(i) + field(num_fields)%isc = 1 + field(num_fields)%iec = 1 + field(num_fields)%jsc = 1 + field(num_fields)%jec = 1 + field(num_fields)%region_type = NO_REGION + field(num_fields)%is_region = 0 + field(num_fields)%ie_region = -1 + field(num_fields)%js_region = 0 + field(num_fields)%je_region = -1 + if (PRESENT(domain)) then + field(num_fields)%domain_present = .true. + field(num_fields)%domain = domain + field(num_fields)%isc=iscomp;field(num_fields)%iec = iecomp + field(num_fields)%jsc=jscomp;field(num_fields)%jec = jecomp + else + field(num_fields)%domain_present = .false. + endif + + call mpp_get_atts(flds(i),valid=field(num_fields)%valid ) + allocate(fld_axes(ndim)) + call mpp_get_atts(flds(i),axes=fld_axes) + if (ndim > 4) call mpp_error(FATAL, & + 'invalid array rank <=4d fields supported') + field(num_fields)%siz = 1 + field(num_fields)%ndim = ndim + field(num_fields)%tdim = 4 + field(num_fields)%missing = missing + do j=1,field(num_fields)%ndim + cart = 'N' + call get_axis_cart(fld_axes(j), cart) + call mpp_get_atts(fld_axes(j),len=len) + if (cart == 'N' .and. .not. ignore_axatts) then + write(msg,'(a,"/",a)') trim(file),trim(fieldname) + call mpp_error(FATAL,'file/field '//trim(msg)// & + ' couldnt recognize axis atts in time_interp_external') + else if (cart == 'N' .and. ignore_axatts) then + cart = cart_dir(j) + endif + select case (cart) + case ('X') + if (j.eq.2) transpose_xy = .true. + if (.not.PRESENT(domain) .and. .not.PRESENT(override)) then + isdata=1;iedata=len + iscomp=1;iecomp=len + gxsize = len + dxsize = len + field(num_fields)%isc=iscomp;field(num_fields)%iec=iecomp + elseif (PRESENT(override)) then + gxsize = len + if (PRESENT(axis_sizes)) axis_sizes(1) = len + endif + field(num_fields)%axes(1) = fld_axes(j) + if(use_comp_domain1) then + field(num_fields)%siz(1) = nx + else + field(num_fields)%siz(1) = dxsize + endif + if (len /= gxsize) then + write(msg,'(a,"/",a)') trim(file),trim(fieldname) + call mpp_error(FATAL,'time_interp_ext, file/field '//trim(msg)//' x dim doesnt match model') + endif + case ('Y') + field(num_fields)%axes(2) = fld_axes(j) + if (.not.PRESENT(domain) .and. .not.PRESENT(override)) then + jsdata=1;jedata=len + jscomp=1;jecomp=len + gysize = len + dysize = len + field(num_fields)%jsc=jscomp;field(num_fields)%jec=jecomp + elseif (PRESENT(override)) then + gysize = len + if (PRESENT(axis_sizes)) axis_sizes(2) = len + endif + if(use_comp_domain1) then + field(num_fields)%siz(2) = ny + else + field(num_fields)%siz(2) = dysize + endif + if (len /= gysize) then + write(msg,'(a,"/",a)') trim(file),trim(fieldname) + call mpp_error(FATAL,'time_interp_ext, file/field '//trim(msg)//' y dim doesnt match model') + endif + case ('Z') + field(num_fields)%axes(3) = fld_axes(j) + field(num_fields)%siz(3) = siz_in(3) + case ('T') + field(num_fields)%axes(4) = fld_axes(j) + field(num_fields)%siz(4) = ntime + field(num_fields)%tdim = j + end select + enddo + siz = field(num_fields)%siz + + if (PRESENT(axis_centers)) then + axis_centers = field(num_fields)%axes + endif + + if (PRESENT(axis_sizes) .and. .not.PRESENT(override)) then + axis_sizes = field(num_fields)%siz + endif + + deallocate(fld_axes) + if (verb) write(outunit,'(a,4i6)') 'field x,y,z,t local size= ',siz + if (verb) write(outunit,*) 'field contains data in units = ',trim(field(num_fields)%units) + if (transpose_xy) call mpp_error(FATAL,'axis ordering not supported') + if (num_io_buffers .le. 1) call mpp_error(FATAL,'time_interp_ext:num_io_buffers should be at least 2') + nbuf = min(num_io_buffers,siz(4)) + + field(num_fields)%numwindows = numwindows + allocate(field(num_fields)%need_compute(nbuf, numwindows)) + field(num_fields)%need_compute = .true. + + allocate(field(num_fields)%data(isdata:iedata,jsdata:jedata,siz(3),nbuf),& + field(num_fields)%mask(isdata:iedata,jsdata:jedata,siz(3),nbuf) ) + field(num_fields)%mask = .false. + field(num_fields)%data = 0.0 + slope=1.0;intercept=0.0 +! if (units /= 'same') call convert_units(trim(field(num_fields)%units),trim(units),slope,intercept) +! if (verb.and.units /= 'same') then +! write(outunit,*) 'attempting to convert data to units = ',trim(units) +! write(outunit,'(a,f8.3,a,f8.3)') 'factor = ',slope,' offset= ',intercept +! endif + field(num_fields)%slope = slope + field(num_fields)%intercept = intercept + allocate(field(num_fields)%ibuf(nbuf)) + field(num_fields)%ibuf = -1 + field(num_fields)%nbuf = 0 ! initialize buffer number so that first reading fills data(:,:,:,1) + if(PRESENT(override)) then + field(num_fields)%is_src = 1 + field(num_fields)%ie_src = gxsize + field(num_fields)%js_src = 1 + field(num_fields)%je_src = gysize + allocate(field(num_fields)%src_data(gxsize,gysize,siz(3),nbuf)) + else + field(num_fields)%is_src = isdata + field(num_fields)%ie_src = iedata + field(num_fields)%js_src = jsdata + field(num_fields)%je_src = jedata + allocate(field(num_fields)%src_data(isdata:iedata,jsdata:jedata,siz(3),nbuf)) + endif + + allocate(field(num_fields)%time(ntime)) + allocate(field(num_fields)%period(ntime)) + allocate(field(num_fields)%start_time(ntime)) + allocate(field(num_fields)%end_time(ntime)) + + call mpp_get_atts(time_axis,units=units,calendar=calendar_type) + do j=1,ntime + field(num_fields)%time(j) = get_cal_time(tstamp(j),trim(units),trim(calendar_type), & + & permit_calendar_conversion) + field(num_fields)%start_time(j) = get_cal_time(tstart(j),trim(units),trim(calendar_type), & + & permit_calendar_conversion) + field(num_fields)%end_time(j) = get_cal_time( tend(j),trim(units),trim(calendar_type), & + & permit_calendar_conversion) + enddo + + if (field(num_fields)%modulo_time) then + call set_time_modulo(field(num_fields)%Time) + call set_time_modulo(field(num_fields)%start_time) + call set_time_modulo(field(num_fields)%end_time) + endif + + if(present(correct_leap_year_inconsistency)) then + field(num_fields)%correct_leap_year_inconsistency = correct_leap_year_inconsistency + else + field(num_fields)%correct_leap_year_inconsistency = .false. + endif + + if(get_axis_modulo_times(time_axis, timebeg, timeend)) then + if(get_calendar_type() == NO_CALENDAR) then + field(num_fields)%modulo_time_beg = set_time(timebeg) + field(num_fields)%modulo_time_end = set_time(timeend) + else + field(num_fields)%modulo_time_beg = set_date(timebeg) + field(num_fields)%modulo_time_end = set_date(timeend) + endif + field(num_fields)%have_modulo_times = .true. + else + field(num_fields)%have_modulo_times = .false. + endif + if(ntime == 1) then + call mpp_error(NOTE, 'time_interp_external_mod: file '//trim(file)//' has only one time level') + else + do j= 1, ntime + field(num_fields)%period(j) = field(num_fields)%end_time(j)-field(num_fields)%start_time(j) + if (field(num_fields)%period(j) > set_time(0,0)) then + call get_time(field(num_fields)%period(j), sec, day) + sec = sec/2+mod(day,2)*43200 + day = day/2 + field(num_fields)%time(j) = field(num_fields)%start_time(j)+& + set_time(sec,day) + else + if (j > 1 .and. j < ntime) then + tdiff = field(num_fields)%time(j+1) - field(num_fields)%time(j-1) + call get_time(tdiff, sec, day) + sec = sec/2+mod(day,2)*43200 + day = day/2 + field(num_fields)%period(j) = set_time(sec,day) + sec = sec/2+mod(day,2)*43200 + day = day/2 + field(num_fields)%start_time(j) = field(num_fields)%time(j) - set_time(sec,day) + field(num_fields)%end_time(j) = field(num_fields)%time(j) + set_time(sec,day) + elseif ( j == 1) then + tdiff = field(num_fields)%time(2) - field(num_fields)%time(1) + call get_time(tdiff, sec, day) + field(num_fields)%period(j) = set_time(sec,day) + sec = sec/2+mod(day,2)*43200 + day = day/2 + field(num_fields)%start_time(j) = field(num_fields)%time(j) - set_time(sec,day) + field(num_fields)%end_time(j) = field(num_fields)%time(j) + set_time(sec,day) + else + tdiff = field(num_fields)%time(ntime) - field(num_fields)%time(ntime-1) + call get_time(tdiff, sec, day) + field(num_fields)%period(j) = set_time(sec,day) + sec = sec/2+mod(day,2)*43200 + day = day/2 + field(num_fields)%start_time(j) = field(num_fields)%time(j) - set_time(sec,day) + field(num_fields)%end_time(j) = field(num_fields)%time(j) + set_time(sec,day) + endif + endif + enddo + endif + + do j=1,ntime-1 + if (field(num_fields)%time(j) >= field(num_fields)%time(j+1)) then + write(msg,'(A,i20)') "times not monotonically increasing. Filename: " & + //TRIM(file)//" field: "//TRIM(fieldname)//" timeslice: ", j + call mpp_error(FATAL, TRIM(msg)) + endif + enddo + + field(num_fields)%modulo_time = get_axis_modulo(time_axis) + + if (verb) then + if (field(num_fields)%modulo_time) write(outunit,*) 'data are being treated as modulo in time' + do j= 1, ntime + write(outunit,*) 'time index, ', j + call get_date(field(num_fields)%start_time(j),yr,mon,day,hr,minu,sec) + write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & + 'start time: yyyy/mm/dd hh:mm:ss= ',yr,'/',mon,'/',day,hr,':',minu,':',sec + call get_date(field(num_fields)%time(j),yr,mon,day,hr,minu,sec) + write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & + 'mid time: yyyy/mm/dd hh:mm:ss= ',yr,'/',mon,'/',day,hr,':',minu,':',sec + call get_date(field(num_fields)%end_time(j),yr,mon,day,hr,minu,sec) + write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & + 'end time: yyyy/mm/dd hh:mm:ss= ',yr,'/',mon,'/',day,hr,':',minu,':',sec + enddo + end if + + enddo + + if (num_fields == nfields_orig) then + if (present(ierr)) then + ierr = ERR_FIELD_NOT_FOUND + else + call mpp_error(FATAL,'external field "'//trim(fieldname)//'" not found in file "'//trim(file)//'"') + endif + endif + + deallocate(global_atts) + deallocate(axes) + deallocate(flds) + deallocate(tstamp, tstart, tend, tavg) + + return + + end function init_external_field + +! NAME="init_external_field" + + + !> @brief 2D time interpolation for @ref time_interp_external + subroutine time_interp_external_2d(index, time, data_in, interp, verbose,horz_interp, mask_out, & + is_in, ie_in, js_in, je_in, window_id) + + integer, intent(in) :: index + type(time_type), intent(in) :: time + real, dimension(:,:), intent(inout) :: data_in + integer, intent(in), optional :: interp + logical, intent(in), optional :: verbose + type(horiz_interp_type),intent(in), optional :: horz_interp + logical, dimension(:,:), intent(out), optional :: mask_out ! set to true where output data is valid + integer, intent(in), optional :: is_in, ie_in, js_in, je_in + integer, intent(in), optional :: window_id + + real , dimension(size(data_in,1), size(data_in,2), 1) :: data_out + logical, dimension(size(data_in,1), size(data_in,2), 1) :: mask3d + + data_out(:,:,1) = data_in(:,:) ! fill initial values for the portions of array that are not touched by 3d routine + call time_interp_external_3d(index, time, data_out, interp, verbose, horz_interp, mask3d, & + is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) + data_in(:,:) = data_out(:,:,1) + if (PRESENT(mask_out)) mask_out(:,:) = mask3d(:,:,1) + + return + end subroutine time_interp_external_2d + +! +! +! +! Provide data from external file interpolated to current model time. +! Data may be local to current processor or global, depending on +! "init_external_field" flags. +! +! +! +! index of external field from previous call to init_external_field +! +! +! target time for data +! +! +! global or local data array +! +! +! time_interp_external defined interpolation method (optional). Currently this module only supports +! LINEAR_TIME_INTERP. +! +! +! verbose flag for debugging (optional). +! + + !> @brief 3D time interpolation for @ref time_interp_external + subroutine time_interp_external_3d(index, time, data, interp,verbose,horz_interp, mask_out, is_in, ie_in, & + & js_in, je_in, window_id) + + integer, intent(in) :: index + type(time_type), intent(in) :: time + real, dimension(:,:,:), intent(inout) :: data + integer, intent(in), optional :: interp + logical, intent(in), optional :: verbose + type(horiz_interp_type), intent(in), optional :: horz_interp + logical, dimension(:,:,:), intent(out), optional :: mask_out ! set to true where output data is valid + integer, intent(in), optional :: is_in, ie_in, js_in, je_in + integer, intent(in), optional :: window_id + + integer :: nx, ny, nz, interp_method, t1, t2 + integer :: i1, i2, isc, iec, jsc, jec, mod_time + integer :: yy, mm, dd, hh, min, ss + character(len=256) :: err_msg, filename + + integer :: isw, iew, jsw, jew, nxw, nyw + ! these are boundaries of the updated portion of the "data" argument + ! they are calculated using sizes of the "data" and isc,iec,jsc,jsc + ! fileds from respective input field, to center the updated portion + ! in the output array + + real :: w1,w2 + logical :: verb + character(len=16) :: message1, message2 + + nx = size(data,1) + ny = size(data,2) + nz = size(data,3) + + interp_method = LINEAR_TIME_INTERP + if (PRESENT(interp)) interp_method = interp + verb=.false. + if (PRESENT(verbose)) verb=verbose + if (debug_this_module) verb = .true. + + if (index < 1.or.index > num_fields) & + call mpp_error(FATAL, & + & 'invalid index in call to time_interp_ext -- field was not initialized or failed to initialize') + + isc=field(index)%isc;iec=field(index)%iec + jsc=field(index)%jsc;jec=field(index)%jec + + if( field(index)%numwindows == 1 ) then + nxw = iec-isc+1 + nyw = jec-jsc+1 + else + if( .not. present(is_in) .or. .not. present(ie_in) .or. .not. present(js_in) .or. .not. present(je_in) ) then + call mpp_error(FATAL, 'time_interp_external: is_in, ie_in, js_in and je_in must be present ' // & + 'when numwindows > 1, field='//trim(field(index)%name)) + endif + nxw = ie_in - is_in + 1 + nyw = je_in - js_in + 1 + isc = isc + is_in - 1 + iec = isc + ie_in - is_in + jsc = jsc + js_in - 1 + jec = jsc + je_in - js_in + endif + + isw = (nx-nxw)/2+1; iew = isw+nxw-1 + jsw = (ny-nyw)/2+1; jew = jsw+nyw-1 + + if (nx < nxw .or. ny < nyw .or. nz < field(index)%siz(3)) then + write(message1,'(i6,2i5)') nx,ny,nz + call mpp_error(FATAL,'field '//trim(field(index)%name)//' Array size mismatch in time_interp_external.'// & + ' Array "data" is too small. shape(data)='//message1) + endif + if(PRESENT(mask_out)) then + if (size(mask_out,1) /= nx .or. size(mask_out,2) /= ny .or. size(mask_out,3) /= nz) then + write(message1,'(i6,2i5)') nx,ny,nz + write(message2,'(i6,2i5)') size(mask_out,1),size(mask_out,2),size(mask_out,3) + call mpp_error(FATAL,'field '//trim(field(index)%name)//' array size mismatch in time_interp_external.'// & + ' Shape of array "mask_out" does not match that of array "data".'// & + ' shape(data)='//message1//' shape(mask_out)='//message2) + endif + endif + + if (field(index)%siz(4) == 1) then + ! only one record in the file => time-independent field + call load_record(field(index),1,horz_interp, is_in, ie_in ,js_in, je_in,window_id) + i1 = find_buf_index(1,field(index)%ibuf) + if( field(index)%region_type == NO_REGION ) then + where(field(index)%mask(isc:iec,jsc:jec,:,i1)) + data(isw:iew,jsw:jew,:) = field(index)%data(isc:iec,jsc:jec,:,i1) + elsewhere +! data(isw:iew,jsw:jew,:) = time_interp_missing !field(index)%missing? Balaji + data(isw:iew,jsw:jew,:) = field(index)%missing + end where + else + where(field(index)%mask(isc:iec,jsc:jec,:,i1)) + data(isw:iew,jsw:jew,:) = field(index)%data(isc:iec,jsc:jec,:,i1) + end where + endif + if(PRESENT(mask_out)) & + mask_out(isw:iew,jsw:jew,:) = field(index)%mask(isc:iec,jsc:jec,:,i1) + else + if(field(index)%have_modulo_times) then + call time_interp(time,field(index)%modulo_time_beg, field(index)%modulo_time_end, field(index)%time(:), & + w2, t1, t2, field(index)%correct_leap_year_inconsistency, err_msg=err_msg) + if(err_msg .NE. '') then + filename = mpp_get_file_name(field(index)%unit) + call mpp_error(FATAL,"time_interp_external 1: "//trim(err_msg)//& + ",file="//trim(filename)//",field="//trim(field(index)%name) ) + endif + else + if(field(index)%modulo_time) then + mod_time=1 + else + mod_time=0 + endif + call time_interp(time,field(index)%time(:),w2,t1,t2,modtime=mod_time, err_msg=err_msg) + if(err_msg .NE. '') then + filename = mpp_get_file_name(field(index)%unit) + call mpp_error(FATAL,"time_interp_external 2: "//trim(err_msg)//& + ",file="//trim(filename)//",field="//trim(field(index)%name) ) + endif + endif + w1 = 1.0-w2 + if (verb) then + call get_date(time,yy,mm,dd,hh,min,ss) + write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & + 'target time yyyy/mm/dd hh:mm:ss= ',yy,'/',mm,'/',dd,hh,':',min,':',ss + write(outunit,*) 't1, t2, w1, w2= ', t1, t2, w1, w2 + endif + + call load_record(field(index),t1,horz_interp, is_in, ie_in ,js_in, je_in, window_id) + call load_record(field(index),t2,horz_interp, is_in, ie_in ,js_in, je_in, window_id) + i1 = find_buf_index(t1,field(index)%ibuf) + i2 = find_buf_index(t2,field(index)%ibuf) + if(i1<0.or.i2<0) & + call mpp_error(FATAL,'time_interp_external : records were not loaded correctly in memory') + + if (verb) then + write(outunit,*) 'ibuf= ',field(index)%ibuf + write(outunit,*) 'i1,i2= ',i1, i2 + endif + + if( field(index)%region_type == NO_REGION ) then + where(field(index)%mask(isc:iec,jsc:jec,:,i1).and.field(index)%mask(isc:iec,jsc:jec,:,i2)) + data(isw:iew,jsw:jew,:) = field(index)%data(isc:iec,jsc:jec,:,i1)*w1 + & + field(index)%data(isc:iec,jsc:jec,:,i2)*w2 + elsewhere +! data(isw:iew,jsw:jew,:) = time_interp_missing !field(index)%missing? Balaji + data(isw:iew,jsw:jew,:) = field(index)%missing + end where + else + where(field(index)%mask(isc:iec,jsc:jec,:,i1).and.field(index)%mask(isc:iec,jsc:jec,:,i2)) + data(isw:iew,jsw:jew,:) = field(index)%data(isc:iec,jsc:jec,:,i1)*w1 + & + field(index)%data(isc:iec,jsc:jec,:,i2)*w2 + end where + endif + if(PRESENT(mask_out)) & + mask_out(isw:iew,jsw:jew,:) = & + field(index)%mask(isc:iec,jsc:jec,:,i1).and.& + field(index)%mask(isc:iec,jsc:jec,:,i2) + endif + + end subroutine time_interp_external_3d +! NAME="time_interp_external" + + !> @brief Scalar time interpolation for @ref time_interp_external + subroutine time_interp_external_0d(index, time, data, verbose) + + integer, intent(in) :: index + type(time_type), intent(in) :: time + real, intent(inout) :: data + logical, intent(in), optional :: verbose + + integer :: t1, t2 + integer :: i1, i2, mod_time + integer :: yy, mm, dd, hh, min, ss + character(len=256) :: err_msg, filename + + real :: w1,w2 + logical :: verb + + verb=.false. + if (PRESENT(verbose)) verb=verbose + if (debug_this_module) verb = .true. + + if (index < 1.or.index > num_fields) & + call mpp_error(FATAL, & + & 'invalid index in call to time_interp_ext -- field was not initialized or failed to initialize') + + if (field(index)%siz(4) == 1) then + ! only one record in the file => time-independent field + call load_record_0d(field(index),1) + i1 = find_buf_index(1,field(index)%ibuf) + data = field(index)%data(1,1,1,i1) + else + if(field(index)%have_modulo_times) then + call time_interp(time,field(index)%modulo_time_beg, field(index)%modulo_time_end, field(index)%time(:), & + w2, t1, t2, field(index)%correct_leap_year_inconsistency, err_msg=err_msg) + if(err_msg .NE. '') then + filename = mpp_get_file_name(field(index)%unit) + call mpp_error(FATAL,"time_interp_external 3:"//trim(err_msg)//& + ",file="//trim(filename)//",field="//trim(field(index)%name) ) + endif + else + if(field(index)%modulo_time) then + mod_time=1 + else + mod_time=0 + endif + call time_interp(time,field(index)%time(:),w2,t1,t2,modtime=mod_time, err_msg=err_msg) + if(err_msg .NE. '') then + filename = mpp_get_file_name(field(index)%unit) + call mpp_error(FATAL,"time_interp_external 4:"//trim(err_msg)// & + ",file="//trim(filename)//",field="//trim(field(index)%name) ) + endif + endif + w1 = 1.0-w2 + if (verb) then + call get_date(time,yy,mm,dd,hh,min,ss) + write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & + 'target time yyyy/mm/dd hh:mm:ss= ',yy,'/',mm,'/',dd,hh,':',min,':',ss + write(outunit,*) 't1, t2, w1, w2= ', t1, t2, w1, w2 + endif + call load_record_0d(field(index),t1) + call load_record_0d(field(index),t2) + i1 = find_buf_index(t1,field(index)%ibuf) + i2 = find_buf_index(t2,field(index)%ibuf) + + if(i1<0.or.i2<0) & + call mpp_error(FATAL,'time_interp_external : records were not loaded correctly in memory') + data = field(index)%data(1,1,1,i1)*w1 + field(index)%data(1,1,1,i2)*w2 + if (verb) then + write(outunit,*) 'ibuf= ',field(index)%ibuf + write(outunit,*) 'i1,i2= ',i1, i2 + endif + endif + + end subroutine time_interp_external_0d + + subroutine set_time_modulo(Time) + + type(time_type), intent(inout), dimension(:) :: Time + + integer :: ntime, n + integer :: yr, mon, dy, hr, minu, sec + + ntime = size(Time(:)) + + do n = 1, ntime + call get_date(Time(n), yr, mon, dy, hr, minu, sec) + yr = modulo_year + Time(n) = set_date(yr, mon, dy, hr, minu, sec) + enddo + + + end subroutine set_time_modulo + +! ============================================================================ +! load specified record from file +subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id_in) + type(ext_fieldtype), intent(inout) :: field + integer , intent(in) :: rec ! record number + type(horiz_interp_type), intent(in), optional :: interp + integer, intent(in), optional :: is_in, ie_in, js_in, je_in + integer, intent(in), optional :: window_id_in + + ! ---- local vars + integer :: ib ! index in the array of input buffers + integer :: isw,iew,jsw,jew ! boundaries of the domain on each window + integer :: is_region, ie_region, js_region, je_region, i, j + integer :: start(4), nread(4) + logical :: need_compute + real :: mask_in(size(field%src_data,1),size(field%src_data,2),size(field%src_data,3)) + real, allocatable :: mask_out(:,:,:) + integer :: window_id + + window_id = 1 + if( PRESENT(window_id_in) ) window_id = window_id_in + need_compute = .true. + +!$OMP CRITICAL + ib = find_buf_index(rec,field%ibuf) + + if(ib>0) then + !--- do nothing + need_compute = .false. + else + ! calculate current buffer number in round-robin fasion + field%nbuf = field%nbuf + 1 + if(field%nbuf > size(field%data,4).or.field%nbuf <= 0) field%nbuf = 1 + ib = field%nbuf + field%ibuf(ib) = rec + field%need_compute(ib,:) = .true. + + if (field%domain_present .and. .not.PRESENT(interp)) then + if (debug_this_module) write(outunit,*) 'reading record with domain for field ',trim(field%name) + call mpp_read(field%unit,field%field,field%domain,field%src_data(:,:,:,ib),rec) + else + if (debug_this_module) write(outunit,*) 'reading record without domain for field ',trim(field%name) + start = 1; nread = 1 + start(1) = field%is_src; nread(1) = field%ie_src - field%is_src + 1 + start(2) = field%js_src; nread(2) = field%je_src - field%js_src + 1 + start(3) = 1; nread(3) = size(field%src_data,3) + start(field%tdim) = rec; nread(field%tdim) = 1 + call mpp_read(field%unit,field%field,field%src_data(:,:,:,ib),start,nread) + endif + endif +!$OMP END CRITICAL + isw=field%isc;iew=field%iec + jsw=field%jsc;jew=field%jec + + if( field%numwindows > 1) then + if( .NOT. PRESENT(is_in) .OR. .NOT. PRESENT(ie_in) .OR. .NOT. PRESENT(js_in) .OR. .NOT. PRESENT(je_in) ) then + call mpp_error(FATAL, & + & 'time_interp_external(load_record): is_in, ie_in, js_in, je_in must be present when numwindows>1') + endif + isw = isw + is_in - 1 + iew = isw + ie_in - is_in + jsw = jsw + js_in - 1 + jew = jsw + je_in - js_in + endif + + ! interpolate to target grid + + need_compute = field%need_compute(ib, window_id) + if(need_compute) then + if(PRESENT(interp)) then + is_region = field%is_region; ie_region = field%ie_region + js_region = field%js_region; je_region = field%je_region + mask_in = 0.0 + where (mpp_is_valid(field%src_data(:,:,:,ib), field%valid)) mask_in = 1.0 + if ( field%region_type .NE. NO_REGION ) then + if( ANY(mask_in == 0.0) ) then + call mpp_error(FATAL, "time_interp_external: mask_in should be all 1 when region_type is not NO_REGION") + endif + if( field%region_type == OUTSIDE_REGION) then + do j = js_region, je_region + do i = is_region, ie_region + mask_in(i,j,:) = 0.0 + enddo + enddo + else ! field%region_choice == INSIDE_REGION + do j = 1, size(mask_in,2) + do i = 1, size(mask_in,1) + if( jje_region .OR. iie_region ) mask_in(i,j,:) = 0.0 + enddo + enddo + endif + endif + allocate(mask_out(isw:iew,jsw:jew, size(field%src_data,3))) + call horiz_interp(interp,field%src_data(:,:,:,ib),field%data(isw:iew,jsw:jew,:,ib), & + mask_in=mask_in, & + mask_out=mask_out) + + field%mask(isw:iew,jsw:jew,:,ib) = mask_out(isw:iew,jsw:jew,:) > 0 + deallocate(mask_out) + else + if ( field%region_type .NE. NO_REGION ) then + call mpp_error(FATAL, "time_interp_external: region_type should be NO_REGION when interp is not present") + endif + field%data(isw:iew,jsw:jew,:,ib) = field%src_data(isw:iew,jsw:jew,:,ib) + field%mask(isw:iew,jsw:jew,:,ib) = mpp_is_valid(field%data(isw:iew,jsw:jew,:,ib),field%valid) + endif + ! convert units + where(field%mask(isw:iew,jsw:jew,:,ib)) field%data(isw:iew,jsw:jew,:,ib) = & + field%data(isw:iew,jsw:jew,:,ib)*field%slope + field%intercept + field%need_compute(ib, window_id) = .false. + endif + +end subroutine load_record + + +subroutine load_record_0d(field, rec) + type(ext_fieldtype), intent(inout) :: field + integer , intent(in) :: rec ! record number + ! ---- local vars + integer :: ib ! index in the array of input buffers + integer :: start(4), nread(4) + + ib = find_buf_index(rec,field%ibuf) + + if(ib>0) then + return + else + ! calculate current buffer number in round-robin fasion + field%nbuf = field%nbuf + 1 + if(field%nbuf > size(field%data,4).or.field%nbuf <= 0) field%nbuf = 1 + ib = field%nbuf + field%ibuf(ib) = rec + + if (debug_this_module) write(outunit,*) 'reading record without domain for field ',trim(field%name) + start = 1; nread = 1 + start(3) = 1; nread(3) = size(field%src_data,3) + start(field%tdim) = rec; nread(field%tdim) = 1 + call mpp_read(field%unit,field%field,field%src_data(:,:,:,ib),start,nread) + if ( field%region_type .NE. NO_REGION ) then + call mpp_error(FATAL, "time_interp_external: region_type should be NO_REGION when field is scalar") + endif + field%data(1,1,:,ib) = field%src_data(1,1,:,ib) + field%mask(1,1,:,ib) = mpp_is_valid(field%data(1,1,:,ib),field%valid) + ! convert units + where(field%mask(1,1,:,ib)) field%data(1,1,:,ib) = & + field%data(1,1,:,ib)*field%slope + field%intercept + endif + +end subroutine load_record_0d + +! ============================================================================ +subroutine reset_src_data_region(index, is, ie, js, je) + integer, intent(in) :: index + integer, intent(in) :: is, ie, js, je + integer :: nk, nbuf + + if( is == field(index)%is_src .AND. ie == field(index)%ie_src .AND. & + js == field(index)%js_src .AND. ie == field(index)%je_src ) return + + if( .NOT. ASSOCIATED(field(index)%src_data) ) call mpp_error(FATAL, & + "time_interp_external: field(index)%src_data is not associated") + nk = size(field(index)%src_data,3) + nbuf = size(field(index)%src_data,4) + deallocate(field(index)%src_data) + allocate(field(index)%src_data(is:ie,js:je,nk,nbuf)) + field(index)%is_src = is + field(index)%ie_src = ie + field(index)%js_src = js + field(index)%je_src = je + + +end subroutine reset_src_data_region + +! ============================================================================ +subroutine set_override_region(index, region_type, is_region, ie_region, js_region, je_region) + integer, intent(in) :: index, region_type + integer, intent(in) :: is_region, ie_region, js_region, je_region + + field(index)%region_type = region_type + field(index)%is_region = is_region + field(index)%ie_region = ie_region + field(index)%js_region = js_region + field(index)%je_region = je_region + + return + +end subroutine set_override_region + +! ============================================================================ +! reallocates array of fields, increasing its size +subroutine realloc_files(n) + integer, intent(in) :: n ! new size + + type(filetype), pointer :: ptr(:) + integer :: i + + if (associated(opened_files)) then + if (n <= size(opened_files)) return ! do nothing, if requested size no more than current + endif + + allocate(ptr(n)) + do i = 1, size(ptr) + ptr(i)%filename = '' + ptr(i)%unit = -1 + enddo + + if (associated(opened_files))then + ptr(1:size(opened_files)) = opened_files(:) + deallocate(opened_files) + endif + opened_files => ptr + +end subroutine realloc_files + +! ============================================================================ +! reallocates array of fields,increasing its size +subroutine realloc_fields(n) + integer, intent(in) :: n ! new size + + type(ext_fieldtype), pointer :: ptr(:) + integer :: i, ier + + if (associated(field)) then + if (n <= size(field)) return ! do nothing if requested size no more then current + endif + + allocate(ptr(n)) + do i=1,size(ptr) + ptr(i)%unit=-1 + ptr(i)%name='' + ptr(i)%units='' + ptr(i)%siz=-1 + ptr(i)%ndim=-1 + ptr(i)%domain = NULL_DOMAIN2D + ptr(i)%axes(:) = default_axis + if (ASSOCIATED(ptr(i)%time)) DEALLOCATE(ptr(i)%time, stat=ier) + if (ASSOCIATED(ptr(i)%start_time)) DEALLOCATE(ptr(i)%start_time, stat=ier) + if (ASSOCIATED(ptr(i)%end_time)) DEALLOCATE(ptr(i)%end_time, stat=ier) + ptr(i)%field = default_field + if (ASSOCIATED(ptr(i)%period)) DEALLOCATE(ptr(i)%period, stat=ier) + ptr(i)%modulo_time=.false. + if (ASSOCIATED(ptr(i)%data)) DEALLOCATE(ptr(i)%data, stat=ier) + if (ASSOCIATED(ptr(i)%ibuf)) DEALLOCATE(ptr(i)%ibuf, stat=ier) + if (ASSOCIATED(ptr(i)%src_data)) DEALLOCATE(ptr(i)%src_data, stat=ier) + ptr(i)%nbuf=-1 + ptr(i)%domain_present=.false. + ptr(i)%slope=1.0 + ptr(i)%intercept=0.0 + ptr(i)%isc=-1;ptr(i)%iec=-1 + ptr(i)%jsc=-1;ptr(i)%jec=-1 + enddo + if (associated(field)) then + ptr(1:size(field)) = field(:) + deallocate(field) + endif + field=>ptr + +end subroutine realloc_fields + + + function find_buf_index(indx,buf) + integer :: indx + integer, dimension(:) :: buf + integer :: find_buf_index + + integer :: nbuf, i + + nbuf = size(buf(:)) + + find_buf_index = -1 + + do i=1,nbuf + if (buf(i) == indx) then + find_buf_index = i + exit + endif + enddo + + end function find_buf_index + +! +! +! +! return size of field after call to init_external_field. +! Ordering is X/Y/Z/T. +! This call only makes sense for non-distributed reads. +! +! +! +! returned from previous call to init_external_field. +! + + function get_external_field_size(index) + + integer :: index + integer :: get_external_field_size(4) + + if (index .lt. 1 .or. index .gt. num_fields) & + call mpp_error(FATAL,'invalid index in call to get_external_field_size') + + + get_external_field_size(1) = field(index)%siz(1) + get_external_field_size(2) = field(index)%siz(2) + get_external_field_size(3) = field(index)%siz(3) + get_external_field_size(4) = field(index)%siz(4) + + end function get_external_field_size +! NAME="get_external_field_size" + + +! +! +! +! return missing value +! +! +! +! returned from previous call to init_external_field. +! + + function get_external_field_missing(index) + + integer :: index + real :: get_external_field_missing + + if (index .lt. 1 .or. index .gt. num_fields) & + call mpp_error(FATAL,'invalid index in call to get_external_field_size') + + +! call mpp_get_atts(field(index)%field,missing=missing) + get_external_field_missing = field(index)%missing + + end function get_external_field_missing +! NAME="get_external_field_missing" + +! +! +! +! return field axes after call to init_external_field. +! Ordering is X/Y/Z/T. +! +! +! +! returned from previous call to init_external_field. +! + + + function get_external_field_axes(index) + + integer :: index + type(axistype), dimension(4) :: get_external_field_axes + + if (index .lt. 1 .or. index .gt. num_fields) & + call mpp_error(FATAL,'invalid index in call to get_external_field_size') + + + get_external_field_axes(1) = field(index)%axes(1) + get_external_field_axes(2) = field(index)%axes(2) + get_external_field_axes(3) = field(index)%axes(3) + get_external_field_axes(4) = field(index)%axes(4) + + end function get_external_field_axes +! NAME="get_external_field_axes" + +! =========================================================================== +subroutine get_time_axis(index, time) + integer , intent(in) :: index ! field id + type(time_type), intent(out) :: time(:) ! array of time values to be filled + + integer :: n ! size of the data to be assigned + + if (index < 1.or.index > num_fields) & + call mpp_error(FATAL,'invalid index in call to get_time_axis') + + n = min(size(time),size(field(index)%time)) + + time(1:n) = field(index)%time(1:n) +end subroutine + +! +! +! +! exit time_interp_external_mod. Close all open files and +! release storage +! + + subroutine time_interp_external_exit() + + integer :: i,j +! +! release storage arrays +! + do i=1,num_fields + deallocate(field(i)%time,field(i)%start_time,field(i)%end_time,& + field(i)%period,field(i)%data,field(i)%mask,field(i)%ibuf) + if (ASSOCIATED(field(i)%src_data)) deallocate(field(i)%src_data) + do j=1,4 + field(i)%axes(j) = default_axis + enddo + field(i)%domain = NULL_DOMAIN2D + field(i)%field = default_field + field(i)%nbuf = 0 + field(i)%slope = 0. + field(i)%intercept = 0. + enddo + + deallocate(field) + deallocate(opened_files) + + num_fields = 0 + + module_initialized = .false. + + end subroutine time_interp_external_exit +! NAME="time_interp_external_exit" + +end module time_interp_external_mod +!> @} +! close documentation grouping diff --git a/tridiagonal/include/tridiagonal.inc b/tridiagonal/include/tridiagonal.inc index 3aaddf070c..c22f99c4ee 100644 --- a/tridiagonal/include/tridiagonal.inc +++ b/tridiagonal/include/tridiagonal.inc @@ -89,8 +89,10 @@ real, dimension(size(x,1),size(x,2),size(x,3)) :: f integer :: k if(present(a)) then - init_tridiagonal = .true. + !< Check if module variables are allocated + !$OMP SINGLE + init_tridiagonal = .true. if(allocated(e)) deallocate(e) if(allocated(g)) deallocate(g) if(allocated(bb)) deallocate(bb) @@ -99,6 +101,7 @@ if(present(a)) then allocate(g (size(x,1),size(x,2),size(x,3))) allocate(bb(size(x,1),size(x,2))) allocate(cc(size(x,1),size(x,2),size(x,3))) + !$OMP END SINGLE !< There is an implicit barrier. e(:,:,1) = - a(:,:,1)/b(:,:,1) a(:,:,size(x,3)) = 0.0 @@ -132,12 +135,15 @@ end subroutine tri_invert !> @brief Releases memory used by the solver subroutine close_tridiagonal -implicit none + implicit none -deallocate(e) -deallocate(g) -deallocate(bb) -deallocate(cc) + !< Check if module variables are allocated + !$OMP SINGLE + if(allocated(e)) deallocate(e) + if(allocated(g)) deallocate(g) + if(allocated(bb)) deallocate(bb) + if(allocated(cc)) deallocate(cc) + !$OMP END SINGLE !< There is an implicit barrier. return end subroutine close_tridiagonal diff --git a/tridiagonal/tridiagonal.F90 b/tridiagonal/tridiagonal.F90 index 3aaddf070c..c22f99c4ee 100644 --- a/tridiagonal/tridiagonal.F90 +++ b/tridiagonal/tridiagonal.F90 @@ -89,8 +89,10 @@ subroutine tri_invert(x,d,a,b,c) integer :: k if(present(a)) then - init_tridiagonal = .true. + !< Check if module variables are allocated + !$OMP SINGLE + init_tridiagonal = .true. if(allocated(e)) deallocate(e) if(allocated(g)) deallocate(g) if(allocated(bb)) deallocate(bb) @@ -99,6 +101,7 @@ subroutine tri_invert(x,d,a,b,c) allocate(g (size(x,1),size(x,2),size(x,3))) allocate(bb(size(x,1),size(x,2))) allocate(cc(size(x,1),size(x,2),size(x,3))) + !$OMP END SINGLE !< There is an implicit barrier. e(:,:,1) = - a(:,:,1)/b(:,:,1) a(:,:,size(x,3)) = 0.0 @@ -132,12 +135,15 @@ end subroutine tri_invert !> @brief Releases memory used by the solver subroutine close_tridiagonal -implicit none + implicit none -deallocate(e) -deallocate(g) -deallocate(bb) -deallocate(cc) + !< Check if module variables are allocated + !$OMP SINGLE + if(allocated(e)) deallocate(e) + if(allocated(g)) deallocate(g) + if(allocated(bb)) deallocate(bb) + if(allocated(cc)) deallocate(cc) + !$OMP END SINGLE !< There is an implicit barrier. return end subroutine close_tridiagonal