MOM6
MOM_diag_mediator.F90
1 !> The subroutines here provide convenient wrappers to the fms diag_manager
2 !! interfaces with additional diagnostic capabilies.
4 
5 ! This file is part of MOM6. See LICENSE.md for the license.
6 
7 use mom_checksums, only : chksum0, zchksum
9 use mom_coms, only : pe_here
10 use mom_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
11 use mom_cpu_clock, only : clock_module, clock_routine
12 use mom_error_handler, only : mom_error, fatal, warning, is_root_pe, assert
14 use mom_grid, only : ocean_grid_type
15 use mom_io, only : slasher, vardesc, query_vardesc, mom_read_data
16 use mom_io, only : get_filename_appendix
18 use mom_string_functions, only : lowercase
19 use mom_time_manager, only : time_type
22 use mom_eos, only : eos_type
24 use mom_diag_remap, only : diag_remap_update
25 use mom_diag_remap, only : diag_remap_calc_hmask
26 use mom_diag_remap, only : diag_remap_init, diag_remap_end, diag_remap_do_remap
27 use mom_diag_remap, only : vertically_reintegrate_diag_field, vertically_interpolate_diag_field
28 use mom_diag_remap, only : diag_remap_configure_axes, diag_remap_axes_configured
29 use mom_diag_remap, only : diag_remap_get_axes_info, diag_remap_set_active
30 use mom_diag_remap, only : diag_remap_diag_registration_closed
31 use mom_diag_remap, only : horizontally_average_diag_field
32 
33 use diag_axis_mod, only : get_diag_axis_name
34 use diag_data_mod, only : null_axis_id
35 use diag_manager_mod, only : diag_manager_init, diag_manager_end
36 use diag_manager_mod, only : send_data, diag_axis_init, east, north, diag_field_add_attribute
37 ! The following module is needed for PGI since the following line does not compile with PGI 6.5.0
38 ! was: use diag_manager_mod, only : register_diag_field_fms=>register_diag_field
40 use diag_manager_mod, only : register_static_field_fms=>register_static_field
41 use diag_manager_mod, only : get_diag_field_id_fms=>get_diag_field_id
42 use diag_manager_mod, only : diag_field_not_found
43 
44 implicit none ; private
45 
46 #undef __DO_SAFETY_CHECKS__
47 #define IMPLIES(A, B) ((.not. (A)) .or. (B))
48 #define MAX_DSAMP_LEV 2
49 
50 public set_axes_info, post_data, register_diag_field, time_type
51 public set_masks_for_axes
52 public post_data_1d_k
54 public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled
55 public diag_mediator_init, diag_mediator_end, set_diag_mediator_grid
56 public diag_mediator_infrastructure_init
57 public diag_mediator_close_registration, get_diag_time_end
58 public diag_axis_init, ocean_register_diag, register_static_field
59 public register_scalar_field
60 public define_axes_group, diag_masks_set
61 public diag_register_area_ids
62 public register_cell_measure, diag_associate_volume_cell_measure
63 public diag_get_volume_cell_measure_dm_id
64 public diag_set_state_ptrs, diag_update_remap_grids
65 public diag_grid_storage_init, diag_grid_storage_end
66 public diag_copy_diag_to_storage, diag_copy_storage_to_diag
67 public diag_save_grids, diag_restore_grids
68 
69 !> Make a diagnostic available for averaging or output.
70 interface post_data
71  module procedure post_data_3d, post_data_2d, post_data_1d_k, post_data_0d
72 end interface post_data
73 
74 !> Down sample a field
76  module procedure downsample_field_2d, downsample_field_3d
77 end interface downsample_field
78 
79 !> Down sample the mask of a field
80 interface downsample_mask
81  module procedure downsample_mask_2d, downsample_mask_3d
82 end interface downsample_mask
83 
84 !> Down sample a diagnostic field
86  module procedure downsample_diag_field_2d, downsample_diag_field_3d
87 end interface downsample_diag_field
88 
89 !> Contained for down sampled masks
90 type, private :: diag_dsamp
91  real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes
92  real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes
93 end type diag_dsamp
94 
95 !> A group of 1D axes that comprise a 1D/2D/3D mesh
96 type, public :: axes_grp
97  character(len=15) :: id !< The id string for this particular combination of handles.
98  integer :: rank !< Number of dimensions in the list of axes.
99  integer, dimension(:), allocatable :: handles !< Handles to 1D axes.
100  type(diag_ctrl), pointer :: diag_cs => null() !< Circular link back to the main diagnostics control structure
101  !! (Used to avoid passing said structure into every possible call).
102  ! ID's for cell_methods
103  character(len=9) :: x_cell_method = '' !< Default nature of data representation, if axes group
104  !! includes x-direction.
105  character(len=9) :: y_cell_method = '' !< Default nature of data representation, if axes group
106  !! includes y-direction.
107  character(len=9) :: v_cell_method = '' !< Default nature of data representation, if axes group
108  !! includes vertical direction.
109  ! For remapping
110  integer :: nz = 0 !< Vertical dimension of diagnostic
111  integer :: vertical_coordinate_number = 0 !< Index of the corresponding diag_remap_ctrl for this axis group
112  ! For detecting position on the grid
113  logical :: is_h_point = .false. !< If true, indicates that this axes group is for an h-point located field.
114  logical :: is_q_point = .false. !< If true, indicates that this axes group is for a q-point located field.
115  logical :: is_u_point = .false. !< If true, indicates that this axes group is for a u-point located field.
116  logical :: is_v_point = .false. !< If true, indicates that this axes group is for a v-point located field.
117  logical :: is_layer = .false. !< If true, indicates that this axes group is for a layer vertically-located field.
118  logical :: is_interface = .false. !< If true, indicates that this axes group is for an interface
119  !! vertically-located field.
120  logical :: is_native = .true. !< If true, indicates that this axes group is for a native model grid.
121  !! False for any other grid. Used for rank>2.
122  logical :: needs_remapping = .false. !< If true, indicates that this axes group is for a intensive layer-located
123  !! field that must be remapped to these axes. Used for rank>2.
124  logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled
125  !! interface-located field that must be interpolated to
126  !! these axes. Used for rank>2.
127  integer :: downsample_level = 1 !< If greater than 1, the factor by which this diagnostic/axes/masks be downsampled
128  ! For horizontally averaged diagnositcs (applies to 2d and 3d fields only)
129  type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontall area-averaged diagnostics
130  ! ID's for cell_measures
131  integer :: id_area = -1 !< The diag_manager id for area to be used for cell_measure of variables with this axes_grp.
132  integer :: id_volume = -1 !< The diag_manager id for volume to be used for cell_measure of variables
133  !! with this axes_grp.
134  ! For masking
135  real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes
136  real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes
137  type(diag_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample container
138 end type axes_grp
139 
140 !> Contains an array to store a diagnostic target grid
141 type, private :: diag_grids_type
142  real, dimension(:,:,:), allocatable :: h !< Target grid for remapped coordinate
143 end type diag_grids_type
144 
145 !> Stores all the remapping grids and the model's native space thicknesses
146 type, public :: diag_grid_storage
147  integer :: num_diag_coords !< Number of target coordinates
148  real, dimension(:,:,:), allocatable :: h_state !< Layer thicknesses in native
149  !! space [H ~> m or kg m-2]
150  type(diag_grids_type), dimension(:), allocatable :: diag_grids !< Primarily empty, except h field
151 end type diag_grid_storage
152 
153 ! Integers to encode the total cell methods
154 !integer :: PPP=111 ! x:point,y:point,z:point, this kind of diagnostic is not currently present in diag_table.MOM6
155 !integer :: PPS=112 ! x:point,y:point,z:sum , this kind of diagnostic is not currently present in diag_table.MOM6
156 !integer :: PPM=113 ! x:point,y:point,z:mean , this kind of diagnostic is not currently present in diag_table.MOM6
157 integer :: psp=121 !< x:point,y:sum,z:point
158 integer :: pss=122 !< x:point,y:sum,z:point
159 integer :: psm=123 !< x:point,y:sum,z:mean
160 integer :: pmp=131 !< x:point,y:mean,z:point
161 integer :: pmm=133 !< x:point,y:mean,z:mean
162 integer :: spp=211 !< x:sum,y:point,z:point
163 integer :: sps=212 !< x:sum,y:point,z:sum
164 integer :: ssp=221 !< x:sum;y:sum,z:point
165 integer :: mpp=311 !< x:mean,y:point,z:point
166 integer :: mpm=313 !< x:mean,y:point,z:mean
167 integer :: mmp=331 !< x:mean,y:mean,z:point
168 integer :: mms=332 !< x:mean,y:mean,z:sum
169 integer :: sss=222 !< x:sum,y:sum,z:sum
170 integer :: mmm=333 !< x:mean,y:mean,z:mean
171 integer :: msk=-1 !< Use the downsample method of a mask
172 
173 !> This type is used to represent a diagnostic at the diag_mediator level.
174 !!
175 !! There can be both 'primary' and 'seconday' diagnostics. The primaries
176 !! reside in the diag_cs%diags array. They have an id which is an index
177 !! into this array. The secondaries are 'variations' on the primary diagnostic.
178 !! For example the CMOR diagnostics are secondary. The secondary diagnostics
179 !! are kept in a list with the primary diagnostic as the head.
180 type, private :: diag_type
181  logical :: in_use !< True if this entry is being used.
182  integer :: fms_diag_id !< Underlying FMS diag_manager id.
183  integer :: fms_xyave_diag_id = -1 !< For a horizontally area-averaged diagnostic.
184  integer :: downsample_diag_id = -1 !< For a horizontally area-downsampled diagnostic.
185  character(64) :: debug_str = '' !< For FATAL errors and debugging.
186  type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic
187  type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic
188  real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero.
189  logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated).
190  !! False for intensive (concentrations).
191  integer :: xyz_method = 0 !< A 3 digit integer encoding the diagnostics cell method
192  !! It can be used to determine the downsample algorithm
193 end type diag_type
194 
195 !> Container for down sampling information
197  integer :: isc !< The start i-index of cell centers within the computational domain
198  integer :: iec !< The end i-index of cell centers within the computational domain
199  integer :: jsc !< The start j-index of cell centers within the computational domain
200  integer :: jec !< The end j-index of cell centers within the computational domain
201  integer :: isd !< The start i-index of cell centers within the data domain
202  integer :: ied !< The end i-index of cell centers within the data domain
203  integer :: jsd !< The start j-index of cell centers within the data domain
204  integer :: jed !< The end j-index of cell centers within the data domain
205  integer :: isg !< The start i-index of cell centers within the global domain
206  integer :: ieg !< The end i-index of cell centers within the global domain
207  integer :: jsg !< The start j-index of cell centers within the global domain
208  integer :: jeg !< The end j-index of cell centers within the global domain
209  integer :: isgb !< The start i-index of cell corners within the global domain
210  integer :: iegb !< The end i-index of cell corners within the global domain
211  integer :: jsgb !< The start j-index of cell corners within the global domain
212  integer :: jegb !< The end j-index of cell corners within the global domain
213 
214  !>@{ Axes for each location on a diagnostic grid
215  type(axes_grp) :: axesbl, axestl, axescul, axescvl
216  type(axes_grp) :: axesbi, axesti, axescui, axescvi
217  type(axes_grp) :: axesb1, axest1, axescu1, axescv1
218  type(axes_grp), dimension(:), allocatable :: remap_axestl, remap_axesbl, remap_axescul, remap_axescvl
219  type(axes_grp), dimension(:), allocatable :: remap_axesti, remap_axesbi, remap_axescui, remap_axescvi
220  !>@}
221 
222  real, dimension(:,:), pointer :: mask2dt => null() !< 2D mask array for cell-center points
223  real, dimension(:,:), pointer :: mask2dbu => null() !< 2D mask array for cell-corner points
224  real, dimension(:,:), pointer :: mask2dcu => null() !< 2D mask array for east-face points
225  real, dimension(:,:), pointer :: mask2dcv => null() !< 2D mask array for north-face points
226  !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i)
227  real, dimension(:,:,:), pointer :: mask3dtl => null()
228  real, dimension(:,:,:), pointer :: mask3dbl => null()
229  real, dimension(:,:,:), pointer :: mask3dcul => null()
230  real, dimension(:,:,:), pointer :: mask3dcvl => null()
231  real, dimension(:,:,:), pointer :: mask3dti => null()
232  real, dimension(:,:,:), pointer :: mask3dbi => null()
233  real, dimension(:,:,:), pointer :: mask3dcui => null()
234  real, dimension(:,:,:), pointer :: mask3dcvi => null()
235  !>@}
236 end type diagcs_dsamp
237 
238 !> The following data type a list of diagnostic fields an their variants,
239 !! as well as variables that control the handling of model output.
240 type, public :: diag_ctrl
241  integer :: available_diag_doc_unit = -1 !< The unit number of a diagnostic documentation file.
242  !! This file is open if available_diag_doc_unit is > 0.
243  integer :: chksum_iounit = -1 !< The unit number of a diagnostic documentation file.
244  !! This file is open if available_diag_doc_unit is > 0.
245  logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics
246  logical :: grid_space_axes !< If true, diagnostic horizontal coordinates axes are in grid space.
247 ! The following fields are used for the output of the data.
248  integer :: is !< The start i-index of cell centers within the computational domain
249  integer :: ie !< The end i-index of cell centers within the computational domain
250  integer :: js !< The start j-index of cell centers within the computational domain
251  integer :: je !< The end j-index of cell centers within the computational domain
252 
253  integer :: isd !< The start i-index of cell centers within the data domain
254  integer :: ied !< The end i-index of cell centers within the data domain
255  integer :: jsd !< The start j-index of cell centers within the data domain
256  integer :: jed !< The end j-index of cell centers within the data domain
257  real :: time_int !< The time interval for any fields
258  !! that are offered for averaging [s].
259  type(time_type) :: time_end !< The end time of the valid
260  !! interval for any offered field.
261  logical :: ave_enabled = .false. !< True if averaging is enabled.
262 
263  !>@{ The following are 3D and 2D axis groups defined for output. The names
264  !! indicate the horizontal (B, T, Cu, or Cv) and vertical (L, i, or 1) locations.
265  type(axes_grp) :: axesbl, axestl, axescul, axescvl
266  type(axes_grp) :: axesbi, axesti, axescui, axescvi
267  type(axes_grp) :: axesb1, axest1, axescu1, axescv1
268  !>@}
269  type(axes_grp) :: axeszi !< A 1-D z-space axis at interfaces
270  type(axes_grp) :: axeszl !< A 1-D z-space axis at layer centers
271  type(axes_grp) :: axesnull !< An axis group for scalars
272 
273  real, dimension(:,:), pointer :: mask2dt => null() !< 2D mask array for cell-center points
274  real, dimension(:,:), pointer :: mask2dbu => null() !< 2D mask array for cell-corner points
275  real, dimension(:,:), pointer :: mask2dcu => null() !< 2D mask array for east-face points
276  real, dimension(:,:), pointer :: mask2dcv => null() !< 2D mask array for north-face points
277  !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i)
278  real, dimension(:,:,:), pointer :: mask3dtl => null()
279  real, dimension(:,:,:), pointer :: mask3dbl => null()
280  real, dimension(:,:,:), pointer :: mask3dcul => null()
281  real, dimension(:,:,:), pointer :: mask3dcvl => null()
282  real, dimension(:,:,:), pointer :: mask3dti => null()
283  real, dimension(:,:,:), pointer :: mask3dbi => null()
284  real, dimension(:,:,:), pointer :: mask3dcui => null()
285  real, dimension(:,:,:), pointer :: mask3dcvi => null()
286 
287  type(diagcs_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample control container
288 
289  !>@}
290 
291 ! Space for diagnostics is dynamically allocated as it is needed.
292 ! The chunk size is how much the array should grow on each new allocation.
293 #define DIAG_ALLOC_CHUNK_SIZE 100
294  type(diag_type), dimension(:), allocatable :: diags !< The list of diagnostics
295  integer :: next_free_diag_id !< The next unused diagnostic ID
296 
297  !> default missing value to be sent to ALL diagnostics registrations
298  real :: missing_value = -1.0e+34
299 
300  !> Number of diagnostic vertical coordinates (remapped)
301  integer :: num_diag_coords
302  !> Control structure for each possible coordinate
303  type(diag_remap_ctrl), dimension(:), allocatable :: diag_remap_cs
304  type(diag_grid_storage) :: diag_grid_temp !< Stores the remapped diagnostic grid
305  logical :: diag_grid_overridden = .false. !< True if the diagnostic grids have been overriden
306 
307  type(axes_grp), dimension(:), allocatable :: &
308  remap_axeszl, & !< The 1-D z-space cell-centered axis for remapping
309  remap_axeszi !< The 1-D z-space interface axis for remapping
310  !>@{ Axes used for remapping
311  type(axes_grp), dimension(:), allocatable :: remap_axestl, remap_axesbl, remap_axescul, remap_axescvl
312  type(axes_grp), dimension(:), allocatable :: remap_axesti, remap_axesbi, remap_axescui, remap_axescvi
313  !>@}
314 
315  ! Pointer to H, G and T&S needed for remapping
316  real, dimension(:,:,:), pointer :: h => null() !< The thicknesses needed for remapping [H ~> m or kg m-2]
317  real, dimension(:,:,:), pointer :: t => null() !< The temperatures needed for remapping [degC]
318  real, dimension(:,:,:), pointer :: s => null() !< The salinities needed for remapping [ppt]
319  type(eos_type), pointer :: eqn_of_state => null() !< The equation of state type
320  type(ocean_grid_type), pointer :: g => null() !< The ocean grid type
321  type(verticalgrid_type), pointer :: gv => null() !< The model's vertical ocean grid
322  type(unit_scale_type), pointer :: us => null() !< A dimensional unit scaling type
323 
324  !> The volume cell measure (special diagnostic) manager id
325  integer :: volume_cell_measure_dm_id = -1
326 
327 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
328  ! Keep a copy of h so that we know whether it has changed [H ~> m or kg m-2]. If it has then
329  ! need the target grid for vertical remapping needs to have been updated.
330  real, dimension(:,:,:), allocatable :: h_old
331 #endif
332 
333  !> Number of checksum-only diagnostics
334  integer :: num_chksum_diags
335 
336  real, dimension(:,:,:), allocatable :: h_begin !< Layer thicknesses at the beginning of the timestep used
337  !! for remapping of extensive variables
338 
339 end type diag_ctrl
340 
341 !>@{ CPU clocks
342 integer :: id_clock_diag_mediator, id_clock_diag_remap, id_clock_diag_grid_updates
343 !>@}
344 
345 contains
346 
347 !> Sets up diagnostics axes
348 subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical)
349  type(ocean_grid_type), intent(inout) :: g !< Ocean grid structure
350  type(verticalgrid_type), intent(in) :: gv !< ocean vertical grid structure
351  type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
352  type(param_file_type), intent(in) :: param_file !< Parameter file structure
353  type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure
354  logical, optional, intent(in) :: set_vertical !< If true or missing, set up
355  !! vertical axes
356  ! Local variables
357  integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh
358  integer :: id_zl_native, id_zi_native
359  integer :: i, j, k, nz
360  real :: zlev(gv%ke), zinter(gv%ke+1)
361  logical :: set_vert
362  real, allocatable, dimension(:) :: iaxb,iax
363  real, allocatable, dimension(:) :: jaxb,jax
364 
365 
366  set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical
367 
368 
369  if (diag_cs%grid_space_axes) then
370  allocate(iaxb(g%IsgB:g%IegB))
371  do i=g%IsgB, g%IegB
372  iaxb(i)=real(i)
373  enddo
374  allocate(iax(g%isg:g%ieg))
375  do i=g%isg, g%ieg
376  iax(i)=real(i)-0.5
377  enddo
378  allocate(jaxb(g%JsgB:g%JegB))
379  do j=g%JsgB, g%JegB
380  jaxb(j)=real(j)
381  enddo
382  allocate(jax(g%jsg:g%jeg))
383  do j=g%jsg, g%jeg
384  jax(j)=real(j)-0.5
385  enddo
386  endif
387 
388  ! Horizontal axes for the native grids
389  if (g%symmetric) then
390  if (diag_cs%grid_space_axes) then
391  id_xq = diag_axis_init('iq', iaxb(g%isgB:g%iegB), 'none', 'x', &
392  'q point grid-space longitude', domain2=g%Domain%mpp_domain, domain_position=east)
393  id_yq = diag_axis_init('jq', jaxb(g%jsgB:g%jegB), 'none', 'y', &
394  'q point grid space latitude', domain2=g%Domain%mpp_domain, domain_position=north)
395  else
396  id_xq = diag_axis_init('xq', g%gridLonB(g%isgB:g%iegB), g%x_axis_units, 'x', &
397  'q point nominal longitude', domain2=g%Domain%mpp_domain, domain_position=east)
398  id_yq = diag_axis_init('yq', g%gridLatB(g%jsgB:g%jegB), g%y_axis_units, 'y', &
399  'q point nominal latitude', domain2=g%Domain%mpp_domain, domain_position=north)
400  endif
401  else
402  if (diag_cs%grid_space_axes) then
403  id_xq = diag_axis_init('Iq', iaxb(g%isg:g%ieg), 'none', 'x', &
404  'q point grid-space longitude', domain2=g%Domain%mpp_domain, domain_position=east)
405  id_yq = diag_axis_init('Jq', jaxb(g%jsg:g%jeg), 'none', 'y', &
406  'q point grid space latitude', domain2=g%Domain%mpp_domain, domain_position=north)
407  else
408  id_xq = diag_axis_init('xq', g%gridLonB(g%isg:g%ieg), g%x_axis_units, 'x', &
409  'q point nominal longitude', domain2=g%Domain%mpp_domain, domain_position=east)
410  id_yq = diag_axis_init('yq', g%gridLatB(g%jsg:g%jeg), g%y_axis_units, 'y', &
411  'q point nominal latitude', domain2=g%Domain%mpp_domain, domain_position=north)
412  endif
413  endif
414 
415 
416  if (diag_cs%grid_space_axes) then
417  id_xh = diag_axis_init('ih', iax(g%isg:g%ieg), 'none', 'x', &
418  'h point grid-space longitude', domain2=g%Domain%mpp_domain, domain_position=east)
419  id_yh = diag_axis_init('jh', jax(g%jsg:g%jeg), 'none', 'y', &
420  'h point grid space latitude', domain2=g%Domain%mpp_domain, domain_position=north)
421  else
422  id_xh = diag_axis_init('xh', g%gridLonT(g%isg:g%ieg), g%x_axis_units, 'x', &
423  'h point nominal longitude', domain2=g%Domain%mpp_domain)
424  id_yh = diag_axis_init('yh', g%gridLatT(g%jsg:g%jeg), g%y_axis_units, 'y', &
425  'h point nominal latitude', domain2=g%Domain%mpp_domain)
426  endif
427 
428  if (set_vert) then
429  nz = gv%ke
430  zinter(1:nz+1) = gv%sInterface(1:nz+1)
431  zlev(1:nz) = gv%sLayer(1:nz)
432  id_zl = diag_axis_init('zl', zlev, trim(gv%zAxisUnits), 'z', &
433  'Layer '//trim(gv%zAxisLongName), &
434  direction=gv%direction)
435  id_zi = diag_axis_init('zi', zinter, trim(gv%zAxisUnits), 'z', &
436  'Interface '//trim(gv%zAxisLongName), &
437  direction=gv%direction)
438  else
439  id_zl = -1 ; id_zi = -1
440  endif
441  id_zl_native = id_zl ; id_zi_native = id_zi
442  ! Vertical axes for the interfaces and layers
443  call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, &
444  v_cell_method='point', is_interface=.true.)
445  call define_axes_group(diag_cs, (/ id_zl /), diag_cs%axesZL, &
446  v_cell_method='mean', is_layer=.true.)
447 
448  ! Axis groupings for the model layers
449  call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%axesTL, &
450  x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', &
451  is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
452  call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%axesBL, &
453  x_cell_method='point', y_cell_method='point', v_cell_method='mean', &
454  is_q_point=.true., is_layer=.true.)
455  call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%axesCuL, &
456  x_cell_method='point', y_cell_method='mean', v_cell_method='mean', &
457  is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
458  call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%axesCvL, &
459  x_cell_method='mean', y_cell_method='point', v_cell_method='mean', &
460  is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
461 
462  ! Axis groupings for the model interfaces
463  call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%axesTi, &
464  x_cell_method='mean', y_cell_method='mean', v_cell_method='point', &
465  is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
466  call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%axesBi, &
467  x_cell_method='point', y_cell_method='point', v_cell_method='point', &
468  is_q_point=.true., is_interface=.true.)
469  call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%axesCui, &
470  x_cell_method='point', y_cell_method='mean', v_cell_method='point', &
471  is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
472  call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%axesCvi, &
473  x_cell_method='mean', y_cell_method='point', v_cell_method='point', &
474  is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
475 
476  ! Axis groupings for 2-D arrays
477  call define_axes_group(diag_cs, (/ id_xh, id_yh /), diag_cs%axesT1, &
478  x_cell_method='mean', y_cell_method='mean', is_h_point=.true.)
479  call define_axes_group(diag_cs, (/ id_xq, id_yq /), diag_cs%axesB1, &
480  x_cell_method='point', y_cell_method='point', is_q_point=.true.)
481  call define_axes_group(diag_cs, (/ id_xq, id_yh /), diag_cs%axesCu1, &
482  x_cell_method='point', y_cell_method='mean', is_u_point=.true.)
483  call define_axes_group(diag_cs, (/ id_xh, id_yq /), diag_cs%axesCv1, &
484  x_cell_method='mean', y_cell_method='point', is_v_point=.true.)
485 
486  ! Axis group for special null axis from diag manager
487  call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull)
488 
489 
490  !Non-native Non-downsampled
491  if (diag_cs%num_diag_coords>0) then
492  allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords))
493  allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords))
494  allocate(diag_cs%remap_axesBL(diag_cs%num_diag_coords))
495  allocate(diag_cs%remap_axesCuL(diag_cs%num_diag_coords))
496  allocate(diag_cs%remap_axesCvL(diag_cs%num_diag_coords))
497  allocate(diag_cs%remap_axesZi(diag_cs%num_diag_coords))
498  allocate(diag_cs%remap_axesTi(diag_cs%num_diag_coords))
499  allocate(diag_cs%remap_axesBi(diag_cs%num_diag_coords))
500  allocate(diag_cs%remap_axesCui(diag_cs%num_diag_coords))
501  allocate(diag_cs%remap_axesCvi(diag_cs%num_diag_coords))
502  endif
503 
504  do i=1, diag_cs%num_diag_coords
505  ! For each possible diagnostic coordinate
506  call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), gv, us, param_file)
507 
508  ! Allocate these arrays since the size of the diagnostic array is now known
509  allocate(diag_cs%diag_remap_cs(i)%h(g%isd:g%ied,g%jsd:g%jed, diag_cs%diag_remap_cs(i)%nz))
510  allocate(diag_cs%diag_remap_cs(i)%h_extensive(g%isd:g%ied,g%jsd:g%jed, diag_cs%diag_remap_cs(i)%nz))
511 
512  ! This vertical coordinate has been configured so can be used.
513  if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then
514 
515  ! This fetches the 1D-axis id for layers and interfaces and overwrite
516  ! id_zl and id_zi from above. It also returns the number of layers.
517  call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zl, id_zi)
518 
519  ! Axes for z layers
520  call define_axes_group(diag_cs, (/ id_zl /), diag_cs%remap_axesZL(i), &
521  nz=nz, vertical_coordinate_number=i, &
522  v_cell_method='mean', &
523  is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true.)
524  call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%remap_axesTL(i), &
525  nz=nz, vertical_coordinate_number=i, &
526  x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', &
527  is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
528  xyave_axes=diag_cs%remap_axesZL(i))
529 
530  !! \note Remapping for B points is not yet implemented so needs_remapping is not
531  !! provided for remap_axesBL
532  call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%remap_axesBL(i), &
533  nz=nz, vertical_coordinate_number=i, &
534  x_cell_method='point', y_cell_method='point', v_cell_method='mean', &
535  is_q_point=.true., is_layer=.true., is_native=.false.)
536 
537  call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%remap_axesCuL(i), &
538  nz=nz, vertical_coordinate_number=i, &
539  x_cell_method='point', y_cell_method='mean', v_cell_method='mean', &
540  is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
541  xyave_axes=diag_cs%remap_axesZL(i))
542 
543  call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%remap_axesCvL(i), &
544  nz=nz, vertical_coordinate_number=i, &
545  x_cell_method='mean', y_cell_method='point', v_cell_method='mean', &
546  is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
547  xyave_axes=diag_cs%remap_axesZL(i))
548 
549  ! Axes for z interfaces
550  call define_axes_group(diag_cs, (/ id_zi /), diag_cs%remap_axesZi(i), &
551  nz=nz, vertical_coordinate_number=i, &
552  v_cell_method='point', &
553  is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true.)
554  call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%remap_axesTi(i), &
555  nz=nz, vertical_coordinate_number=i, &
556  x_cell_method='mean', y_cell_method='mean', v_cell_method='point', &
557  is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., &
558  xyave_axes=diag_cs%remap_axesZi(i))
559 
560  !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi
561  call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%remap_axesBi(i), &
562  nz=nz, vertical_coordinate_number=i, &
563  x_cell_method='point', y_cell_method='point', v_cell_method='point', &
564  is_q_point=.true., is_interface=.true., is_native=.false.)
565 
566  call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%remap_axesCui(i), &
567  nz=nz, vertical_coordinate_number=i, &
568  x_cell_method='point', y_cell_method='mean', v_cell_method='point', &
569  is_u_point=.true., is_interface=.true., is_native=.false., &
570  needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
571 
572  call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%remap_axesCvi(i), &
573  nz=nz, vertical_coordinate_number=i, &
574  x_cell_method='mean', y_cell_method='point', v_cell_method='point', &
575  is_v_point=.true., is_interface=.true., is_native=.false., &
576  needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
577  endif
578  enddo
579 
580  if (diag_cs%grid_space_axes) then
581  deallocate(iaxb,iax,jaxb,jax)
582  endif
583  !Define the downsampled axes
584  call set_axes_info_dsamp(g, gv, param_file, diag_cs, id_zl_native, id_zi_native)
585 
586  call diag_grid_storage_init(diag_cs%diag_grid_temp, g, diag_cs)
587 
588 end subroutine set_axes_info
589 
590 subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native)
591  type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
592  type(verticalgrid_type), intent(in) :: GV !< ocean vertical grid structure
593  type(param_file_type), intent(in) :: param_file !< Parameter file structure
594  type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure
595  integer, intent(in) :: id_zl_native !< ID of native layers
596  integer, intent(in) :: id_zi_native !< ID of native interfaces
597 
598  ! Local variables
599  integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh
600  integer :: i, j, k, nz, dl
601  real, dimension(:), pointer :: gridLonT_dsamp =>null()
602  real, dimension(:), pointer :: gridLatT_dsamp =>null()
603  real, dimension(:), pointer :: gridLonB_dsamp =>null()
604  real, dimension(:), pointer :: gridLatB_dsamp =>null()
605 
606  id_zl = id_zl_native ; id_zi = id_zi_native
607  !Axes group for native downsampled diagnostics
608  do dl=2,max_dsamp_lev
609  if(dl .ne. 2) call mom_error(fatal, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!")
610  if (g%symmetric) then
611  allocate(gridlonb_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB))
612  allocate(gridlatb_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB))
613  do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridlonb_dsamp(i) = g%gridLonB(g%isgB+dl*i); enddo
614  do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridlatb_dsamp(j) = g%gridLatB(g%jsgB+dl*j); enddo
615  id_xq = diag_axis_init('xq', gridlonb_dsamp, g%x_axis_units, 'x', &
616  'q point nominal longitude', domain2=g%Domain%mpp_domain_d2)
617  id_yq = diag_axis_init('yq', gridlatb_dsamp, g%y_axis_units, 'y', &
618  'q point nominal latitude', domain2=g%Domain%mpp_domain_d2)
619  deallocate(gridlonb_dsamp,gridlatb_dsamp)
620  else
621  allocate(gridlonb_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg))
622  allocate(gridlatb_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg))
623  do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridlonb_dsamp(i) = g%gridLonB(g%isg+dl*i-2); enddo
624  do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridlatb_dsamp(j) = g%gridLatB(g%jsg+dl*j-2); enddo
625  id_xq = diag_axis_init('xq', gridlonb_dsamp, g%x_axis_units, 'x', &
626  'q point nominal longitude', domain2=g%Domain%mpp_domain_d2)
627  id_yq = diag_axis_init('yq', gridlatb_dsamp, g%y_axis_units, 'y', &
628  'q point nominal latitude', domain2=g%Domain%mpp_domain_d2)
629  deallocate(gridlonb_dsamp,gridlatb_dsamp)
630  endif
631 
632  allocate(gridlont_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg))
633  allocate(gridlatt_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg))
634  do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridlont_dsamp(i) = g%gridLonT(g%isg+dl*i-2); enddo
635  do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridlatt_dsamp(j) = g%gridLatT(g%jsg+dl*j-2); enddo
636  id_xh = diag_axis_init('xh', gridlont_dsamp, g%x_axis_units, 'x', &
637  'h point nominal longitude', domain2=g%Domain%mpp_domain_d2)
638  id_yh = diag_axis_init('yh', gridlatt_dsamp, g%y_axis_units, 'y', &
639  'h point nominal latitude', domain2=g%Domain%mpp_domain_d2)
640 
641  deallocate(gridlont_dsamp,gridlatt_dsamp)
642 
643  ! Axis groupings for the model layers
644  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%dsamp(dl)%axesTL, dl, &
645  x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', &
646  is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
647  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%dsamp(dl)%axesBL, dl, &
648  x_cell_method='point', y_cell_method='point', v_cell_method='mean', &
649  is_q_point=.true., is_layer=.true.)
650  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%dsamp(dl)%axesCuL, dl, &
651  x_cell_method='point', y_cell_method='mean', v_cell_method='mean', &
652  is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
653  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%dsamp(dl)%axesCvL, dl, &
654  x_cell_method='mean', y_cell_method='point', v_cell_method='mean', &
655  is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
656 
657  ! Axis groupings for the model interfaces
658  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%axesTi, dl, &
659  x_cell_method='mean', y_cell_method='mean', v_cell_method='point', &
660  is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
661  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%axesBi, dl, &
662  x_cell_method='point', y_cell_method='point', v_cell_method='point', &
663  is_q_point=.true., is_interface=.true.)
664  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%axesCui, dl, &
665  x_cell_method='point', y_cell_method='mean', v_cell_method='point', &
666  is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
667  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%axesCvi, dl, &
668  x_cell_method='mean', y_cell_method='point', v_cell_method='point', &
669  is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
670 
671  ! Axis groupings for 2-D arrays
672  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh /), diag_cs%dsamp(dl)%axesT1, dl, &
673  x_cell_method='mean', y_cell_method='mean', is_h_point=.true.)
674  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq /), diag_cs%dsamp(dl)%axesB1, dl, &
675  x_cell_method='point', y_cell_method='point', is_q_point=.true.)
676  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh /), diag_cs%dsamp(dl)%axesCu1, dl, &
677  x_cell_method='point', y_cell_method='mean', is_u_point=.true.)
678  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, &
679  x_cell_method='mean', y_cell_method='point', is_v_point=.true.)
680 
681  !Non-native axes
682  if (diag_cs%num_diag_coords>0) then
683  allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords))
684  allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords))
685  allocate(diag_cs%dsamp(dl)%remap_axesCuL(diag_cs%num_diag_coords))
686  allocate(diag_cs%dsamp(dl)%remap_axesCvL(diag_cs%num_diag_coords))
687  allocate(diag_cs%dsamp(dl)%remap_axesTi(diag_cs%num_diag_coords))
688  allocate(diag_cs%dsamp(dl)%remap_axesBi(diag_cs%num_diag_coords))
689  allocate(diag_cs%dsamp(dl)%remap_axesCui(diag_cs%num_diag_coords))
690  allocate(diag_cs%dsamp(dl)%remap_axesCvi(diag_cs%num_diag_coords))
691  endif
692 
693  do i=1, diag_cs%num_diag_coords
694  ! For each possible diagnostic coordinate
695  !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file)
696 
697  ! This vertical coordinate has been configured so can be used.
698  if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then
699 
700  ! This fetches the 1D-axis id for layers and interfaces and overwrite
701  ! id_zl and id_zi from above. It also returns the number of layers.
702  call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zl, id_zi)
703 
704  ! Axes for z layers
705  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%dsamp(dl)%remap_axesTL(i), dl, &
706  nz=nz, vertical_coordinate_number=i, &
707  x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', &
708  is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
709  xyave_axes=diag_cs%remap_axesZL(i))
710 
711  !! \note Remapping for B points is not yet implemented so needs_remapping is not
712  !! provided for remap_axesBL
713  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%dsamp(dl)%remap_axesBL(i), dl, &
714  nz=nz, vertical_coordinate_number=i, &
715  x_cell_method='point', y_cell_method='point', v_cell_method='mean', &
716  is_q_point=.true., is_layer=.true., is_native=.false.)
717 
718  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%dsamp(dl)%remap_axesCuL(i), dl, &
719  nz=nz, vertical_coordinate_number=i, &
720  x_cell_method='point', y_cell_method='mean', v_cell_method='mean', &
721  is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
722  xyave_axes=diag_cs%remap_axesZL(i))
723 
724  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%dsamp(dl)%remap_axesCvL(i), dl, &
725  nz=nz, vertical_coordinate_number=i, &
726  x_cell_method='mean', y_cell_method='point', v_cell_method='mean', &
727  is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
728  xyave_axes=diag_cs%remap_axesZL(i))
729 
730  ! Axes for z interfaces
731  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesTi(i), dl, &
732  nz=nz, vertical_coordinate_number=i, &
733  x_cell_method='mean', y_cell_method='mean', v_cell_method='point', &
734  is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., &
735  xyave_axes=diag_cs%remap_axesZi(i))
736 
737  !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi
738  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesBi(i), dl, &
739  nz=nz, vertical_coordinate_number=i, &
740  x_cell_method='point', y_cell_method='point', v_cell_method='point', &
741  is_q_point=.true., is_interface=.true., is_native=.false.)
742 
743  call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesCui(i), dl, &
744  nz=nz, vertical_coordinate_number=i, &
745  x_cell_method='point', y_cell_method='mean', v_cell_method='point', &
746  is_u_point=.true., is_interface=.true., is_native=.false., &
747  needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
748 
749  call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesCvi(i), dl, &
750  nz=nz, vertical_coordinate_number=i, &
751  x_cell_method='mean', y_cell_method='point', v_cell_method='point', &
752  is_v_point=.true., is_interface=.true., is_native=.false., &
753  needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
754  endif
755  enddo
756  enddo
757 
758 end subroutine set_axes_info_dsamp
759 
760 
761 !> set_masks_for_axes sets up the 2d and 3d masks for diagnostics using the current grid
762 !! recorded after calling diag_update_remap_grids()
763 subroutine set_masks_for_axes(G, diag_cs)
764  type(ocean_grid_type), target, intent(in) :: g !< The ocean grid type.
765  type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables
766  !! used for diagnostics
767  ! Local variables
768  integer :: c, nk, i, j, k, ii, jj
769  type(axes_grp), pointer :: axes => null(), h_axes => null() ! Current axes, for convenience
770 
771  do c=1, diag_cs%num_diag_coords
772  ! This vertical coordinate has been configured so can be used.
773  if (diag_remap_axes_configured(diag_cs%diag_remap_cs(c))) then
774 
775  ! Level/layer h-points in diagnostic coordinate
776  axes => diag_cs%remap_axesTL(c)
777  nk = axes%nz
778  allocate( axes%mask3d(g%isd:g%ied,g%jsd:g%jed,nk) ) ; axes%mask3d(:,:,:) = 0.
779  call diag_remap_calc_hmask(diag_cs%diag_remap_cs(c), g, axes%mask3d)
780 
781  h_axes => diag_cs%remap_axesTL(c) ! Use the h-point masks to generate the u-, v- and q- masks
782 
783  ! Level/layer u-points in diagnostic coordinate
784  axes => diag_cs%remap_axesCuL(c)
785  call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at u-layers')
786  call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated')
787  allocate( axes%mask3d(g%IsdB:g%IedB,g%jsd:g%jed,nk) ) ; axes%mask3d(:,:,:) = 0.
788  do k = 1, nk ; do j=g%jsc,g%jec ; do i=g%isc-1,g%iec
789  if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(i,j,k) = 1.
790  enddo ; enddo ; enddo
791 
792  ! Level/layer v-points in diagnostic coordinate
793  axes => diag_cs%remap_axesCvL(c)
794  call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at v-layers')
795  call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated')
796  allocate( axes%mask3d(g%isd:g%ied,g%JsdB:g%JedB,nk) ) ; axes%mask3d(:,:,:) = 0.
797  do k = 1, nk ; do j=g%jsc-1,g%jec ; do i=g%isc,g%iec
798  if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
799  enddo ; enddo ; enddo
800 
801  ! Level/layer q-points in diagnostic coordinate
802  axes => diag_cs%remap_axesBL(c)
803  call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at q-layers')
804  call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated')
805  allocate( axes%mask3d(g%IsdB:g%IedB,g%JsdB:g%JedB,nk) ) ; axes%mask3d(:,:,:) = 0.
806  do k = 1, nk ; do j=g%jsc-1,g%jec ; do i=g%isc-1,g%iec
807  if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + &
808  h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
809  enddo ; enddo ; enddo
810 
811  ! Interface h-points in diagnostic coordinate (w-point)
812  axes => diag_cs%remap_axesTi(c)
813  call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at h-interfaces')
814  call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated')
815  allocate( axes%mask3d(g%isd:g%ied,g%jsd:g%jed,nk+1) ) ; axes%mask3d(:,:,:) = 0.
816  do j=g%jsc-1,g%jec+1 ; do i=g%isc-1,g%iec+1
817  if (h_axes%mask3d(i,j,1) > 0.) axes%mask3d(i,j,1) = 1.
818  do k = 2, nk
819  if (h_axes%mask3d(i,j,k-1) + h_axes%mask3d(i,j,k) > 0.) axes%mask3d(i,j,k) = 1.
820  enddo
821  if (h_axes%mask3d(i,j,nk) > 0.) axes%mask3d(i,j,nk+1) = 1.
822  enddo ; enddo
823 
824  h_axes => diag_cs%remap_axesTi(c) ! Use the w-point masks to generate the u-, v- and q- masks
825 
826  ! Interface u-points in diagnostic coordinate
827  axes => diag_cs%remap_axesCui(c)
828  call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at u-interfaces')
829  call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated')
830  allocate( axes%mask3d(g%IsdB:g%IedB,g%jsd:g%jed,nk+1) ) ; axes%mask3d(:,:,:) = 0.
831  do k = 1, nk+1 ; do j=g%jsc,g%jec ; do i=g%isc-1,g%iec
832  if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(i,j,k) = 1.
833  enddo ; enddo ; enddo
834 
835  ! Interface v-points in diagnostic coordinate
836  axes => diag_cs%remap_axesCvi(c)
837  call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at v-interfaces')
838  call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated')
839  allocate( axes%mask3d(g%isd:g%ied,g%JsdB:g%JedB,nk+1) ) ; axes%mask3d(:,:,:) = 0.
840  do k = 1, nk+1 ; do j=g%jsc-1,g%jec ; do i=g%isc,g%iec
841  if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
842  enddo ; enddo ; enddo
843 
844  ! Interface q-points in diagnostic coordinate
845  axes => diag_cs%remap_axesBi(c)
846  call assert(axes%nz == nk, 'set_masks_for_axes: vertical size mismatch at q-interfaces')
847  call assert(.not. associated(axes%mask3d), 'set_masks_for_axes: already associated')
848  allocate( axes%mask3d(g%IsdB:g%IedB,g%JsdB:g%JedB,nk+1) ) ; axes%mask3d(:,:,:) = 0.
849  do k = 1, nk ; do j=g%jsc-1,g%jec ; do i=g%isc-1,g%iec
850  if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + &
851  h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
852  enddo ; enddo ; enddo
853  endif
854  enddo
855 
856  !Allocate and initialize the downsampled masks for the axes
857  call set_masks_for_axes_dsamp(g, diag_cs)
858 
859 end subroutine set_masks_for_axes
860 
861 subroutine set_masks_for_axes_dsamp(G, diag_cs)
862  type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type.
863  type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables
864  !! used for diagnostics
865  ! Local variables
866  integer :: c, nk, i, j, k, ii, jj
867  integer :: dl
868  type(axes_grp), pointer :: axes => null(), h_axes => null() ! Current axes, for convenience
869 
870  !Each downsampled axis needs both downsampled and non-downsampled mask
871  !The downsampled mask is needed for sending out the diagnostics output via diag_manager
872  !The non-downsampled mask is needed for downsampling the diagnostics field
873  do dl=2,max_dsamp_lev
874  if(dl .ne. 2) call mom_error(fatal, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!")
875  do c=1, diag_cs%num_diag_coords
876  ! Level/layer h-points in diagnostic coordinate
877  axes => diag_cs%remap_axesTL(c)
878  call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl,g%isc, g%jsc, &
879  g%HId2%isc, g%HId2%iec, g%HId2%jsc, g%HId2%jec, g%HId2%isd, g%HId2%ied, g%HId2%jsd, g%HId2%jed)
880  diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-downsampled mask
881  ! Level/layer u-points in diagnostic coordinate
882  axes => diag_cs%remap_axesCuL(c)
883  call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
884  g%HId2%IscB,g%HId2%IecB,g%HId2%jsc, g%HId2%jec,g%HId2%IsdB,g%HId2%IedB,g%HId2%jsd, g%HId2%jed)
885  diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-downsampled mask
886  ! Level/layer v-points in diagnostic coordinate
887  axes => diag_cs%remap_axesCvL(c)
888  call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl,g%isc ,g%JscB, &
889  g%HId2%isc ,g%HId2%iec, g%HId2%JscB,g%HId2%JecB,g%HId2%isd ,g%HId2%ied, g%HId2%JsdB,g%HId2%JedB)
890  diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-downsampled mask
891  ! Level/layer q-points in diagnostic coordinate
892  axes => diag_cs%remap_axesBL(c)
893  call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
894  g%HId2%IscB,g%HId2%IecB,g%HId2%JscB,g%HId2%JecB,g%HId2%IsdB,g%HId2%IedB,g%HId2%JsdB,g%HId2%JedB)
895  diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-downsampled mask
896  ! Interface h-points in diagnostic coordinate (w-point)
897  axes => diag_cs%remap_axesTi(c)
898  call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl,g%isc, g%jsc, &
899  g%HId2%isc, g%HId2%iec, g%HId2%jsc, g%HId2%jec, g%HId2%isd, g%HId2%ied, g%HId2%jsd, g%HId2%jed)
900  diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-downsampled mask
901  ! Interface u-points in diagnostic coordinate
902  axes => diag_cs%remap_axesCui(c)
903  call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
904  g%HId2%IscB,g%HId2%IecB,g%HId2%jsc, g%HId2%jec,g%HId2%IsdB,g%HId2%IedB,g%HId2%jsd, g%HId2%jed)
905  diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-downsampled mask
906  ! Interface v-points in diagnostic coordinate
907  axes => diag_cs%remap_axesCvi(c)
908  call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl,g%isc ,g%JscB, &
909  g%HId2%isc ,g%HId2%iec, g%HId2%JscB,g%HId2%JecB,g%HId2%isd ,g%HId2%ied, g%HId2%JsdB,g%HId2%JedB)
910  diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-downsampled mask
911  ! Interface q-points in diagnostic coordinate
912  axes => diag_cs%remap_axesBi(c)
913  call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
914  g%HId2%IscB,g%HId2%IecB,g%HId2%JscB,g%HId2%JecB,g%HId2%IsdB,g%HId2%IedB,g%HId2%JsdB,g%HId2%JedB)
915  diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask
916  enddo
917  enddo
918 end subroutine set_masks_for_axes_dsamp
919 
920 !> Attaches the id of cell areas to axes groups for use with cell_measures
921 subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q)
922  type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure
923  integer, optional, intent(in) :: id_area_t !< Diag_mediator id for area of h-cells
924  integer, optional, intent(in) :: id_area_q !< Diag_mediator id for area of q-cells
925  ! Local variables
926  integer :: fms_id, i
927  if (present(id_area_t)) then
928  fms_id = diag_cs%diags(id_area_t)%fms_diag_id
929  diag_cs%axesT1%id_area = fms_id
930  diag_cs%axesTi%id_area = fms_id
931  diag_cs%axesTL%id_area = fms_id
932  do i=1, diag_cs%num_diag_coords
933  diag_cs%remap_axesTL(i)%id_area = fms_id
934  diag_cs%remap_axesTi(i)%id_area = fms_id
935  enddo
936  endif
937  if (present(id_area_q)) then
938  fms_id = diag_cs%diags(id_area_q)%fms_diag_id
939  diag_cs%axesB1%id_area = fms_id
940  diag_cs%axesBi%id_area = fms_id
941  diag_cs%axesBL%id_area = fms_id
942  do i=1, diag_cs%num_diag_coords
943  diag_cs%remap_axesBL(i)%id_area = fms_id
944  diag_cs%remap_axesBi(i)%id_area = fms_id
945  enddo
946  endif
947 end subroutine diag_register_area_ids
948 
949 !> Sets a handle inside diagnostics mediator to associate 3d cell measures
950 subroutine register_cell_measure(G, diag, Time)
951  type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
952  type(diag_ctrl), target, intent(inout) :: diag !< Regulates diagnostic output
953  type(time_type), intent(in) :: time !< Model time
954  ! Local variables
955  integer :: id
956  id = register_diag_field('ocean_model', 'volcello', diag%axesTL, &
957  time, 'Ocean grid-cell volume', 'm3', &
958  standard_name='ocean_volume', v_extensive=.true., &
959  x_cell_method='sum', y_cell_method='sum')
960  call diag_associate_volume_cell_measure(diag, id)
961 
962 end subroutine register_cell_measure
963 
964 !> Attaches the id of cell volumes to axes groups for use with cell_measures
965 subroutine diag_associate_volume_cell_measure(diag_cs, id_h_volume)
966  type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure
967  integer, intent(in) :: id_h_volume !< Diag_manager id for volume of h-cells
968  ! Local variables
969  type(diag_type), pointer :: tmp => null()
970 
971  if (id_h_volume<=0) return ! Do nothing
972  diag_cs%volume_cell_measure_dm_id = id_h_volume ! Record for diag_get_volume_cell_measure_dm_id()
973 
974  ! Set the cell measure for this axes group to the FMS id in this coordinate system
975  diag_cs%diags(id_h_volume)%axes%id_volume = diag_cs%diags(id_h_volume)%fms_diag_id
976 
977  tmp => diag_cs%diags(id_h_volume)%next ! First item in the list, if any
978  do while (associated(tmp))
979  ! Set the cell measure for this axes group to the FMS id in this coordinate system
980  tmp%axes%id_volume = tmp%fms_diag_id
981  tmp => tmp%next ! Move to next axes group for this field
982  enddo
983 
984 end subroutine diag_associate_volume_cell_measure
985 
986 !> Returns diag_manager id for cell measure of h-cells
987 integer function diag_get_volume_cell_measure_dm_id(diag_cs)
988  type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics control structure
989 
990  diag_get_volume_cell_measure_dm_id = diag_cs%volume_cell_measure_dm_id
991 
992 end function diag_get_volume_cell_measure_dm_id
993 
994 !> Defines a group of "axes" from list of handles
995 subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_number, &
996  x_cell_method, y_cell_method, v_cell_method, &
997  is_h_point, is_q_point, is_u_point, is_v_point, &
998  is_layer, is_interface, &
999  is_native, needs_remapping, needs_interpolating, &
1000  xyave_axes)
1001  type(diag_ctrl), target, intent(in) :: diag_cs !< Diagnostics control structure
1002  integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles
1003  type(axes_grp), intent(out) :: axes !< The group of 1D axes
1004  integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid
1005  integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate
1006  character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the
1007  !! "cell_methods" attribute in CF convention
1008  character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the
1009  !! "cell_methods" attribute in CF convention
1010  character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct
1011  !! the "cell_methods" attribute in CF convention
1012  logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point
1013  !! located fields
1014  logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point
1015  !! located fields
1016  logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for
1017  !! u-point located fields
1018  logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for
1019  !! v-point located fields
1020  logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is
1021  !! for a layer vertically-located field.
1022  logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group
1023  !! is for an interface vertically-located field.
1024  logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is
1025  !! for a native model grid. False for any other grid.
1026  logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is
1027  !! for a intensive layer-located field that must
1028  !! be remapped to these axes. Used for rank>2.
1029  logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group
1030  !! is for a sampled interface-located field that must
1031  !! be interpolated to these axes. Used for rank>2.
1032  type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally
1033  !! area-average diagnostics
1034  ! Local variables
1035  integer :: n
1036 
1037  n = size(handles)
1038  if (n<1 .or. n>3) call mom_error(fatal, "define_axes_group: wrong size for list of handles!")
1039  allocate( axes%handles(n) )
1040  axes%id = i2s(handles, n) ! Identifying string
1041  axes%rank = n
1042  axes%handles(:) = handles(:)
1043  axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure
1044  if (present(x_cell_method)) then
1045  if (axes%rank<2) call mom_error(fatal, 'define_axes_group: ' // &
1046  'Can not set x_cell_method for rank<2.')
1047  axes%x_cell_method = trim(x_cell_method)
1048  else
1049  axes%x_cell_method = ''
1050  endif
1051  if (present(y_cell_method)) then
1052  if (axes%rank<2) call mom_error(fatal, 'define_axes_group: ' // &
1053  'Can not set y_cell_method for rank<2.')
1054  axes%y_cell_method = trim(y_cell_method)
1055  else
1056  axes%y_cell_method = ''
1057  endif
1058  if (present(v_cell_method)) then
1059  if (axes%rank/=1 .and. axes%rank/=3) call mom_error(fatal, 'define_axes_group: ' // &
1060  'Can not set v_cell_method for rank<>1 or 3.')
1061  axes%v_cell_method = trim(v_cell_method)
1062  else
1063  axes%v_cell_method = ''
1064  endif
1065  if (present(nz)) axes%nz = nz
1066  if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number
1067  if (present(is_h_point)) axes%is_h_point = is_h_point
1068  if (present(is_q_point)) axes%is_q_point = is_q_point
1069  if (present(is_u_point)) axes%is_u_point = is_u_point
1070  if (present(is_v_point)) axes%is_v_point = is_v_point
1071  if (present(is_layer)) axes%is_layer = is_layer
1072  if (present(is_interface)) axes%is_interface = is_interface
1073  if (present(is_native)) axes%is_native = is_native
1074  if (present(needs_remapping)) axes%needs_remapping = needs_remapping
1075  if (present(needs_interpolating)) axes%needs_interpolating = needs_interpolating
1076  if (present(xyave_axes)) axes%xyave_axes => xyave_axes
1077 
1078  ! Setup masks for this axes group
1079  axes%mask2d => null()
1080  if (axes%rank==2) then
1081  if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT
1082  if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu
1083  if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv
1084  if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu
1085  endif
1086  ! A static 3d mask for non-native coordinates can only be setup when a grid is available
1087  axes%mask3d => null()
1088  if (axes%rank==3 .and. axes%is_native) then
1089  ! Native variables can/should use the native masks copied into diag_cs
1090  if (axes%is_layer) then
1091  if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL
1092  if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL
1093  if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL
1094  if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL
1095  elseif (axes%is_interface) then
1096  if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi
1097  if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui
1098  if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi
1099  if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi
1100  endif
1101  endif
1102 
1103 end subroutine define_axes_group
1104 
1105 !> Defines a group of downsampled "axes" from list of handles
1106 subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coordinate_number, &
1107  x_cell_method, y_cell_method, v_cell_method, &
1108  is_h_point, is_q_point, is_u_point, is_v_point, &
1109  is_layer, is_interface, &
1110  is_native, needs_remapping, needs_interpolating, &
1111  xyave_axes)
1112  type(diag_ctrl), target, intent(in) :: diag_cs !< Diagnostics control structure
1113  integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles
1114  type(axes_grp), intent(out) :: axes !< The group of 1D axes
1115  integer, intent(in) :: dl !< Downsample level
1116  integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid
1117  integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate
1118  character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the
1119  !! "cell_methods" attribute in CF convention
1120  character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the
1121  !! "cell_methods" attribute in CF convention
1122  character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct
1123  !! the "cell_methods" attribute in CF convention
1124  logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point
1125  !! located fields
1126  logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point
1127  !! located fields
1128  logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for
1129  !! u-point located fields
1130  logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for
1131  !! v-point located fields
1132  logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is
1133  !! for a layer vertically-located field.
1134  logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group
1135  !! is for an interface vertically-located field.
1136  logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is
1137  !! for a native model grid. False for any other grid.
1138  logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is
1139  !! for a intensive layer-located field that must
1140  !! be remapped to these axes. Used for rank>2.
1141  logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group
1142  !! is for a sampled interface-located field that must
1143  !! be interpolated to these axes. Used for rank>2.
1144  type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally
1145  !! area-average diagnostics
1146  ! Local variables
1147  integer :: n
1148 
1149  n = size(handles)
1150  if (n<1 .or. n>3) call mom_error(fatal, "define_axes_group: wrong size for list of handles!")
1151  allocate( axes%handles(n) )
1152  axes%id = i2s(handles, n) ! Identifying string
1153  axes%rank = n
1154  axes%handles(:) = handles(:)
1155  axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure
1156  if (present(x_cell_method)) then
1157  if (axes%rank<2) call mom_error(fatal, 'define_axes_group: ' // &
1158  'Can not set x_cell_method for rank<2.')
1159  axes%x_cell_method = trim(x_cell_method)
1160  else
1161  axes%x_cell_method = ''
1162  endif
1163  if (present(y_cell_method)) then
1164  if (axes%rank<2) call mom_error(fatal, 'define_axes_group: ' // &
1165  'Can not set y_cell_method for rank<2.')
1166  axes%y_cell_method = trim(y_cell_method)
1167  else
1168  axes%y_cell_method = ''
1169  endif
1170  if (present(v_cell_method)) then
1171  if (axes%rank/=1 .and. axes%rank/=3) call mom_error(fatal, 'define_axes_group: ' // &
1172  'Can not set v_cell_method for rank<>1 or 3.')
1173  axes%v_cell_method = trim(v_cell_method)
1174  else
1175  axes%v_cell_method = ''
1176  endif
1177  axes%downsample_level = dl
1178  if (present(nz)) axes%nz = nz
1179  if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number
1180  if (present(is_h_point)) axes%is_h_point = is_h_point
1181  if (present(is_q_point)) axes%is_q_point = is_q_point
1182  if (present(is_u_point)) axes%is_u_point = is_u_point
1183  if (present(is_v_point)) axes%is_v_point = is_v_point
1184  if (present(is_layer)) axes%is_layer = is_layer
1185  if (present(is_interface)) axes%is_interface = is_interface
1186  if (present(is_native)) axes%is_native = is_native
1187  if (present(needs_remapping)) axes%needs_remapping = needs_remapping
1188  if (present(needs_interpolating)) axes%needs_interpolating = needs_interpolating
1189  if (present(xyave_axes)) axes%xyave_axes => xyave_axes
1190 
1191  ! Setup masks for this axes group
1192 
1193  axes%mask2d => null()
1194  if (axes%rank==2) then
1195  if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT
1196  if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu
1197  if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv
1198  if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu
1199  endif
1200  ! A static 3d mask for non-native coordinates can only be setup when a grid is available
1201  axes%mask3d => null()
1202  if (axes%rank==3 .and. axes%is_native) then
1203  ! Native variables can/should use the native masks copied into diag_cs
1204  if (axes%is_layer) then
1205  if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL
1206  if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL
1207  if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL
1208  if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL
1209  elseif (axes%is_interface) then
1210  if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi
1211  if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui
1212  if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi
1213  if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi
1214  endif
1215  endif
1216 
1217  axes%dsamp(dl)%mask2d => null()
1218  if (axes%rank==2) then
1219  if (axes%is_h_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dT
1220  if (axes%is_u_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCu
1221  if (axes%is_v_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCv
1222  if (axes%is_q_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dBu
1223  endif
1224  ! A static 3d mask for non-native coordinates can only be setup when a grid is available
1225  axes%dsamp(dl)%mask3d => null()
1226  if (axes%rank==3 .and. axes%is_native) then
1227  ! Native variables can/should use the native masks copied into diag_cs
1228  if (axes%is_layer) then
1229  if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTL
1230  if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCuL
1231  if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvL
1232  if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBL
1233  elseif (axes%is_interface) then
1234  if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTi
1235  if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCui
1236  if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvi
1237  if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBi
1238  endif
1239  endif
1240 
1241 end subroutine define_axes_group_dsamp
1242 
1243 !> Set up the array extents for doing diagnostics
1244 subroutine set_diag_mediator_grid(G, diag_cs)
1245  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure
1246  type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
1247 
1248  diag_cs%is = g%isc - (g%isd-1) ; diag_cs%ie = g%iec - (g%isd-1)
1249  diag_cs%js = g%jsc - (g%jsd-1) ; diag_cs%je = g%jec - (g%jsd-1)
1250  diag_cs%isd = g%isd ; diag_cs%ied = g%ied
1251  diag_cs%jsd = g%jsd ; diag_cs%jed = g%jed
1252 
1253 end subroutine set_diag_mediator_grid
1254 
1255 !> Make a real scalar diagnostic available for averaging or output
1256 subroutine post_data_0d(diag_field_id, field, diag_cs, is_static)
1257  integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
1258  !! previous call to register_diag_field.
1259  real, intent(in) :: field !< real value being offered for output or averaging
1260  type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output
1261  logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
1262 
1263  ! Local variables
1264  real :: locfield
1265  logical :: used, is_stat
1266  type(diag_type), pointer :: diag => null()
1267 
1268  if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator)
1269  is_stat = .false. ; if (present(is_static)) is_stat = is_static
1270 
1271  ! Iterate over list of diag 'variants', e.g. CMOR aliases, call send_data
1272  ! for each one.
1273  call assert(diag_field_id < diag_cs%next_free_diag_id, &
1274  'post_data_0d: Unregistered diagnostic id')
1275  diag => diag_cs%diags(diag_field_id)
1276 
1277  do while (associated(diag))
1278  locfield = field
1279  if (diag%conversion_factor /= 0.) &
1280  locfield = locfield * diag%conversion_factor
1281 
1282  if (diag_cs%diag_as_chksum) then
1283  call chksum0(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit)
1284  else if (is_stat) then
1285  used = send_data(diag%fms_diag_id, locfield)
1286  elseif (diag_cs%ave_enabled) then
1287  used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end)
1288  endif
1289  diag => diag%next
1290  enddo
1291 
1292  if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator)
1293 end subroutine post_data_0d
1294 
1295 !> Make a real 1-d array diagnostic available for averaging or output
1296 subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static)
1297  integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
1298  !! previous call to register_diag_field.
1299  real, target, intent(in) :: field(:) !< 1-d array being offered for output or averaging
1300  type(diag_ctrl), target, intent(in) :: diag_cs !< Structure used to regulate diagnostic output
1301  logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
1302 
1303  ! Local variables
1304  logical :: used ! The return value of send_data is not used for anything.
1305  real, dimension(:), pointer :: locfield => null()
1306  logical :: is_stat
1307  integer :: k, ks, ke
1308  type(diag_type), pointer :: diag => null()
1309 
1310  if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator)
1311  is_stat = .false. ; if (present(is_static)) is_stat = is_static
1312 
1313  ! Iterate over list of diag 'variants', e.g. CMOR aliases.
1314  call assert(diag_field_id < diag_cs%next_free_diag_id, &
1315  'post_data_1d_k: Unregistered diagnostic id')
1316  diag => diag_cs%diags(diag_field_id)
1317  do while (associated(diag))
1318 
1319  if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then
1320  ks = lbound(field,1) ; ke = ubound(field,1)
1321  allocate( locfield( ks:ke ) )
1322 
1323  do k=ks,ke
1324  if (field(k) == diag_cs%missing_value) then
1325  locfield(k) = diag_cs%missing_value
1326  else
1327  locfield(k) = field(k) * diag%conversion_factor
1328  endif
1329  enddo
1330  else
1331  locfield => field
1332  endif
1333 
1334  if (diag_cs%diag_as_chksum) then
1335  call zchksum(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit)
1336  else if (is_stat) then
1337  used = send_data(diag%fms_diag_id, locfield)
1338  elseif (diag_cs%ave_enabled) then
1339  used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, weight=diag_cs%time_int)
1340  endif
1341  if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield )
1342 
1343  diag => diag%next
1344  enddo
1345 
1346  if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator)
1347 end subroutine post_data_1d_k
1348 
1349 !> Make a real 2-d array diagnostic available for averaging or output
1350 subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask)
1351  integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
1352  !! previous call to register_diag_field.
1353  real, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging
1354  type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output
1355  logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
1356  real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask.
1357 
1358  ! Local variables
1359  type(diag_type), pointer :: diag => null()
1360 
1361  if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator)
1362 
1363  ! Iterate over list of diag 'variants' (e.g. CMOR aliases) and post each.
1364  call assert(diag_field_id < diag_cs%next_free_diag_id, &
1365  'post_data_2d: Unregistered diagnostic id')
1366  diag => diag_cs%diags(diag_field_id)
1367  do while (associated(diag))
1368  call post_data_2d_low(diag, field, diag_cs, is_static, mask)
1369  diag => diag%next
1370  enddo
1371 
1372  if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator)
1373 end subroutine post_data_2d
1374 
1375 !> Make a real 2-d array diagnostic available for averaging or output
1376 !! using a diag_type instead of an integer id.
1377 subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask)
1378  type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post
1379  real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging
1380  type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
1381  logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
1382  real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask.
1383 
1384  ! Local variables
1385  real, dimension(:,:), pointer :: locfield
1386  real, dimension(:,:), pointer :: locmask
1387  character(len=300) :: mesg
1388  logical :: used, is_stat
1389  integer :: cszi, cszj, dszi, dszj
1390  integer :: isv, iev, jsv, jev, i, j, chksum, isv_o,jsv_o
1391  real, dimension(:,:), allocatable, target :: locfield_dsamp
1392  real, dimension(:,:), allocatable, target :: locmask_dsamp
1393  integer :: dl
1394 
1395  locfield => null()
1396  locmask => null()
1397  is_stat = .false. ; if (present(is_static)) is_stat = is_static
1398 
1399  ! Determine the propery array indices, noting that because of the (:,:)
1400  ! declaration of field, symmetric arrays are using a SW-grid indexing,
1401  ! but non-symmetric arrays are using a NE-grid indexing. Send_data
1402  ! actually only uses the difference between ie and is to determine
1403  ! the output data size and assumes that halos are symmetric.
1404  isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je
1405 
1406  cszi = diag_cs%ie-diag_cs%is +1 ; dszi = diag_cs%ied-diag_cs%isd +1
1407  cszj = diag_cs%je-diag_cs%js +1 ; dszj = diag_cs%jed-diag_cs%jsd +1
1408  if ( size(field,1) == dszi ) then
1409  isv = diag_cs%is ; iev = diag_cs%ie ! Data domain
1410  elseif ( size(field,1) == dszi + 1 ) then
1411  isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain
1412  elseif ( size(field,1) == cszi) then
1413  isv = 1 ; iev = cszi ! Computational domain
1414  elseif ( size(field,1) == cszi + 1 ) then
1415  isv = 1 ; iev = cszi+1 ! Symmetric computational domain
1416  else
1417  write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//&
1418  "does not match one of ", cszi, cszi+1, dszi, dszi+1
1419  call mom_error(fatal,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg))
1420  endif
1421 
1422  if ( size(field,2) == dszj ) then
1423  jsv = diag_cs%js ; jev = diag_cs%je ! Data domain
1424  elseif ( size(field,2) == dszj + 1 ) then
1425  jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain
1426  elseif ( size(field,2) == cszj ) then
1427  jsv = 1 ; jev = cszj ! Computational domain
1428  elseif ( size(field,2) == cszj+1 ) then
1429  jsv = 1 ; jev = cszj+1 ! Symmetric computational domain
1430  else
1431  write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//&
1432  "does not match one of ", cszj, cszj+1, dszj, dszj+1
1433  call mom_error(fatal,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg))
1434  endif
1435 
1436  if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then
1437  allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) )
1438  do j=jsv,jev ; do i=isv,iev
1439  if (field(i,j) == diag_cs%missing_value) then
1440  locfield(i,j) = diag_cs%missing_value
1441  else
1442  locfield(i,j) = field(i,j) * diag%conversion_factor
1443  endif
1444  enddo ; enddo
1445  locfield(isv:iev,jsv:jev) = field(isv:iev,jsv:jev) * diag%conversion_factor
1446  else
1447  locfield => field
1448  endif
1449 
1450  if (present(mask)) then
1451  locmask => mask
1452  elseif(.NOT. is_stat) then
1453  if(associated(diag%axes%mask2d)) locmask => diag%axes%mask2d
1454  endif
1455 
1456  dl=1
1457  if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet
1458  !Downsample the diag field and mask (if present)
1459  if (dl > 1) then
1460  isv_o=isv ; jsv_o=jsv
1461  call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask)
1462  if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield )
1463  locfield => locfield_dsamp
1464  if (present(mask)) then
1465  call downsample_field_2d(locmask, locmask_dsamp, dl, msk, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev)
1466  locmask => locmask_dsamp
1467  elseif(associated(diag%axes%dsamp(dl)%mask2d)) then
1468  locmask => diag%axes%dsamp(dl)%mask2d
1469  endif
1470  endif
1471 
1472  if (diag_cs%diag_as_chksum) then
1473  if (diag%axes%is_h_point) then
1474  call hchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1475  logunit=diag_cs%chksum_iounit)
1476  else if (diag%axes%is_u_point) then
1477  call uchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1478  logunit=diag_cs%chksum_iounit)
1479  else if (diag%axes%is_v_point) then
1480  call vchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1481  logunit=diag_cs%chksum_iounit)
1482  else if (diag%axes%is_q_point) then
1483  call bchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1484  logunit=diag_cs%chksum_iounit)
1485  else
1486  call mom_error(fatal, "post_data_2d_low: unknown axis type.")
1487  endif
1488  else
1489  if (is_stat) then
1490  if (present(mask)) then
1491  call assert(size(locfield) == size(locmask), &
1492  'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str)
1493  used = send_data(diag%fms_diag_id, locfield, &
1494  is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask)
1495  !elseif (associated(diag%axes%mask2d)) then
1496  ! used = send_data(diag%fms_diag_id, locfield, &
1497  ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d)
1498  else
1499  used = send_data(diag%fms_diag_id, locfield, &
1500  is_in=isv, js_in=jsv, ie_in=iev, je_in=jev)
1501  endif
1502  elseif (diag_cs%ave_enabled) then
1503  if (associated(locmask)) then
1504  call assert(size(locfield) == size(locmask), &
1505  'post_data_2d_low: mask size mismatch: '//diag%debug_str)
1506  used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1507  is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1508  weight=diag_cs%time_int, rmask=locmask)
1509  else
1510  used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1511  is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1512  weight=diag_cs%time_int)
1513  endif
1514  endif
1515  endif
1516  if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) &
1517  deallocate( locfield )
1518 end subroutine post_data_2d_low
1519 
1520 !> Make a real 3-d array diagnostic available for averaging or output.
1521 subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h)
1523  integer, intent(in) :: diag_field_id !< The id for an output variable returned by a
1524  !! previous call to register_diag_field.
1525  real, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging
1526  type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output
1527  logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
1528  real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask.
1529  real, dimension(:,:,:), &
1530  target, optional, intent(in) :: alt_h !< An alternate thickness to use for vertically
1531  !! remapping this diagnostic [H ~> m or kg m-2].
1532 
1533  ! Local variables
1534  type(diag_type), pointer :: diag => null()
1535  integer :: nz, i, j, k
1536  real, dimension(:,:,:), allocatable :: remapped_field
1537  logical :: staggered_in_x, staggered_in_y
1538  real, dimension(:,:,:), pointer :: h_diag => null()
1539 
1540  if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator)
1541 
1542  ! For intensive variables only, we can choose to use a different diagnostic grid
1543  ! to map to
1544  if (present(alt_h)) then
1545  h_diag => alt_h
1546  else
1547  h_diag => diag_cs%h
1548  endif
1549 
1550  ! Iterate over list of diag 'variants', e.g. CMOR aliases, different vertical
1551  ! grids, and post each.
1552  call assert(diag_field_id < diag_cs%next_free_diag_id, &
1553  'post_data_3d: Unregistered diagnostic id')
1554  diag => diag_cs%diags(diag_field_id)
1555  do while (associated(diag))
1556  call assert(associated(diag%axes), 'post_data_3d: axes is not associated')
1557 
1558  staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point
1559  staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point
1560 
1561  if (diag%v_extensive .and. .not.diag%axes%is_native) then
1562  ! The field is vertically integrated and needs to be re-gridded
1563  if (present(mask)) then
1564  call mom_error(fatal,"post_data_3d: no mask for regridded field.")
1565  endif
1566 
1567  if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap)
1568  allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz))
1569  call vertically_reintegrate_diag_field( &
1570  diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, &
1571  diag_cs%h_begin, &
1572  diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, &
1573  staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field)
1574  if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap)
1575  if (associated(diag%axes%mask3d)) then
1576  ! Since 3d masks do not vary in the vertical, just use as much as is
1577  ! needed.
1578  call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
1579  mask=diag%axes%mask3d)
1580  else
1581  call post_data_3d_low(diag, remapped_field, diag_cs, is_static)
1582  endif
1583  if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap)
1584  deallocate(remapped_field)
1585  if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap)
1586  elseif (diag%axes%needs_remapping) then
1587  ! Remap this field to another vertical coordinate.
1588  if (present(mask)) then
1589  call mom_error(fatal,"post_data_3d: no mask for regridded field.")
1590  endif
1591 
1592  if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap)
1593  allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz))
1594  call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), &
1595  diag_cs%G, diag_cs%GV, h_diag, staggered_in_x, staggered_in_y, &
1596  diag%axes%mask3d, field, remapped_field)
1597  if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap)
1598  if (associated(diag%axes%mask3d)) then
1599  ! Since 3d masks do not vary in the vertical, just use as much as is
1600  ! needed.
1601  call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
1602  mask=diag%axes%mask3d)
1603  else
1604  call post_data_3d_low(diag, remapped_field, diag_cs, is_static)
1605  endif
1606  if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap)
1607  deallocate(remapped_field)
1608  if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap)
1609  elseif (diag%axes%needs_interpolating) then
1610  ! Interpolate this field to another vertical coordinate.
1611  if (present(mask)) then
1612  call mom_error(fatal,"post_data_3d: no mask for regridded field.")
1613  endif
1614 
1615  if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap)
1616  allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz+1))
1617  call vertically_interpolate_diag_field(diag_cs%diag_remap_cs( &
1618  diag%axes%vertical_coordinate_number), &
1619  diag_cs%G, h_diag, staggered_in_x, staggered_in_y, &
1620  diag%axes%mask3d, field, remapped_field)
1621  if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap)
1622  if (associated(diag%axes%mask3d)) then
1623  ! Since 3d masks do not vary in the vertical, just use as much as is
1624  ! needed.
1625  call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
1626  mask=diag%axes%mask3d)
1627  else
1628  call post_data_3d_low(diag, remapped_field, diag_cs, is_static)
1629  endif
1630  if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap)
1631  deallocate(remapped_field)
1632  if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap)
1633  else
1634  call post_data_3d_low(diag, field, diag_cs, is_static, mask)
1635  endif
1636  diag => diag%next
1637  enddo
1638  if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator)
1639 
1640 end subroutine post_data_3d
1641 
1642 !> Make a real 3-d array diagnostic available for averaging or output
1643 !! using a diag_type instead of an integer id.
1644 subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask)
1645  type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post
1646  real, target, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging
1647  type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
1648  logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered.
1649  real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask.
1650 
1651  ! Local variables
1652  real, dimension(:,:,:), pointer :: locfield
1653  real, dimension(:,:,:), pointer :: locmask
1654  character(len=300) :: mesg
1655  logical :: used ! The return value of send_data is not used for anything.
1656  logical :: staggered_in_x, staggered_in_y
1657  logical :: is_stat
1658  integer :: cszi, cszj, dszi, dszj
1659  integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o
1660  integer :: chksum
1661  real, dimension(:,:,:), allocatable, target :: locfield_dsamp
1662  real, dimension(:,:,:), allocatable, target :: locmask_dsamp
1663  integer :: dl
1664 
1665  locfield => null()
1666  locmask => null()
1667  is_stat = .false. ; if (present(is_static)) is_stat = is_static
1668 
1669  ! Determine the proper array indices, noting that because of the (:,:)
1670  ! declaration of field, symmetric arrays are using a SW-grid indexing,
1671  ! but non-symmetric arrays are using a NE-grid indexing. Send_data
1672  ! actually only uses the difference between ie and is to determine
1673  ! the output data size and assumes that halos are symmetric.
1674  isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je
1675 
1676  cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1
1677  cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1
1678  if ( size(field,1) == dszi ) then
1679  isv = diag_cs%is ; iev = diag_cs%ie ! Data domain
1680  elseif ( size(field,1) == dszi + 1 ) then
1681  isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain
1682  elseif ( size(field,1) == cszi) then
1683  isv = 1 ; iev = cszi ! Computational domain
1684  elseif ( size(field,1) == cszi + 1 ) then
1685  isv = 1 ; iev = cszi+1 ! Symmetric computational domain
1686  else
1687  write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//&
1688  "does not match one of ", cszi, cszi+1, dszi, dszi+1
1689  call mom_error(fatal,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg))
1690  endif
1691 
1692  if ( size(field,2) == dszj ) then
1693  jsv = diag_cs%js ; jev = diag_cs%je ! Data domain
1694  elseif ( size(field,2) == dszj + 1 ) then
1695  jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain
1696  elseif ( size(field,2) == cszj ) then
1697  jsv = 1 ; jev = cszj ! Computational domain
1698  elseif ( size(field,2) == cszj+1 ) then
1699  jsv = 1 ; jev = cszj+1 ! Symmetric computational domain
1700  else
1701  write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//&
1702  "does not match one of ", cszj, cszj+1, dszj, dszj+1
1703  call mom_error(fatal,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg))
1704  endif
1705 
1706  ks = lbound(field,3) ; ke = ubound(field,3)
1707  if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then
1708  allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) )
1709  ! locfield(:,:,:) = 0.0 ! Zeroing out this array would be a good idea, but it appears
1710  ! not to be necessary.
1711  isv_c = isv ; jsv_c = jsv
1712  if (diag%fms_xyave_diag_id>0) then
1713  staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point
1714  staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point
1715  ! When averaging a staggered field, edge points are always required.
1716  if (staggered_in_x) isv_c = iev - (diag_cs%ie - diag_cs%is) - 1
1717  if (staggered_in_y) jsv_c = jev - (diag_cs%je - diag_cs%js) - 1
1718  if (isv_c < lbound(locfield,1)) call mom_error(fatal, &
1719  "It is an error to average a staggered diagnostic field that does not "//&
1720  "have i-direction space to represent the symmetric computational domain.")
1721  if (jsv_c < lbound(locfield,2)) call mom_error(fatal, &
1722  "It is an error to average a staggered diagnostic field that does not "//&
1723  "have j-direction space to represent the symmetric computational domain.")
1724  endif
1725 
1726  do k=ks,ke ; do j=jsv,jev ; do i=isv,iev
1727  if (field(i,j,k) == diag_cs%missing_value) then
1728  locfield(i,j,k) = diag_cs%missing_value
1729  else
1730  locfield(i,j,k) = field(i,j,k) * diag%conversion_factor
1731  endif
1732  enddo ; enddo ; enddo
1733  else
1734  locfield => field
1735  endif
1736 
1737  if (present(mask)) then
1738  locmask => mask
1739  elseif(associated(diag%axes%mask3d)) then
1740  locmask => diag%axes%mask3d
1741  endif
1742 
1743  dl=1
1744  if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet
1745  !Downsample the diag field and mask (if present)
1746  if (dl > 1) then
1747  isv_o=isv ; jsv_o=jsv
1748  call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask)
1749  if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield )
1750  locfield => locfield_dsamp
1751  if (present(mask)) then
1752  call downsample_field_3d(locmask, locmask_dsamp, dl, msk, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev)
1753  locmask => locmask_dsamp
1754  elseif(associated(diag%axes%dsamp(dl)%mask3d)) then
1755  locmask => diag%axes%dsamp(dl)%mask3d
1756  endif
1757  endif
1758 
1759  if (diag%fms_diag_id>0) then
1760  if (diag_cs%diag_as_chksum) then
1761  if (diag%axes%is_h_point) then
1762  call hchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1763  logunit=diag_cs%chksum_iounit)
1764  else if (diag%axes%is_u_point) then
1765  call uchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1766  logunit=diag_cs%chksum_iounit)
1767  else if (diag%axes%is_v_point) then
1768  call vchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1769  logunit=diag_cs%chksum_iounit)
1770  else if (diag%axes%is_q_point) then
1771  call bchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1772  logunit=diag_cs%chksum_iounit)
1773  else
1774  call mom_error(fatal, "post_data_3d_low: unknown axis type.")
1775  endif
1776  else
1777  if (is_stat) then
1778  if (present(mask)) then
1779  call assert(size(locfield) == size(locmask), &
1780  'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str)
1781  used = send_data(diag%fms_diag_id, locfield, &
1782  is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask)
1783  !elseif (associated(diag%axes%mask2d)) then
1784  ! used = send_data(diag%fms_diag_id, locfield, &
1785  ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d)
1786  else
1787  used = send_data(diag%fms_diag_id, locfield, &
1788  is_in=isv, js_in=jsv, ie_in=iev, je_in=jev)
1789  endif
1790  elseif (diag_cs%ave_enabled) then
1791  if (associated(locmask)) then
1792  call assert(size(locfield) == size(locmask), &
1793  'post_data_3d_low: mask size mismatch: '//diag%debug_str)
1794  used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1795  is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1796  weight=diag_cs%time_int, rmask=locmask)
1797  else
1798  used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1799  is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1800  weight=diag_cs%time_int)
1801  endif
1802  endif
1803  endif
1804  endif
1805 
1806  if (diag%fms_xyave_diag_id>0) then
1807  call post_xy_average(diag_cs, diag, locfield)
1808  endif
1809 
1810  if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) &
1811  deallocate( locfield )
1812 
1813 end subroutine post_data_3d_low
1814 
1815 !> Post the horizontally area-averaged diagnostic
1816 subroutine post_xy_average(diag_cs, diag, field)
1817  type(diag_type), intent(in) :: diag !< This diagnostic
1818  real, target, intent(in) :: field(:,:,:) !< Diagnostic field
1819  type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics mediator control structure
1820  ! Local variable
1821  real, dimension(size(field,3)) :: averaged_field
1822  logical, dimension(size(field,3)) :: averaged_mask
1823  logical :: staggered_in_x, staggered_in_y, used
1824  integer :: nz, remap_nz, coord
1825 
1826  if (.not. diag_cs%ave_enabled) then
1827  return
1828  endif
1829 
1830  staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point
1831  staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point
1832 
1833  if (diag%axes%is_native) then
1834  call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, diag_cs%h, &
1835  staggered_in_x, staggered_in_y, &
1836  diag%axes%is_layer, diag%v_extensive, &
1837  field, &
1838  averaged_field, averaged_mask)
1839  else
1840  nz = size(field, 3)
1841  coord = diag%axes%vertical_coordinate_number
1842  remap_nz = diag_cs%diag_remap_cs(coord)%nz
1843 
1844  call assert(diag_cs%diag_remap_cs(coord)%initialized, &
1845  'post_xy_average: remap_cs not initialized.')
1846 
1847  call assert(implies(diag%axes%is_layer, nz == remap_nz), &
1848  'post_xy_average: layer field dimension mismatch.')
1849  call assert(implies(.not. diag%axes%is_layer, nz == remap_nz+1), &
1850  'post_xy_average: interface field dimension mismatch.')
1851 
1852  call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, &
1853  diag_cs%diag_remap_cs(coord)%h, &
1854  staggered_in_x, staggered_in_y, &
1855  diag%axes%is_layer, diag%v_extensive, &
1856  field, &
1857  averaged_field, averaged_mask)
1858  endif
1859 
1860  if (diag_cs%diag_as_chksum) then
1861  call zchksum(averaged_field, trim(diag%debug_str)//'_xyave', &
1862  logunit=diag_cs%chksum_iounit)
1863  else
1864  used = send_data(diag%fms_xyave_diag_id, averaged_field, diag_cs%time_end, &
1865  weight=diag_cs%time_int, mask=averaged_mask)
1866  endif
1867 end subroutine post_xy_average
1868 
1869 !> This subroutine enables the accumulation of time averages over the specified time interval.
1870 subroutine enable_averaging(time_int_in, time_end_in, diag_cs)
1871  real, intent(in) :: time_int_in !< The time interval [s] over which any
1872  !! values that are offered are valid.
1873  type(time_type), intent(in) :: time_end_in !< The end time of the valid interval
1874  type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
1875 
1876 ! This subroutine enables the accumulation of time averages over the specified time interval.
1877 
1878 ! if (num_file==0) return
1879  diag_cs%time_int = time_int_in
1880  diag_cs%time_end = time_end_in
1881  diag_cs%ave_enabled = .true.
1882 end subroutine enable_averaging
1883 
1884 !> Enable the accumulation of time averages over the specified time interval in time units.
1885 subroutine enable_averages(time_int, time_end, diag_CS, T_to_s)
1886  real, intent(in) :: time_int !< The time interval over which any values
1887  !! that are offered are valid [T ~> s].
1888  type(time_type), intent(in) :: time_end !< The end time of the valid interval.
1889  type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output
1890  real, optional, intent(in) :: t_to_s !< A conversion factor for time_int to [s].
1891 ! This subroutine enables the accumulation of time averages over the specified time interval.
1892 
1893  if (present(t_to_s)) then
1894  diag_cs%time_int = time_int*t_to_s
1895  elseif (associated(diag_cs%US)) then
1896  diag_cs%time_int = time_int*diag_cs%US%T_to_s
1897  else
1898  diag_cs%time_int = time_int
1899  endif
1900  diag_cs%time_end = time_end
1901  diag_cs%ave_enabled = .true.
1902 end subroutine enable_averages
1903 
1904 !> Call this subroutine to avoid averaging any offered fields.
1905 subroutine disable_averaging(diag_cs)
1906  type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
1907 
1908  diag_cs%time_int = 0.0
1909  diag_cs%ave_enabled = .false.
1910 
1911 end subroutine disable_averaging
1912 
1913 !> Call this subroutine to determine whether the averaging is
1914 !! currently enabled. .true. is returned if it is.
1915 function query_averaging_enabled(diag_cs, time_int, time_end)
1916  type(diag_ctrl), intent(in) :: diag_cs !< Structure used to regulate diagnostic output
1917  real, optional, intent(out) :: time_int !< Current setting of diag%time_int [s]
1918  type(time_type), optional, intent(out) :: time_end !< Current setting of diag%time_end
1919  logical :: query_averaging_enabled
1920 
1921  if (present(time_int)) time_int = diag_cs%time_int
1922  if (present(time_end)) time_end = diag_cs%time_end
1923  query_averaging_enabled = diag_cs%ave_enabled
1924 end function query_averaging_enabled
1925 
1926 !> This function returns the valid end time for use with diagnostics that are
1927 !! handled outside of the MOM6 diagnostics infrastructure.
1928 function get_diag_time_end(diag_cs)
1929  type(diag_ctrl), intent(in) :: diag_cs !< Structure used to regulate diagnostic output
1930  type(time_type) :: get_diag_time_end
1931  ! This function returns the valid end time for diagnostics that are handled
1932  ! outside of the MOM6 infrastructure, such as via the generic tracer code.
1933 
1934  get_diag_time_end = diag_cs%time_end
1935 end function get_diag_time_end
1936 
1937 !> Returns the "diag_mediator" handle for a group (native, CMOR, z-coord, ...) of diagnostics
1938 !! derived from one field.
1939 integer function register_diag_field(module_name, field_name, axes_in, init_time, &
1940  long_name, units, missing_value, range, mask_variant, standard_name, &
1941  verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, &
1942  cmor_long_name, cmor_units, cmor_standard_name, cell_methods, &
1943  x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive)
1944  character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
1945  !! or "ice_shelf_model"
1946  character(len=*), intent(in) :: field_name !< Name of the diagnostic field
1947  type(axes_grp), target, intent(in) :: axes_in !< Container w/ up to 3 integer handles that
1948  !! indicates axes for this field
1949  type(time_type), intent(in) :: init_time !< Time at which a field is first available?
1950  character(len=*), optional, intent(in) :: long_name !< Long name of a field.
1951  character(len=*), optional, intent(in) :: units !< Units of a field.
1952  character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
1953  real, optional, intent(in) :: missing_value !< A value that indicates missing values.
1954  real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
1955  logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with
1956  !! post_data calls (not used in MOM?)
1957  logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?)
1958  logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?)
1959  character(len=*), optional, intent(out):: err_msg !< String into which an error message might be
1960  !! placed (not used in MOM?)
1961  character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not
1962  !! be interpolated as a scalar
1963  integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?)
1964  character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
1965  character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
1966  character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
1967  character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
1968  character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to
1969  !! have no attribute. If present, this overrides the
1970  !! default constructed from the default for
1971  !! each individual axis direction.
1972  character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction.
1973  !! Use '' have no method.
1974  character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction.
1975  !! Use '' have no method.
1976  character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction.
1977  !! Use '' have no method.
1978  real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file
1979  logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically
1980  !! integrated). Default/absent for intensive.
1981  ! Local variables
1982  real :: mom_missing_value
1983  type(diag_ctrl), pointer :: diag_cs => null()
1984  type(axes_grp), pointer :: remap_axes => null()
1985  type(axes_grp), pointer :: axes => null()
1986  integer :: dm_id, i, dl
1987  character(len=256) :: new_module_name
1988  logical :: active
1989 
1990  axes => axes_in
1991  mom_missing_value = axes%diag_cs%missing_value
1992  if (present(missing_value)) mom_missing_value = missing_value
1993 
1994  diag_cs => axes%diag_cs
1995  dm_id = -1
1996 
1997  if (axes_in%id == diag_cs%axesTL%id) then
1998  axes => diag_cs%axesTL
1999  elseif (axes_in%id == diag_cs%axesBL%id) then
2000  axes => diag_cs%axesBL
2001  elseif (axes_in%id == diag_cs%axesCuL%id ) then
2002  axes => diag_cs%axesCuL
2003  elseif (axes_in%id == diag_cs%axesCvL%id) then
2004  axes => diag_cs%axesCvL
2005  elseif (axes_in%id == diag_cs%axesTi%id) then
2006  axes => diag_cs%axesTi
2007  elseif (axes_in%id == diag_cs%axesBi%id) then
2008  axes => diag_cs%axesBi
2009  elseif (axes_in%id == diag_cs%axesCui%id ) then
2010  axes => diag_cs%axesCui
2011  elseif (axes_in%id == diag_cs%axesCvi%id) then
2012  axes => diag_cs%axesCvi
2013  endif
2014 
2015  ! Register the native diagnostic
2016  active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, &
2017  init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2018  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2019  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2020  interp_method=interp_method, tile_count=tile_count, &
2021  cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2022  cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2023  cell_methods=cell_methods, x_cell_method=x_cell_method, &
2024  y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2025  conversion=conversion, v_extensive=v_extensive)
2026 
2027  ! For each diagnostic coordinate register the diagnostic again under a different module name
2028  do i=1,diag_cs%num_diag_coords
2029  new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)
2030 
2031  ! Register diagnostics remapped to z vertical coordinate
2032  if (axes_in%rank == 3) then
2033  remap_axes => null()
2034  if ((axes_in%id == diag_cs%axesTL%id)) then
2035  remap_axes => diag_cs%remap_axesTL(i)
2036  elseif (axes_in%id == diag_cs%axesBL%id) then
2037  remap_axes => diag_cs%remap_axesBL(i)
2038  elseif (axes_in%id == diag_cs%axesCuL%id ) then
2039  remap_axes => diag_cs%remap_axesCuL(i)
2040  elseif (axes_in%id == diag_cs%axesCvL%id) then
2041  remap_axes => diag_cs%remap_axesCvL(i)
2042  elseif (axes_in%id == diag_cs%axesTi%id) then
2043  remap_axes => diag_cs%remap_axesTi(i)
2044  elseif (axes_in%id == diag_cs%axesBi%id) then
2045  remap_axes => diag_cs%remap_axesBi(i)
2046  elseif (axes_in%id == diag_cs%axesCui%id ) then
2047  remap_axes => diag_cs%remap_axesCui(i)
2048  elseif (axes_in%id == diag_cs%axesCvi%id) then
2049  remap_axes => diag_cs%remap_axesCvi(i)
2050  endif
2051  ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will
2052  ! always exist but in the mean-time we have to do this check:
2053  ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set')
2054  if (associated(remap_axes)) then
2055  if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating) then
2056  active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, &
2057  init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2058  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2059  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2060  interp_method=interp_method, tile_count=tile_count, &
2061  cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2062  cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2063  cell_methods=cell_methods, x_cell_method=x_cell_method, &
2064  y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2065  conversion=conversion, v_extensive=v_extensive)
2066  if (active) then
2067  call diag_remap_set_active(diag_cs%diag_remap_cs(i))
2068  endif
2069  endif ! remap_axes%needs_remapping
2070  endif ! associated(remap_axes)
2071  endif ! axes%rank == 3
2072  enddo ! i
2073 
2074  !Register downsampled diagnostics
2075  do dl=2,max_dsamp_lev
2076  ! Do not attempt to checksum the downsampled diagnostics
2077  if (diag_cs%diag_as_chksum) cycle
2078 
2079  new_module_name = trim(module_name)//'_d2'
2080 
2081  if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then
2082  axes => null()
2083  if (axes_in%id == diag_cs%axesTL%id) then
2084  axes => diag_cs%dsamp(dl)%axesTL
2085  elseif (axes_in%id == diag_cs%axesBL%id) then
2086  axes => diag_cs%dsamp(dl)%axesBL
2087  elseif (axes_in%id == diag_cs%axesCuL%id ) then
2088  axes => diag_cs%dsamp(dl)%axesCuL
2089  elseif (axes_in%id == diag_cs%axesCvL%id) then
2090  axes => diag_cs%dsamp(dl)%axesCvL
2091  elseif (axes_in%id == diag_cs%axesTi%id) then
2092  axes => diag_cs%dsamp(dl)%axesTi
2093  elseif (axes_in%id == diag_cs%axesBi%id) then
2094  axes => diag_cs%dsamp(dl)%axesBi
2095  elseif (axes_in%id == diag_cs%axesCui%id ) then
2096  axes => diag_cs%dsamp(dl)%axesCui
2097  elseif (axes_in%id == diag_cs%axesCvi%id) then
2098  axes => diag_cs%dsamp(dl)%axesCvi
2099  elseif (axes_in%id == diag_cs%axesT1%id) then
2100  axes => diag_cs%dsamp(dl)%axesT1
2101  elseif (axes_in%id == diag_cs%axesB1%id) then
2102  axes => diag_cs%dsamp(dl)%axesB1
2103  elseif (axes_in%id == diag_cs%axesCu1%id ) then
2104  axes => diag_cs%dsamp(dl)%axesCu1
2105  elseif (axes_in%id == diag_cs%axesCv1%id) then
2106  axes => diag_cs%dsamp(dl)%axesCv1
2107  else
2108  !Niki: Should we worry about these, e.g., diag_to_Z_CS?
2109  call mom_error(warning,"register_diag_field: Could not find a proper axes for " &
2110  //trim( new_module_name)//"-"//trim(field_name))
2111  endif
2112  endif
2113  ! Register the native diagnostic
2114  if (associated(axes)) then
2115  active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes, &
2116  init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2117  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2118  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2119  interp_method=interp_method, tile_count=tile_count, &
2120  cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2121  cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2122  cell_methods=cell_methods, x_cell_method=x_cell_method, &
2123  y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2124  conversion=conversion, v_extensive=v_extensive)
2125  endif
2126 
2127  ! For each diagnostic coordinate register the diagnostic again under a different module name
2128  do i=1,diag_cs%num_diag_coords
2129  new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)//'_d2'
2130 
2131  ! Register diagnostics remapped to z vertical coordinate
2132  if (axes_in%rank == 3) then
2133  remap_axes => null()
2134  if ((axes_in%id == diag_cs%axesTL%id)) then
2135  remap_axes => diag_cs%dsamp(dl)%remap_axesTL(i)
2136  elseif (axes_in%id == diag_cs%axesBL%id) then
2137  remap_axes => diag_cs%dsamp(dl)%remap_axesBL(i)
2138  elseif (axes_in%id == diag_cs%axesCuL%id ) then
2139  remap_axes => diag_cs%dsamp(dl)%remap_axesCuL(i)
2140  elseif (axes_in%id == diag_cs%axesCvL%id) then
2141  remap_axes => diag_cs%dsamp(dl)%remap_axesCvL(i)
2142  elseif (axes_in%id == diag_cs%axesTi%id) then
2143  remap_axes => diag_cs%dsamp(dl)%remap_axesTi(i)
2144  elseif (axes_in%id == diag_cs%axesBi%id) then
2145  remap_axes => diag_cs%dsamp(dl)%remap_axesBi(i)
2146  elseif (axes_in%id == diag_cs%axesCui%id ) then
2147  remap_axes => diag_cs%dsamp(dl)%remap_axesCui(i)
2148  elseif (axes_in%id == diag_cs%axesCvi%id) then
2149  remap_axes => diag_cs%dsamp(dl)%remap_axesCvi(i)
2150  endif
2151 
2152  ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will
2153  ! always exist but in the mean-time we have to do this check:
2154  ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set')
2155  if (associated(remap_axes)) then
2156  if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating) then
2157  active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, &
2158  init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2159  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2160  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2161  interp_method=interp_method, tile_count=tile_count, &
2162  cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2163  cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2164  cell_methods=cell_methods, x_cell_method=x_cell_method, &
2165  y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2166  conversion=conversion, v_extensive=v_extensive)
2167  if (active) then
2168  call diag_remap_set_active(diag_cs%diag_remap_cs(i))
2169  endif
2170  endif ! remap_axes%needs_remapping
2171  endif ! associated(remap_axes)
2172  endif ! axes%rank == 3
2173  enddo ! i
2174  enddo
2175 
2176  register_diag_field = dm_id
2177 
2178 end function register_diag_field
2179 
2180 !> Returns True if either the native or CMOr version of the diagnostic were registered. Updates 'dm_id'
2181 !! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field.
2182 logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, &
2183  long_name, units, missing_value, range, mask_variant, standard_name, &
2184  verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, &
2185  cmor_long_name, cmor_units, cmor_standard_name, cell_methods, &
2186  x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive)
2187  integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group
2188  character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model"
2189  character(len=*), intent(in) :: field_name !< Name of the diagnostic field
2190  type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes
2191  !! for this field
2192  type(time_type), intent(in) :: init_time !< Time at which a field is first available?
2193  character(len=*), optional, intent(in) :: long_name !< Long name of a field.
2194  character(len=*), optional, intent(in) :: units !< Units of a field.
2195  character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
2196  real, optional, intent(in) :: missing_value !< A value that indicates missing values.
2197  real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
2198  logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided
2199  !! with post_data calls (not used in MOM?)
2200  logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?)
2201  logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?)
2202  character(len=*), optional, intent(out):: err_msg !< String into which an error message might be
2203  !! placed (not used in MOM?)
2204  character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should
2205  !! not be interpolated as a scalar
2206  integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?)
2207  character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
2208  character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
2209  character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
2210  character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
2211  character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute.
2212  !! Use '' to have no attribute. If present, this
2213  !! overrides the default constructed from the default
2214  !! for each individual axis direction.
2215  character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction.
2216  !! Use '' have no method.
2217  character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction.
2218  !! Use '' have no method.
2219  character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction.
2220  !! Use '' have no method.
2221  real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file
2222  logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically
2223  !! integrated). Default/absent for intensive.
2224  ! Local variables
2225  real :: mom_missing_value
2226  type(diag_ctrl), pointer :: diag_cs => null()
2227  type(diag_type), pointer :: this_diag => null()
2228  integer :: fms_id, fms_xyave_id
2229  character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg
2230 
2231  mom_missing_value = axes%diag_cs%missing_value
2232  if (present(missing_value)) mom_missing_value = missing_value
2233 
2234  register_diag_field_expand_cmor = .false.
2235  diag_cs => axes%diag_cs
2236 
2237  ! Set up the 'primary' diagnostic, first get an underlying FMS id
2238  fms_id = register_diag_field_expand_axes(module_name, field_name, axes, init_time, &
2239  long_name=long_name, units=units, missing_value=mom_missing_value, &
2240  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2241  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2242  interp_method=interp_method, tile_count=tile_count)
2243  if (.not. diag_cs%diag_as_chksum) &
2244  call attach_cell_methods(fms_id, axes, cm_string, cell_methods, &
2245  x_cell_method, y_cell_method, v_cell_method, &
2246  v_extensive=v_extensive)
2247  if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0) then
2248  msg = ''
2249  if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'"'
2250  call log_available_diag(fms_id>0, module_name, field_name, cm_string, &
2251  msg, diag_cs, long_name, units, standard_name)
2252  endif
2253  ! Associated horizontally area-averaged diagnostic
2254  fms_xyave_id = diag_field_not_found
2255  if (associated(axes%xyave_axes)) then
2256  fms_xyave_id = register_diag_field_expand_axes(module_name, trim(field_name)//'_xyave', &
2257  axes%xyave_axes, init_time, &
2258  long_name=long_name, units=units, missing_value=mom_missing_value, &
2259  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2260  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2261  interp_method=interp_method, tile_count=tile_count)
2262  if (.not. diag_cs%diag_as_chksum) &
2263  call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, &
2264  cell_methods, v_cell_method, v_extensive=v_extensive)
2265  if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0) then
2266  msg = ''
2267  if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'_xyave"'
2268  call log_available_diag(fms_xyave_id>0, module_name, trim(field_name)//'_xyave', cm_string, &
2269  msg, diag_cs, long_name, units, standard_name)
2270  endif
2271  endif
2272  this_diag => null()
2273  if (fms_id /= diag_field_not_found .or. fms_xyave_id /= diag_field_not_found) then
2274  call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
2275  this_diag%fms_xyave_diag_id = fms_xyave_id
2276  !Encode and save the cell methods for this diag
2277  call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
2278  if (present(v_extensive)) this_diag%v_extensive = v_extensive
2279  if (present(conversion)) this_diag%conversion_factor = conversion
2280  register_diag_field_expand_cmor = .true.
2281  endif
2282 
2283  ! For the CMOR variation of the above diagnostic
2284  if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then
2285  ! Fallback values for strings set to "NULL"
2286  posted_cmor_units = "not provided" !
2287  posted_cmor_standard_name = "not provided" ! Values might be able to be replaced with a CS%missing field?
2288  posted_cmor_long_name = "not provided" !
2289 
2290  ! If attributes are present for MOM variable names, use them first for the register_diag_field
2291  ! call for CMOR verison of the variable
2292  if (present(units)) posted_cmor_units = units
2293  if (present(standard_name)) posted_cmor_standard_name = standard_name
2294  if (present(long_name)) posted_cmor_long_name = long_name
2295 
2296  ! If specified in the call to register_diag_field, override attributes with the CMOR versions
2297  if (present(cmor_units)) posted_cmor_units = cmor_units
2298  if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
2299  if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
2300 
2301  fms_id = register_diag_field_expand_axes(module_name, cmor_field_name, axes, init_time, &
2302  long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2303  missing_value=mom_missing_value, range=range, mask_variant=mask_variant, &
2304  standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, &
2305  err_msg=err_msg, interp_method=interp_method, tile_count=tile_count)
2306  call attach_cell_methods(fms_id, axes, cm_string, &
2307  cell_methods, x_cell_method, y_cell_method, v_cell_method, &
2308  v_extensive=v_extensive)
2309  if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0) then
2310  msg = 'native name is "'//trim(field_name)//'"'
2311  call log_available_diag(fms_id>0, module_name, cmor_field_name, cm_string, &
2312  msg, diag_cs, posted_cmor_long_name, posted_cmor_units, &
2313  posted_cmor_standard_name)
2314  endif
2315  ! Associated horizontally area-averaged diagnostic
2316  fms_xyave_id = diag_field_not_found
2317  if (associated(axes%xyave_axes)) then
2318  fms_xyave_id = register_diag_field_expand_axes(module_name, trim(cmor_field_name)//'_xyave', &
2319  axes%xyave_axes, init_time, &
2320  long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2321  missing_value=mom_missing_value, range=range, mask_variant=mask_variant, &
2322  standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, &
2323  err_msg=err_msg, interp_method=interp_method, tile_count=tile_count)
2324  call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, &
2325  cell_methods, v_cell_method, v_extensive=v_extensive)
2326  if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0) then
2327  msg = 'native name is "'//trim(field_name)//'_xyave"'
2328  call log_available_diag(fms_xyave_id>0, module_name, trim(cmor_field_name)//'_xyave', &
2329  cm_string, msg, diag_cs, posted_cmor_long_name, posted_cmor_units, &
2330  posted_cmor_standard_name)
2331  endif
2332  endif
2333  this_diag => null()
2334  if (fms_id /= diag_field_not_found .or. fms_xyave_id /= diag_field_not_found) then
2335  call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
2336  this_diag%fms_xyave_diag_id = fms_xyave_id
2337  !Encode and save the cell methods for this diag
2338  call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
2339  if (present(v_extensive)) this_diag%v_extensive = v_extensive
2340  if (present(conversion)) this_diag%conversion_factor = conversion
2341  register_diag_field_expand_cmor = .true.
2342  endif
2343  endif
2344 
2345 end function register_diag_field_expand_cmor
2346 
2347 !> Returns an FMS id from register_diag_field_fms (the diag_manager routine) after expanding axes
2348 !! (axes-group) into handles and conditionally adding an FMS area_id for cell_measures.
2349 integer function register_diag_field_expand_axes(module_name, field_name, axes, init_time, &
2350  long_name, units, missing_value, range, mask_variant, standard_name, &
2351  verbose, do_not_log, err_msg, interp_method, tile_count)
2352  character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
2353  !! or "ice_shelf_model"
2354  character(len=*), intent(in) :: field_name !< Name of the diagnostic field
2355  type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates
2356  !! axes for this field
2357  type(time_type), intent(in) :: init_time !< Time at which a field is first available?
2358  character(len=*), optional, intent(in) :: long_name !< Long name of a field.
2359  character(len=*), optional, intent(in) :: units !< Units of a field.
2360  character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
2361  real, optional, intent(in) :: missing_value !< A value that indicates missing values.
2362  real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
2363  logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided
2364  !! with post_data calls (not used in MOM?)
2365  logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?)
2366  logical, optional, intent(in) :: do_not_log !< If true, do not log something
2367  !! (not used in MOM?)
2368  character(len=*), optional, intent(out):: err_msg !< String into which an error message might be
2369  !! placed (not used in MOM?)
2370  character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should
2371  !! not be interpolated as a scalar
2372  integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?)
2373  ! Local variables
2374  integer :: fms_id, area_id, volume_id
2375 
2376  ! This gets the cell area associated with the grid location of this variable
2377  area_id = axes%id_area
2378  volume_id = axes%id_volume
2379 
2380  ! Get the FMS diagnostic id
2381  if (axes%diag_cs%diag_as_chksum) then
2382  fms_id = axes%diag_cs%num_chksum_diags + 1
2383  axes%diag_cs%num_chksum_diags = fms_id
2384  else if (present(interp_method) .or. axes%is_h_point) then
2385  ! If interp_method is provided we must use it
2386  if (area_id>0) then
2387  if (volume_id>0) then
2388  fms_id = register_diag_field_fms(module_name, field_name, axes%handles, &
2389  init_time, long_name=long_name, units=units, missing_value=missing_value, &
2390  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2391  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2392  interp_method=interp_method, tile_count=tile_count, area=area_id, volume=volume_id)
2393  else
2394  fms_id = register_diag_field_fms(module_name, field_name, axes%handles, &
2395  init_time, long_name=long_name, units=units, missing_value=missing_value, &
2396  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2397  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2398  interp_method=interp_method, tile_count=tile_count, area=area_id)
2399  endif
2400  else
2401  if (volume_id>0) then
2402  fms_id = register_diag_field_fms(module_name, field_name, axes%handles, &
2403  init_time, long_name=long_name, units=units, missing_value=missing_value, &
2404  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2405  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2406  interp_method=interp_method, tile_count=tile_count, volume=volume_id)
2407  else
2408  fms_id = register_diag_field_fms(module_name, field_name, axes%handles, &
2409  init_time, long_name=long_name, units=units, missing_value=missing_value, &
2410  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2411  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2412  interp_method=interp_method, tile_count=tile_count)
2413  endif
2414  endif
2415  else
2416  ! If interp_method is not provided and the field is not at an h-point then interp_method='none'
2417  if (area_id>0) then
2418  if (volume_id>0) then
2419  fms_id = register_diag_field_fms(module_name, field_name, axes%handles, &
2420  init_time, long_name=long_name, units=units, missing_value=missing_value, &
2421  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2422  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2423  interp_method='none', tile_count=tile_count, area=area_id, volume=volume_id)
2424  else
2425  fms_id = register_diag_field_fms(module_name, field_name, axes%handles, &
2426  init_time, long_name=long_name, units=units, missing_value=missing_value, &
2427  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2428  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2429  interp_method='none', tile_count=tile_count, area=area_id)
2430  endif
2431  else
2432  if (volume_id>0) then
2433  fms_id = register_diag_field_fms(module_name, field_name, axes%handles, &
2434  init_time, long_name=long_name, units=units, missing_value=missing_value, &
2435  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2436  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2437  interp_method='none', tile_count=tile_count, volume=volume_id)
2438  else
2439  fms_id = register_diag_field_fms(module_name, field_name, axes%handles, &
2440  init_time, long_name=long_name, units=units, missing_value=missing_value, &
2441  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2442  verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2443  interp_method='none', tile_count=tile_count)
2444  endif
2445  endif
2446  endif
2447 
2448  register_diag_field_expand_axes = fms_id
2449 
2450 end function register_diag_field_expand_axes
2451 
2452 !> Create a diagnostic type and attached to list
2453 subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
2454  type(diag_ctrl), pointer :: diag_cs !< Diagnostics mediator control structure
2455  integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group
2456  integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic
2457  type(diag_type), pointer :: this_diag !< This diagnostic
2458  type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that
2459  !! indicates axes for this field
2460  character(len=*), intent(in) :: module_name !< Name of this module, usually
2461  !! "ocean_model" or "ice_shelf_model"
2462  character(len=*), intent(in) :: field_name !< Name of diagnostic
2463  character(len=*), intent(in) :: msg !< Message for errors
2464 
2465  ! If the diagnostic is needed obtain a diag_mediator ID (if needed)
2466  if (dm_id == -1) dm_id = get_new_diag_id(diag_cs)
2467  ! Create a new diag_type to store links in
2468  call alloc_diag_with_id(dm_id, diag_cs, this_diag)
2469  call assert(associated(this_diag), trim(msg)//': diag_type allocation failed')
2470  ! Record FMS id, masks and conversion factor, in diag_type
2471  this_diag%fms_diag_id = fms_id
2472  this_diag%debug_str = trim(module_name)//"-"//trim(field_name)
2473  this_diag%axes => axes
2474 
2475 end subroutine add_diag_to_list
2476 
2477 !> Adds the encoded "cell_methods" for a diagnostics as a diag% property
2478 !! This allows access to the cell_method for a given diagnostics at the time of sending
2479 subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
2480  type(diag_type), pointer :: diag !< This diagnostic
2481  type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates
2482  !! axes for this field
2483  character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction.
2484  !! Use '' have no method.
2485  character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction.
2486  !! Use '' have no method.
2487  character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction.
2488  !! Use '' have no method.
2489  logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields
2490  !! (vertically integrated). Default/absent for intensive.
2491  integer :: xyz_method
2492  character(len=9) :: mstr
2493 
2494  !This is a simple way to encode the cell method information made from 3 strings
2495  !(x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz
2496  !x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean'
2497  !We can encode these with setting 1 for 'point', 2 for 'sum, 3 for 'mean' in
2498  !the 100s position for x, 10s position for y, 1s position for z
2499  !E.g., x:sum,y:point,z:mean is 213
2500 
2501  xyz_method = 111
2502 
2503  mstr = diag%axes%v_cell_method
2504  if (present(v_extensive)) then
2505  if (present(v_cell_method)) call mom_error(fatal, "attach_cell_methods: " // &
2506  'Vertical cell method was specified along with the vertically extensive flag.')
2507  if(v_extensive) then
2508  mstr='sum'
2509  else
2510  mstr='mean'
2511  endif
2512  elseif (present(v_cell_method)) then
2513  mstr = v_cell_method
2514  endif
2515  if (trim(mstr)=='sum') then
2516  xyz_method = xyz_method + 1
2517  elseif (trim(mstr)=='mean') then
2518  xyz_method = xyz_method + 2
2519  endif
2520 
2521  mstr = diag%axes%y_cell_method
2522  if (present(y_cell_method)) mstr = y_cell_method
2523  if (trim(mstr)=='sum') then
2524  xyz_method = xyz_method + 10
2525  elseif (trim(mstr)=='mean') then
2526  xyz_method = xyz_method + 20
2527  endif
2528 
2529  mstr = diag%axes%x_cell_method
2530  if (present(x_cell_method)) mstr = x_cell_method
2531  if (trim(mstr)=='sum') then
2532  xyz_method = xyz_method + 100
2533  elseif (trim(mstr)=='mean') then
2534  xyz_method = xyz_method + 200
2535  endif
2536 
2537  diag%xyz_method = xyz_method
2538 end subroutine add_xyz_method
2539 
2540 !> Attaches "cell_methods" attribute to a variable based on defaults for axes_grp or optional arguments.
2541 subroutine attach_cell_methods(id, axes, ostring, cell_methods, &
2542  x_cell_method, y_cell_method, v_cell_method, v_extensive)
2543  integer, intent(in) :: id !< Handle to diagnostic
2544  type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates
2545  !! axes for this field
2546  character(len=*), intent(out) :: ostring !< The cell_methods strings that would appear in the file
2547  character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute.
2548  !! Use '' to have no attribute. If present, this
2549  !! overrides the default constructed from the default
2550  !! for each individual axis direction.
2551  character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction.
2552  !! Use '' have no method.
2553  character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction.
2554  !! Use '' have no method.
2555  character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction.
2556  !! Use '' have no method.
2557  logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields
2558  !! (vertically integrated). Default/absent for intensive.
2559  ! Local variables
2560  character(len=9) :: axis_name
2561  logical :: x_mean, y_mean, x_sum, y_sum
2562 
2563  x_mean = .false.
2564  y_mean = .false.
2565  x_sum = .false.
2566  y_sum = .false.
2567 
2568  ostring = ''
2569  if (present(cell_methods)) then
2570  if (present(x_cell_method) .or. present(y_cell_method) .or. present(v_cell_method) &
2571  .or. present(v_extensive)) then
2572  call mom_error(fatal, "attach_cell_methods: " // &
2573  'Individual direction cell method was specified along with a "cell_methods" string.')
2574  endif
2575  if (len(trim(cell_methods))>0) then
2576  call diag_field_add_attribute(id, 'cell_methods', trim(cell_methods))
2577  ostring = trim(cell_methods)
2578  endif
2579  else
2580  if (present(x_cell_method)) then
2581  if (len(trim(x_cell_method))>0) then
2582  call get_diag_axis_name(axes%handles(1), axis_name)
2583  call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method))
2584  ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(x_cell_method)
2585  if (trim(x_cell_method)=='mean') x_mean=.true.
2586  if (trim(x_cell_method)=='sum') x_sum=.true.
2587  endif
2588  else
2589  if (len(trim(axes%x_cell_method))>0) then
2590  call get_diag_axis_name(axes%handles(1), axis_name)
2591  call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%x_cell_method))
2592  ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%x_cell_method)
2593  if (trim(axes%x_cell_method)=='mean') x_mean=.true.
2594  if (trim(axes%x_cell_method)=='sum') x_sum=.true.
2595  endif
2596  endif
2597  if (present(y_cell_method)) then
2598  if (len(trim(y_cell_method))>0) then
2599  call get_diag_axis_name(axes%handles(2), axis_name)
2600  call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method))
2601  ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(y_cell_method)
2602  if (trim(y_cell_method)=='mean') y_mean=.true.
2603  if (trim(y_cell_method)=='sum') y_sum=.true.
2604  endif
2605  else
2606  if (len(trim(axes%y_cell_method))>0) then
2607  call get_diag_axis_name(axes%handles(2), axis_name)
2608  call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%y_cell_method))
2609  ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%y_cell_method)
2610  if (trim(axes%y_cell_method)=='mean') y_mean=.true.
2611  if (trim(axes%y_cell_method)=='sum') y_sum=.true.
2612  endif
2613  endif
2614  if (present(v_cell_method)) then
2615  if (present(v_extensive)) call mom_error(fatal, "attach_cell_methods: " // &
2616  'Vertical cell method was specified along with the vertically extensive flag.')
2617  if (len(trim(v_cell_method))>0) then
2618  if (axes%rank==1) then
2619  call get_diag_axis_name(axes%handles(1), axis_name)
2620  elseif (axes%rank==3) then
2621  call get_diag_axis_name(axes%handles(3), axis_name)
2622  endif
2623  call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(v_cell_method))
2624  ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(v_cell_method)
2625  endif
2626  elseif (present(v_extensive)) then
2627  if(v_extensive) then
2628  if (axes%rank==1) then
2629  call get_diag_axis_name(axes%handles(1), axis_name)
2630  elseif (axes%rank==3) then
2631  call get_diag_axis_name(axes%handles(3), axis_name)
2632  endif
2633  call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':sum')
2634  ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':sum'
2635  endif
2636  else
2637  if (len(trim(axes%v_cell_method))>0) then
2638  if (axes%rank==1) then
2639  call get_diag_axis_name(axes%handles(1), axis_name)
2640  elseif (axes%rank==3) then
2641  call get_diag_axis_name(axes%handles(3), axis_name)
2642  endif
2643  call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%v_cell_method))
2644  ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%v_cell_method)
2645  endif
2646  endif
2647  if (x_mean .and. y_mean) then
2648  call diag_field_add_attribute(id, 'cell_methods', 'area:mean')
2649  ostring = trim(adjustl(ostring))//' area:mean'
2650  elseif (x_sum .and. y_sum) then
2651  call diag_field_add_attribute(id, 'cell_methods', 'area:sum')
2652  ostring = trim(adjustl(ostring))//' area:sum'
2653  endif
2654  endif
2655  ostring = adjustl(ostring)
2656 end subroutine attach_cell_methods
2657 
2658 function register_scalar_field(module_name, field_name, init_time, diag_cs, &
2659  long_name, units, missing_value, range, standard_name, &
2660  do_not_log, err_msg, interp_method, cmor_field_name, &
2661  cmor_long_name, cmor_units, cmor_standard_name)
2662  integer :: register_scalar_field !< An integer handle for a diagnostic array.
2663  character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
2664  !! or "ice_shelf_model"
2665  character(len=*), intent(in) :: field_name !< Name of the diagnostic field
2666  type(time_type), intent(in) :: init_time !< Time at which a field is first available?
2667  type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
2668  character(len=*), optional, intent(in) :: long_name !< Long name of a field.
2669  character(len=*), optional, intent(in) :: units !< Units of a field.
2670  character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
2671  real, optional, intent(in) :: missing_value !< A value that indicates missing values.
2672  real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
2673  logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?)
2674  character(len=*), optional, intent(out):: err_msg !< String into which an error message might be
2675  !! placed (not used in MOM?)
2676  character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not
2677  !! be interpolated as a scalar
2678  character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
2679  character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
2680  character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
2681  character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
2682 
2683  ! Local variables
2684  real :: mom_missing_value
2685  integer :: dm_id, fms_id
2686  type(diag_type), pointer :: diag => null(), cmor_diag => null()
2687  character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
2688 
2689  mom_missing_value = diag_cs%missing_value
2690  if (present(missing_value)) mom_missing_value = missing_value
2691 
2692  dm_id = -1
2693  diag => null()
2694  cmor_diag => null()
2695 
2696  if (diag_cs%diag_as_chksum) then
2697  fms_id = diag_cs%num_chksum_diags + 1
2698  diag_cs%num_chksum_diags = fms_id
2699  else
2700  fms_id = register_diag_field_fms(module_name, field_name, init_time, &
2701  long_name=long_name, units=units, missing_value=mom_missing_value, &
2702  range=range, standard_name=standard_name, do_not_log=do_not_log, &
2703  err_msg=err_msg)
2704  endif
2705 
2706  if (fms_id /= diag_field_not_found) then
2707  dm_id = get_new_diag_id(diag_cs)
2708  call alloc_diag_with_id(dm_id, diag_cs, diag)
2709  call assert(associated(diag), 'register_scalar_field: diag allocation failed')
2710  diag%fms_diag_id = fms_id
2711  diag%debug_str = trim(module_name)//"-"//trim(field_name)
2712  endif
2713 
2714  if (present(cmor_field_name)) then
2715  ! Fallback values for strings set to "not provided"
2716  posted_cmor_units = "not provided"
2717  posted_cmor_standard_name = "not provided"
2718  posted_cmor_long_name = "not provided"
2719 
2720  ! If attributes are present for MOM variable names, use them first for the register_static_field
2721  ! call for CMOR verison of the variable
2722  if (present(units)) posted_cmor_units = units
2723  if (present(standard_name)) posted_cmor_standard_name = standard_name
2724  if (present(long_name)) posted_cmor_long_name = long_name
2725 
2726  ! If specified in the call to register_static_field, override attributes with the CMOR versions
2727  if (present(cmor_units)) posted_cmor_units = cmor_units
2728  if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
2729  if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
2730 
2731  fms_id = register_diag_field_fms(module_name, cmor_field_name, init_time, &
2732  long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2733  missing_value=mom_missing_value, range=range, &
2734  standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, err_msg=err_msg)
2735  if (fms_id /= diag_field_not_found) then
2736  if (dm_id == -1) then
2737  dm_id = get_new_diag_id(diag_cs)
2738  endif
2739  call alloc_diag_with_id(dm_id, diag_cs, cmor_diag)
2740  cmor_diag%fms_diag_id = fms_id
2741  cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name)
2742  endif
2743  endif
2744 
2745  ! Document diagnostics in list of available diagnostics
2746  if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0) then
2747  call log_available_diag(associated(diag), module_name, field_name, '', '', diag_cs, &
2748  long_name, units, standard_name)
2749  if (present(cmor_field_name)) then
2750  call log_available_diag(associated(cmor_diag), module_name, cmor_field_name, &
2751  '', '', diag_cs, posted_cmor_long_name, posted_cmor_units, &
2752  posted_cmor_standard_name)
2753  endif
2754  endif
2755 
2756  register_scalar_field = dm_id
2757 
2758 end function register_scalar_field
2759 
2760 !> Registers a static diagnostic, returning an integer handle
2761 function register_static_field(module_name, field_name, axes, &
2762  long_name, units, missing_value, range, mask_variant, standard_name, &
2763  do_not_log, interp_method, tile_count, &
2764  cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, &
2765  x_cell_method, y_cell_method, area_cell_method, conversion)
2766  integer :: register_static_field !< An integer handle for a diagnostic array.
2767  character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model"
2768  !! or "ice_shelf_model"
2769  character(len=*), intent(in) :: field_name !< Name of the diagnostic field
2770  type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that
2771  !! indicates axes for this field
2772  character(len=*), optional, intent(in) :: long_name !< Long name of a field.
2773  character(len=*), optional, intent(in) :: units !< Units of a field.
2774  character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field
2775  real, optional, intent(in) :: missing_value !< A value that indicates missing values.
2776  real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?)
2777  logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with
2778  !! post_data calls (not used in MOM?)
2779  logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?)
2780  character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not
2781  !! be interpolated as a scalar
2782  integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?)
2783  character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field
2784  character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field
2785  character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field
2786  character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field
2787  integer, optional, intent(in) :: area !< fms_id for area_t
2788  character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction.
2789  character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction.
2790  character(len=*), optional, intent(in) :: area_cell_method !< Specifies the cell method for area
2791  real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file
2792 
2793  ! Local variables
2794  real :: mom_missing_value
2795  type(diag_ctrl), pointer :: diag_cs => null()
2796  type(diag_type), pointer :: diag => null(), cmor_diag => null()
2797  integer :: dm_id, fms_id, cmor_id
2798  character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
2799  character(len=9) :: axis_name
2800 
2801  mom_missing_value = axes%diag_cs%missing_value
2802  if (present(missing_value)) mom_missing_value = missing_value
2803 
2804  diag_cs => axes%diag_cs
2805  dm_id = -1
2806  diag => null()
2807  cmor_diag => null()
2808 
2809  if (diag_cs%diag_as_chksum) then
2810  fms_id = diag_cs%num_chksum_diags + 1
2811  diag_cs%num_chksum_diags = fms_id
2812  else
2813  fms_id = register_static_field_fms(module_name, field_name, axes%handles, &
2814  long_name=long_name, units=units, missing_value=mom_missing_value, &
2815  range=range, mask_variant=mask_variant, standard_name=standard_name, &
2816  do_not_log=do_not_log, &
2817  interp_method=interp_method, tile_count=tile_count, area=area)
2818  endif
2819 
2820  if (fms_id /= diag_field_not_found) then
2821  dm_id = get_new_diag_id(diag_cs)
2822  call alloc_diag_with_id(dm_id, diag_cs, diag)
2823  call assert(associated(diag), 'register_static_field: diag allocation failed')
2824  diag%fms_diag_id = fms_id
2825  diag%debug_str = trim(module_name)//"-"//trim(field_name)
2826  if (present(conversion)) diag%conversion_factor = conversion
2827 
2828  if (diag_cs%diag_as_chksum) then
2829  diag%axes => axes
2830  else
2831  if (present(x_cell_method)) then
2832  call get_diag_axis_name(axes%handles(1), axis_name)
2833  call diag_field_add_attribute(fms_id, 'cell_methods', &
2834  trim(axis_name)//':'//trim(x_cell_method))
2835  endif
2836  if (present(y_cell_method)) then
2837  call get_diag_axis_name(axes%handles(2), axis_name)
2838  call diag_field_add_attribute(fms_id, 'cell_methods', &
2839  trim(axis_name)//':'//trim(y_cell_method))
2840  endif
2841  if (present(area_cell_method)) then
2842  call diag_field_add_attribute(fms_id, 'cell_methods', &
2843  'area:'//trim(area_cell_method))
2844  endif
2845  endif
2846  endif
2847 
2848  if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then
2849  ! Fallback values for strings set to "not provided"
2850  posted_cmor_units = "not provided"
2851  posted_cmor_standard_name = "not provided"
2852  posted_cmor_long_name = "not provided"
2853 
2854  ! If attributes are present for MOM variable names, use them first for the register_static_field
2855  ! call for CMOR verison of the variable
2856  if (present(units)) posted_cmor_units = units
2857  if (present(standard_name)) posted_cmor_standard_name = standard_name
2858  if (present(long_name)) posted_cmor_long_name = long_name
2859 
2860  ! If specified in the call to register_static_field, override attributes with the CMOR versions
2861  if (present(cmor_units)) posted_cmor_units = cmor_units
2862  if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
2863  if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
2864 
2865  fms_id = register_static_field_fms(module_name, cmor_field_name, &
2866  axes%handles, long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2867  missing_value=mom_missing_value, range=range, mask_variant=mask_variant, &
2868  standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, &
2869  interp_method=interp_method, tile_count=tile_count, area=area)
2870  if (fms_id /= diag_field_not_found) then
2871  if (dm_id == -1) then
2872  dm_id = get_new_diag_id(diag_cs)
2873  endif
2874  call alloc_diag_with_id(dm_id, diag_cs, cmor_diag)
2875  cmor_diag%fms_diag_id = fms_id
2876  cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name)
2877  if (present(conversion)) cmor_diag%conversion_factor = conversion
2878  if (present(x_cell_method)) then
2879  call get_diag_axis_name(axes%handles(1), axis_name)
2880  call diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method))
2881  endif
2882  if (present(y_cell_method)) then
2883  call get_diag_axis_name(axes%handles(2), axis_name)
2884  call diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method))
2885  endif
2886  if (present(area_cell_method)) then
2887  call diag_field_add_attribute(fms_id, 'cell_methods', 'area:'//trim(area_cell_method))
2888  endif
2889  endif
2890  endif
2891 
2892  ! Document diagnostics in list of available diagnostics
2893  if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0) then
2894  call log_available_diag(associated(diag), module_name, field_name, '', '', diag_cs, &
2895  long_name, units, standard_name)
2896  if (present(cmor_field_name)) then
2897  call log_available_diag(associated(cmor_diag), module_name, cmor_field_name, &
2898  '', '', diag_cs, posted_cmor_long_name, posted_cmor_units, &
2899  posted_cmor_standard_name)
2900  endif
2901  endif
2902 
2903  register_static_field = dm_id
2904 
2905 end function register_static_field
2906 
2907 !> Describe an option setting in the diagnostic files.
2908 subroutine describe_option(opt_name, value, diag_CS)
2909  character(len=*), intent(in) :: opt_name !< The name of the option
2910  character(len=*), intent(in) :: value !< A character string with the setting of the option.
2911  type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
2912 
2913  character(len=240) :: mesg
2914  integer :: len_ind
2915 
2916  len_ind = len_trim(value) ! Add error handling for long values?
2917 
2918  mesg = " ! "//trim(opt_name)//": "//trim(value)
2919  write(diag_cs%available_diag_doc_unit, '(a)') trim(mesg)
2920 end subroutine describe_option
2921 
2922 !> Registers a diagnostic using the information encapsulated in the vardesc
2923 !! type argument and returns an integer handle to this diagostic. That
2924 !! integer handle is negative if the diagnostic is unused.
2925 function ocean_register_diag(var_desc, G, diag_CS, day)
2926  integer :: ocean_register_diag !< An integer handle to this diagnostic.
2927  type(vardesc), intent(in) :: var_desc !< The vardesc type describing the diagnostic
2928  type(ocean_grid_type), intent(in) :: g !< The ocean's grid type
2929  type(diag_ctrl), intent(in), target :: diag_cs !< The diagnotic control structure
2930  type(time_type), intent(in) :: day !< The current model time
2931 
2932  character(len=64) :: var_name ! A variable's name.
2933  character(len=48) :: units ! A variable's units.
2934  character(len=240) :: longname ! A variable's longname.
2935  character(len=8) :: hor_grid, z_grid ! Variable grid info.
2936  type(axes_grp), pointer :: axes => null()
2937 
2938  call query_vardesc(var_desc, units=units, longname=longname, hor_grid=hor_grid, &
2939  z_grid=z_grid, caller="ocean_register_diag")
2940 
2941  ! Use the hor_grid and z_grid components of vardesc to determine the
2942  ! desired axes to register the diagnostic field for.
2943  select case (z_grid)
2944 
2945  case ("L")
2946  select case (hor_grid)
2947  case ("q")
2948  axes => diag_cs%axesBL
2949  case ("h")
2950  axes => diag_cs%axesTL
2951  case ("u")
2952  axes => diag_cs%axesCuL
2953  case ("v")
2954  axes => diag_cs%axesCvL
2955  case ("Bu")
2956  axes => diag_cs%axesBL
2957  case ("T")
2958  axes => diag_cs%axesTL
2959  case ("Cu")
2960  axes => diag_cs%axesCuL
2961  case ("Cv")
2962  axes => diag_cs%axesCvL
2963  case ("z")
2964  axes => diag_cs%axeszL
2965  case default
2966  call mom_error(fatal, "ocean_register_diag: " // &
2967  "unknown hor_grid component "//trim(hor_grid))
2968  end select
2969 
2970  case ("i")
2971  select case (hor_grid)
2972  case ("q")
2973  axes => diag_cs%axesBi
2974  case ("h")
2975  axes => diag_cs%axesTi
2976  case ("u")
2977  axes => diag_cs%axesCui
2978  case ("v")
2979  axes => diag_cs%axesCvi
2980  case ("Bu")
2981  axes => diag_cs%axesBi
2982  case ("T")
2983  axes => diag_cs%axesTi
2984  case ("Cu")
2985  axes => diag_cs%axesCui
2986  case ("Cv")
2987  axes => diag_cs%axesCvi
2988  case ("z")
2989  axes => diag_cs%axeszi
2990  case default
2991  call mom_error(fatal, "ocean_register_diag: " // &
2992  "unknown hor_grid component "//trim(hor_grid))
2993  end select
2994 
2995  case ("1")
2996  select case (hor_grid)
2997  case ("q")
2998  axes => diag_cs%axesB1
2999  case ("h")
3000  axes => diag_cs%axesT1
3001  case ("u")
3002  axes => diag_cs%axesCu1
3003  case ("v")
3004  axes => diag_cs%axesCv1
3005  case ("Bu")
3006  axes => diag_cs%axesB1
3007  case ("T")
3008  axes => diag_cs%axesT1
3009  case ("Cu")
3010  axes => diag_cs%axesCu1
3011  case ("Cv")
3012  axes => diag_cs%axesCv1
3013  case default
3014  call mom_error(fatal, "ocean_register_diag: " // &
3015  "unknown hor_grid component "//trim(hor_grid))
3016  end select
3017 
3018  case default
3019  call mom_error(fatal,&
3020  "ocean_register_diag: unknown z_grid component "//trim(z_grid))
3021  end select
3022 
3023  ocean_register_diag = register_diag_field("ocean_model", trim(var_name), &
3024  axes, day, trim(longname), trim(units), missing_value=-1.0e+34)
3025 
3026 end function ocean_register_diag
3027 
3028 subroutine diag_mediator_infrastructure_init(err_msg)
3029  ! This subroutine initializes the FMS diag_manager.
3030  character(len=*), optional, intent(out) :: err_msg !< An error message
3031 
3032  call diag_manager_init(err_msg=err_msg)
3033 end subroutine diag_mediator_infrastructure_init
3034 
3035 !> diag_mediator_init initializes the MOM diag_mediator and opens the available
3036 !! diagnostics file, if appropriate.
3037 subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir)
3038  type(ocean_grid_type), target, intent(inout) :: g !< The ocean grid type.
3039  type(verticalgrid_type), target, intent(in) :: gv !< The ocean vertical grid structure
3040  type(unit_scale_type), target, intent(in) :: us !< A dimensional unit scaling type
3041  integer, intent(in) :: nz !< The number of layers in the model's native grid.
3042  type(param_file_type), intent(in) :: param_file !< Parameter file structure
3043  type(diag_ctrl), intent(inout) :: diag_cs !< A pointer to a type with many variables
3044  !! used for diagnostics
3045  character(len=*), optional, intent(in) :: doc_file_dir !< A directory in which to create the
3046  !! file
3047 
3048  ! This subroutine initializes the diag_mediator and the diag_manager.
3049  ! The grid type should have its dimensions set by this point, but it
3050  ! is not necessary that the metrics and axis labels be set up yet.
3051 
3052  ! Local variables
3053  integer :: ios, i, new_unit
3054  logical :: opened, new_file
3055  logical :: answers_2018, default_2018_answers
3056  character(len=8) :: this_pe
3057  character(len=240) :: doc_file, doc_file_dflt, doc_path
3058  character(len=240), allocatable :: diag_coords(:)
3059  ! This include declares and sets the variable "version".
3060 # include "version_variable.h"
3061  character(len=40) :: mdl = "MOM_diag_mediator" ! This module's name.
3062  character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs
3063 
3064  id_clock_diag_mediator = cpu_clock_id('(Ocean diagnostics framework)', grain=clock_module)
3065  id_clock_diag_remap = cpu_clock_id('(Ocean diagnostics remapping)', grain=clock_routine)
3066  id_clock_diag_grid_updates = cpu_clock_id('(Ocean diagnostics grid updates)', grain=clock_routine)
3067 
3068  ! Allocate and initialize list of all diagnostics (and variants)
3069  allocate(diag_cs%diags(diag_alloc_chunk_size))
3070  diag_cs%next_free_diag_id = 1
3071  do i=1, diag_alloc_chunk_size
3072  call initialize_diag_type(diag_cs%diags(i))
3073  enddo
3074 
3075  ! Read all relevant parameters and write them to the model log.
3076  call log_version(param_file, mdl, version, "")
3077 
3078  call get_param(param_file, mdl, 'NUM_DIAG_COORDS', diag_cs%num_diag_coords, &
3079  'The number of diagnostic vertical coordinates to use. '//&
3080  'For each coordinate, an entry in DIAG_COORDS must be provided.', &
3081  default=1)
3082  call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, &
3083  "This sets the default value for the various _2018_ANSWERS parameters.", &
3084  default=.false.)
3085  call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, &
3086  "If true, use the order of arithmetic and expressions that recover the "//&
3087  "answers from the end of 2018. Otherwise, use updated and more robust "//&
3088  "forms of the same expressions.", default=default_2018_answers)
3089  call get_param(param_file, mdl, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, &
3090  'If true, use a grid index coordinate convention for diagnostic axes. ',&
3091  default=.false.)
3092 
3093  if (diag_cs%num_diag_coords>0) then
3094  allocate(diag_coords(diag_cs%num_diag_coords))
3095  if (diag_cs%num_diag_coords==1) then ! The default is to provide just one instance of Z*
3096  call get_param(param_file, mdl, 'DIAG_COORDS', diag_coords, &
3097  'A list of string tuples associating diag_table modules to '//&
3098  'a coordinate definition used for diagnostics. Each string '//&
3099  'is of the form "MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME".', &
3100  default='z Z ZSTAR')
3101  else ! If using more than 1 diagnostic coordinate, all must be explicitly defined
3102  call get_param(param_file, mdl, 'DIAG_COORDS', diag_coords, &
3103  'A list of string tuples associating diag_table modules to '//&
3104  'a coordinate definition used for diagnostics. Each string '//&
3105  'is of the form "MODULE_SUFFIX,PARAMETER_SUFFIX,COORDINATE_NAME".', &
3106  fail_if_missing=.true.)
3107  endif
3108  allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords))
3109  ! Initialize each diagnostic vertical coordinate
3110  do i=1, diag_cs%num_diag_coords
3111  call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answers_2018=answers_2018)
3112  enddo
3113  deallocate(diag_coords)
3114  endif
3115 
3116  call get_param(param_file, mdl, 'DIAG_MISVAL', diag_cs%missing_value, &
3117  'Set the default missing value to use for diagnostics.', &
3118  default=1.e20)
3119  call get_param(param_file, mdl, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, &
3120  'Instead of writing diagnostics to the diag manager, write '//&
3121  'a text file containing the checksum (bitcount) of the array.', &
3122  default=.false.)
3123 
3124  if (diag_cs%diag_as_chksum) &
3125  diag_cs%num_chksum_diags = 0
3126 
3127  ! Keep pointers grid, h, T, S needed diagnostic remapping
3128  diag_cs%G => g
3129  diag_cs%GV => gv
3130  diag_cs%US => us
3131  diag_cs%h => null()
3132  diag_cs%T => null()
3133  diag_cs%S => null()
3134  diag_cs%eqn_of_state => null()
3135 
3136  allocate(diag_cs%h_begin(g%isd:g%ied,g%jsd:g%jed,nz))
3137 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
3138  allocate(diag_cs%h_old(g%isd:g%ied,g%jsd:g%jed,nz))
3139  diag_cs%h_old(:,:,:) = 0.0
3140 #endif
3141 
3142  diag_cs%is = g%isc - (g%isd-1) ; diag_cs%ie = g%iec - (g%isd-1)
3143  diag_cs%js = g%jsc - (g%jsd-1) ; diag_cs%je = g%jec - (g%jsd-1)
3144  diag_cs%isd = g%isd ; diag_cs%ied = g%ied
3145  diag_cs%jsd = g%jsd ; diag_cs%jed = g%jed
3146 
3147  !Downsample indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array)
3148  diag_cs%dsamp(2)%isc = g%HId2%isc - (g%HId2%isd-1) ; diag_cs%dsamp(2)%iec = g%HId2%iec - (g%HId2%isd-1)
3149  diag_cs%dsamp(2)%jsc = g%HId2%jsc - (g%HId2%jsd-1) ; diag_cs%dsamp(2)%jec = g%HId2%jec - (g%HId2%jsd-1)
3150  diag_cs%dsamp(2)%isd = g%HId2%isd ; diag_cs%dsamp(2)%ied = g%HId2%ied
3151  diag_cs%dsamp(2)%jsd = g%HId2%jsd ; diag_cs%dsamp(2)%jed = g%HId2%jed
3152  diag_cs%dsamp(2)%isg = g%HId2%isg ; diag_cs%dsamp(2)%ieg = g%HId2%ieg
3153  diag_cs%dsamp(2)%jsg = g%HId2%jsg ; diag_cs%dsamp(2)%jeg = g%HId2%jeg
3154  diag_cs%dsamp(2)%isgB = g%HId2%isgB ; diag_cs%dsamp(2)%iegB = g%HId2%iegB
3155  diag_cs%dsamp(2)%jsgB = g%HId2%jsgB ; diag_cs%dsamp(2)%jegB = g%HId2%jegB
3156 
3157  ! Initialze available diagnostic log file
3158  if (is_root_pe() .and. (diag_cs%available_diag_doc_unit < 0)) then
3159  write(this_pe,'(i6.6)') pe_here()
3160  doc_file_dflt = "available_diags."//this_pe
3161  call get_param(param_file, mdl, "AVAILABLE_DIAGS_FILE", doc_file, &
3162  "A file into which to write a list of all available "//&
3163  "ocean diagnostics that can be included in a diag_table.", &
3164  default=doc_file_dflt, do_not_log=(diag_cs%available_diag_doc_unit/=-1))
3165  if (len_trim(doc_file) > 0) then
3166  new_file = .true. ; if (diag_cs%available_diag_doc_unit /= -1) new_file = .false.
3167  ! Find an unused unit number.
3168  do new_unit=512,42,-1
3169  inquire( new_unit, opened=opened)
3170  if (.not.opened) exit
3171  enddo
3172  if (opened) call mom_error(fatal, &
3173  "diag_mediator_init failed to find an unused unit number.")
3174 
3175  doc_path = doc_file
3176  if (present(doc_file_dir)) then ; if (len_trim(doc_file_dir) > 0) then
3177  doc_path = trim(slasher(doc_file_dir))//trim(doc_file)
3178  endif ; endif
3179 
3180  diag_cs%available_diag_doc_unit = new_unit
3181 
3182  if (new_file) then
3183  open(diag_cs%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
3184  action='WRITE', status='REPLACE', iostat=ios)
3185  else ! This file is being reopened, and should be appended.
3186  open(diag_cs%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
3187  action='WRITE', status='OLD', position='APPEND', iostat=ios)
3188  endif
3189  inquire(diag_cs%available_diag_doc_unit, opened=opened)
3190  if ((.not.opened) .or. (ios /= 0)) then
3191  call mom_error(fatal, "Failed to open available diags file "//trim(doc_path)//".")
3192  endif
3193  endif
3194  endif
3195 
3196  if (is_root_pe() .and. (diag_cs%chksum_iounit < 0) .and. diag_cs%diag_as_chksum) then
3197  !write(this_pe,'(i6.6)') PE_here()
3198  !doc_file_dflt = "chksum_diag."//this_pe
3199  doc_file_dflt = "chksum_diag"
3200  call get_param(param_file, mdl, "CHKSUM_DIAG_FILE", doc_file, &
3201  "A file into which to write all checksums of the "//&
3202  "diagnostics listed in the diag_table.", &
3203  default=doc_file_dflt, do_not_log=(diag_cs%chksum_iounit/=-1))
3204 
3205  call get_filename_appendix(filename_appendix)
3206  if (len_trim(filename_appendix) > 0) then
3207  doc_file = trim(doc_file) //'.'//trim(filename_appendix)
3208  endif
3209 #ifdef STATSLABEL
3210  doc_file = trim(doc_file)//"."//trim(adjustl(statslabel))
3211 #endif
3212 
3213  if (len_trim(doc_file) > 0) then
3214  new_file = .true. ; if (diag_cs%chksum_iounit /= -1) new_file = .false.
3215  ! Find an unused unit number.
3216  do new_unit=512,42,-1
3217  inquire( new_unit, opened=opened)
3218  if (.not.opened) exit
3219  enddo
3220  if (opened) call mom_error(fatal, &
3221  "diag_mediator_init failed to find an unused unit number.")
3222 
3223  doc_path = doc_file
3224  if (present(doc_file_dir)) then ; if (len_trim(doc_file_dir) > 0) then
3225  doc_path = trim(slasher(doc_file_dir))//trim(doc_file)
3226  endif ; endif
3227 
3228  diag_cs%chksum_iounit = new_unit
3229 
3230  if (new_file) then
3231  open(diag_cs%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
3232  action='WRITE', status='REPLACE', iostat=ios)
3233  else ! This file is being reopened, and should be appended.
3234  open(diag_cs%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', &
3235  action='WRITE', status='OLD', position='APPEND', iostat=ios)
3236  endif
3237  inquire(diag_cs%chksum_iounit, opened=opened)
3238  if ((.not.opened) .or. (ios /= 0)) then
3239  call mom_error(fatal, "Failed to open checksum diags file "//trim(doc_path)//".")
3240  endif
3241  endif
3242  endif
3243 
3244 end subroutine diag_mediator_init
3245 
3246 !> Set pointers to the default state fields used to remap diagnostics.
3247 subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs)
3248  real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array [H ~> m or kg m-2]
3249  real, dimension(:,:,:), target, intent(in ) :: t !< the model temperature array
3250  real, dimension(:,:,:), target, intent(in ) :: s !< the model salinity array
3251  type(eos_type), target, intent(in ) :: eqn_of_state !< Equation of state structure
3252  type(diag_ctrl), intent(inout) :: diag_cs !< diag mediator control structure
3253 
3254  ! Keep pointers to h, T, S needed for the diagnostic remapping
3255  diag_cs%h => h
3256  diag_cs%T => t
3257  diag_cs%S => s
3258  diag_cs%eqn_of_state => eqn_of_state
3259 
3260 end subroutine
3261 
3262 !> Build/update vertical grids for diagnostic remapping.
3263 !! \note The target grids need to be updated whenever sea surface
3264 !! height changes.
3265 subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensive, update_extensive )
3266  type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure
3267  real, target, optional, intent(in ) :: alt_h(:,:,:) !< Used if remapped grids should be something other than
3268  !! the current thicknesses [H ~> m or kg m-2]
3269  real, target, optional, intent(in ) :: alt_t(:,:,:) !< Used if remapped grids should be something other than
3270  !! the current temperatures
3271  real, target, optional, intent(in ) :: alt_s(:,:,:) !< Used if remapped grids should be something other than
3272  !! the current salinity
3273  logical, optional, intent(in ) :: update_intensive !< If true (default), update the grids used for
3274  !! intensive diagnostics
3275  logical, optional, intent(in ) :: update_extensive !< If true (not default), update the grids used for
3276  !! intensive diagnostics
3277  ! Local variables
3278  integer :: i
3279  real, dimension(:,:,:), pointer :: h_diag => null() ! The layer thickneses for diagnostics [H ~> m or kg m-2]
3280  real, dimension(:,:,:), pointer :: t_diag => null(), s_diag => null()
3281  logical :: update_intensive_local, update_extensive_local
3282 
3283  ! Set values based on optional input arguments
3284  if (present(alt_h)) then
3285  h_diag => alt_h
3286  else
3287  h_diag => diag_cs%h
3288  endif
3289 
3290  if (present(alt_t)) then
3291  t_diag => alt_t
3292  else
3293  t_diag => diag_cs%T
3294  endif
3295 
3296  if (present(alt_s)) then
3297  s_diag => alt_s
3298  else
3299  s_diag => diag_cs%S
3300  endif
3301 
3302  ! Defaults here are based on wanting to update intensive quantities frequently as soon as the model state changes.
3303  ! Conversely, for extensive quantities, in an effort to close budgets and to be consistent with the total time
3304  ! tendency, we construct the diagnostic grid at the beginning of the baroclinic timestep and remap all extensive
3305  ! quantities to the same grid
3306  update_intensive_local = .true.
3307  if (present(update_intensive)) update_intensive_local = update_intensive
3308  update_extensive_local = .false.
3309  if (present(update_extensive)) update_extensive_local = update_extensive
3310 
3311  if (id_clock_diag_grid_updates>0) call cpu_clock_begin(id_clock_diag_grid_updates)
3312 
3313  if (diag_cs%diag_grid_overridden) then
3314  call mom_error(fatal, "diag_update_remap_grids was called, but current grids in "// &
3315  "diagnostic structure have been overridden")
3316  endif
3317 
3318  if (update_intensive_local) then
3319  do i=1, diag_cs%num_diag_coords
3320  call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, t_diag, s_diag, &
3321  diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h)
3322  enddo
3323  endif
3324  if (update_extensive_local) then
3325  diag_cs%h_begin(:,:,:) = diag_cs%h(:,:,:)
3326  do i=1, diag_cs%num_diag_coords
3327  call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, t_diag, s_diag, &
3328  diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h_extensive)
3329  enddo
3330  endif
3331 
3332 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
3333  ! Keep a copy of H - used to check whether grids are up-to-date
3334  ! when doing remapping.
3335  diag_cs%h_old(:,:,:) = diag_cs%h(:,:,:)
3336 #endif
3337 
3338  if (id_clock_diag_grid_updates>0) call cpu_clock_end(id_clock_diag_grid_updates)
3339 
3340 end subroutine diag_update_remap_grids
3341 
3342 !> Sets up the 2d and 3d masks for native diagnostics
3343 subroutine diag_masks_set(G, nz, diag_cs)
3344  type(ocean_grid_type), target, intent(in) :: g !< The ocean grid type.
3345  integer, intent(in) :: nz !< The number of layers in the model's native grid.
3346  type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables
3347  !! used for diagnostics
3348  ! Local variables
3349  integer :: k
3350 
3351  ! 2d masks point to the model masks since they are identical
3352  diag_cs%mask2dT => g%mask2dT
3353  diag_cs%mask2dBu => g%mask2dBu
3354  diag_cs%mask2dCu => g%mask2dCu
3355  diag_cs%mask2dCv => g%mask2dCv
3356 
3357  ! 3d native masks are needed by diag_manager but the native variables
3358  ! can only be masked 2d - for ocean points, all layers exists.
3359  allocate(diag_cs%mask3dTL(g%isd:g%ied,g%jsd:g%jed,1:nz))
3360  allocate(diag_cs%mask3dBL(g%IsdB:g%IedB,g%JsdB:g%JedB,1:nz))
3361  allocate(diag_cs%mask3dCuL(g%IsdB:g%IedB,g%jsd:g%jed,1:nz))
3362  allocate(diag_cs%mask3dCvL(g%isd:g%ied,g%JsdB:g%JedB,1:nz))
3363  do k=1,nz
3364  diag_cs%mask3dTL(:,:,k) = diag_cs%mask2dT(:,:)
3365  diag_cs%mask3dBL(:,:,k) = diag_cs%mask2dBu(:,:)
3366  diag_cs%mask3dCuL(:,:,k) = diag_cs%mask2dCu(:,:)
3367  diag_cs%mask3dCvL(:,:,k) = diag_cs%mask2dCv(:,:)
3368  enddo
3369  allocate(diag_cs%mask3dTi(g%isd:g%ied,g%jsd:g%jed,1:nz+1))
3370  allocate(diag_cs%mask3dBi(g%IsdB:g%IedB,g%JsdB:g%JedB,1:nz+1))
3371  allocate(diag_cs%mask3dCui(g%IsdB:g%IedB,g%jsd:g%jed,1:nz+1))
3372  allocate(diag_cs%mask3dCvi(g%isd:g%ied,g%JsdB:g%JedB,1:nz+1))
3373  do k=1,nz+1
3374  diag_cs%mask3dTi(:,:,k) = diag_cs%mask2dT(:,:)
3375  diag_cs%mask3dBi(:,:,k) = diag_cs%mask2dBu(:,:)
3376  diag_cs%mask3dCui(:,:,k) = diag_cs%mask2dCu(:,:)
3377  diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:)
3378  enddo
3379 
3380  !Allocate and initialize the downsampled masks
3381  call downsample_diag_masks_set(g, nz, diag_cs)
3382 
3383 end subroutine diag_masks_set
3384 
3385 subroutine diag_mediator_close_registration(diag_CS)
3386  type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
3387 
3388  integer :: i
3389 
3390  if (diag_cs%available_diag_doc_unit > -1) then
3391  close(diag_cs%available_diag_doc_unit) ; diag_cs%available_diag_doc_unit = -2
3392  endif
3393 
3394  do i=1, diag_cs%num_diag_coords
3395  call diag_remap_diag_registration_closed(diag_cs%diag_remap_cs(i))
3396  enddo
3397 
3398 end subroutine diag_mediator_close_registration
3399 
3400 subroutine diag_mediator_end(time, diag_CS, end_diag_manager)
3401  type(time_type), intent(in) :: time !< The current model time
3402  type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output
3403  logical, optional, intent(in) :: end_diag_manager !< If true, call diag_manager_end()
3404 
3405  ! Local variables
3406  integer :: i
3407 
3408  if (diag_cs%available_diag_doc_unit > -1) then
3409  close(diag_cs%available_diag_doc_unit) ; diag_cs%available_diag_doc_unit = -3
3410  endif
3411  if (diag_cs%chksum_iounit > -1) then
3412  close(diag_cs%chksum_iounit) ; diag_cs%chksum_iounit = -3
3413  endif
3414 
3415  deallocate(diag_cs%diags)
3416 
3417  do i=1, diag_cs%num_diag_coords
3418  call diag_remap_end(diag_cs%diag_remap_cs(i))
3419  enddo
3420 
3421  call diag_grid_storage_end(diag_cs%diag_grid_temp)
3422  deallocate(diag_cs%mask3dTL)
3423  deallocate(diag_cs%mask3dBL)
3424  deallocate(diag_cs%mask3dCuL)
3425  deallocate(diag_cs%mask3dCvL)
3426  deallocate(diag_cs%mask3dTi)
3427  deallocate(diag_cs%mask3dBi)
3428  deallocate(diag_cs%mask3dCui)
3429  deallocate(diag_cs%mask3dCvi)
3430  do i=2,max_dsamp_lev
3431  deallocate(diag_cs%dsamp(i)%mask2dT)
3432  deallocate(diag_cs%dsamp(i)%mask2dBu)
3433  deallocate(diag_cs%dsamp(i)%mask2dCu)
3434  deallocate(diag_cs%dsamp(i)%mask2dCv)
3435  deallocate(diag_cs%dsamp(i)%mask3dTL)
3436  deallocate(diag_cs%dsamp(i)%mask3dBL)
3437  deallocate(diag_cs%dsamp(i)%mask3dCuL)
3438  deallocate(diag_cs%dsamp(i)%mask3dCvL)
3439  deallocate(diag_cs%dsamp(i)%mask3dTi)
3440  deallocate(diag_cs%dsamp(i)%mask3dBi)
3441  deallocate(diag_cs%dsamp(i)%mask3dCui)
3442  deallocate(diag_cs%dsamp(i)%mask3dCvi)
3443  enddo
3444 
3445 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
3446  deallocate(diag_cs%h_old)
3447 #endif
3448 
3449  if (present(end_diag_manager)) then
3450  if (end_diag_manager) call diag_manager_end(time)
3451  endif
3452 
3453 end subroutine diag_mediator_end
3454 
3455 !> Convert the first n elements (up to 3) of an integer array to an underscore delimited string.
3456 function i2s(a,n_in)
3457  ! "Convert the first n elements of an integer array to a string."
3458  ! Perhaps this belongs elsewhere in the MOM6 code?
3459  integer, dimension(:), intent(in) :: a !< The array of integers to translate
3460  integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all
3461  character(len=15) :: i2s !< The returned string
3462 
3463  character(len=15) :: i2s_temp
3464  integer :: i,n
3465 
3466  n=size(a)
3467  if (present(n_in)) n = n_in
3468 
3469  i2s = ''
3470  do i=1,min(n,3)
3471  write (i2s_temp, '(I4.4)') a(i)
3472  i2s = trim(i2s) //'_'// trim(i2s_temp)
3473  enddo
3474  i2s = adjustl(i2s)
3475 end function i2s
3476 
3477 !> Returns a new diagnostic id, it may be necessary to expand the diagnostics array.
3478 integer function get_new_diag_id(diag_cs)
3479  type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure
3480  ! Local variables
3481  type(diag_type), dimension(:), allocatable :: tmp
3482  integer :: i
3483 
3484  if (diag_cs%next_free_diag_id > size(diag_cs%diags)) then
3485  call assert(diag_cs%next_free_diag_id - size(diag_cs%diags) == 1, &
3486  'get_new_diag_id: inconsistent diag id')
3487 
3488  ! Increase the size of diag_cs%diags and copy data over.
3489  ! Do not use move_alloc() because it is not supported by Fortran 90
3490  allocate(tmp(size(diag_cs%diags)))
3491  tmp(:) = diag_cs%diags(:)
3492  deallocate(diag_cs%diags)
3493  allocate(diag_cs%diags(size(tmp) + diag_alloc_chunk_size))
3494  diag_cs%diags(1:size(tmp)) = tmp(:)
3495  deallocate(tmp)
3496 
3497  ! Initialize new part of the diag array.
3498  do i=diag_cs%next_free_diag_id, size(diag_cs%diags)
3499  call initialize_diag_type(diag_cs%diags(i))
3500  enddo
3501  endif
3502 
3503  get_new_diag_id = diag_cs%next_free_diag_id
3504  diag_cs%next_free_diag_id = diag_cs%next_free_diag_id + 1
3505 
3506 end function get_new_diag_id
3507 
3508 !> Initializes a diag_type (used after allocating new memory)
3509 subroutine initialize_diag_type(diag)
3510  type(diag_type), intent(inout) :: diag !< diag_type to be initialized
3511 
3512  diag%in_use = .false.
3513  diag%fms_diag_id = -1
3514  diag%axes => null()
3515  diag%next => null()
3516  diag%conversion_factor = 0.
3517 
3518 end subroutine initialize_diag_type
3519 
3520 !> Make a new diagnostic. Either use memory which is in the array of 'primary'
3521 !! diagnostics, or if that is in use, insert it to the list of secondary diags.
3522 subroutine alloc_diag_with_id(diag_id, diag_cs, diag)
3523  integer, intent(in ) :: diag_id !< id for the diagnostic
3524  type(diag_ctrl), target, intent(inout) :: diag_cs !< structure used to regulate diagnostic output
3525  type(diag_type), pointer :: diag !< structure representing a diagnostic (inout)
3526 
3527  type(diag_type), pointer :: tmp => null()
3528 
3529  if (.not. diag_cs%diags(diag_id)%in_use) then
3530  diag => diag_cs%diags(diag_id)
3531  else
3532  allocate(diag)
3533  tmp => diag_cs%diags(diag_id)%next
3534  diag_cs%diags(diag_id)%next => diag
3535  diag%next => tmp
3536  endif
3537  diag%in_use = .true.
3538 
3539 end subroutine alloc_diag_with_id
3540 
3541 !> Log a diagnostic to the available diagnostics file.
3542 subroutine log_available_diag(used, module_name, field_name, cell_methods_string, comment, &
3543  diag_CS, long_name, units, standard_name)
3544  logical, intent(in) :: used !< Whether this diagnostic was in the diag_table or not
3545  character(len=*), intent(in) :: module_name !< Name of the diagnostic module
3546  character(len=*), intent(in) :: field_name !< Name of this diagnostic field
3547  character(len=*), intent(in) :: cell_methods_string !< The spatial component of the CF cell_methods attribute
3548  character(len=*), intent(in) :: comment !< A comment to append after [Used|Unused]
3549  type(diag_ctrl), intent(in) :: diag_CS !< The diagnotics control structure
3550  character(len=*), optional, intent(in) :: long_name !< CF long name of diagnostic
3551  character(len=*), optional, intent(in) :: units !< Units for diagnostic
3552  character(len=*), optional, intent(in) :: standard_name !< CF standardized name of diagnostic
3553  ! Local variables
3554  character(len=240) :: mesg
3555 
3556  if (used) then
3557  mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]'
3558  else
3559  mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]'
3560  endif
3561  if (len(trim((comment)))>0) then
3562  write(diag_cs%available_diag_doc_unit, '(a,x,"(",a,")")') trim(mesg),trim(comment)
3563  else
3564  write(diag_cs%available_diag_doc_unit, '(a)') trim(mesg)
3565  endif
3566  if (present(long_name)) call describe_option("long_name", long_name, diag_cs)
3567  if (present(units)) call describe_option("units", units, diag_cs)
3568  if (present(standard_name)) &
3569  call describe_option("standard_name", standard_name, diag_cs)
3570  if (len(trim((cell_methods_string)))>0) &
3571  call describe_option("cell_methods", trim(cell_methods_string), diag_cs)
3572 
3573 end subroutine log_available_diag
3574 
3575 !> Log the diagnostic chksum to the chksum diag file
3576 subroutine log_chksum_diag(docunit, description, chksum)
3577  integer, intent(in) :: docunit !< Handle of the log file
3578  character(len=*), intent(in) :: description !< Name of the diagnostic module
3579  integer, intent(in) :: chksum !< chksum of the diagnostic
3580 
3581  write(docunit, '(a,x,i9.8)') description, chksum
3582  flush(docunit)
3583 
3584 end subroutine log_chksum_diag
3585 
3586 !> Allocates fields necessary to store diagnostic remapping fields
3587 subroutine diag_grid_storage_init(grid_storage, G, diag)
3588  type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids
3589  type(ocean_grid_type), intent(in) :: g !< Horizontal grid
3590  type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor
3591  !! template for this routine
3592 
3593  integer :: m, nz
3594  grid_storage%num_diag_coords = diag%num_diag_coords
3595 
3596  ! Don't do anything else if there are no remapped coordinates
3597  if (grid_storage%num_diag_coords < 1) return
3598 
3599  ! Allocate memory for the native space
3600  allocate(grid_storage%h_state(g%isd:g%ied,g%jsd:g%jed, g%ke))
3601  ! Allocate diagnostic remapping structures
3602  allocate(grid_storage%diag_grids(diag%num_diag_coords))
3603  ! Loop through and allocate memory for the grid on each target coordinate
3604  do m = 1, diag%num_diag_coords
3605  nz = diag%diag_remap_cs(m)%nz
3606  allocate(grid_storage%diag_grids(m)%h(g%isd:g%ied,g%jsd:g%jed, nz))
3607  enddo
3608 
3609 end subroutine diag_grid_storage_init
3610 
3611 !> Copy from the main diagnostic arrays to the grid storage as well as the native thicknesses
3612 subroutine diag_copy_diag_to_storage(grid_storage, h_state, diag)
3613  type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids
3614  real, dimension(:,:,:), intent(in) :: h_state !< Current model thicknesses [H ~> m or kg m-2]
3615  type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor
3616 
3617  integer :: m
3618 
3619  ! Don't do anything else if there are no remapped coordinates
3620  if (grid_storage%num_diag_coords < 1) return
3621 
3622  grid_storage%h_state(:,:,:) = h_state(:,:,:)
3623  do m = 1,grid_storage%num_diag_coords
3624  if (diag%diag_remap_cs(m)%nz > 0) &
3625  grid_storage%diag_grids(m)%h(:,:,:) = diag%diag_remap_cs(m)%h(:,:,:)
3626  enddo
3627 
3628 end subroutine diag_copy_diag_to_storage
3629 
3630 !> Copy from the stored diagnostic arrays to the main diagnostic grids
3631 subroutine diag_copy_storage_to_diag(diag, grid_storage)
3632  type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor
3633  type(diag_grid_storage), intent(in) :: grid_storage !< Structure containing a snapshot of the target grids
3634 
3635  integer :: m
3636 
3637  ! Don't do anything else if there are no remapped coordinates
3638  if (grid_storage%num_diag_coords < 1) return
3639 
3640  diag%diag_grid_overridden = .true.
3641  do m = 1,grid_storage%num_diag_coords
3642  if (diag%diag_remap_cs(m)%nz > 0) &
3643  diag%diag_remap_cs(m)%h(:,:,:) = grid_storage%diag_grids(m)%h(:,:,:)
3644  enddo
3645 
3646 end subroutine diag_copy_storage_to_diag
3647 
3648 !> Save the current diagnostic grids in the temporary structure within diag
3649 subroutine diag_save_grids(diag)
3650  type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor
3651 
3652  integer :: m
3653 
3654  ! Don't do anything else if there are no remapped coordinates
3655  if (diag%num_diag_coords < 1) return
3656 
3657  do m = 1,diag%num_diag_coords
3658  if (diag%diag_remap_cs(m)%nz > 0) &
3659  diag%diag_grid_temp%diag_grids(m)%h(:,:,:) = diag%diag_remap_cs(m)%h(:,:,:)
3660  enddo
3661 
3662 end subroutine diag_save_grids
3663 
3664 !> Restore the diagnostic grids from the temporary structure within diag
3665 subroutine diag_restore_grids(diag)
3666  type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor
3667 
3668  integer :: m
3669 
3670  ! Don't do anything else if there are no remapped coordinates
3671  if (diag%num_diag_coords < 1) return
3672 
3673  diag%diag_grid_overridden = .false.
3674  do m = 1,diag%num_diag_coords
3675  if (diag%diag_remap_cs(m)%nz > 0) &
3676  diag%diag_remap_cs(m)%h(:,:,:) = diag%diag_grid_temp%diag_grids(m)%h(:,:,:)
3677  enddo
3678 
3679 end subroutine diag_restore_grids
3680 
3681 !> Deallocates the fields in the remapping fields container
3682 subroutine diag_grid_storage_end(grid_storage)
3683  type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids
3684  ! Local variables
3685  integer :: m, nz
3686 
3687  ! Don't do anything else if there are no remapped coordinates
3688  if (grid_storage%num_diag_coords < 1) return
3689 
3690  ! Deallocate memory for the native space
3691  deallocate(grid_storage%h_state)
3692  ! Loop through and deallocate memory for the grid on each target coordinate
3693  do m = 1, grid_storage%num_diag_coords
3694  deallocate(grid_storage%diag_grids(m)%h)
3695  enddo
3696  ! Deallocate diagnostic remapping structures
3697  deallocate(grid_storage%diag_grids)
3698 end subroutine diag_grid_storage_end
3699 
3700 !< Allocate and initialize the masks for downsampled diagostics in diag_cs
3701 !! The downsampled masks in the axes would later "point" to these.
3702 subroutine downsample_diag_masks_set(G, nz, diag_cs)
3703  type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type.
3704  integer, intent(in) :: nz !< The number of layers in the model's native grid.
3705  type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables
3706  !! used for diagnostics
3707  ! Local variables
3708  integer :: i,j,k,ii,jj,dl
3709 
3710 !print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec
3711 !print*,'original c extents ',G%iscb,G%iecb,G%jscb,G%jecb
3712 !print*,'coarse c extents ',G%HId2%isc,G%HId2%iec,G%HId2%jsc,G%HId2%jec
3713 !print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed
3714 !print*,'coarse d extents ',G%HId2%isd,G%HId2%ied,G%HId2%jsd,G%HId2%jed
3715 ! original c extents 5 52 5 52
3716 ! original cB-nonsym extents 5 52 5 52
3717 ! original cB-sym extents 4 52 4 52
3718 ! coarse c extents 3 26 3 26
3719 ! original d extents 1 56 1 56
3720 ! original dB-nonsym extents 1 56 1 56
3721 ! original dB-sym extents 0 56 0 56
3722 ! coarse d extents 1 28 1 28
3723 
3724  do dl=2,max_dsamp_lev
3725  ! 2d mask
3726  call downsample_mask(g%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,g%isc, g%jsc, &
3727  g%HId2%isc, g%HId2%iec, g%HId2%jsc, g%HId2%jec, g%HId2%isd, g%HId2%ied, g%HId2%jsd, g%HId2%jed)
3728  call downsample_mask(g%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl,g%IscB,g%JscB, &
3729  g%HId2%IscB,g%HId2%IecB,g%HId2%JscB,g%HId2%JecB,g%HId2%IsdB,g%HId2%IedB,g%HId2%JsdB,g%HId2%JedB)
3730  call downsample_mask(g%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl,g%IscB,g%JscB, &
3731  g%HId2%IscB,g%HId2%IecB,g%HId2%jsc, g%HId2%jec,g%HId2%IsdB,g%HId2%IedB,g%HId2%jsd, g%HId2%jed)
3732  call downsample_mask(g%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl,g%isc ,g%JscB, &
3733  g%HId2%isc ,g%HId2%iec, g%HId2%JscB,g%HId2%JecB,g%HId2%isd ,g%HId2%ied, g%HId2%JsdB,g%HId2%JedB)
3734  ! 3d native masks are needed by diag_manager but the native variables
3735  ! can only be masked 2d - for ocean points, all layers exists.
3736  allocate(diag_cs%dsamp(dl)%mask3dTL(g%HId2%isd:g%HId2%ied,g%HId2%jsd:g%HId2%jed,1:nz))
3737  allocate(diag_cs%dsamp(dl)%mask3dBL(g%HId2%IsdB:g%HId2%IedB,g%HId2%JsdB:g%HId2%JedB,1:nz))
3738  allocate(diag_cs%dsamp(dl)%mask3dCuL(g%HId2%IsdB:g%HId2%IedB,g%HId2%jsd:g%HId2%jed,1:nz))
3739  allocate(diag_cs%dsamp(dl)%mask3dCvL(g%HId2%isd:g%HId2%ied,g%HId2%JsdB:g%HId2%JedB,1:nz))
3740  do k=1,nz
3741  diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:)
3742  diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:)
3743  diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:)
3744  diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:)
3745  enddo
3746  allocate(diag_cs%dsamp(dl)%mask3dTi(g%HId2%isd:g%HId2%ied,g%HId2%jsd:g%HId2%jed,1:nz+1))
3747  allocate(diag_cs%dsamp(dl)%mask3dBi(g%HId2%IsdB:g%HId2%IedB,g%HId2%JsdB:g%HId2%JedB,1:nz+1))
3748  allocate(diag_cs%dsamp(dl)%mask3dCui(g%HId2%IsdB:g%HId2%IedB,g%HId2%jsd:g%HId2%jed,1:nz+1))
3749  allocate(diag_cs%dsamp(dl)%mask3dCvi(g%HId2%isd:g%HId2%ied,g%HId2%JsdB:g%HId2%JedB,1:nz+1))
3750  do k=1,nz+1
3751  diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:)
3752  diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:)
3753  diag_cs%dsamp(dl)%mask3dCui(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:)
3754  diag_cs%dsamp(dl)%mask3dCvi(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:)
3755  enddo
3756  enddo
3757 end subroutine downsample_diag_masks_set
3758 
3759 !> Get the diagnostics-compute indices (to be passed to send_data) based on the shape of
3760 !! the diag field (the same way they are deduced for non-downsampled fields)
3761 subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev)
3762  integer, intent(in) :: fo1 !< The size of the diag field in x
3763  integer, intent(in) :: fo2 !< The size of the diag field in y
3764  integer, intent(in) :: dl !< Integer downsample level
3765  type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
3766  integer, intent(out) :: isv !< i-start index for diagnostics
3767  integer, intent(out) :: iev !< i-end index for diagnostics
3768  integer, intent(out) :: jsv !< j-start index for diagnostics
3769  integer, intent(out) :: jev !< j-end index for diagnostics
3770  ! Local variables
3771  integer :: dszi,cszi,dszj,cszj,f1,f2
3772  character(len=500) :: mesg
3773  logical, save :: first_check = .true.
3774 
3775  !Check ONCE that the downsampled diag-compute domain is commensurate with the original
3776  !non-downsampled diag-compute domain.
3777  !This is a major limitation of the current implementation of the downsampled diagnostics.
3778  !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates.
3779  !We want this check to error out only if there was a downsampled diagnostics requested and about to post that is
3780  !why the check is here and not in the init routines. This check need to be done only once, hence the outer if.
3781  if(first_check) then
3782  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
3783  write (mesg,*) "Non-commensurate downsampled domain is not supported. "//&
3784  "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl,&
3785  " Current domain extents: ", diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je
3786  call mom_error(fatal,"downsample_diag_indices_get: "//trim(mesg))
3787  endif
3788  first_check = .false.
3789  endif
3790 
3791  cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1
3792  cszj = diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc +1 ; dszj = diag_cs%dsamp(dl)%jed-diag_cs%dsamp(dl)%jsd +1
3793  isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec
3794  jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec
3795  f1 = fo1/dl
3796  f2 = fo2/dl
3797  !Correction for the symmetric case
3798  if (diag_cs%G%symmetric) then
3799  f1 = f1 + mod(fo1,dl)
3800  f2 = f2 + mod(fo2,dl)
3801  endif
3802  if ( f1 == dszi ) then
3803  isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies
3804  !The rest is not taken with the full MOM6 diag_table
3805  elseif ( f1 == dszi + 1 ) then
3806  isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1 ! Symmetric data domain
3807  elseif ( f1 == cszi) then
3808  isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +1 ! Computational domain
3809  elseif ( f1 == cszi + 1 ) then
3810  isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2 ! Symmetric computational domain
3811  else
3812  write (mesg,*) " peculiar size ",f1," in i-direction\n"//&
3813  "does not match one of ", cszi, cszi+1, dszi, dszi+1
3814  call mom_error(fatal,"downsample_diag_indices_get: "//trim(mesg))
3815  endif
3816  if ( f2 == dszj ) then
3817  jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec ! Data domain
3818  elseif ( f2 == dszj + 1 ) then
3819  jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec+1 ! Symmetric data domain
3820  elseif ( f2 == cszj) then
3821  jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +1 ! Computational domain
3822  elseif ( f2 == cszj + 1 ) then
3823  jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2 ! Symmetric computational domain
3824  else
3825  write (mesg,*) " peculiar size ",f2," in j-direction\n"//&
3826  "does not match one of ", cszj, cszj+1, dszj, dszj+1
3827  call mom_error(fatal,"downsample_diag_indices_get: "//trim(mesg))
3828  endif
3829 end subroutine downsample_diag_indices_get
3830 
3831 !> This subroutine allocates and computes a downsampled array from an input array
3832 !! It also determines the diagnostics-compurte indices for the downsampled array
3833 !! 3d interface
3834 subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
3835  real, dimension(:,:,:), pointer :: locfield !< Input array pointer
3836  real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array
3837  type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
3838  type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post
3839  integer, intent(in) :: dl !< Level of down sampling
3840  integer, intent(inout) :: isv !< i-start index for diagnostics
3841  integer, intent(inout) :: iev !< i-end index for diagnostics
3842  integer, intent(inout) :: jsv !< j-start index for diagnostics
3843  integer, intent(inout) :: jev !< j-end index for diagnostics
3844  real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask.
3845  ! Locals
3846  real, dimension(:,:,:), pointer :: locmask
3847  integer :: f1,f2,isv_o,jsv_o
3848 
3849  locmask => null()
3850  !Get the correct indices corresponding to input field
3851  !Shape of the input diag field
3852  f1=size(locfield,1)
3853  f2=size(locfield,2)
3854  !Save the extents of the original (fine) domain
3855  isv_o=isv;jsv_o=jsv
3856  !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them
3857  call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev)
3858  !Set the non-downsampled mask, it must be associated and initialized
3859  if (present(mask)) then
3860  locmask => mask
3861  elseif (associated(diag%axes%mask3d)) then
3862  locmask => diag%axes%mask3d
3863  else
3864  call mom_error(fatal, "downsample_diag_field_3d: Cannot downsample without a mask!!! ")
3865  endif
3866 
3867  call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs, diag, &
3868  isv_o,jsv_o,isv,iev,jsv,jev)
3869 
3870 end subroutine downsample_diag_field_3d
3871 
3872 !> This subroutine allocates and computes a downsampled array from an input array
3873 !! It also determines the diagnostics-compurte indices for the downsampled array
3874 !! 2d interface
3875 subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
3876  real, dimension(:,:), pointer :: locfield !< Input array pointer
3877  real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array
3878  type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
3879  type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post
3880  integer, intent(in) :: dl !< Level of down sampling
3881  integer, intent(inout) :: isv !< i-start index for diagnostics
3882  integer, intent(inout) :: iev !< i-end index for diagnostics
3883  integer, intent(inout) :: jsv !< j-start index for diagnostics
3884  integer, intent(inout) :: jev !< j-end index for diagnostics
3885  real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask.
3886  ! Locals
3887  real, dimension(:,:), pointer :: locmask
3888  integer :: f1,f2,isv_o,jsv_o
3889 
3890  locmask => null()
3891  !Get the correct indices corresponding to input field
3892  !Shape of the input diag field
3893  f1=size(locfield,1)
3894  f2=size(locfield,2)
3895  !Save the extents of the original (fine) domain
3896  isv_o=isv;jsv_o=jsv
3897  !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them
3898  call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev)
3899  !Set the non-downsampled mask, it must be associated and initialized
3900  if (present(mask)) then
3901  locmask => mask
3902  elseif (associated(diag%axes%mask2d)) then
3903  locmask => diag%axes%mask2d
3904  else
3905  call mom_error(fatal, "downsample_diag_field_2d: Cannot downsample without a mask!!! ")
3906  endif
3907 
3908  call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, &
3909  isv_o,jsv_o,isv,iev,jsv,jev)
3910 
3911 end subroutine downsample_diag_field_2d
3912 
3913 !> \section downsampling The down sample algorithm
3914 !!
3915 !! The down sample method could be deduced (before send_data call)
3916 !! from the diag%x_cell_method, diag%y_cell_method and diag%v_cell_method
3917 !!
3918 !! This is the summary of the down sample algoritm for a diagnostic field f:
3919 !! \f[
3920 !! f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)]
3921 !! \f]
3922 !! Here, i and j run from 0 to dl-1 (dl being the down sample level).
3923 !! Id,Jd are the down sampled (coarse grid) indices run over the coarsened compute grid,
3924 !! if and jf are the original (fine grid) indices.
3925 !!
3926 !! \verbatim
3927 !! Example x_cell y_cell v_cell algorithm_id implemented weight(if,jf)
3928 !! ---------------------------------------------------------------------------------------
3929 !! theta mean mean mean MMM =222 G%areaT(if,jf)*h(if,jf)
3930 !! u point mean mean PMM =022 dyCu(if,jf)*h(if,jf)*delta(if,Id)
3931 !! v mean point mean MPM =202 dxCv(if,jf)*h(if,jf)*delta(jf,Jd)
3932 !! ? point sum mean PSM =012 h(if,jf)*delta(if,Id)
3933 !! volcello sum sum sum SSS =111 1
3934 !! T_dfxy_co sum sum point SSP =110 1
3935 !! umo point sum sum PSS =011 1*delta(if,Id)
3936 !! vmo sum point sum SPS =101 1*delta(jf,Jd)
3937 !! umo_2d point sum point PSP =010 1*delta(if,Id)
3938 !! vmo_2d sum point point SPP =100 1*delta(jf,Jd)
3939 !! ? point mean point PMP =020 dyCu(if,jf)*delta(if,Id)
3940 !! ? mean point point MPP =200 dxCv(if,jf)*delta(jf,Jd)
3941 !! w mean mean point MMP =220 G%areaT(if,jf)
3942 !! h*theta mean mean sum MMS =221 G%areaT(if,jf)
3943 !!
3944 !! delta is the Kronecker delta
3945 !! \endverbatim
3946 
3947 !> This subroutine allocates and computes a down sampled 3d array given an input array
3948 !! The down sample method is based on the "cell_methods" for the diagnostics as explained
3949 !! in the above table
3950 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)
3951  real, dimension(:,:,:), pointer :: field_in !< Original field to be down sampled
3952  real, dimension(:,:,:), allocatable :: field_out !< down sampled field
3953  integer, intent(in) :: dl !< Level of down sampling
3954  integer, intent(in) :: method !< Sampling method
3955  real, dimension(:,:,:), pointer :: mask !< Mask for field
3956  type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
3957  type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post
3958  integer, intent(in) :: isv_o !< Original i-start index
3959  integer, intent(in) :: jsv_o !< Original j-start index
3960  integer, intent(in) :: isv_d !< i-start index of down sampled data
3961  integer, intent(in) :: iev_d !< i-end index of down sampled data
3962  integer, intent(in) :: jsv_d !< j-start index of down sampled data
3963  integer, intent(in) :: jev_d !< j-end index of down sampled data
3964  ! Locals
3965  character(len=240) :: mesg
3966  integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2
3967  integer :: k,ks,ke
3968  real :: ave,total_weight,weight
3969  real :: eps_vol ! A negligibly small volume or mass [H L2 ~> m3 or kg]
3970  real :: eps_area ! A negligibly small area [L2 ~> m2]
3971  real :: eps_face ! A negligibly small face area [H L ~> m2 or kg m-1]
3972 
3973  ks = 1 ; ke = size(field_in,3)
3974  eps_face = 1.0e-20 * diag_cs%G%US%m_to_L * diag_cs%GV%m_to_H
3975  eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2
3976  eps_vol = 1.0e-20 * diag_cs%G%US%m_to_L**2 * diag_cs%GV%m_to_H
3977 
3978  ! Allocate the down sampled field on the down sampled data domain
3979 ! 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))
3980 ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke))
3981  f_in1 = size(field_in,1)
3982  f_in2 = size(field_in,2)
3983  f1 = f_in1/dl
3984  f2 = f_in2/dl
3985  !Correction for the symmetric case
3986  if (diag_cs%G%symmetric) then
3987  f1 = f1 + mod(f_in1,dl)
3988  f2 = f2 + mod(f_in2,dl)
3989  endif
3990  allocate(field_out(1:f1,1:f2,ks:ke))
3991 
3992  ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain
3993  if (method == mmm) then
3994  do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
3995  i0 = isv_o+dl*(i-isv_d)
3996  j0 = jsv_o+dl*(j-jsv_d)
3997  ave = 0.0
3998  total_weight = 0.0
3999  do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
4000 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!!
4001  weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k)
4002  total_weight = total_weight + weight
4003  ave = ave+field_in(ii,jj,k) * weight
4004  enddo; enddo
4005  field_out(i,j,k) = ave/(total_weight + eps_vol) !Avoid zero mask at all aggregating cells where ave=0.0
4006  enddo; enddo; enddo
4007  elseif (method == sss) then !e.g., volcello
4008  do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
4009  i0 = isv_o+dl*(i-isv_d)
4010  j0 = jsv_o+dl*(j-jsv_d)
4011  ave = 0.0
4012  do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
4013  weight = mask(ii,jj,k)
4014  ave = ave+field_in(ii,jj,k)*weight
4015  enddo; enddo
4016  field_out(i,j,k) = ave !Masked Sum (total_weight=1)
4017  enddo; enddo; enddo
4018  elseif(method == mmp .or. method == mms) then !e.g., T_advection_xy
4019  do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
4020  i0 = isv_o+dl*(i-isv_d)
4021  j0 = jsv_o+dl*(j-jsv_d)
4022  ave = 0.0
4023  total_weight = 0.0
4024  do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
4025 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1
4026  weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj)
4027  total_weight = total_weight + weight
4028  ave = ave+field_in(ii,jj,k)*weight
4029  enddo; enddo
4030  field_out(i,j,k) = ave / (total_weight+eps_area) !Avoid zero mask at all aggregating cells where ave=0.0
4031  enddo; enddo; enddo
4032  elseif(method == pmm) then
4033  do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
4034  i0 = isv_o+dl*(i-isv_d)
4035  j0 = jsv_o+dl*(j-jsv_d)
4036  ave = 0.0
4037  total_weight = 0.0
4038  ii=i0
4039  do jj=j0,j0+dl-1
4040  weight =mask(ii,jj,k) * diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k)
4041  total_weight = total_weight +weight
4042  ave=ave+field_in(ii,jj,k)*weight
4043  enddo
4044  field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0
4045  enddo; enddo; enddo
4046  elseif(method == pss) then !e.g. umo
4047  do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
4048  i0 = isv_o+dl*(i-isv_d)
4049  j0 = jsv_o+dl*(j-jsv_d)
4050  ave = 0.0
4051  ii=i0
4052  do jj=j0,j0+dl-1
4053  weight =mask(ii,jj,k)
4054  ave=ave+field_in(ii,jj,k)*weight
4055  enddo
4056  field_out(i,j,k) = ave !Masked Sum (total_weight=1)
4057  enddo; enddo; enddo
4058  elseif(method == sps) then !e.g. vmo
4059  do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
4060  i0 = isv_o+dl*(i-isv_d)
4061  j0 = jsv_o+dl*(j-jsv_d)
4062  ave = 0.0
4063  jj=j0
4064  do ii=i0,i0+dl-1
4065  weight =mask(ii,jj,k)
4066  ave=ave+field_in(ii,jj,k)*weight
4067  enddo
4068  field_out(i,j,k) = ave !Masked Sum (total_weight=1)
4069  enddo; enddo; enddo
4070  elseif(method == mpm) then
4071  do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
4072  i0 = isv_o+dl*(i-isv_d)
4073  j0 = jsv_o+dl*(j-jsv_d)
4074  ave = 0.0
4075  total_weight = 0.0
4076  jj=j0
4077  do ii=i0,i0+dl-1
4078  weight = mask(ii,jj,k) * diag_cs%G%dxCv(ii,jj) * diag_cs%h(ii,jj,k)
4079  total_weight = total_weight + weight
4080  ave=ave+field_in(ii,jj,k)*weight
4081  enddo
4082  field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0
4083  enddo; enddo; enddo
4084  elseif(method == msk) then !The input field is a mask, subsample
4085  field_out(:,:,:) = 0.0
4086  do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d
4087  i0 = isv_o+dl*(i-isv_d)
4088  j0 = jsv_o+dl*(j-jsv_d)
4089  ave = 0.0
4090  do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
4091  ave=ave+field_in(ii,jj,k)
4092  enddo; enddo
4093  if(ave > 0.0) field_out(i,j,k)=1.0
4094  enddo; enddo; enddo
4095  else
4096  write (mesg,*) " unknown sampling method: ",method
4097  call mom_error(fatal, "downsample_field_3d: "//trim(mesg)//" "//trim(diag%debug_str))
4098  endif
4099 
4100 end subroutine downsample_field_3d
4101 
4102 !> This subroutine allocates and computes a down sampled 2d array given an input array
4103 !! The down sample method is based on the "cell_methods" for the diagnostics as explained
4104 !! in the above table
4105 subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, diag, &
4106  isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d)
4107  real, dimension(:,:), pointer :: field_in !< Original field to be down sampled
4108  real, dimension(:,:), allocatable :: field_out !< Down sampled field
4109  integer, intent(in) :: dl !< Level of down sampling
4110  integer, intent(in) :: method !< Sampling method
4111  real, dimension(:,:), pointer :: mask !< Mask for field
4112  type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output
4113  type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post
4114  integer, intent(in) :: isv_o !< Original i-start index
4115  integer, intent(in) :: jsv_o !< Original j-start index
4116  integer, intent(in) :: isv_d !< i-start index of down sampled data
4117  integer, intent(in) :: iev_d !< i-end index of down sampled data
4118  integer, intent(in) :: jsv_d !< j-start index of down sampled data
4119  integer, intent(in) :: jev_d !< j-end index of down sampled data
4120  ! Locals
4121  character(len=240) :: mesg
4122  integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2
4123  real :: ave, total_weight, weight
4124  real :: epsilon = 1.0e-20 ! A negligibly small count of weights [nondim]
4125  real :: eps_area ! A negligibly small area [L2 ~> m2]
4126  real :: eps_len ! A negligibly small horizontal length [L ~> m]
4127 
4128  eps_len = 1.0e-20 * diag_cs%G%US%m_to_L
4129  eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2
4130 
4131  ! Allocate the down sampled field on the down sampled data domain
4132 ! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed))
4133 ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl))
4134  ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain
4135  f_in1 = size(field_in,1)
4136  f_in2 = size(field_in,2)
4137  f1 = f_in1/dl
4138  f2 = f_in2/dl
4139  ! Correction for the symmetric case
4140  if (diag_cs%G%symmetric) then
4141  f1 = f1 + mod(f_in1,dl)
4142  f2 = f2 + mod(f_in2,dl)
4143  endif
4144  allocate(field_out(1:f1,1:f2))
4145 
4146  if (method == mmp) then
4147  do j=jsv_d,jev_d ; do i=isv_d,iev_d
4148  i0 = isv_o+dl*(i-isv_d)
4149  j0 = jsv_o+dl*(j-jsv_d)
4150  ave = 0.0
4151  total_weight = 0.0
4152  do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
4153 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1
4154  weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj)
4155  total_weight = total_weight + weight
4156  ave = ave+field_in(ii,jj)*weight
4157  enddo; enddo
4158  field_out(i,j) = ave/(total_weight + eps_area) !Avoid zero mask at all aggregating cells where ave=0.0
4159  enddo; enddo
4160  elseif(method == ssp) then ! e.g., T_dfxy_cont_tendency_2d
4161  do j=jsv_d,jev_d ; do i=isv_d,iev_d
4162  i0 = isv_o+dl*(i-isv_d)
4163  j0 = jsv_o+dl*(j-jsv_d)
4164  ave = 0.0
4165  total_weight = 0.0
4166  do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
4167 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1
4168  weight = mask(ii,jj)
4169  total_weight = total_weight + weight
4170  ave=ave+field_in(ii,jj)*weight
4171  enddo; enddo
4172  field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0
4173  enddo; enddo
4174  elseif(method == psp) then ! e.g., umo_2d
4175  do j=jsv_d,jev_d ; do i=isv_d,iev_d
4176  i0 = isv_o+dl*(i-isv_d)
4177  j0 = jsv_o+dl*(j-jsv_d)
4178  ave = 0.0
4179  total_weight = 0.0
4180  ii=i0
4181  do jj=j0,j0+dl-1
4182  weight = mask(ii,jj)
4183  total_weight = total_weight +weight
4184  ave=ave+field_in(ii,jj)*weight
4185  enddo
4186  field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0
4187  enddo; enddo
4188  elseif(method == spp) then ! e.g., vmo_2d
4189  do j=jsv_d,jev_d ; do i=isv_d,iev_d
4190  i0 = isv_o+dl*(i-isv_d)
4191  j0 = jsv_o+dl*(j-jsv_d)
4192  ave = 0.0
4193  total_weight = 0.0
4194  jj=j0
4195  do ii=i0,i0+dl-1
4196  weight = mask(ii,jj)
4197  total_weight = total_weight +weight
4198  ave=ave+field_in(ii,jj)*weight
4199  enddo
4200  field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0
4201  enddo; enddo
4202  elseif(method == pmp) then
4203  do j=jsv_d,jev_d ; do i=isv_d,iev_d
4204  i0 = isv_o+dl*(i-isv_d)
4205  j0 = jsv_o+dl*(j-jsv_d)
4206  ave = 0.0
4207  total_weight = 0.0
4208  ii=i0
4209  do jj=j0,j0+dl-1
4210  weight = mask(ii,jj) * diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki?
4211  total_weight = total_weight +weight
4212  ave=ave+field_in(ii,jj)*weight
4213  enddo
4214  field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0
4215  enddo; enddo
4216  elseif(method == mpp) then
4217  do j=jsv_d,jev_d ; do i=isv_d,iev_d
4218  i0 = isv_o+dl*(i-isv_d)
4219  j0 = jsv_o+dl*(j-jsv_d)
4220  ave = 0.0
4221  total_weight = 0.0
4222  jj=j0
4223  do ii=i0,i0+dl-1
4224  weight = mask(ii,jj)* diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki?
4225  total_weight = total_weight +weight
4226  ave=ave+field_in(ii,jj)*weight
4227  enddo
4228  field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0
4229  enddo; enddo
4230  elseif(method == msk) then !The input field is a mask, subsample
4231  field_out(:,:) = 0.0
4232  do j=jsv_d,jev_d ; do i=isv_d,iev_d
4233  i0 = isv_o+dl*(i-isv_d)
4234  j0 = jsv_o+dl*(j-jsv_d)
4235  ave = 0.0
4236  do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
4237  ave=ave+field_in(ii,jj)
4238  enddo; enddo
4239  if(ave > 0.0) field_out(i,j)=1.0
4240  enddo; enddo
4241  else
4242  write (mesg,*) " unknown sampling method: ",method
4243  call mom_error(fatal, "downsample_field_2d: "//trim(mesg)//" "//trim(diag%debug_str))
4244  endif
4245 
4246 end subroutine downsample_field_2d
4247 
4248 !> Allocate and compute the 2d down sampled mask
4249 !! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1)
4250 !! if at least one of the sub-cells are open, otherwise it's closed (0)
4251 subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, &
4252  isd_d, ied_d, jsd_d, jed_d)
4253  real, dimension(:,:), intent(in) :: field_in !< Original field to be down sampled
4254  real, dimension(:,:), pointer :: field_out !< Down sampled field
4255  integer, intent(in) :: dl !< Level of down sampling
4256  integer, intent(in) :: isc_o !< Original i-start index
4257  integer, intent(in) :: jsc_o !< Original j-start index
4258  integer, intent(in) :: isc_d !< Computational i-start index of down sampled data
4259  integer, intent(in) :: iec_d !< Computational i-end index of down sampled data
4260  integer, intent(in) :: jsc_d !< Computational j-start index of down sampled data
4261  integer, intent(in) :: jec_d !< Computational j-end index of down sampled data
4262  integer, intent(in) :: isd_d !< Computational i-start index of down sampled data
4263  integer, intent(in) :: ied_d !< Computational i-end index of down sampled data
4264  integer, intent(in) :: jsd_d !< Computational j-start index of down sampled data
4265  integer, intent(in) :: jed_d !< Computational j-end index of down sampled data
4266  ! Locals
4267  integer :: i,j,ii,jj,i0,j0
4268  real :: tot_non_zero
4269  ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1
4270  allocate(field_out(isd_d:ied_d,jsd_d:jed_d))
4271  field_out(:,:) = 0.0
4272  do j=jsc_d,jec_d ; do i=isc_d,iec_d
4273  i0 = isc_o+dl*(i-isc_d)
4274  j0 = jsc_o+dl*(j-jsc_d)
4275  tot_non_zero = 0.0
4276  do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
4277  tot_non_zero = tot_non_zero + field_in(ii,jj)
4278  enddo;enddo
4279  if(tot_non_zero > 0.0) field_out(i,j)=1.0
4280  enddo; enddo
4281 end subroutine downsample_mask_2d
4282 
4283 !> Allocate and compute the 3d down sampled mask
4284 !! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1)
4285 !! if at least one of the sub-cells are open, otherwise it's closed (0)
4286 subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, &
4287  isd_d, ied_d, jsd_d, jed_d)
4288  real, dimension(:,:,:), intent(in) :: field_in !< Original field to be down sampled
4289  real, dimension(:,:,:), pointer :: field_out !< down sampled field
4290  integer, intent(in) :: dl !< Level of down sampling
4291  integer, intent(in) :: isc_o !< Original i-start index
4292  integer, intent(in) :: jsc_o !< Original j-start index
4293  integer, intent(in) :: isc_d !< Computational i-start index of down sampled data
4294  integer, intent(in) :: iec_d !< Computational i-end index of down sampled data
4295  integer, intent(in) :: jsc_d !< Computational j-start index of down sampled data
4296  integer, intent(in) :: jec_d !< Computational j-end index of down sampled data
4297  integer, intent(in) :: isd_d !< Computational i-start index of down sampled data
4298  integer, intent(in) :: ied_d !< Computational i-end index of down sampled data
4299  integer, intent(in) :: jsd_d !< Computational j-start index of down sampled data
4300  integer, intent(in) :: jed_d !< Computational j-end index of down sampled data
4301  ! Locals
4302  integer :: i,j,ii,jj,i0,j0,k,ks,ke
4303  real :: tot_non_zero
4304  ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1
4305  ks = lbound(field_in,3) ; ke = ubound(field_in,3)
4306  allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke))
4307  field_out(:,:,:) = 0.0
4308  do k= ks,ke ; do j=jsc_d,jec_d ; do i=isc_d,iec_d
4309  i0 = isc_o+dl*(i-isc_d)
4310  j0 = jsc_o+dl*(j-jsc_d)
4311  tot_non_zero = 0.0
4312  do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1
4313  tot_non_zero = tot_non_zero + field_in(ii,jj,k)
4314  enddo;enddo
4315  if(tot_non_zero > 0.0) field_out(i,j,k)=1.0
4316  enddo; enddo; enddo
4317 end subroutine downsample_mask_3d
4318 
4319 end module mom_diag_mediator
Checksums an array (2d or 3d) staggered at C-grid u points.
Wraps the FMS time manager functions.
This type is used to represent a diagnostic at the diag_mediator level.
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:26
The following data type a list of diagnostic fields an their variants, as well as variables that cont...
A structure that can be parsed to read and document run-time parameters.
Provides the ocean grid type.
Definition: MOM_grid.F90:2
Wraps the MPP cpu clock functions.
A simple (very thin) wrapper for register_diag_field to avoid a compiler bug with PGI.
This module contains I/O framework code.
Definition: MOM_io.F90:2
The MOM6 facility to parse input files for runtime parameters.
Routines to calculate checksums of various array and vector types.
Contains an array to store a diagnostic target grid.
Interfaces to non-domain-oriented communication subroutines, including the MOM6 reproducing sums faci...
Definition: MOM_coms.F90:3
Allocate a pointer to a 1-d, 2-d or 3-d array.
Make a diagnostic available for averaging or output.
A group of 1D axes that comprise a 1D/2D/3D mesh.
Describes various unit conversion factors.
Checksums an array (2d or 3d) staggered at tracer points.
Represents remapping of diagnostics to a particular vertical coordinate.
Provides a transparent unit rescaling type to facilitate dimensional consistency testing.
Convenience functions for safely allocating memory without accidentally reallocating pointer and caus...
The subroutines here provide convenient wrappers to the fms diag_manager interfaces with additional d...
Routines for error handling and I/O management.
Stores all the remapping grids and the model's native space thicknesses.
Allocate a 2-d or 3-d allocatable array.
Down sample the mask of a field.
Contained for down sampled masks.
Down sample a diagnostic field.
provides runtime remapping of diagnostics to z star, sigma and rho vertical coordinates.
Provides subroutines for quantities specific to the equation of state.
Definition: MOM_EOS.F90:2
Type for describing a variable, typically a tracer.
Definition: MOM_io.F90:53
An overloaded interface to log version information about modules.
Describes the vertical ocean grid, including unit conversion factors.
This is an older interface for 1-, 2-, or 3-D checksums.
Container for down sampling information.
Checksums an array (2d or 3d) staggered at corner points.
Checksums an array (2d or 3d) staggered at C-grid v points.
Handy functions for manipulating strings.
Provides a transparent vertical ocean grid type and supporting routines.
Read a data field from a file.
Definition: MOM_io.F90:74
An overloaded interface to read and log the values of various types of parameters.
A control structure for the equation of state.
Definition: MOM_EOS.F90:108