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