From dcdd9ae1e214d8f0c4c548d12dd1448c83016489 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Wed, 5 Sep 2018 13:30:52 -0400 Subject: [PATCH 01/18] Effort to decimate the diag output at runtime - To produce the full diagnostics for 1/8 degree model it is needed to reduce the size of output files. This could be done by "averaging" over a few neighboring grid cells and output the resulting fields on the reduced domain. That's what we call decimation and is the purpose of this project branch. --- src/framework/MOM_diag_mediator.F90 | 51 ++++++++++++++++++++++++++++- src/framework/MOM_diag_remap.F90 | 17 ++++++++++ 2 files changed, 67 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index fb84d4d48d..6fdd0cc6df 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -25,7 +25,7 @@ module MOM_diag_mediator use MOM_diag_remap, only : diag_remap_configure_axes, diag_remap_axes_configured use MOM_diag_remap, only : diag_remap_get_axes_info, diag_remap_set_active use MOM_diag_remap, only : diag_remap_diag_registration_closed -use MOM_diag_remap, only : horizontally_average_diag_field +use MOM_diag_remap, only : horizontally_average_diag_field, horizontally_decimate_diag_field use diag_axis_mod, only : get_diag_axis_name use diag_data_mod, only : null_axis_id @@ -133,6 +133,7 @@ module MOM_diag_mediator logical :: in_use !< True if this entry is being used. integer :: fms_diag_id !< Underlying FMS diag_manager id. integer :: fms_xyave_diag_id = -1 !< For a horizontally area-averaged diagnostic. + integer :: decimate_diag_id = -1 !< For a horizontally area-decimated diagnostic. character(64) :: debug_str = '' !< For FATAL errors and debugging. type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic @@ -1170,11 +1171,59 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) if (diag%fms_xyave_diag_id>0) then call post_xy_average(diag_cs, diag, locfield) endif + + !Decimation test + if (diag%decimate_diag_id>0) then + call post_decimated_data(diag_cs, diag, locfield, decimation_factor=2) + endif + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & deallocate( locfield ) end subroutine post_data_3d_low +!> Post the horizontally area-averaged diagnostic +subroutine post_decimated_data(diag_cs, diag, field, decimation_factor) + type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics mediator control structure + type(diag_type), intent(in) :: diag !< This diagnostic + real, target, intent(in) :: field(:,:,:) !< Diagnostic field + integer, intent(in) :: decimation_factor !< The factor by which to decimate the diag output field + ! Local variable + real, dimension(size(field,3)) :: decimated_field + logical :: used + integer :: nz, remap_nz, coord + +! if (.not. diag_cs%ave_enabled) then +! return +! endif + + if (diag%axes%is_native) then + call horizontally_decimate_diag_field(diag_cs%G, diag_cs%h, & + diag%axes%is_layer, diag%v_extensive, & + diag_cs%missing_value, decimation_factor, field, decimated_field) + else + nz = size(field, 3) + coord = diag%axes%vertical_coordinate_number + remap_nz = diag_cs%diag_remap_cs(coord)%nz + + call assert(diag_cs%diag_remap_cs(coord)%initialized, & + 'post_xy_average: remap_cs not initialized.') + + call assert(IMPLIES(diag%axes%is_layer, nz == remap_nz), & + 'post_xy_average: layer field dimension mismatch.') + call assert(IMPLIES(.not. diag%axes%is_layer, nz == remap_nz+1), & + 'post_xy_average: interface field dimension mismatch.') + + call horizontally_decimate_diag_field(diag_cs%G, diag_cs%diag_remap_cs(coord)%h, & + diag%axes%is_layer, diag%v_extensive, & + diag_cs%missing_value, decimation_factor, field, decimated_field) + endif + + used = send_data(diag%decimate_diag_id, decimated_field, diag_cs%time_end, & + weight=diag_cs%time_int) + +end subroutine post_decimated_data + !> Post the horizontally area-averaged diagnostic subroutine post_xy_average(diag_cs, diag, field) type(diag_type), intent(in) :: diag !< This diagnostic diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 737e7a3fbf..4022318e69 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -54,6 +54,7 @@ module MOM_diag_remap public vertically_reintegrate_diag_field public vertically_interpolate_diag_field public horizontally_average_diag_field +public horizontally_decimate_diag_field !> Represents remapping of diagnostics to a particular vertical coordinate. !! @@ -704,4 +705,20 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, end subroutine horizontally_average_diag_field +!> Horizontally decimate field +subroutine horizontally_decimate_diag_field(G, h, & + is_layer, is_extensive, & + missing_value, decimation_factor, field, decimated_field) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses + logical, intent(in) :: is_layer !< True if the z-axis location is at h points + logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) + real, intent(in) :: missing_value !< A missing_value to assign land/vanished points + integer, intent(in) :: decimation_factor !< The factor by which to decimate the diag output field + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped + real, dimension(:), intent(inout) :: decimated_field !< Field argument horizontally averaged + ! Local variables + +end subroutine horizontally_decimate_diag_field + end module MOM_diag_remap From 7c4adcb96685db1bbb205a111677ccab9b832f90 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 18 Sep 2018 17:19:13 -0400 Subject: [PATCH 02/18] Diag decimation prototype, coarsening by a factor of 2 - Prototype zaps all diagnostics by a factor of 2 - Works only for the native grid diagnostics - _z diagnostics complain about the local mask array index --- src/core/MOM_grid.F90 | 36 ++- src/framework/MOM_diag_mediator.F90 | 372 ++++++++++++++++++++++++++-- src/framework/MOM_domains.F90 | 48 +++- 3 files changed, 435 insertions(+), 21 deletions(-) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index e72038a252..35247a178b 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -5,7 +5,7 @@ module MOM_grid use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_domains, only : MOM_domain_type, get_domain_extent, compute_block_extent -use MOM_domains, only : get_global_shape +use MOM_domains, only : get_global_shape, get_domain_extent_zap2 use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -52,6 +52,23 @@ module MOM_grid integer :: JsgB !< The start j-index of cell vertices within the global domain integer :: JegB !< The end j-index of cell vertices within the global domain + integer :: isc_zap2 !< The start i-index of cell centers within the computational domain + integer :: iec_zap2 !< The end i-index of cell centers within the computational domain + integer :: jsc_zap2 !< The start j-index of cell centers within the computational domain + integer :: jec_zap2 !< The end j-index of cell centers within the computational domain + integer :: isd_zap2 !< The start i-index of cell centers within the data domain + integer :: ied_zap2 !< The end i-index of cell centers within the data domain + integer :: jsd_zap2 !< The start j-index of cell centers within the data domain + integer :: jed_zap2 !< The end j-index of cell centers within the data domain + integer :: IsdB_zap2 !< The start i-index of cell vertices within the data domain + integer :: IedB_zap2 !< The end i-index of cell vertices within the data domain + integer :: JsdB_zap2 !< The start j-index of cell vertices within the data domain + integer :: JedB_zap2 !< The end j-index of cell vertices within the data domain + integer :: isg_zap2 !< The start i-index of cell centers within the computational domain + integer :: ieg_zap2 !< The end i-index of cell centers within the computational domain + integer :: jsg_zap2 !< The start j-index of cell centers within the computational domain + integer :: jeg_zap2 !< The end j-index of cell centers within the computational domain + integer :: isd_global !< The value of isd in the global index space (decompoistion invariant). integer :: jsd_global !< The value of isd in the global index space (decompoistion invariant). integer :: idg_offset !< The offset between the corresponding global and local i-indices. @@ -343,6 +360,23 @@ subroutine MOM_grid_init(G, param_file, HI, global_indexing, bathymetry_at_vel) if ( G%block(nblocks)%jed+G%block(nblocks)%jdg_offset > G%HI%jed + G%HI%jdg_offset ) & call MOM_error(FATAL, "MOM_grid_init: G%jed_bk > G%jed") + call get_domain_extent_zap2(G%Domain, G%isc_zap2, G%iec_zap2, G%jsc_zap2, G%jec_zap2,& + G%isd_zap2, G%ied_zap2, G%jsd_zap2, G%jed_zap2,& + G%isg_zap2, G%ieg_zap2, G%jsg_zap2, G%jeg_zap2) + + ! Set array sizes for fields that are discretized at tracer cell boundaries. +! G%IscB_zap2 = G%isc_zap2 ; G%JscB_zap2 = G%jsc_zap2 + G%IsdB_zap2 = G%isd_zap2 ; G%JsdB_zap2 = G%jsd_zap2 +! G%IsgB_zap2 = G%isg_zap2 ; G%JsgB_zap2 = G%jsg_zap2 + if (G%symmetric) then +! G%IscB_zap2 = G%isc_zap2-1 ; G%JscB_zap2 = G%jsc_zap2-1 + G%IsdB_zap2 = G%isd_zap2-1 ; G%JsdB_zap2 = G%jsd_zap2-1 +! G%IsgB_zap2 = G%isg_zap2-1 ; G%JsgB_zap2 = G%jsg_zap2-1 + endif +! G%IecB_zap2 = G%iec_zap2 ; G%JecB_zap2 = G%jec_zap2 + G%IedB_zap2 = G%ied_zap2 ; G%JedB_zap2 = G%jed_zap2 +! G%IegB_zap2 = G%ieg_zap2 ; G%JegB_zap2 = G%jeg_zap2 + end subroutine MOM_grid_init diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 6fdd0cc6df..f4d33cb2cb 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -67,6 +67,10 @@ module MOM_diag_mediator module procedure post_data_3d, post_data_2d, post_data_0d end interface post_data +interface zap2_sample + module procedure zap2_sample_2d,zap2_sample_3d,zap2_sample_2d0,zap2_sample_3d0 +end interface zap2_sample + !> A group of 1D axes that comprise a 1D/2D/3D mesh type, public :: axes_grp character(len=15) :: id !< The id string for this particular combination of handles. @@ -108,6 +112,8 @@ module MOM_diag_mediator ! For masking real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes + real, pointer, dimension(:,:) :: mask2d_zap2 => null() !< Mask for 2d (x-y) axes zapped by a factor 2 + real, pointer, dimension(:,:,:) :: mask3d_zap2 => null() !< Mask for 3d axes zapped by a factor 2 end type axes_grp !> Contains an array to store a diagnostic target grid @@ -191,6 +197,28 @@ module MOM_diag_mediator real, dimension(:,:,:), pointer :: mask3dCui => null() real, dimension(:,:,:), pointer :: mask3dCvi => null() !!@} + real, dimension(:,:), pointer :: mask2dT_zap2 => null() !< 2D mask array for cell-center points + real, dimension(:,:), pointer :: mask2dBu_zap2 => null() !< 2D mask array for cell-corner points + real, dimension(:,:), pointer :: mask2dCu_zap2 => null() !< 2D mask array for east-face points + real, dimension(:,:), pointer :: mask2dCv_zap2 => null() !< 2D mask array for north-face points + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + real, dimension(:,:,:), pointer :: mask3dTL_zap2 => null() + real, dimension(:,:,:), pointer :: mask3dBL_zap2 => null() + real, dimension(:,:,:), pointer :: mask3dCuL_zap2 => null() + real, dimension(:,:,:), pointer :: mask3dCvL_zap2 => null() + real, dimension(:,:,:), pointer :: mask3dTi_zap2 => null() + real, dimension(:,:,:), pointer :: mask3dBi_zap2 => null() + real, dimension(:,:,:), pointer :: mask3dCui_zap2 => null() + real, dimension(:,:,:), pointer :: mask3dCvi_zap2 => null() + !!@} + integer :: isc_zap2 !< The start i-index of cell centers within the computational domain + integer :: iec_zap2 !< The end i-index of cell centers within the computational domain + integer :: jsc_zap2 !< The start j-index of cell centers within the computational domain + integer :: jec_zap2 !< The end j-index of cell centers within the computational domain + integer :: isd_zap2 !< The start i-index of cell centers within the data domain + integer :: ied_zap2 !< The end i-index of cell centers within the data domain + integer :: jsd_zap2 !< The start j-index of cell centers within the data domain + integer :: jed_zap2 !< The end j-index of cell centers within the data domain ! Space for diagnostics is dynamically allocated as it is needed. ! The chunk size is how much the array should grow on each new allocation. @@ -238,6 +266,9 @@ module MOM_diag_mediator ! CPU clocks integer :: id_clock_diag_mediator, id_clock_diag_remap, id_clock_diag_grid_updates +logical :: decim_all_diags = .true. +integer :: decim_fac = 2 + contains !> Sets up diagnostics axes @@ -250,12 +281,43 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) !! vertical axes ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh - integer :: i, k, nz + integer :: i, j, k, nz real :: zlev(GV%ke), zinter(GV%ke+1) logical :: set_vert + real, dimension(:), pointer :: gridLonT_zap2 =>NULL() + real, dimension(:), pointer :: gridLatT_zap2 =>NULL() set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical +if(decim_all_diags) then + + allocate(gridLonT_zap2(G%isg_zap2:G%ieg_zap2)) + allocate(gridLatT_zap2(G%jsg_zap2:G%jeg_zap2)) + + do i=G%isg_zap2,G%ieg_zap2; gridLonT_zap2(i) = G%gridLonT(G%isg+decim_fac*i-2); enddo + do j=G%jsg_zap2,G%jeg_zap2; gridLatT_zap2(j) = G%gridLatT(G%jsg+decim_fac*j-2); enddo + + +! if (G%symmetric) then +! id_xq = diag_axis_init('xq', G%gridLonB_zap2(G%isgB:G%iegB), G%x_axis_units, 'x', & +! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) +! id_yq = diag_axis_init('yq', G%gridLatB_zap2(G%jsgB:G%jegB), G%y_axis_units, 'y', & +! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) +! else + id_xq = diag_axis_init('xq', gridLonT_zap2(G%isg_zap2:G%ieg_zap2), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) + id_yq = diag_axis_init('yq', gridLatT_zap2(G%jsg_zap2:G%jeg_zap2), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) +! endif + id_xh = diag_axis_init('xh', gridLonT_zap2(G%isg_zap2:G%ieg_zap2), G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) + id_yh = diag_axis_init('yh', gridLatT_zap2(G%jsg_zap2:G%jeg_zap2), G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + + deallocate(gridLonT_zap2) + deallocate(gridLatT_zap2) + +else if (G%symmetric) then id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & 'q point nominal longitude', Domain2=G%Domain%mpp_domain) @@ -271,6 +333,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) 'h point nominal longitude', Domain2=G%Domain%mpp_domain) id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & 'h point nominal latitude', Domain2=G%Domain%mpp_domain) +endif if (set_vert) then nz = GV%ke @@ -429,7 +492,7 @@ subroutine set_masks_for_axes(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, nk, i, j, k + integer :: c, nk, i, j, k, ii, jj type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience do c=1, diag_cs%num_diag_coords @@ -441,7 +504,9 @@ subroutine set_masks_for_axes(G, diag_cs) nk = axes%nz allocate( axes%mask3d(G%isd:G%ied,G%jsd:G%jed,nk) ) ; axes%mask3d(:,:,:) = 0. call diag_remap_calc_hmask(diag_cs%diag_remap_cs(c), G, axes%mask3d) - + if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk, G%isd,G%ied,G%jsd,G%jed,& + G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + h_axes => diag_cs%remap_axesTL(c) ! Use the h-point masks to generate the u-, v- and q- masks ! Level/layer u-points in diagnostic coordinate @@ -452,6 +517,8 @@ subroutine set_masks_for_axes(G, diag_cs) do k = 1, nk ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(I,j,k) = 1. enddo ; enddo ; enddo + if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk, G%isdb,G%iedb,G%jsd,G%jed,& + G%isdb_zap2,G%iedb_zap2,G%jsd_zap2,G%jed_zap2) ! Level/layer v-points in diagnostic coordinate axes => diag_cs%remap_axesCvL(c) @@ -461,6 +528,8 @@ subroutine set_masks_for_axes(G, diag_cs) do k = 1, nk ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,J,k) = 1. enddo ; enddo ; enddo + if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk, G%isd,G%ied,G%jsdb,G%jedb,& + G%isd_zap2,G%ied_zap2,G%jsdb_zap2,G%jedb_zap2) ! Level/layer q-points in diagnostic coordinate axes => diag_cs%remap_axesBL(c) @@ -471,6 +540,8 @@ subroutine set_masks_for_axes(G, diag_cs) if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + & h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(I,J,k) = 1. enddo ; enddo ; enddo + if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk, G%isdb,G%iedb,G%jsdb,G%jedb,& + G%isdb_zap2,G%iedb_zap2,G%jsdb_zap2,G%jedb_zap2) ! Interface h-points in diagnostic coordinate (w-point) axes => diag_cs%remap_axesTi(c) @@ -484,6 +555,8 @@ subroutine set_masks_for_axes(G, diag_cs) enddo if (h_axes%mask3d(i,j,nk) > 0.) axes%mask3d(i,J,nk+1) = 1. enddo ; enddo + if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk+1, G%isd,G%ied,G%jsd,G%jed,& + G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) h_axes => diag_cs%remap_axesTi(c) ! Use the w-point masks to generate the u-, v- and q- masks @@ -495,6 +568,8 @@ subroutine set_masks_for_axes(G, diag_cs) do k = 1, nk+1 ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(I,j,k) = 1. enddo ; enddo ; enddo + if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk+1, G%isdb,G%iedb,G%jsd,G%jed,& + G%isdb_zap2,G%iedb_zap2,G%jsd_zap2,G%jed_zap2) ! Interface v-points in diagnostic coordinate axes => diag_cs%remap_axesCvi(c) @@ -504,6 +579,8 @@ subroutine set_masks_for_axes(G, diag_cs) do k = 1, nk+1 ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,J,k) = 1. enddo ; enddo ; enddo + if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk+1, G%isd,G%ied,G%jsdb,G%jedb,& + G%isd_zap2,G%ied_zap2,G%jsdb_zap2,G%jedb_zap2) ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) @@ -514,6 +591,8 @@ subroutine set_masks_for_axes(G, diag_cs) if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + & h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(I,J,k) = 1. enddo ; enddo ; enddo + if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk+1, G%isdb,G%iedb,G%jsdb,G%jedb,& + G%isdb_zap2,G%iedb_zap2,G%jsdb_zap2,G%jedb_zap2) endif enddo @@ -703,6 +782,31 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num endif endif + axes%mask2d_zap2 => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%mask2d_zap2 => diag_cs%mask2dT_zap2 + if (axes%is_u_point) axes%mask2d_zap2 => diag_cs%mask2dCu_zap2 + if (axes%is_v_point) axes%mask2d_zap2 => diag_cs%mask2dCv_zap2 + if (axes%is_q_point) axes%mask2d_zap2 => diag_cs%mask2dBu_zap2 + endif + ! A static 3d mask for non-native coordinates can only be setup when a grid is available + axes%mask3d_zap2 => null() + if (axes%rank==3 .and. axes%is_native) then + ! Native variables can/should use the native masks copied into diag_cs + if (axes%is_layer) then + if (axes%is_h_point) axes%mask3d_zap2 => diag_cs%mask3dTL_zap2 + if (axes%is_u_point) axes%mask3d_zap2 => diag_cs%mask3dCuL_zap2 + if (axes%is_v_point) axes%mask3d_zap2 => diag_cs%mask3dCvL_zap2 + if (axes%is_q_point) axes%mask3d_zap2 => diag_cs%mask3dBL_zap2 + elseif (axes%is_interface) then + if (axes%is_h_point) axes%mask3d_zap2 => diag_cs%mask3dTi_zap2 + if (axes%is_u_point) axes%mask3d_zap2 => diag_cs%mask3dCui_zap2 + if (axes%is_v_point) axes%mask3d_zap2 => diag_cs%mask3dCvi_zap2 + if (axes%is_q_point) axes%mask3d_zap2 => diag_cs%mask3dBi_zap2 + endif + endif + + end subroutine define_axes_group !> Set up the array extents for doing diagnostics @@ -715,6 +819,11 @@ subroutine set_diag_mediator_grid(G, diag_cs) diag_cs%isd = G%isd ; diag_cs%ied = G%ied diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + diag_cs%isc_zap2 = G%isc_zap2 - (G%isd_zap2-1) ; diag_cs%iec_zap2 = G%iec_zap2 - (G%isd_zap2-1) + diag_cs%jsc_zap2 = G%jsc_zap2 - (G%jsd_zap2-1) ; diag_cs%jec_zap2 = G%jec_zap2 - (G%jsd_zap2-1) + diag_cs%isd_zap2 = G%isd_zap2 ; diag_cs%ied_zap2 = G%ied_zap2 + diag_cs%jsd_zap2 = G%jsd_zap2 ; diag_cs%jed_zap2 = G%jed_zap2 + end subroutine set_diag_mediator_grid !> Make a real scalar diagnostic available for averaging or output @@ -823,6 +932,9 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) logical :: used, is_stat integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, i, j, chksum + !decimation + integer :: isv_dec,iev_dec,jsv_dec,jev_dec + real, dimension(:,:), pointer :: decim_field => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -876,11 +988,25 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) else locfield => field endif + + if (decim_all_diags) then + isv_dec = 1 ; iev_dec = (iev-isv+1)/decim_fac + jsv_dec = 1 ; jev_dec = (jev-jsv+1)/decim_fac + allocate(decim_field(isv_dec:iev_dec,jsv_dec:jev_dec)) + endif + if (diag_cs%diag_as_chksum) then chksum = chksum_general(locfield) if (is_root_pe()) then call log_chksum_diag(diag_cs%chksum_diag_doc_unit, diag%debug_str, chksum) endif + elseif (decim_all_diags) then + !Sample the field at the corner of each cell + do j=jsv_dec,jev_dec ; do i=isv_dec,iev_dec + decim_field(i,j) = locfield(isv+decim_fac*i-2,jsv+decim_fac*j-2) + enddo ; enddo + used = send_data(diag%fms_diag_id, decim_field, diag_cs%time_end, & + is_in=isv_dec, js_in=jsv_dec, ie_in=iev_dec, je_in=jev_dec) else if (is_stat) then if (present(mask)) then @@ -1045,7 +1171,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) real, target, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. ! Local variables real, dimension(:,:,:), pointer :: locfield => NULL() @@ -1056,6 +1182,12 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c integer :: chksum + !decimation + integer :: isv_zap2,iev_zap2,jsv_zap2,jev_zap2 + real, dimension(:,:,:), pointer :: zap2_field => NULL() + real, dimension(:,:,:), pointer :: zap2_mask => NULL() + real, dimension(:,:,:), pointer :: locmask => NULL() + real, dimension(:,:,:), pointer :: diag_axes_mask3d => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1096,8 +1228,8 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) endif + ks = lbound(field,3) ; ke = ubound(field,3) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then - ks = lbound(field,3) ; ke = ubound(field,3) allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) ) ! locfield(:,:,:) = 0.0 ! Zeroing out this array would be a good idea, but it appears ! not to be necessary. @@ -1116,7 +1248,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) "have j-direction space to represent the symmetric computational domain.") endif - do k=ks,ke ; do j=jsv_c,jev ; do i=isv_c,iev + do k=ks,ke ; do j=jsv,jev ; do i=isv,iev if (field(i,j,k) == diag_cs%missing_value) then locfield(i,j,k) = diag_cs%missing_value else @@ -1127,12 +1259,74 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) locfield => field endif + if (present(mask)) then + call assert(size(locfield) == size(mask), & + 'post_data_3d_low: mask size mismatch: '//diag%debug_str) + locmask => mask + endif + + diag_axes_mask3d => diag%axes%mask3d + + if (decim_all_diags) then + diag_axes_mask3d => diag%axes%mask3d_zap2 + + isv_zap2 = diag_cs%isc_zap2 ; iev_zap2 = diag_cs%iec_zap2 + jsv_zap2 = diag_cs%jsc_zap2 ; jev_zap2 = diag_cs%jec_zap2 + + if ( size(field,1) == dszi ) then + isv_zap2 = diag_cs%isc_zap2 ; iev_zap2 = diag_cs%iec_zap2 ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv_zap2 = diag_cs%isc_zap2 ; iev_zap2 = diag_cs%iec_zap2+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv_zap2 = 1 ; iev_zap2 = (diag_cs%iec_zap2-diag_cs%isc_zap2) +1 ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv_zap2 = 1 ; iev_zap2 = (diag_cs%iec_zap2-diag_cs%isc_zap2) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) + endif + if ( size(field,2) == dszj ) then + jsv_zap2 = diag_cs%jsc_zap2 ; jev_zap2 = diag_cs%jec_zap2 ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv_zap2 = diag_cs%jsc_zap2 ; jev_zap2 = diag_cs%jec_zap2+1 ! Symmetric data domain + elseif ( size(field,2) == cszj) then + jsv_zap2 = 1 ; jev_zap2 = (diag_cs%jec_zap2-diag_cs%jsc_zap2) +1 ! Computational domain + elseif ( size(field,2) == cszj + 1 ) then + jsv_zap2 = 1 ; jev_zap2 = (diag_cs%jec_zap2-diag_cs%jsc_zap2) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) + endif + !Sample the field at the corner of each cell + call zap2_sample(locfield, zap2_field, ks,ke) + !point locfield to the decimated field + locfield => zap2_field + isv=isv_zap2; iev=iev_zap2; jsv=jsv_zap2; jev=jev_zap2 + + !Decimated mask + if (present(mask)) then + call zap2_sample(mask, zap2_mask, ks,ke) + locmask => zap2_mask + endif + + endif + if (diag%fms_diag_id>0) then if (diag_cs%diag_as_chksum) then chksum = chksum_general(locfield) if (is_root_pe()) then call log_chksum_diag(diag_cs%chksum_diag_doc_unit, diag%debug_str, chksum) endif + !Decimation test +! elseif (decim_all_diags) then +! !Sample the field at the corner of each cell +! do k=ks,ke ; do j=jsv_dec,jev_dec ; do i=isv_dec,iev_dec +! decim_field(i,j,k) = locfield(isv+decim_fac*i-2,jsv+decim_fac*j-2,k) +! enddo ; enddo ; enddo +! used = send_data(diag%fms_diag_id, decim_field, diag_cs%time_end, & +! is_in=isv_dec, js_in=jsv_dec, ie_in=iev_dec, je_in=jev_dec) else if (is_stat) then if (present(mask)) then @@ -1148,18 +1342,16 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then - if (present(mask)) then - call assert(size(locfield) == size(mask), & - 'post_data_3d_low: mask size mismatch: '//diag%debug_str) + if (associated(locmask)) then used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=mask) - elseif (associated(diag%axes%mask3d)) then - call assert(size(locfield) == size(diag%axes%mask3d), & + weight=diag_cs%time_int, rmask=locmask) + elseif (associated(diag_axes_mask3d)) then + call assert(size(locfield) == size(diag_axes_mask3d), & 'post_data_3d_low: mask3d size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%axes%mask3d) + weight=diag_cs%time_int, rmask=diag_axes_mask3d) else used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & @@ -1182,6 +1374,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) end subroutine post_data_3d_low + !> Post the horizontally area-averaged diagnostic subroutine post_decimated_data(diag_cs, diag, field, decimation_factor) type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics mediator control structure @@ -1320,7 +1513,7 @@ end function get_diag_time_end !> Returns the "diag_mediator" handle for a group (native, CMOR, z-coord, ...) of diagnostics !! derived from one field. -integer function register_diag_field(module_name, field_name, axes, init_time, & +integer function register_diag_field(module_name, field_name, axes_in, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & @@ -1328,7 +1521,7 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + type(axes_grp), target, intent(in) :: axes_in !< Container w/ up to 3 integer handles that !! indicates axes for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. @@ -1366,16 +1559,37 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & real :: MOM_missing_value type(diag_ctrl), pointer :: diag_cs => NULL() type(axes_grp), pointer :: remap_axes => null() + type(axes_grp), pointer :: axes => null() integer :: dm_id, i character(len=256) :: new_module_name logical :: active + axes => axes_in MOM_missing_value = axes%diag_cs%missing_value if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs dm_id = -1 - + !Reroute the axes for decimated diagnostics + if (decim_all_diags) then + if ((axes_in%id == diag_cs%axesTL%id)) then + axes => diag_cs%axesTL + elseif (axes_in%id == diag_cs%axesBL%id) then + axes => diag_cs%axesBL + elseif (axes_in%id == diag_cs%axesCuL%id ) then + axes => diag_cs%axesCuL + elseif (axes_in%id == diag_cs%axesCvL%id) then + axes => diag_cs%axesCvL + elseif (axes_in%id == diag_cs%axesTi%id) then + axes => diag_cs%axesTi + elseif (axes_in%id == diag_cs%axesBi%id) then + axes => diag_cs%axesBi + elseif (axes_in%id == diag_cs%axesCui%id ) then + axes => diag_cs%axesCui + elseif (axes_in%id == diag_cs%axesCvi%id) then + axes => diag_cs%axesCvi + endif + endif ! Register the native diagnostic active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & @@ -1439,7 +1653,7 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & end function register_diag_field -!> Returns True if either the native of CMOr version of the diagnostic were registered. Updates 'dm_id' +!> Returns True if either the native or CMOr version of the diagnostic were registered. Updates 'dm_id' !! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field. logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & @@ -2235,7 +2449,6 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mod, version, "") - call get_param(param_file, mod, 'NUM_DIAG_COORDS', diag_cs%num_diag_coords, & 'The number of diagnostic vertical coordinates to use.\n'//& 'For each coordinate, an entry in DIAG_COORDS must be provided.', & @@ -2450,6 +2663,9 @@ subroutine diag_masks_set(G, nz, diag_cs) ! Local variables integer :: k + if(decim_all_diags) then + call zap2_diag_masks_set(G, nz, diag_cs) + endif ! 2d masks point to the model masks since they are identical diag_cs%mask2dT => G%mask2dT diag_cs%mask2dBu => G%mask2dBu @@ -2481,6 +2697,126 @@ subroutine diag_masks_set(G, nz, diag_cs) end subroutine diag_masks_set +subroutine zap2_sample_3d(field_in, field_out,ks,ke, is,ie,js,je, is2,ie2,js2,je2) + integer , intent(in) :: ks,ke, is,ie,js,je, is2,ie2,js2,je2 + real, dimension(is:,js:,1:) ,intent(in) :: field_in + real, dimension(:,:,:) , pointer :: field_out + integer :: k,i,j,ii,jj + + allocate(field_out(is2:ie2,js2:je2,ks:ke)) + do k= ks,ke ; do j=js2,je2 ; do i=is2,ie2 + ii = is+2*(i-is2) + jj = js+2*(j-js2) + field_out(i,j,k) = field_in(ii,jj,k) + enddo; enddo; enddo + +end subroutine zap2_sample_3d + +subroutine zap2_sample_2d(field_in, field_out, is,ie,js,je, is2,ie2,js2,je2) + integer , intent(in) :: is,ie,js,je, is2,ie2,js2,je2 + real, dimension(is:,js:) ,intent(in) :: field_in + real, dimension(:,:) , pointer :: field_out + integer :: i,j,ii,jj + + allocate(field_out(is2:ie2,js2:je2)) + do j=js2,je2 ; do i=is2,ie2 + ii = is+2*(i-is2) + jj = js+2*(j-js2) + field_out(i,j) = field_in(ii,jj) + enddo; enddo + +end subroutine zap2_sample_2d + +subroutine zap2_sample_3d0(field_in, field_out,ks,ke) + integer , intent(in) :: ks,ke + real, dimension(:,:,:) ,intent(in) :: field_in + real, dimension(:,:,:) , pointer :: field_out + integer :: k,i,j,ii,jj, is_in,js_in, is2,ie2,js2,je2 + + is_in=1; js_in=1 + is2=1; ie2=size(field_in,1)/2 + js2=1; je2=size(field_in,2)/2 + + allocate(field_out(is2:ie2,js2:je2,ks:ke)) + + do k= ks,ke ; do j=js2,je2 ; do i=is2,ie2 + ii = is_in+2*(i-is2) + jj = js_in+2*(j-js2) + field_out(i,j,k) = field_in(ii,jj,k) + enddo; enddo; enddo + +end subroutine zap2_sample_3d0 + +subroutine zap2_sample_2d0(field_in, field_out) + real, dimension(:,:) ,intent(in) :: field_in + real, dimension(:,:) , pointer :: field_out + integer :: i,j,ii,jj, is_in,js_in, is2,ie2,js2,je2 + + is_in=1; js_in=1 + is2=1; ie2=size(field_in,1)/2 + js2=1; je2=size(field_in,2)/2 + + allocate(field_out(is2:ie2,js2:je2)) + + do j=js2,je2 ; do i=is2,ie2 + ii = is_in+2*(i-is2) + jj = js_in+2*(j-js2) + field_out(i,j) = field_in(ii,jj) + enddo; enddo + +end subroutine zap2_sample_2d0 + +subroutine zap2_diag_masks_set(G, nz, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + integer, intent(in) :: nz !< The number of layers in the model's native grid. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: i,j,k,ii,jj + +!print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec +!print*,'coarse c extents ',G%isc_zap2,G%iec_zap2,G%jsc_zap2,G%jec_zap2 +!print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed +!print*,'coarse d extents ',G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2 +! original c extents 5 52 5 64 +! coarse c extents 5 28 5 34 +! original d extents 1 56 1 68 +! coarse d extents 1 32 1 38 + diag_cs%isc_zap2 = G%isc_zap2 - (G%isd_zap2-1) ; diag_cs%iec_zap2 = G%iec_zap2 - (G%isd_zap2-1) + diag_cs%jsc_zap2 = G%jsc_zap2 - (G%jsd_zap2-1) ; diag_cs%jec_zap2 = G%jec_zap2 - (G%jsd_zap2-1) + diag_cs%isd_zap2 = G%isd_zap2 ; diag_cs%ied_zap2 = G%ied_zap2 + diag_cs%jsd_zap2 = G%jsd_zap2 ; diag_cs%jed_zap2 = G%jed_zap2 + + ! 2d masks point to the model masks since they are identical + call zap2_sample(G%mask2dT, diag_cs%mask2dT_zap2 ,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + call zap2_sample(G%mask2dBu,diag_cs%mask2dBu_zap2,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + call zap2_sample(G%mask2dCu,diag_cs%mask2dCu_zap2,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + call zap2_sample(G%mask2dCv,diag_cs%mask2dCv_zap2,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + ! 3d native masks are needed by diag_manager but the native variables + ! can only be masked 2d - for ocean points, all layers exists. + allocate(diag_cs%mask3dTL_zap2(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) + allocate(diag_cs%mask3dBL_zap2(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz)) + allocate(diag_cs%mask3dCuL_zap2(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) + allocate(diag_cs%mask3dCvL_zap2(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz)) + do k=1,nz + diag_cs%mask3dTL_zap2(:,:,k) = diag_cs%mask2dT_zap2(:,:) + diag_cs%mask3dBL_zap2(:,:,k) = diag_cs%mask2dBu_zap2(:,:) + diag_cs%mask3dCuL_zap2(:,:,k) = diag_cs%mask2dCu_zap2(:,:) + diag_cs%mask3dCvL_zap2(:,:,k) = diag_cs%mask2dCv_zap2(:,:) + enddo + allocate(diag_cs%mask3dTi_zap2(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz+1)) + allocate(diag_cs%mask3dBi_zap2(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz+1)) + allocate(diag_cs%mask3dCui_zap2(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2,1:nz+1)) + allocate(diag_cs%mask3dCvi_zap2(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz+1)) + do k=1,nz+1 + diag_cs%mask3dTi_zap2(:,:,k) = diag_cs%mask2dT_zap2(:,:) + diag_cs%mask3dBi_zap2(:,:,k) = diag_cs%mask2dBu_zap2(:,:) + diag_cs%mask3dCui_zap2(:,:,k) = diag_cs%mask2dCu_zap2(:,:) + diag_cs%mask3dCvi_zap2(:,:,k) = diag_cs%mask2dCv_zap2(:,:) + enddo + +end subroutine zap2_diag_masks_set + subroutine diag_mediator_close_registration(diag_CS) type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index a38facf79a..58c6f30171 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -32,7 +32,7 @@ module MOM_domains implicit none ; private -public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent +public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent, get_domain_extent_zap2 public :: MOM_define_domain, MOM_define_io_domain, clone_MOM_domain public :: pass_var, pass_vector, broadcast, PE_here, root_PE, num_PEs public :: pass_var_start, pass_var_complete, fill_symmetric_edges @@ -98,6 +98,8 @@ module MOM_domains type, public :: MOM_domain_type type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos !! on this processor, centered at h points. + type(domain2D), pointer :: mpp_domain_zap2 => NULL() !< A coarse FMS domain with halos + !! on this processor, centered at h points. integer :: niglobal !< The total horizontal i-domain size. integer :: njglobal !< The total horizontal j-domain size. integer :: nihalo !< The i-halo size in memory. @@ -1148,7 +1150,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & character(len=8) :: char_xsiz, char_ysiz, char_niglobal, char_njglobal character(len=40) :: nihalo_nm, njhalo_nm, layout_nm, io_layout_nm, masktable_nm character(len=40) :: niproc_nm, njproc_nm - + integer :: xhalo_zap2,yhalo_zap2 ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -1156,6 +1158,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_zap2) endif pe = PE_here() @@ -1510,6 +1513,28 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif endif + global_indices(1) = 1 ; global_indices(2) = int(MOM_dom%niglobal/2) + global_indices(3) = 1 ; global_indices(4) = int(MOM_dom%njglobal/2) + xhalo_zap2 = int(MOM_dom%nihalo/2) + yhalo_zap2 = int(MOM_dom%njhalo/2) + if (mask_table_exists) then + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_zap2, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=xhalo_zap2, yhalo=yhalo_zap2, & + symmetry = MOM_dom%symmetric, name=trim("MOMc"), & + maskmap=MOM_dom%maskmap ) + else + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_zap2, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=xhalo_zap2, yhalo=yhalo_zap2, & + symmetry = MOM_dom%symmetric, name=trim("MOMc")) + endif + + if ((io_layout(1) > 0) .and. (io_layout(2) > 0) .and. & + (layout(1)*layout(2) > 1)) then + call MOM_define_io_domain(MOM_dom%mpp_domain_zap2, io_layout) + endif + end subroutine MOM_domains_init !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing @@ -1541,6 +1566,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_zap2) endif ! Save the extra data for creating other domains of different resolution that overlay this domain @@ -1738,6 +1764,24 @@ subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & end subroutine get_domain_extent +subroutine get_domain_extent_zap2(Domain, isc_zap2, iec_zap2, jsc_zap2, jec_zap2,& + isd_zap2, ied_zap2, jsd_zap2, jed_zap2,& + isg_zap2, ieg_zap2, jsg_zap2, jeg_zap2) + type(MOM_domain_type), & + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc_zap2, iec_zap2, jsc_zap2, jec_zap2 + integer, intent(out) :: isd_zap2, ied_zap2, jsd_zap2, jed_zap2 + integer, intent(out) :: isg_zap2, ieg_zap2, jsg_zap2, jeg_zap2 + call mpp_get_compute_domain(Domain%mpp_domain_zap2, isc_zap2, iec_zap2, jsc_zap2, jec_zap2) + call mpp_get_data_domain(Domain%mpp_domain_zap2, isd_zap2, ied_zap2, jsd_zap2, jed_zap2) + call mpp_get_global_domain (Domain%mpp_domain_zap2, isg_zap2, ieg_zap2, jsg_zap2, jeg_zap2) + ! This code institutes the MOM convention that local array indices start at 1. + isc_zap2 = isc_zap2-isd_zap2+1 ; iec_zap2 = iec_zap2-isd_zap2+1 + jsc_zap2 = jsc_zap2-jsd_zap2+1 ; jec_zap2 = jec_zap2-jsd_zap2+1 + ied_zap2 = ied_zap2-isd_zap2+1 ; jed_zap2 = jed_zap2-jsd_zap2+1 + isd_zap2 = 1 ; jsd_zap2 = 1 +end subroutine get_domain_extent_zap2 + !> Returns the global shape of h-point arrays subroutine get_global_shape(domain, niglobal, njglobal) type(MOM_domain_type), intent(in) :: domain !< MOM domain From b9d714b49be2f9d43f25b2cffd12855b2a352e4b Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Wed, 19 Sep 2018 14:52:09 -0400 Subject: [PATCH 03/18] Diag decimation prototype, works for native and _z - Next: make diag decimation optional at diag_table level --- src/framework/MOM_diag_mediator.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index f4d33cb2cb..8571283fd3 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1330,10 +1330,10 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) else if (is_stat) then if (present(mask)) then - call assert(size(locfield) == size(mask), & + call assert(size(locfield) == size(locmask), & 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) !elseif (associated(diag%axes%mask3d)) then ! used = send_data(diag_field_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask3d) @@ -1342,7 +1342,9 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then - if (associated(locmask)) then + if (present(mask)) then + call assert(size(locfield) == size(locmask), & + 'post_data_3d_low: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int, rmask=locmask) From d1b15c4a20f60895633c45fa700c763baac5a334 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 27 Sep 2018 15:29:39 -0400 Subject: [PATCH 04/18] Diag decimation prototype, requesting in diag_table - This update allows the use to request a level 2 decimated diagnostics in the diag_table as following example shows OMp5 1900 1 1 0 0 0 "ocean_hour", 0, "days", 1, "days", "time" "ocean_model", "tos", "tos", "ocean_hour", "all", "mean", "none",2 "ocean_model", "thetao", "thetao", "ocean_hour", "all", "mean", "none",2 "ocean_model", "umo", "umo", "ocean_hour", "all", "mean", "none",2 "ocean_model", "vmo", "vmo", "ocean_hour", "all", "mean", "none",2 "ocean_model", "volcello", "volcello", "ocean_hour", "all", "mean", "none",2 # Cell measure for 3d data "ocean_hour_d2", 0, "days", 1, "days", "time" "ocean_model_d2", "tos", "tos", "ocean_hour_d2", "all", "mean", "none",2 "ocean_model_d2", "thetao", "thetao", "ocean_hour_d2", "all", "mean", "none",2 "ocean_model_d2", "umo", "umo", "ocean_hour_d2", "all", "mean", "none",2 "ocean_model_d2", "vmo", "vmo", "ocean_hour_d2", "all", "mean", "none",2 "ocean_model_d2", "volcello", "volcello", "ocean_hour_d2", "all", "mean", "none",2 # Cell measure for 3d data - At the moment it works only for "Native" grid diagnostics and level 2 decimation (bination?) - It has to be extended to non-native diagnostics, e.g., "ocean_model_z_d2", "tos", "tos", "ocean_hour_z_d2", "all", "mean", "none",2 - It has to be extended to arbitrary level of decimation, e.g., "ocean_model_z_d4", "tos", "tos", "ocean_hour_z_d4", "all", "mean", "none",2 "ocean_model_z_d2", "tos", "tos", "ocean_hour_z_d2", "all", "mean", "none",2 - Also, note that this prototype only works for smart choices of layouts where "combined" cells are on the same pe We need a major design revision to extend this to arbitrary layouts that would need halo updates and halo handling. --- src/framework/MOM_diag_mediator.F90 | 1199 +++++++++++++++++---------- src/framework/MOM_diag_remap.F90 | 17 - 2 files changed, 745 insertions(+), 471 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 8571283fd3..9bb049dbb7 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -8,7 +8,7 @@ module MOM_diag_mediator use MOM_coms, only : PE_here use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, assert use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, query_vardesc, mom_read_data @@ -25,7 +25,7 @@ module MOM_diag_mediator use MOM_diag_remap, only : diag_remap_configure_axes, diag_remap_axes_configured use MOM_diag_remap, only : diag_remap_get_axes_info, diag_remap_set_active use MOM_diag_remap, only : diag_remap_diag_registration_closed -use MOM_diag_remap, only : horizontally_average_diag_field, horizontally_decimate_diag_field +use MOM_diag_remap, only : horizontally_average_diag_field use diag_axis_mod, only : get_diag_axis_name use diag_data_mod, only : null_axis_id @@ -42,6 +42,7 @@ module MOM_diag_mediator #undef __DO_SAFETY_CHECKS__ #define IMPLIES(A, B) ((.not. (A)) .or. (B)) +#define MAX_DECIM_LEV 2 public set_axes_info, post_data, register_diag_field, time_type public set_masks_for_axes @@ -71,6 +72,19 @@ module MOM_diag_mediator module procedure zap2_sample_2d,zap2_sample_3d,zap2_sample_2d0,zap2_sample_3d0 end interface zap2_sample +interface decimate_sample + module procedure decimate_sample_2d, decimate_sample_3d +end interface decimate_sample + +interface decimate_diag_field + module procedure decimate_diag_field_2d,decimate_diag_field_3d +end interface decimate_diag_field + +type, private :: diag_decim + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes +end type diag_decim + !> A group of 1D axes that comprise a 1D/2D/3D mesh type, public :: axes_grp character(len=15) :: id !< The id string for this particular combination of handles. @@ -103,6 +117,7 @@ module MOM_diag_mediator logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled !! interface-located field that must be interpolated to !! these axes. Used for rank>2. + integer :: decimation_level = 1 !< If greater than 1, the factor by which this diagnostic/axes/masks be decimated ! For horizontally averaged diagnositcs (applies to 2d and 3d fields only) type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontall area-averaged diagnostics ! ID's for cell_measures @@ -112,8 +127,7 @@ module MOM_diag_mediator ! For masking real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes - real, pointer, dimension(:,:) :: mask2d_zap2 => null() !< Mask for 2d (x-y) axes zapped by a factor 2 - real, pointer, dimension(:,:,:) :: mask3d_zap2 => null() !< Mask for 3d axes zapped by a factor 2 + type(diag_decim), dimension(2:MAX_DECIM_LEV) :: decim !< Decimation container end type axes_grp !> Contains an array to store a diagnostic target grid @@ -148,6 +162,36 @@ module MOM_diag_mediator !! False for intensive (concentrations). end type diag_type +type diagcs_decim + integer :: isc !< The start i-index of cell centers within the computational domain + integer :: iec !< The end i-index of cell centers within the computational domain + integer :: jsc !< The start j-index of cell centers within the computational domain + integer :: jec !< The end j-index of cell centers within the computational domain + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + integer :: isg,ieg,jsg,jeg + + type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL + type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi + type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 + + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + real, dimension(:,:,:), pointer :: mask3dTL => null() + real, dimension(:,:,:), pointer :: mask3dBL => null() + real, dimension(:,:,:), pointer :: mask3dCuL => null() + real, dimension(:,:,:), pointer :: mask3dCvL => null() + real, dimension(:,:,:), pointer :: mask3dTi => null() + real, dimension(:,:,:), pointer :: mask3dBi => null() + real, dimension(:,:,:), pointer :: mask3dCui => null() + real, dimension(:,:,:), pointer :: mask3dCvi => null() +end type diagcs_decim + !> The following data type a list of diagnostic fields an their variants, !! as well as variables that control the handling of model output. type, public :: diag_ctrl @@ -182,7 +226,7 @@ module MOM_diag_mediator type(axes_grp) :: axesZi !< A 1-D z-space axis at interfaces type(axes_grp) :: axesZL !< A 1-D z-space axis at layer centers type(axes_grp) :: axesNull !< An axis group for scalars - + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points @@ -196,29 +240,10 @@ module MOM_diag_mediator real, dimension(:,:,:), pointer :: mask3dBi => null() real, dimension(:,:,:), pointer :: mask3dCui => null() real, dimension(:,:,:), pointer :: mask3dCvi => null() + + type(diagcs_decim), dimension(2:MAX_DECIM_LEV) :: decim !< Decimation control container + !!@} - real, dimension(:,:), pointer :: mask2dT_zap2 => null() !< 2D mask array for cell-center points - real, dimension(:,:), pointer :: mask2dBu_zap2 => null() !< 2D mask array for cell-corner points - real, dimension(:,:), pointer :: mask2dCu_zap2 => null() !< 2D mask array for east-face points - real, dimension(:,:), pointer :: mask2dCv_zap2 => null() !< 2D mask array for north-face points - !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) - real, dimension(:,:,:), pointer :: mask3dTL_zap2 => null() - real, dimension(:,:,:), pointer :: mask3dBL_zap2 => null() - real, dimension(:,:,:), pointer :: mask3dCuL_zap2 => null() - real, dimension(:,:,:), pointer :: mask3dCvL_zap2 => null() - real, dimension(:,:,:), pointer :: mask3dTi_zap2 => null() - real, dimension(:,:,:), pointer :: mask3dBi_zap2 => null() - real, dimension(:,:,:), pointer :: mask3dCui_zap2 => null() - real, dimension(:,:,:), pointer :: mask3dCvi_zap2 => null() - !!@} - integer :: isc_zap2 !< The start i-index of cell centers within the computational domain - integer :: iec_zap2 !< The end i-index of cell centers within the computational domain - integer :: jsc_zap2 !< The start j-index of cell centers within the computational domain - integer :: jec_zap2 !< The end j-index of cell centers within the computational domain - integer :: isd_zap2 !< The start i-index of cell centers within the data domain - integer :: ied_zap2 !< The end i-index of cell centers within the data domain - integer :: jsd_zap2 !< The start j-index of cell centers within the data domain - integer :: jed_zap2 !< The end j-index of cell centers within the data domain ! Space for diagnostics is dynamically allocated as it is needed. ! The chunk size is how much the array should grow on each new allocation. @@ -263,12 +288,11 @@ module MOM_diag_mediator end type diag_ctrl + + ! CPU clocks integer :: id_clock_diag_mediator, id_clock_diag_remap, id_clock_diag_grid_updates -logical :: decim_all_diags = .true. -integer :: decim_fac = 2 - contains !> Sets up diagnostics axes @@ -281,60 +305,14 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) !! vertical axes ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh - integer :: i, j, k, nz + integer :: i, j, k, nz, dl real :: zlev(GV%ke), zinter(GV%ke+1) logical :: set_vert - real, dimension(:), pointer :: gridLonT_zap2 =>NULL() - real, dimension(:), pointer :: gridLatT_zap2 =>NULL() + real, dimension(:), pointer :: gridLonT_zap =>NULL() + real, dimension(:), pointer :: gridLatT_zap =>NULL() set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical -if(decim_all_diags) then - - allocate(gridLonT_zap2(G%isg_zap2:G%ieg_zap2)) - allocate(gridLatT_zap2(G%jsg_zap2:G%jeg_zap2)) - - do i=G%isg_zap2,G%ieg_zap2; gridLonT_zap2(i) = G%gridLonT(G%isg+decim_fac*i-2); enddo - do j=G%jsg_zap2,G%jeg_zap2; gridLatT_zap2(j) = G%gridLatT(G%jsg+decim_fac*j-2); enddo - - -! if (G%symmetric) then -! id_xq = diag_axis_init('xq', G%gridLonB_zap2(G%isgB:G%iegB), G%x_axis_units, 'x', & -! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) -! id_yq = diag_axis_init('yq', G%gridLatB_zap2(G%jsgB:G%jegB), G%y_axis_units, 'y', & -! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) -! else - id_xq = diag_axis_init('xq', gridLonT_zap2(G%isg_zap2:G%ieg_zap2), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) - id_yq = diag_axis_init('yq', gridLatT_zap2(G%jsg_zap2:G%jeg_zap2), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) -! endif - id_xh = diag_axis_init('xh', gridLonT_zap2(G%isg_zap2:G%ieg_zap2), G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) - id_yh = diag_axis_init('yh', gridLatT_zap2(G%jsg_zap2:G%jeg_zap2), G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) - - deallocate(gridLonT_zap2) - deallocate(gridLatT_zap2) - -else - if (G%symmetric) then - id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) - else - id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) - endif - id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain) - id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain) -endif - if (set_vert) then nz = GV%ke zinter(1:nz+1) = GV%sInterface(1:nz+1) @@ -350,11 +328,29 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) endif ! Vertical axes for the interfaces and layers - call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, & + call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, 1, & v_cell_method='point', is_interface=.true.) - call define_axes_group(diag_cs, (/ id_zL /), diag_cs%axesZL, & + call define_axes_group(diag_cs, (/ id_zL /), diag_cs%axesZL, 1, & v_cell_method='mean', is_layer=.true.) + ! Horizontal axes for the native grid + + if (G%symmetric) then + id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + endif + id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain) + id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain) + ! Axis groupings for the model layers call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%axesTL, & x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & @@ -392,10 +388,82 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) x_cell_method='point', y_cell_method='mean', is_u_point=.true.) call define_axes_group(diag_cs, (/ id_xh, id_yq /), diag_cs%axesCv1, & x_cell_method='mean', y_cell_method='point', is_v_point=.true.) - ! Axis group for special null axis from diag manager call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull) + !Axes group for native decimated diagnostics + do dl=2,MAX_DECIM_LEV + + if(dl .eq. 2) then + allocate(gridLonT_zap(diag_cs%decim(dl)%isg:diag_cs%decim(dl)%ieg)) + allocate(gridLatT_zap(diag_cs%decim(dl)%jsg:diag_cs%decim(dl)%jeg)) + + do i=diag_cs%decim(dl)%isg,diag_cs%decim(dl)%ieg; gridLonT_zap(i) = G%gridLonT(G%isg+dl*i-2); enddo + do j=diag_cs%decim(dl)%jsg,diag_cs%decim(dl)%jeg; gridLatT_zap(j) = G%gridLatT(G%jsg+dl*j-2); enddo + + + ! if (G%symmetric) then + ! id_xq = diag_axis_init('xq', G%gridLonB_zap2(G%isgB:G%iegB), G%x_axis_units, 'x', & + ! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) + ! id_yq = diag_axis_init('yq', G%gridLatB_zap2(G%jsgB:G%jegB), G%y_axis_units, 'y', & + ! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + ! else + id_xq = diag_axis_init('xq', gridLonT_zap, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) + id_yq = diag_axis_init('yq', gridLatT_zap, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + ! endif + id_xh = diag_axis_init('xh', gridLonT_zap, G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) + id_yh = diag_axis_init('yh', gridLatT_zap, G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + + deallocate(gridLonT_zap) + deallocate(gridLatT_zap) + else + call MOM_error(FATAL, "This decimation level is not supported yet!") + endif + + ! Axis groupings for the model layers + call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%decim(dl)%axesTL, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%decim(dl)%axesBL, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true.) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%decim(dl)%axesCuL, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%decim(dl)%axesCvL, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + + ! Axis groupings for the model interfaces + call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%decim(dl)%axesTi, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%decim(dl)%axesBi, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true.) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%decim(dl)%axesCui, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%decim(dl)%axesCvi, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + + ! Axis groupings for 2-D arrays + call define_axes_group_decim(diag_cs, (/ id_xh, id_yh /), diag_cs%decim(dl)%axesT1, dl, & + x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yq /), diag_cs%decim(dl)%axesB1, dl, & + x_cell_method='point', y_cell_method='point', is_q_point=.true.) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yh /), diag_cs%decim(dl)%axesCu1, dl, & + x_cell_method='point', y_cell_method='mean', is_u_point=.true.) + call define_axes_group_decim(diag_cs, (/ id_xh, id_yq /), diag_cs%decim(dl)%axesCv1, dl, & + x_cell_method='mean', y_cell_method='point', is_v_point=.true.) + + enddo + if (diag_cs%num_diag_coords>0) then allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords)) allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords)) @@ -425,6 +493,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) nz=nz, vertical_coordinate_number=i, & v_cell_method='mean', & is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true.) + call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%remap_axesTL(i), & nz=nz, vertical_coordinate_number=i, & x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & @@ -451,7 +520,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) xyave_axes=diag_cs%remap_axesZL(i)) ! Axes for z interfaces - call define_axes_group(diag_cs, (/ id_zi /), diag_cs%remap_axesZi(i), & + call define_axes_group(diag_cs, (/ id_zi /), diag_cs%remap_axesZi(i),& nz=nz, vertical_coordinate_number=i, & v_cell_method='point', & is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true.) @@ -480,7 +549,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) endif enddo - + call diag_grid_storage_init(diag_CS%diag_grid_temp, G, diag_CS) end subroutine set_axes_info @@ -504,9 +573,7 @@ subroutine set_masks_for_axes(G, diag_cs) nk = axes%nz allocate( axes%mask3d(G%isd:G%ied,G%jsd:G%jed,nk) ) ; axes%mask3d(:,:,:) = 0. call diag_remap_calc_hmask(diag_cs%diag_remap_cs(c), G, axes%mask3d) - if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk, G%isd,G%ied,G%jsd,G%jed,& - G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) - + h_axes => diag_cs%remap_axesTL(c) ! Use the h-point masks to generate the u-, v- and q- masks ! Level/layer u-points in diagnostic coordinate @@ -517,8 +584,6 @@ subroutine set_masks_for_axes(G, diag_cs) do k = 1, nk ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(I,j,k) = 1. enddo ; enddo ; enddo - if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk, G%isdb,G%iedb,G%jsd,G%jed,& - G%isdb_zap2,G%iedb_zap2,G%jsd_zap2,G%jed_zap2) ! Level/layer v-points in diagnostic coordinate axes => diag_cs%remap_axesCvL(c) @@ -528,8 +593,6 @@ subroutine set_masks_for_axes(G, diag_cs) do k = 1, nk ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,J,k) = 1. enddo ; enddo ; enddo - if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk, G%isd,G%ied,G%jsdb,G%jedb,& - G%isd_zap2,G%ied_zap2,G%jsdb_zap2,G%jedb_zap2) ! Level/layer q-points in diagnostic coordinate axes => diag_cs%remap_axesBL(c) @@ -540,8 +603,6 @@ subroutine set_masks_for_axes(G, diag_cs) if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + & h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(I,J,k) = 1. enddo ; enddo ; enddo - if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk, G%isdb,G%iedb,G%jsdb,G%jedb,& - G%isdb_zap2,G%iedb_zap2,G%jsdb_zap2,G%jedb_zap2) ! Interface h-points in diagnostic coordinate (w-point) axes => diag_cs%remap_axesTi(c) @@ -555,8 +616,6 @@ subroutine set_masks_for_axes(G, diag_cs) enddo if (h_axes%mask3d(i,j,nk) > 0.) axes%mask3d(i,J,nk+1) = 1. enddo ; enddo - if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk+1, G%isd,G%ied,G%jsd,G%jed,& - G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) h_axes => diag_cs%remap_axesTi(c) ! Use the w-point masks to generate the u-, v- and q- masks @@ -568,8 +627,6 @@ subroutine set_masks_for_axes(G, diag_cs) do k = 1, nk+1 ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(I,j,k) = 1. enddo ; enddo ; enddo - if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk+1, G%isdb,G%iedb,G%jsd,G%jed,& - G%isdb_zap2,G%iedb_zap2,G%jsd_zap2,G%jed_zap2) ! Interface v-points in diagnostic coordinate axes => diag_cs%remap_axesCvi(c) @@ -579,8 +636,6 @@ subroutine set_masks_for_axes(G, diag_cs) do k = 1, nk+1 ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,J,k) = 1. enddo ; enddo ; enddo - if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk+1, G%isd,G%ied,G%jsdb,G%jedb,& - G%isd_zap2,G%ied_zap2,G%jsdb_zap2,G%jedb_zap2) ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) @@ -591,8 +646,6 @@ subroutine set_masks_for_axes(G, diag_cs) if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + & h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(I,J,k) = 1. enddo ; enddo ; enddo - if(decim_all_diags) call zap2_sample(axes%mask3d, axes%mask3d_zap2, 1,nk+1, G%isdb,G%iedb,G%jsdb,G%jedb,& - G%isdb_zap2,G%iedb_zap2,G%jsdb_zap2,G%jedb_zap2) endif enddo @@ -782,32 +835,145 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num endif endif - axes%mask2d_zap2 => null() +end subroutine define_axes_group + +!> Defines a group of "axes" from list of handles +subroutine define_axes_group_decim(diag_cs, handles, axes, dl, nz, vertical_coordinate_number, & + x_cell_method, y_cell_method, v_cell_method, & + is_h_point, is_q_point, is_u_point, is_v_point, & + is_layer, is_interface, & + is_native, needs_remapping, needs_interpolating, & + xyave_axes) + type(diag_ctrl), target, intent(in) :: diag_cs !< Diagnostics control structure + integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles + type(axes_grp), intent(out) :: axes !< The group of 1D axes + integer, intent(in) :: dl !< Decimation level + integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid + integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate + character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct + !! the "cell_methods" attribute in CF convention + logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point + !! located fields + logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point + !! located fields + logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for + !! u-point located fields + logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for + !! v-point located fields + logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is + !! for a layer vertically-located field. + logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group + !! is for an interface vertically-located field. + logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is + !! for a native model grid. False for any other grid. + logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is + !! for a intensive layer-located field that must + !! be remapped to these axes. Used for rank>2. + logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group + !! is for a sampled interface-located field that must + !! be interpolated to these axes. Used for rank>2. + type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally + !! area-average diagnostics + ! Local variables + integer :: n + + n = size(handles) + if (n<1 .or. n>3) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!") + allocate( axes%handles(n) ) + axes%id = i2s(handles, n) ! Identifying string + axes%rank = n + axes%handles(:) = handles(:) + axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure + if (present(x_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set x_cell_method for rank<2.') + axes%x_cell_method = trim(x_cell_method) + else + axes%x_cell_method = '' + endif + if (present(y_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set y_cell_method for rank<2.') + axes%y_cell_method = trim(y_cell_method) + else + axes%y_cell_method = '' + endif + if (present(v_cell_method)) then + if (axes%rank/=1 .and. axes%rank/=3) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set v_cell_method for rank<>1 or 3.') + axes%v_cell_method = trim(v_cell_method) + else + axes%v_cell_method = '' + endif + axes%decimation_level = dl + if (present(nz)) axes%nz = nz + if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number + if (present(is_h_point)) axes%is_h_point = is_h_point + if (present(is_q_point)) axes%is_q_point = is_q_point + if (present(is_u_point)) axes%is_u_point = is_u_point + if (present(is_v_point)) axes%is_v_point = is_v_point + if (present(is_layer)) axes%is_layer = is_layer + if (present(is_interface)) axes%is_interface = is_interface + if (present(is_native)) axes%is_native = is_native + if (present(needs_remapping)) axes%needs_remapping = needs_remapping + if (present(needs_interpolating)) axes%needs_interpolating = needs_interpolating + if (present(xyave_axes)) axes%xyave_axes => xyave_axes + + ! Setup masks for this axes group + + axes%mask2d => null() if (axes%rank==2) then - if (axes%is_h_point) axes%mask2d_zap2 => diag_cs%mask2dT_zap2 - if (axes%is_u_point) axes%mask2d_zap2 => diag_cs%mask2dCu_zap2 - if (axes%is_v_point) axes%mask2d_zap2 => diag_cs%mask2dCv_zap2 - if (axes%is_q_point) axes%mask2d_zap2 => diag_cs%mask2dBu_zap2 + if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT + if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu + if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv + if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu endif ! A static 3d mask for non-native coordinates can only be setup when a grid is available - axes%mask3d_zap2 => null() + axes%mask3d => null() if (axes%rank==3 .and. axes%is_native) then ! Native variables can/should use the native masks copied into diag_cs if (axes%is_layer) then - if (axes%is_h_point) axes%mask3d_zap2 => diag_cs%mask3dTL_zap2 - if (axes%is_u_point) axes%mask3d_zap2 => diag_cs%mask3dCuL_zap2 - if (axes%is_v_point) axes%mask3d_zap2 => diag_cs%mask3dCvL_zap2 - if (axes%is_q_point) axes%mask3d_zap2 => diag_cs%mask3dBL_zap2 + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL elseif (axes%is_interface) then - if (axes%is_h_point) axes%mask3d_zap2 => diag_cs%mask3dTi_zap2 - if (axes%is_u_point) axes%mask3d_zap2 => diag_cs%mask3dCui_zap2 - if (axes%is_v_point) axes%mask3d_zap2 => diag_cs%mask3dCvi_zap2 - if (axes%is_q_point) axes%mask3d_zap2 => diag_cs%mask3dBi_zap2 + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi endif endif + axes%decim(dl)%mask2d => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%decim(dl)%mask2d => diag_cs%decim(dl)%mask2dT + if (axes%is_u_point) axes%decim(dl)%mask2d => diag_cs%decim(dl)%mask2dCu + if (axes%is_v_point) axes%decim(dl)%mask2d => diag_cs%decim(dl)%mask2dCv + if (axes%is_q_point) axes%decim(dl)%mask2d => diag_cs%decim(dl)%mask2dBu + endif + ! A static 3d mask for non-native coordinates can only be setup when a grid is available + axes%decim(dl)%mask3d => null() + if (axes%rank==3 .and. axes%is_native) then + ! Native variables can/should use the native masks copied into diag_cs + if (axes%is_layer) then + if (axes%is_h_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dTL + if (axes%is_u_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dCuL + if (axes%is_v_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dCvL + if (axes%is_q_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dBL + elseif (axes%is_interface) then + if (axes%is_h_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dTi + if (axes%is_u_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dCui + if (axes%is_v_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dCvi + if (axes%is_q_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dBi + endif + endif -end subroutine define_axes_group +end subroutine define_axes_group_decim !> Set up the array extents for doing diagnostics subroutine set_diag_mediator_grid(G, diag_cs) @@ -818,11 +984,6 @@ subroutine set_diag_mediator_grid(G, diag_cs) diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1) diag_cs%isd = G%isd ; diag_cs%ied = G%ied diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed - - diag_cs%isc_zap2 = G%isc_zap2 - (G%isd_zap2-1) ; diag_cs%iec_zap2 = G%iec_zap2 - (G%isd_zap2-1) - diag_cs%jsc_zap2 = G%jsc_zap2 - (G%jsd_zap2-1) ; diag_cs%jec_zap2 = G%jec_zap2 - (G%jsd_zap2-1) - diag_cs%isd_zap2 = G%isd_zap2 ; diag_cs%ied_zap2 = G%ied_zap2 - diag_cs%jsd_zap2 = G%jsd_zap2 ; diag_cs%jed_zap2 = G%jed_zap2 end subroutine set_diag_mediator_grid @@ -924,17 +1085,16 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. ! Local variables real, dimension(:,:), pointer :: locfield => NULL() + real, dimension(:,:), pointer :: locmask => NULL() + real, dimension(:,:), pointer :: diag_axes_mask2d => NULL() character(len=300) :: mesg logical :: used, is_stat integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, i, j, chksum - !decimation - integer :: isv_dec,iev_dec,jsv_dec,jev_dec - real, dimension(:,:), pointer :: decim_field => NULL() + integer :: isv, iev, jsv, jev, i, j, chksum, dl is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -989,10 +1149,40 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) locfield => field endif - if (decim_all_diags) then - isv_dec = 1 ; iev_dec = (iev-isv+1)/decim_fac - jsv_dec = 1 ; jev_dec = (jev-jsv+1)/decim_fac - allocate(decim_field(isv_dec:iev_dec,jsv_dec:jev_dec)) + if (present(mask)) then + call assert(size(locfield) == size(mask), & + 'post_data_2d_low: mask size mismatch: '//diag%debug_str) + locmask => mask + endif + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then + allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) ) + do j=jsv,jev ; do i=isv,iev + if (field(i,j) == diag_cs%missing_value) then + locfield(i,j) = diag_cs%missing_value + else + locfield(i,j) = field(i,j) * diag%conversion_factor + endif + enddo ; enddo + locfield(isv:iev,jsv:jev) = field(isv:iev,jsv:jev) * diag%conversion_factor + else + locfield => field + endif + + if (present(mask)) then + call assert(size(locfield) == size(mask), & + 'post_data_2d_low: mask size mismatch: '//diag%debug_str) + locmask => mask + endif + + diag_axes_mask2d => diag%axes%mask2d + dl = diag%axes%decimation_level + if (dl > 1) then + call decimate_diag_field(locfield, dl, diag_cs,isv,iev,jsv,jev) + if (present(mask)) then + call decimate_diag_field(locmask, dl) + elseif (associated(diag%axes%decim(dl)%mask2d)) then + diag_axes_mask2d => diag%axes%decim(dl)%mask2d + endif endif if (diag_cs%diag_as_chksum) then @@ -1000,20 +1190,13 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) if (is_root_pe()) then call log_chksum_diag(diag_cs%chksum_diag_doc_unit, diag%debug_str, chksum) endif - elseif (decim_all_diags) then - !Sample the field at the corner of each cell - do j=jsv_dec,jev_dec ; do i=isv_dec,iev_dec - decim_field(i,j) = locfield(isv+decim_fac*i-2,jsv+decim_fac*j-2) - enddo ; enddo - used = send_data(diag%fms_diag_id, decim_field, diag_cs%time_end, & - is_in=isv_dec, js_in=jsv_dec, ie_in=iev_dec, je_in=jev_dec) else if (is_stat) then if (present(mask)) then - call assert(size(locfield) == size(mask), & + call assert(size(locfield) == size(locmask), & 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) !elseif (associated(diag%axes%mask2d)) then ! used = send_data(diag%fms_diag_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) @@ -1023,15 +1206,17 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) endif elseif (diag_cs%ave_enabled) then if (present(mask)) then - call assert(size(locfield) == size(mask), & + call assert(size(locfield) == size(locmask), & 'post_data_2d_low: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=mask) - elseif (associated(diag%axes%mask2d)) then + weight=diag_cs%time_int, rmask=locmask) + elseif (associated(diag_axes_mask2d)) then + call assert(size(locfield) == size(diag_axes_mask2d), & + 'post_data_2d_low: mask2d size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%axes%mask2d) + weight=diag_cs%time_int, rmask=diag_axes_mask2d) else used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & @@ -1175,19 +1360,15 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) ! Local variables real, dimension(:,:,:), pointer :: locfield => NULL() + real, dimension(:,:,:), pointer :: locmask => NULL() + real, dimension(:,:,:), pointer :: diag_axes_mask3d => NULL() character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. logical :: staggered_in_x, staggered_in_y logical :: is_stat integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c - integer :: chksum - !decimation - integer :: isv_zap2,iev_zap2,jsv_zap2,jev_zap2 - real, dimension(:,:,:), pointer :: zap2_field => NULL() - real, dimension(:,:,:), pointer :: zap2_mask => NULL() - real, dimension(:,:,:), pointer :: locmask => NULL() - real, dimension(:,:,:), pointer :: diag_axes_mask3d => NULL() + integer :: chksum, dl is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1263,162 +1444,63 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) call assert(size(locfield) == size(mask), & 'post_data_3d_low: mask size mismatch: '//diag%debug_str) locmask => mask - endif - - diag_axes_mask3d => diag%axes%mask3d + endif - if (decim_all_diags) then - diag_axes_mask3d => diag%axes%mask3d_zap2 - - isv_zap2 = diag_cs%isc_zap2 ; iev_zap2 = diag_cs%iec_zap2 - jsv_zap2 = diag_cs%jsc_zap2 ; jev_zap2 = diag_cs%jec_zap2 + diag_axes_mask3d => diag%axes%mask3d + dl = diag%axes%decimation_level + if (dl > 1) then + call decimate_diag_field(locfield, dl, diag_cs,isv,iev,jsv,jev) + if (present(mask)) then + call decimate_diag_field(locmask, dl) + elseif (associated(diag%axes%decim(dl)%mask3d)) then + diag_axes_mask3d => diag%axes%decim(dl)%mask3d + endif + endif - if ( size(field,1) == dszi ) then - isv_zap2 = diag_cs%isc_zap2 ; iev_zap2 = diag_cs%iec_zap2 ! Data domain - elseif ( size(field,1) == dszi + 1 ) then - isv_zap2 = diag_cs%isc_zap2 ; iev_zap2 = diag_cs%iec_zap2+1 ! Symmetric data domain - elseif ( size(field,1) == cszi) then - isv_zap2 = 1 ; iev_zap2 = (diag_cs%iec_zap2-diag_cs%isc_zap2) +1 ! Computational domain - elseif ( size(field,1) == cszi + 1 ) then - isv_zap2 = 1 ; iev_zap2 = (diag_cs%iec_zap2-diag_cs%isc_zap2) +2 ! Symmetric computational domain - else - write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& - "does not match one of ", cszi, cszi+1, dszi, dszi+1 - call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) - endif - if ( size(field,2) == dszj ) then - jsv_zap2 = diag_cs%jsc_zap2 ; jev_zap2 = diag_cs%jec_zap2 ! Data domain - elseif ( size(field,2) == dszj + 1 ) then - jsv_zap2 = diag_cs%jsc_zap2 ; jev_zap2 = diag_cs%jec_zap2+1 ! Symmetric data domain - elseif ( size(field,2) == cszj) then - jsv_zap2 = 1 ; jev_zap2 = (diag_cs%jec_zap2-diag_cs%jsc_zap2) +1 ! Computational domain - elseif ( size(field,2) == cszj + 1 ) then - jsv_zap2 = 1 ; jev_zap2 = (diag_cs%jec_zap2-diag_cs%jsc_zap2) +2 ! Symmetric computational domain + if (diag_cs%diag_as_chksum) then + chksum = chksum_general(locfield) + if (is_root_pe()) then + call log_chksum_diag(diag_cs%chksum_diag_doc_unit, diag%debug_str, chksum) + endif + else + if (is_stat) then + if (present(mask)) then + call assert(size(locfield) == size(locmask), & + 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) + used = send_data(diag%fms_diag_id, locfield, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) + !elseif (associated(diag%axes%mask2d)) then + ! used = send_data(diag%fms_diag_id, locfield, & + ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) else - write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& - "does not match one of ", cszj, cszj+1, dszj, dszj+1 - call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) + used = send_data(diag%fms_diag_id, locfield, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif - !Sample the field at the corner of each cell - call zap2_sample(locfield, zap2_field, ks,ke) - !point locfield to the decimated field - locfield => zap2_field - isv=isv_zap2; iev=iev_zap2; jsv=jsv_zap2; jev=jev_zap2 - - !Decimated mask + elseif (diag_cs%ave_enabled) then if (present(mask)) then - call zap2_sample(mask, zap2_mask, ks,ke) - locmask => zap2_mask - endif - - endif - - if (diag%fms_diag_id>0) then - if (diag_cs%diag_as_chksum) then - chksum = chksum_general(locfield) - if (is_root_pe()) then - call log_chksum_diag(diag_cs%chksum_diag_doc_unit, diag%debug_str, chksum) - endif - !Decimation test -! elseif (decim_all_diags) then -! !Sample the field at the corner of each cell -! do k=ks,ke ; do j=jsv_dec,jev_dec ; do i=isv_dec,iev_dec -! decim_field(i,j,k) = locfield(isv+decim_fac*i-2,jsv+decim_fac*j-2,k) -! enddo ; enddo ; enddo -! used = send_data(diag%fms_diag_id, decim_field, diag_cs%time_end, & -! is_in=isv_dec, js_in=jsv_dec, ie_in=iev_dec, je_in=jev_dec) - else - if (is_stat) then - if (present(mask)) then - call assert(size(locfield) == size(locmask), & - 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) - !elseif (associated(diag%axes%mask3d)) then - ! used = send_data(diag_field_id, locfield, & - ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask3d) - else - used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) - endif - elseif (diag_cs%ave_enabled) then - if (present(mask)) then - call assert(size(locfield) == size(locmask), & - 'post_data_3d_low: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=locmask) - elseif (associated(diag_axes_mask3d)) then - call assert(size(locfield) == size(diag_axes_mask3d), & + call assert(size(locfield) == size(locmask), & + 'post_data_3d_low: mask size mismatch: '//diag%debug_str) + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & + weight=diag_cs%time_int, rmask=locmask) + elseif (associated(diag_axes_mask3d)) then + call assert(size(locfield) == size(diag_axes_mask3d), & 'post_data_3d_low: mask3d size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag_axes_mask3d) - else - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int) - endif + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & + weight=diag_cs%time_int, rmask=diag_axes_mask3d) + else + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & + weight=diag_cs%time_int) endif endif endif - if (diag%fms_xyave_diag_id>0) then - call post_xy_average(diag_cs, diag, locfield) - endif - - !Decimation test - if (diag%decimate_diag_id>0) then - call post_decimated_data(diag_cs, diag, locfield, decimation_factor=2) - endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & deallocate( locfield ) end subroutine post_data_3d_low - -!> Post the horizontally area-averaged diagnostic -subroutine post_decimated_data(diag_cs, diag, field, decimation_factor) - type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics mediator control structure - type(diag_type), intent(in) :: diag !< This diagnostic - real, target, intent(in) :: field(:,:,:) !< Diagnostic field - integer, intent(in) :: decimation_factor !< The factor by which to decimate the diag output field - ! Local variable - real, dimension(size(field,3)) :: decimated_field - logical :: used - integer :: nz, remap_nz, coord - -! if (.not. diag_cs%ave_enabled) then -! return -! endif - - if (diag%axes%is_native) then - call horizontally_decimate_diag_field(diag_cs%G, diag_cs%h, & - diag%axes%is_layer, diag%v_extensive, & - diag_cs%missing_value, decimation_factor, field, decimated_field) - else - nz = size(field, 3) - coord = diag%axes%vertical_coordinate_number - remap_nz = diag_cs%diag_remap_cs(coord)%nz - - call assert(diag_cs%diag_remap_cs(coord)%initialized, & - 'post_xy_average: remap_cs not initialized.') - - call assert(IMPLIES(diag%axes%is_layer, nz == remap_nz), & - 'post_xy_average: layer field dimension mismatch.') - call assert(IMPLIES(.not. diag%axes%is_layer, nz == remap_nz+1), & - 'post_xy_average: interface field dimension mismatch.') - - call horizontally_decimate_diag_field(diag_cs%G, diag_cs%diag_remap_cs(coord)%h, & - diag%axes%is_layer, diag%v_extensive, & - diag_cs%missing_value, decimation_factor, field, decimated_field) - endif - - used = send_data(diag%decimate_diag_id, decimated_field, diag_cs%time_end, & - weight=diag_cs%time_int) - -end subroutine post_decimated_data - !> Post the horizontally area-averaged diagnostic subroutine post_xy_average(diag_cs, diag, field) type(diag_type), intent(in) :: diag !< This diagnostic @@ -1562,36 +1644,35 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time type(diag_ctrl), pointer :: diag_cs => NULL() type(axes_grp), pointer :: remap_axes => null() type(axes_grp), pointer :: axes => null() - integer :: dm_id, i + integer :: dm_id, i, dl character(len=256) :: new_module_name logical :: active axes => axes_in MOM_missing_value = axes%diag_cs%missing_value if (present(missing_value)) MOM_missing_value = missing_value - - diag_cs => axes%diag_cs - dm_id = -1 - !Reroute the axes for decimated diagnostics - if (decim_all_diags) then - if ((axes_in%id == diag_cs%axesTL%id)) then - axes => diag_cs%axesTL - elseif (axes_in%id == diag_cs%axesBL%id) then - axes => diag_cs%axesBL - elseif (axes_in%id == diag_cs%axesCuL%id ) then - axes => diag_cs%axesCuL - elseif (axes_in%id == diag_cs%axesCvL%id) then - axes => diag_cs%axesCvL - elseif (axes_in%id == diag_cs%axesTi%id) then - axes => diag_cs%axesTi - elseif (axes_in%id == diag_cs%axesBi%id) then - axes => diag_cs%axesBi - elseif (axes_in%id == diag_cs%axesCui%id ) then - axes => diag_cs%axesCui - elseif (axes_in%id == diag_cs%axesCvi%id) then - axes => diag_cs%axesCvi - endif + + diag_cs => axes%diag_cs + dm_id = -1 + + if (axes_in%id == diag_cs%axesTL%id) then + axes => diag_cs%axesTL + elseif (axes_in%id == diag_cs%axesBL%id) then + axes => diag_cs%axesBL + elseif (axes_in%id == diag_cs%axesCuL%id ) then + axes => diag_cs%axesCuL + elseif (axes_in%id == diag_cs%axesCvL%id) then + axes => diag_cs%axesCvL + elseif (axes_in%id == diag_cs%axesTi%id) then + axes => diag_cs%axesTi + elseif (axes_in%id == diag_cs%axesBi%id) then + axes => diag_cs%axesBi + elseif (axes_in%id == diag_cs%axesCui%id ) then + axes => diag_cs%axesCui + elseif (axes_in%id == diag_cs%axesCvi%id) then + axes => diag_cs%axesCvi endif + ! Register the native diagnostic active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & @@ -1604,30 +1685,80 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time y_cell_method=y_cell_method, v_cell_method=v_cell_method, & conversion=conversion, v_extensive=v_extensive) + do dl=2,MAX_DECIM_LEV + new_module_name = trim(module_name)//'_d2' + + if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then + axes => null() + if (axes_in%id == diag_cs%axesTL%id) then + axes => diag_cs%decim(dl)%axesTL + elseif (axes_in%id == diag_cs%axesBL%id) then + axes => diag_cs%decim(dl)%axesBL + elseif (axes_in%id == diag_cs%axesCuL%id ) then + axes => diag_cs%decim(dl)%axesCuL + elseif (axes_in%id == diag_cs%axesCvL%id) then + axes => diag_cs%decim(dl)%axesCvL + elseif (axes_in%id == diag_cs%axesTi%id) then + axes => diag_cs%decim(dl)%axesTi + elseif (axes_in%id == diag_cs%axesBi%id) then + axes => diag_cs%decim(dl)%axesBi + elseif (axes_in%id == diag_cs%axesCui%id ) then + axes => diag_cs%decim(dl)%axesCui + elseif (axes_in%id == diag_cs%axesCvi%id) then + axes => diag_cs%decim(dl)%axesCvi + elseif (axes_in%id == diag_cs%axesT1%id) then + axes => diag_cs%decim(dl)%axesT1 + elseif (axes_in%id == diag_cs%axesB1%id) then + axes => diag_cs%decim(dl)%axesB1 + elseif (axes_in%id == diag_cs%axesCu1%id ) then + axes => diag_cs%decim(dl)%axesCu1 + elseif (axes_in%id == diag_cs%axesCv1%id) then + axes => diag_cs%decim(dl)%axesCv1 + else + !Niki: Should we worry about these, e.g., diag_to_Z_CS? + call MOM_error(WARNING,"register_diag_field: Could not find a proper axes for " & + //trim( new_module_name)//"-"//trim(field_name)) + endif + endif + ! Register the native diagnostic + if (associated(axes)) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + endif + enddo ! For each diagnostic coordinate register the diagnostic again under a different module name do i=1,diag_cs%num_diag_coords new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix) ! Register diagnostics remapped to z vertical coordinate - if (axes%rank == 3) then + if (axes_in%rank == 3) then remap_axes => null() - if ((axes%id == diag_cs%axesTL%id)) then + if ((axes_in%id == diag_cs%axesTL%id)) then remap_axes => diag_cs%remap_axesTL(i) - elseif (axes%id == diag_cs%axesBL%id) then + elseif (axes_in%id == diag_cs%axesBL%id) then remap_axes => diag_cs%remap_axesBL(i) - elseif (axes%id == diag_cs%axesCuL%id ) then + elseif (axes_in%id == diag_cs%axesCuL%id ) then remap_axes => diag_cs%remap_axesCuL(i) - elseif (axes%id == diag_cs%axesCvL%id) then + elseif (axes_in%id == diag_cs%axesCvL%id) then remap_axes => diag_cs%remap_axesCvL(i) - elseif (axes%id == diag_cs%axesTi%id) then + elseif (axes_in%id == diag_cs%axesTi%id) then remap_axes => diag_cs%remap_axesTi(i) - elseif (axes%id == diag_cs%axesBi%id) then + elseif (axes_in%id == diag_cs%axesBi%id) then remap_axes => diag_cs%remap_axesBi(i) - elseif (axes%id == diag_cs%axesCui%id ) then + elseif (axes_in%id == diag_cs%axesCui%id ) then remap_axes => diag_cs%remap_axesCui(i) - elseif (axes%id == diag_cs%axesCvi%id) then + elseif (axes_in%id == diag_cs%axesCvi%id) then remap_axes => diag_cs%remap_axesCvi(i) endif + ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will ! always exist but in the mean-time we have to do this check: ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set') @@ -2504,6 +2635,15 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) diag_cs%isd = G%isd ; diag_cs%ied = G%ied diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + !Decimation indices (should be generalized to arbitrary dl) + diag_cs%decim(2)%isc = G%isc_zap2 - (G%isd_zap2-1) ; diag_cs%decim(2)%iec = G%iec_zap2 - (G%isd_zap2-1) + diag_cs%decim(2)%jsc = G%jsc_zap2 - (G%jsd_zap2-1) ; diag_cs%decim(2)%jec = G%jec_zap2 - (G%jsd_zap2-1) + diag_cs%decim(2)%isd = G%isd_zap2 ; diag_cs%decim(2)%ied = G%ied_zap2 + diag_cs%decim(2)%jsd = G%jsd_zap2 ; diag_cs%decim(2)%jed = G%jed_zap2 + diag_cs%decim(2)%isg = G%isg_zap2 ; diag_cs%decim(2)%ieg = G%ieg_zap2 + diag_cs%decim(2)%jsg = G%jsg_zap2 ; diag_cs%decim(2)%jeg = G%jeg_zap2 + + ! Initialze available diagnostic log file if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then write(this_pe,'(i6.6)') PE_here() @@ -2665,9 +2805,6 @@ subroutine diag_masks_set(G, nz, diag_cs) ! Local variables integer :: k - if(decim_all_diags) then - call zap2_diag_masks_set(G, nz, diag_cs) - endif ! 2d masks point to the model masks since they are identical diag_cs%mask2dT => G%mask2dT diag_cs%mask2dBu => G%mask2dBu @@ -2697,127 +2834,10 @@ subroutine diag_masks_set(G, nz, diag_cs) diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:) enddo -end subroutine diag_masks_set - -subroutine zap2_sample_3d(field_in, field_out,ks,ke, is,ie,js,je, is2,ie2,js2,je2) - integer , intent(in) :: ks,ke, is,ie,js,je, is2,ie2,js2,je2 - real, dimension(is:,js:,1:) ,intent(in) :: field_in - real, dimension(:,:,:) , pointer :: field_out - integer :: k,i,j,ii,jj - - allocate(field_out(is2:ie2,js2:je2,ks:ke)) - do k= ks,ke ; do j=js2,je2 ; do i=is2,ie2 - ii = is+2*(i-is2) - jj = js+2*(j-js2) - field_out(i,j,k) = field_in(ii,jj,k) - enddo; enddo; enddo - -end subroutine zap2_sample_3d - -subroutine zap2_sample_2d(field_in, field_out, is,ie,js,je, is2,ie2,js2,je2) - integer , intent(in) :: is,ie,js,je, is2,ie2,js2,je2 - real, dimension(is:,js:) ,intent(in) :: field_in - real, dimension(:,:) , pointer :: field_out - integer :: i,j,ii,jj - - allocate(field_out(is2:ie2,js2:je2)) - do j=js2,je2 ; do i=is2,ie2 - ii = is+2*(i-is2) - jj = js+2*(j-js2) - field_out(i,j) = field_in(ii,jj) - enddo; enddo - -end subroutine zap2_sample_2d - -subroutine zap2_sample_3d0(field_in, field_out,ks,ke) - integer , intent(in) :: ks,ke - real, dimension(:,:,:) ,intent(in) :: field_in - real, dimension(:,:,:) , pointer :: field_out - integer :: k,i,j,ii,jj, is_in,js_in, is2,ie2,js2,je2 - - is_in=1; js_in=1 - is2=1; ie2=size(field_in,1)/2 - js2=1; je2=size(field_in,2)/2 - - allocate(field_out(is2:ie2,js2:je2,ks:ke)) - - do k= ks,ke ; do j=js2,je2 ; do i=is2,ie2 - ii = is_in+2*(i-is2) - jj = js_in+2*(j-js2) - field_out(i,j,k) = field_in(ii,jj,k) - enddo; enddo; enddo - -end subroutine zap2_sample_3d0 - -subroutine zap2_sample_2d0(field_in, field_out) - real, dimension(:,:) ,intent(in) :: field_in - real, dimension(:,:) , pointer :: field_out - integer :: i,j,ii,jj, is_in,js_in, is2,ie2,js2,je2 - - is_in=1; js_in=1 - is2=1; ie2=size(field_in,1)/2 - js2=1; je2=size(field_in,2)/2 - - allocate(field_out(is2:ie2,js2:je2)) - - do j=js2,je2 ; do i=is2,ie2 - ii = is_in+2*(i-is2) - jj = js_in+2*(j-js2) - field_out(i,j) = field_in(ii,jj) - enddo; enddo + call decimate_diag_masks_set(G, nz, diag_cs) -end subroutine zap2_sample_2d0 - -subroutine zap2_diag_masks_set(G, nz, diag_cs) - type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. - integer, intent(in) :: nz !< The number of layers in the model's native grid. - type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables - !! used for diagnostics - ! Local variables - integer :: i,j,k,ii,jj - -!print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec -!print*,'coarse c extents ',G%isc_zap2,G%iec_zap2,G%jsc_zap2,G%jec_zap2 -!print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed -!print*,'coarse d extents ',G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2 -! original c extents 5 52 5 64 -! coarse c extents 5 28 5 34 -! original d extents 1 56 1 68 -! coarse d extents 1 32 1 38 - diag_cs%isc_zap2 = G%isc_zap2 - (G%isd_zap2-1) ; diag_cs%iec_zap2 = G%iec_zap2 - (G%isd_zap2-1) - diag_cs%jsc_zap2 = G%jsc_zap2 - (G%jsd_zap2-1) ; diag_cs%jec_zap2 = G%jec_zap2 - (G%jsd_zap2-1) - diag_cs%isd_zap2 = G%isd_zap2 ; diag_cs%ied_zap2 = G%ied_zap2 - diag_cs%jsd_zap2 = G%jsd_zap2 ; diag_cs%jed_zap2 = G%jed_zap2 - - ! 2d masks point to the model masks since they are identical - call zap2_sample(G%mask2dT, diag_cs%mask2dT_zap2 ,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) - call zap2_sample(G%mask2dBu,diag_cs%mask2dBu_zap2,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) - call zap2_sample(G%mask2dCu,diag_cs%mask2dCu_zap2,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) - call zap2_sample(G%mask2dCv,diag_cs%mask2dCv_zap2,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) - ! 3d native masks are needed by diag_manager but the native variables - ! can only be masked 2d - for ocean points, all layers exists. - allocate(diag_cs%mask3dTL_zap2(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) - allocate(diag_cs%mask3dBL_zap2(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz)) - allocate(diag_cs%mask3dCuL_zap2(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) - allocate(diag_cs%mask3dCvL_zap2(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz)) - do k=1,nz - diag_cs%mask3dTL_zap2(:,:,k) = diag_cs%mask2dT_zap2(:,:) - diag_cs%mask3dBL_zap2(:,:,k) = diag_cs%mask2dBu_zap2(:,:) - diag_cs%mask3dCuL_zap2(:,:,k) = diag_cs%mask2dCu_zap2(:,:) - diag_cs%mask3dCvL_zap2(:,:,k) = diag_cs%mask2dCv_zap2(:,:) - enddo - allocate(diag_cs%mask3dTi_zap2(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz+1)) - allocate(diag_cs%mask3dBi_zap2(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz+1)) - allocate(diag_cs%mask3dCui_zap2(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2,1:nz+1)) - allocate(diag_cs%mask3dCvi_zap2(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz+1)) - do k=1,nz+1 - diag_cs%mask3dTi_zap2(:,:,k) = diag_cs%mask2dT_zap2(:,:) - diag_cs%mask3dBi_zap2(:,:,k) = diag_cs%mask2dBu_zap2(:,:) - diag_cs%mask3dCui_zap2(:,:,k) = diag_cs%mask2dCu_zap2(:,:) - diag_cs%mask3dCvi_zap2(:,:,k) = diag_cs%mask2dCv_zap2(:,:) - enddo +end subroutine diag_masks_set -end subroutine zap2_diag_masks_set subroutine diag_mediator_close_registration(diag_CS) type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output @@ -2856,14 +2876,20 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) enddo call diag_grid_storage_end(diag_cs%diag_grid_temp) - deallocate(diag_cs%mask3dTL) - deallocate(diag_cs%mask3dBL) - deallocate(diag_cs%mask3dCuL) - deallocate(diag_cs%mask3dCvL) - deallocate(diag_cs%mask3dTi) - deallocate(diag_cs%mask3dBi) - deallocate(diag_cs%mask3dCui) - deallocate(diag_cs%mask3dCvi) + do i=2,MAX_DECIM_LEV + deallocate(diag_cs%decim(i)%mask2dT) + deallocate(diag_cs%decim(i)%mask2dBu) + deallocate(diag_cs%decim(i)%mask2dCu) + deallocate(diag_cs%decim(i)%mask2dCv) + deallocate(diag_cs%decim(i)%mask3dTL) + deallocate(diag_cs%decim(i)%mask3dBL) + deallocate(diag_cs%decim(i)%mask3dCuL) + deallocate(diag_cs%decim(i)%mask3dCvL) + deallocate(diag_cs%decim(i)%mask3dTi) + deallocate(diag_cs%decim(i)%mask3dBi) + deallocate(diag_cs%decim(i)%mask3dCui) + deallocate(diag_cs%decim(i)%mask3dCvi) + enddo #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) deallocate(diag_cs%h_old) @@ -3120,4 +3146,269 @@ subroutine diag_grid_storage_end(grid_storage) deallocate(grid_storage%diag_grids) end subroutine diag_grid_storage_end +subroutine zap2_sample_3d(field_in, field_out,ks,ke, is,ie,js,je, is2,ie2,js2,je2) + integer , intent(in) :: ks,ke, is,ie,js,je, is2,ie2,js2,je2 + real, dimension(is:,js:,1:) ,intent(in) :: field_in + real, dimension(:,:,:) , pointer :: field_out + integer :: k,i,j,ii,jj + + allocate(field_out(is2:ie2,js2:je2,ks:ke)) + do k= ks,ke ; do j=js2,je2 ; do i=is2,ie2 + ii = is+2*(i-is2) + jj = js+2*(j-js2) + field_out(i,j,k) = field_in(ii,jj,k) + enddo; enddo; enddo + +end subroutine zap2_sample_3d + +subroutine zap2_sample_2d(field_in, field_out, is,ie,js,je, is2,ie2,js2,je2) + integer , intent(in) :: is,ie,js,je, is2,ie2,js2,je2 + real, dimension(is:,js:) ,intent(in) :: field_in + real, dimension(:,:) , pointer :: field_out + integer :: i,j,ii,jj + + allocate(field_out(is2:ie2,js2:je2)) + do j=js2,je2 ; do i=is2,ie2 + ii = is+2*(i-is2) + jj = js+2*(j-js2) + field_out(i,j) = field_in(ii,jj) + enddo; enddo + +end subroutine zap2_sample_2d + +subroutine zap2_sample_3d0(field_in, field_out,ks,ke) + integer , intent(in) :: ks,ke + real, dimension(:,:,:) ,intent(in) :: field_in + real, dimension(:,:,:) , pointer :: field_out + integer :: k,i,j,ii,jj, is_in,js_in, is2,ie2,js2,je2 + + is_in=1; js_in=1 + is2=1; ie2=size(field_in,1)/2 + js2=1; je2=size(field_in,2)/2 + + allocate(field_out(is2:ie2,js2:je2,ks:ke)) + + do k= ks,ke ; do j=js2,je2 ; do i=is2,ie2 + ii = is_in+2*(i-is2) + jj = js_in+2*(j-js2) + field_out(i,j,k) = field_in(ii,jj,k) + enddo; enddo; enddo + +end subroutine zap2_sample_3d0 + +subroutine zap2_sample_2d0(field_in, field_out) + real, dimension(:,:) ,intent(in) :: field_in + real, dimension(:,:) , pointer :: field_out + integer :: i,j,ii,jj, is_in,js_in, is2,ie2,js2,je2 + + is_in=1; js_in=1 + is2=1; ie2=size(field_in,1)/2 + js2=1; je2=size(field_in,2)/2 + + allocate(field_out(is2:ie2,js2:je2)) + + do j=js2,je2 ; do i=is2,ie2 + ii = is_in+2*(i-is2) + jj = js_in+2*(j-js2) + field_out(i,j) = field_in(ii,jj) + enddo; enddo + +end subroutine zap2_sample_2d0 + + +subroutine decimate_diag_masks_set(G, nz, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + integer, intent(in) :: nz !< The number of layers in the model's native grid. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: i,j,k,ii,jj,dl + +!print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec +!print*,'coarse c extents ',G%isc_zap2,G%iec_zap2,G%jsc_zap2,G%jec_zap2 +!print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed +!print*,'coarse d extents ',G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2 +! original c extents 5 52 5 64 +! coarse c extents 5 28 5 34 +! original d extents 1 56 1 68 +! coarse d extents 1 32 1 38 + + do dl=2,MAX_DECIM_LEV + ! 2d masks + allocate(diag_cs%decim(dl)%mask2dT(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2)) + allocate(diag_cs%decim(dl)%mask2dBu(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2)) + allocate(diag_cs%decim(dl)%mask2dCu(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2)) + allocate(diag_cs%decim(dl)%mask2dCv(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2)) + call zap2_sample(G%mask2dT, diag_cs%decim(dl)%mask2dT ,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + call zap2_sample(G%mask2dBu,diag_cs%decim(dl)%mask2dBu,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + call zap2_sample(G%mask2dCu,diag_cs%decim(dl)%mask2dCu,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + call zap2_sample(G%mask2dCv,diag_cs%decim(dl)%mask2dCv,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + ! 3d native masks are needed by diag_manager but the native variables + ! can only be masked 2d - for ocean points, all layers exists. + allocate(diag_cs%decim(dl)%mask3dTL(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) + allocate(diag_cs%decim(dl)%mask3dBL(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz)) + allocate(diag_cs%decim(dl)%mask3dCuL(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) + allocate(diag_cs%decim(dl)%mask3dCvL(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz)) + do k=1,nz + diag_cs%decim(dl)%mask3dTL(:,:,k) = diag_cs%decim(dl)%mask2dT(:,:) + diag_cs%decim(dl)%mask3dBL(:,:,k) = diag_cs%decim(dl)%mask2dBu(:,:) + diag_cs%decim(dl)%mask3dCuL(:,:,k) = diag_cs%decim(dl)%mask2dCu(:,:) + diag_cs%decim(dl)%mask3dCvL(:,:,k) = diag_cs%decim(dl)%mask2dCv(:,:) + enddo + allocate(diag_cs%decim(dl)%mask3dTi(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz+1)) + allocate(diag_cs%decim(dl)%mask3dBi(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz+1)) + allocate(diag_cs%decim(dl)%mask3dCui(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2,1:nz+1)) + allocate(diag_cs%decim(dl)%mask3dCvi(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz+1)) + do k=1,nz+1 + diag_cs%decim(dl)%mask3dTi(:,:,k) = diag_cs%decim(dl)%mask2dT(:,:) + diag_cs%decim(dl)%mask3dBi(:,:,k) = diag_cs%decim(dl)%mask2dBu(:,:) + diag_cs%decim(dl)%mask3dCui(:,:,k) = diag_cs%decim(dl)%mask2dCu(:,:) + diag_cs%decim(dl)%mask3dCvi(:,:,k) = diag_cs%decim(dl)%mask2dCv(:,:) + enddo + enddo +end subroutine decimate_diag_masks_set + + + +subroutine decimate_diag_field_2d(field, dl, diag_cs, isv,iev,jsv,jev) + real, pointer :: field(:,:) !< 2-d array being offered for output or averaging + integer, intent(in) :: dl !< integer decimation level + type(diag_ctrl),optional, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + integer, optional, intent(inout) ::isv,iev,jsv,jev + ! Local variables + integer :: dszi,cszi,dszj,cszj + character(len=300) :: mesg + + call decimate_sample(field, dl) + + if(present(diag_cs))then + cszi = diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc +1 ; dszi = diag_cs%decim(dl)%ied-diag_cs%decim(dl)%isd +1 + cszj = diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc +1 ; dszj = diag_cs%decim(dl)%jed-diag_cs%decim(dl)%jsd +1 + + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec + jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec + + if ( size(field,1) == dszi ) then + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +1 ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) + endif + if ( size(field,2) == dszj ) then + jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec+1 ! Symmetric data domain + elseif ( size(field,2) == cszj) then + jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +1 ! Computational domain + elseif ( size(field,2) == cszj + 1 ) then + jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) + endif + endif + +end subroutine decimate_diag_field_2d + +subroutine decimate_diag_field_3d(field, dl, diag_cs, isv,iev,jsv,jev) + real, pointer :: field(:,:,:) !< 3-d array being offered for output or averaging + integer, intent(in) :: dl !< integer decimation level + type(diag_ctrl),optional, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + integer, optional, intent(inout) ::isv,iev,jsv,jev + ! Local variables + integer :: dszi,cszi,dszj,cszj + character(len=300) :: mesg + + call decimate_sample(field, dl) + + if(present(diag_cs))then + cszi = diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc +1 ; dszi = diag_cs%decim(dl)%ied-diag_cs%decim(dl)%isd +1 + cszj = diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc +1 ; dszj = diag_cs%decim(dl)%jed-diag_cs%decim(dl)%jsd +1 + + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec + jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec + + if ( size(field,1) == dszi ) then + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +1 ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) + endif + if ( size(field,2) == dszj ) then + jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec+1 ! Symmetric data domain + elseif ( size(field,2) == cszj) then + jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +1 ! Computational domain + elseif ( size(field,2) == cszj + 1 ) then + jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) + endif + endif + +end subroutine decimate_diag_field_3d + + +subroutine decimate_sample_3d(field_in, level) + integer , intent(in) :: level + real, dimension(:,:,:) , pointer :: field_in, field_out + integer :: i,j,ii,jj,is,js + integer :: isl,iel,jsl,jel + integer :: k,ks,ke + ! is = lbound(field_in,1) ; ie = ubound(field_in,1) + ! js = lbound(field_in,2) ; je = ubound(field_in,2) + !Always start from the first element + is=1 + js=1 + ks = lbound(field_in,3) ; ke = ubound(field_in,3) + isl=1; iel=size(field_in,1)/level + jsl=1; jel=size(field_in,2)/level + allocate(field_out(isl:iel,jsl:jel,ks:ke)) + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + ii = is+level*(i-isl) + jj = js+level*(j-jsl) + field_out(i,j,k) = field_in(ii,jj,k) + enddo; enddo; enddo + field_in => field_out +end subroutine decimate_sample_3d + +subroutine decimate_sample_2d(field_in, level) + integer , intent(in) :: level + real, dimension(:,:) , pointer :: field_in, field_out + integer :: i,j,ii,jj,is,js + integer :: isl,iel,jsl,jel + ! is = lbound(field_in,1) ; ie = ubound(field_in,1) + ! js = lbound(field_in,2) ; je = ubound(field_in,2) + !Always start from the first element + is=1 + js=1 + isl=1; iel=size(field_in,1)/level + jsl=1; jel=size(field_in,2)/level + allocate(field_out(isl:iel,jsl:jel)) + do j=jsl,jel ; do i=isl,iel + ii = is+level*(i-isl) + jj = js+level*(j-jsl) + field_out(i,j) = field_in(ii,jj) + enddo; enddo + field_in => field_out +end subroutine decimate_sample_2d + end module MOM_diag_mediator diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 4022318e69..737e7a3fbf 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -54,7 +54,6 @@ module MOM_diag_remap public vertically_reintegrate_diag_field public vertically_interpolate_diag_field public horizontally_average_diag_field -public horizontally_decimate_diag_field !> Represents remapping of diagnostics to a particular vertical coordinate. !! @@ -705,20 +704,4 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, end subroutine horizontally_average_diag_field -!> Horizontally decimate field -subroutine horizontally_decimate_diag_field(G, h, & - is_layer, is_extensive, & - missing_value, decimation_factor, field, decimated_field) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses - logical, intent(in) :: is_layer !< True if the z-axis location is at h points - logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) - real, intent(in) :: missing_value !< A missing_value to assign land/vanished points - integer, intent(in) :: decimation_factor !< The factor by which to decimate the diag output field - real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped - real, dimension(:), intent(inout) :: decimated_field !< Field argument horizontally averaged - ! Local variables - -end subroutine horizontally_decimate_diag_field - end module MOM_diag_remap From 8802dd25891bcbb24a4ec3bb36eca569a2be79e1 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 27 Sep 2018 19:02:01 -0400 Subject: [PATCH 05/18] Diag decimation prototype, requesting in diag_table - This update allows using non-native and decimated diagnostics as well as their combinations. E.g., it works for a diag_table as shown below. - I have to validate with a full diagnostics validate individual diagnostics make sense study the memory foot print to make sure the decimate rotuines have no leak (due to extensive use of fortran pointers) - Also we have to work on an averaging rather than sub-sampling of the fields as is done in this prototype OM5p5 1900 1 1 0 0 0 "ocean_hour", 0, "days", 1, "days", "time" "ocean_model", "tos", "tos", "ocean_hour", "all", "mean", "none",2 "ocean_model", "thetao", "thetao", "ocean_hour", "all", "mean", "none",2 "ocean_model", "umo", "umo", "ocean_hour", "all", "mean", "none",2 "ocean_model", "vmo", "vmo", "ocean_hour", "all", "mean", "none",2 "ocean_model", "volcello", "volcello", "ocean_hour", "all", "mean", "none",2 # Cell measure for 3d data "ocean_hour_d2", 0, "days", 1, "days", "time" "ocean_model_d2", "tos", "tos", "ocean_hour_d2", "all", "mean", "none",2 "ocean_model_d2", "thetao", "thetao", "ocean_hour_d2", "all", "mean", "none",2 "ocean_model_d2", "umo", "umo", "ocean_hour_d2", "all", "mean", "none",2 "ocean_model_d2", "vmo", "vmo", "ocean_hour_d2", "all", "mean", "none",2 "ocean_model_d2", "volcello", "volcello", "ocean_hour_d2", "all", "mean", "none",2 # Cell measure for 3d data "ocean_hour_z", 0, "days", 1, "days", "time" "ocean_model_z", "thetao", "thetao", "ocean_hour_z", "all", "mean", "none",2 "ocean_model_z", "umo", "umo", "ocean_hour_z", "all", "mean", "none",2 "ocean_model_z", "vmo", "vmo", "ocean_hour_z", "all", "mean", "none",2 "ocean_model_z", "volcello", "volcello", "ocean_hour_z", "all", "mean", "none",2 # Cell measure for 3d data "ocean_hour_z_d2", 0, "days", 1, "days", "time" "ocean_model_z_d2", "thetao", "thetao", "ocean_hour_z_d2", "all", "mean", "none",2 "ocean_model_z_d2", "umo", "umo", "ocean_hour_z_d2", "all", "mean", "none",2 "ocean_model_z_d2", "vmo", "vmo", "ocean_hour_z_d2", "all", "mean", "none",2 "ocean_model_z_d2", "volcello", "volcello", "ocean_hour_z_d2", "all", "mean", "none",2 # Cell measure for 3d data --- src/framework/MOM_diag_mediator.F90 | 466 ++++++++++++++++++++-------- 1 file changed, 342 insertions(+), 124 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 9bb049dbb7..6696933d9e 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -73,7 +73,7 @@ module MOM_diag_mediator end interface zap2_sample interface decimate_sample - module procedure decimate_sample_2d, decimate_sample_3d + module procedure decimate_sample_2d, decimate_sample_3d, decimate_sample_3d_out end interface decimate_sample interface decimate_diag_field @@ -176,6 +176,8 @@ module MOM_diag_mediator type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 + type(axes_grp), dimension(:), allocatable :: remap_axesTL, remap_axesBL, remap_axesCuL, remap_axesCvL + type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points @@ -305,11 +307,10 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) !! vertical axes ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh - integer :: i, j, k, nz, dl + integer :: id_zl_native, id_zi_native + integer :: i, j, k, nz real :: zlev(GV%ke), zinter(GV%ke+1) logical :: set_vert - real, dimension(:), pointer :: gridLonT_zap =>NULL() - real, dimension(:), pointer :: gridLatT_zap =>NULL() set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical @@ -326,7 +327,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) else id_zl = -1 ; id_zi = -1 endif - + id_zl_native = id_zl ; id_zi_native = id_zi ! Vertical axes for the interfaces and layers call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, 1, & v_cell_method='point', is_interface=.true.) @@ -391,79 +392,8 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) ! Axis group for special null axis from diag manager call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull) - !Axes group for native decimated diagnostics - do dl=2,MAX_DECIM_LEV - - if(dl .eq. 2) then - allocate(gridLonT_zap(diag_cs%decim(dl)%isg:diag_cs%decim(dl)%ieg)) - allocate(gridLatT_zap(diag_cs%decim(dl)%jsg:diag_cs%decim(dl)%jeg)) - - do i=diag_cs%decim(dl)%isg,diag_cs%decim(dl)%ieg; gridLonT_zap(i) = G%gridLonT(G%isg+dl*i-2); enddo - do j=diag_cs%decim(dl)%jsg,diag_cs%decim(dl)%jeg; gridLatT_zap(j) = G%gridLatT(G%jsg+dl*j-2); enddo - - - ! if (G%symmetric) then - ! id_xq = diag_axis_init('xq', G%gridLonB_zap2(G%isgB:G%iegB), G%x_axis_units, 'x', & - ! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) - ! id_yq = diag_axis_init('yq', G%gridLatB_zap2(G%jsgB:G%jegB), G%y_axis_units, 'y', & - ! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) - ! else - id_xq = diag_axis_init('xq', gridLonT_zap, G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) - id_yq = diag_axis_init('yq', gridLatT_zap, G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) - ! endif - id_xh = diag_axis_init('xh', gridLonT_zap, G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) - id_yh = diag_axis_init('yh', gridLatT_zap, G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) - - deallocate(gridLonT_zap) - deallocate(gridLatT_zap) - else - call MOM_error(FATAL, "This decimation level is not supported yet!") - endif - - ! Axis groupings for the model layers - call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%decim(dl)%axesTL, dl, & - x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & - is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%decim(dl)%axesBL, dl, & - x_cell_method='point', y_cell_method='point', v_cell_method='mean', & - is_q_point=.true., is_layer=.true.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%decim(dl)%axesCuL, dl, & - x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & - is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) - call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%decim(dl)%axesCvL, dl, & - x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & - is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) - - ! Axis groupings for the model interfaces - call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%decim(dl)%axesTi, dl, & - x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & - is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%decim(dl)%axesBi, dl, & - x_cell_method='point', y_cell_method='point', v_cell_method='point', & - is_q_point=.true., is_interface=.true.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%decim(dl)%axesCui, dl, & - x_cell_method='point', y_cell_method='mean', v_cell_method='point', & - is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) - call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%decim(dl)%axesCvi, dl, & - x_cell_method='mean', y_cell_method='point', v_cell_method='point', & - is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) - - ! Axis groupings for 2-D arrays - call define_axes_group_decim(diag_cs, (/ id_xh, id_yh /), diag_cs%decim(dl)%axesT1, dl, & - x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yq /), diag_cs%decim(dl)%axesB1, dl, & - x_cell_method='point', y_cell_method='point', is_q_point=.true.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yh /), diag_cs%decim(dl)%axesCu1, dl, & - x_cell_method='point', y_cell_method='mean', is_u_point=.true.) - call define_axes_group_decim(diag_cs, (/ id_xh, id_yq /), diag_cs%decim(dl)%axesCv1, dl, & - x_cell_method='mean', y_cell_method='point', is_v_point=.true.) - - enddo + !Non-native Non-decimated if (diag_cs%num_diag_coords>0) then allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords)) allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords)) @@ -549,11 +479,186 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) endif enddo + + !Defien the decimated axes + call set_axes_info_decim(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) call diag_grid_storage_init(diag_CS%diag_grid_temp, G, diag_CS) end subroutine set_axes_info +subroutine set_axes_info_decim(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + integer, intent(in) :: id_zl_native, id_zi_native + + ! Local variables + integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh + integer :: i, j, k, nz, dl + real, dimension(:), pointer :: gridLonT_zap =>NULL() + real, dimension(:), pointer :: gridLatT_zap =>NULL() + + id_zl = id_zl_native ; id_zi = id_zi_native + !Axes group for native decimated diagnostics + do dl=2,MAX_DECIM_LEV + if(dl .ne. 2) call MOM_error(FATAL, "Decimation level other than 2 is not supported yet!") + allocate(gridLonT_zap(diag_cs%decim(dl)%isg:diag_cs%decim(dl)%ieg)) + allocate(gridLatT_zap(diag_cs%decim(dl)%jsg:diag_cs%decim(dl)%jeg)) + + do i=diag_cs%decim(dl)%isg,diag_cs%decim(dl)%ieg; gridLonT_zap(i) = G%gridLonT(G%isg+dl*i-2); enddo + do j=diag_cs%decim(dl)%jsg,diag_cs%decim(dl)%jeg; gridLatT_zap(j) = G%gridLatT(G%jsg+dl*j-2); enddo + + ! if (G%symmetric) then + ! id_xq = diag_axis_init('xq', G%gridLonB_zap2(G%isgB:G%iegB), G%x_axis_units, 'x', & + ! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) + ! id_yq = diag_axis_init('yq', G%gridLatB_zap2(G%jsgB:G%jegB), G%y_axis_units, 'y', & + ! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + ! else + id_xq = diag_axis_init('xq', gridLonT_zap, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) + id_yq = diag_axis_init('yq', gridLatT_zap, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + ! endif + id_xh = diag_axis_init('xh', gridLonT_zap, G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) + id_yh = diag_axis_init('yh', gridLatT_zap, G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + + deallocate(gridLonT_zap) + deallocate(gridLatT_zap) + + ! Axis groupings for the model layers + call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%decim(dl)%axesTL, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%decim(dl)%axesBL, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true.) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%decim(dl)%axesCuL, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%decim(dl)%axesCvL, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + + ! Axis groupings for the model interfaces + call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%decim(dl)%axesTi, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%decim(dl)%axesBi, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true.) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%decim(dl)%axesCui, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%decim(dl)%axesCvi, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + + ! Axis groupings for 2-D arrays + call define_axes_group_decim(diag_cs, (/ id_xh, id_yh /), diag_cs%decim(dl)%axesT1, dl, & + x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yq /), diag_cs%decim(dl)%axesB1, dl, & + x_cell_method='point', y_cell_method='point', is_q_point=.true.) + call define_axes_group_decim(diag_cs, (/ id_xq, id_yh /), diag_cs%decim(dl)%axesCu1, dl, & + x_cell_method='point', y_cell_method='mean', is_u_point=.true.) + call define_axes_group_decim(diag_cs, (/ id_xh, id_yq /), diag_cs%decim(dl)%axesCv1, dl, & + x_cell_method='mean', y_cell_method='point', is_v_point=.true.) + + !Non-native axes + if (diag_cs%num_diag_coords>0) then +! allocate(diag_cs%decim(dl)%remap_axesZL(diag_cs%num_diag_coords)) +! allocate(diag_cs%decim(dl)%remap_axesZi(diag_cs%num_diag_coords)) + allocate(diag_cs%decim(dl)%remap_axesTL(diag_cs%num_diag_coords)) + allocate(diag_cs%decim(dl)%remap_axesBL(diag_cs%num_diag_coords)) + allocate(diag_cs%decim(dl)%remap_axesCuL(diag_cs%num_diag_coords)) + allocate(diag_cs%decim(dl)%remap_axesCvL(diag_cs%num_diag_coords)) + allocate(diag_cs%decim(dl)%remap_axesTi(diag_cs%num_diag_coords)) + allocate(diag_cs%decim(dl)%remap_axesBi(diag_cs%num_diag_coords)) + allocate(diag_cs%decim(dl)%remap_axesCui(diag_cs%num_diag_coords)) + allocate(diag_cs%decim(dl)%remap_axesCvi(diag_cs%num_diag_coords)) + endif + + do i=1, diag_cs%num_diag_coords + ! For each possible diagnostic coordinate + !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file) + + ! This vertical coordinate has been configured so can be used. + if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then + + ! This fetches the 1D-axis id for layers and interfaces and overwrite + ! id_zl and id_zi from above. It also returns the number of layers. + call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zL, id_zi) + + ! Axes for z layers + !This should be the same as non-decimated one which should already be set +! call define_axes_group(diag_cs, (/ id_zL /), diag_cs%decim(dl)%remap_axesZL(i), & +! nz=nz, vertical_coordinate_number=i, & +! v_cell_method='mean', & +! is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true.) + + call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%decim(dl)%remap_axesTL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not + !! provided for remap_axesBL + call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%decim(dl)%remap_axesBL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true., is_native=.false.) + + call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%decim(dl)%remap_axesCuL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%decim(dl)%remap_axesCvL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + ! Axes for z interfaces +! call define_axes_group_decim(diag_cs, (/ id_zi /), diag_cs%decim(dl)%remap_axesZi(i),& +! nz=nz, vertical_coordinate_number=i, & +! v_cell_method='point', & +! is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true.) + call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%decim(dl)%remap_axesTi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., & + xyave_axes=diag_cs%remap_axesZi(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi + call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%decim(dl)%remap_axesBi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true., is_native=.false.) + + call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%decim(dl)%remap_axesCui(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + + call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%decim(dl)%remap_axesCvi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + endif + enddo + enddo + +end subroutine set_axes_info_decim + + !> set_masks_for_axes sets up the 2d and 3d masks for diagnostics using the current grid !! recorded after calling diag_update_remap_grids() subroutine set_masks_for_axes(G, diag_cs) @@ -650,8 +755,50 @@ subroutine set_masks_for_axes(G, diag_cs) endif enddo + call set_masks_for_axes_decim(G, diag_cs) + end subroutine set_masks_for_axes +subroutine set_masks_for_axes_decim(G, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: c, nk, i, j, k, ii, jj + integer :: dl + type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience + + do dl=2,MAX_DECIM_LEV + if(dl .ne. 2) call MOM_error(FATAL, "Decimation level other than 2 is not supported yet!") + do c=1, diag_cs%num_diag_coords + ! Level/layer h-points in diagnostic coordinate + axes => diag_cs%remap_axesTL(c) + call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + ! Level/layer u-points in diagnostic coordinate + axes => diag_cs%remap_axesCuL(c) + call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + ! Level/layer v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvL(c) + call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + ! Level/layer q-points in diagnostic coordinate + axes => diag_cs%remap_axesBL(c) + call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + ! Interface h-points in diagnostic coordinate (w-point) + axes => diag_cs%remap_axesTi(c) + call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + ! Interface u-points in diagnostic coordinate + axes => diag_cs%remap_axesCui(c) + call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + ! Interface v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvi(c) + call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + ! Interface q-points in diagnostic coordinate + axes => diag_cs%remap_axesBi(c) + call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + enddo + enddo +end subroutine set_masks_for_axes_decim + !> Attaches the id of cell areas to axes groups for use with cell_measures subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q) type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure @@ -1685,6 +1832,54 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time y_cell_method=y_cell_method, v_cell_method=v_cell_method, & conversion=conversion, v_extensive=v_extensive) + ! For each diagnostic coordinate register the diagnostic again under a different module name + do i=1,diag_cs%num_diag_coords + new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix) + + ! Register diagnostics remapped to z vertical coordinate + if (axes_in%rank == 3) then + remap_axes => null() + if ((axes_in%id == diag_cs%axesTL%id)) then + remap_axes => diag_cs%remap_axesTL(i) + elseif (axes_in%id == diag_cs%axesBL%id) then + remap_axes => diag_cs%remap_axesBL(i) + elseif (axes_in%id == diag_cs%axesCuL%id ) then + remap_axes => diag_cs%remap_axesCuL(i) + elseif (axes_in%id == diag_cs%axesCvL%id) then + remap_axes => diag_cs%remap_axesCvL(i) + elseif (axes_in%id == diag_cs%axesTi%id) then + remap_axes => diag_cs%remap_axesTi(i) + elseif (axes_in%id == diag_cs%axesBi%id) then + remap_axes => diag_cs%remap_axesBi(i) + elseif (axes_in%id == diag_cs%axesCui%id ) then + remap_axes => diag_cs%remap_axesCui(i) + elseif (axes_in%id == diag_cs%axesCvi%id) then + remap_axes => diag_cs%remap_axesCvi(i) + endif + + ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will + ! always exist but in the mean-time we have to do this check: + ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set') + if (associated(remap_axes)) then + if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + if (active) then + call diag_remap_set_active(diag_cs%diag_remap_cs(i)) + endif + endif ! remap_axes%needs_remapping + endif ! associated(remap_axes) + endif ! axes%rank == 3 + enddo ! i + do dl=2,MAX_DECIM_LEV new_module_name = trim(module_name)//'_d2' @@ -1733,54 +1928,55 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time y_cell_method=y_cell_method, v_cell_method=v_cell_method, & conversion=conversion, v_extensive=v_extensive) endif - enddo - ! For each diagnostic coordinate register the diagnostic again under a different module name - do i=1,diag_cs%num_diag_coords - new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix) - - ! Register diagnostics remapped to z vertical coordinate - if (axes_in%rank == 3) then - remap_axes => null() - if ((axes_in%id == diag_cs%axesTL%id)) then - remap_axes => diag_cs%remap_axesTL(i) - elseif (axes_in%id == diag_cs%axesBL%id) then - remap_axes => diag_cs%remap_axesBL(i) - elseif (axes_in%id == diag_cs%axesCuL%id ) then - remap_axes => diag_cs%remap_axesCuL(i) - elseif (axes_in%id == diag_cs%axesCvL%id) then - remap_axes => diag_cs%remap_axesCvL(i) - elseif (axes_in%id == diag_cs%axesTi%id) then - remap_axes => diag_cs%remap_axesTi(i) - elseif (axes_in%id == diag_cs%axesBi%id) then - remap_axes => diag_cs%remap_axesBi(i) - elseif (axes_in%id == diag_cs%axesCui%id ) then - remap_axes => diag_cs%remap_axesCui(i) - elseif (axes_in%id == diag_cs%axesCvi%id) then - remap_axes => diag_cs%remap_axesCvi(i) - endif - ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will - ! always exist but in the mean-time we have to do this check: - ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set') - if (associated(remap_axes)) then - if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating) then - active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, & - init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & - range=range, mask_variant=mask_variant, standard_name=standard_name, & - verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & - interp_method=interp_method, tile_count=tile_count, & - cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & - cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & - cell_methods=cell_methods, x_cell_method=x_cell_method, & - y_cell_method=y_cell_method, v_cell_method=v_cell_method, & - conversion=conversion, v_extensive=v_extensive) - if (active) then - call diag_remap_set_active(diag_cs%diag_remap_cs(i)) - endif - endif ! remap_axes%needs_remapping - endif ! associated(remap_axes) - endif ! axes%rank == 3 - enddo ! i + ! For each diagnostic coordinate register the diagnostic again under a different module name + do i=1,diag_cs%num_diag_coords + new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)//'_d2' + + ! Register diagnostics remapped to z vertical coordinate + if (axes_in%rank == 3) then + remap_axes => null() + if ((axes_in%id == diag_cs%axesTL%id)) then + remap_axes => diag_cs%decim(dl)%remap_axesTL(i) + elseif (axes_in%id == diag_cs%axesBL%id) then + remap_axes => diag_cs%decim(dl)%remap_axesBL(i) + elseif (axes_in%id == diag_cs%axesCuL%id ) then + remap_axes => diag_cs%decim(dl)%remap_axesCuL(i) + elseif (axes_in%id == diag_cs%axesCvL%id) then + remap_axes => diag_cs%decim(dl)%remap_axesCvL(i) + elseif (axes_in%id == diag_cs%axesTi%id) then + remap_axes => diag_cs%decim(dl)%remap_axesTi(i) + elseif (axes_in%id == diag_cs%axesBi%id) then + remap_axes => diag_cs%decim(dl)%remap_axesBi(i) + elseif (axes_in%id == diag_cs%axesCui%id ) then + remap_axes => diag_cs%decim(dl)%remap_axesCui(i) + elseif (axes_in%id == diag_cs%axesCvi%id) then + remap_axes => diag_cs%decim(dl)%remap_axesCvi(i) + endif + + ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will + ! always exist but in the mean-time we have to do this check: + ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set') + if (associated(remap_axes)) then + if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + if (active) then + call diag_remap_set_active(diag_cs%diag_remap_cs(i)) + endif + endif ! remap_axes%needs_remapping + endif ! associated(remap_axes) + endif ! axes%rank == 3 + enddo ! i + enddo register_diag_field = dm_id @@ -3411,4 +3607,26 @@ subroutine decimate_sample_2d(field_in, level) field_in => field_out end subroutine decimate_sample_2d +subroutine decimate_sample_3d_out(field_in, field_out, level) + integer , intent(in) :: level + real, dimension(:,:,:) , pointer :: field_in, field_out + integer :: i,j,ii,jj,is,js + integer :: isl,iel,jsl,jel + integer :: k,ks,ke + ! is = lbound(field_in,1) ; ie = ubound(field_in,1) + ! js = lbound(field_in,2) ; je = ubound(field_in,2) + !Always start from the first element + is=1 + js=1 + ks = lbound(field_in,3) ; ke = ubound(field_in,3) + isl=1; iel=size(field_in,1)/level + jsl=1; jel=size(field_in,2)/level + allocate(field_out(isl:iel,jsl:jel,ks:ke)) + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + ii = is+level*(i-isl) + jj = js+level*(j-jsl) + field_out(i,j,k) = field_in(ii,jj,k) + enddo; enddo; enddo +end subroutine decimate_sample_3d_out + end module MOM_diag_mediator From 7e3d3685d508564e442c08b15d052c1e403c9bde Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 1 Oct 2018 15:05:47 -0400 Subject: [PATCH 06/18] Diag decimation prototype, fixing memory leaks - The design of decimating subroutines with pointer manipulations was bad and causing memory leak. Using "allocatable" arrays instead is not as elegant but avoids memory leaks at the cost of bringing a few lines of code fo allocating temporary arrays outside the decimating subroutines. The FORTRAN garbage collection takes care of deallocating the "allocatable"s when their scope ends (unlike pointers). --- src/framework/MOM_diag_mediator.F90 | 221 +++++++++++----------------- 1 file changed, 89 insertions(+), 132 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 6696933d9e..46dfae8507 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -73,13 +73,13 @@ module MOM_diag_mediator end interface zap2_sample interface decimate_sample - module procedure decimate_sample_2d, decimate_sample_3d, decimate_sample_3d_out + module procedure decimate_sample_3d_out end interface decimate_sample -interface decimate_diag_field - module procedure decimate_diag_field_2d,decimate_diag_field_3d -end interface decimate_diag_field - +interface decimate_diag_field_set + module procedure decimate_diag_field_set_2d,decimate_diag_field_set_3d +end interface decimate_diag_field_set + type, private :: diag_decim real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes @@ -1237,11 +1237,14 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) ! Local variables real, dimension(:,:), pointer :: locfield => NULL() real, dimension(:,:), pointer :: locmask => NULL() - real, dimension(:,:), pointer :: diag_axes_mask2d => NULL() character(len=300) :: mesg logical :: used, is_stat integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, i, j, chksum, dl + integer :: isv, iev, jsv, jev, i, j, chksum + real, dimension(:,:), pointer :: diag_axes_mask2d => NULL() + real, dimension(:,:), allocatable, target :: locfield_decim + real, dimension(:,:), allocatable, target :: locmask_decim + integer :: isl,iel,jsl,jel,dl is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1324,9 +1327,16 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) diag_axes_mask2d => diag%axes%mask2d dl = diag%axes%decimation_level if (dl > 1) then - call decimate_diag_field(locfield, dl, diag_cs,isv,iev,jsv,jev) + isl=1; iel=size(field,1)/dl + jsl=1; jel=size(field,2)/dl + call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) + allocate(locfield_decim(isl:iel,jsl:jel)) + call decimate_diag_field_set(locfield, locfield_decim, dl,isl,iel,jsl,jel) + locfield => locfield_decim if (present(mask)) then - call decimate_diag_field(locmask, dl) + allocate(locmask_decim(isl:iel,jsl:jel)) + call decimate_diag_field_set(locmask, locmask_decim, dl,isl,iel,jsl,jel) + locmask => locmask_decim elseif (associated(diag%axes%decim(dl)%mask2d)) then diag_axes_mask2d => diag%axes%decim(dl)%mask2d endif @@ -1373,7 +1383,6 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & deallocate( locfield ) - end subroutine post_data_2d_low !> Make a real 3-d array diagnostic available for averaging or output. @@ -1508,14 +1517,17 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) ! Local variables real, dimension(:,:,:), pointer :: locfield => NULL() real, dimension(:,:,:), pointer :: locmask => NULL() - real, dimension(:,:,:), pointer :: diag_axes_mask3d => NULL() character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. logical :: staggered_in_x, staggered_in_y logical :: is_stat integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c - integer :: chksum, dl + integer :: chksum + real, dimension(:,:,:), pointer :: diag_axes_mask3d => NULL() + real, dimension(:,:,:), allocatable, target :: locfield_decim + real, dimension(:,:,:), allocatable, target :: locmask_decim + integer :: isl,iel,jsl,jel,dl is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1596,9 +1608,16 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) diag_axes_mask3d => diag%axes%mask3d dl = diag%axes%decimation_level if (dl > 1) then - call decimate_diag_field(locfield, dl, diag_cs,isv,iev,jsv,jev) + isl=1; iel=size(field,1)/dl + jsl=1; jel=size(field,2)/dl + call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) + allocate(locfield_decim(isl:iel,jsl:jel,ks:ke)) + call decimate_diag_field_set(locfield, locfield_decim, dl,isl,iel,jsl,jel,ks,ke) + locfield => locfield_decim if (present(mask)) then - call decimate_diag_field(locmask, dl) + allocate(locmask_decim(isl:iel,jsl:jel,ks:ke)) + call decimate_diag_field_set(locmask, locmask_decim, dl,isl,iel,jsl,jel,ks,ke) + locmask => locmask_decim elseif (associated(diag%axes%decim(dl)%mask3d)) then diag_axes_mask3d => diag%axes%decim(dl)%mask3d endif @@ -3464,148 +3483,86 @@ subroutine decimate_diag_masks_set(G, nz, diag_cs) enddo end subroutine decimate_diag_masks_set - - -subroutine decimate_diag_field_2d(field, dl, diag_cs, isv,iev,jsv,jev) - real, pointer :: field(:,:) !< 2-d array being offered for output or averaging +subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) + integer, intent(in) :: f1,f2 integer, intent(in) :: dl !< integer decimation level - type(diag_ctrl),optional, intent(in) :: diag_CS !< Structure used to regulate diagnostic output - integer, optional, intent(inout) ::isv,iev,jsv,jev - ! Local variables - integer :: dszi,cszi,dszj,cszj - character(len=300) :: mesg - - call decimate_sample(field, dl) - - if(present(diag_cs))then - cszi = diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc +1 ; dszi = diag_cs%decim(dl)%ied-diag_cs%decim(dl)%isd +1 - cszj = diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc +1 ; dszj = diag_cs%decim(dl)%jed-diag_cs%decim(dl)%jsd +1 - - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec - jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec - - if ( size(field,1) == dszi ) then - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec ! Data domain - elseif ( size(field,1) == dszi + 1 ) then - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec+1 ! Symmetric data domain - elseif ( size(field,1) == cszi) then - isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +1 ! Computational domain - elseif ( size(field,1) == cszi + 1 ) then - isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +2 ! Symmetric computational domain - else - write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& - "does not match one of ", cszi, cszi+1, dszi, dszi+1 - call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) - endif - if ( size(field,2) == dszj ) then - jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec ! Data domain - elseif ( size(field,2) == dszj + 1 ) then - jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec+1 ! Symmetric data domain - elseif ( size(field,2) == cszj) then - jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +1 ! Computational domain - elseif ( size(field,2) == cszj + 1 ) then - jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +2 ! Symmetric computational domain - else - write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& - "does not match one of ", cszj, cszj+1, dszj, dszj+1 - call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) - endif - endif - -end subroutine decimate_diag_field_2d - -subroutine decimate_diag_field_3d(field, dl, diag_cs, isv,iev,jsv,jev) - real, pointer :: field(:,:,:) !< 3-d array being offered for output or averaging - integer, intent(in) :: dl !< integer decimation level - type(diag_ctrl),optional, intent(in) :: diag_CS !< Structure used to regulate diagnostic output - integer, optional, intent(inout) ::isv,iev,jsv,jev + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + integer, intent(inout) ::isv,iev,jsv,jev ! Local variables integer :: dszi,cszi,dszj,cszj character(len=300) :: mesg - call decimate_sample(field, dl) - - if(present(diag_cs))then - cszi = diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc +1 ; dszi = diag_cs%decim(dl)%ied-diag_cs%decim(dl)%isd +1 - cszj = diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc +1 ; dszj = diag_cs%decim(dl)%jed-diag_cs%decim(dl)%jsd +1 + cszi = diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc +1 ; dszi = diag_cs%decim(dl)%ied-diag_cs%decim(dl)%isd +1 + cszj = diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc +1 ; dszj = diag_cs%decim(dl)%jed-diag_cs%decim(dl)%jsd +1 - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec - jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec + jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec - if ( size(field,1) == dszi ) then - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec ! Data domain - elseif ( size(field,1) == dszi + 1 ) then - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec+1 ! Symmetric data domain - elseif ( size(field,1) == cszi) then - isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +1 ! Computational domain - elseif ( size(field,1) == cszi + 1 ) then - isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +2 ! Symmetric computational domain - else - write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& - "does not match one of ", cszi, cszi+1, dszi, dszi+1 - call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) - endif - if ( size(field,2) == dszj ) then - jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec ! Data domain - elseif ( size(field,2) == dszj + 1 ) then - jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec+1 ! Symmetric data domain - elseif ( size(field,2) == cszj) then - jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +1 ! Computational domain - elseif ( size(field,2) == cszj + 1 ) then - jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +2 ! Symmetric computational domain - else - write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& - "does not match one of ", cszj, cszj+1, dszj, dszj+1 - call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) - endif - endif - -end subroutine decimate_diag_field_3d + if ( f1 == dszi ) then + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec ! Data domain + elseif ( f1 == dszi + 1 ) then + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec+1 ! Symmetric data domain + elseif ( f1 == cszi) then + isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +1 ! Computational domain + elseif ( f1 == cszi + 1 ) then + isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",f1," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) + endif + if ( f2 == dszj ) then + jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec ! Data domain + elseif ( f2 == dszj + 1 ) then + jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec+1 ! Symmetric data domain + elseif ( f2 == cszj) then + jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +1 ! Computational domain + elseif ( f2 == cszj + 1 ) then + jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",f2," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) + endif +end subroutine decimate_diag_indices_get + -subroutine decimate_sample_3d(field_in, level) - integer , intent(in) :: level - real, dimension(:,:,:) , pointer :: field_in, field_out +subroutine decimate_diag_field_set_3d(field_in, field_out, level ,isl,iel,jsl,jel,ks,ke) + real, dimension(:,:,:) , pointer :: field_in + real, dimension(:,:,:) , intent(inout) :: field_out + integer , intent(in) :: level, iel,jel,ks,ke + integer , intent(inout) :: isl,jsl integer :: i,j,ii,jj,is,js - integer :: isl,iel,jsl,jel - integer :: k,ks,ke - ! is = lbound(field_in,1) ; ie = ubound(field_in,1) - ! js = lbound(field_in,2) ; je = ubound(field_in,2) + integer :: k + !Always start from the first element - is=1 - js=1 - ks = lbound(field_in,3) ; ke = ubound(field_in,3) - isl=1; iel=size(field_in,1)/level - jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel,ks:ke)) + is=1; isl=1 + js=1; jsl=1 do k= ks,ke ; do j=jsl,jel ; do i=isl,iel ii = is+level*(i-isl) jj = js+level*(j-jsl) field_out(i,j,k) = field_in(ii,jj,k) enddo; enddo; enddo - field_in => field_out -end subroutine decimate_sample_3d +end subroutine decimate_diag_field_set_3d -subroutine decimate_sample_2d(field_in, level) - integer , intent(in) :: level - real, dimension(:,:) , pointer :: field_in, field_out +subroutine decimate_diag_field_set_2d(field_in, field_out, level ,isl,iel,jsl,jel) + real, dimension(:,:) , pointer :: field_in + real, dimension(:,:), intent(inout) :: field_out + integer , intent(in) :: level, iel,jel + integer , intent(inout) :: isl,jsl integer :: i,j,ii,jj,is,js - integer :: isl,iel,jsl,jel - ! is = lbound(field_in,1) ; ie = ubound(field_in,1) - ! js = lbound(field_in,2) ; je = ubound(field_in,2) + !Always start from the first element - is=1 - js=1 - isl=1; iel=size(field_in,1)/level - jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel)) + is=1; isl=1 + js=1; jsl=1 do j=jsl,jel ; do i=isl,iel ii = is+level*(i-isl) jj = js+level*(j-jsl) field_out(i,j) = field_in(ii,jj) enddo; enddo - field_in => field_out -end subroutine decimate_sample_2d +end subroutine decimate_diag_field_set_2d + subroutine decimate_sample_3d_out(field_in, field_out, level) integer , intent(in) :: level From dfe674c5d0336e53c82cd2a8951e30699844c7c3 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 4 Oct 2018 12:58:00 -0400 Subject: [PATCH 07/18] Diag decimation prototype, aggregating methods - This update introduces aggregation methods, so that we can point average the fields rather than subsampling. This cab be extended to fancier methods such as area or volume averaging --- src/framework/MOM_diag_mediator.F90 | 267 ++++++++++++++++++---------- 1 file changed, 174 insertions(+), 93 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 46dfae8507..c5e4de65a2 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -68,12 +68,8 @@ module MOM_diag_mediator module procedure post_data_3d, post_data_2d, post_data_0d end interface post_data -interface zap2_sample - module procedure zap2_sample_2d,zap2_sample_3d,zap2_sample_2d0,zap2_sample_3d0 -end interface zap2_sample - interface decimate_sample - module procedure decimate_sample_3d_out + module procedure decimate_sample_2d_ptr, decimate_sample_3d_ptr, decimate_sample_2d, decimate_sample_3d end interface decimate_sample interface decimate_diag_field_set @@ -1330,12 +1326,20 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) isl=1; iel=size(field,1)/dl jsl=1; jel=size(field,2)/dl call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) - allocate(locfield_decim(isl:iel,jsl:jel)) - call decimate_diag_field_set(locfield, locfield_decim, dl,isl,iel,jsl,jel) +! allocate(locfield_decim(isl:iel,jsl:jel)) +! call decimate_diag_field_set(locfield, locfield_decim, dl,isl,iel,jsl,jel) + if (present(mask)) then + call decimate_sample(locfield, locfield_decim, dl, method='pave', mask=locmask) + elseif (associated(diag%axes%mask2d)) then + call decimate_sample(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask2d) + else + call decimate_sample(locfield, locfield_decim, dl, method='pave') !decimate without a mask, how ?? + endif locfield => locfield_decim if (present(mask)) then - allocate(locmask_decim(isl:iel,jsl:jel)) - call decimate_diag_field_set(locmask, locmask_decim, dl,isl,iel,jsl,jel) +! allocate(locmask_decim(isl:iel,jsl:jel)) +! call decimate_diag_field_set(locmask, locmask_decim, dl,isl,iel,jsl,jel) + call decimate_sample(locmask, locmask_decim, dl) locmask => locmask_decim elseif (associated(diag%axes%decim(dl)%mask2d)) then diag_axes_mask2d => diag%axes%decim(dl)%mask2d @@ -1611,12 +1615,21 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) isl=1; iel=size(field,1)/dl jsl=1; jel=size(field,2)/dl call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) - allocate(locfield_decim(isl:iel,jsl:jel,ks:ke)) - call decimate_diag_field_set(locfield, locfield_decim, dl,isl,iel,jsl,jel,ks,ke) +! allocate(locfield_decim(isl:iel,jsl:jel,ks:ke)) +! call decimate_diag_field_set(locfield, locfield_decim, dl,isl,iel,jsl,jel,ks,ke) + if (present(mask)) then + call decimate_sample(locfield, locfield_decim, dl, method='pave', mask=locmask) + elseif (associated(diag%axes%mask3d)) then + call decimate_sample(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask3d) + else + !Niki: How are we supposed to aggregate/average without a mask if one or more aggregating cells are on land? + call decimate_sample(locfield, locfield_decim, dl, method='pave') !decimate without a mask, how ?? + endif locfield => locfield_decim if (present(mask)) then - allocate(locmask_decim(isl:iel,jsl:jel,ks:ke)) - call decimate_diag_field_set(locmask, locmask_decim, dl,isl,iel,jsl,jel,ks,ke) +! allocate(locmask_decim(isl:iel,jsl:jel,ks:ke)) +! call decimate_diag_field_set(locmask, locmask_decim, dl,isl,iel,jsl,jel,ks,ke) + call decimate_sample(locmask, locmask_decim, dl) ! Niki: What is the correct method for mask? Defaults to subsample locmask => locmask_decim elseif (associated(diag%axes%decim(dl)%mask3d)) then diag_axes_mask3d => diag%axes%decim(dl)%mask3d @@ -3361,76 +3374,6 @@ subroutine diag_grid_storage_end(grid_storage) deallocate(grid_storage%diag_grids) end subroutine diag_grid_storage_end -subroutine zap2_sample_3d(field_in, field_out,ks,ke, is,ie,js,je, is2,ie2,js2,je2) - integer , intent(in) :: ks,ke, is,ie,js,je, is2,ie2,js2,je2 - real, dimension(is:,js:,1:) ,intent(in) :: field_in - real, dimension(:,:,:) , pointer :: field_out - integer :: k,i,j,ii,jj - - allocate(field_out(is2:ie2,js2:je2,ks:ke)) - do k= ks,ke ; do j=js2,je2 ; do i=is2,ie2 - ii = is+2*(i-is2) - jj = js+2*(j-js2) - field_out(i,j,k) = field_in(ii,jj,k) - enddo; enddo; enddo - -end subroutine zap2_sample_3d - -subroutine zap2_sample_2d(field_in, field_out, is,ie,js,je, is2,ie2,js2,je2) - integer , intent(in) :: is,ie,js,je, is2,ie2,js2,je2 - real, dimension(is:,js:) ,intent(in) :: field_in - real, dimension(:,:) , pointer :: field_out - integer :: i,j,ii,jj - - allocate(field_out(is2:ie2,js2:je2)) - do j=js2,je2 ; do i=is2,ie2 - ii = is+2*(i-is2) - jj = js+2*(j-js2) - field_out(i,j) = field_in(ii,jj) - enddo; enddo - -end subroutine zap2_sample_2d - -subroutine zap2_sample_3d0(field_in, field_out,ks,ke) - integer , intent(in) :: ks,ke - real, dimension(:,:,:) ,intent(in) :: field_in - real, dimension(:,:,:) , pointer :: field_out - integer :: k,i,j,ii,jj, is_in,js_in, is2,ie2,js2,je2 - - is_in=1; js_in=1 - is2=1; ie2=size(field_in,1)/2 - js2=1; je2=size(field_in,2)/2 - - allocate(field_out(is2:ie2,js2:je2,ks:ke)) - - do k= ks,ke ; do j=js2,je2 ; do i=is2,ie2 - ii = is_in+2*(i-is2) - jj = js_in+2*(j-js2) - field_out(i,j,k) = field_in(ii,jj,k) - enddo; enddo; enddo - -end subroutine zap2_sample_3d0 - -subroutine zap2_sample_2d0(field_in, field_out) - real, dimension(:,:) ,intent(in) :: field_in - real, dimension(:,:) , pointer :: field_out - integer :: i,j,ii,jj, is_in,js_in, is2,ie2,js2,je2 - - is_in=1; js_in=1 - is2=1; ie2=size(field_in,1)/2 - js2=1; je2=size(field_in,2)/2 - - allocate(field_out(is2:ie2,js2:je2)) - - do j=js2,je2 ; do i=is2,ie2 - ii = is_in+2*(i-is2) - jj = js_in+2*(j-js2) - field_out(i,j) = field_in(ii,jj) - enddo; enddo - -end subroutine zap2_sample_2d0 - - subroutine decimate_diag_masks_set(G, nz, diag_cs) type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. integer, intent(in) :: nz !< The number of layers in the model's native grid. @@ -3450,14 +3393,10 @@ subroutine decimate_diag_masks_set(G, nz, diag_cs) do dl=2,MAX_DECIM_LEV ! 2d masks - allocate(diag_cs%decim(dl)%mask2dT(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2)) - allocate(diag_cs%decim(dl)%mask2dBu(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2)) - allocate(diag_cs%decim(dl)%mask2dCu(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2)) - allocate(diag_cs%decim(dl)%mask2dCv(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2)) - call zap2_sample(G%mask2dT, diag_cs%decim(dl)%mask2dT ,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) - call zap2_sample(G%mask2dBu,diag_cs%decim(dl)%mask2dBu,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) - call zap2_sample(G%mask2dCu,diag_cs%decim(dl)%mask2dCu,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) - call zap2_sample(G%mask2dCv,diag_cs%decim(dl)%mask2dCv,G%isd,G%ied,G%jsd,G%jed,G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2) + call decimate_sample(G%mask2dT, diag_cs%decim(dl)%mask2dT, dl) + call decimate_sample(G%mask2dBu,diag_cs%decim(dl)%mask2dBu, dl) + call decimate_sample(G%mask2dCu,diag_cs%decim(dl)%mask2dCu, dl) + call decimate_sample(G%mask2dCv,diag_cs%decim(dl)%mask2dCv, dl) ! 3d native masks are needed by diag_manager but the native variables ! can only be masked 2d - for ocean points, all layers exists. allocate(diag_cs%decim(dl)%mask3dTL(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) @@ -3564,7 +3503,7 @@ subroutine decimate_diag_field_set_2d(field_in, field_out, level ,isl,iel,jsl,je end subroutine decimate_diag_field_set_2d -subroutine decimate_sample_3d_out(field_in, field_out, level) +subroutine decimate_sample_3d(field_in, field_out, level) integer , intent(in) :: level real, dimension(:,:,:) , pointer :: field_in, field_out integer :: i,j,ii,jj,is,js @@ -3584,6 +3523,148 @@ subroutine decimate_sample_3d_out(field_in, field_out, level) jj = js+level*(j-jsl) field_out(i,j,k) = field_in(ii,jj,k) enddo; enddo; enddo -end subroutine decimate_sample_3d_out +end subroutine decimate_sample_3d + +subroutine decimate_sample_3d_ptr(field_in, field_out, level, method, mask) + real, dimension(:,:,:) , pointer :: field_in + real, dimension(:,:,:) , allocatable :: field_out + integer , intent(in) :: level + character(len=4), optional, intent(in) :: method !< sampling method, one of samp,pave,aave,vave + real, dimension(:,:,:), optional , pointer :: mask + !locals + integer :: i,j,ii,jj,is,js,i0,j0 + integer :: isl,iel,jsl,jel + integer :: k,ks,ke + real :: ave,tot_non_zero + character(len=4) :: samplemethod + samplemethod = 'samp' + if(present(method)) samplemethod = method + + !Always start from the first element + is=1 + js=1 + ks = lbound(field_in,3) ; ke = ubound(field_in,3) + isl=1; iel=size(field_in,1)/level + jsl=1; jel=size(field_in,2)/level + allocate(field_out(isl:iel,jsl:jel,ks:ke)) + + + select case (samplemethod) + case ('samp') !subsample the SW corner cell + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + field_out(i,j,k) = field_in(i0,j0,k) + enddo; enddo; enddo + case ('pave') !point average of the cells + if(present(mask)) then + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + ave = 0.0 + tot_non_zero = 0.0 + do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 + tot_non_zero = tot_non_zero + mask(ii,jj,k) + ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) + enddo; enddo + field_out(i,j,k) = ave/max(1.0,tot_non_zero) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + else + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + ave = 0.0 + tot_non_zero = 0.0 + do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 + tot_non_zero = tot_non_zero + 1 + ave=ave+field_in(ii,jj,k) + enddo; enddo + field_out(i,j,k) = ave/tot_non_zero + enddo; enddo; enddo + endif + case default + call MOM_error(FATAL, "decimate_sample_3d_ptr: unknown sampling method "//trim(samplemethod)) + end select + +end subroutine decimate_sample_3d_ptr + +subroutine decimate_sample_2d_ptr(field_in, field_out, level, method, mask) + real, dimension(:,:) , pointer :: field_in + real, dimension(:,:) , allocatable :: field_out + integer , intent(in) :: level + character(len=4), optional, intent(in) :: method !< sampling method, one of samp,pave,aave,vave + real, dimension(:,:), optional , pointer :: mask + !locals + integer :: i,j,ii,jj,is,js,i0,j0 + integer :: isl,iel,jsl,jel + real :: ave,tot_non_zero + character(len=4) :: samplemethod + samplemethod = 'samp' + if(present(method)) samplemethod = method + + !Always start from the first element + is=1 + js=1 + isl=1; iel=size(field_in,1)/level + jsl=1; jel=size(field_in,2)/level + allocate(field_out(isl:iel,jsl:jel)) + + select case (samplemethod) + case ('samp') !subsample the SW corner cell + do j=jsl,jel ; do i=isl,iel + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + field_out(i,j) = field_in(i0,j0) + enddo; enddo + case ('pave') !point average of the cells + if(present(mask)) then + do j=jsl,jel ; do i=isl,iel + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + ave = 0.0 + tot_non_zero = 0.0 + do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 + tot_non_zero = tot_non_zero + mask(ii,jj) + ave=ave+field_in(ii,jj)*mask(ii,jj) + enddo; enddo + field_out(i,j) = ave/max(1.0,tot_non_zero) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + else !Niki: How are we supposed to aggregate/average without a mask? What if field_in is on land at one or more aggregating cells? + do j=jsl,jel ; do i=isl,iel + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + ave = 0.0 + tot_non_zero = 0.0 + do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 + tot_non_zero = tot_non_zero + 1 + ave=ave+field_in(ii,jj) + enddo; enddo + field_out(i,j) = ave/tot_non_zero + enddo; enddo + endif + case default + call MOM_error(FATAL, "decimate_sample_2d_ptr: unknown sampling method "//trim(samplemethod)) + end select + +end subroutine decimate_sample_2d_ptr + +subroutine decimate_sample_2d(field_in, field_out, level) + integer , intent(in) :: level + real, dimension(:,:) , intent(in) :: field_in + real, dimension(:,:) , pointer :: field_out + integer :: i,j,ii,jj,is,js + integer :: isl,iel,jsl,jel + !Always start from the first element + is=1 + js=1 + isl=1; iel=size(field_in,1)/level + jsl=1; jel=size(field_in,2)/level + allocate(field_out(isl:iel,jsl:jel)) + do j=jsl,jel ; do i=isl,iel + ii = is+level*(i-isl) + jj = js+level*(j-jsl) + field_out(i,j) = field_in(ii,jj) + enddo; enddo +end subroutine decimate_sample_2d end module MOM_diag_mediator From 5f3949fd71a313992106d903c792d3607e04fa33 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 5 Oct 2018 12:05:37 -0400 Subject: [PATCH 08/18] Diag decimation prototype, fixed masks and cleanup - The masks for non-native decimated diags were not set right - Some cleanup of the code to consolidate new calls - Note that locmask => NULL() shoulbe in the body of subroutines not in the definition section. If it is in the definition section it is set to null only on the first entry (it is automatically "save"ed) and on subsequent entry it is whatever it was the last time. --- src/framework/MOM_diag_mediator.F90 | 314 +++++++++++++++------------- 1 file changed, 165 insertions(+), 149 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index c5e4de65a2..9bce490007 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -68,13 +68,17 @@ module MOM_diag_mediator module procedure post_data_3d, post_data_2d, post_data_0d end interface post_data -interface decimate_sample - module procedure decimate_sample_2d_ptr, decimate_sample_3d_ptr, decimate_sample_2d, decimate_sample_3d -end interface decimate_sample +interface decimate_field + module procedure decimate_field_2d, decimate_field_3d +end interface decimate_field -interface decimate_diag_field_set - module procedure decimate_diag_field_set_2d,decimate_diag_field_set_3d -end interface decimate_diag_field_set +interface decimate_mask + module procedure decimate_mask_2d_p, decimate_mask_3d_p, decimate_mask_2d_a, decimate_mask_3d_a +end interface decimate_mask + +interface decimate_diag_field + module procedure decimate_diag_field_2d, decimate_diag_field_3d +end interface decimate_diag_field type, private :: diag_decim real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes @@ -769,28 +773,28 @@ subroutine set_masks_for_axes_decim(G, diag_cs) do c=1, diag_cs%num_diag_coords ! Level/layer h-points in diagnostic coordinate axes => diag_cs%remap_axesTL(c) - call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesTL(c)%decim(dl)%mask3d, dl) ! Level/layer u-points in diagnostic coordinate axes => diag_cs%remap_axesCuL(c) - call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCuL(c)%decim(dl)%mask3d, dl) ! Level/layer v-points in diagnostic coordinate axes => diag_cs%remap_axesCvL(c) - call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCvL(c)%decim(dl)%mask3d, dl) ! Level/layer q-points in diagnostic coordinate axes => diag_cs%remap_axesBL(c) - call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesBL(c)%decim(dl)%mask3d, dl) ! Interface h-points in diagnostic coordinate (w-point) axes => diag_cs%remap_axesTi(c) - call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesTi(c)%decim(dl)%mask3d, dl) ! Interface u-points in diagnostic coordinate axes => diag_cs%remap_axesCui(c) - call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCui(c)%decim(dl)%mask3d, dl) ! Interface v-points in diagnostic coordinate axes => diag_cs%remap_axesCvi(c) - call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCvi(c)%decim(dl)%mask3d, dl) ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) - call decimate_sample(axes%mask3d, axes%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesBi(c)%decim(dl)%mask3d, dl) enddo enddo end subroutine set_masks_for_axes_decim @@ -1232,16 +1236,16 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) ! Local variables real, dimension(:,:), pointer :: locfield => NULL() - real, dimension(:,:), pointer :: locmask => NULL() + real, dimension(:,:), pointer :: locmask character(len=300) :: mesg logical :: used, is_stat integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, i, j, chksum - real, dimension(:,:), pointer :: diag_axes_mask2d => NULL() real, dimension(:,:), allocatable, target :: locfield_decim real, dimension(:,:), allocatable, target :: locmask_decim - integer :: isl,iel,jsl,jel,dl + integer :: dl + locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static ! Determine the propery array indices, noting that because of the (:,:) @@ -1295,11 +1299,6 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) locfield => field endif - if (present(mask)) then - call assert(size(locfield) == size(mask), & - 'post_data_2d_low: mask size mismatch: '//diag%debug_str) - locmask => mask - endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) ) do j=jsv,jev ; do i=isv,iev @@ -1315,35 +1314,21 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) endif if (present(mask)) then - call assert(size(locfield) == size(mask), & - 'post_data_2d_low: mask size mismatch: '//diag%debug_str) locmask => mask + elseif(associated(diag%axes%mask2d)) then + locmask => diag%axes%mask2d endif - diag_axes_mask2d => diag%axes%mask2d dl = diag%axes%decimation_level if (dl > 1) then - isl=1; iel=size(field,1)/dl - jsl=1; jel=size(field,2)/dl - call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) -! allocate(locfield_decim(isl:iel,jsl:jel)) -! call decimate_diag_field_set(locfield, locfield_decim, dl,isl,iel,jsl,jel) - if (present(mask)) then - call decimate_sample(locfield, locfield_decim, dl, method='pave', mask=locmask) - elseif (associated(diag%axes%mask2d)) then - call decimate_sample(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask2d) - else - call decimate_sample(locfield, locfield_decim, dl, method='pave') !decimate without a mask, how ?? - endif + call decimate_diag_field(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) locfield => locfield_decim if (present(mask)) then -! allocate(locmask_decim(isl:iel,jsl:jel)) -! call decimate_diag_field_set(locmask, locmask_decim, dl,isl,iel,jsl,jel) - call decimate_sample(locmask, locmask_decim, dl) + call decimate_mask(locmask, locmask_decim, dl) locmask => locmask_decim - elseif (associated(diag%axes%decim(dl)%mask2d)) then - diag_axes_mask2d => diag%axes%decim(dl)%mask2d - endif + elseif(associated(diag%axes%decim(dl)%mask2d)) then + locmask => diag%axes%decim(dl)%mask2d + endif endif if (diag_cs%diag_as_chksum) then @@ -1366,18 +1351,12 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then - if (present(mask)) then + if (associated(locmask)) then call assert(size(locfield) == size(locmask), & 'post_data_2d_low: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int, rmask=locmask) - elseif (associated(diag_axes_mask2d)) then - call assert(size(locfield) == size(diag_axes_mask2d), & - 'post_data_2d_low: mask2d size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag_axes_mask2d) else used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & @@ -1520,7 +1499,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) ! Local variables real, dimension(:,:,:), pointer :: locfield => NULL() - real, dimension(:,:,:), pointer :: locmask => NULL() + real, dimension(:,:,:), pointer :: locmask character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. logical :: staggered_in_x, staggered_in_y @@ -1528,11 +1507,11 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c integer :: chksum - real, dimension(:,:,:), pointer :: diag_axes_mask3d => NULL() real, dimension(:,:,:), allocatable, target :: locfield_decim real, dimension(:,:,:), allocatable, target :: locmask_decim integer :: isl,iel,jsl,jel,dl + locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static ! Determine the proper array indices, noting that because of the (:,:) @@ -1604,36 +1583,21 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) endif if (present(mask)) then - call assert(size(locfield) == size(mask), & - 'post_data_3d_low: mask size mismatch: '//diag%debug_str) locmask => mask + elseif(associated(diag%axes%mask3d)) then + locmask => diag%axes%mask3d endif - - diag_axes_mask3d => diag%axes%mask3d + dl = diag%axes%decimation_level if (dl > 1) then - isl=1; iel=size(field,1)/dl - jsl=1; jel=size(field,2)/dl - call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) -! allocate(locfield_decim(isl:iel,jsl:jel,ks:ke)) -! call decimate_diag_field_set(locfield, locfield_decim, dl,isl,iel,jsl,jel,ks,ke) - if (present(mask)) then - call decimate_sample(locfield, locfield_decim, dl, method='pave', mask=locmask) - elseif (associated(diag%axes%mask3d)) then - call decimate_sample(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask3d) - else - !Niki: How are we supposed to aggregate/average without a mask if one or more aggregating cells are on land? - call decimate_sample(locfield, locfield_decim, dl, method='pave') !decimate without a mask, how ?? - endif + call decimate_diag_field(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) locfield => locfield_decim if (present(mask)) then -! allocate(locmask_decim(isl:iel,jsl:jel,ks:ke)) -! call decimate_diag_field_set(locmask, locmask_decim, dl,isl,iel,jsl,jel,ks,ke) - call decimate_sample(locmask, locmask_decim, dl) ! Niki: What is the correct method for mask? Defaults to subsample + call decimate_mask(locmask, locmask_decim, dl) locmask => locmask_decim - elseif (associated(diag%axes%decim(dl)%mask3d)) then - diag_axes_mask3d => diag%axes%decim(dl)%mask3d - endif + elseif(associated(diag%axes%decim(dl)%mask3d)) then + locmask => diag%axes%decim(dl)%mask3d + endif endif if (diag_cs%diag_as_chksum) then @@ -1656,18 +1620,12 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then - if (present(mask)) then + if (associated(locmask)) then call assert(size(locfield) == size(locmask), & 'post_data_3d_low: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int, rmask=locmask) - elseif (associated(diag_axes_mask3d)) then - call assert(size(locfield) == size(diag_axes_mask3d), & - 'post_data_3d_low: mask3d size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag_axes_mask3d) else used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & @@ -3393,10 +3351,10 @@ subroutine decimate_diag_masks_set(G, nz, diag_cs) do dl=2,MAX_DECIM_LEV ! 2d masks - call decimate_sample(G%mask2dT, diag_cs%decim(dl)%mask2dT, dl) - call decimate_sample(G%mask2dBu,diag_cs%decim(dl)%mask2dBu, dl) - call decimate_sample(G%mask2dCu,diag_cs%decim(dl)%mask2dCu, dl) - call decimate_sample(G%mask2dCv,diag_cs%decim(dl)%mask2dCv, dl) + call decimate_mask(G%mask2dT, diag_cs%decim(dl)%mask2dT, dl) + call decimate_mask(G%mask2dBu,diag_cs%decim(dl)%mask2dBu, dl) + call decimate_mask(G%mask2dCu,diag_cs%decim(dl)%mask2dCu, dl) + call decimate_mask(G%mask2dCv,diag_cs%decim(dl)%mask2dCv, dl) ! 3d native masks are needed by diag_manager but the native variables ! can only be masked 2d - for ocean points, all layers exists. allocate(diag_cs%decim(dl)%mask3dTL(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) @@ -3426,7 +3384,7 @@ subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) integer, intent(in) :: f1,f2 integer, intent(in) :: dl !< integer decimation level type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output - integer, intent(inout) ::isv,iev,jsv,jev + integer, intent(out) ::isv,iev,jsv,jev ! Local variables integer :: dszi,cszi,dszj,cszj character(len=300) :: mesg @@ -3467,65 +3425,58 @@ subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) end subroutine decimate_diag_indices_get -subroutine decimate_diag_field_set_3d(field_in, field_out, level ,isl,iel,jsl,jel,ks,ke) - real, dimension(:,:,:) , pointer :: field_in - real, dimension(:,:,:) , intent(inout) :: field_out - integer , intent(in) :: level, iel,jel,ks,ke - integer , intent(inout) :: isl,jsl - integer :: i,j,ii,jj,is,js - integer :: k - !Always start from the first element - is=1; isl=1 - js=1; jsl=1 - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - ii = is+level*(i-isl) - jj = js+level*(j-jsl) - field_out(i,j,k) = field_in(ii,jj,k) - enddo; enddo; enddo -end subroutine decimate_diag_field_set_3d - -subroutine decimate_diag_field_set_2d(field_in, field_out, level ,isl,iel,jsl,jel) - real, dimension(:,:) , pointer :: field_in - real, dimension(:,:), intent(inout) :: field_out - integer , intent(in) :: level, iel,jel - integer , intent(inout) :: isl,jsl - integer :: i,j,ii,jj,is,js - - !Always start from the first element - is=1; isl=1 - js=1; jsl=1 - do j=jsl,jel ; do i=isl,iel - ii = is+level*(i-isl) - jj = js+level*(j-jsl) - field_out(i,j) = field_in(ii,jj) - enddo; enddo -end subroutine decimate_diag_field_set_2d +subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + real, dimension(:,:,:), pointer :: locfield + real, dimension(:,:,:), allocatable, intent(inout) :: locfield_decim + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: dl + integer, intent(out):: isv,iev,jsv,jev + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + !locals + real, dimension(:,:,:), pointer :: locmask => NULL() + integer :: isl,iel,jsl,jel + isl=1; iel=size(locfield,1)/dl + jsl=1; jel=size(locfield,2)/dl + call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) + if (present(mask)) then + locmask => mask + call decimate_field(locfield, locfield_decim, dl, method='pave', mask=locmask) + elseif (associated(diag%axes%mask3d)) then + call decimate_field(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask3d) + else + call decimate_field(locfield, locfield_decim, dl, method='pave') !decimate without a mask, how ?? + endif +end subroutine decimate_diag_field_3d -subroutine decimate_sample_3d(field_in, field_out, level) - integer , intent(in) :: level - real, dimension(:,:,:) , pointer :: field_in, field_out - integer :: i,j,ii,jj,is,js +subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + real, dimension(:,:), pointer :: locfield + real, dimension(:,:), allocatable, intent(inout) :: locfield_decim + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: dl + integer, intent(out):: isv,iev,jsv,jev + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + !locals + real, dimension(:,:), pointer :: locmask => NULL() integer :: isl,iel,jsl,jel - integer :: k,ks,ke - ! is = lbound(field_in,1) ; ie = ubound(field_in,1) - ! js = lbound(field_in,2) ; je = ubound(field_in,2) - !Always start from the first element - is=1 - js=1 - ks = lbound(field_in,3) ; ke = ubound(field_in,3) - isl=1; iel=size(field_in,1)/level - jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel,ks:ke)) - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - ii = is+level*(i-isl) - jj = js+level*(j-jsl) - field_out(i,j,k) = field_in(ii,jj,k) - enddo; enddo; enddo -end subroutine decimate_sample_3d + isl=1; iel=size(locfield,1)/dl + jsl=1; jel=size(locfield,2)/dl + call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) + if (present(mask)) then + locmask => mask + call decimate_field(locfield, locfield_decim, dl, method='pave', mask=locmask) + elseif (associated(diag%axes%mask2d)) then + call decimate_field(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask2d) + else + call decimate_field(locfield, locfield_decim, dl, method='pave') !decimate without a mask, how ?? + endif -subroutine decimate_sample_3d_ptr(field_in, field_out, level, method, mask) +end subroutine decimate_diag_field_2d + +subroutine decimate_field_3d(field_in, field_out, level, method, mask) real, dimension(:,:,:) , pointer :: field_in real, dimension(:,:,:) , allocatable :: field_out integer , intent(in) :: level @@ -3583,12 +3534,12 @@ subroutine decimate_sample_3d_ptr(field_in, field_out, level, method, mask) enddo; enddo; enddo endif case default - call MOM_error(FATAL, "decimate_sample_3d_ptr: unknown sampling method "//trim(samplemethod)) + call MOM_error(FATAL, "decimate_field_3d: unknown sampling method "//trim(samplemethod)) end select -end subroutine decimate_sample_3d_ptr +end subroutine decimate_field_3d -subroutine decimate_sample_2d_ptr(field_in, field_out, level, method, mask) +subroutine decimate_field_2d(field_in, field_out, level, method, mask) real, dimension(:,:) , pointer :: field_in real, dimension(:,:) , allocatable :: field_out integer , intent(in) :: level @@ -3629,7 +3580,7 @@ subroutine decimate_sample_2d_ptr(field_in, field_out, level, method, mask) enddo; enddo field_out(i,j) = ave/max(1.0,tot_non_zero) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - else !Niki: How are we supposed to aggregate/average without a mask? What if field_in is on land at one or more aggregating cells? + else !Niki: How are we supposed to decimate/average without a mask? What if field_in is on land at one or more aggregating cells? do j=jsl,jel ; do i=isl,iel i0 = is+level*(i-isl) j0 = js+level*(j-jsl) @@ -3643,12 +3594,34 @@ subroutine decimate_sample_2d_ptr(field_in, field_out, level, method, mask) enddo; enddo endif case default - call MOM_error(FATAL, "decimate_sample_2d_ptr: unknown sampling method "//trim(samplemethod)) + call MOM_error(FATAL, "decimate_field_2d: unknown sampling method "//trim(samplemethod)) end select -end subroutine decimate_sample_2d_ptr +end subroutine decimate_field_2d + +subroutine decimate_mask_3d_p(field_in, field_out, level) + integer , intent(in) :: level + real, dimension(:,:,:) , pointer :: field_in, field_out + integer :: i,j,ii,jj,is,js + integer :: isl,iel,jsl,jel + integer :: k,ks,ke + ! is = lbound(field_in,1) ; ie = ubound(field_in,1) + ! js = lbound(field_in,2) ; je = ubound(field_in,2) + !Always start from the first element + is=1 + js=1 + ks = lbound(field_in,3) ; ke = ubound(field_in,3) + isl=1; iel=size(field_in,1)/level + jsl=1; jel=size(field_in,2)/level + allocate(field_out(isl:iel,jsl:jel,ks:ke)) + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + ii = is+level*(i-isl) + jj = js+level*(j-jsl) + field_out(i,j,k) = field_in(ii,jj,k) + enddo; enddo; enddo +end subroutine decimate_mask_3d_p -subroutine decimate_sample_2d(field_in, field_out, level) +subroutine decimate_mask_2d_p(field_in, field_out, level) integer , intent(in) :: level real, dimension(:,:) , intent(in) :: field_in real, dimension(:,:) , pointer :: field_out @@ -3665,6 +3638,49 @@ subroutine decimate_sample_2d(field_in, field_out, level) jj = js+level*(j-jsl) field_out(i,j) = field_in(ii,jj) enddo; enddo -end subroutine decimate_sample_2d +end subroutine decimate_mask_2d_p + +subroutine decimate_mask_3d_a(field_in, field_out, level) + integer , intent(in) :: level + real, dimension(:,:,:), pointer :: field_in + real, dimension(:,:,:), allocatable :: field_out + integer :: i,j,ii,jj,is,js + integer :: isl,iel,jsl,jel + integer :: k,ks,ke + ! is = lbound(field_in,1) ; ie = ubound(field_in,1) + ! js = lbound(field_in,2) ; je = ubound(field_in,2) + !Always start from the first element + is=1 + js=1 + ks = lbound(field_in,3) ; ke = ubound(field_in,3) + isl=1; iel=size(field_in,1)/level + jsl=1; jel=size(field_in,2)/level + allocate(field_out(isl:iel,jsl:jel,ks:ke)) + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + ii = is+level*(i-isl) + jj = js+level*(j-jsl) + field_out(i,j,k) = field_in(ii,jj,k) + enddo; enddo; enddo +end subroutine decimate_mask_3d_a + +subroutine decimate_mask_2d_a(field_in, field_out, level) + integer , intent(in) :: level + real, dimension(:,:) , intent(in) :: field_in + real, dimension(:,:) , allocatable :: field_out + integer :: i,j,ii,jj,is,js + integer :: isl,iel,jsl,jel + !Always start from the first element + is=1 + js=1 + isl=1; iel=size(field_in,1)/level + jsl=1; jel=size(field_in,2)/level + allocate(field_out(isl:iel,jsl:jel)) + do j=jsl,jel ; do i=isl,iel + ii = is+level*(i-isl) + jj = js+level*(j-jsl) + field_out(i,j) = field_in(ii,jj) + enddo; enddo +end subroutine decimate_mask_2d_a + end module MOM_diag_mediator From 373c23264bb9b56124d78f4b040c22169bc7a699 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Wed, 10 Oct 2018 11:39:22 -0400 Subject: [PATCH 09/18] Diag decimation prototype, fix masks for non-native grids - All decimated axes need to have the non-decimated mask3d fields initialized correctly. The non-decimated masks are being used in the decimation algorithm for the diagnostics fields --- src/framework/MOM_diag_mediator.F90 | 128 ++++++++++++++++++---------- 1 file changed, 85 insertions(+), 43 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 9bce490007..02033958f0 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -768,33 +768,44 @@ subroutine set_masks_for_axes_decim(G, diag_cs) integer :: dl type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience + !Each decimated axis needs both decimated and non-decimated mask + !The decimated mask is needed for sending out the diagnostics output via diag_manager + !The non-decimated mask is needed for decimating the diagnostics field do dl=2,MAX_DECIM_LEV if(dl .ne. 2) call MOM_error(FATAL, "Decimation level other than 2 is not supported yet!") do c=1, diag_cs%num_diag_coords ! Level/layer h-points in diagnostic coordinate axes => diag_cs%remap_axesTL(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesTL(c)%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesTL(c)%decim(dl)%mask3d, dl)!set decimated mask + diag_cs%decim(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-decimated mask ! Level/layer u-points in diagnostic coordinate axes => diag_cs%remap_axesCuL(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCuL(c)%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCuL(c)%decim(dl)%mask3d, dl)!set decimated mask + diag_cs%decim(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-decimated mask ! Level/layer v-points in diagnostic coordinate axes => diag_cs%remap_axesCvL(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCvL(c)%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCvL(c)%decim(dl)%mask3d, dl)!set decimated mask + diag_cs%decim(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-decimated mask ! Level/layer q-points in diagnostic coordinate axes => diag_cs%remap_axesBL(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesBL(c)%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesBL(c)%decim(dl)%mask3d, dl)!set decimated mask + diag_cs%decim(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-decimated mask ! Interface h-points in diagnostic coordinate (w-point) axes => diag_cs%remap_axesTi(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesTi(c)%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesTi(c)%decim(dl)%mask3d, dl)!set decimated mask + diag_cs%decim(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-decimated mask ! Interface u-points in diagnostic coordinate axes => diag_cs%remap_axesCui(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCui(c)%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCui(c)%decim(dl)%mask3d, dl)!set decimated mask + diag_cs%decim(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-decimated mask ! Interface v-points in diagnostic coordinate axes => diag_cs%remap_axesCvi(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCvi(c)%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCvi(c)%decim(dl)%mask3d, dl)!set decimated mask + diag_cs%decim(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-decimated mask ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesBi(c)%decim(dl)%mask3d, dl) + call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesBi(c)%decim(dl)%mask3d, dl)!set decimated mask + diag_cs%decim(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-decimated mask enddo enddo end subroutine set_masks_for_axes_decim @@ -3442,11 +3453,11 @@ subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,is call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) if (present(mask)) then locmask => mask - call decimate_field(locfield, locfield_decim, dl, method='pave', mask=locmask) + call decimate_field(locfield, locfield_decim, dl, method='pave', mask=locmask, area=diag_cs%G%areaT) elseif (associated(diag%axes%mask3d)) then - call decimate_field(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask3d) + call decimate_field(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask3d, area=diag_cs%G%areaT) else - call decimate_field(locfield, locfield_decim, dl, method='pave') !decimate without a mask, how ?? + call MOM_error(FATAL, "decimate_diag_field_3d: Cannot decimate without a mask!!! ") endif end subroutine decimate_diag_field_3d @@ -3471,22 +3482,23 @@ subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,is elseif (associated(diag%axes%mask2d)) then call decimate_field(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask2d) else - call decimate_field(locfield, locfield_decim, dl, method='pave') !decimate without a mask, how ?? + call MOM_error(FATAL, "decimate_diag_field_2d: Cannot decimate without a mask!!! ") endif end subroutine decimate_diag_field_2d -subroutine decimate_field_3d(field_in, field_out, level, method, mask) +subroutine decimate_field_3d(field_in, field_out, level, method, mask, area) real, dimension(:,:,:) , pointer :: field_in real, dimension(:,:,:) , allocatable :: field_out integer , intent(in) :: level character(len=4), optional, intent(in) :: method !< sampling method, one of samp,pave,aave,vave real, dimension(:,:,:), optional , pointer :: mask - !locals + real, dimension(:,:), optional , intent(in) :: area + !locals integer :: i,j,ii,jj,is,js,i0,j0 integer :: isl,iel,jsl,jel integer :: k,ks,ke - real :: ave,tot_non_zero + real :: ave,tot_non_zero,a1 character(len=4) :: samplemethod samplemethod = 'samp' if(present(method)) samplemethod = method @@ -3533,6 +3545,20 @@ subroutine decimate_field_3d(field_in, field_out, level, method, mask) field_out(i,j,k) = ave/tot_non_zero enddo; enddo; enddo endif + case ('aave') !area average of the cells + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + field_out(i,j,k) = 0.0 + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + ave = 0.0 + tot_non_zero = 0.0 + do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 + a1 = area(ii,jj)*mask(ii,jj,k) + tot_non_zero = tot_non_zero + a1 + ave=ave + field_in(ii,jj,k) * a1 + enddo; enddo + if(tot_non_zero .gt. 0.0) field_out(i,j,k) = ave/tot_non_zero + enddo; enddo; enddo case default call MOM_error(FATAL, "decimate_field_3d: unknown sampling method "//trim(samplemethod)) end select @@ -3602,22 +3628,25 @@ end subroutine decimate_field_2d subroutine decimate_mask_3d_p(field_in, field_out, level) integer , intent(in) :: level real, dimension(:,:,:) , pointer :: field_in, field_out - integer :: i,j,ii,jj,is,js + integer :: i,j,ii,jj,is,js,i0,j0 integer :: isl,iel,jsl,jel integer :: k,ks,ke - ! is = lbound(field_in,1) ; ie = ubound(field_in,1) - ! js = lbound(field_in,2) ; je = ubound(field_in,2) - !Always start from the first element + real :: tot_non_zero + !decimated mask = 0 unless the mask value of one of the decimating cells is 1 is=1 js=1 ks = lbound(field_in,3) ; ke = ubound(field_in,3) isl=1; iel=size(field_in,1)/level jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel,ks:ke)) + allocate(field_out(isl:iel,jsl:jel,ks:ke)); field_out(:,:,:) = 0.0 do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - ii = is+level*(i-isl) - jj = js+level*(j-jsl) - field_out(i,j,k) = field_in(ii,jj,k) + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + tot_non_zero = 0.0 + do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 + tot_non_zero = tot_non_zero + field_in(ii,jj,k) + enddo;enddo + if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 enddo; enddo; enddo end subroutine decimate_mask_3d_p @@ -3625,18 +3654,23 @@ subroutine decimate_mask_2d_p(field_in, field_out, level) integer , intent(in) :: level real, dimension(:,:) , intent(in) :: field_in real, dimension(:,:) , pointer :: field_out - integer :: i,j,ii,jj,is,js + integer :: i,j,ii,jj,is,js,i0,j0 integer :: isl,iel,jsl,jel - !Always start from the first element + real :: tot_non_zero + !decimated mask = 0 unless the mask value of one of the decimating cells is 1 is=1 js=1 isl=1; iel=size(field_in,1)/level jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel)) + allocate(field_out(isl:iel,jsl:jel)); field_out(:,:) = 0.0 do j=jsl,jel ; do i=isl,iel - ii = is+level*(i-isl) - jj = js+level*(j-jsl) - field_out(i,j) = field_in(ii,jj) + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + tot_non_zero = 0.0 + do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 + tot_non_zero = tot_non_zero + field_in(ii,jj) + enddo;enddo + if(tot_non_zero > 0.0) field_out(i,j)=1.0 enddo; enddo end subroutine decimate_mask_2d_p @@ -3644,22 +3678,25 @@ subroutine decimate_mask_3d_a(field_in, field_out, level) integer , intent(in) :: level real, dimension(:,:,:), pointer :: field_in real, dimension(:,:,:), allocatable :: field_out - integer :: i,j,ii,jj,is,js + integer :: i,j,ii,jj,is,js,i0,j0 integer :: isl,iel,jsl,jel integer :: k,ks,ke - ! is = lbound(field_in,1) ; ie = ubound(field_in,1) - ! js = lbound(field_in,2) ; je = ubound(field_in,2) - !Always start from the first element + real :: tot_non_zero + !decimated mask = 0 unless the mask value of one of the decimating cells is 1 is=1 js=1 ks = lbound(field_in,3) ; ke = ubound(field_in,3) isl=1; iel=size(field_in,1)/level jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel,ks:ke)) + allocate(field_out(isl:iel,jsl:jel,ks:ke)); field_out(:,:,:) = 0.0 do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - ii = is+level*(i-isl) - jj = js+level*(j-jsl) - field_out(i,j,k) = field_in(ii,jj,k) + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + tot_non_zero = 0.0 + do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 + tot_non_zero = tot_non_zero + field_in(ii,jj,k) + enddo;enddo + if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 enddo; enddo; enddo end subroutine decimate_mask_3d_a @@ -3667,18 +3704,23 @@ subroutine decimate_mask_2d_a(field_in, field_out, level) integer , intent(in) :: level real, dimension(:,:) , intent(in) :: field_in real, dimension(:,:) , allocatable :: field_out - integer :: i,j,ii,jj,is,js + integer :: i,j,ii,jj,is,js,i0,j0 integer :: isl,iel,jsl,jel - !Always start from the first element + real :: tot_non_zero + !decimated mask = 0 unless the mask value of one of the decimating cells is 1 is=1 js=1 isl=1; iel=size(field_in,1)/level jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel)) + allocate(field_out(isl:iel,jsl:jel)); field_out(:,:) = 0.0 do j=jsl,jel ; do i=isl,iel - ii = is+level*(i-isl) - jj = js+level*(j-jsl) - field_out(i,j) = field_in(ii,jj) + i0 = is+level*(i-isl) + j0 = js+level*(j-jsl) + tot_non_zero = 0.0 + do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 + tot_non_zero = tot_non_zero + field_in(ii,jj) + enddo;enddo + if(tot_non_zero > 0.0) field_out(i,j)=1.0 enddo; enddo end subroutine decimate_mask_2d_a From 2dd042a5c6c19ce41fc0884782e9ada733495a03 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 15 Oct 2018 17:30:54 -0400 Subject: [PATCH 10/18] Diag decimation prototype, first attemp at general algorithm - According to Alistair, the decimation method could be solely deduced from the axes%x_cell_method, axes%y_cell_method and probably the area_cell_method at the time of send_data - This is the summary of the algoritm f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)] Id,Jd are the decimated (coarse grid) indices run over the coarsened compute grid, i and j run from 0 to dl-1 (dl being the decimation level) if and jf weight(if,jf) run over the original fine computre grid x_cell_method y_cell_method area_cell_method weight(if,jf) example --------------------------------------------------------------------- ------------- mean mean mean A(if,jf)*h(if,jf) theta point mean mean dy(if,jf)*h(if,jf) u mean point mean dx(if,jf)*h(if,jf) v mean mean sum A(if,jf) h*theta sum sum sum 1 volcello point sum sum 1 umo --- src/framework/MOM_diag_mediator.F90 | 318 ++++++++++++++++++---------- 1 file changed, 201 insertions(+), 117 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 02033958f0..bed00b2355 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3434,8 +3434,6 @@ subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) endif end subroutine decimate_diag_indices_get - - subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) real, dimension(:,:,:), pointer :: locfield @@ -3446,20 +3444,46 @@ subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,is integer, intent(out):: isv,iev,jsv,jev real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. !locals - real, dimension(:,:,:), pointer :: locmask => NULL() - integer :: isl,iel,jsl,jel + real, dimension(:,:,:), pointer :: locmask + integer :: isl,iel,jsl,jel, xy_method + + locmask => NULL() + !Get the correct indices corresponding to input field + !Shape of the input diag field isl=1; iel=size(locfield,1)/dl - jsl=1; jel=size(locfield,2)/dl + jsl=1; jel=size(locfield,2)/dl + !Get the shape of the decimated field isv,iev,jsv,jev call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) + !Set the non-decimated mask, it must be associated and initialized if (present(mask)) then locmask => mask - call decimate_field(locfield, locfield_decim, dl, method='pave', mask=locmask, area=diag_cs%G%areaT) elseif (associated(diag%axes%mask3d)) then - call decimate_field(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask3d, area=diag_cs%G%areaT) + locmask => diag%axes%mask3d else call MOM_error(FATAL, "decimate_diag_field_3d: Cannot decimate without a mask!!! ") endif + !Determine the decimation method + !Make a two digit integer case id = x_case*10+y_case where x_case and/or y_case is 1 for sum and 2 for mean + xy_method = 0 !subsample and pick the SW corner value + if (trim(diag%axes%y_cell_method)=='sum') then + xy_method = xy_method + 1 + elseif (trim(diag%axes%y_cell_method)=='mean') then + xy_method = xy_method + 2 + endif + if (trim(diag%axes%x_cell_method)=='sum') then + xy_method = xy_method + 10 + elseif (trim(diag%axes%x_cell_method)=='mean') then + xy_method = xy_method + 20 + endif +! if (trim(diag%axes%area_cell_method)=='sum') then +! xy_method = xy_method + 100 +! elseif (trim(diag%axes%area_cell_method)=='mean') then +! xy_method = xy_method + 200 +! endif + + call decimate_field(locfield, locfield_decim, dl, xy_method, locmask, diag_cs) + end subroutine decimate_diag_field_3d subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) @@ -3471,157 +3495,217 @@ subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,is integer, intent(out):: isv,iev,jsv,jev real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. !locals - real, dimension(:,:), pointer :: locmask => NULL() - integer :: isl,iel,jsl,jel + real, dimension(:,:), pointer :: locmask + integer :: isl,iel,jsl,jel, xy_method + + locmask => NULL() + !Get the correct indices corresponding to input field + !Shape of the input diag field isl=1; iel=size(locfield,1)/dl - jsl=1; jel=size(locfield,2)/dl + jsl=1; jel=size(locfield,2)/dl + !Get the shape of the decimated field isv,iev,jsv,jev call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) + !Set the non-decimated mask, it must be associated and initialized if (present(mask)) then locmask => mask - call decimate_field(locfield, locfield_decim, dl, method='pave', mask=locmask) elseif (associated(diag%axes%mask2d)) then - call decimate_field(locfield, locfield_decim, dl, method='pave', mask=diag%axes%mask2d) + locmask => diag%axes%mask2d else call MOM_error(FATAL, "decimate_diag_field_2d: Cannot decimate without a mask!!! ") endif - + !Determine the decimation method + !Make a two digit integer case id = x_case*10+y_case where x_case and/or y_case is 1 for sum and 2 for mean + xy_method = 0 !subsample and pick the SW corner value + if (trim(diag%axes%y_cell_method)=='sum') then + xy_method = xy_method + 1 + elseif (trim(diag%axes%y_cell_method)=='mean') then + xy_method = xy_method + 2 + endif + if (trim(diag%axes%x_cell_method)=='sum') then + xy_method = xy_method + 10 + elseif (trim(diag%axes%x_cell_method)=='mean') then + xy_method = xy_method + 20 + endif +! if (trim(diag%axes%area_cell_method)=='sum') then +! xy_method = xy_method + 100 +! elseif (trim(diag%axes%area_cell_method)=='mean') then +! xy_method = xy_method + 200 +! endif + + call decimate_field(locfield, locfield_decim, dl, xy_method, locmask, diag_cs) + end subroutine decimate_diag_field_2d -subroutine decimate_field_3d(field_in, field_out, level, method, mask, area) +subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs) real, dimension(:,:,:) , pointer :: field_in real, dimension(:,:,:) , allocatable :: field_out - integer , intent(in) :: level - character(len=4), optional, intent(in) :: method !< sampling method, one of samp,pave,aave,vave - real, dimension(:,:,:), optional , pointer :: mask - real, dimension(:,:), optional , intent(in) :: area - !locals + integer , intent(in) :: dl + integer, optional, intent(in) :: method !< sampling method, one of 00,01,02,10,20,11,22 + real, dimension(:,:,:), pointer :: mask + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + !locals + character(len=240) :: mesg integer :: i,j,ii,jj,is,js,i0,j0 integer :: isl,iel,jsl,jel integer :: k,ks,ke - real :: ave,tot_non_zero,a1 - character(len=4) :: samplemethod - samplemethod = 'samp' - if(present(method)) samplemethod = method - + real :: ave,total_weight,weight + real :: epsilon = 1.0e-20 !Always start from the first element is=1 js=1 ks = lbound(field_in,3) ; ke = ubound(field_in,3) - isl=1; iel=size(field_in,1)/level - jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel,ks:ke)) + isl=1; iel=size(field_in,1)/dl + jsl=1; jel=size(field_in,2)/dl + allocate(field_out(isl:iel,jsl:jel,ks:ke)) - - select case (samplemethod) - case ('samp') !subsample the SW corner cell + if(method .eq. 0) then !point average the fields in dl^2 cells do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) - field_out(i,j,k) = field_in(i0,j0,k) + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + total_weight = total_weight + mask(ii,jj,k) + ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) + enddo; enddo + field_out(i,j,k) = ave/max(1.0,total_weight) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - case ('pave') !point average of the cells - if(present(mask)) then - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) - ave = 0.0 - tot_non_zero = 0.0 - do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 - tot_non_zero = tot_non_zero + mask(ii,jj,k) - ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) - enddo; enddo - field_out(i,j,k) = ave/max(1.0,tot_non_zero) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo; enddo; enddo - else - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) - ave = 0.0 - tot_non_zero = 0.0 - do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 - tot_non_zero = tot_non_zero + 1 - ave=ave+field_in(ii,jj,k) - enddo; enddo - field_out(i,j,k) = ave/tot_non_zero - enddo; enddo; enddo - endif - case ('aave') !area average of the cells + elseif(method .eq. 1) then !point in x, sum in y + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + total_weight = total_weight + mask(ii,jj,k) + ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. 10) then !sum in x, point in y + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + total_weight = total_weight + mask(ii,jj,k) + ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. 2) then !point in x, normal area average in y do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - field_out(i,j,k) = 0.0 - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) ave = 0.0 - tot_non_zero = 0.0 - do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 - a1 = area(ii,jj)*mask(ii,jj,k) - tot_non_zero = tot_non_zero + a1 - ave=ave + field_in(ii,jj,k) * a1 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj,k)*diag_cs%G%dyCu(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. 20) then !normal area average in x, point in y + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj,k)*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. 22) then !Volume average the fields in x and y + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight enddo; enddo - if(tot_non_zero .gt. 0.0) field_out(i,j,k) = ave/tot_non_zero + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - case default - call MOM_error(FATAL, "decimate_field_3d: unknown sampling method "//trim(samplemethod)) - end select - + elseif(method .eq. 11) then !sum the fields in x and y + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + total_weight = total_weight + mask(ii,jj,k) + ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) + enddo; enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + else + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "decimate_field_3d: "//trim(mesg)) + endif + end subroutine decimate_field_3d -subroutine decimate_field_2d(field_in, field_out, level, method, mask) +subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs) real, dimension(:,:) , pointer :: field_in real, dimension(:,:) , allocatable :: field_out - integer , intent(in) :: level - character(len=4), optional, intent(in) :: method !< sampling method, one of samp,pave,aave,vave - real, dimension(:,:), optional , pointer :: mask + integer , intent(in) :: dl + integer, optional, intent(in) :: method !< sampling method, one of 00,01,02,10,20,11,22 + real, dimension(:,:), pointer :: mask + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output !locals + character(len=240) :: mesg integer :: i,j,ii,jj,is,js,i0,j0 integer :: isl,iel,jsl,jel - real :: ave,tot_non_zero - character(len=4) :: samplemethod - samplemethod = 'samp' - if(present(method)) samplemethod = method - + real :: ave,total_weight,weight + real :: epsilon = 1.0e-20 !Always start from the first element is=1 js=1 - isl=1; iel=size(field_in,1)/level - jsl=1; jel=size(field_in,2)/level + isl=1; iel=size(field_in,1)/dl + jsl=1; jel=size(field_in,2)/dl allocate(field_out(isl:iel,jsl:jel)) - select case (samplemethod) - case ('samp') !subsample the SW corner cell + if(method .eq. 0) then !point average the fields in dl^2 cells do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) - field_out(i,j) = field_in(i0,j0) - enddo; enddo - case ('pave') !point average of the cells - if(present(mask)) then - do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) - ave = 0.0 - tot_non_zero = 0.0 - do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 - tot_non_zero = tot_non_zero + mask(ii,jj) - ave=ave+field_in(ii,jj)*mask(ii,jj) - enddo; enddo - field_out(i,j) = ave/max(1.0,tot_non_zero) !Avoid zero mask at all aggregating cells where ave=0.0 + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + total_weight = total_weight + mask(ii,jj) + ave=ave+field_in(ii,jj)*mask(ii,jj) enddo; enddo - else !Niki: How are we supposed to decimate/average without a mask? What if field_in is on land at one or more aggregating cells? - do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) - ave = 0.0 - tot_non_zero = 0.0 - do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 - tot_non_zero = tot_non_zero + 1 - ave=ave+field_in(ii,jj) - enddo; enddo - field_out(i,j) = ave/tot_non_zero + field_out(i,j) = ave/max(1.0,total_weight) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. 22) then !Volume average the fields in x and y + do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,1) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj)*weight enddo; enddo - endif - case default - call MOM_error(FATAL, "decimate_field_2d: unknown sampling method "//trim(samplemethod)) - end select + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + + else + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "decimate_field_2d: "//trim(mesg)) + endif end subroutine decimate_field_2d From 0a3335fb0ea95b595da9656ab8ec52a3aa799034 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 18 Oct 2018 15:16:48 -0400 Subject: [PATCH 11/18] Diag decimation prototype, decimation algorithm extension - This commit extends the proposed decimatipn algorithm to cover all the present diagnostics in the OM4_025 diag_table There may be more cases that need to be coded up later --- src/framework/MOM_diag_mediator.F90 | 364 ++++++++++++++++++++-------- 1 file changed, 265 insertions(+), 99 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index bed00b2355..0fe947423a 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -142,6 +142,25 @@ module MOM_diag_mediator type(diag_grids_type), dimension(:), allocatable :: diag_grids !< Primarily empty, except h field end type diag_grid_storage +!> integers to encode the total cell methods +integer :: PPP=0 !< x:point,y:point,z:point +integer :: PPS=1 !< x:point,y:point,z:sum +integer :: PPM=2 !< x:point,y:point,z:mean +integer :: PSP=10 !< x:point,y:sum,z:point +integer :: PSS=11 !< x:point,y:sum,z:point +integer :: PSM=12 !< x:point,y:sum,z:mean +integer :: PMP=20 !< x:point,y:mean,z:point +integer :: PMM=22 !< x:point,y:mean,z:mean +integer :: SPP=100 !< x:sum,y:point,z:point +integer :: SPS=101 !< x:sum,y:point,z:sum +integer :: SSP=110 !< x:sum;y:sum,z:point +integer :: MPP=200 !< x:mean,y:point,z:point +integer :: MPM=202 !< x:mean,y:point,z:mean +integer :: MMP=220 !< x:mean,y:mean,z:point +integer :: MMS=221 !< x:mean,y:mean,z:sum +integer :: SSS=111 !< x:sum,y:sum,z:sum +integer :: MMM=222 !< x:mean,y:mean,z:mean + !> This type is used to represent a diagnostic at the diag_mediator level. !! !! There can be both 'primary' and 'seconday' diagnostics. The primaries @@ -160,6 +179,8 @@ module MOM_diag_mediator real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). !! False for intensive (concentrations). + integer :: xyz_method = 0 !< A 3 digit integer encoding the diagnostics cell method + !! It can be used to determine the decimation algorithm end type diag_type type diagcs_decim @@ -290,8 +311,6 @@ module MOM_diag_mediator end type diag_ctrl - - ! CPU clocks integer :: id_clock_diag_mediator, id_clock_diag_remap, id_clock_diag_grid_updates @@ -1246,7 +1265,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. ! Local variables - real, dimension(:,:), pointer :: locfield => NULL() + real, dimension(:,:), pointer :: locfield real, dimension(:,:), pointer :: locmask character(len=300) :: mesg logical :: used, is_stat @@ -1256,6 +1275,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) real, dimension(:,:), allocatable, target :: locmask_decim integer :: dl + locfield => NULL() locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1326,13 +1346,15 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) if (present(mask)) then locmask => mask - elseif(associated(diag%axes%mask2d)) then - locmask => diag%axes%mask2d + elseif(.NOT. is_stat) then + if(associated(diag%axes%mask2d)) locmask => diag%axes%mask2d endif - dl = diag%axes%decimation_level + dl=1 + if(.NOT. is_stat) dl = diag%axes%decimation_level if (dl > 1) then call decimate_diag_field(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) locfield => locfield_decim if (present(mask)) then call decimate_mask(locmask, locmask_decim, dl) @@ -1375,7 +1397,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) endif endif endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & deallocate( locfield ) end subroutine post_data_2d_low @@ -1509,7 +1531,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. ! Local variables - real, dimension(:,:,:), pointer :: locfield => NULL() + real, dimension(:,:,:), pointer :: locfield real, dimension(:,:,:), pointer :: locmask character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. @@ -1522,6 +1544,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) real, dimension(:,:,:), allocatable, target :: locmask_decim integer :: isl,iel,jsl,jel,dl + locfield => NULL() locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1599,9 +1622,11 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) locmask => diag%axes%mask3d endif - dl = diag%axes%decimation_level + dl=1 + if(.NOT. is_stat) dl = diag%axes%decimation_level if (dl > 1) then call decimate_diag_field(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) locfield => locfield_decim if (present(mask)) then call decimate_mask(locmask, locmask_decim, dl) @@ -1644,7 +1669,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) endif endif endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & deallocate( locfield ) end subroutine post_data_3d_low @@ -2077,7 +2102,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) this_diag%fms_xyave_diag_id = fms_xyave_id - + call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) if (present(v_extensive)) this_diag%v_extensive = v_extensive if (present(conversion)) this_diag%conversion_factor = conversion register_diag_field_expand_cmor = .true. @@ -2137,7 +2162,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) this_diag%fms_xyave_diag_id = fms_xyave_id - + call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) if (present(v_extensive)) this_diag%v_extensive = v_extensive if (present(conversion)) this_diag%conversion_factor = conversion register_diag_field_expand_cmor = .true. @@ -2273,6 +2298,67 @@ subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name end subroutine add_diag_to_list +subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) + type(diag_type), pointer :: diag !< This diagnostic + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields + !! (vertically integrated). Default/absent for intensive. + integer :: xyz_method + character(len=9) :: mstr + + !This is a simple way to encode the cell method information made from 3 strings + !(x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz + !x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean' + !We can encode these with setting 0 for 'point', 1 for 'sum, 2 for 'mean' in + !the 100s position for x, 10s position for y, 1s position for z + !E.g., x:sum,y:point,z:mean is 102 + + xyz_method = 0 + + mstr = diag%axes%v_cell_method + if (present(v_extensive)) then + if (present(v_cell_method)) call MOM_error(FATAL, "attach_cell_methods: " // & + 'Vertical cell method was specified along with the vertically extensive flag.') + if(v_extensive) then + mstr='sum' + else + mstr='mean' + endif + elseif (present(v_cell_method)) then + mstr = v_cell_method + endif + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 1 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 2 + endif + + mstr = diag%axes%y_cell_method + if (present(y_cell_method)) mstr = y_cell_method + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 10 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 20 + endif + + mstr = diag%axes%x_cell_method + if (present(x_cell_method)) mstr = x_cell_method + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 100 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 200 + endif + + diag%xyz_method = xyz_method +end subroutine add_xyz_method + !> Attaches "cell_methods" attribute to a variable based on defaults for axes_grp or optional arguments. subroutine attach_cell_methods(id, axes, ostring, cell_methods, & x_cell_method, y_cell_method, v_cell_method, v_extensive) @@ -2360,6 +2446,7 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(v_cell_method) endif elseif (present(v_extensive)) then + if(v_extensive) then if (axes%rank==1) then call get_diag_axis_name(axes%handles(1), axis_name) elseif (axes%rank==3) then @@ -2367,6 +2454,7 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & endif call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':sum') ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':sum' + endif else if (len(trim(axes%v_cell_method))>0) then if (axes%rank==1) then @@ -3445,7 +3533,7 @@ subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,is real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. !locals real, dimension(:,:,:), pointer :: locmask - integer :: isl,iel,jsl,jel, xy_method + integer :: isl,iel,jsl,jel locmask => NULL() !Get the correct indices corresponding to input field @@ -3462,27 +3550,8 @@ subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,is else call MOM_error(FATAL, "decimate_diag_field_3d: Cannot decimate without a mask!!! ") endif - !Determine the decimation method - !Make a two digit integer case id = x_case*10+y_case where x_case and/or y_case is 1 for sum and 2 for mean - xy_method = 0 !subsample and pick the SW corner value - if (trim(diag%axes%y_cell_method)=='sum') then - xy_method = xy_method + 1 - elseif (trim(diag%axes%y_cell_method)=='mean') then - xy_method = xy_method + 2 - endif - if (trim(diag%axes%x_cell_method)=='sum') then - xy_method = xy_method + 10 - elseif (trim(diag%axes%x_cell_method)=='mean') then - xy_method = xy_method + 20 - endif -! if (trim(diag%axes%area_cell_method)=='sum') then -! xy_method = xy_method + 100 -! elseif (trim(diag%axes%area_cell_method)=='mean') then -! xy_method = xy_method + 200 -! endif - - call decimate_field(locfield, locfield_decim, dl, xy_method, locmask, diag_cs) + call decimate_field(locfield, locfield_decim, dl, diag%xyz_method, locmask, diag_cs, diag) end subroutine decimate_diag_field_3d @@ -3496,7 +3565,7 @@ subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,is real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. !locals real, dimension(:,:), pointer :: locmask - integer :: isl,iel,jsl,jel, xy_method + integer :: isl,iel,jsl,jel locmask => NULL() !Get the correct indices corresponding to input field @@ -3513,36 +3582,45 @@ subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,is else call MOM_error(FATAL, "decimate_diag_field_2d: Cannot decimate without a mask!!! ") endif - !Determine the decimation method - !Make a two digit integer case id = x_case*10+y_case where x_case and/or y_case is 1 for sum and 2 for mean - xy_method = 0 !subsample and pick the SW corner value - if (trim(diag%axes%y_cell_method)=='sum') then - xy_method = xy_method + 1 - elseif (trim(diag%axes%y_cell_method)=='mean') then - xy_method = xy_method + 2 - endif - if (trim(diag%axes%x_cell_method)=='sum') then - xy_method = xy_method + 10 - elseif (trim(diag%axes%x_cell_method)=='mean') then - xy_method = xy_method + 20 - endif -! if (trim(diag%axes%area_cell_method)=='sum') then -! xy_method = xy_method + 100 -! elseif (trim(diag%axes%area_cell_method)=='mean') then -! xy_method = xy_method + 200 -! endif - call decimate_field(locfield, locfield_decim, dl, xy_method, locmask, diag_cs) + call decimate_field(locfield, locfield_decim, dl, diag%xyz_method, locmask, diag_cs,diag) end subroutine decimate_diag_field_2d -subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs) + +!- According to Alistair, the decimation method could be solely deduced +! from the axes%x_cell_method, axes%y_cell_method and probably the area_cell_method +! at the time of send_data +!- This is the summary of the algoritm +! f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)] +! Id,Jd are the decimated (coarse grid) indices run over the coarsened compute grid, +! i and j run from 0 to dl-1 (dl being the decimation level) +! if and jf +! weight(if,jf) run over the original fine computre grid +! +!example x_cell y_cell ?_cell weight impemented weight(if,jf) algorithm_id +!--------------------------------------------------------------------------------------- +!theta mean mean mean A*h A(if,jf)*h(if,jf) 22 +!u point mean mean dy*h dyCu(if,jf)*h(if,jf)*delta(if,Id) 02 +!v mean point mean dx*h dxCv(if,jf)*h(if,jf)*delta(jf,Jd) 20 +!volcello sum sum sum 1 1 11 +!umo point sum sum 1 1*delta(if,Id) 01 +!? sum point sum 1 1*delta(jf,Jd) 10 +!w mean mean point A N/A +!h*theta mean mean sum A N/A +! +!delta is the Kroneker delta +!Niki: I am not sure if he meant area_cell_method or z_cell_method for the 4th column +!Niki: I have not used the 4th column at all!!! + +subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag) real, dimension(:,:,:) , pointer :: field_in real, dimension(:,:,:) , allocatable :: field_out integer , intent(in) :: dl integer, optional, intent(in) :: method !< sampling method, one of 00,01,02,10,20,11,22 real, dimension(:,:,:), pointer :: mask type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post !locals character(len=240) :: mesg integer :: i,j,ii,jj,is,js,i0,j0 @@ -3553,50 +3631,65 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs) !Always start from the first element is=1 js=1 - ks = lbound(field_in,3) ; ke = ubound(field_in,3) + ks=1 ; ke =size(field_in,3) isl=1; iel=size(field_in,1)/dl jsl=1; jel=size(field_in,2)/dl allocate(field_out(isl:iel,jsl:jel,ks:ke)) - if(method .eq. 0) then !point average the fields in dl^2 cells + if(method .eq. MMM) then !xyz_method = MMM = 222 do k= ks,ke ; do j=jsl,jel ; do i=isl,iel i0 = is+dl*(i-isl) j0 = js+dl*(j-jsl) ave = 0.0 total_weight = 0.0 do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - total_weight = total_weight + mask(ii,jj,k) - ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) + weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight enddo; enddo - field_out(i,j,k) = ave/max(1.0,total_weight) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. 1) then !point in x, sum in y + elseif(method .eq. SSS) then !xyz_method = SSS = 111 e.g., volcello do k= ks,ke ; do j=jsl,jel ; do i=isl,iel i0 = is+dl*(i-isl) j0 = js+dl*(j-jsl) ave = 0.0 total_weight = 0.0 - ii=i0 - do jj=j0,j0+dl-1 - total_weight = total_weight + mask(ii,jj,k) - ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) - enddo + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo; enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. 10) then !sum in x, point in y + elseif(method .eq. MMP .or. method .eq. MMS) then !xyz_method = MMP = 220, e.g., or T_advection_xy do k= ks,ke ; do j=jsl,jel ; do i=isl,iel i0 = is+dl*(i-isl) j0 = js+dl*(j-jsl) ave = 0.0 total_weight = 0.0 - jj=j0 - do ii=i0,i0+dl-1 - total_weight = total_weight + mask(ii,jj,k) - ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo; enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. PMM) then !xyz_method = PMM = 022 + do k= ks,ke ; do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj,k)*diag_cs%G%dyCu(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. 2) then !point in x, normal area average in y + elseif(method .eq. PSM) then !xyz_method = PSM = 012 do k= ks,ke ; do j=jsl,jel ; do i=isl,iel i0 = is+dl*(i-isl) j0 = js+dl*(j-jsl) @@ -3610,59 +3703,63 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs) enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. 20) then !normal area average in x, point in y + elseif(method .eq. PSS) then !xyz_method = PSS = 011 e.g. umo do k= ks,ke ; do j=jsl,jel ; do i=isl,iel i0 = is+dl*(i-isl) j0 = js+dl*(j-jsl) ave = 0.0 total_weight = 0.0 - jj=j0 - do ii=i0,i0+dl-1 - weight = mask(ii,jj,k)*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k) - total_weight = total_weight + weight + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj,k) + total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. 22) then !Volume average the fields in x and y + elseif(method .eq. SPS) then !xyz_method = SPS = 101 e.g. vmo do k= ks,ke ; do j=jsl,jel ; do i=isl,iel i0 = is+dl*(i-isl) j0 = js+dl*(j-jsl) ave = 0.0 total_weight = 0.0 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,k) - total_weight = total_weight + weight + jj=j0 + do ii=i0,i0+dl-1 + weight =mask(ii,jj,k) + total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight - enddo; enddo + enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. 11) then !sum the fields in x and y + elseif(method .eq. MPM) then !xyz_method = MPM = 202 do k= ks,ke ; do j=jsl,jel ; do i=isl,iel i0 = is+dl*(i-isl) j0 = js+dl*(j-jsl) ave = 0.0 total_weight = 0.0 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - total_weight = total_weight + mask(ii,jj,k) - ave=ave+field_in(ii,jj,k)*mask(ii,jj,k) - enddo; enddo + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj,k)*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo; enddo; enddo + enddo; enddo; enddo else write (mesg,*) " unknown sampling method: ",method - call MOM_error(FATAL, "decimate_field_3d: "//trim(mesg)) + call MOM_error(FATAL, "decimate_field_3d: "//trim(mesg)//" "//trim(diag%debug_str)) endif end subroutine decimate_field_3d -subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs) +subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag) real, dimension(:,:) , pointer :: field_in real, dimension(:,:) , allocatable :: field_out integer , intent(in) :: dl integer, optional, intent(in) :: method !< sampling method, one of 00,01,02,10,20,11,22 real, dimension(:,:), pointer :: mask type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post !locals character(len=240) :: mesg integer :: i,j,ii,jj,is,js,i0,j0 @@ -3675,36 +3772,105 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs) isl=1; iel=size(field_in,1)/dl jsl=1; jel=size(field_in,2)/dl allocate(field_out(isl:iel,jsl:jel)) - - if(method .eq. 0) then !point average the fields in dl^2 cells + + if(method .eq. MMM) then !xyz_method = MMM do j=jsl,jel ; do i=isl,iel i0 = is+dl*(i-isl) j0 = js+dl*(j-jsl) ave = 0.0 total_weight = 0.0 do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - total_weight = total_weight + mask(ii,jj) - ave=ave+field_in(ii,jj)*mask(ii,jj) + weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,1) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj)*weight enddo; enddo - field_out(i,j) = ave/max(1.0,total_weight) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. 22) then !Volume average the fields in x and y + elseif(method .eq. MMP) then !xyz_method = MMP do j=jsl,jel ; do i=isl,iel i0 = is+dl*(i-isl) j0 = js+dl*(j-jsl) ave = 0.0 total_weight = 0.0 do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,1) - total_weight = total_weight + weight + weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight ave=ave+field_in(ii,jj)*weight enddo; enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - + elseif(method .eq. SSP) then !xyz_method = SSP , e.g., T_dfxy_cont_tendency_2d + do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj)*weight + enddo; enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. PSP) then !xyz_method = PSP = 010, e.g., umo_2d + do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. SPP) then !xyz_method = SPP = 100, e.g., vmo_2d + do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight =mask(ii,jj) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. PMP) then !xyz_method = PMP = 020 + do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj)*diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. MPP) then !xyz_method = MPP = 200 + do j=jsl,jel ; do i=isl,iel + i0 = is+dl*(i-isl) + j0 = js+dl*(j-jsl) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight =mask(ii,jj)*diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo else write (mesg,*) " unknown sampling method: ",method - call MOM_error(FATAL, "decimate_field_2d: "//trim(mesg)) + call MOM_error(FATAL, "decimate_field_2d: "//trim(mesg)//" "//trim(diag%debug_str)) endif end subroutine decimate_field_2d From d748764c7176b25f6ad44c80847c1715b85cec2d Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 23 Oct 2018 10:31:57 -0400 Subject: [PATCH 12/18] Diag decimation, fixed the decimated fields indices --- src/framework/MOM_diag_mediator.F90 | 365 ++++++++++++++-------------- 1 file changed, 187 insertions(+), 178 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 0fe947423a..881c77a76f 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1330,20 +1330,6 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) locfield => field endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then - allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) ) - do j=jsv,jev ; do i=isv,iev - if (field(i,j) == diag_cs%missing_value) then - locfield(i,j) = diag_cs%missing_value - else - locfield(i,j) = field(i,j) * diag%conversion_factor - endif - enddo ; enddo - locfield(isv:iev,jsv:jev) = field(isv:iev,jsv:jev) * diag%conversion_factor - else - locfield => field - endif - if (present(mask)) then locmask => mask elseif(.NOT. is_stat) then @@ -1633,7 +1619,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) locmask => locmask_decim elseif(associated(diag%axes%decim(dl)%mask3d)) then locmask => diag%axes%decim(dl)%mask3d - endif + endif endif if (diag_cs%diag_as_chksum) then @@ -3443,10 +3429,10 @@ subroutine decimate_diag_masks_set(G, nz, diag_cs) !print*,'coarse c extents ',G%isc_zap2,G%iec_zap2,G%jsc_zap2,G%jec_zap2 !print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed !print*,'coarse d extents ',G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2 -! original c extents 5 52 5 64 -! coarse c extents 5 28 5 34 -! original d extents 1 56 1 68 -! coarse d extents 1 32 1 38 +! original c extents 5 52 5 52 +! coarse c extents 3 26 3 26 +! original d extents 1 56 1 56 +! coarse d extents 1 28 1 28 do dl=2,MAX_DECIM_LEV ! 2d masks @@ -3495,7 +3481,8 @@ subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec if ( f1 == dszi ) then - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec ! Data domain + isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec ! field on Data domain, take compute domain indcies + !The rest is not taken with the full MOM6 diag_table elseif ( f1 == dszi + 1 ) then isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec+1 ! Symmetric data domain elseif ( f1 == cszi) then @@ -3505,7 +3492,7 @@ subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) else write (mesg,*) " peculiar size ",f1," in i-direction\n"//& "does not match one of ", cszi, cszi+1, dszi, dszi+1 - call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) + call MOM_error(FATAL,"decimate_diag_indices_get: "//trim(mesg)) endif if ( f2 == dszj ) then jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec ! Data domain @@ -3518,7 +3505,7 @@ subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) else write (mesg,*) " peculiar size ",f2," in j-direction\n"//& "does not match one of ", cszj, cszj+1, dszj, dszj+1 - call MOM_error(FATAL,"decimate_diag_field: "//trim(mesg)) + call MOM_error(FATAL,"decimate_diag_indices_get: "//trim(mesg)) endif end subroutine decimate_diag_indices_get @@ -3529,19 +3516,21 @@ subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,is type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: dl - integer, intent(out):: isv,iev,jsv,jev + integer, intent(inout):: isv,iev,jsv,jev real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. !locals real, dimension(:,:,:), pointer :: locmask - integer :: isl,iel,jsl,jel + integer :: f1,f2,isv_o,jsv_o locmask => NULL() !Get the correct indices corresponding to input field !Shape of the input diag field - isl=1; iel=size(locfield,1)/dl - jsl=1; jel=size(locfield,2)/dl - !Get the shape of the decimated field isv,iev,jsv,jev - call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) + f1=size(locfield,1)/dl + f2=size(locfield,2)/dl + !Save the extents of the original (fine) domain + isv_o=isv;jsv_o=jsv + !Get the shape of the decimated field and overwrite isv,iev,jsv,jev with them + call decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) !Set the non-decimated mask, it must be associated and initialized if (present(mask)) then locmask => mask @@ -3551,7 +3540,8 @@ subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,is call MOM_error(FATAL, "decimate_diag_field_3d: Cannot decimate without a mask!!! ") endif - call decimate_field(locfield, locfield_decim, dl, diag%xyz_method, locmask, diag_cs, diag) + call decimate_field(locfield, locfield_decim, dl, diag%xyz_method, locmask, diag_cs, diag, & + isv_o,jsv_o,isv,iev,jsv,jev) end subroutine decimate_diag_field_3d @@ -3565,15 +3555,17 @@ subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,is real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. !locals real, dimension(:,:), pointer :: locmask - integer :: isl,iel,jsl,jel + integer :: f1,f2,isv_o,jsv_o locmask => NULL() !Get the correct indices corresponding to input field !Shape of the input diag field - isl=1; iel=size(locfield,1)/dl - jsl=1; jel=size(locfield,2)/dl - !Get the shape of the decimated field isv,iev,jsv,jev - call decimate_diag_indices_get(iel,jel, dl, diag_cs,isv,iev,jsv,jev) + f1=size(locfield,1)/dl + f2=size(locfield,2)/dl + !Save the extents of the original (fine) domain + isv_o=isv;jsv_o=jsv + !Get the shape of the decimated field and overwrite isv,iev,jsv,jev with them + call decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) !Set the non-decimated mask, it must be associated and initialized if (present(mask)) then locmask => mask @@ -3583,66 +3575,70 @@ subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,is call MOM_error(FATAL, "decimate_diag_field_2d: Cannot decimate without a mask!!! ") endif - call decimate_field(locfield, locfield_decim, dl, diag%xyz_method, locmask, diag_cs,diag) + call decimate_field(locfield, locfield_decim, dl, diag%xyz_method, locmask, diag_cs,diag, & + isv_o,jsv_o,isv,iev,jsv,jev) end subroutine decimate_diag_field_2d -!- According to Alistair, the decimation method could be solely deduced -! from the axes%x_cell_method, axes%y_cell_method and probably the area_cell_method -! at the time of send_data -!- This is the summary of the algoritm +!- The decimation method could be deduced (before send_data call) +! from the diag%x_cell_method, diag%y_cell_method and diag%v_cell_method +! +!- This is the summary of the decimation algoritm for a diagnostic field f: ! f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)] -! Id,Jd are the decimated (coarse grid) indices run over the coarsened compute grid, ! i and j run from 0 to dl-1 (dl being the decimation level) -! if and jf -! weight(if,jf) run over the original fine computre grid +! Id,Jd are the decimated (coarse grid) indices run over the coarsened compute grid, +! if and jf are the original (fine grid) indices ! -!example x_cell y_cell ?_cell weight impemented weight(if,jf) algorithm_id +!example x_cell y_cell v_cell algorithm_id impemented weight(if,jf) !--------------------------------------------------------------------------------------- -!theta mean mean mean A*h A(if,jf)*h(if,jf) 22 -!u point mean mean dy*h dyCu(if,jf)*h(if,jf)*delta(if,Id) 02 -!v mean point mean dx*h dxCv(if,jf)*h(if,jf)*delta(jf,Jd) 20 -!volcello sum sum sum 1 1 11 -!umo point sum sum 1 1*delta(if,Id) 01 -!? sum point sum 1 1*delta(jf,Jd) 10 -!w mean mean point A N/A -!h*theta mean mean sum A N/A +!theta mean mean mean MMM =222 G%areaT(if,jf)*h(if,jf) +!u point mean mean PMM =022 dyCu(if,jf)*h(if,jf)*delta(if,Id) +!? point sum mean PSM =012 dyCu(if,jf)*h(if,jf)*delta(if,Id) right? +!v mean point mean MPM =202 dxCv(if,jf)*h(if,jf)*delta(jf,Jd) +!volcello sum sum sum SSS =111 1 +!T_dfxy_co sum sum point SSP =110 1 right? T_dfxy_cont_tendency_2d +!umo point sum sum PSS =011 1*delta(if,Id) +!vmo sum point sum SPS =101 1*delta(jf,Jd) +!umo_2d point sum point PSP =010 1*delta(if,Id) right? +!vmo_2d sum point point SPP =100 1*delta(jf,Jd) right? +!? point mean point PMP =020 dyCu(if,jf)*delta(if,Id) right? +!? mean point point MPP =200 dxCv(if,jf)*delta(jf,Jd) right? +!w mean mean point MMP =220 G%areaT(if,jf) +!h*theta mean mean sum MMS =221 G%areaT(if,jf) right? ! !delta is the Kroneker delta -!Niki: I am not sure if he meant area_cell_method or z_cell_method for the 4th column -!Niki: I have not used the 4th column at all!!! -subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag) +subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) real, dimension(:,:,:) , pointer :: field_in real, dimension(:,:,:) , allocatable :: field_out integer , intent(in) :: dl - integer, optional, intent(in) :: method !< sampling method, one of 00,01,02,10,20,11,22 + integer, intent(in) :: method !< sampling method, one of 00,01,02,10,20,11,22 real, dimension(:,:,:), pointer :: mask type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer , intent(in) :: isv_o,jsv_o !< original indices, In practice isv_o=jsv_o=1 + integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< decimaed indices !locals character(len=240) :: mesg - integer :: i,j,ii,jj,is,js,i0,j0 - integer :: isl,iel,jsl,jel + integer :: i,j,ii,jj,i0,j0 integer :: k,ks,ke real :: ave,total_weight,weight real :: epsilon = 1.0e-20 - !Always start from the first element - is=1 - js=1 - ks=1 ; ke =size(field_in,3) - isl=1; iel=size(field_in,1)/dl - jsl=1; jel=size(field_in,2)/dl - allocate(field_out(isl:iel,jsl:jel,ks:ke)) + ks=1 ; ke =size(field_in,3) + !Allocate the decimated field on the decimated data domain + allocate(field_out(diag_cs%decim(dl)%isd:diag_cs%decim(dl)%ied,diag_cs%decim(dl)%jsd:diag_cs%decim(dl)%jed,ks:ke)) +! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke)) + !Fill the decimated field on the decimated diagnostics (almost always compuate) domain if(method .eq. MMM) then !xyz_method = MMM = 222 - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!! weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,k) total_weight = total_weight + weight ave=ave+field_in(ii,jj,k)*weight @@ -3650,12 +3646,13 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo elseif(method .eq. SSS) then !xyz_method = SSS = 111 e.g., volcello - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj,k) total_weight = total_weight + weight ave=ave+field_in(ii,jj,k)*weight @@ -3663,12 +3660,13 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo elseif(method .eq. MMP .or. method .eq. MMS) then !xyz_method = MMP = 220, e.g., or T_advection_xy - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight ave=ave+field_in(ii,jj,k)*weight @@ -3676,9 +3674,9 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo elseif(method .eq. PMM) then !xyz_method = PMM = 022 - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 ii=i0 @@ -3690,9 +3688,9 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo elseif(method .eq. PSM) then !xyz_method = PSM = 012 - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 ii=i0 @@ -3704,9 +3702,9 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo elseif(method .eq. PSS) then !xyz_method = PSS = 011 e.g. umo - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 ii=i0 @@ -3718,9 +3716,9 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo elseif(method .eq. SPS) then !xyz_method = SPS = 101 e.g. vmo - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 jj=j0 @@ -3732,9 +3730,9 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo elseif(method .eq. MPM) then !xyz_method = MPM = 202 - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 jj=j0 @@ -3752,7 +3750,7 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia end subroutine decimate_field_3d -subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag) +subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) real, dimension(:,:) , pointer :: field_in real, dimension(:,:) , allocatable :: field_out integer , intent(in) :: dl @@ -3760,26 +3758,27 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag real, dimension(:,:), pointer :: mask type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer , intent(in) :: isv_o,jsv_o !< original indices, In practice isv_o=jsv_o=1 + integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< decimaed indices !locals character(len=240) :: mesg - integer :: i,j,ii,jj,is,js,i0,j0 - integer :: isl,iel,jsl,jel + integer :: i,j,ii,jj,i0,j0 real :: ave,total_weight,weight real :: epsilon = 1.0e-20 - !Always start from the first element - is=1 - js=1 - isl=1; iel=size(field_in,1)/dl - jsl=1; jel=size(field_in,2)/dl - allocate(field_out(isl:iel,jsl:jel)) - + + !Allocate the decimated field on the decimated data domain + allocate(field_out(diag_cs%decim(dl)%isd:diag_cs%decim(dl)%ied,diag_cs%decim(dl)%jsd:diag_cs%decim(dl)%jed)) +! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl)) + !Fill the decimated field on the decimated diagnostics (almost always compuate) domain + if(method .eq. MMM) then !xyz_method = MMM - do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,1) total_weight = total_weight + weight ave=ave+field_in(ii,jj)*weight @@ -3787,25 +3786,27 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo elseif(method .eq. MMP) then !xyz_method = MMP - do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight ave=ave+field_in(ii,jj)*weight enddo; enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. SSP) then !xyz_method = SSP , e.g., T_dfxy_cont_tendency_2d - do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + elseif(method .eq. SSP) then !xyz_method = SSP , e.g., T_dfxy_cont_tendency_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj) total_weight = total_weight + weight ave=ave+field_in(ii,jj)*weight @@ -3813,9 +3814,9 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo elseif(method .eq. PSP) then !xyz_method = PSP = 010, e.g., umo_2d - do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 ii=i0 @@ -3827,9 +3828,9 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo elseif(method .eq. SPP) then !xyz_method = SPP = 100, e.g., vmo_2d - do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 jj=j0 @@ -3841,9 +3842,9 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo elseif(method .eq. PMP) then !xyz_method = PMP = 020 - do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 ii=i0 @@ -3855,9 +3856,9 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo elseif(method .eq. MPP) then !xyz_method = MPP = 200 - do j=jsl,jel ; do i=isl,iel - i0 = is+dl*(i-isl) - j0 = js+dl*(j-jsl) + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 jj=j0 @@ -3875,99 +3876,107 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag end subroutine decimate_field_2d -subroutine decimate_mask_3d_p(field_in, field_out, level) - integer , intent(in) :: level +subroutine decimate_mask_3d_p(field_in, field_out, dl) + integer , intent(in) :: dl real, dimension(:,:,:) , pointer :: field_in, field_out - integer :: i,j,ii,jj,is,js,i0,j0 - integer :: isl,iel,jsl,jel + integer :: i,j,ii,jj,i0,j0 + integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d integer :: k,ks,ke real :: tot_non_zero !decimated mask = 0 unless the mask value of one of the decimating cells is 1 - is=1 - js=1 + isv_o=1 + jsv_o=1 ks = lbound(field_in,3) ; ke = ubound(field_in,3) - isl=1; iel=size(field_in,1)/level - jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel,ks:ke)); field_out(:,:,:) = 0.0 - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) + isv_d=1; iev_d=size(field_in,1)/dl + jsv_d=1; jev_d=size(field_in,2)/dl + allocate(field_out(isv_d:iev_d,jsv_d:jev_d,ks:ke)) + field_out(:,:,:) = 0.0 + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) tot_non_zero = 0.0 - do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 +! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj,k) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 enddo; enddo; enddo end subroutine decimate_mask_3d_p -subroutine decimate_mask_2d_p(field_in, field_out, level) - integer , intent(in) :: level +subroutine decimate_mask_2d_p(field_in, field_out, dl) + integer , intent(in) :: dl real, dimension(:,:) , intent(in) :: field_in real, dimension(:,:) , pointer :: field_out - integer :: i,j,ii,jj,is,js,i0,j0 - integer :: isl,iel,jsl,jel + integer :: i,j,ii,jj,i0,j0 + integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d real :: tot_non_zero !decimated mask = 0 unless the mask value of one of the decimating cells is 1 - is=1 - js=1 - isl=1; iel=size(field_in,1)/level - jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel)); field_out(:,:) = 0.0 - do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) + isv_o=1 + jsv_o=1 + isv_d=1; iev_d=size(field_in,1)/dl + jsv_d=1; jev_d=size(field_in,2)/dl + allocate(field_out(isv_d:iev_d,jsv_d:jev_d)) + field_out(:,:) = 0.0 + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) tot_non_zero = 0.0 - do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 +! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j)=1.0 enddo; enddo end subroutine decimate_mask_2d_p -subroutine decimate_mask_3d_a(field_in, field_out, level) - integer , intent(in) :: level +subroutine decimate_mask_3d_a(field_in, field_out, dl) + integer , intent(in) :: dl real, dimension(:,:,:), pointer :: field_in real, dimension(:,:,:), allocatable :: field_out - integer :: i,j,ii,jj,is,js,i0,j0 - integer :: isl,iel,jsl,jel + integer :: i,j,ii,jj,i0,j0 + integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d integer :: k,ks,ke real :: tot_non_zero !decimated mask = 0 unless the mask value of one of the decimating cells is 1 - is=1 - js=1 + isv_o=1 + jsv_o=1 ks = lbound(field_in,3) ; ke = ubound(field_in,3) - isl=1; iel=size(field_in,1)/level - jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel,ks:ke)); field_out(:,:,:) = 0.0 - do k= ks,ke ; do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) + isv_d=1; iev_d=size(field_in,1)/dl + jsv_d=1; jev_d=size(field_in,2)/dl + allocate(field_out(isv_d:iev_d,jsv_d:jev_d,ks:ke)) + field_out(:,:,:) = 0.0 + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) tot_non_zero = 0.0 - do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 +! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj,k) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 enddo; enddo; enddo end subroutine decimate_mask_3d_a -subroutine decimate_mask_2d_a(field_in, field_out, level) - integer , intent(in) :: level +subroutine decimate_mask_2d_a(field_in, field_out, dl) + integer , intent(in) :: dl real, dimension(:,:) , intent(in) :: field_in real, dimension(:,:) , allocatable :: field_out - integer :: i,j,ii,jj,is,js,i0,j0 - integer :: isl,iel,jsl,jel + integer :: i,j,ii,jj,i0,j0 + integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d real :: tot_non_zero !decimated mask = 0 unless the mask value of one of the decimating cells is 1 - is=1 - js=1 - isl=1; iel=size(field_in,1)/level - jsl=1; jel=size(field_in,2)/level - allocate(field_out(isl:iel,jsl:jel)); field_out(:,:) = 0.0 - do j=jsl,jel ; do i=isl,iel - i0 = is+level*(i-isl) - j0 = js+level*(j-jsl) + isv_o=1 + jsv_o=1 + isv_d=1; iev_d=size(field_in,1)/dl + jsv_d=1; jev_d=size(field_in,2)/dl + allocate(field_out(isv_d:iev_d,jsv_d:jev_d)) + field_out(:,:) = 0.0 + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) tot_non_zero = 0.0 - do ii=i0,i0+level-1 ; do jj=j0,j0+level-1 +! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j)=1.0 From de8f1b66df6696e8a2b0c7c1f696bc8f6a0b2281 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 25 Oct 2018 10:27:30 -0400 Subject: [PATCH 13/18] Diag decimation, check the commensurate condition - Beware! Currently only commensurate layouts are supported. I.e., the decimated subgrid cells should all be contained in the same core (pe). For this to happend the layout of the model runs should be chosen so that NIGLOBAL/layout_x and NJGLOBAL/layout_y are both divisible by dl (decimation level) if a _dl diagnostics is present in the diag_table - This is a major limitition of the current implementation. But the extension to arbitrary layouts would required cross processor communications (halo updates) which may slow down the model considerably and beat the purpose of decimation. --- src/framework/MOM_diag_mediator.F90 | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index e6de2309e3..a31f8e8f69 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3512,8 +3512,24 @@ subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) integer, intent(out) ::isv,iev,jsv,jev !< diagnostics-compute indices (to be passed to send_data) ! Local variables integer :: dszi,cszi,dszj,cszj - character(len=300) :: mesg - + character(len=500) :: mesg + logical, save :: first_check = .true. + + !Check ONCE that the decimated diag-compute domain is commensurate with the original non-decimated diag-compute domain + !This is a major limitation of the current implementation of the decimated diagnostics. + !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates. + !We want this check to error out only if there was a decimated diagnostics requested and about to post that is + !why the check is here and not in the init routines. This check need to be done only once, hence the outer if statement + if(first_check) then + if(mod(diag_cs%ie-diag_cs%is+1, dl) .ne. 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) .ne. 0) then + write (mesg,*) "Non-commensurate decimated domain is not supported. "//& + "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl, " Current domain extents: ",& + diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je + call MOM_error(FATAL,"decimate_diag_indices_get: "//trim(mesg)) + endif + first_check = .false. + endif + cszi = diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc +1 ; dszi = diag_cs%decim(dl)%ied-diag_cs%decim(dl)%isd +1 cszj = diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc +1 ; dszj = diag_cs%decim(dl)%jed-diag_cs%decim(dl)%jsd +1 From fe0c041f997b855864a88e7aa909063d337cefcc Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 26 Oct 2018 16:19:53 -0400 Subject: [PATCH 14/18] Diagnostics downsampling, implement suggestions in reviews - This update addresses and implements suggestions in the reviews by Alisair and Balaji, particularly - Rename the whole project and scheme to downsampling - Make a container type for the horizontal indices G%Hd2 for downsampling level 2 - Removed the trailing blanks caught by travis --- src/core/MOM_grid.F90 | 38 +- src/framework/MOM_diag_mediator.F90 | 802 ++++++++++++++-------------- src/framework/MOM_domains.F90 | 57 +- 3 files changed, 426 insertions(+), 471 deletions(-) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index c80f2a2070..453e351060 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -5,7 +5,7 @@ module MOM_grid use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_domains, only : MOM_domain_type, get_domain_extent, compute_block_extent -use MOM_domains, only : get_global_shape, get_domain_extent_zap2 +use MOM_domains, only : get_global_shape, get_domain_extent_dsamp2 use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -21,6 +21,7 @@ module MOM_grid type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain type(MOM_domain_type), pointer :: Domain_aux => NULL() !< A non-symmetric auxiliary domain type. type(hor_index_type) :: HI !< Horizontal index ranges + type(hor_index_type) :: HId2 !< Horizontal index ranges for level-2-downsampling integer :: isc !< The start i-index of cell centers within the computational domain integer :: iec !< The end i-index of cell centers within the computational domain @@ -52,23 +53,6 @@ module MOM_grid integer :: JsgB !< The start j-index of cell vertices within the global domain integer :: JegB !< The end j-index of cell vertices within the global domain - integer :: isc_zap2 !< The start i-index of cell centers within the computational domain - integer :: iec_zap2 !< The end i-index of cell centers within the computational domain - integer :: jsc_zap2 !< The start j-index of cell centers within the computational domain - integer :: jec_zap2 !< The end j-index of cell centers within the computational domain - integer :: isd_zap2 !< The start i-index of cell centers within the data domain - integer :: ied_zap2 !< The end i-index of cell centers within the data domain - integer :: jsd_zap2 !< The start j-index of cell centers within the data domain - integer :: jed_zap2 !< The end j-index of cell centers within the data domain - integer :: IsdB_zap2 !< The start i-index of cell vertices within the data domain - integer :: IedB_zap2 !< The end i-index of cell vertices within the data domain - integer :: JsdB_zap2 !< The start j-index of cell vertices within the data domain - integer :: JedB_zap2 !< The end j-index of cell vertices within the data domain - integer :: isg_zap2 !< The start i-index of cell centers within the computational domain - integer :: ieg_zap2 !< The end i-index of cell centers within the computational domain - integer :: jsg_zap2 !< The start j-index of cell centers within the computational domain - integer :: jeg_zap2 !< The end j-index of cell centers within the computational domain - integer :: isd_global !< The value of isd in the global index space (decompoistion invariant). integer :: jsd_global !< The value of isd in the global index space (decompoistion invariant). integer :: idg_offset !< The offset between the corresponding global and local i-indices. @@ -361,22 +345,16 @@ subroutine MOM_grid_init(G, param_file, HI, global_indexing, bathymetry_at_vel) if ( G%block(nblocks)%jed+G%block(nblocks)%jdg_offset > G%HI%jed + G%HI%jdg_offset ) & call MOM_error(FATAL, "MOM_grid_init: G%jed_bk > G%jed") - call get_domain_extent_zap2(G%Domain, G%isc_zap2, G%iec_zap2, G%jsc_zap2, G%jec_zap2,& - G%isd_zap2, G%ied_zap2, G%jsd_zap2, G%jed_zap2,& - G%isg_zap2, G%ieg_zap2, G%jsg_zap2, G%jeg_zap2) + call get_domain_extent_dsamp2(G%Domain, G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec,& + G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed,& + G%HId2%isg, G%HId2%ieg, G%HId2%jsg, G%HId2%jeg) ! Set array sizes for fields that are discretized at tracer cell boundaries. -! G%IscB_zap2 = G%isc_zap2 ; G%JscB_zap2 = G%jsc_zap2 - G%IsdB_zap2 = G%isd_zap2 ; G%JsdB_zap2 = G%jsd_zap2 -! G%IsgB_zap2 = G%isg_zap2 ; G%JsgB_zap2 = G%jsg_zap2 + G%HId2%IsdB = G%HId2%isd ; G%HId2%JsdB = G%HId2%jsd if (G%symmetric) then -! G%IscB_zap2 = G%isc_zap2-1 ; G%JscB_zap2 = G%jsc_zap2-1 - G%IsdB_zap2 = G%isd_zap2-1 ; G%JsdB_zap2 = G%jsd_zap2-1 -! G%IsgB_zap2 = G%isg_zap2-1 ; G%JsgB_zap2 = G%jsg_zap2-1 + G%HId2%IsdB = G%HId2%isd-1 ; G%HId2%JsdB = G%HId2%jsd-1 endif -! G%IecB_zap2 = G%iec_zap2 ; G%JecB_zap2 = G%jec_zap2 - G%IedB_zap2 = G%ied_zap2 ; G%JedB_zap2 = G%jed_zap2 -! G%IegB_zap2 = G%ieg_zap2 ; G%JegB_zap2 = G%jeg_zap2 + G%HId2%IedB = G%HId2%ied ; G%HId2%JedB = G%HId2%jed end subroutine MOM_grid_init diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index a31f8e8f69..2abc9b611d 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -42,7 +42,7 @@ module MOM_diag_mediator #undef __DO_SAFETY_CHECKS__ #define IMPLIES(A, B) ((.not. (A)) .or. (B)) -#define MAX_DECIM_LEV 2 +#define MAX_DSAMP_LEV 2 public set_axes_info, post_data, register_diag_field, time_type public set_masks_for_axes @@ -68,22 +68,22 @@ module MOM_diag_mediator module procedure post_data_3d, post_data_2d, post_data_1d_k, post_data_0d end interface post_data -interface decimate_field - module procedure decimate_field_2d, decimate_field_3d -end interface decimate_field +interface downsample_field + module procedure downsample_field_2d, downsample_field_3d +end interface downsample_field -interface decimate_mask - module procedure decimate_mask_2d_p, decimate_mask_3d_p, decimate_mask_2d_a, decimate_mask_3d_a -end interface decimate_mask +interface downsample_mask + module procedure downsample_mask_2d_p, downsample_mask_3d_p, downsample_mask_2d_a, downsample_mask_3d_a +end interface downsample_mask -interface decimate_diag_field - module procedure decimate_diag_field_2d, decimate_diag_field_3d -end interface decimate_diag_field +interface downsample_diag_field + module procedure downsample_diag_field_2d, downsample_diag_field_3d +end interface downsample_diag_field -type, private :: diag_decim - real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes - real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes -end type diag_decim +type, private :: diag_dsamp + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes +end type diag_dsamp !> A group of 1D axes that comprise a 1D/2D/3D mesh type, public :: axes_grp @@ -117,7 +117,7 @@ module MOM_diag_mediator logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled !! interface-located field that must be interpolated to !! these axes. Used for rank>2. - integer :: decimation_level = 1 !< If greater than 1, the factor by which this diagnostic/axes/masks be decimated + integer :: downsample_level = 1 !< If greater than 1, the factor by which this diagnostic/axes/masks be downsampled ! For horizontally averaged diagnositcs (applies to 2d and 3d fields only) type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontall area-averaged diagnostics ! ID's for cell_measures @@ -127,7 +127,7 @@ module MOM_diag_mediator ! For masking real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes - type(diag_decim), dimension(2:MAX_DECIM_LEV) :: decim !< Decimation container + type(diag_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample container end type axes_grp !> Contains an array to store a diagnostic target grid @@ -172,7 +172,7 @@ module MOM_diag_mediator logical :: in_use !< True if this entry is being used. integer :: fms_diag_id !< Underlying FMS diag_manager id. integer :: fms_xyave_diag_id = -1 !< For a horizontally area-averaged diagnostic. - integer :: decimate_diag_id = -1 !< For a horizontally area-decimated diagnostic. + integer :: downsample_diag_id = -1 !< For a horizontally area-downsampled diagnostic. character(64) :: debug_str = '' !< For FATAL errors and debugging. type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic @@ -180,10 +180,10 @@ module MOM_diag_mediator logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). !! False for intensive (concentrations). integer :: xyz_method = 0 !< A 3 digit integer encoding the diagnostics cell method - !! It can be used to determine the decimation algorithm + !! It can be used to determine the downsample algorithm end type diag_type -type diagcs_decim +type diagcs_dsamp integer :: isc !< The start i-index of cell centers within the computational domain integer :: iec !< The end i-index of cell centers within the computational domain integer :: jsc !< The start j-index of cell centers within the computational domain @@ -193,7 +193,7 @@ module MOM_diag_mediator integer :: jsd !< The start j-index of cell centers within the data domain integer :: jed !< The end j-index of cell centers within the data domain integer :: isg,ieg,jsg,jeg - + type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 @@ -213,7 +213,7 @@ module MOM_diag_mediator real, dimension(:,:,:), pointer :: mask3dBi => null() real, dimension(:,:,:), pointer :: mask3dCui => null() real, dimension(:,:,:), pointer :: mask3dCvi => null() -end type diagcs_decim +end type diagcs_dsamp !> The following data type a list of diagnostic fields an their variants, !! as well as variables that control the handling of model output. @@ -264,8 +264,8 @@ module MOM_diag_mediator real, dimension(:,:,:), pointer :: mask3dCui => null() real, dimension(:,:,:), pointer :: mask3dCvi => null() - type(diagcs_decim), dimension(2:MAX_DECIM_LEV) :: decim !< Decimation control container - + type(diagcs_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample control container + !!@} ! Space for diagnostics is dynamically allocated as it is needed. @@ -365,9 +365,9 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) endif id_zl_native = id_zl ; id_zi_native = id_zi ! Vertical axes for the interfaces and layers - call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, nz=1, & + call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, & v_cell_method='point', is_interface=.true.) - call define_axes_group(diag_cs, (/ id_zL /), diag_cs%axesZL, nz=1, & + call define_axes_group(diag_cs, (/ id_zL /), diag_cs%axesZL, & v_cell_method='mean', is_layer=.true.) ! Axis groupings for the model layers @@ -412,7 +412,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull) - !Non-native Non-decimated + !Non-native Non-downsampled if (diag_cs%num_diag_coords>0) then allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords)) allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords)) @@ -498,14 +498,14 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) endif enddo - !Define the decimated axes - call set_axes_info_decim(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) - + !Define the downsampled axes + call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) + call diag_grid_storage_init(diag_CS%diag_grid_temp, G, diag_CS) end subroutine set_axes_info -subroutine set_axes_info_decim(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) +subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(param_file_type), intent(in) :: param_file !< Parameter file structure @@ -515,89 +515,87 @@ subroutine set_axes_info_decim(G, GV, param_file, diag_cs, id_zl_native, id_zi_n ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh integer :: i, j, k, nz, dl - real, dimension(:), pointer :: gridLonT_zap =>NULL() - real, dimension(:), pointer :: gridLatT_zap =>NULL() + real, dimension(:), pointer :: gridLonT_dsamp =>NULL() + real, dimension(:), pointer :: gridLatT_dsamp =>NULL() id_zl = id_zl_native ; id_zi = id_zi_native - !Axes group for native decimated diagnostics - do dl=2,MAX_DECIM_LEV - if(dl .ne. 2) call MOM_error(FATAL, "set_axes_info_decim: Decimation level other than 2 is not supported yet!") - allocate(gridLonT_zap(diag_cs%decim(dl)%isg:diag_cs%decim(dl)%ieg)) - allocate(gridLatT_zap(diag_cs%decim(dl)%jsg:diag_cs%decim(dl)%jeg)) + !Axes group for native downsampled diagnostics + do dl=2,MAX_DSAMP_LEV + if(dl .ne. 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!") + allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) - do i=diag_cs%decim(dl)%isg,diag_cs%decim(dl)%ieg; gridLonT_zap(i) = G%gridLonT(G%isg+dl*i-2); enddo - do j=diag_cs%decim(dl)%jsg,diag_cs%decim(dl)%jeg; gridLatT_zap(j) = G%gridLatT(G%jsg+dl*j-2); enddo + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo if (G%symmetric) then - call MOM_error(FATAL, "set_axes_info_decim: Decimation of symmetric case is not supported yet!") - ! id_xq = diag_axis_init('xq', gridLonB_zap(G%isgB:G%iegB), G%x_axis_units, 'x', & - ! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) - ! id_yq = diag_axis_init('yq', gridLatB_zap(G%jsgB:G%jegB), G%y_axis_units, 'y', & - ! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + call MOM_error(FATAL, "set_axes_info_dsamp: Downsample of symmetric case is not supported yet!") + ! id_xq = diag_axis_init('xq', gridLonB_dsamp(G%isgB:G%iegB), G%x_axis_units, 'x', & + ! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + ! id_yq = diag_axis_init('yq', gridLatB_dsamp(G%jsgB:G%jegB), G%y_axis_units, 'y', & + ! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) else - id_xq = diag_axis_init('xq', gridLonT_zap, G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) - id_yq = diag_axis_init('yq', gridLatT_zap, G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + id_xq = diag_axis_init('xq', gridLonT_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatT_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) endif - id_xh = diag_axis_init('xh', gridLonT_zap, G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain_zap2) - id_yh = diag_axis_init('yh', gridLatT_zap, G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain_zap2) + id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain_d2) - deallocate(gridLonT_zap) - deallocate(gridLatT_zap) + deallocate(gridLonT_dsamp) + deallocate(gridLatT_dsamp) ! Axis groupings for the model layers - call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%decim(dl)%axesTL, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%decim(dl)%axesBL, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%axesBL, dl, & x_cell_method='point', y_cell_method='point', v_cell_method='mean', & is_q_point=.true., is_layer=.true.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%decim(dl)%axesCuL, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%axesCuL, dl, & x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) - call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%decim(dl)%axesCvL, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%axesCvL, dl, & x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) ! Axis groupings for the model interfaces - call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%decim(dl)%axesTi, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%axesTi, dl, & x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%decim(dl)%axesBi, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%axesBi, dl, & x_cell_method='point', y_cell_method='point', v_cell_method='point', & is_q_point=.true., is_interface=.true.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%decim(dl)%axesCui, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%axesCui, dl, & x_cell_method='point', y_cell_method='mean', v_cell_method='point', & is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) - call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%decim(dl)%axesCvi, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%axesCvi, dl, & x_cell_method='mean', y_cell_method='point', v_cell_method='point', & is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) ! Axis groupings for 2-D arrays - call define_axes_group_decim(diag_cs, (/ id_xh, id_yh /), diag_cs%decim(dl)%axesT1, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh /), diag_cs%dsamp(dl)%axesT1, dl, & x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yq /), diag_cs%decim(dl)%axesB1, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq /), diag_cs%dsamp(dl)%axesB1, dl, & x_cell_method='point', y_cell_method='point', is_q_point=.true.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yh /), diag_cs%decim(dl)%axesCu1, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh /), diag_cs%dsamp(dl)%axesCu1, dl, & x_cell_method='point', y_cell_method='mean', is_u_point=.true.) - call define_axes_group_decim(diag_cs, (/ id_xh, id_yq /), diag_cs%decim(dl)%axesCv1, dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, & x_cell_method='mean', y_cell_method='point', is_v_point=.true.) !Non-native axes if (diag_cs%num_diag_coords>0) then -! allocate(diag_cs%decim(dl)%remap_axesZL(diag_cs%num_diag_coords)) -! allocate(diag_cs%decim(dl)%remap_axesZi(diag_cs%num_diag_coords)) - allocate(diag_cs%decim(dl)%remap_axesTL(diag_cs%num_diag_coords)) - allocate(diag_cs%decim(dl)%remap_axesBL(diag_cs%num_diag_coords)) - allocate(diag_cs%decim(dl)%remap_axesCuL(diag_cs%num_diag_coords)) - allocate(diag_cs%decim(dl)%remap_axesCvL(diag_cs%num_diag_coords)) - allocate(diag_cs%decim(dl)%remap_axesTi(diag_cs%num_diag_coords)) - allocate(diag_cs%decim(dl)%remap_axesBi(diag_cs%num_diag_coords)) - allocate(diag_cs%decim(dl)%remap_axesCui(diag_cs%num_diag_coords)) - allocate(diag_cs%decim(dl)%remap_axesCvi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCuL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesTi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCui(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvi(diag_cs%num_diag_coords)) endif do i=1, diag_cs%num_diag_coords @@ -612,13 +610,7 @@ subroutine set_axes_info_decim(G, GV, param_file, diag_cs, id_zl_native, id_zi_n call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zL, id_zi) ! Axes for z layers - !This should be the same as non-decimated one which should already be set -! call define_axes_group(diag_cs, (/ id_zL /), diag_cs%decim(dl)%remap_axesZL(i), & -! nz=nz, vertical_coordinate_number=i, & -! v_cell_method='mean', & -! is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true.) - - call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%decim(dl)%remap_axesTL(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesTL(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & @@ -626,47 +618,43 @@ subroutine set_axes_info_decim(G, GV, param_file, diag_cs, id_zl_native, id_zi_n !! \note Remapping for B points is not yet implemented so needs_remapping is not !! provided for remap_axesBL - call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%decim(dl)%remap_axesBL(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesBL(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='point', v_cell_method='mean', & is_q_point=.true., is_layer=.true., is_native=.false.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%decim(dl)%remap_axesCuL(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesCuL(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & xyave_axes=diag_cs%remap_axesZL(i)) - call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%decim(dl)%remap_axesCvL(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesCvL(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & xyave_axes=diag_cs%remap_axesZL(i)) ! Axes for z interfaces -! call define_axes_group_decim(diag_cs, (/ id_zi /), diag_cs%decim(dl)%remap_axesZi(i),& -! nz=nz, vertical_coordinate_number=i, & -! v_cell_method='point', & -! is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true.) - call define_axes_group_decim(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%decim(dl)%remap_axesTi(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesTi(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., & xyave_axes=diag_cs%remap_axesZi(i)) !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi - call define_axes_group_decim(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%decim(dl)%remap_axesBi(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesBi(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='point', v_cell_method='point', & is_q_point=.true., is_interface=.true., is_native=.false.) - call define_axes_group_decim(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%decim(dl)%remap_axesCui(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesCui(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='mean', v_cell_method='point', & is_u_point=.true., is_interface=.true., is_native=.false., & needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) - call define_axes_group_decim(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%decim(dl)%remap_axesCvi(i), dl, & + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesCvi(i), dl, & nz=nz, vertical_coordinate_number=i, & x_cell_method='mean', y_cell_method='point', v_cell_method='point', & is_v_point=.true., is_interface=.true., is_native=.false., & @@ -674,9 +662,9 @@ subroutine set_axes_info_decim(G, GV, param_file, diag_cs, id_zl_native, id_zi_n endif enddo enddo - -end subroutine set_axes_info_decim - + +end subroutine set_axes_info_dsamp + !> set_masks_for_axes sets up the 2d and 3d masks for diagnostics using the current grid !! recorded after calling diag_update_remap_grids() @@ -774,12 +762,12 @@ subroutine set_masks_for_axes(G, diag_cs) endif enddo - !Allocate and initialize the decimated masks for the axes - call set_masks_for_axes_decim(G, diag_cs) - + !Allocate and initialize the downsampled masks for the axes + call set_masks_for_axes_dsamp(G, diag_cs) + end subroutine set_masks_for_axes -subroutine set_masks_for_axes_decim(G, diag_cs) +subroutine set_masks_for_axes_dsamp(G, diag_cs) type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics @@ -788,47 +776,47 @@ subroutine set_masks_for_axes_decim(G, diag_cs) integer :: dl type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience - !Each decimated axis needs both decimated and non-decimated mask - !The decimated mask is needed for sending out the diagnostics output via diag_manager - !The non-decimated mask is needed for decimating the diagnostics field - do dl=2,MAX_DECIM_LEV - if(dl .ne. 2) call MOM_error(FATAL, "set_masks_for_axes_decim: Decimation level other than 2 is not supported yet!") + !Each downsampled axis needs both downsampled and non-downsampled mask + !The downsampled mask is needed for sending out the diagnostics output via diag_manager + !The non-downsampled mask is needed for downsampling the diagnostics field + do dl=2,MAX_DSAMP_LEV + if(dl .ne. 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported yet!") do c=1, diag_cs%num_diag_coords ! Level/layer h-points in diagnostic coordinate axes => diag_cs%remap_axesTL(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesTL(c)%decim(dl)%mask3d, dl)!set decimated mask - diag_cs%decim(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-decimated mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-downsampled mask ! Level/layer u-points in diagnostic coordinate axes => diag_cs%remap_axesCuL(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCuL(c)%decim(dl)%mask3d, dl)!set decimated mask - diag_cs%decim(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-decimated mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-downsampled mask ! Level/layer v-points in diagnostic coordinate axes => diag_cs%remap_axesCvL(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCvL(c)%decim(dl)%mask3d, dl)!set decimated mask - diag_cs%decim(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-decimated mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-downsampled mask ! Level/layer q-points in diagnostic coordinate axes => diag_cs%remap_axesBL(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesBL(c)%decim(dl)%mask3d, dl)!set decimated mask - diag_cs%decim(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-decimated mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface h-points in diagnostic coordinate (w-point) axes => diag_cs%remap_axesTi(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesTi(c)%decim(dl)%mask3d, dl)!set decimated mask - diag_cs%decim(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-decimated mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface u-points in diagnostic coordinate axes => diag_cs%remap_axesCui(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCui(c)%decim(dl)%mask3d, dl)!set decimated mask - diag_cs%decim(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-decimated mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface v-points in diagnostic coordinate axes => diag_cs%remap_axesCvi(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesCvi(c)%decim(dl)%mask3d, dl)!set decimated mask - diag_cs%decim(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-decimated mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) - call decimate_mask(axes%mask3d, diag_cs%decim(dl)%remap_axesBi(c)%decim(dl)%mask3d, dl)!set decimated mask - diag_cs%decim(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-decimated mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask enddo enddo -end subroutine set_masks_for_axes_decim +end subroutine set_masks_for_axes_dsamp !> Attaches the id of cell areas to axes groups for use with cell_measures subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q) @@ -1015,8 +1003,8 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num end subroutine define_axes_group -!> Defines a group of decimated "axes" from list of handles -subroutine define_axes_group_decim(diag_cs, handles, axes, dl, nz, vertical_coordinate_number, & +!> Defines a group of downsampled "axes" from list of handles +subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coordinate_number, & x_cell_method, y_cell_method, v_cell_method, & is_h_point, is_q_point, is_u_point, is_v_point, & is_layer, is_interface, & @@ -1025,7 +1013,7 @@ subroutine define_axes_group_decim(diag_cs, handles, axes, dl, nz, vertical_coor type(diag_ctrl), target, intent(in) :: diag_cs !< Diagnostics control structure integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles type(axes_grp), intent(out) :: axes !< The group of 1D axes - integer, intent(in) :: dl !< Decimation level + integer, intent(in) :: dl !< Downsample level integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the @@ -1087,7 +1075,7 @@ subroutine define_axes_group_decim(diag_cs, handles, axes, dl, nz, vertical_coor else axes%v_cell_method = '' endif - axes%decimation_level = dl + axes%downsample_level = dl if (present(nz)) axes%nz = nz if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number if (present(is_h_point)) axes%is_h_point = is_h_point @@ -1102,7 +1090,7 @@ subroutine define_axes_group_decim(diag_cs, handles, axes, dl, nz, vertical_coor if (present(xyave_axes)) axes%xyave_axes => xyave_axes ! Setup masks for this axes group - + axes%mask2d => null() if (axes%rank==2) then if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT @@ -1127,31 +1115,31 @@ subroutine define_axes_group_decim(diag_cs, handles, axes, dl, nz, vertical_coor endif endif - axes%decim(dl)%mask2d => null() + axes%dsamp(dl)%mask2d => null() if (axes%rank==2) then - if (axes%is_h_point) axes%decim(dl)%mask2d => diag_cs%decim(dl)%mask2dT - if (axes%is_u_point) axes%decim(dl)%mask2d => diag_cs%decim(dl)%mask2dCu - if (axes%is_v_point) axes%decim(dl)%mask2d => diag_cs%decim(dl)%mask2dCv - if (axes%is_q_point) axes%decim(dl)%mask2d => diag_cs%decim(dl)%mask2dBu + if (axes%is_h_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dT + if (axes%is_u_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCu + if (axes%is_v_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCv + if (axes%is_q_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dBu endif ! A static 3d mask for non-native coordinates can only be setup when a grid is available - axes%decim(dl)%mask3d => null() + axes%dsamp(dl)%mask3d => null() if (axes%rank==3 .and. axes%is_native) then ! Native variables can/should use the native masks copied into diag_cs if (axes%is_layer) then - if (axes%is_h_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dTL - if (axes%is_u_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dCuL - if (axes%is_v_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dCvL - if (axes%is_q_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dBL + if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTL + if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCuL + if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvL + if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBL elseif (axes%is_interface) then - if (axes%is_h_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dTi - if (axes%is_u_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dCui - if (axes%is_v_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dCvi - if (axes%is_q_point) axes%decim(dl)%mask3d => diag_cs%decim(dl)%mask3dBi + if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTi + if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCui + if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvi + if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBi endif endif - -end subroutine define_axes_group_decim + +end subroutine define_axes_group_dsamp !> Set up the array extents for doing diagnostics subroutine set_diag_mediator_grid(G, diag_cs) @@ -1285,14 +1273,14 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. ! Local variables - real, dimension(:,:), pointer :: locfield + real, dimension(:,:), pointer :: locfield real, dimension(:,:), pointer :: locmask character(len=300) :: mesg logical :: used, is_stat integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, i, j, chksum - real, dimension(:,:), allocatable, target :: locfield_decim - real, dimension(:,:), allocatable, target :: locmask_decim + real, dimension(:,:), allocatable, target :: locfield_dsamp + real, dimension(:,:), allocatable, target :: locmask_dsamp integer :: dl locfield => NULL() @@ -1353,21 +1341,21 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) if (present(mask)) then locmask => mask elseif(.NOT. is_stat) then - if(associated(diag%axes%mask2d)) locmask => diag%axes%mask2d - endif + if(associated(diag%axes%mask2d)) locmask => diag%axes%mask2d + endif dl=1 - if(.NOT. is_stat) dl = diag%axes%decimation_level !static field decimation i not supported yet - !Decimate the diag field and mask (if present) + if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet + !Downsample the diag field and mask (if present) if (dl > 1) then - call decimate_diag_field(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) - locfield => locfield_decim + locfield => locfield_dsamp if (present(mask)) then - call decimate_mask(locmask, locmask_decim, dl) - locmask => locmask_decim - elseif(associated(diag%axes%decim(dl)%mask2d)) then - locmask => diag%axes%decim(dl)%mask2d + call downsample_mask(locmask, locmask_dsamp, dl) + locmask => locmask_dsamp + elseif(associated(diag%axes%dsamp(dl)%mask2d)) then + locmask => diag%axes%dsamp(dl)%mask2d endif endif @@ -1547,8 +1535,8 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c integer :: chksum - real, dimension(:,:,:), allocatable, target :: locfield_decim - real, dimension(:,:,:), allocatable, target :: locmask_decim + real, dimension(:,:,:), allocatable, target :: locfield_dsamp + real, dimension(:,:,:), allocatable, target :: locmask_dsamp integer :: isl,iel,jsl,jel,dl locfield => NULL() @@ -1626,22 +1614,22 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) if (present(mask)) then locmask => mask elseif(associated(diag%axes%mask3d)) then - locmask => diag%axes%mask3d + locmask => diag%axes%mask3d endif dl=1 - if(.NOT. is_stat) dl = diag%axes%decimation_level !static field decimation i not supported yet - !Decimate the diag field and mask (if present) + if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet + !Downsample the diag field and mask (if present) if (dl > 1) then - call decimate_diag_field(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) - locfield => locfield_decim + locfield => locfield_dsamp if (present(mask)) then - call decimate_mask(locmask, locmask_decim, dl) - locmask => locmask_decim - elseif(associated(diag%axes%decim(dl)%mask3d)) then - locmask => diag%axes%decim(dl)%mask3d - endif + call downsample_mask(locmask, locmask_dsamp, dl) + locmask => locmask_dsamp + elseif(associated(diag%axes%dsamp(dl)%mask3d)) then + locmask => diag%axes%dsamp(dl)%mask3d + endif endif if (diag%fms_diag_id>0) then @@ -1837,7 +1825,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time diag_cs => axes%diag_cs dm_id = -1 - + if (axes_in%id == diag_cs%axesTL%id) then axes => diag_cs%axesTL elseif (axes_in%id == diag_cs%axesBL%id) then @@ -1915,42 +1903,42 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time endif ! axes%rank == 3 enddo ! i - !Register decimated diagnostics - do dl=2,MAX_DECIM_LEV + !Register downsampled diagnostics + do dl=2,MAX_DSAMP_LEV new_module_name = trim(module_name)//'_d2' if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then axes => null() if (axes_in%id == diag_cs%axesTL%id) then - axes => diag_cs%decim(dl)%axesTL + axes => diag_cs%dsamp(dl)%axesTL elseif (axes_in%id == diag_cs%axesBL%id) then - axes => diag_cs%decim(dl)%axesBL + axes => diag_cs%dsamp(dl)%axesBL elseif (axes_in%id == diag_cs%axesCuL%id ) then - axes => diag_cs%decim(dl)%axesCuL + axes => diag_cs%dsamp(dl)%axesCuL elseif (axes_in%id == diag_cs%axesCvL%id) then - axes => diag_cs%decim(dl)%axesCvL + axes => diag_cs%dsamp(dl)%axesCvL elseif (axes_in%id == diag_cs%axesTi%id) then - axes => diag_cs%decim(dl)%axesTi + axes => diag_cs%dsamp(dl)%axesTi elseif (axes_in%id == diag_cs%axesBi%id) then - axes => diag_cs%decim(dl)%axesBi + axes => diag_cs%dsamp(dl)%axesBi elseif (axes_in%id == diag_cs%axesCui%id ) then - axes => diag_cs%decim(dl)%axesCui + axes => diag_cs%dsamp(dl)%axesCui elseif (axes_in%id == diag_cs%axesCvi%id) then - axes => diag_cs%decim(dl)%axesCvi + axes => diag_cs%dsamp(dl)%axesCvi elseif (axes_in%id == diag_cs%axesT1%id) then - axes => diag_cs%decim(dl)%axesT1 + axes => diag_cs%dsamp(dl)%axesT1 elseif (axes_in%id == diag_cs%axesB1%id) then - axes => diag_cs%decim(dl)%axesB1 + axes => diag_cs%dsamp(dl)%axesB1 elseif (axes_in%id == diag_cs%axesCu1%id ) then - axes => diag_cs%decim(dl)%axesCu1 + axes => diag_cs%dsamp(dl)%axesCu1 elseif (axes_in%id == diag_cs%axesCv1%id) then - axes => diag_cs%decim(dl)%axesCv1 + axes => diag_cs%dsamp(dl)%axesCv1 else !Niki: Should we worry about these, e.g., diag_to_Z_CS? call MOM_error(WARNING,"register_diag_field: Could not find a proper axes for " & //trim( new_module_name)//"-"//trim(field_name)) endif - endif + endif ! Register the native diagnostic if (associated(axes)) then active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes, & @@ -1973,21 +1961,21 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time if (axes_in%rank == 3) then remap_axes => null() if ((axes_in%id == diag_cs%axesTL%id)) then - remap_axes => diag_cs%decim(dl)%remap_axesTL(i) + remap_axes => diag_cs%dsamp(dl)%remap_axesTL(i) elseif (axes_in%id == diag_cs%axesBL%id) then - remap_axes => diag_cs%decim(dl)%remap_axesBL(i) + remap_axes => diag_cs%dsamp(dl)%remap_axesBL(i) elseif (axes_in%id == diag_cs%axesCuL%id ) then - remap_axes => diag_cs%decim(dl)%remap_axesCuL(i) + remap_axes => diag_cs%dsamp(dl)%remap_axesCuL(i) elseif (axes_in%id == diag_cs%axesCvL%id) then - remap_axes => diag_cs%decim(dl)%remap_axesCvL(i) + remap_axes => diag_cs%dsamp(dl)%remap_axesCvL(i) elseif (axes_in%id == diag_cs%axesTi%id) then - remap_axes => diag_cs%decim(dl)%remap_axesTi(i) + remap_axes => diag_cs%dsamp(dl)%remap_axesTi(i) elseif (axes_in%id == diag_cs%axesBi%id) then - remap_axes => diag_cs%decim(dl)%remap_axesBi(i) + remap_axes => diag_cs%dsamp(dl)%remap_axesBi(i) elseif (axes_in%id == diag_cs%axesCui%id ) then - remap_axes => diag_cs%decim(dl)%remap_axesCui(i) + remap_axes => diag_cs%dsamp(dl)%remap_axesCui(i) elseif (axes_in%id == diag_cs%axesCvi%id) then - remap_axes => diag_cs%decim(dl)%remap_axesCvi(i) + remap_axes => diag_cs%dsamp(dl)%remap_axesCvi(i) endif ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will @@ -2326,14 +2314,14 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho !! (vertically integrated). Default/absent for intensive. integer :: xyz_method character(len=9) :: mstr - + !This is a simple way to encode the cell method information made from 3 strings !(x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz !x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean' !We can encode these with setting 0 for 'point', 1 for 'sum, 2 for 'mean' in !the 100s position for x, 10s position for y, 1s position for z !E.g., x:sum,y:point,z:mean is 102 - + xyz_method = 0 mstr = diag%axes%v_cell_method @@ -2344,7 +2332,7 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho mstr='sum' else mstr='mean' - endif + endif elseif (present(v_cell_method)) then mstr = v_cell_method endif @@ -2353,7 +2341,7 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho elseif (trim(mstr)=='mean') then xyz_method = xyz_method + 2 endif - + mstr = diag%axes%y_cell_method if (present(y_cell_method)) mstr = y_cell_method if (trim(mstr)=='sum') then @@ -2361,7 +2349,7 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho elseif (trim(mstr)=='mean') then xyz_method = xyz_method + 20 endif - + mstr = diag%axes%x_cell_method if (present(x_cell_method)) mstr = x_cell_method if (trim(mstr)=='sum') then @@ -2935,14 +2923,14 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) diag_cs%isd = G%isd ; diag_cs%ied = G%ied diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed - !Decimation indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array) - diag_cs%decim(2)%isc = G%isc_zap2 - (G%isd_zap2-1) ; diag_cs%decim(2)%iec = G%iec_zap2 - (G%isd_zap2-1) - diag_cs%decim(2)%jsc = G%jsc_zap2 - (G%jsd_zap2-1) ; diag_cs%decim(2)%jec = G%jec_zap2 - (G%jsd_zap2-1) - diag_cs%decim(2)%isd = G%isd_zap2 ; diag_cs%decim(2)%ied = G%ied_zap2 - diag_cs%decim(2)%jsd = G%jsd_zap2 ; diag_cs%decim(2)%jed = G%jed_zap2 - diag_cs%decim(2)%isg = G%isg_zap2 ; diag_cs%decim(2)%ieg = G%ieg_zap2 - diag_cs%decim(2)%jsg = G%jsg_zap2 ; diag_cs%decim(2)%jeg = G%jeg_zap2 - + !Downsample indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array) + diag_cs%dsamp(2)%isc = G%HId2%isc - (G%HId2%isd-1) ; diag_cs%dsamp(2)%iec = G%HId2%iec - (G%HId2%isd-1) + diag_cs%dsamp(2)%jsc = G%HId2%jsc - (G%HId2%jsd-1) ; diag_cs%dsamp(2)%jec = G%HId2%jec - (G%HId2%jsd-1) + diag_cs%dsamp(2)%isd = G%HId2%isd ; diag_cs%dsamp(2)%ied = G%HId2%ied + diag_cs%dsamp(2)%jsd = G%HId2%jsd ; diag_cs%dsamp(2)%jed = G%HId2%jed + diag_cs%dsamp(2)%isg = G%HId2%isg ; diag_cs%dsamp(2)%ieg = G%HId2%ieg + diag_cs%dsamp(2)%jsg = G%HId2%jsg ; diag_cs%dsamp(2)%jeg = G%HId2%jeg + ! Initialze available diagnostic log file if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then write(this_pe,'(i6.6)') PE_here() @@ -3133,8 +3121,8 @@ subroutine diag_masks_set(G, nz, diag_cs) diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:) enddo - !Allocate and initialize the decimated masks - call decimate_diag_masks_set(G, nz, diag_cs) + !Allocate and initialize the downsampled masks + call downsample_diag_masks_set(G, nz, diag_cs) end subroutine diag_masks_set @@ -3183,19 +3171,19 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) deallocate(diag_cs%mask3dBi) deallocate(diag_cs%mask3dCui) deallocate(diag_cs%mask3dCvi) - do i=2,MAX_DECIM_LEV - deallocate(diag_cs%decim(i)%mask2dT) - deallocate(diag_cs%decim(i)%mask2dBu) - deallocate(diag_cs%decim(i)%mask2dCu) - deallocate(diag_cs%decim(i)%mask2dCv) - deallocate(diag_cs%decim(i)%mask3dTL) - deallocate(diag_cs%decim(i)%mask3dBL) - deallocate(diag_cs%decim(i)%mask3dCuL) - deallocate(diag_cs%decim(i)%mask3dCvL) - deallocate(diag_cs%decim(i)%mask3dTi) - deallocate(diag_cs%decim(i)%mask3dBi) - deallocate(diag_cs%decim(i)%mask3dCui) - deallocate(diag_cs%decim(i)%mask3dCvi) + do i=2,MAX_DSAMP_LEV + deallocate(diag_cs%dsamp(i)%mask2dT) + deallocate(diag_cs%dsamp(i)%mask2dBu) + deallocate(diag_cs%dsamp(i)%mask2dCu) + deallocate(diag_cs%dsamp(i)%mask2dCv) + deallocate(diag_cs%dsamp(i)%mask3dTL) + deallocate(diag_cs%dsamp(i)%mask3dBL) + deallocate(diag_cs%dsamp(i)%mask3dCuL) + deallocate(diag_cs%dsamp(i)%mask3dCvL) + deallocate(diag_cs%dsamp(i)%mask3dTi) + deallocate(diag_cs%dsamp(i)%mask3dBi) + deallocate(diag_cs%dsamp(i)%mask3dCui) + deallocate(diag_cs%dsamp(i)%mask3dCvi) enddo #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) @@ -3453,9 +3441,9 @@ subroutine diag_grid_storage_end(grid_storage) deallocate(grid_storage%diag_grids) end subroutine diag_grid_storage_end -!< Allocate and initialize the masks for decimated diagostics in diag_cs -!! The decimated masks in the axes would later "point" to these. -subroutine decimate_diag_masks_set(G, nz, diag_cs) +!< Allocate and initialize the masks for downsampled diagostics in diag_cs +!! The downsampled masks in the axes would later "point" to these. +subroutine downsample_diag_masks_set(G, nz, diag_cs) type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. integer, intent(in) :: nz !< The number of layers in the model's native grid. type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables @@ -3464,50 +3452,50 @@ subroutine decimate_diag_masks_set(G, nz, diag_cs) integer :: i,j,k,ii,jj,dl !print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec -!print*,'coarse c extents ',G%isc_zap2,G%iec_zap2,G%jsc_zap2,G%jec_zap2 +!print*,'coarse c extents ',G%HId2%isc,G%HId2%iec,G%HId2%jsc,G%HId2%jec !print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed -!print*,'coarse d extents ',G%isd_zap2,G%ied_zap2,G%jsd_zap2,G%jed_zap2 +!print*,'coarse d extents ',G%HId2%isd,G%HId2%ied,G%HId2%jsd,G%HId2%jed ! original c extents 5 52 5 52 ! coarse c extents 3 26 3 26 ! original d extents 1 56 1 56 ! coarse d extents 1 28 1 28 - - do dl=2,MAX_DECIM_LEV + + do dl=2,MAX_DSAMP_LEV ! 2d masks - call decimate_mask(G%mask2dT, diag_cs%decim(dl)%mask2dT, dl) - call decimate_mask(G%mask2dBu,diag_cs%decim(dl)%mask2dBu, dl) - call decimate_mask(G%mask2dCu,diag_cs%decim(dl)%mask2dCu, dl) - call decimate_mask(G%mask2dCv,diag_cs%decim(dl)%mask2dCv, dl) + call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl) + call downsample_mask(G%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl) + call downsample_mask(G%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl) + call downsample_mask(G%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl) ! 3d native masks are needed by diag_manager but the native variables ! can only be masked 2d - for ocean points, all layers exists. - allocate(diag_cs%decim(dl)%mask3dTL(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) - allocate(diag_cs%decim(dl)%mask3dBL(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz)) - allocate(diag_cs%decim(dl)%mask3dCuL(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2,1:nz)) - allocate(diag_cs%decim(dl)%mask3dCvL(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dTL(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dBL(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCuL(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCvL(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz)) do k=1,nz - diag_cs%decim(dl)%mask3dTL(:,:,k) = diag_cs%decim(dl)%mask2dT(:,:) - diag_cs%decim(dl)%mask3dBL(:,:,k) = diag_cs%decim(dl)%mask2dBu(:,:) - diag_cs%decim(dl)%mask3dCuL(:,:,k) = diag_cs%decim(dl)%mask2dCu(:,:) - diag_cs%decim(dl)%mask3dCvL(:,:,k) = diag_cs%decim(dl)%mask2dCv(:,:) + diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) enddo - allocate(diag_cs%decim(dl)%mask3dTi(G%isd_zap2:G%ied_zap2,G%jsd_zap2:G%jed_zap2,1:nz+1)) - allocate(diag_cs%decim(dl)%mask3dBi(G%IsdB_zap2:G%IedB_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz+1)) - allocate(diag_cs%decim(dl)%mask3dCui(G%IsdB_zap2:G%IedB_zap2,G%jsd_zap2:G%jed_zap2,1:nz+1)) - allocate(diag_cs%decim(dl)%mask3dCvi(G%isd_zap2:G%ied_zap2,G%JsdB_zap2:G%JedB_zap2,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dTi(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dBi(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCui(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCvi(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) do k=1,nz+1 - diag_cs%decim(dl)%mask3dTi(:,:,k) = diag_cs%decim(dl)%mask2dT(:,:) - diag_cs%decim(dl)%mask3dBi(:,:,k) = diag_cs%decim(dl)%mask2dBu(:,:) - diag_cs%decim(dl)%mask3dCui(:,:,k) = diag_cs%decim(dl)%mask2dCu(:,:) - diag_cs%decim(dl)%mask3dCvi(:,:,k) = diag_cs%decim(dl)%mask2dCv(:,:) + diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCui(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvi(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) enddo enddo -end subroutine decimate_diag_masks_set +end subroutine downsample_diag_masks_set -!> Get the diagnostics-compute indices (to be passed to send_data) based on the shape of -!! the diag field (the same way they are deduced for non-decimated fields) -subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) +!> Get the diagnostics-compute indices (to be passed to send_data) based on the shape of +!! the diag field (the same way they are deduced for non-downsampled fields) +subroutine downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) integer, intent(in) :: f1,f2 !< the sizes of the diag field in x and y - integer, intent(in) :: dl !< integer decimation level + integer, intent(in) :: dl !< integer downsample level type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output integer, intent(out) ::isv,iev,jsv,jev !< diagnostics-compute indices (to be passed to send_data) ! Local variables @@ -3515,71 +3503,71 @@ subroutine decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) character(len=500) :: mesg logical, save :: first_check = .true. - !Check ONCE that the decimated diag-compute domain is commensurate with the original non-decimated diag-compute domain - !This is a major limitation of the current implementation of the decimated diagnostics. - !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates. - !We want this check to error out only if there was a decimated diagnostics requested and about to post that is + !Check ONCE that the downsampled diag-compute domain is commensurate with the original non-downsampled diag-compute domain + !This is a major limitation of the current implementation of the downsampled diagnostics. + !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates. + !We want this check to error out only if there was a downsampled diagnostics requested and about to post that is !why the check is here and not in the init routines. This check need to be done only once, hence the outer if statement if(first_check) then if(mod(diag_cs%ie-diag_cs%is+1, dl) .ne. 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) .ne. 0) then - write (mesg,*) "Non-commensurate decimated domain is not supported. "//& + write (mesg,*) "Non-commensurate downsampled domain is not supported. "//& "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl, " Current domain extents: ",& diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je - call MOM_error(FATAL,"decimate_diag_indices_get: "//trim(mesg)) + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) endif first_check = .false. endif - - cszi = diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc +1 ; dszi = diag_cs%decim(dl)%ied-diag_cs%decim(dl)%isd +1 - cszj = diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc +1 ; dszj = diag_cs%decim(dl)%jed-diag_cs%decim(dl)%jsd +1 - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec - jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec + cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1 + cszj = diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc +1 ; dszj = diag_cs%dsamp(dl)%jed-diag_cs%dsamp(dl)%jsd +1 + + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec if ( f1 == dszi ) then - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec ! field on Data domain, take compute domain indcies - !The rest is not taken with the full MOM6 diag_table + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies + !The rest is not taken with the full MOM6 diag_table elseif ( f1 == dszi + 1 ) then - isv = diag_cs%decim(dl)%isc ; iev = diag_cs%decim(dl)%iec+1 ! Symmetric data domain + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1 ! Symmetric data domain elseif ( f1 == cszi) then - isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +1 ! Computational domain + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +1 ! Computational domain elseif ( f1 == cszi + 1 ) then - isv = 1 ; iev = (diag_cs%decim(dl)%iec-diag_cs%decim(dl)%isc) +2 ! Symmetric computational domain + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2 ! Symmetric computational domain else write (mesg,*) " peculiar size ",f1," in i-direction\n"//& "does not match one of ", cszi, cszi+1, dszi, dszi+1 - call MOM_error(FATAL,"decimate_diag_indices_get: "//trim(mesg)) + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) endif if ( f2 == dszj ) then - jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec ! Data domain + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec ! Data domain elseif ( f2 == dszj + 1 ) then - jsv = diag_cs%decim(dl)%jsc ; jev = diag_cs%decim(dl)%jec+1 ! Symmetric data domain + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec+1 ! Symmetric data domain elseif ( f2 == cszj) then - jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +1 ! Computational domain + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +1 ! Computational domain elseif ( f2 == cszj + 1 ) then - jsv = 1 ; jev = (diag_cs%decim(dl)%jec-diag_cs%decim(dl)%jsc) +2 ! Symmetric computational domain + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2 ! Symmetric computational domain else write (mesg,*) " peculiar size ",f2," in j-direction\n"//& "does not match one of ", cszj, cszj+1, dszj, dszj+1 - call MOM_error(FATAL,"decimate_diag_indices_get: "//trim(mesg)) + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) endif -end subroutine decimate_diag_indices_get +end subroutine downsample_diag_indices_get -!> This subroutine allocates and computes a decimated array from an input array -!! It also determines the diagnostics-compurte indices for the decimated array -!! 3d interface -subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) +!> This subroutine allocates and computes a downsampled array from an input array +!! It also determines the diagnostics-compurte indices for the downsampled array +!! 3d interface +subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) real, dimension(:,:,:), pointer :: locfield !< input array pointer - real, dimension(:,:,:), allocatable, intent(inout) :: locfield_decim !< output (decimated) array + real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< output (downsampled) array type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post - integer, intent(in) :: dl !< integer decimation level + integer, intent(in) :: dl !< integer downsample level integer, intent(inout):: isv,iev,jsv,jev !< diagnostics-compute indices (to be passed to send_data) real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. !locals - real, dimension(:,:,:), pointer :: locmask + real, dimension(:,:,:), pointer :: locmask integer :: f1,f2,isv_o,jsv_o - + locmask => NULL() !Get the correct indices corresponding to input field !Shape of the input diag field @@ -3587,37 +3575,37 @@ subroutine decimate_diag_field_3d(locfield, locfield_decim, dl, diag_cs, diag,is f2=size(locfield,2)/dl !Save the extents of the original (fine) domain isv_o=isv;jsv_o=jsv - !Get the shape of the decimated field and overwrite isv,iev,jsv,jev with them - call decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) - !Set the non-decimated mask, it must be associated and initialized + !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them + call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) + !Set the non-downsampled mask, it must be associated and initialized if (present(mask)) then locmask => mask elseif (associated(diag%axes%mask3d)) then locmask => diag%axes%mask3d else - call MOM_error(FATAL, "decimate_diag_field_3d: Cannot decimate without a mask!!! ") + call MOM_error(FATAL, "downsample_diag_field_3d: Cannot downsample without a mask!!! ") endif - - call decimate_field(locfield, locfield_decim, dl, diag%xyz_method, locmask, diag_cs, diag, & + + call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs, diag, & isv_o,jsv_o,isv,iev,jsv,jev) - -end subroutine decimate_diag_field_3d -!> This subroutine allocates and computes a decimated array from an input array -!! It also determines the diagnostics-compurte indices for the decimated array -!! 2d interface -subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,isv,iev,jsv,jev, mask) +end subroutine downsample_diag_field_3d + +!> This subroutine allocates and computes a downsampled array from an input array +!! It also determines the diagnostics-compurte indices for the downsampled array +!! 2d interface +subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) real, dimension(:,:), pointer :: locfield !< input array pointer - real, dimension(:,:), allocatable, intent(inout) :: locfield_decim !< output (decimated) array + real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< output (downsampled) array type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post - integer, intent(in) :: dl !< integer decimation level + integer, intent(in) :: dl !< integer downsample level integer, intent(out):: isv,iev,jsv,jev !< diagnostics-compute indices (to be passed to send_data) real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. !locals - real, dimension(:,:), pointer :: locmask + real, dimension(:,:), pointer :: locmask integer :: f1,f2,isv_o,jsv_o - + locmask => NULL() !Get the correct indices corresponding to input field !Shape of the input diag field @@ -3625,56 +3613,56 @@ subroutine decimate_diag_field_2d(locfield, locfield_decim, dl, diag_cs, diag,is f2=size(locfield,2)/dl !Save the extents of the original (fine) domain isv_o=isv;jsv_o=jsv - !Get the shape of the decimated field and overwrite isv,iev,jsv,jev with them - call decimate_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) - !Set the non-decimated mask, it must be associated and initialized + !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them + call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) + !Set the non-downsampled mask, it must be associated and initialized if (present(mask)) then locmask => mask elseif (associated(diag%axes%mask2d)) then locmask => diag%axes%mask2d else - call MOM_error(FATAL, "decimate_diag_field_2d: Cannot decimate without a mask!!! ") + call MOM_error(FATAL, "downsample_diag_field_2d: Cannot downsample without a mask!!! ") endif - - call decimate_field(locfield, locfield_decim, dl, diag%xyz_method, locmask, diag_cs,diag, & + + call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, & isv_o,jsv_o,isv,iev,jsv,jev) - -end subroutine decimate_diag_field_2d -!> The decimation algorithm -!! The decimation method could be deduced (before send_data call) +end subroutine downsample_diag_field_2d + +!> The downsample algorithm +!! The downsample method could be deduced (before send_data call) !! from the diag%x_cell_method, diag%y_cell_method and diag%v_cell_method -!! -!! This is the summary of the decimation algoritm for a diagnostic field f: +!! +!! This is the summary of the downsample algoritm for a diagnostic field f: !! f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)] -!! i and j run from 0 to dl-1 (dl being the decimation level) -!! Id,Jd are the decimated (coarse grid) indices run over the coarsened compute grid, +!! i and j run from 0 to dl-1 (dl being the downsample level) +!! Id,Jd are the downsampled (coarse grid) indices run over the coarsened compute grid, !! if and jf are the original (fine grid) indices !! -!!example x_cell y_cell v_cell algorithm_id impemented weight(if,jf) +!!example x_cell y_cell v_cell algorithm_id impemented weight(if,jf) !!--------------------------------------------------------------------------------------- -!!theta mean mean mean MMM =222 G%areaT(if,jf)*h(if,jf) -!!u point mean mean PMM =022 dyCu(if,jf)*h(if,jf)*delta(if,Id) -!!? point sum mean PSM =012 dyCu(if,jf)*h(if,jf)*delta(if,Id) right? -!!v mean point mean MPM =202 dxCv(if,jf)*h(if,jf)*delta(jf,Jd) -!!volcello sum sum sum SSS =111 1 -!!T_dfxy_co sum sum point SSP =110 1 right? T_dfxy_cont_tendency_2d -!!umo point sum sum PSS =011 1*delta(if,Id) -!!vmo sum point sum SPS =101 1*delta(jf,Jd) -!!umo_2d point sum point PSP =010 1*delta(if,Id) right? -!!vmo_2d sum point point SPP =100 1*delta(jf,Jd) right? -!!? point mean point PMP =020 dyCu(if,jf)*delta(if,Id) right? -!!? mean point point MPP =200 dxCv(if,jf)*delta(jf,Jd) right? -!!w mean mean point MMP =220 G%areaT(if,jf) -!!h*theta mean mean sum MMS =221 G%areaT(if,jf) right? +!!theta mean mean mean MMM =222 G%areaT(if,jf)*h(if,jf) +!!u point mean mean PMM =022 dyCu(if,jf)*h(if,jf)*delta(if,Id) +!!v mean point mean MPM =202 dxCv(if,jf)*h(if,jf)*delta(jf,Jd) +!!? point sum mean PSM =012 h(if,jf)*delta(if,Id) +!!volcello sum sum sum SSS =111 1 +!!T_dfxy_co sum sum point SSP =110 1 +!!umo point sum sum PSS =011 1*delta(if,Id) +!!vmo sum point sum SPS =101 1*delta(jf,Jd) +!!umo_2d point sum point PSP =010 1*delta(if,Id) +!!vmo_2d sum point point SPP =100 1*delta(jf,Jd) +!!? point mean point PMP =020 dyCu(if,jf)*delta(if,Id) +!!? mean point point MPP =200 dxCv(if,jf)*delta(jf,Jd) +!!w mean mean point MMP =220 G%areaT(if,jf) +!!h*theta mean mean sum MMS =221 G%areaT(if,jf) !! !!delta is the Kroneker delta -!> This subroutine allocates and computes a decimated array given an input array -!! The decimation method is based on the "cell_methods" for the diagnostics as explained +!> This subroutine allocates and computes a downsampled array given an input array +!! The downsample method is based on the "cell_methods" for the diagnostics as explained !! in the above table -!! 3d interface -subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) +!! 3d interface +subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) real, dimension(:,:,:) , pointer :: field_in real, dimension(:,:,:) , allocatable :: field_out integer , intent(in) :: dl @@ -3683,7 +3671,7 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer , intent(in) :: isv_o,jsv_o !< original indices, In practice isv_o=jsv_o=1 - integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< decimaed indices + integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< dsampaed indices !locals character(len=240) :: mesg integer :: i,j,ii,jj,i0,j0 @@ -3692,10 +3680,10 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia real :: epsilon = 1.0e-20 ks=1 ; ke =size(field_in,3) - !Allocate the decimated field on the decimated data domain - allocate(field_out(diag_cs%decim(dl)%isd:diag_cs%decim(dl)%ied,diag_cs%decim(dl)%jsd:diag_cs%decim(dl)%jed,ks:ke)) + !Allocate the downsampled field on the downsampled data domain + allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed,ks:ke)) ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke)) - !Fill the decimated field on the decimated diagnostics (almost always compuate) domain + !Fill the downsampled field on the downsampled diagnostics (almost always compuate) domain if(method .eq. MMM) then !xyz_method = MMM = 222 do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) @@ -3717,7 +3705,7 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia ave = 0.0 total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj,k) total_weight = total_weight + weight ave=ave+field_in(ii,jj,k)*weight @@ -3731,7 +3719,7 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia ave = 0.0 total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight ave=ave+field_in(ii,jj,k)*weight @@ -3746,8 +3734,8 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight =mask(ii,jj,k)*diag_cs%G%dyCu(ii,jj)*diag_cs%h(ii,jj,k) - total_weight = total_weight +weight + weight =mask(ii,jj,k)*diag_cs%G%dyCu(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 @@ -3760,8 +3748,8 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight =mask(ii,jj,k)*diag_cs%G%dyCu(ii,jj)*diag_cs%h(ii,jj,k) - total_weight = total_weight +weight + weight =mask(ii,jj,k)*diag_cs%h(ii,jj,k) + total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 @@ -3774,8 +3762,8 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight =mask(ii,jj,k) - total_weight = total_weight +weight + weight =mask(ii,jj,k) + total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 @@ -3788,8 +3776,8 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight =mask(ii,jj,k) - total_weight = total_weight +weight + weight =mask(ii,jj,k) + total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 @@ -3802,20 +3790,20 @@ subroutine decimate_field_3d(field_in, field_out, dl, method, mask, diag_cs, dia total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight = mask(ii,jj,k)*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k) + weight = mask(ii,jj,k)*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k) total_weight = total_weight + weight ave=ave+field_in(ii,jj,k)*weight enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo else - write (mesg,*) " unknown sampling method: ",method - call MOM_error(FATAL, "decimate_field_3d: "//trim(mesg)//" "//trim(diag%debug_str)) + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_3d: "//trim(mesg)//" "//trim(diag%debug_str)) endif - -end subroutine decimate_field_3d -subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) +end subroutine downsample_field_3d + +subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) real, dimension(:,:) , pointer :: field_in real, dimension(:,:) , allocatable :: field_out integer , intent(in) :: dl @@ -3824,54 +3812,40 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer , intent(in) :: isv_o,jsv_o !< original indices, In practice isv_o=jsv_o=1 - integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< decimaed indices + integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< dsampaed indices !locals character(len=240) :: mesg integer :: i,j,ii,jj,i0,j0 real :: ave,total_weight,weight real :: epsilon = 1.0e-20 - !Allocate the decimated field on the decimated data domain - allocate(field_out(diag_cs%decim(dl)%isd:diag_cs%decim(dl)%ied,diag_cs%decim(dl)%jsd:diag_cs%decim(dl)%jed)) + !Allocate the downsampled field on the downsampled data domain + allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed)) ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl)) - !Fill the decimated field on the decimated diagnostics (almost always compuate) domain + !Fill the downsampled field on the downsampled diagnostics (almost always compuate) domain - if(method .eq. MMM) then !xyz_method = MMM + if(method .eq. MMP) then !xyz_method = MMP do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,1) - total_weight = total_weight + weight - ave=ave+field_in(ii,jj)*weight - enddo; enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo; enddo - elseif(method .eq. MMP) then !xyz_method = MMP - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight ave=ave+field_in(ii,jj)*weight enddo; enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. SSP) then !xyz_method = SSP , e.g., T_dfxy_cont_tendency_2d + elseif(method .eq. SSP) then !xyz_method = SSP , e.g., T_dfxy_cont_tendency_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj) total_weight = total_weight + weight ave=ave+field_in(ii,jj)*weight @@ -3886,8 +3860,8 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight =mask(ii,jj) - total_weight = total_weight +weight + weight =mask(ii,jj) + total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 @@ -3900,8 +3874,8 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight =mask(ii,jj) - total_weight = total_weight +weight + weight =mask(ii,jj) + total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 @@ -3914,8 +3888,8 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight =mask(ii,jj)*diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? - total_weight = total_weight +weight + weight =mask(ii,jj)*diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 @@ -3928,35 +3902,35 @@ subroutine decimate_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight =mask(ii,jj)*diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? - total_weight = total_weight +weight + weight =mask(ii,jj)*diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo else - write (mesg,*) " unknown sampling method: ",method - call MOM_error(FATAL, "decimate_field_2d: "//trim(mesg)//" "//trim(diag%debug_str)) + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_2d: "//trim(mesg)//" "//trim(diag%debug_str)) endif - -end subroutine decimate_field_2d -!> Allocate and compute the decimated masks -!! The masks are decimated based on a minority rule, i.e., a coarse cell is open (1) +end subroutine downsample_field_2d + +!> Allocate and compute the downsampled masks +!! The masks are downsampled based on a minority rule, i.e., a coarse cell is open (1) !! if at least one of the sub-cells are open, otherwise it's closed (0) -subroutine decimate_mask_3d_p(field_in, field_out, dl) +subroutine downsample_mask_3d_p(field_in, field_out, dl) integer , intent(in) :: dl real, dimension(:,:,:) , pointer :: field_in, field_out integer :: i,j,ii,jj,i0,j0 integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d integer :: k,ks,ke real :: tot_non_zero - !decimated mask = 0 unless the mask value of one of the decimating cells is 1 + !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 isv_o=1 jsv_o=1 - ks = lbound(field_in,3) ; ke = ubound(field_in,3) + ks = lbound(field_in,3) ; ke = ubound(field_in,3) isv_d=1; iev_d=size(field_in,1)/dl - jsv_d=1; jev_d=size(field_in,2)/dl + jsv_d=1; jev_d=size(field_in,2)/dl allocate(field_out(isv_d:iev_d,jsv_d:jev_d,ks:ke)) field_out(:,:,:) = 0.0 do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -3964,40 +3938,40 @@ subroutine decimate_mask_3d_p(field_in, field_out, dl) j0 = jsv_o+dl*(j-jsv_d) tot_non_zero = 0.0 ! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj,k) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 enddo; enddo; enddo -end subroutine decimate_mask_3d_p +end subroutine downsample_mask_3d_p -subroutine decimate_mask_2d_p(field_in, field_out, dl) +subroutine downsample_mask_2d_p(field_in, field_out, dl) integer , intent(in) :: dl real, dimension(:,:) , intent(in) :: field_in real, dimension(:,:) , pointer :: field_out integer :: i,j,ii,jj,i0,j0 integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d real :: tot_non_zero - !decimated mask = 0 unless the mask value of one of the decimating cells is 1 + !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 isv_o=1 jsv_o=1 isv_d=1; iev_d=size(field_in,1)/dl - jsv_d=1; jev_d=size(field_in,2)/dl - allocate(field_out(isv_d:iev_d,jsv_d:jev_d)) + jsv_d=1; jev_d=size(field_in,2)/dl + allocate(field_out(isv_d:iev_d,jsv_d:jev_d)) field_out(:,:) = 0.0 do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) tot_non_zero = 0.0 ! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j)=1.0 enddo; enddo -end subroutine decimate_mask_2d_p +end subroutine downsample_mask_2d_p -subroutine decimate_mask_3d_a(field_in, field_out, dl) +subroutine downsample_mask_3d_a(field_in, field_out, dl) integer , intent(in) :: dl real, dimension(:,:,:), pointer :: field_in real, dimension(:,:,:), allocatable :: field_out @@ -4005,51 +3979,51 @@ subroutine decimate_mask_3d_a(field_in, field_out, dl) integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d integer :: k,ks,ke real :: tot_non_zero - !decimated mask = 0 unless the mask value of one of the decimating cells is 1 + !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 isv_o=1 jsv_o=1 - ks = lbound(field_in,3) ; ke = ubound(field_in,3) + ks = lbound(field_in,3) ; ke = ubound(field_in,3) isv_d=1; iev_d=size(field_in,1)/dl - jsv_d=1; jev_d=size(field_in,2)/dl + jsv_d=1; jev_d=size(field_in,2)/dl allocate(field_out(isv_d:iev_d,jsv_d:jev_d,ks:ke)) field_out(:,:,:) = 0.0 do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) tot_non_zero = 0.0 -! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 +! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj,k) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 enddo; enddo; enddo -end subroutine decimate_mask_3d_a +end subroutine downsample_mask_3d_a -subroutine decimate_mask_2d_a(field_in, field_out, dl) +subroutine downsample_mask_2d_a(field_in, field_out, dl) integer , intent(in) :: dl real, dimension(:,:) , intent(in) :: field_in real, dimension(:,:) , allocatable :: field_out integer :: i,j,ii,jj,i0,j0 integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d real :: tot_non_zero - !decimated mask = 0 unless the mask value of one of the decimating cells is 1 + !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 isv_o=1 jsv_o=1 isv_d=1; iev_d=size(field_in,1)/dl - jsv_d=1; jev_d=size(field_in,2)/dl + jsv_d=1; jev_d=size(field_in,2)/dl allocate(field_out(isv_d:iev_d,jsv_d:jev_d)) field_out(:,:) = 0.0 do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) tot_non_zero = 0.0 -! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 +! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j)=1.0 enddo; enddo -end subroutine decimate_mask_2d_a +end subroutine downsample_mask_2d_a end module MOM_diag_mediator diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index c4ef88d30c..55e6e47b63 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -32,7 +32,7 @@ module MOM_domains implicit none ; private -public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent, get_domain_extent_zap2 +public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent, get_domain_extent_dsamp2 public :: MOM_define_domain, MOM_define_io_domain, clone_MOM_domain public :: pass_var, pass_vector, PE_here, root_PE, num_PEs public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast @@ -99,7 +99,7 @@ module MOM_domains type, public :: MOM_domain_type type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos !! on this processor, centered at h points. - type(domain2D), pointer :: mpp_domain_zap2 => NULL() !< A coarse FMS domain with halos + type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos !! on this processor, centered at h points. integer :: niglobal !< The total horizontal i-domain size. integer :: njglobal !< The total horizontal j-domain size. @@ -1206,7 +1206,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & character(len=8) :: char_xsiz, char_ysiz, char_niglobal, char_njglobal character(len=40) :: nihalo_nm, njhalo_nm, layout_nm, io_layout_nm, masktable_nm character(len=40) :: niproc_nm, njproc_nm - integer :: xhalo_zap2,yhalo_zap2 + integer :: xhalo_d2,yhalo_d2 ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -1214,7 +1214,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) - allocate(MOM_dom%mpp_domain_zap2) + allocate(MOM_dom%mpp_domain_d2) endif pe = PE_here() @@ -1571,26 +1571,29 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & global_indices(1) = 1 ; global_indices(2) = int(MOM_dom%niglobal/2) global_indices(3) = 1 ; global_indices(4) = int(MOM_dom%njglobal/2) - xhalo_zap2 = int(MOM_dom%nihalo/2) - yhalo_zap2 = int(MOM_dom%njhalo/2) + !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. + !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get + !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 + xhalo_d2 = int(MOM_dom%nihalo/2) + yhalo_d2 = int(MOM_dom%njhalo/2) if (mask_table_exists) then - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_zap2, & + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=xhalo_zap2, yhalo=yhalo_zap2, & + xhalo=xhalo_d2, yhalo=yhalo_d2, & symmetry = MOM_dom%symmetric, name=trim("MOMc"), & maskmap=MOM_dom%maskmap ) else - call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_zap2, & + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & xflags=X_FLAGS, yflags=Y_FLAGS, & - xhalo=xhalo_zap2, yhalo=yhalo_zap2, & + xhalo=xhalo_d2, yhalo=yhalo_d2, & symmetry = MOM_dom%symmetric, name=trim("MOMc")) endif if ((io_layout(1) > 0) .and. (io_layout(2) > 0) .and. & (layout(1)*layout(2) > 1)) then - call MOM_define_io_domain(MOM_dom%mpp_domain_zap2, io_layout) + call MOM_define_io_domain(MOM_dom%mpp_domain_d2, io_layout) endif - + end subroutine MOM_domains_init !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing @@ -1622,7 +1625,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) - allocate(MOM_dom%mpp_domain_zap2) + allocate(MOM_dom%mpp_domain_d2) endif ! Save the extra data for creating other domains of different resolution that overlay this domain @@ -1818,23 +1821,23 @@ subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & end subroutine get_domain_extent -subroutine get_domain_extent_zap2(Domain, isc_zap2, iec_zap2, jsc_zap2, jec_zap2,& - isd_zap2, ied_zap2, jsd_zap2, jed_zap2,& - isg_zap2, ieg_zap2, jsg_zap2, jeg_zap2) +subroutine get_domain_extent_dsamp2(Domain, isc_d2, iec_d2, jsc_d2, jec_d2,& + isd_d2, ied_d2, jsd_d2, jed_d2,& + isg_d2, ieg_d2, jsg_d2, jeg_d2) type(MOM_domain_type), & intent(in) :: Domain !< The MOM domain from which to extract information - integer, intent(out) :: isc_zap2, iec_zap2, jsc_zap2, jec_zap2 - integer, intent(out) :: isd_zap2, ied_zap2, jsd_zap2, jed_zap2 - integer, intent(out) :: isg_zap2, ieg_zap2, jsg_zap2, jeg_zap2 - call mpp_get_compute_domain(Domain%mpp_domain_zap2, isc_zap2, iec_zap2, jsc_zap2, jec_zap2) - call mpp_get_data_domain(Domain%mpp_domain_zap2, isd_zap2, ied_zap2, jsd_zap2, jed_zap2) - call mpp_get_global_domain (Domain%mpp_domain_zap2, isg_zap2, ieg_zap2, jsg_zap2, jeg_zap2) + integer, intent(out) :: isc_d2, iec_d2, jsc_d2, jec_d2 + integer, intent(out) :: isd_d2, ied_d2, jsd_d2, jed_d2 + integer, intent(out) :: isg_d2, ieg_d2, jsg_d2, jeg_d2 + call mpp_get_compute_domain(Domain%mpp_domain_d2, isc_d2, iec_d2, jsc_d2, jec_d2) + call mpp_get_data_domain(Domain%mpp_domain_d2, isd_d2, ied_d2, jsd_d2, jed_d2) + call mpp_get_global_domain (Domain%mpp_domain_d2, isg_d2, ieg_d2, jsg_d2, jeg_d2) ! This code institutes the MOM convention that local array indices start at 1. - isc_zap2 = isc_zap2-isd_zap2+1 ; iec_zap2 = iec_zap2-isd_zap2+1 - jsc_zap2 = jsc_zap2-jsd_zap2+1 ; jec_zap2 = jec_zap2-jsd_zap2+1 - ied_zap2 = ied_zap2-isd_zap2+1 ; jed_zap2 = jed_zap2-jsd_zap2+1 - isd_zap2 = 1 ; jsd_zap2 = 1 -end subroutine get_domain_extent_zap2 + isc_d2 = isc_d2-isd_d2+1 ; iec_d2 = iec_d2-isd_d2+1 + jsc_d2 = jsc_d2-jsd_d2+1 ; jec_d2 = jec_d2-jsd_d2+1 + ied_d2 = ied_d2-isd_d2+1 ; jed_d2 = jed_d2-jsd_d2+1 + isd_d2 = 1 ; jsd_d2 = 1 +end subroutine get_domain_extent_dsamp2 !> Return the (potentially symmetric) computational domain i-bounds for an array !! passed without index specifications (i.e. indices start at 1) based on an array size. From 16fef4f69f3641f0c1af91f6b290f17528960e38 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 26 Oct 2018 17:44:17 -0400 Subject: [PATCH 15/18] Diagnostics downsampling, fix the issue for symmetric case - There was a unnecessary check for symmetric case --- src/core/MOM_grid.F90 | 5 ++-- src/framework/MOM_diag_mediator.F90 | 37 ++++++++++++++++------------- 2 files changed, 24 insertions(+), 18 deletions(-) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 453e351060..39aa9290f0 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -21,7 +21,7 @@ module MOM_grid type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain type(MOM_domain_type), pointer :: Domain_aux => NULL() !< A non-symmetric auxiliary domain type. type(hor_index_type) :: HI !< Horizontal index ranges - type(hor_index_type) :: HId2 !< Horizontal index ranges for level-2-downsampling + type(hor_index_type) :: HId2 !< Horizontal index ranges for level-2-downsampling integer :: isc !< The start i-index of cell centers within the computational domain integer :: iec !< The end i-index of cell centers within the computational domain @@ -348,8 +348,9 @@ subroutine MOM_grid_init(G, param_file, HI, global_indexing, bathymetry_at_vel) call get_domain_extent_dsamp2(G%Domain, G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec,& G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed,& G%HId2%isg, G%HId2%ieg, G%HId2%jsg, G%HId2%jeg) - + ! Set array sizes for fields that are discretized at tracer cell boundaries. + G%HId2%IegB = G%HId2%ieg ; G%HId2%JegB = G%HId2%jeg G%HId2%IsdB = G%HId2%isd ; G%HId2%JsdB = G%HId2%jsd if (G%symmetric) then G%HId2%IsdB = G%HId2%isd-1 ; G%HId2%JsdB = G%HId2%jsd-1 diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 2abc9b611d..8ba54ba997 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -517,6 +517,8 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n integer :: i, j, k, nz, dl real, dimension(:), pointer :: gridLonT_dsamp =>NULL() real, dimension(:), pointer :: gridLatT_dsamp =>NULL() + real, dimension(:), pointer :: gridLonB_dsamp =>NULL() + real, dimension(:), pointer :: gridLatB_dsamp =>NULL() id_zl = id_zl_native ; id_zi = id_zi_native !Axes group for native downsampled diagnostics @@ -524,29 +526,32 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n if(dl .ne. 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!") allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) - do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo - - if (G%symmetric) then - call MOM_error(FATAL, "set_axes_info_dsamp: Downsample of symmetric case is not supported yet!") - ! id_xq = diag_axis_init('xq', gridLonB_dsamp(G%isgB:G%iegB), G%x_axis_units, 'x', & - ! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) - ! id_yq = diag_axis_init('yq', gridLatB_dsamp(G%jsgB:G%jegB), G%y_axis_units, 'y', & - ! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) - else - id_xq = diag_axis_init('xq', gridLonT_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) - id_yq = diag_axis_init('yq', gridLatT_dsamp, G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) - endif + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo + +!I don't see a need for this since isgB=isg and iegB=ieg +! if (G%symmetric) then +! id_xq = diag_axis_init('xq', gridLonB_dsamp(G%isgB:G%iegB), G%x_axis_units, 'x', & +! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) +! id_yq = diag_axis_init('yq', gridLatB_dsamp(G%jsgB:G%jegB), G%y_axis_units, 'y', & +! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) +! else + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) +! endif id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & 'h point nominal longitude', Domain2=G%Domain%mpp_domain_d2) id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & 'h point nominal latitude', Domain2=G%Domain%mpp_domain_d2) - deallocate(gridLonT_dsamp) - deallocate(gridLatT_dsamp) + deallocate(gridLonT_dsamp,gridLatT_dsamp) + deallocate(gridLonB_dsamp,gridLatB_dsamp) ! Axis groupings for the model layers call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & From 1cfc3841b8c988603e43224c9d2211c933002b39 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 30 Oct 2018 11:17:34 -0400 Subject: [PATCH 16/18] Downsample Diagnostics, fix symmetric memory case - This updates fixes the symetric memory case. By hook or by crook, the downsampled diagnostics now run for both symmetric and non-symmetric memory cases. --- src/core/MOM_grid.F90 | 7 +- src/framework/MOM_diag_mediator.F90 | 292 +++++++++++++++------------- 2 files changed, 159 insertions(+), 140 deletions(-) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 39aa9290f0..a08c6c4c6c 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -350,12 +350,17 @@ subroutine MOM_grid_init(G, param_file, HI, global_indexing, bathymetry_at_vel) G%HId2%isg, G%HId2%ieg, G%HId2%jsg, G%HId2%jeg) ! Set array sizes for fields that are discretized at tracer cell boundaries. - G%HId2%IegB = G%HId2%ieg ; G%HId2%JegB = G%HId2%jeg + G%HId2%IscB = G%HId2%isc ; G%HId2%JscB = G%HId2%jsc G%HId2%IsdB = G%HId2%isd ; G%HId2%JsdB = G%HId2%jsd + G%HId2%IsgB = G%HId2%isg ; G%HId2%JsgB = G%HId2%jsg if (G%symmetric) then + G%HId2%IscB = G%HId2%isc-1 ; G%HId2%JscB = G%HId2%jsc-1 G%HId2%IsdB = G%HId2%isd-1 ; G%HId2%JsdB = G%HId2%jsd-1 + G%HId2%IsgB = G%HId2%isg-1 ; G%HId2%JsgB = G%HId2%jsg-1 endif + G%HId2%IecB = G%HId2%iec ; G%HId2%JecB = G%HId2%jec G%HId2%IedB = G%HId2%ied ; G%HId2%JedB = G%HId2%jed + G%HId2%IegB = G%HId2%ieg ; G%HId2%JegB = G%HId2%jeg end subroutine MOM_grid_init diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 8ba54ba997..1f58e1489e 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -73,7 +73,7 @@ module MOM_diag_mediator end interface downsample_field interface downsample_mask - module procedure downsample_mask_2d_p, downsample_mask_3d_p, downsample_mask_2d_a, downsample_mask_3d_a + module procedure downsample_mask_2d, downsample_mask_3d end interface downsample_mask interface downsample_diag_field @@ -160,6 +160,7 @@ module MOM_diag_mediator integer :: MMS=221 !< x:mean,y:mean,z:sum integer :: SSS=111 !< x:sum,y:sum,z:sum integer :: MMM=222 !< x:mean,y:mean,z:mean +integer :: MSK=-1 !< Use the downsample method of a mask !> This type is used to represent a diagnostic at the diag_mediator level. !! @@ -193,6 +194,7 @@ module MOM_diag_mediator integer :: jsd !< The start j-index of cell centers within the data domain integer :: jed !< The end j-index of cell centers within the data domain integer :: isg,ieg,jsg,jeg + integer :: isgB,iegB,jsgB,jegB type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi @@ -524,34 +526,38 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n !Axes group for native downsampled diagnostics do dl=2,MAX_DSAMP_LEV if(dl .ne. 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!") + if (G%symmetric) then + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB)) + do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo + do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + else + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + endif + allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo - allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) - allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) - do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo - do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo - -!I don't see a need for this since isgB=isg and iegB=ieg -! if (G%symmetric) then -! id_xq = diag_axis_init('xq', gridLonB_dsamp(G%isgB:G%iegB), G%x_axis_units, 'x', & -! 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) -! id_yq = diag_axis_init('yq', gridLatB_dsamp(G%jsgB:G%jegB), G%y_axis_units, 'y', & -! 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) -! else - id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) - id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) -! endif id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & 'h point nominal longitude', Domain2=G%Domain%mpp_domain_d2) id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & 'h point nominal latitude', Domain2=G%Domain%mpp_domain_d2) deallocate(gridLonT_dsamp,gridLatT_dsamp) - deallocate(gridLonB_dsamp,gridLatB_dsamp) ! Axis groupings for the model layers call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & @@ -789,35 +795,43 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs) do c=1, diag_cs%num_diag_coords ! Level/layer h-points in diagnostic coordinate axes => diag_cs%remap_axesTL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-downsampled mask ! Level/layer u-points in diagnostic coordinate axes => diag_cs%remap_axesCuL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-downsampled mask ! Level/layer v-points in diagnostic coordinate axes => diag_cs%remap_axesCvL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-downsampled mask ! Level/layer q-points in diagnostic coordinate axes => diag_cs%remap_axesBL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface h-points in diagnostic coordinate (w-point) axes => diag_cs%remap_axesTi(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface u-points in diagnostic coordinate axes => diag_cs%remap_axesCui(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface v-points in diagnostic coordinate axes => diag_cs%remap_axesCvi(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl)!set downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB)!set downsampled mask diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask enddo enddo @@ -1283,7 +1297,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) character(len=300) :: mesg logical :: used, is_stat integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, i, j, chksum + integer :: isv, iev, jsv, jev, i, j, chksum, isv_o,jsv_o real, dimension(:,:), allocatable, target :: locfield_dsamp real, dimension(:,:), allocatable, target :: locmask_dsamp integer :: dl @@ -1353,11 +1367,12 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet !Downsample the diag field and mask (if present) if (dl > 1) then + isv_o=isv ; jsv_o=jsv call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) locfield => locfield_dsamp if (present(mask)) then - call downsample_mask(locmask, locmask_dsamp, dl) + call downsample_field_2d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) locmask => locmask_dsamp elseif(associated(diag%axes%dsamp(dl)%mask2d)) then locmask => diag%axes%dsamp(dl)%mask2d @@ -1538,11 +1553,11 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) logical :: staggered_in_x, staggered_in_y logical :: is_stat integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c + integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o integer :: chksum real, dimension(:,:,:), allocatable, target :: locfield_dsamp real, dimension(:,:,:), allocatable, target :: locmask_dsamp - integer :: isl,iel,jsl,jel,dl + integer :: dl locfield => NULL() locmask => NULL() @@ -1626,11 +1641,12 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet !Downsample the diag field and mask (if present) if (dl > 1) then + isv_o=isv ; jsv_o=jsv call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) locfield => locfield_dsamp if (present(mask)) then - call downsample_mask(locmask, locmask_dsamp, dl) + call downsample_field_3d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) locmask => locmask_dsamp elseif(associated(diag%axes%dsamp(dl)%mask3d)) then locmask => diag%axes%dsamp(dl)%mask3d @@ -2935,6 +2951,8 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) diag_cs%dsamp(2)%jsd = G%HId2%jsd ; diag_cs%dsamp(2)%jed = G%HId2%jed diag_cs%dsamp(2)%isg = G%HId2%isg ; diag_cs%dsamp(2)%ieg = G%HId2%ieg diag_cs%dsamp(2)%jsg = G%HId2%jsg ; diag_cs%dsamp(2)%jeg = G%HId2%jeg + diag_cs%dsamp(2)%isgB = G%HId2%isgB ; diag_cs%dsamp(2)%iegB = G%HId2%iegB + diag_cs%dsamp(2)%jsgB = G%HId2%jsgB ; diag_cs%dsamp(2)%jegB = G%HId2%jegB ! Initialze available diagnostic log file if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then @@ -3457,20 +3475,29 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) integer :: i,j,k,ii,jj,dl !print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec +!print*,'original c extents ',G%iscb,G%iecb,G%jscb,G%jecb !print*,'coarse c extents ',G%HId2%isc,G%HId2%iec,G%HId2%jsc,G%HId2%jec !print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed !print*,'coarse d extents ',G%HId2%isd,G%HId2%ied,G%HId2%jsd,G%HId2%jed -! original c extents 5 52 5 52 +! original c extents 5 52 5 52 +! original cB-nonsym extents 5 52 5 52 +! original cB-sym extents 4 52 4 52 ! coarse c extents 3 26 3 26 ! original d extents 1 56 1 56 +! original dB-nonsym extents 1 56 1 56 +! original dB-sym extents 0 56 0 56 ! coarse d extents 1 28 1 28 do dl=2,MAX_DSAMP_LEV - ! 2d masks - call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl) - call downsample_mask(G%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl) - call downsample_mask(G%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl) - call downsample_mask(G%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl) + ! 2d mask + call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,G%isc, G%jsc, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(G%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl,G%isc ,G%JscB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) ! 3d native masks are needed by diag_manager but the native variables ! can only be masked 2d - for ocean points, all layers exists. allocate(diag_cs%dsamp(dl)%mask3dTL(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz)) @@ -3498,13 +3525,13 @@ end subroutine downsample_diag_masks_set !> Get the diagnostics-compute indices (to be passed to send_data) based on the shape of !! the diag field (the same way they are deduced for non-downsampled fields) -subroutine downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) - integer, intent(in) :: f1,f2 !< the sizes of the diag field in x and y +subroutine downsample_diag_indices_get(fo1,fo2, dl, diag_cs,isv,iev,jsv,jev) + integer, intent(in) :: fo1,fo2 !< the sizes of the diag field in x and y integer, intent(in) :: dl !< integer downsample level type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output integer, intent(out) ::isv,iev,jsv,jev !< diagnostics-compute indices (to be passed to send_data) ! Local variables - integer :: dszi,cszi,dszj,cszj + integer :: dszi,cszi,dszj,cszj,f1,f2 character(len=500) :: mesg logical, save :: first_check = .true. @@ -3525,10 +3552,15 @@ subroutine downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1 cszj = diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc +1 ; dszj = diag_cs%dsamp(dl)%jed-diag_cs%dsamp(dl)%jsd +1 - isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec - + f1 = fo1/dl + f2 = fo2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(fo1,dl) + f2 = f2 + mod(fo2,dl) + endif if ( f1 == dszi ) then isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies !The rest is not taken with the full MOM6 diag_table @@ -3576,8 +3608,8 @@ subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, locmask => NULL() !Get the correct indices corresponding to input field !Shape of the input diag field - f1=size(locfield,1)/dl - f2=size(locfield,2)/dl + f1=size(locfield,1) + f2=size(locfield,2) !Save the extents of the original (fine) domain isv_o=isv;jsv_o=jsv !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them @@ -3614,8 +3646,8 @@ subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, locmask => NULL() !Get the correct indices corresponding to input field !Shape of the input diag field - f1=size(locfield,1)/dl - f2=size(locfield,2)/dl + f1=size(locfield,1) + f2=size(locfield,2) !Save the extents of the original (fine) domain isv_o=isv;jsv_o=jsv !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them @@ -3671,23 +3703,34 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d real, dimension(:,:,:) , pointer :: field_in real, dimension(:,:,:) , allocatable :: field_out integer , intent(in) :: dl - integer, intent(in) :: method !< sampling method, one of 00,01,02,10,20,11,22 - real, dimension(:,:,:), pointer :: mask + integer, intent(in) :: method !< sampling method + real, dimension(:,:,:), pointer :: mask type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer , intent(in) :: isv_o,jsv_o !< original indices, In practice isv_o=jsv_o=1 integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< dsampaed indices !locals character(len=240) :: mesg - integer :: i,j,ii,jj,i0,j0 + integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 integer :: k,ks,ke real :: ave,total_weight,weight real :: epsilon = 1.0e-20 ks=1 ; ke =size(field_in,3) !Allocate the downsampled field on the downsampled data domain - allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed,ks:ke)) +! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed,ks:ke)) ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke)) + f_in1 = size(field_in,1) + f_in2 = size(field_in,2) + f1 = f_in1/dl + f2 = f_in2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) + endif + allocate(field_out(1:f1,1:f2,ks:ke)) + !Fill the downsampled field on the downsampled diagnostics (almost always compuate) domain if(method .eq. MMM) then !xyz_method = MMM = 222 do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -3801,6 +3844,17 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo + elseif(method .eq. MSK) then !The input field is a mask, subsample + field_out(:,:,:) = 0.0 + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave=ave+field_in(ii,jj,k) + enddo; enddo + if(ave > 0.0) field_out(i,j,k)=1.0 + enddo; enddo; enddo else write (mesg,*) " unknown sampling method: ",method call MOM_error(FATAL, "downsample_field_3d: "//trim(mesg)//" "//trim(diag%debug_str)) @@ -3812,7 +3866,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,di real, dimension(:,:) , pointer :: field_in real, dimension(:,:) , allocatable :: field_out integer , intent(in) :: dl - integer, optional, intent(in) :: method !< sampling method, one of 00,01,02,10,20,11,22 + integer, intent(in) :: method !< sampling method real, dimension(:,:), pointer :: mask type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post @@ -3820,14 +3874,24 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,di integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< dsampaed indices !locals character(len=240) :: mesg - integer :: i,j,ii,jj,i0,j0 + integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 real :: ave,total_weight,weight real :: epsilon = 1.0e-20 !Allocate the downsampled field on the downsampled data domain - allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed)) +! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed)) ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl)) !Fill the downsampled field on the downsampled diagnostics (almost always compuate) domain + f_in1 = size(field_in,1) + f_in2 = size(field_in,2) + f1 = f_in1/dl + f2 = f_in2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) + endif + allocate(field_out(1:f1,1:f2)) if(method .eq. MMP) then !xyz_method = MMP do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -3913,6 +3977,17 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,di enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo + elseif(method .eq. MSK) then !The input field is a mask, subsample + field_out(:,:) = 0.0 + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave=ave+field_in(ii,jj) + enddo; enddo + if(ave > 0.0) field_out(i,j)=1.0 + enddo; enddo else write (mesg,*) " unknown sampling method: ",method call MOM_error(FATAL, "downsample_field_2d: "//trim(mesg)//" "//trim(diag%debug_str)) @@ -3923,113 +3998,52 @@ end subroutine downsample_field_2d !> Allocate and compute the downsampled masks !! The masks are downsampled based on a minority rule, i.e., a coarse cell is open (1) !! if at least one of the sub-cells are open, otherwise it's closed (0) -subroutine downsample_mask_3d_p(field_in, field_out, dl) - integer , intent(in) :: dl - real, dimension(:,:,:) , pointer :: field_in, field_out - integer :: i,j,ii,jj,i0,j0 - integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d - integer :: k,ks,ke - real :: tot_non_zero - !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 - isv_o=1 - jsv_o=1 - ks = lbound(field_in,3) ; ke = ubound(field_in,3) - isv_d=1; iev_d=size(field_in,1)/dl - jsv_d=1; jev_d=size(field_in,2)/dl - allocate(field_out(isv_d:iev_d,jsv_d:jev_d,ks:ke)) - field_out(:,:,:) = 0.0 - do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - tot_non_zero = 0.0 -! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - tot_non_zero = tot_non_zero + field_in(ii,jj,k) - enddo;enddo - if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 - enddo; enddo; enddo -end subroutine downsample_mask_3d_p - -subroutine downsample_mask_2d_p(field_in, field_out, dl) - integer , intent(in) :: dl +subroutine downsample_mask_2d(field_in, field_out, dl, isc_o,jsc_o, isc_d,iec_d,jsc_d,jec_d , isd_d,ied_d,jsd_d,jed_d) real, dimension(:,:) , intent(in) :: field_in real, dimension(:,:) , pointer :: field_out + integer , intent(in) :: dl + integer , intent(in) :: isc_o,jsc_o + integer , intent(in) :: isc_d,iec_d,jsc_d,jec_d !< downsampled mask compute indices + integer , intent(in) :: isd_d,ied_d,jsd_d,jed_d !< downsampled mask data indices integer :: i,j,ii,jj,i0,j0 - integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d real :: tot_non_zero !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 - isv_o=1 - jsv_o=1 - isv_d=1; iev_d=size(field_in,1)/dl - jsv_d=1; jev_d=size(field_in,2)/dl - allocate(field_out(isv_d:iev_d,jsv_d:jev_d)) + allocate(field_out(isd_d:ied_d,jsd_d:jed_d)) field_out(:,:) = 0.0 - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) + do j=jsc_d,jec_d ; do i=isc_d,iec_d + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) tot_non_zero = 0.0 -! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j)=1.0 enddo; enddo -end subroutine downsample_mask_2d_p +end subroutine downsample_mask_2d -subroutine downsample_mask_3d_a(field_in, field_out, dl) +subroutine downsample_mask_3d(field_in, field_out, dl, isc_o,jsc_o, isc_d,iec_d,jsc_d,jec_d , isd_d,ied_d,jsd_d,jed_d) + real, dimension(:,:,:) , intent(in) :: field_in + real, dimension(:,:,:) , pointer :: field_out integer , intent(in) :: dl - real, dimension(:,:,:), pointer :: field_in - real, dimension(:,:,:), allocatable :: field_out - integer :: i,j,ii,jj,i0,j0 - integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d - integer :: k,ks,ke + integer , intent(in) :: isc_o,jsc_o + integer , intent(in) :: isc_d,iec_d,jsc_d,jec_d !< downsampled mask compute indices + integer , intent(in) :: isd_d,ied_d,jsd_d,jed_d !< downsampled mask data indices + integer :: i,j,ii,jj,i0,j0,k,ks,ke real :: tot_non_zero !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 - isv_o=1 - jsv_o=1 ks = lbound(field_in,3) ; ke = ubound(field_in,3) - isv_d=1; iev_d=size(field_in,1)/dl - jsv_d=1; jev_d=size(field_in,2)/dl - allocate(field_out(isv_d:iev_d,jsv_d:jev_d,ks:ke)) + allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke)) field_out(:,:,:) = 0.0 - do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) + do k= ks,ke ; do j=jsc_d,jec_d ; do i=isc_d,iec_d + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) tot_non_zero = 0.0 -! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 tot_non_zero = tot_non_zero + field_in(ii,jj,k) enddo;enddo if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 enddo; enddo; enddo -end subroutine downsample_mask_3d_a - -subroutine downsample_mask_2d_a(field_in, field_out, dl) - integer , intent(in) :: dl - real, dimension(:,:) , intent(in) :: field_in - real, dimension(:,:) , allocatable :: field_out - integer :: i,j,ii,jj,i0,j0 - integer :: isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d - real :: tot_non_zero - !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 - isv_o=1 - jsv_o=1 - isv_d=1; iev_d=size(field_in,1)/dl - jsv_d=1; jev_d=size(field_in,2)/dl - allocate(field_out(isv_d:iev_d,jsv_d:jev_d)) - field_out(:,:) = 0.0 - do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - tot_non_zero = 0.0 -! do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 - do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - tot_non_zero = tot_non_zero + field_in(ii,jj) - enddo;enddo - if(tot_non_zero > 0.0) field_out(i,j)=1.0 - enddo; enddo -end subroutine downsample_mask_2d_a - +end subroutine downsample_mask_3d end module MOM_diag_mediator From c98fb73187b8e4d0220d525929762d54bc7f013d Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 2 Nov 2018 10:10:36 -0400 Subject: [PATCH 17/18] Diagnostics Downsample, implement Hallberg's suggestion - Could I suggest that we do the enumeration using 1,2,3 instead of 0,1,2, so that the 2-d variant PS (which would currently resolve to 1) can not be confused with the 3-d PPS (which would also resolve to 1). With 1,2,3, PS becomes 12, whereas PPS becomes 112. 0 could be reserved for no-axis. - There is still no need to have two digit codes, may be because there are no diagnostics with PP* in the full diag_table.MOM6 --- src/framework/MOM_diag_mediator.F90 | 68 ++++++++++++++--------------- 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 1f58e1489e..4973eaa3b3 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -143,23 +143,23 @@ module MOM_diag_mediator end type diag_grid_storage !> integers to encode the total cell methods -integer :: PPP=0 !< x:point,y:point,z:point -integer :: PPS=1 !< x:point,y:point,z:sum -integer :: PPM=2 !< x:point,y:point,z:mean -integer :: PSP=10 !< x:point,y:sum,z:point -integer :: PSS=11 !< x:point,y:sum,z:point -integer :: PSM=12 !< x:point,y:sum,z:mean -integer :: PMP=20 !< x:point,y:mean,z:point -integer :: PMM=22 !< x:point,y:mean,z:mean -integer :: SPP=100 !< x:sum,y:point,z:point -integer :: SPS=101 !< x:sum,y:point,z:sum -integer :: SSP=110 !< x:sum;y:sum,z:point -integer :: MPP=200 !< x:mean,y:point,z:point -integer :: MPM=202 !< x:mean,y:point,z:mean -integer :: MMP=220 !< x:mean,y:mean,z:point -integer :: MMS=221 !< x:mean,y:mean,z:sum -integer :: SSS=111 !< x:sum,y:sum,z:sum -integer :: MMM=222 !< x:mean,y:mean,z:mean +!integer :: PPP=111 !< x:point,y:point,z:point, this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPS=112 !< x:point,y:point,z:sum , this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPM=113 !< x:point,y:point,z:mean , this kind of diagnostic is not currently present in diag_table.MOM6 +integer :: PSP=121 !< x:point,y:sum,z:point +integer :: PSS=122 !< x:point,y:sum,z:point +integer :: PSM=123 !< x:point,y:sum,z:mean +integer :: PMP=131 !< x:point,y:mean,z:point +integer :: PMM=133 !< x:point,y:mean,z:mean +integer :: SPP=211 !< x:sum,y:point,z:point +integer :: SPS=212 !< x:sum,y:point,z:sum +integer :: SSP=221 !< x:sum;y:sum,z:point +integer :: MPP=311 !< x:mean,y:point,z:point +integer :: MPM=313 !< x:mean,y:point,z:mean +integer :: MMP=331 !< x:mean,y:mean,z:point +integer :: MMS=332 !< x:mean,y:mean,z:sum +integer :: SSS=222 !< x:sum,y:sum,z:sum +integer :: MMM=333 !< x:mean,y:mean,z:mean integer :: MSK=-1 !< Use the downsample method of a mask !> This type is used to represent a diagnostic at the diag_mediator level. @@ -2339,11 +2339,11 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho !This is a simple way to encode the cell method information made from 3 strings !(x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz !x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean' - !We can encode these with setting 0 for 'point', 1 for 'sum, 2 for 'mean' in + !We can encode these with setting 1 for 'point', 2 for 'sum, 3 for 'mean' in !the 100s position for x, 10s position for y, 1s position for z - !E.g., x:sum,y:point,z:mean is 102 + !E.g., x:sum,y:point,z:mean is 213 - xyz_method = 0 + xyz_method = 111 mstr = diag%axes%v_cell_method if (present(v_extensive)) then @@ -3732,7 +3732,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d allocate(field_out(1:f1,1:f2,ks:ke)) !Fill the downsampled field on the downsampled diagnostics (almost always compuate) domain - if(method .eq. MMM) then !xyz_method = MMM = 222 + if(method .eq. MMM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3746,7 +3746,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo; enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. SSS) then !xyz_method = SSS = 111 e.g., volcello + elseif(method .eq. SSS) then !e.g., volcello do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3760,7 +3760,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo; enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. MMP .or. method .eq. MMS) then !xyz_method = MMP = 220, e.g., or T_advection_xy + elseif(method .eq. MMP .or. method .eq. MMS) then !e.g., T_advection_xy do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3774,7 +3774,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo; enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. PMM) then !xyz_method = PMM = 022 + elseif(method .eq. PMM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3788,7 +3788,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. PSM) then !xyz_method = PSM = 012 + elseif(method .eq. PSM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3802,7 +3802,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. PSS) then !xyz_method = PSS = 011 e.g. umo + elseif(method .eq. PSS) then !e.g. umo do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3816,7 +3816,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. SPS) then !xyz_method = SPS = 101 e.g. vmo + elseif(method .eq. SPS) then !e.g. vmo do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3830,7 +3830,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. MPM) then !xyz_method = MPM = 202 + elseif(method .eq. MPM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3893,7 +3893,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,di endif allocate(field_out(1:f1,1:f2)) - if(method .eq. MMP) then !xyz_method = MMP + if(method .eq. MMP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3907,7 +3907,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,di enddo; enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. SSP) then !xyz_method = SSP , e.g., T_dfxy_cont_tendency_2d + elseif(method .eq. SSP) then ! e.g., T_dfxy_cont_tendency_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3921,7 +3921,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,di enddo; enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. PSP) then !xyz_method = PSP = 010, e.g., umo_2d + elseif(method .eq. PSP) then ! e.g., umo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3935,7 +3935,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,di enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. SPP) then !xyz_method = SPP = 100, e.g., vmo_2d + elseif(method .eq. SPP) then ! e.g., vmo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3949,7 +3949,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,di enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. PMP) then !xyz_method = PMP = 020 + elseif(method .eq. PMP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3963,7 +3963,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,di enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. MPP) then !xyz_method = MPP = 200 + elseif(method .eq. MPP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) From 8233da23165adc2ac9a2c409af09b17ce7cec137 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 31 Jan 2019 17:43:00 -0500 Subject: [PATCH 18/18] Diagnostics downsampling, shorten line more than 120 chars long - This update shortens the lines that were more than 120 chars long. --- src/framework/MOM_diag_mediator.F90 | 49 +++++++++++++++-------------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index cfc4eebb51..d862f8c815 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -144,24 +144,24 @@ module MOM_diag_mediator end type diag_grid_storage !> integers to encode the total cell methods -!integer :: PPP=111 !< x:point,y:point,z:point, this kind of diagnostic is not currently present in diag_table.MOM6 -!integer :: PPS=112 !< x:point,y:point,z:sum , this kind of diagnostic is not currently present in diag_table.MOM6 -!integer :: PPM=113 !< x:point,y:point,z:mean , this kind of diagnostic is not currently present in diag_table.MOM6 -integer :: PSP=121 !< x:point,y:sum,z:point -integer :: PSS=122 !< x:point,y:sum,z:point -integer :: PSM=123 !< x:point,y:sum,z:mean -integer :: PMP=131 !< x:point,y:mean,z:point -integer :: PMM=133 !< x:point,y:mean,z:mean -integer :: SPP=211 !< x:sum,y:point,z:point -integer :: SPS=212 !< x:sum,y:point,z:sum -integer :: SSP=221 !< x:sum;y:sum,z:point -integer :: MPP=311 !< x:mean,y:point,z:point -integer :: MPM=313 !< x:mean,y:point,z:mean -integer :: MMP=331 !< x:mean,y:mean,z:point -integer :: MMS=332 !< x:mean,y:mean,z:sum -integer :: SSS=222 !< x:sum,y:sum,z:sum -integer :: MMM=333 !< x:mean,y:mean,z:mean -integer :: MSK=-1 !< Use the downsample method of a mask +!integer :: PPP=111 ! x:point,y:point,z:point, this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPS=112 ! x:point,y:point,z:sum , this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPM=113 ! x:point,y:point,z:mean , this kind of diagnostic is not currently present in diag_table.MOM6 +integer :: PSP=121 ! x:point,y:sum,z:point +integer :: PSS=122 ! x:point,y:sum,z:point +integer :: PSM=123 ! x:point,y:sum,z:mean +integer :: PMP=131 ! x:point,y:mean,z:point +integer :: PMM=133 ! x:point,y:mean,z:mean +integer :: SPP=211 ! x:sum,y:point,z:point +integer :: SPS=212 ! x:sum,y:point,z:sum +integer :: SSP=221 ! x:sum;y:sum,z:point +integer :: MPP=311 ! x:mean,y:point,z:point +integer :: MPM=313 ! x:mean,y:point,z:mean +integer :: MMP=331 ! x:mean,y:mean,z:point +integer :: MMS=332 ! x:mean,y:mean,z:sum +integer :: SSS=222 ! x:sum,y:sum,z:sum +integer :: MMM=333 ! x:mean,y:mean,z:mean +integer :: MSK=-1 ! Use the downsample method of a mask !> This type is used to represent a diagnostic at the diag_mediator level. !! @@ -794,7 +794,7 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs) !The downsampled mask is needed for sending out the diagnostics output via diag_manager !The non-downsampled mask is needed for downsampling the diagnostics field do dl=2,MAX_DSAMP_LEV - if(dl .ne. 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported yet!") + if(dl .ne. 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!") do c=1, diag_cs%num_diag_coords ! Level/layer h-points in diagnostic coordinate axes => diag_cs%remap_axesTL(c) @@ -834,7 +834,7 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs) ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB)!set downsampled mask + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask enddo enddo @@ -3543,16 +3543,17 @@ subroutine downsample_diag_indices_get(fo1,fo2, dl, diag_cs,isv,iev,jsv,jev) character(len=500) :: mesg logical, save :: first_check = .true. - !Check ONCE that the downsampled diag-compute domain is commensurate with the original non-downsampled diag-compute domain + !Check ONCE that the downsampled diag-compute domain is commensurate with the original + !non-downsampled diag-compute domain. !This is a major limitation of the current implementation of the downsampled diagnostics. !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates. !We want this check to error out only if there was a downsampled diagnostics requested and about to post that is - !why the check is here and not in the init routines. This check need to be done only once, hence the outer if statement + !why the check is here and not in the init routines. This check need to be done only once, hence the outer if. if(first_check) then if(mod(diag_cs%ie-diag_cs%is+1, dl) .ne. 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) .ne. 0) then write (mesg,*) "Non-commensurate downsampled domain is not supported. "//& - "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl, " Current domain extents: ",& - diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je + "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl,& + " Current domain extents: ", diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) endif first_check = .false.