FMS  2026.01.01-dev
Flexible Modeling System
fms_diag_field_object.F90
1 !***********************************************************************
2 !* Apache License 2.0
3 !*
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
5 !*
6 !* Licensed under the Apache License, Version 2.0 (the "License");
7 !* you may not use this file except in compliance with the License.
8 !* You may obtain a copy of the License at
9 !*
10 !* http://www.apache.org/licenses/LICENSE-2.0
11 !*
12 !* FMS is distributed in the hope that it will be useful, but WITHOUT
13 !* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied;
14 !* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
15 !* PARTICULAR PURPOSE. See the License for the specific language
16 !* governing permissions and limitations under the License.
17 !***********************************************************************
18 module fms_diag_field_object_mod
19 !> \author Tom Robinson
20 !> \email thomas.robinson@noaa.gov
21 !! \brief Contains routines for the diag_objects
22 !!
23 !! \description The diag_manager passes an object back and forth between the diag routines and the users.
24 !! The procedures of this object and the types are all in this module. The fms_dag_object is a type
25 !! that contains all of the information of the variable. It is extended by a type that holds the
26 !! appropriate buffer for the data for manipulation.
27 #ifdef use_yaml
28 use diag_data_mod, only: prepend_date, diag_null, cmor_missing_value, diag_null_string, max_str_len
29 use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, no_domain
30 use diag_data_mod, only: max_field_attributes, fmsdiagattribute_type
31 use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
34 use fms_string_utils_mod, only: int2str=>string
35 use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe
36 use fms_diag_yaml_mod, only: diagyamlfilesvar_type, get_diag_fields_entries, get_diag_files_id, &
38 use fms_diag_axis_object_mod, only: diagdomain_t, get_domain_and_domain_type, fmsdiagaxis_type, &
40 use time_manager_mod, ONLY: time_type, get_date
41 use fms2_io_mod, only: fmsnetcdffile_t, fmsnetcdfdomainfile_t, fmsnetcdfunstructureddomainfile_t, register_field, &
42  register_variable_attribute
43 use fms_diag_input_buffer_mod, only: fmsdiaginputbuffer_t
44 !!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
45 !!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
46 !!! & get_ticks_per_second
47 
48 use platform_mod
49 use iso_c_binding
50 
51 implicit none
52 
53 private
54 
55 !> \brief Object that holds all variable information
57  type (diagyamlfilesvar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable
58  integer, allocatable, dimension(:) :: file_ids !< Ids of the FMS_diag_files the variable
59  !! belongs to
60  integer, allocatable, private :: diag_id !< unique id for varable
61  integer, allocatable, dimension(:) :: buffer_ids !< index/id for this field's buffers
62  type(fmsdiagattribute_type), allocatable :: attributes(:) !< attributes for the variable
63  integer, private :: num_attributes !< Number of attributes currently added
64  logical, allocatable, private :: static !< true if this is a static var
65  logical, allocatable, private :: scalar !< .True. if the variable is a scalar
66  logical, allocatable, private :: registered !< true when registered
67  logical, allocatable, private :: mask_variant !< true if the mask changes over time
68  logical, allocatable, private :: var_is_masked !< true if the field is masked
69  logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field
70  logical, allocatable, private :: local !< If the output is local
71  integer, allocatable, private :: vartype !< the type of varaible
72  character(len=:), allocatable, private :: varname !< the name of the variable
73  character(len=:), allocatable, private :: longname !< longname of the variable
74  character(len=:), allocatable, private :: standname !< standard name of the variable
75  character(len=:), allocatable, private :: units !< the units
76  character(len=:), allocatable, private :: modname !< the module
77  character(len=:), allocatable, private :: realm !< String to set as the value
78  !! to the modeling_realm attribute
79  character(len=:), allocatable, private :: interp_method !< The interp method to be used
80  !! when regridding the field in post-processing.
81  !! Valid options are "conserve_order1",
82  !! "conserve_order2", and "none".
83  integer, allocatable, dimension(:), private :: frequency !< specifies the frequency
84  integer, allocatable, private :: tile_count !< The number of tiles
85  integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs
86  class(diagdomain_t), pointer, private :: domain !< Domain
87  INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN",
88  !! "TWO_D_DOMAIN", or "UG_DOMAIN")
89  integer, allocatable, private :: area, volume !< The Area and Volume
90  class(*), allocatable, private :: missing_value !< The missing fill value
91  class(*), allocatable, private :: data_range(:) !< The range of the variable data
92  type(fmsdiaginputbuffer_t), allocatable :: input_data_buffer !< Input buffer object for when buffering
93  !! data
94  logical, allocatable, private :: multiple_send_data!< .True. if send_data is called multiple
95  !! times for the same model time
96  logical, allocatable, private :: data_buffer_is_allocated !< True if the buffer has
97  !! been allocated
98  logical, allocatable, private :: math_needs_to_be_done !< If true, do math
99  !! functions. False when done.
100  logical, allocatable :: buffer_allocated !< True if a buffer pointed by
101  !! the corresponding index in
102  !! buffer_ids(:) is allocated.
103  logical, allocatable :: mask(:,:,:,:) !< Mask passed in send_data
104  logical :: halo_present = .false. !< set if any halos are used
105  contains
106 ! procedure :: send_data => fms_send_data !!TODO
107 ! Get ID functions
108  procedure :: get_id => fms_diag_get_id
109  procedure :: id_from_name => diag_field_id_from_name
110  procedure :: copy => copy_diag_obj
111  procedure :: register => fms_register_diag_field_obj !! Merely initialize fields.
112  procedure :: setid => set_diag_id
113  procedure :: set_type => set_vartype
114  procedure :: set_data_buffer => set_data_buffer
115  procedure :: prepare_data_buffer
116  procedure :: init_data_buffer
117  procedure :: set_data_buffer_is_allocated
118  procedure :: set_send_data_time
119  procedure :: get_send_data_time
120  procedure :: is_data_buffer_allocated
121  procedure :: allocate_data_buffer
122  procedure :: set_math_needs_to_be_done => set_math_needs_to_be_done
123  procedure :: add_attribute => diag_field_add_attribute
124  procedure :: vartype_inq => what_is_vartype
125  procedure :: set_var_is_masked
126  procedure :: get_var_is_masked
127 ! Check functions
128  procedure :: is_static => diag_obj_is_static
129  procedure :: is_scalar
130  procedure :: is_registered => get_registered
131  procedure :: is_registeredb => diag_obj_is_registered
132  procedure :: is_mask_variant => get_mask_variant
133  procedure :: is_local => get_local
134 ! Is variable allocated check functions
135 !TODO procedure :: has_diag_field
136  procedure :: has_diag_id
137  procedure :: has_attributes
138  procedure :: has_static
139  procedure :: has_registered
140  procedure :: has_mask_variant
141  procedure :: has_local
142  procedure :: has_vartype
143  procedure :: has_varname
144  procedure :: has_longname
145  procedure :: has_standname
146  procedure :: has_units
147  procedure :: has_modname
148  procedure :: has_realm
149  procedure :: has_interp_method
150  procedure :: has_frequency
151  procedure :: has_tile_count
152  procedure :: has_axis_ids
153  procedure :: has_area
154  procedure :: has_volume
155  procedure :: has_missing_value
156  procedure :: has_data_range
157  procedure :: has_input_data_buffer
158 ! Get functions
159  procedure :: get_attributes
160  procedure :: get_static
161  procedure :: get_registered
162  procedure :: get_mask_variant
163  procedure :: get_local
164  procedure :: get_vartype
165  procedure :: get_varname
166  procedure :: get_longname
167  procedure :: get_standname
168  procedure :: get_units
169  procedure :: get_modname
170  procedure :: get_realm
171  procedure :: get_interp_method
172  procedure :: get_frequency
173  procedure :: get_tile_count
174  procedure :: get_area
175  procedure :: get_volume
176  procedure :: get_missing_value
177  procedure :: get_data_range
178  procedure :: get_axis_id
179  procedure :: get_data_buffer
180  procedure :: get_mask
181  procedure :: get_weight
182  procedure :: dump_field_obj
183  procedure :: get_domain
184  procedure :: get_type_of_domain
185  procedure :: set_file_ids
186  procedure :: get_dimnames
187  procedure :: get_var_skind
188  procedure :: get_longname_to_write
189  procedure :: get_multiple_send_data
190  procedure :: write_field_metadata
191  procedure :: get_chunksizes
192  procedure :: write_coordinate_attribute
193  procedure :: get_math_needs_to_be_done
194  procedure :: add_area_volume
195  procedure :: append_time_cell_methods
196  procedure :: get_file_ids
197  procedure :: set_mask
198  procedure :: allocate_mask
199  procedure :: set_halo_present
200  procedure :: is_halo_present
201  procedure :: find_missing_value
202  procedure :: has_mask_allocated
203  procedure :: is_variable_in_file
204  procedure :: get_field_file_name
205  procedure :: generate_associated_files_att
206 end type fmsdiagfield_type
207 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
208 type(fmsdiagfield_type) :: null_ob
209 
210 logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized
211 
212 !type(fmsDiagField_type) :: diag_object_placeholder (10)
213 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
214 public :: fmsdiagfield_type
215 public :: fms_diag_fields_object_init
216 public :: null_ob
217 public :: fms_diag_field_object_end
218 public :: get_default_missing_value
219 public :: check_for_slices
220 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
221 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
222  CONTAINS
223 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
224 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
225 
226 !> @brief Deallocates the array of diag_objs
227 subroutine fms_diag_field_object_end (ob)
228  class(fmsdiagfield_type), allocatable, intent(inout) :: ob(:) !< diag field object
229  if (allocated(ob)) deallocate(ob)
230  module_is_initialized = .false.
231 end subroutine fms_diag_field_object_end
232 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
233 !> \Description Allocates the diad field object array.
234 !! Sets the diag_id to the not registered value.
235 !! Initializes the number of registered variables to be 0
236 logical function fms_diag_fields_object_init(ob)
237  type(fmsdiagfield_type), allocatable, intent(inout) :: ob(:) !< diag field object
238  integer :: i !< For looping
239  allocate(ob(get_num_unique_fields()))
240  do i = 1,size(ob)
241  ob(i)%diag_id = diag_not_registered !null_ob%diag_id
242  ob(i)%registered = .false.
243  enddo
244  module_is_initialized = .true.
245  fms_diag_fields_object_init = .true.
246 end function fms_diag_fields_object_init
247 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
248 !> \Description Fills in and allocates (when necessary) the values in the diagnostic object
249 subroutine fms_register_diag_field_obj &
250  (this, modname, varname, diag_field_indices, diag_axis, axes, &
251  longname, units, missing_value, varrange, mask_variant, standname, &
252  do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static, &
253  multiple_send_data)
254 
255  class(fmsdiagfield_type), INTENT(inout) :: this !< Diaj_obj to fill
256  CHARACTER(len=*), INTENT(in) :: modname !< The module name
257  CHARACTER(len=*), INTENT(in) :: varname !< The variable name
258  integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
259  !! in the yaml object
260  class(fmsdiagaxiscontainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis
261  INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies
262  CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
263  CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables
264  CHARACTER(len=*), OPTIONAL, INTENT(in) :: standname !< The variables stanard name
265  class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a attribute
266  class(*), OPTIONAL, INTENT(in) :: varrange(:) !< Range to add as a attribute (#1896)
267  LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask
268  LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged
269  CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Error message to be passed back up
270  CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
271  !! regridding the field in post-processing.
272  !! Valid options are "conserve_order1",
273  !! "conserve_order2", and "none".
274  INTEGER, OPTIONAL, INTENT(in) :: tile_count !< the number of tiles
275  INTEGER, OPTIONAL, INTENT(in) :: area !< diag_field_id of the cell area field
276  INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field
277  CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
278  !! modeling_realm attribute
279  LOGICAL, OPTIONAL, INTENT(in) :: static !< Set to true if it is a static field
280  LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple
281  !! times for the same time
282  integer :: i, j !< for looponig over field/axes indices
283  character(len=:), allocatable, target :: a_name_tmp !< axis name tmp
284  type(diagyamlfilesvar_type), pointer :: yaml_var_ptr !< pointer this fields yaml variable entries
285 
286 !> Fill in information from the register call
287  this%varname = trim(varname)
288  this%modname = trim(modname)
289 
290 !> Add the yaml info to the diag_object
291  this%diag_field = get_diag_fields_entries(diag_field_indices)
292 
293  if (present(static)) then
294  this%static = static
295  else
296  this%static = .false.
297  endif
298 
299 !> Add axis and domain information
300  if (present(axes)) then
301 
302  this%scalar = .false.
303  this%axis_ids = axes
304  call get_domain_and_domain_type(diag_axis, this%axis_ids, this%type_of_domain, this%domain, this%varname)
305 
306  ! store dim names for output
307  ! cant use this%diag_field since they are copies
308  do i=1, SIZE(diag_field_indices)
309  yaml_var_ptr => diag_yaml%get_diag_field_from_id(diag_field_indices(i))
310  ! add dim names from axes
311  do j=1, SIZE(axes)
312  a_name_tmp = diag_axis(axes(j))%axis%get_axis_name( yaml_var_ptr%is_file_subregional())
313  if(yaml_var_ptr%has_var_zbounds() .and. a_name_tmp .eq. 'z') &
314  a_name_tmp = trim(a_name_tmp)//"_sub01"
315  call yaml_var_ptr%add_axis_name(a_name_tmp)
316  enddo
317  ! add time_of_day_N dimension if diurnal
318  if(yaml_var_ptr%has_n_diurnal()) then
319  a_name_tmp = "time_of_day_"// int2str(yaml_var_ptr%get_n_diurnal())
320  call yaml_var_ptr%add_axis_name(a_name_tmp)
321  endif
322  ! add time dimension if not static
323  if(.not. this%static) then
324  a_name_tmp = "time"
325  call yaml_var_ptr%add_axis_name(a_name_tmp)
326  endif
327  enddo
328  else
329  !> The variable is a scalar
330  this%scalar = .true.
331  this%type_of_domain = no_domain
332  this%domain => null()
333  ! store dim name for output (just the time if not static and no axes)
334  if(.not. this%static) then
335  do i=1, SIZE(diag_field_indices)
336  a_name_tmp = "time"
337  yaml_var_ptr => diag_yaml%get_diag_field_from_id(diag_field_indices(i))
338  call yaml_var_ptr%add_axis_name(a_name_tmp)
339  enddo
340  endif
341  endif
342  nullify(yaml_var_ptr)
343 
344 !> get the optional arguments if included and the diagnostic is in the diag table
345  if (present(longname)) this%longname = trim(longname)
346  if (present(standname)) this%standname = trim(standname)
347  do i=1, SIZE(diag_field_indices)
348  yaml_var_ptr => diag_yaml%get_diag_field_from_id(diag_field_indices(i))
349 
350  !! Add standard name to the diag_yaml object, so that it can be used when writing the diag_manifest
351  call yaml_var_ptr%add_standname(standname)
352  enddo
353 
354  !> Ignore the units if they are set to "none". This is to reproduce previous diag_manager behavior
355  if (present(units)) then
356  if (trim(units) .ne. "none") this%units = trim(units)
357  endif
358  if (present(realm)) this%realm = trim(realm)
359  if (present(interp_method)) this%interp_method = trim(interp_method)
360 
361  if (present(tile_count)) then
362  allocate(this%tile_count)
363  this%tile_count = tile_count
364  endif
365 
366  if (present(missing_value)) then
367  select type (missing_value)
368  type is (integer(kind=i4_kind))
369  allocate(integer(kind=i4_kind) :: this%missing_value)
370  this%missing_value = missing_value
371  type is (integer(kind=i8_kind))
372  allocate(integer(kind=i8_kind) :: this%missing_value)
373  this%missing_value = missing_value
374  type is (real(kind=r4_kind))
375  allocate(real(kind=r4_kind) :: this%missing_value)
376  this%missing_value = missing_value
377  type is (real(kind=r8_kind))
378  allocate(real(kind=r8_kind) :: this%missing_value)
379  this%missing_value = missing_value
380  class default
381  call mpp_error("fms_register_diag_field_obj", &
382  "The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",&
383  fatal)
384  end select
385  endif
386 
387  if (present(varrange)) then
388  !> See #1896
389  if (size(varrange) /= 2) call mpp_error("fms_register_diag_field_obj", &
390  "The varRange passed to register a diagnostic must have exactly 2 elements (/min, max/)", fatal)
391  select type (varrange)
392  type is (integer(kind=i4_kind))
393  allocate(integer(kind=i4_kind) :: this%data_range(2))
394  this%data_RANGE = varrange
395  type is (integer(kind=i8_kind))
396  allocate(integer(kind=i8_kind) :: this%data_range(2))
397  this%data_RANGE = varrange
398  type is (real(kind=r4_kind))
399  allocate(integer(kind=i4_kind) :: this%data_range(2))
400  this%data_RANGE = varrange
401  type is (real(kind=r8_kind))
402  allocate(integer(kind=r8_kind) :: this%data_range(2))
403  this%data_RANGE = varrange
404  class default
405  call mpp_error("fms_register_diag_field_obj", &
406  "The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",&
407  fatal)
408  end select
409  endif
410 
411  if (present(area)) then
412  if (area < 0) call mpp_error("fms_register_diag_field_obj", &
413  "The area id passed with field_name"//trim(varname)//" has not been registered. &
414  &Check that there is a register_diag_field call for the AREA measure and that is in the &
415  &diag_table.yaml", fatal)
416  allocate(this%area)
417  this%area = area
418  endif
419 
420  if (present(volume)) then
421  if (volume < 0) call mpp_error("fms_register_diag_field_obj", &
422  "The volume id passed with field_name"//trim(varname)//" has not been registered. &
423  &Check that there is a register_diag_field call for the VOLUME measure and that is in the &
424  &diag_table.yaml", fatal)
425  allocate(this%volume)
426  this%volume = volume
427  endif
428 
429  this%mask_variant = .false.
430  if (present(mask_variant)) then
431  this%mask_variant = mask_variant
432  endif
433 
434  if (present(do_not_log)) then
435  allocate(this%do_not_log)
436  this%do_not_log = do_not_log
437  endif
438 
439  if (present(multiple_send_data)) then
440  this%multiple_send_data = multiple_send_data
441  else
442  this%multiple_send_data = .false.
443  endif
444 
445  !< Allocate space for any additional variable attributes
446  !< These will be fill out when calling `diag_field_add_attribute`
447  allocate(this%attributes(max_field_attributes))
448  this%num_attributes = 0
449  this%registered = .true.
450 end subroutine fms_register_diag_field_obj
451 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
452 
453 !> \brief Sets the diag_id. This can only be done if a variable is unregistered
454 subroutine set_diag_id(this , id)
455  class(fmsdiagfield_type) , intent(inout):: this
456  integer :: id
457  if (allocated(this%registered)) then
458  if (this%registered) then
459  call mpp_error("set_diag_id", "The variable"//this%varname//" is already registered", fatal)
460  else
461  this%diag_id = id
462  endif
463  else
464  this%diag_id = id
465  endif
466 end subroutine set_diag_id
467 
468 !> \brief Find the type of the variable and store it in the object
469 subroutine set_vartype(objin , var)
470  class(fmsdiagfield_type) , intent(inout):: objin
471  class(*) :: var
472  select type (var)
473  type is (real(kind=8))
474  objin%vartype = r8
475  type is (real(kind=4))
476  objin%vartype = r4
477  type is (integer(kind=8))
478  objin%vartype = i8
479  type is (integer(kind=4))
480  objin%vartype = i4
481  type is (character(*))
482  objin%vartype = string
483  class default
484  objin%vartype = null_type_int
485  call mpp_error("set_vartype", "The variable"//objin%varname//" is not a supported type "// &
486  " r8, r4, i8, i4, or string.", warning)
487  end select
488 end subroutine set_vartype
489 
490 !> @brief Sets the time send data was called last
491 subroutine set_send_data_time (this, time)
492  class(fmsdiagfield_type) , intent(inout):: this !< The field object
493  type(time_type), intent(in) :: time !< Current model time
494 
495  call this%input_data_buffer%set_send_data_time(time)
496 end subroutine set_send_data_time
497 
498 !> @brief Get the time send data was called last
499 !! @result the time send data was called last
500 function get_send_data_time(this) &
501  result(rslt)
502  class(fmsdiagfield_type) , intent(in):: this !< The field object
503  type(time_type) :: rslt
504 
505  rslt = this%input_data_buffer%get_send_data_time()
506 end function get_send_data_time
507 
508 !> @brief Prepare the input_data_buffer to do the reduction method
509 subroutine prepare_data_buffer(this)
510  class(fmsdiagfield_type) , intent(inout):: this !< The field object
511 
512  if (.not. this%multiple_send_data) return
513  if (this%mask_variant) return
514  call this%input_data_buffer%prepare_input_buffer_object(this%modname//":"//this%varname)
515 end subroutine prepare_data_buffer
516 
517 !> @brief Initialize the input_data_buffer
518 subroutine init_data_buffer(this)
519  class(fmsdiagfield_type) , intent(inout):: this !< The field object
520 
521  if (.not. this%multiple_send_data) return
522  if (this%mask_variant) return
523  call this%input_data_buffer%init_input_buffer_object()
524 end subroutine init_data_buffer
525 
526 !> @brief Adds the input data to the buffered data.
527 subroutine set_data_buffer (this, input_data, mask, weight, is, js, ks, ie, je, ke)
528  class(fmsdiagfield_type) , intent(inout):: this !< The field object
529  class(*), intent(in) :: input_data(:,:,:,:) !< The input array
530  logical, intent(in) :: mask(:,:,:,:) !< Mask that is passed into
531  !! send_data
532  real(kind=r8_kind), intent(in) :: weight !< The field weight
533  integer, intent(in) :: is, js, ks !< Starting indicies of the field_data relative
534  !! to the compute domain (1 based)
535  integer, intent(in) :: ie, je, ke !< Ending indicies of the field_data relative
536  !! to the compute domain (1 based)
537 
538  character(len=128) :: err_msg !< Error msg
539  if (.not.this%data_buffer_is_allocated) &
540  call mpp_error ("set_data_buffer", "The data buffer for the field "//trim(this%varname)//" was unable to be "//&
541  "allocated.", fatal)
542  if (this%multiple_send_data) then
543  err_msg = this%input_data_buffer%update_input_buffer_object(input_data, is, js, ks, ie, je, ke, &
544  mask, this%mask, this%mask_variant, this%var_is_masked)
545  else
546  this%mask(is:ie, js:je, ks:ke, :) = mask
547  err_msg = this%input_data_buffer%set_input_buffer_object(input_data, weight, is, js, ks, ie, je, ke)
548  endif
549  if (trim(err_msg) .ne. "") call mpp_error(fatal, "Field:"//trim(this%varname)//" -"//trim(err_msg))
550 
551 end subroutine set_data_buffer
552 !> Allocates the global data buffer for a given field using a single thread. Returns true when the
553 !! buffer is allocated
554 logical function allocate_data_buffer(this, input_data, diag_axis)
555  class(fmsdiagfield_type), target, intent(inout):: this !< The field object
556  class(*), dimension(:,:,:,:), intent(in) :: input_data !< The input array
557  class(fmsdiagaxiscontainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis
558 
559  character(len=128) :: err_msg !< Error msg
560  err_msg = ""
561 
562  allocate(this%input_data_buffer)
563  err_msg = this%input_data_buffer%allocate_input_buffer_object(input_data, this%axis_ids, diag_axis)
564  if (trim(err_msg) .ne. "") then
565  call mpp_error(fatal, "Field:"//trim(this%varname)//" -"//trim(err_msg))
566  return
567  endif
568 
569  allocate_data_buffer = .true.
570 end function allocate_data_buffer
571 !> Sets the flag saying that the math functions need to be done
572 subroutine set_math_needs_to_be_done (this, math_needs_to_be_done)
573  class(fmsdiagfield_type) , intent(inout):: this
574  logical, intent (in) :: math_needs_to_be_done !< Flag saying that the math functions need to be done
575  this%math_needs_to_be_done = math_needs_to_be_done
576 end subroutine set_math_needs_to_be_done
577 
578 !> @brief Set the mask_variant to .true.
579 subroutine set_var_is_masked(this, is_masked)
580  class(fmsdiagfield_type) , intent(inout):: this !< The diag field object
581  logical, intent (in) :: is_masked !< .True. if the field is masked
582 
583  this%var_is_masked = is_masked
584 end subroutine set_var_is_masked
585 
586 !> @brief Queries a field for the var_is_masked variable
587 !! @return var_is_masked
588 function get_var_is_masked(this) &
589  result(rslt)
590  class(fmsdiagfield_type) , intent(inout):: this !< The diag field object
591  logical :: rslt !< .True. if the field is masked
592 
593  rslt = this%var_is_masked
594 end function get_var_is_masked
595 
596 !> @brief Sets the flag saying that the data buffer is allocated
597 subroutine set_data_buffer_is_allocated (this, data_buffer_is_allocated)
598  class(fmsdiagfield_type) , intent(inout) :: this !< The field object
599  logical, intent (in) :: data_buffer_is_allocated !< .true. if the
600  !! data buffer is allocated
601  this%data_buffer_is_allocated = data_buffer_is_allocated
602 end subroutine set_data_buffer_is_allocated
603 
604 !> @brief Determine if the data_buffer is allocated
605 !! @return logical indicating if the data_buffer is allocated
606 pure logical function is_data_buffer_allocated (this)
607  class(fmsdiagfield_type) , intent(in) :: this !< The field object
608 
609  is_data_buffer_allocated = .false.
610  if (allocated(this%data_buffer_is_allocated)) is_data_buffer_allocated = this%data_buffer_is_allocated
611 
612 end function
613 !> \brief Prints to the screen what type the diag variable is
614 subroutine what_is_vartype(this)
615  class(fmsdiagfield_type) , intent(inout):: this
616  if (.not. allocated(this%vartype)) then
617  call mpp_error("what_is_vartype", "The variable type has not been set prior to this call", warning)
618  return
619  endif
620  select case (this%vartype)
621  case (r8)
622  call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
623  " is REAL(kind=8)", note)
624  case (r4)
625  call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
626  " is REAL(kind=4)", note)
627  case (i8)
628  call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
629  " is INTEGER(kind=8)", note)
630  case (i4)
631  call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
632  " is INTEGER(kind=4)", note)
633  case (string)
634  call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
635  " is CHARACTER(*)", note)
636  case (null_type_int)
637  call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
638  " was not set", warning)
639  case default
640  call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
641  " is not supported by diag_manager", fatal)
642  end select
643 end subroutine what_is_vartype
644 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
645 
646 !> \brief Copies the calling object into the object that is the argument of the subroutine
647 subroutine copy_diag_obj(this , objout)
648  class(fmsdiagfield_type) , intent(in) :: this
649  class(fmsdiagfield_type) , intent(inout) , allocatable :: objout !< The destination of the copy
650 select type (objout)
651  class is (fmsdiagfield_type)
652 
653  if (allocated(this%registered)) then
654  objout%registered = this%registered
655  else
656  call mpp_error("copy_diag_obj", "You can only copy objects that have been registered",warning)
657  endif
658  objout%diag_id = this%diag_id
659 
660  if (allocated(this%attributes)) objout%attributes = this%attributes
661  objout%static = this%static
662  if (allocated(this%frequency)) objout%frequency = this%frequency
663  if (allocated(this%varname)) objout%varname = this%varname
664 end select
665 end subroutine copy_diag_obj
666 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
667 
668 !> \brief Returns the ID integer for a variable
669 !! \return the diag ID
670 pure integer function fms_diag_get_id (this) result(diag_id)
671  class(fmsdiagfield_type) , intent(in) :: this
672 !> Check if the diag_object registration has been done
673  if (allocated(this%registered)) then
674  !> Return the diag_id if the variable has been registered
675  diag_id = this%diag_id
676  else
677 !> If the variable is not regitered, then return the unregistered value
678  diag_id = diag_not_registered
679  endif
680 end function fms_diag_get_id
681 
682 !> Function to return a character (string) representation of the most basic
683 !> object identity info. Intended for debugging and warning. The format produced is:
684 !> [this: o.varname(string|?), vartype (string|?), o.registered (T|F|?), diag_id (id|?)].
685 !> A questionmark "?" is set in place of the variable that is not yet allocated
686 !>TODO: Add diag_id ?
687 function fms_diag_obj_as_string_basic(this) result(rslt)
688  class(fmsdiagfield_type), allocatable, intent(in) :: this
689  character(:), allocatable :: rslt
690  character (len=:), allocatable :: registered, vartype, varname, diag_id
691  if ( .not. allocated (this)) then
692  varname = "?"
693  vartype = "?"
694  registered = "?"
695  diag_id = "?"
696  rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]"
697  return
698  end if
699 
700 ! if(allocated (this%registered)) then
701 ! registered = logical_to_cs (this%registered)
702 ! else
703 ! registered = "?"
704 ! end if
705 
706 ! if(allocated (this%diag_id)) then
707 ! diag_id = int_to_cs (this%diag_id)
708 ! else
709 ! diag_id = "?"
710 ! end if
711 
712 ! if(allocated (this%vartype)) then
713 ! vartype = int_to_cs (this%vartype)
714 ! else
715 ! registered = "?"
716 ! end if
717 
718  if(allocated (this%varname)) then
719  varname = this%varname
720  else
721  registered = "?"
722  end if
723 
724  rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]"
725 
726 end function fms_diag_obj_as_string_basic
727 
728 
729 function diag_obj_is_registered (this) result (rslt)
730  class(fmsdiagfield_type), intent(in) :: this
731  logical :: rslt
732  rslt = this%registered
733 end function diag_obj_is_registered
734 
735 function diag_obj_is_static (this) result (rslt)
736  class(fmsdiagfield_type), intent(in) :: this
737  logical :: rslt
738  rslt = .false.
739  if (allocated(this%static)) rslt = this%static
740 end function diag_obj_is_static
741 
742 !> @brief Determine if the field is a scalar
743 !! @return .True. if the field is a scalar
744 function is_scalar (this) result (rslt)
745  class(fmsdiagfield_type), intent(in) :: this !< diag_field object
746  logical :: rslt
747  rslt = this%scalar
748 end function is_scalar
749 
750 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
751 !! Get functions
752 
753 !> @brief Gets attributes
754 !! @return A pointer to the attributes of the diag_obj, null pointer if there are no attributes
755 function get_attributes (this) &
756 result(rslt)
757  class(fmsdiagfield_type), target, intent(in) :: this !< diag object
758  type(fmsdiagattribute_type), pointer :: rslt(:)
759 
760  rslt => null()
761  if (this%num_attributes > 0 ) rslt => this%attributes
762 end function get_attributes
763 
764 !> @brief Gets static
765 !! @return copy of variable static
766 pure function get_static (this) &
767 result(rslt)
768  class(fmsdiagfield_type), intent(in) :: this !< diag object
769  logical :: rslt
770  rslt = this%static
771 end function get_static
772 
773 !> @brief Gets regisetered
774 !! @return copy of registered
775 pure function get_registered (this) &
776 result(rslt)
777  class(fmsdiagfield_type), intent(in) :: this !< diag object
778  logical :: rslt
779  rslt = this%registered
780 end function get_registered
781 
782 !> @brief Gets mask variant
783 !! @return copy of mask variant
784 pure function get_mask_variant (this) &
785 result(rslt)
786  class(fmsdiagfield_type), intent(in) :: this !< diag object
787  logical :: rslt
788  rslt = .false.
789  if (allocated(this%mask_variant)) rslt = this%mask_variant
790 end function get_mask_variant
791 
792 !> @brief Gets local
793 !! @return copy of local
794 pure function get_local (this) &
795 result(rslt)
796  class(fmsdiagfield_type), intent(in) :: this !< diag object
797  logical :: rslt
798  rslt = this%local
799 end function get_local
800 
801 !> @brief Gets vartype
802 !! @return copy of The integer related to the variable type
803 pure function get_vartype (this) &
804 result(rslt)
805  class(fmsdiagfield_type), intent(in) :: this !< diag object
806  integer :: rslt
807  rslt = this%vartype
808 end function get_vartype
809 
810 !> @brief Gets varname
811 !! @return copy of the variable name
812 function get_varname (this, filename, to_write) &
813 result(rslt)
814  class(fmsdiagfield_type), intent(in) :: this !< diag object
815  character(len=*), optional, intent(in) :: filename !< Name of the diag_file we are writing to
816  logical, optional, intent(in) :: to_write !< .true. if getting the varname that will be writen to the file
817  character(len=:), allocatable :: rslt
818 
819  integer :: i
820 
821  rslt = this%varname
822 
823  !< If writing the varname can be the outname which is defined in the yaml
824  if (present(to_write)) then
825  if (to_write) then
826  if (.not. present(filename)) then
827  call mpp_error(fatal, "get_varname was called using the to_write optional argument, "//&
828  "but a filename was not provided!")
829  endif
830  ! Loop through all of the file the variable is in and find the outputname of the variable
831  do i = 1, size(this%diag_field)
832  if (trim(filename) .eq. trim(this%diag_field(i)%get_var_fname())) then
833  rslt = this%diag_field(i)%get_var_outname()
834  return
835  endif
836  enddo
837  endif
838  endif
839 
840 end function get_varname
841 
842 !> @brief Gets longname
843 !! @return copy of the variable long name or a single string if there is no long name
844 pure function get_longname (this) &
845 result(rslt)
846  class(fmsdiagfield_type), intent(in) :: this !< diag object
847  character(len=:), allocatable :: rslt
848  if (allocated(this%longname)) then
849  rslt = this%longname
850  else
851  rslt = diag_null_string
852  endif
853 end function get_longname
854 
855 !> @brief Gets standname
856 !! @return copy of the standard name or an empty string if standname is not allocated
857 pure function get_standname (this) &
858 result(rslt)
859  class(fmsdiagfield_type), intent(in) :: this !< diag object
860  character(len=:), allocatable :: rslt
861  if (allocated(this%standname)) then
862  rslt = this%standname
863  else
864  rslt = diag_null_string
865  endif
866 end function get_standname
867 
868 !> @brief Gets units
869 !! @return copy of the units or an empty string if not allocated
870 pure function get_units (this) &
871 result(rslt)
872  class(fmsdiagfield_type), intent(in) :: this !< diag object
873  character(len=:), allocatable :: rslt
874  if (allocated(this%units)) then
875  rslt = this%units
876  else
877  rslt = diag_null_string
878  endif
879 end function get_units
880 
881 !> @brief Gets modname
882 !! @return copy of the module name that the variable is in or an empty string if not allocated
883 pure function get_modname (this) &
884 result(rslt)
885  class(fmsdiagfield_type), intent(in) :: this !< diag object
886  character(len=:), allocatable :: rslt
887  if (allocated(this%modname)) then
888  rslt = this%modname
889  else
890  rslt = diag_null_string
891  endif
892 end function get_modname
893 
894 !> @brief Gets realm
895 !! @return copy of the variables modeling realm or an empty string if not allocated
896 pure function get_realm (this) &
897 result(rslt)
898  class(fmsdiagfield_type), intent(in) :: this !< diag object
899  character(len=:), allocatable :: rslt
900  if (allocated(this%realm)) then
901  rslt = this%realm
902  else
903  rslt = diag_null_string
904  endif
905 end function get_realm
906 
907 !> @brief Gets interp_method
908 !! @return copy of The interpolation method or an empty string if not allocated
909 pure function get_interp_method (this) &
910 result(rslt)
911  class(fmsdiagfield_type), intent(in) :: this !< diag object
912  character(len=:), allocatable :: rslt
913  if (allocated(this%interp_method)) then
914  rslt = this%interp_method
915  else
916  rslt = diag_null_string
917  endif
918 end function get_interp_method
919 
920 !> @brief Gets frequency
921 !! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated
922 pure function get_frequency (this) &
923 result(rslt)
924  class(fmsdiagfield_type), intent(in) :: this !< diag object
925  integer, allocatable, dimension (:) :: rslt
926  if (allocated(this%frequency)) then
927  allocate (rslt(size(this%frequency)))
928  rslt = this%frequency
929  else
930  allocate (rslt(1))
931  rslt = diag_null
932  endif
933 end function get_frequency
934 
935 !> @brief Gets tile_count
936 !! @return copy of the number of tiles or diag_null if tile_count is not allocated
937 pure function get_tile_count (this) &
938 result(rslt)
939  class(fmsdiagfield_type), intent(in) :: this !< diag object
940  integer :: rslt
941  if (allocated(this%tile_count)) then
942  rslt = this%tile_count
943  else
944  rslt = diag_null
945  endif
946 end function get_tile_count
947 
948 !> @brief Gets area
949 !! @return copy of the area or diag_null if not allocated
950 pure function get_area (this) &
951 result(rslt)
952  class(fmsdiagfield_type), intent(in) :: this !< diag object
953  integer :: rslt
954  if (allocated(this%area)) then
955  rslt = this%area
956  else
957  rslt = diag_null
958  endif
959 end function get_area
960 
961 !> @brief Gets volume
962 !! @return copy of the volume or diag_null if volume is not allocated
963 pure function get_volume (this) &
964 result(rslt)
965  class(fmsdiagfield_type), intent(in) :: this !< diag object
966  integer :: rslt
967  if (allocated(this%volume)) then
968  rslt = this%volume
969  else
970  rslt = diag_null
971  endif
972 end function get_volume
973 
974 !> @brief Gets missing_value
975 !! @return copy of The missing value
976 !! @note Netcdf requires the type of the variable and the type of the missing_value and _Fillvalue to be the same
977 !! var_type is the type of the variable which may not be in the same type as the missing_value in the register call
978 !! For example, if compiling with r8 but the in diag_table.yaml the kind is r4
979 function get_missing_value (this, var_type) &
980 result(rslt)
981  class(fmsdiagfield_type), intent(in) :: this !< diag object
982  integer, intent(in) :: var_type !< The type of the variable as it will writen to the netcdf file
983  !! and the missing value is return as
984 
985  class(*),allocatable :: rslt
986 
987  if (.not. allocated(this%missing_value)) then
988  call mpp_error ("get_missing_value", &
989  "The missing value is not allocated", fatal)
990  endif
991 
992  !< The select types are needed so that the missing_value can be correctly converted and copied as the needed variable
993  !! type
994  select case (var_type)
995  case (r4)
996  allocate (real(kind=r4_kind) :: rslt)
997  select type (miss => this%missing_value)
998  type is (real(kind=r4_kind))
999  select type (rslt)
1000  type is (real(kind=r4_kind))
1001  rslt = real(miss, kind=r4_kind)
1002  end select
1003  type is (real(kind=r8_kind))
1004  select type (rslt)
1005  type is (real(kind=r4_kind))
1006  rslt = real(miss, kind=r4_kind)
1007  end select
1008  end select
1009  case (r8)
1010  allocate (real(kind=r8_kind) :: rslt)
1011  select type (miss => this%missing_value)
1012  type is (real(kind=r4_kind))
1013  select type (rslt)
1014  type is (real(kind=r8_kind))
1015  rslt = real(miss, kind=r8_kind)
1016  end select
1017  type is (real(kind=r8_kind))
1018  select type (rslt)
1019  type is (real(kind=r8_kind))
1020  rslt = real(miss, kind=r8_kind)
1021  end select
1022  end select
1023  end select
1024 
1025 end function get_missing_value
1026 
1027 !> @brief Gets data_range
1028 !! @return copy of the data range
1029 !! @note Netcdf requires the type of the variable and the type of the range to be the same
1030 !! var_type is the type of the variable which may not be in the same type as the range in the register call
1031 !! For example, if compiling with r8 but the in diag_table.yaml the kind is r4
1032 function get_data_range (this, var_type) &
1033 result(rslt)
1034  class(fmsdiagfield_type), intent(in) :: this !< diag object
1035  integer, intent(in) :: var_type !< The type of the variable as it will writen to the netcdf file
1036  !! and the data_range is returned as
1037  class(*),allocatable :: rslt(:)
1038 
1039  if ( .not. allocated(this%data_RANGE)) call mpp_error ("get_data_RANGE", &
1040  "The data_RANGE value is not allocated", fatal)
1041 
1042  !< The select types are needed so that the range can be correctly converted and copied as the needed variable
1043  !! type
1044  select case (var_type)
1045  case (r4)
1046  allocate (real(kind=r4_kind) :: rslt(2))
1047  select type (r => this%data_RANGE)
1048  type is (real(kind=r4_kind))
1049  select type (rslt)
1050  type is (real(kind=r4_kind))
1051  rslt = real(r, kind=r4_kind)
1052  end select
1053  type is (real(kind=r8_kind))
1054  select type (rslt)
1055  type is (real(kind=r4_kind))
1056  rslt = real(r, kind=r4_kind)
1057  end select
1058  end select
1059  case (r8)
1060  allocate (real(kind=r8_kind) :: rslt(2))
1061  select type (r => this%data_RANGE)
1062  type is (real(kind=r4_kind))
1063  select type (rslt)
1064  type is (real(kind=r8_kind))
1065  rslt = real(r, kind=r8_kind)
1066  end select
1067  type is (real(kind=r8_kind))
1068  select type (rslt)
1069  type is (real(kind=r8_kind))
1070  rslt = real(r, kind=r8_kind)
1071  end select
1072  end select
1073  end select
1074 end function get_data_range
1075 
1076 !> @brief Gets axis_ids
1077 !! @return pointer to the axis ids
1078 function get_axis_id (this) &
1079 result(rslt)
1080  class(fmsdiagfield_type), target, intent(in) :: this !< diag object
1081  integer, pointer, dimension(:) :: rslt !< field's axis_ids
1082 
1083  if(allocated(this%axis_ids)) then
1084  rslt => this%axis_ids
1085  else
1086  rslt => null()
1087  endif
1088 end function get_axis_id
1089 
1090 !> @brief Gets field's domain
1091 !! @return pointer to the domain
1092 function get_domain (this) &
1093 result(rslt)
1094  class(fmsdiagfield_type), target, intent(in) :: this !< diag field
1095  class(diagdomain_t), pointer :: rslt !< field's domain
1096 
1097  if (associated(this%domain)) then
1098  rslt => this%domain
1099  else
1100  rslt => null()
1101  endif
1102 
1103 end function get_domain
1104 
1105 !> @brief Gets field's type of domain
1106 !! @return integer defining the type of domain (NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN)
1107 pure function get_type_of_domain (this) &
1108 result(rslt)
1109  class(fmsdiagfield_type), target, intent(in) :: this !< diag field
1110  integer :: rslt !< field's domain
1111 
1112  rslt = this%type_of_domain
1113 end function get_type_of_domain
1114 
1115 !> @brief Set the file ids of the files that the field belongs to
1116 subroutine set_file_ids(this, file_ids)
1117  class(fmsdiagfield_type), intent(inout) :: this !< diag field
1118  integer, intent(in) :: file_ids(:) !< File_ids to add
1119 
1120  allocate(this%file_ids(size(file_ids)))
1121  this%file_ids = file_ids
1122 end subroutine set_file_ids
1123 
1124 !> @brief Get the kind of the variable based on the yaml
1125 !! @return A string indicating the kind of the variable (as it is used in fms2_io)
1126 pure function get_var_skind(this, field_yaml) &
1127 result(rslt)
1128  class(fmsdiagfield_type), intent(in) :: this !< diag field
1129  type(diagyamlfilesvar_type), intent(in) :: field_yaml !< The corresponding yaml of the field
1130 
1131  character(len=:), allocatable :: rslt
1132 
1133  integer :: var_kind !< The integer corresponding to the kind of the variable (i4, i8, r4, r8)
1134 
1135  var_kind = field_yaml%get_var_kind()
1136  select case (var_kind)
1137  case (r4)
1138  rslt = "float"
1139  case (r8)
1140  rslt = "double"
1141  case (i4)
1142  rslt = "int"
1143  case (i8)
1144  rslt = "int64"
1145  end select
1146 
1147 end function get_var_skind
1148 
1149 !> @brief Get the multiple_send_data member of the field object
1150 !! @return multiple_send_data of the field
1151 pure function get_multiple_send_data(this) &
1152 result(rslt)
1153  class(fmsdiagfield_type), intent(in) :: this !< diag field
1154  logical :: rslt
1155  rslt = this%multiple_send_data
1156 end function get_multiple_send_data
1157 
1158 !> @brief Determine the long name to write for the field
1159 !! @return Long name to write
1160 pure function get_longname_to_write(this, field_yaml) &
1161 result(rslt)
1162  class(fmsdiagfield_type), intent(in) :: this !< diag field
1163  type(diagyamlfilesvar_type), intent(in) :: field_yaml !< The corresponding yaml of the field
1164 
1165  character(len=:), allocatable :: rslt
1166 
1167  rslt = field_yaml%get_var_longname() !! This is the long name defined in the yaml
1168  if (rslt .eq. "") then !! If the long name is not defined in the yaml, use the long name in the
1169  !! register_diag_field
1170  rslt = this%get_longname()
1171  else
1172  return
1173  endif
1174  if (rslt .eq. "") then !! If the long name is not defined in the yaml and in the register_diag_field
1175  !! use the variable name
1176  rslt = field_yaml%get_var_varname()
1177  endif
1178 end function get_longname_to_write
1179 
1180 !> @brief Determine the dimension names to use when registering the field to fms2_io
1181 subroutine get_dimnames(this, diag_axis, field_yaml, unlim_dimname, dimnames, is_regional, &
1182  file_axis_ids)
1183  class(fmsdiagfield_type), target, intent(inout) :: this !< diag field
1184  class(fmsdiagaxiscontainer_type), target, intent(in) :: diag_axis(:) !< Diag_axis object
1185  type(diagyamlfilesvar_type), intent(in) :: field_yaml !< Field info from diag_table yaml
1186  character(len=*), intent(in) :: unlim_dimname !< The name of unlimited dimension
1187  character(len=120), allocatable, intent(out) :: dimnames(:) !< Array of the dimension names
1188  !! for the field
1189  logical, intent(in) :: is_regional !< Flag indicating if the field is regional
1190  integer, intent(in) :: file_axis_ids(:) !< Ids of the file axis
1191 
1192  integer :: i !< For do loops
1193  integer :: naxis !< Number of axis for the field
1194  class(fmsdiagaxiscontainer_type), pointer :: axis_ptr !diag_axis(this%axis_ids(i), for convenience
1195  character(len=23) :: diurnal_axis_name !< name of the diurnal axis
1196 
1197  if (this%is_static()) then
1198  naxis = size(this%axis_ids)
1199  else
1200  naxis = size(this%axis_ids) + 1 !< Adding 1 more dimension for the unlimited dimension
1201  endif
1202 
1203  if (field_yaml%has_n_diurnal()) then
1204  naxis = naxis + 1 !< Adding 1 more dimension for the diurnal axis
1205  endif
1206 
1207  allocate(dimnames(naxis))
1208 
1209  !< Duplicated do loops for performance
1210  if (field_yaml%has_var_zbounds()) then
1211  do i = 1, size(this%axis_ids)
1212  axis_ptr => diag_axis(this%axis_ids(i))
1213  if (axis_ptr%axis%is_z_axis()) then
1214  call find_z_sub_axis_name(dimnames(i), this%axis_ids(i), file_axis_ids, field_yaml, diag_axis)
1215  else
1216  dimnames(i) = axis_ptr%axis%get_axis_name(is_regional)
1217  endif
1218  enddo
1219  else
1220  do i = 1, size(this%axis_ids)
1221  axis_ptr => diag_axis(this%axis_ids(i))
1222  dimnames(i) = axis_ptr%axis%get_axis_name(is_regional)
1223  enddo
1224  endif
1225 
1226  !< The second to last dimension is always the diurnal axis
1227  if (field_yaml%has_n_diurnal()) then
1228  WRITE (diurnal_axis_name,'(a,i2.2)') 'time_of_day_', field_yaml%get_n_diurnal()
1229  dimnames(naxis - 1) = trim(diurnal_axis_name)
1230  endif
1231 
1232  !< The last dimension is always the unlimited dimensions
1233  if (.not. this%is_static()) dimnames(naxis) = unlim_dimname
1234 
1235 end subroutine get_dimnames
1236 
1237 !> @brief Wrapper for the register_field call. The select types are needed so that the code can go
1238 !! in the correct interface
1239 subroutine register_field_wrap(fms2io_fileobj, varname, vartype, dimensions, chunksizes)
1240  class(fmsnetcdffile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write to
1241  character(len=*), INTENT(IN) :: varname !< Name of the variable
1242  character(len=*), INTENT(IN) :: vartype !< The type of the variable
1243  character(len=*), optional, INTENT(IN) :: dimensions(:) !< The dimension names of the field
1244  integer, optional, INTENT(IN) :: chunksizes(:) !< Chunksize to use, only relevant when using
1245  !! NETCDF-4 and the variable is domain decomposed
1246 
1247  select type(fms2io_fileobj)
1248  type is (fmsnetcdffile_t)
1249  call register_field(fms2io_fileobj, varname, vartype, dimensions)
1250  type is (fmsnetcdfdomainfile_t)
1251  call register_field(fms2io_fileobj, varname, vartype, dimensions, chunksizes=chunksizes)
1252  type is (fmsnetcdfunstructureddomainfile_t)
1253  call register_field(fms2io_fileobj, varname, vartype, dimensions)
1254  end select
1255 end subroutine register_field_wrap
1256 
1257 !> @brief Write the field's metadata to the file
1258 subroutine write_field_metadata(this, fms2io_fileobj, file_id, yaml_id, diag_axis, unlim_dimname, is_regional, &
1259  cell_measures, use_collective_writes, file_axis_ids)
1260  class(fmsdiagfield_type), target, intent(inout) :: this !< diag field
1261  class(fmsnetcdffile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write to
1262  integer, intent(in) :: file_id !< File id of the file to write to
1263  integer, intent(in) :: yaml_id !< Yaml id of the yaml entry of this field
1264  class(fmsdiagaxiscontainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
1265  character(len=*), intent(in) :: unlim_dimname !< The name of the unlimited dimension
1266  logical, intent(in) :: is_regional !< Flag indicating if the field is regional
1267  character(len=*), intent(in) :: cell_measures !< The cell measures attribute to write
1268  logical, intent(in) :: use_collective_writes !< True if using collective writes
1269  !! for this variable
1270  integer, intent(in) :: file_axis_ids(:) !< Ids of all of the axis in thje file
1271 
1272  type(diagyamlfilesvar_type), pointer :: field_yaml !< pointer to the yaml entry
1273  character(len=:), allocatable :: var_name !< Variable name
1274  character(len=:), allocatable :: long_name !< Longname to write
1275  character(len=:), allocatable :: units !< Units of the field to write
1276  character(len=120), allocatable :: dimnames(:) !< Dimension names of the field
1277  character(len=120) :: cell_methods!< Cell methods attribute to write
1278  integer :: i !< For do loops
1279  character (len=MAX_STR_LEN), allocatable :: yaml_field_attributes(:,:) !< Variable attributes defined in the yaml
1280  character(len=:), allocatable :: interp_method_tmp !< temp to hold the name of the interpolation method
1281  integer :: interp_method_len !< length of the above string
1282 
1283  integer, allocatable :: chunksizes(:) !< Chunksizes to use for the variable
1284 
1285  field_yaml => diag_yaml%get_diag_field_from_id(yaml_id)
1286  var_name = field_yaml%get_var_outname()
1287 
1288  if (allocated(this%axis_ids)) then
1289  call this%get_dimnames(diag_axis, field_yaml, unlim_dimname, dimnames, is_regional, file_axis_ids)
1290 
1291  !! Collective writes are only used for 2D+ variables
1292  if ((use_collective_writes .and. size(this%axis_ids) >= 2) .or. field_yaml%has_chunksizes()) then
1293  chunksizes = this%get_chunksizes(diag_axis, field_yaml)
1294  call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml), dimnames, &
1295  chunksizes = chunksizes)
1296  else
1297  call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml), dimnames)
1298  endif
1299  else
1300  if (this%is_static()) then
1301  call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml))
1302  else
1303  !< In this case, the scalar variable is a function of time, so we need to pass in the
1304  !! unlimited dimension as a dimension
1305  call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml), (/unlim_dimname/))
1306  endif
1307  endif
1308 
1309  long_name = this%get_longname_to_write(field_yaml)
1310  call register_variable_attribute(fms2io_fileobj, var_name, "long_name", long_name, str_len=len_trim(long_name))
1311 
1312  units = this%get_units()
1313  if (units .ne. diag_null_string) &
1314  call register_variable_attribute(fms2io_fileobj, var_name, "units", units, str_len=len_trim(units))
1315 
1316  if (this%has_missing_value()) then
1317  call register_variable_attribute(fms2io_fileobj, var_name, "missing_value", &
1318  this%get_missing_value(field_yaml%get_var_kind()))
1319  call register_variable_attribute(fms2io_fileobj, var_name, "_FillValue", &
1320  this%get_missing_value(field_yaml%get_var_kind()))
1321  else
1322  call register_variable_attribute(fms2io_fileobj, var_name, "missing_value", &
1323  get_default_missing_value(field_yaml%get_var_kind()))
1324  call register_variable_attribute(fms2io_fileobj, var_name, "_FillValue", &
1325  get_default_missing_value(field_yaml%get_var_kind()))
1326  endif
1327 
1328  if (this%has_data_RANGE()) then
1329  call register_variable_attribute(fms2io_fileobj, var_name, "valid_range", &
1330  this%get_data_range(field_yaml%get_var_kind()))
1331  endif
1332 
1333  if (this%has_interp_method()) then
1334  interp_method_tmp = this%interp_method
1335  interp_method_len = len_trim(interp_method_tmp)
1336  call register_variable_attribute(fms2io_fileobj, var_name, "interp_method", interp_method_tmp, &
1337  str_len=interp_method_len)
1338  endif
1339 
1340  cell_methods = ""
1341  !< Check if any of the attributes defined via a "diag_field_add_attribute" call
1342  !! are the cell_methods, if so add to the "cell_methods" variable:
1343  do i = 1, this%num_attributes
1344  call this%attributes(i)%write_metadata(fms2io_fileobj, var_name, &
1345  cell_methods=cell_methods)
1346  enddo
1347 
1348  !< Append the time cell methods based on the variable's reduction
1349  call this%append_time_cell_methods(cell_methods, field_yaml)
1350  if (trim(cell_methods) .ne. "") &
1351  call register_variable_attribute(fms2io_fileobj, var_name, "cell_methods", &
1352  trim(adjustl(cell_methods)), str_len=len_trim(adjustl(cell_methods)))
1353 
1354  !< Write out the cell_measures attribute (i.e Area, Volume)
1355  !! The diag field ids for the Area and Volume are sent in the register call
1356  !! This was defined in file object and passed in here
1357  if (trim(cell_measures) .ne. "") &
1358  call register_variable_attribute(fms2io_fileobj, var_name, "cell_measures", &
1359  trim(adjustl(cell_measures)), str_len=len_trim(adjustl(cell_measures)))
1360 
1361  !< Write out the standard_name (this was defined in the register call)
1362  if (this%has_standname()) &
1363  call register_variable_attribute(fms2io_fileobj, var_name, "standard_name", &
1364  trim(this%get_standname()), str_len=len_trim(this%get_standname()))
1365 
1366  call this%write_coordinate_attribute(fms2io_fileobj, var_name, diag_axis)
1367 
1368  if (field_yaml%has_var_attributes()) then
1369  yaml_field_attributes = field_yaml%get_var_attributes()
1370  do i = 1, size(yaml_field_attributes,1)
1371  call register_variable_attribute(fms2io_fileobj, var_name, trim(yaml_field_attributes(i,1)), &
1372  trim(yaml_field_attributes(i,2)), str_len=len_trim(yaml_field_attributes(i,2)))
1373  enddo
1374  deallocate(yaml_field_attributes)
1375  endif
1376 end subroutine write_field_metadata
1377 
1378 !> @brief Determine the appropriate chunksizes for a diagnostic field based on its axes.
1379 !! For "X" and "Y" axes, the function returns a chunksize equal to the axis size divided by the layout.
1380 !! If the dimension is not evenly divisible by the layout, the function raises an error.
1381 !! For the other axis (i.e z axis) it return a chunksize equal to the axis length
1382 !! For sub-z axes (e.g., layer bounds), a chunksize of 1 is returned for now, as this case is not yet implemented.
1383 !! @return An integer array of chunksizes, one per diagnostic axis, plus one for the unlimited dimension.
1384 function get_chunksizes(this, diag_axis, field_yaml) &
1385  result(chunksizes)
1386 
1387  class(fmsdiagfield_type), target, intent(inout) :: this !< diag field
1388  class(fmsdiagaxiscontainer_type), target, intent(in) :: diag_axis(:) !< Diag_axis object
1389  type(diagyamlfilesvar_type), intent(in) :: field_yaml !< Field info from diag_table yaml
1390 
1391  integer, allocatable :: chunksizes(:)
1392 
1393  integer :: i !< For do loops
1394  integer :: ndim !< Number of spatial dimensions
1395  integer :: dim_size !< Dimensions size for the variable
1396  integer :: layout !< Layout to use for the variable
1397  integer :: specified_chunksizes(max_dimensions) !< Chunksizes specified in the yaml
1398 
1399  ndim = size(this%axis_ids)
1400  allocate(chunksizes(ndim + 1)) !! Adding 1 because of the unlimited dimension
1401  chunksizes = 1
1402  if (field_yaml%has_chunksizes()) then
1403  specified_chunksizes = field_yaml%get_chunksizes()
1404  chunksizes = specified_chunksizes(1:ndim+1)
1405  return
1406  endif
1407 
1408  ! Determine some default chunksizes to use, based on the compute domain
1409  do i = 1, ndim
1410  select type (axis => diag_axis(this%axis_ids(i))%axis)
1411  type is (fmsdiagfullaxis_type)
1412  if (axis%is_x_or_y_axis()) then
1413  call axis%get_dim_size_layout(dim_size, layout)
1414  if (mod(dim_size, layout) == 0) then
1415  chunksizes(i) = dim_size / layout
1416  else
1417  call mpp_error(fatal, "The variable "//field_yaml%get_var_varname()//" has a layout that is not"//&
1418  "evenly divisible by dimension size for axis "//axis%get_axis_name()//"."&
1419  "This may lead to poor performance when using collective writes. "//&
1420  "Consider using a different layout, disabling collective writes, "//&
1421  "or specifying chunksizes manually via the diag table yaml")
1422  endif
1423  else if (axis%is_z_axis() .and. field_yaml%has_var_zbounds()) then
1424  !TODO Handle edge case: chunking for z-axis with layer bounds (not yet implemented)
1425  else
1426  chunksizes(i) = axis%axis_length()
1427  endif
1428  end select
1429  enddo
1430 end function get_chunksizes
1431 
1432 !> @brief Writes the coordinate attribute of a field if any of the field's axis has an
1433 !! auxiliary axis
1434 subroutine write_coordinate_attribute (this, fms2io_fileobj, var_name, diag_axis)
1435  CLASS(fmsdiagfield_type), intent(in) :: this !< The field object
1436  class(fmsnetcdffile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write to
1437  character(len=*), intent(in) :: var_name !< Variable name
1438  class(fmsdiagaxiscontainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
1439 
1440  integer :: i !< For do loops
1441  character(len = 252) :: aux_coord !< Auxuliary axis name
1442 
1443  !> If the variable is a scalar, go away
1444  if (.not. allocated(this%axis_ids)) return
1445 
1446  !> Determine if any of the field's axis has an auxiliary axis and the
1447  !! axis_names as a variable attribute
1448  aux_coord = ""
1449  do i = 1, size(this%axis_ids)
1450  select type (obj => diag_axis(this%axis_ids(i))%axis)
1451  type is (fmsdiagfullaxis_type)
1452  if (obj%has_aux()) then
1453  aux_coord = trim(aux_coord)//" "//obj%get_aux()
1454  endif
1455  end select
1456  enddo
1457 
1458  if (trim(aux_coord) .eq. "") return
1459 
1460  call register_variable_attribute(fms2io_fileobj, var_name, "coordinates", &
1461  trim(adjustl(aux_coord)), str_len=len_trim(adjustl(aux_coord)))
1462 
1463 end subroutine write_coordinate_attribute
1464 
1465 !> @brief Gets a fields data buffer
1466 !! @return a pointer to the data buffer
1467 function get_data_buffer (this) &
1468  result(rslt)
1469  class(fmsdiagfield_type), target, intent(in) :: this !< diag field
1470  class(*),dimension(:,:,:,:), pointer :: rslt !< The field's data buffer
1471 
1472  if (.not. this%data_buffer_is_allocated) &
1473  call mpp_error(fatal, "The input data buffer for the field:"&
1474  //trim(this%varname)//" was never allocated.")
1475 
1476  rslt => this%input_data_buffer%get_buffer()
1477 end function get_data_buffer
1478 
1479 
1480 !> @brief Gets a fields weight buffer
1481 !! @return a pointer to the weight buffer
1482 function get_weight (this) &
1483  result(rslt)
1484  class(fmsdiagfield_type), target, intent(in) :: this !< diag field
1485  type(real(kind=r8_kind)), pointer :: rslt
1486 
1487  if (.not. this%data_buffer_is_allocated) &
1488  call mpp_error(fatal, "The input data buffer for the field:"&
1489  //trim(this%varname)//" was never allocated.")
1490 
1491  rslt => this%input_data_buffer%get_weight()
1492 end function get_weight
1493 
1494 !> Gets the flag telling if the math functions need to be done
1495 !! \return Copy of math_needs_to_be_done flag
1496 pure logical function get_math_needs_to_be_done(this)
1497  class(fmsdiagfield_type), intent(in) :: this !< diag object
1498  get_math_needs_to_be_done = .false.
1499  if (allocated(this%math_needs_to_be_done)) get_math_needs_to_be_done = this%math_needs_to_be_done
1500 end function get_math_needs_to_be_done
1501 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1502 !!!!! Allocation checks
1503 
1504 !!> @brief Checks if obj%diag_field is allocated
1505 !!! @return true if obj%diag_field is allocated
1506 !logical function has_diag_field (obj)
1507 ! class (fmsDiagField_type), intent(in) :: obj !< diag object
1508 ! has_diag_field = allocated(obj%diag_field)
1509 !end function has_diag_field
1510 !> @brief Checks if obj%diag_id is allocated
1511 !! @return true if obj%diag_id is allocated
1512 pure logical function has_diag_id (this)
1513  class(fmsdiagfield_type), intent(in) :: this !< diag object
1514  has_diag_id = allocated(this%diag_id)
1515 end function has_diag_id
1516 
1517 !> @brief Checks if obj%metadata is allocated
1518 !! @return true if obj%metadata is allocated
1519 pure logical function has_attributes (this)
1520  class(fmsdiagfield_type), intent(in) :: this !< diag object
1521  has_attributes = this%num_attributes > 0
1522 end function has_attributes
1523 
1524 !> @brief Checks if obj%static is allocated
1525 !! @return true if obj%static is allocated
1526 pure logical function has_static (this)
1527  class(fmsdiagfield_type), intent(in) :: this !< diag object
1528  has_static = allocated(this%static)
1529 end function has_static
1530 
1531 !> @brief Checks if obj%registered is allocated
1532 !! @return true if obj%registered is allocated
1533 pure logical function has_registered (this)
1534  class(fmsdiagfield_type), intent(in) :: this !< diag object
1535  has_registered = allocated(this%registered)
1536 end function has_registered
1537 
1538 !> @brief Checks if obj%mask_variant is allocated
1539 !! @return true if obj%mask_variant is allocated
1540 pure logical function has_mask_variant (this)
1541  class(fmsdiagfield_type), intent(in) :: this !< diag object
1542  has_mask_variant = allocated(this%mask_variant)
1543 end function has_mask_variant
1544 
1545 !> @brief Checks if obj%local is allocated
1546 !! @return true if obj%local is allocated
1547 pure logical function has_local (this)
1548  class(fmsdiagfield_type), intent(in) :: this !< diag object
1549  has_local = allocated(this%local)
1550 end function has_local
1551 
1552 !> @brief Checks if obj%vartype is allocated
1553 !! @return true if obj%vartype is allocated
1554 pure logical function has_vartype (this)
1555  class(fmsdiagfield_type), intent(in) :: this !< diag object
1556  has_vartype = allocated(this%vartype)
1557 end function has_vartype
1558 
1559 !> @brief Checks if obj%varname is allocated
1560 !! @return true if obj%varname is allocated
1561 pure logical function has_varname (this)
1562  class(fmsdiagfield_type), intent(in) :: this !< diag object
1563  has_varname = allocated(this%varname)
1564 end function has_varname
1565 
1566 !> @brief Checks if obj%longname is allocated
1567 !! @return true if obj%longname is allocated
1568 pure logical function has_longname (this)
1569  class(fmsdiagfield_type), intent(in) :: this !< diag object
1570  has_longname = allocated(this%longname)
1571 end function has_longname
1572 
1573 !> @brief Checks if obj%standname is allocated
1574 !! @return true if obj%standname is allocated
1575 pure logical function has_standname (this)
1576  class(fmsdiagfield_type), intent(in) :: this !< diag object
1577  has_standname = allocated(this%standname)
1578 end function has_standname
1579 
1580 !> @brief Checks if obj%units is allocated
1581 !! @return true if obj%units is allocated
1582 pure logical function has_units (this)
1583  class(fmsdiagfield_type), intent(in) :: this !< diag object
1584  has_units = allocated(this%units)
1585 end function has_units
1586 
1587 !> @brief Checks if obj%modname is allocated
1588 !! @return true if obj%modname is allocated
1589 pure logical function has_modname (this)
1590  class(fmsdiagfield_type), intent(in) :: this !< diag object
1591  has_modname = allocated(this%modname)
1592 end function has_modname
1593 
1594 !> @brief Checks if obj%realm is allocated
1595 !! @return true if obj%realm is allocated
1596 pure logical function has_realm (this)
1597  class(fmsdiagfield_type), intent(in) :: this !< diag object
1598  has_realm = allocated(this%realm)
1599 end function has_realm
1600 
1601 !> @brief Checks if obj%interp_method is allocated
1602 !! @return true if obj%interp_method is allocated
1603 pure logical function has_interp_method (this)
1604  class(fmsdiagfield_type), intent(in) :: this !< diag object
1605  has_interp_method = allocated(this%interp_method)
1606 end function has_interp_method
1607 
1608 !> @brief Checks if obj%frequency is allocated
1609 !! @return true if obj%frequency is allocated
1610 pure logical function has_frequency (this)
1611  class(fmsdiagfield_type), intent(in) :: this !< diag object
1612  has_frequency = allocated(this%frequency)
1613 end function has_frequency
1614 
1615 !> @brief Checks if obj%tile_count is allocated
1616 !! @return true if obj%tile_count is allocated
1617 pure logical function has_tile_count (this)
1618  class(fmsdiagfield_type), intent(in) :: this !< diag object
1619  has_tile_count = allocated(this%tile_count)
1620 end function has_tile_count
1621 
1622 !> @brief Checks if axis_ids of the object is allocated
1623 !! @return true if it is allocated
1624 pure logical function has_axis_ids (this)
1625  class(fmsdiagfield_type), intent(in) :: this !< diag field object
1626  has_axis_ids = allocated(this%axis_ids)
1627 end function has_axis_ids
1628 
1629 !> @brief Checks if obj%area is allocated
1630 !! @return true if obj%area is allocated
1631 pure logical function has_area (this)
1632  class(fmsdiagfield_type), intent(in) :: this !< diag object
1633  has_area = allocated(this%area)
1634 end function has_area
1635 
1636 !> @brief Checks if obj%volume is allocated
1637 !! @return true if obj%volume is allocated
1638 pure logical function has_volume (this)
1639  class(fmsdiagfield_type), intent(in) :: this !< diag object
1640  has_volume = allocated(this%volume)
1641 end function has_volume
1642 
1643 !> @brief Checks if obj%missing_value is allocated
1644 !! @return true if obj%missing_value is allocated
1645 pure logical function has_missing_value (this)
1646  class(fmsdiagfield_type), intent(in) :: this !< diag object
1647  has_missing_value = allocated(this%missing_value)
1648 end function has_missing_value
1649 
1650 !> @brief Checks if obj%data_RANGE is allocated
1651 !! @return true if obj%data_RANGE is allocated
1652 pure logical function has_data_range (this)
1653  class(fmsdiagfield_type), intent(in) :: this !< diag object
1654  has_data_range = allocated(this%data_RANGE)
1655 end function has_data_range
1656 
1657 !> @brief Checks if obj%input_data_buffer is allocated
1658 !! @return true if obj%input_data_buffer is allocated
1659 pure logical function has_input_data_buffer (this)
1660  class(fmsdiagfield_type), intent(in) :: this !< diag object
1661  has_input_data_buffer = allocated(this%input_data_buffer)
1662 end function has_input_data_buffer
1663 
1664 !> @brief Add a attribute to the diag_obj using the diag_field_id
1665 subroutine diag_field_add_attribute(this, att_name, att_value)
1666  class(fmsdiagfield_type), intent (inout) :: this !< The field object
1667  character(len=*), intent(in) :: att_name !< Name of the attribute
1668  class(*), intent(in) :: att_value(:) !< The attribute value to add
1669 
1670  this%num_attributes = this%num_attributes + 1
1671  if (this%num_attributes > max_field_attributes) &
1672  call mpp_error(fatal, "diag_field_add_attribute: Number of attributes exceeds max_field_attributes for field:"&
1673  //trim(this%varname)//". Increase diag_manager_nml:max_field_attributes.")
1674 
1675  call this%attributes(this%num_attributes)%add(att_name, att_value)
1676 end subroutine diag_field_add_attribute
1677 
1678 !> @brief Determine the default missing value to use based on the requested variable type
1679 !! @return The missing value
1680 function get_default_missing_value(var_type) &
1681  result(rslt)
1682 
1683  integer, intent(in) :: var_type !< The type of the variable to return the missing value as
1684  class(*),allocatable :: rslt
1685 
1686  select case(var_type)
1687  case (r4)
1688  allocate(real(kind=r4_kind) :: rslt)
1689  rslt = real(cmor_missing_value, kind=r4_kind)
1690  case (r8)
1691  allocate(real(kind=r8_kind) :: rslt)
1692  rslt = real(cmor_missing_value, kind=r8_kind)
1693  case default
1694  end select
1695 end function
1696 
1697 !> @brief Determines the diag_obj id corresponding to a module name and field_name
1698 !> @return diag_obj id
1699 FUNCTION diag_field_id_from_name(this, module_name, field_name) &
1700  result(diag_field_id)
1701  CLASS(fmsdiagfield_type), INTENT(in) :: this !< The field object
1702  CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
1703  CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
1704 
1705  integer :: diag_field_id
1706 
1707  diag_field_id = diag_field_not_found
1708  if (this%get_varname() .eq. trim(field_name) .and. &
1709  this%get_modname() .eq. trim(module_name)) then
1710  diag_field_id = this%get_id()
1711  endif
1712 end function diag_field_id_from_name
1713 
1714 !> @brief Adds the area and volume id to a field object
1715 subroutine add_area_volume(this, area, volume)
1716  CLASS(fmsdiagfield_type), intent(inout) :: this !< The field object
1717  INTEGER, optional, INTENT(in) :: area !< diag ids of area
1718  INTEGER, optional, INTENT(in) :: volume !< diag ids of volume
1719 
1720  if (present(area)) then
1721  if (area > 0) then
1722  this%area = area
1723  else
1724  call mpp_error(fatal, "diag_field_add_cell_measures: the area id is not valid. &
1725  &Verify that the area_id passed in to the field:"//this%varname// &
1726  " is valid and that the field is registered and in the diag_table.yaml")
1727  endif
1728  endif
1729 
1730  if (present(volume)) then
1731  if (volume > 0) then
1732  this%volume = volume
1733  else
1734  call mpp_error(fatal, "diag_field_add_cell_measures: the volume id is not valid. &
1735  &Verify that the volume_id passed in to the field:"//this%varname// &
1736  " is valid and that the field is registered and in the diag_table.yaml")
1737  endif
1738  endif
1739 
1740 end subroutine add_area_volume
1741 
1742 !> @brief Append the time cell meathods based on the variable's reduction
1743 subroutine append_time_cell_methods(this, cell_methods, field_yaml)
1744  class(fmsdiagfield_type), target, intent(inout) :: this !< diag field
1745  character(len=*), intent(inout) :: cell_methods !< The cell methods var to append to
1746  type(diagyamlfilesvar_type), intent(in) :: field_yaml !< The field's yaml
1747 
1748  if (this%static) then
1749  cell_methods = trim(cell_methods)//" time: point "
1750  return
1751  endif
1752 
1753  select case (field_yaml%get_var_reduction())
1754  case (time_none)
1755  cell_methods = trim(cell_methods)//" time: point "
1756  case (time_diurnal)
1757  cell_methods = trim(cell_methods)//" time: mean"
1758  case (time_power)
1759  cell_methods = trim(cell_methods)//" time: mean_pow"//int2str(field_yaml%get_pow_value())
1760  case (time_rms)
1761  cell_methods = trim(cell_methods)//" time: root_mean_square"
1762  case (time_max)
1763  cell_methods = trim(cell_methods)//" time: max"
1764  case (time_min)
1765  cell_methods = trim(cell_methods)//" time: min"
1766  case (time_average)
1767  cell_methods = trim(cell_methods)//" time: mean"
1768  case (time_sum)
1769  cell_methods = trim(cell_methods)//" time: sum"
1770  end select
1771 end subroutine append_time_cell_methods
1772 
1773 !> Dumps any data from a given fmsDiagField_type object
1774 subroutine dump_field_obj (this, unit_num)
1775  class(fmsdiagfield_type), intent(in) :: this
1776  integer, intent(in) :: unit_num !< passed in from dump_diag_obj if log file is being written to
1777  integer :: i
1778 
1779  if( mpp_pe() .eq. mpp_root_pe()) then
1780  if( allocated(this%file_ids)) write(unit_num, *) 'file_ids:' ,this%file_ids
1781  if( allocated(this%diag_id)) write(unit_num, *) 'diag_id:' ,this%diag_id
1782  if( allocated(this%static)) write(unit_num, *) 'static:' ,this%static
1783  if( allocated(this%registered)) write(unit_num, *) 'registered:' ,this%registered
1784  if( allocated(this%mask_variant)) write(unit_num, *) 'mask_variant:' ,this%mask_variant
1785  if( allocated(this%do_not_log)) write(unit_num, *) 'do_not_log:' ,this%do_not_log
1786  if( allocated(this%local)) write(unit_num, *) 'local:' ,this%local
1787  if( allocated(this%vartype)) write(unit_num, *) 'vartype:' ,this%vartype
1788  if( allocated(this%varname)) write(unit_num, *) 'varname:' ,this%varname
1789  if( allocated(this%longname)) write(unit_num, *) 'longname:' ,this%longname
1790  if( allocated(this%standname)) write(unit_num, *) 'standname:' ,this%standname
1791  if( allocated(this%units)) write(unit_num, *) 'units:' ,this%units
1792  if( allocated(this%modname)) write(unit_num, *) 'modname:' ,this%modname
1793  if( allocated(this%realm)) write(unit_num, *) 'realm:' ,this%realm
1794  if( allocated(this%interp_method)) write(unit_num, *) 'interp_method:' ,this%interp_method
1795  if( allocated(this%tile_count)) write(unit_num, *) 'tile_count:' ,this%tile_count
1796  if( allocated(this%axis_ids)) write(unit_num, *) 'axis_ids:' ,this%axis_ids
1797  write(unit_num, *) 'type_of_domain:' ,this%type_of_domain
1798  if( allocated(this%area)) write(unit_num, *) 'area:' ,this%area
1799  if( allocated(this%missing_value)) then
1800  select type(missing_val => this%missing_value)
1801  type is (real(r4_kind))
1802  write(unit_num, *) 'missing_value:', missing_val
1803  type is (real(r8_kind))
1804  write(unit_num, *) 'missing_value:' ,missing_val
1805  type is(integer(i4_kind))
1806  write(unit_num, *) 'missing_value:' ,missing_val
1807  type is(integer(i8_kind))
1808  write(unit_num, *) 'missing_value:' ,missing_val
1809  end select
1810  endif
1811  if( allocated( this%data_RANGE)) then
1812  select type(drange => this%data_RANGE)
1813  type is (real(r4_kind))
1814  write(unit_num, *) 'data_RANGE:' ,drange
1815  type is (real(r8_kind))
1816  write(unit_num, *) 'data_RANGE:' ,drange
1817  type is(integer(i4_kind))
1818  write(unit_num, *) 'data_RANGE:' ,drange
1819  type is(integer(i8_kind))
1820  write(unit_num, *) 'data_RANGE:' ,drange
1821  end select
1822  endif
1823  write(unit_num, *) 'num_attributes:' ,this%num_attributes
1824  if( allocated(this%attributes)) then
1825  do i=1, this%num_attributes
1826  if( allocated(this%attributes(i)%att_value)) then
1827  select type( val => this%attributes(i)%att_value)
1828  type is (real(r8_kind))
1829  write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val
1830  type is (real(r4_kind))
1831  write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val
1832  type is (integer(i4_kind))
1833  write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val
1834  type is (integer(i8_kind))
1835  write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val
1836  end select
1837  endif
1838  enddo
1839  endif
1840 
1841  endif
1842 
1843 end subroutine
1844 
1845 !< @brief Get the starting compute domain indices for a set of axis
1846 !! @return compute domain starting indices
1847 function get_starting_compute_domain(axis_ids, diag_axis) &
1848 result(compute_domain)
1849  integer, intent(in) :: axis_ids(:) !< Array of axis ids
1850  class(fmsdiagaxiscontainer_type),intent(in) :: diag_axis(:) !< Array of axis object
1851 
1852  integer :: compute_domain(4)
1853  integer :: a !< For looping through axes
1854  integer :: compute_idx(2) !< Compute domain indices (starting, ending)
1855  logical :: dummy !< Dummy variable for the `get_compute_domain` subroutine
1856 
1857  compute_domain = 1
1858  axis_loop: do a = 1,size(axis_ids)
1859  select type (axis => diag_axis(axis_ids(a))%axis)
1860  type is (fmsdiagfullaxis_type)
1861  call axis%get_compute_domain(compute_idx, dummy)
1862  if ( compute_idx(1) .ne. diag_null) compute_domain(a) = compute_idx(1)
1863  end select
1864  enddo axis_loop
1865 end function get_starting_compute_domain
1866 
1867 !> Get list of field ids
1868 pure function get_file_ids(this)
1869  class(fmsdiagfield_type), intent(in) :: this
1870  integer, allocatable :: get_file_ids(:) !< Ids of the FMS_diag_files the variable
1871  get_file_ids = this%file_ids
1872 end function
1873 
1874 !> @brief Get the mask from the input buffer object
1875 !! @return a pointer to the mask
1876 function get_mask(this)
1877  class(fmsdiagfield_type), target, intent(in) :: this !< input buffer object
1878  logical, pointer :: get_mask(:,:,:,:)
1879  get_mask => this%mask
1880 end function get_mask
1881 
1882 !> @brief If in openmp region, omp_axis should be provided in order to allocate to the given axis lengths.
1883 !! Otherwise mask will be allocated to the size of mask_in
1884 subroutine allocate_mask(this, mask_in, omp_axis)
1885  class(fmsdiagfield_type), target, intent(inout) :: this !< input buffer object
1886  logical, intent(in) :: mask_in(:,:,:,:)
1887  class(fmsdiagaxiscontainer_type), intent(in), optional :: omp_axis(:) !< true if calling from omp region
1888  integer :: axis_num, length(4)
1889  integer, pointer :: id_num
1890  ! if not omp just allocate to whatever is given
1891  if(.not. present(omp_axis)) then
1892  allocate(this%mask(size(mask_in,1), size(mask_in,2), size(mask_in,3), &
1893  size(mask_in,4)))
1894  ! otherwise loop through axis and get sizes
1895  else
1896  length = 1
1897  do axis_num=1, size(this%axis_ids)
1898  id_num => this%axis_ids(axis_num)
1899  select type(axis => omp_axis(id_num)%axis)
1900  type is (fmsdiagfullaxis_type)
1901  length(axis_num) = axis%axis_length()
1902  end select
1903  enddo
1904  allocate(this%mask(length(1), length(2), length(3), length(4)))
1905  endif
1906 end subroutine allocate_mask
1907 
1908 !> Sets previously allocated mask to mask_in at given index ranges
1909 subroutine set_mask(this, mask_in, field_info, is, js, ks, ie, je, ke)
1910  class(fmsdiagfield_type), intent(inout) :: this
1911  logical, intent(in) :: mask_in(:,:,:,:)
1912  character(len=*), intent(in) :: field_info !< Field info to add to error message
1913  integer, optional, intent(in) :: is, js, ks, ie, je, ke
1914  if(present(is)) then
1915  if(is .lt. lbound(this%mask,1) .or. ie .gt. ubound(this%mask,1) .or. &
1916  js .lt. lbound(this%mask,2) .or. je .gt. ubound(this%mask,2) .or. &
1917  ks .lt. lbound(this%mask,3) .or. ke .gt. ubound(this%mask,3)) then
1918  print *, "PE:", int2str(mpp_pe()), "The size of the mask is", &
1919  shape(this%mask), &
1920  "But the indices passed in are is=", int2str(is), " ie=", int2str(ie),&
1921  " js=", int2str(js), " je=", int2str(je), &
1922  " ks=", int2str(ks), " ke=", int2str(ke), &
1923  " ", trim(field_info)
1924  call mpp_error(fatal,"set_mask:: given indices out of bounds for allocated mask")
1925  endif
1926  this%mask(is:ie, js:je, ks:ke, :) = mask_in
1927  else
1928  this%mask = mask_in
1929  endif
1930 end subroutine set_mask
1931 
1932 !> sets halo_present to true
1933 subroutine set_halo_present(this)
1934  class(fmsdiagfield_type), intent(inout) :: this !< field object to modify
1935  this%halo_present = .true.
1936 end subroutine set_halo_present
1937 
1938 !> Getter for halo_present
1939 pure function is_halo_present(this)
1940  class(fmsdiagfield_type), intent(in) :: this !< field object to get from
1941  logical :: is_halo_present
1942  is_halo_present = this%halo_present
1943 end function is_halo_present
1944 
1945 !> Helper routine to find and set the netcdf missing value for a field
1946 !! Always returns r8 due to reduction routine args
1947 !! casts up to r8 from given missing val or default if needed
1948 function find_missing_value(this, missing_val) &
1949  result(res)
1950  class(fmsdiagfield_type), intent(in) :: this !< field object to get missing value for
1951  class(*), allocatable, intent(out) :: missing_val !< outputted netcdf missing value (oriignal type)
1952  real(r8_kind), allocatable :: res !< returned r8 copy of missing_val
1953  integer :: vtype !< temp to hold enumerated variable type
1954 
1955  if(this%has_missing_value()) then
1956  missing_val = this%get_missing_value(this%get_vartype())
1957  else
1958  vtype = this%get_vartype()
1959  if(vtype .eq. r8) then
1960  missing_val = cmor_missing_value
1961  else
1962  missing_val = real(cmor_missing_value, r4_kind)
1963  endif
1964  endif
1965 
1966  select type(missing_val)
1967  type is (real(r8_kind))
1968  res = missing_val
1969  type is (real(r4_kind))
1970  res = real(missing_val, r8_kind)
1971  end select
1972 end function find_missing_value
1973 
1974 !> @returns allocation status of logical mask array
1975 !! this just indicates whether the mask array itself has been alloc'd
1976 !! this is different from @ref has_mask_variant, which is set earlier for whether a mask is being used at all
1977 pure logical function has_mask_allocated(this)
1978  class(fmsdiagfield_type),intent(in) :: this !< field object to check mask allocation for
1979  has_mask_allocated = allocated(this%mask)
1980 end function has_mask_allocated
1981 
1982 !> @brief Determine if the variable is in the file
1983 !! @return .True. if the varibale is in the file
1984 pure function is_variable_in_file(this, file_id) &
1985 result(res)
1986  class(fmsdiagfield_type), intent(in) :: this !< field object to check
1987  integer, intent(in) :: file_id !< File id to check
1988  logical :: res
1989 
1990  integer :: i
1991 
1992  res = .false.
1993  if (any(this%file_ids .eq. file_id)) res = .true.
1994 end function is_variable_in_file
1995 
1996 !> @brief Determine the name of the first file the variable is in
1997 !! @return filename
1998 function get_field_file_name(this) &
1999  result(res)
2000  class(fmsdiagfield_type), intent(in) :: this !< Field object to query
2001  character(len=:), allocatable :: res
2002 
2003  res = this%diag_field(1)%get_var_fname()
2004 end function get_field_file_name
2005 
2006 !> @brief Generate the associated files attribute
2007 subroutine generate_associated_files_att(this, att, start_time, var_output_name)
2008  class(fmsdiagfield_type) , intent(in) :: this !< diag_field_object for the
2009  !! area/volume field
2010  character(len=*), intent(inout) :: att !< associated_files_att
2011  type(time_type), intent(in) :: start_time !< The start_time for the field's file
2012  character(len=*), intent(out) :: var_output_name !< output name of the area/volume field
2013 
2014 
2015  character(len=:), allocatable :: field_name !< Name of the area/volume field
2016  character(len=FMS_FILE_LEN) :: file_name !< Name of the file the area/volume field is in!
2017  character(len=128) :: start_date !< Start date to append to the begining of the filename
2018 
2019  integer :: year, month, day, hour, minute, second
2020 
2021  file_name = this%get_field_file_name()
2022  field_name = this%get_varname(to_write = .true., filename=file_name)
2023 
2024  ! Save the outputname of the area/volume so it can be added correctly to the cell_measures attribute
2025  var_output_name = field_name
2026 
2027  ! Check if the field is already in the associated files attribute (i.e the area can be associated with multiple
2028  ! fields in the file, but it only needs to be added once)
2029  if (index(att, field_name) .ne. 0) return
2030 
2031  if (prepend_date) then
2032  call get_date(start_time, year, month, day, hour, minute, second)
2033  write (start_date, '(1I20.4, 2I2.2)') year, month, day
2034  file_name = trim(adjustl(start_date))//'.'//trim(file_name)
2035  endif
2036 
2037  att = trim(att)//" "//trim(field_name)//": "//trim(file_name)//".nc"
2038 end subroutine generate_associated_files_att
2039 
2040 !> @brief Determines if the compute domain has been divide further into slices (i.e openmp blocks)
2041 !! @return .True. if the compute domain has been divided furter into slices
2042 function check_for_slices(field, diag_axis, var_size) &
2043  result(rslt)
2044  type(fmsdiagfield_type), intent(in) :: field !< Field object
2045  type(fmsdiagaxiscontainer_type), target, intent(in) :: diag_axis(:) !< Array of diag axis
2046  integer, intent(in) :: var_size(:) !< The size of the buffer pass into send_data
2047 
2048  logical :: rslt
2049  integer :: i !< For do loops
2050 
2051  rslt = .false.
2052 
2053  if (.not. field%has_axis_ids()) then
2054  rslt = .false.
2055  return
2056  endif
2057  do i = 1, size(field%axis_ids)
2058  select type (axis_obj => diag_axis(field%axis_ids(i))%axis)
2059  type is (fmsdiagfullaxis_type)
2060  if (axis_obj%axis_length() .ne. var_size(i)) then
2061  rslt = .true.
2062  return
2063  endif
2064  end select
2065  enddo
2066 end function
2067 #endif
2068 end module fms_diag_field_object_mod
integer, parameter max_str_len
Max length for a string.
Definition: diag_data.F90:129
integer, parameter no_domain
Use the FmsNetcdfFile_t fileobj.
Definition: diag_data.F90:100
character(len=7) avg_name
Name of the average fields.
Definition: diag_data.F90:124
integer, parameter diag_field_not_found
Return value for a diag_field that isn't found in the diag_table.
Definition: diag_data.F90:112
integer, parameter string
s is the 19th letter of the alphabet
Definition: diag_data.F90:87
integer, parameter time_min
The reduction method is min value.
Definition: diag_data.F90:117
integer, parameter time_diurnal
The reduction method is diurnal.
Definition: diag_data.F90:122
integer, parameter time_power
The reduction method is average with exponents.
Definition: diag_data.F90:123
real(r8_kind), parameter cmor_missing_value
CMOR standard missing value.
Definition: diag_data.F90:111
logical prepend_date
Should the history file have the start date prepended to the file name. .TRUE. is only supported if t...
Definition: diag_data.F90:386
integer, parameter max_dimensions
Max number of dimensions allowed (including unlimited dimension)
Definition: diag_data.F90:104
integer, parameter time_average
The reduction method is average of values.
Definition: diag_data.F90:120
integer, parameter time_sum
The reduction method is sum of values.
Definition: diag_data.F90:119
integer, parameter time_rms
The reudction method is root mean square of values.
Definition: diag_data.F90:121
integer, parameter time_none
There is no reduction method.
Definition: diag_data.F90:116
integer, parameter time_max
The reduction method is max value.
Definition: diag_data.F90:118
integer, parameter r8
Supported type/kind of the variable.
Definition: diag_data.F90:83
integer max_field_attributes
Maximum number of user definable attributes per field. Liptak: Changed from 2 to 4 20170718.
Definition: diag_data.F90:382
Type to hold the attributes of the field/axis/file.
Definition: diag_data.F90:334
Defines a new field/variable within the given file. After a variable is registered,...
Definition: fms2_io.F90:282
Type to hold the information needed for the input buffer This is used when set_math_needs_to_be_done ...
type(diagyamlfilesvar_type) function, dimension(:), allocatable, public get_diag_fields_entries(indices)
Gets the diag_field entries corresponding to the indices of the sorted variable_list.
subroutine, public find_z_sub_axis_name(dim_name, parent_axis_id, file_axis_id, field_yaml, diag_axis)
Determine the name of the z subaxis by matching the parent axis id and the zbounds in the diag table ...
integer function, public get_num_unique_fields()
Determine the number of unique diag_fields in the diag_yaml_object.
integer function, dimension(:), allocatable, public find_diag_field(diag_field_name, module_name)
Determines if a diag_field is in the diag_yaml_object.
integer function, dimension(:), allocatable, public get_diag_files_id(indices)
Finds the indices of the diag_yamldiag_files(:) corresponding to fields in variable_list(indices)
subroutine, public get_domain_and_domain_type(diag_axis, axis_id, domain_type, domain, var_name)
Loop through a variable's axis_id to determine and return the domain type and domain to use.
character(:) function, allocatable, public string(v, fmt)
Converts a number or a Boolean value to a string.
integer function mpp_pe()
Returns processor ID.
Definition: mpp_util.inc:406
Error handler.
Definition: mpp.F90:385
subroutine, public get_date(time, year, month, day, hour, minute, second, tick, err_msg)
Gets the date for different calendar types. Given a time_interval, returns the corresponding date und...
Type to represent amounts of time. Implemented as seconds and days to allow for larger intervals.
Type to hold the domain info for an axis This type was created to avoid having to send in "Domain",...
Type to hold the diagnostic axis description.
Type to hold the diag_axis (either subaxis or a full axis)
Type to hold the diagnostic axis description.
Object that holds all variable information.
type to hold the info a diag_field