FMS  2026.01.01-dev
Flexible Modeling System
diag_manager.F90
Go to the documentation of this file.
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 !> @defgroup diag_manager_mod diag_manager_mod
19 !> @ingroup diag_manager
20 !! @brief diag_manager_mod is a set of simple calls for parallel diagnostics
21 !! on distributed systems. It is geared toward the writing of data in netCDF
22 !! format. See @ref diag_manager for diag table information.
23 !! @author Matt Harrison, Giang Nong, Seth Underwood
24 !!
25 !! <TT>diag_manager_mod</TT> provides a convenient set of interfaces for
26 !! writing data to disk. It is built upon the parallel I/O interface of FMS
27 !! code <TT>/shared/mpp/mpp_io.F90</TT>.
28 !!
29 !! A single group of calls to the <TT>diag_manager_mod</TT> interfaces
30 !! provides data to disk at any number of sampling and/or averaging intervals
31 !! specified at run-time. Run-time specification of diagnostics are input
32 !! through the diagnostics table.
33 !!
34 !! <H4>Usage</H4>
35 !! Use of <TT>diag_manager</TT> includes the following steps:
36 !! <OL>
37 !! <LI> Create diag_table as described in the @ref diag_table_mod
38 !! documentation.</LI>
39 !! <LI> Call @ref diag_manager_init to initialize
40 !! diag_manager_mod.</LI>
41 !! <LI> Call @ref register_diag_field to register the field to be
42 !! output.
43 !! <B>NOTE:</B> ALL fields in diag_table should be registered <I>BEFORE</I>
44 !! the first send_data call</LI>
45 !! <LI> Call @ref send_data to send data to output fields </LI>
46 !! <LI> Call @ref diag_manager_end to exit diag_manager </LI>
47 !! </OL>
48 !!
49 !! <H4>Features</H4>
50 !! Features of <TT>diag_manager_mod</TT>:
51 !! <OL>
52 !! <LI> Ability to output from 0D arrays (scalars) to 3D arrays.</LI>
53 !! <LI> Ability to output time average of fields that have time dependent
54 !! mask.</LI>
55 !! <LI> Give optional warning if <TT>register_diag_field</TT> fails due to
56 !! misspelled module name or field name.</LI>
57 !! <LI> Check if a field is registered twice.</LI>
58 !! <LI> Check for duplicate lines in diag_table. </LI>
59 !! <LI> @ref diag_table_mod can contain fields
60 !! that are NOT written to any files. The file name in diag_table of
61 !! these fields is <TT>null</TT>.</LI>
62 !! <LI> By default, a field is output in its global grid. The user can now
63 !! output a field in a specified region. See
64 !! @ref send_data for more details.</LI>
65 !! <LI> To check if the diag table is set up correctly, user should set
66 !! <TT>debug_diag_manager=.true.</TT> in diag_manager namelist, then
67 !! the content of diag_table is printed in stdout.</LI>
68 !! <LI> New optional format of file information in @ref diag_table_mod.
69 !! It is possible to have just
70 !! one file name and reuse it many times. A time string will be appended to
71 !! the base file name each time a new file is opened. The time string can be
72 !! any combination from year to second of current model time.
73 !!
74 !! Here is an example file line: <BR />
75 !! <PRE>"file2_yr_dy%1yr%3dy",2,"hours",1,"hours","Time", 10, "days", "1 1 7 0 0 0", 6, "hours"</PRE>
76 !! <BR />
77 !!
78 !! From left to right we have:
79 !! <UL>
80 !! <LI>file name</LI>
81 !! <LI>output frequency</LI>
82 !! <LI>output frequency unit</LI>
83 !! <LI>Format (should always be 1)</LI>
84 !! <LI>time axis unit</LI>
85 !! <LI>time axis name</LI>
86 !! <LI>frequency for creating new file</LI>
87 !! <LI>unit for creating new file</LI>
88 !! <LI>start time of the new file</LI>
89 !! <LI>file duration</LI>
90 !! <LI>file duration unit.</LI>
91 !! </UL>
92 !! The 'file duration', if absent, will be equal to frequency for creating a new file.
93 !!
94 !! Thus, the above means: create a new file every 10 days, each file will last 6 hours
95 !! from creation time, no files will
96 !! be created before time "1 1 7 0 0 0".
97 !!
98 !! In this example the string
99 !! <TT>10, "days", "1 1 7 0 0 0", 6, "hours"</TT> is optional.
100 !!
101 !! Keywords for the time string suffix is
102 !! <TT>%xyr,%xmo,%xdy,%xhr,%xmi,%xsc</TT> where <TT>x</TT> is a
103 !! mandatory 1 digit number specifying the width of field used in
104 !! writing the string</LI>
105 !! <LI> New time axis for time averaged fields. Users can use a namelist option to handle the time value written
106 !! to time axis for time averaged fields.
107 !!
108 !! If <TT>mix_snapshot_average_fields=.true.</TT> then a time averaged file will have
109 !! time values corresponding to
110 !! ending time_bound e.g. January monthly average is labeled Feb01. Users can have
111 !! both snapshot and averaged fields in
112 !! one file.
113 !!
114 !! If <TT>mix_snapshot_average_fields=.false.</TT> The time value written to time
115 !! axis for time averaged fields is the
116 !! middle on the averaging time. For example, January monthly mean will be written at Jan 16 not Feb 01 as
117 !! before. However, to use this new feature users should <B>separate</B> snapshot
118 !! fields and time averaged fields in
119 !! <B>different</B> files or a fatal error will occur.
120 !!
121 !! The namelist <B>default</B> value is <TT>mix_snapshot_average_fields=.false.</TT></LI>
122 !! <LI> Time average, Root Mean Square, Max and Min, and diurnal. In addition to time average
123 !! users can also get then Root Mean Square, Max or Min value
124 !! during the same interval of time as time average. For this purpose, in the diag table users must replace
125 !! <TT>.true.</TT> or <TT>.false.</TT> by <TT>rms</TT>, <TT>max</TT> or <TT>min</TT>.
126 !! <B><I>Note:</I></B> Currently, max
127 !! and min are not available for regional output.
128 !!
129 !! A diurnal average or the average of an integer power can also be requested using
130 !! <TT>diurnal##</TT> or <TT>pow##</TT> where
131 !! <TT>##</TT> are the number of diurnal sections or integer power to average.</LI>
132 !! <LI> <TT>standard_name</TT> is added as optional argument in @ref register_diag_field. </LI>
133 !! <LI>When namelist variable <TT>debug_diag_manager = .true.</TT> array
134 !! bounds are checked in @ref send_data.</LI>
135 !! <LI>Coordinate attributes can be written in the output file if the
136 !! argument "aux" is given in @ref diag_axis_mod#diag_axis_init . The
137 !! corresponding fields (geolat/geolon) should also be written to the
138 !! same file.</LI>
139 !! </OL>
140 
141 !> @file
142 !> @ingroup diag_manager_mod
143 !> @brief File for @ref diag_manager_mod
144 
145 MODULE diag_manager_mod
146 use platform_mod
147  ! <NAMELIST NAME="diag_manager_nml">
148  ! <DATA NAME="append_pelist_name" TYPE="LOGICAL" DEFAULT=".FALSE.">
149  ! </DATA>
150  ! <DATA NAME="mix_snapshot_average_fields" TYPE="LOGICAL" DEFAULT=".FALSE.">
151  ! Set to .TRUE. to allow both time average and instantaneous fields in the same output file.
152  ! </DATA>
153  ! <DATA NAME="max_files" TYPE="INTEGER" DEFULT="31">
154  ! </DATA>
155  ! <DATA NAME="max_output_fields" TYPE="INTEGER" DEFAULT="300">
156  ! </DATA>
157  ! <DATA NAME="max_input_fields" TYPE="INTEGER" DEFAULT="300">
158  ! </DATA>
159  ! <DATA NAME="max_axes" TYPE="INTEGER" DEFAULT="60">
160  ! </DATA>
161  ! <DATA NAME="do_diag_field_log" TYPE="LOGICAL" DEFAULT=".FALSE.">
162  ! </DATA>
163  ! <DATA NAME="write_bytes_in_files" TYPE="LOGICAL" DEFAULT=".FALSE.">
164  ! </DATA>
165  ! <DATA NAME="debug_diag_manager" TYPE="LOGICAL" DEFAULT=".FALSE.">
166  ! </DATA>
167  ! <DATA NAME="max_num_axis_sets" TYPE="INTEGER" DEFAULT="25">
168  ! </DATA>
169  ! <DATA NAME="use_cmor" TYPE="LOGICAL" DEFAULT=".FALSE.">
170  ! Let the <TT>diag_manager</TT> know if the missing value (if supplied) should be overridden to be the
171  ! CMOR standard value of -1.0e20.
172  ! </DATA>
173  ! <DATA NAME="issue_oor_warnings" TYPE="LOGICAL" DEFAULT=".TRUE.">
174  ! If <TT>.TRUE.</TT>, then the <TT>diag_manager</TT> will check for values outside the
175  ! valid range. This range is defined in
176  ! the model, and passed to the <TT>diag_manager_mod</TT> via the OPTIONAL variable range
177  ! in the <TT>register_diag_field</TT>
178  ! function.
179  ! </DATA>
180  ! <DATA NAME="oor_warnings_fatal" TYPE="LOGICAL" DEFAULT=".FALSE.">
181  ! If <TT>.TRUE.</TT> then <TT>diag_manager_mod</TT> will issue a <TT>FATAL</TT> error
182  ! if any values for the output field are
183  ! outside the given range.
184  ! </DATA>
185  ! <DATA NAME="max_field_attributes" TYPE="INTEGER" DEFAULT="4">
186  ! Maximum number of user definable attributes per field.
187  ! </DATA>
188  ! <DATA NAME="max_file_attributes" TYPE="INTEGER" DEFAULT="2">
189  ! Maximum number of user definable global attributes per file.
190  ! </DATA>
191  ! <DATA NAME="prepend_date" TYPE="LOGICAL" DEFAULT=".TRUE.">
192  ! If <TT>.TRUE.</TT> then prepend the file start date to the output file. <TT>.TRUE.</TT>
193  ! is only supported if the
194  ! diag_manager_init routine is called with the optional time_init parameter. Note:
195  ! This was usually done by FRE after the
196  ! model run.
197  ! </DATA>
198  ! <DATA NAME="region_out_use_alt_value" TYPE="LOGICAL" DEFAULT=".TRUE.">
199  ! Will determine which value to use when checking a regional output if the region is the full axis or a sub-axis.
200  ! The values are defined as <TT>GLO_REG_VAL</TT> (-999) and <TT>GLO_REG_VAL_ALT</TT>
201  ! (-1) in <TT>diag_data_mod</TT>.
202  ! </DATA>
203  ! </NAMELIST>
204 
205  USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
206  & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
208  USE mpp_mod, ONLY: mpp_get_current_pelist, mpp_pe, mpp_npes, mpp_root_pe, mpp_sum
209 
210  USE mpp_mod, ONLY: input_nml_file, mpp_error
211 
212  USE fms_mod, ONLY: error_mesg, fatal, warning, note, stdout, stdlog, write_version_number,&
213  & fms_error_handler, check_nml_error, lowercase
216  USE diag_util_mod, ONLY: get_subfield_size, log_diag_field_info, update_bounds,&
222  USE diag_data_mod, ONLY: max_files, cmor_missing_value, diag_other, diag_ocean, diag_all, every_time,&
223  & end_of_run, diag_seconds, diag_minutes, diag_hours, diag_days, diag_months, diag_years, num_files,&
225  & max_value, min_value, get_base_time, get_base_year, get_base_month, get_base_day,&
226  & get_base_hour, get_base_minute, get_base_second, global_descriptor, coord_type, files, input_fields,&
227  & output_fields, time_zero, append_pelist_name, mix_snapshot_average_fields,&
228  & first_send_data_call, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
229  & diag_log_unit, time_unit_list, pelist_name, max_axes, module_is_initialized, max_num_axis_sets,&
235  USE diag_data_mod, ONLY: fileobj, fileobju, fnum_for_domain, fileobjnd
236  USE diag_table_mod, ONLY: parse_diag_table
237  USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
238  USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
239  use fms_diag_object_mod, only:fms_diag_object
240 
241  USE constants_mod, ONLY: seconds_per_day
242  USE fms_diag_outfield_mod, ONLY: fmsdiagoutfieldindex_type, fmsdiagoutfield_type
243  USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, &
245  USE fms_string_utils_mod, ONLY: string
246 
247  USE netcdf, ONLY: nf90_int, nf90_float, nf90_char
248 
249 !----------
250 !ug support
251  use diag_axis_mod, only: diag_axis_2ddomain
252  use diag_axis_mod, only: diag_axis_ugdomain
253 !----------
254 
255  IMPLICIT NONE
256 
257  PRIVATE
259  & register_diag_field, register_static_field, diag_axis_init, get_base_time, get_base_date,&
260  & need_data, diag_all, diag_ocean, diag_other, get_date_dif, diag_seconds,&
261  & diag_minutes, diag_hours, diag_days, diag_months, diag_years, get_diag_global_att,&
263  & get_diag_field_id, diag_axis_add_attribute, cmor_missing_value, null_axis_id
264  PUBLIC :: center, north, east !< Used for diag_axis_init
265  ! Public interfaces from diag_grid_mod
266  PUBLIC :: diag_grid_init, diag_grid_end
267  PUBLIC :: diag_manager_set_time_end, diag_send_complete
269  ! Public interfaces from diag_data_mod
270  PUBLIC :: diag_field_not_found
271 
272  ! version number of this module
273  ! Include variable "version" to be written to log file.
274 #include<file_version.h>
275 
276  type(time_type) :: Time_end
277 
278  !> @brief Send data over to output fields.
279  !!
280  !> <TT>send_data</TT> is overloaded for fields having zero dimension
281  !! (scalars) to 3 dimension. <TT>diag_field_id</TT> corresponds to the id
282  !! returned from a previous call to <TT>register_diag_field</TT>. The field
283  !! array is restricted to the computational range of the array. Optional
284  !! argument <TT>is_in</TT> can be used to update sub-arrays of the entire
285  !! field. Additionally, an optional logical or real mask can be used to
286  !! apply missing values to the array.
287  !!
288  !! If a field is declared to be <TT>mask_variant</TT> in
289  !! <TT>register_diag_field</TT> logical mask should be mandatory.
290  !!
291  !! For the real mask, the mask is applied if the mask value is less than
292  !! 0.5.
293  !!
294  !! By default, a field will be written out entirely in its global grid.
295  !! Users can also specify regions in which the field will be output. The
296  !! region is specified in diag-table just before the end of output_field
297  !! replacing "none".
298  !!
299  !! For example, by default:
300  !!
301  !! "ocean_mod","Vorticity","vorticity","file1","all",.false.,"none",2
302  !!
303  !! for regional output:
304  !!
305  !! "ocean_mod","Vorticity","vorticity_local","file2","all",.false.,"0.5 53.5 -89.5 -28.5 -1 -1",2
306  !!
307  !! The format of a region is "<TT>xbegin xend ybegin yend zbegin zend</TT>".
308  !! If it is a 2D field use (-1 -1) for (zbegin zend) as in the example above.
309  !! For a 3D field use (-1 -1) for (zbegin zend) when you want to write the
310  !! entire vertical extent, otherwise specify real coordinates. The units
311  !! used for region are the actual units used in grid_spec.nc (for example
312  !! degrees for lat, lon). <B><I>NOTE:</I></B> A FATAL error will occur if
313  !! the region's boundaries are not found in grid_spec.nc.
314  !!
315  !! Regional output on the cubed sphere grid is also supported. To use regional
316  !! output on the cubed sphere grid, first the grid information needs to be sent to
317  !! <TT>diag_manager_mod</TT> using the @ref diag_grid#diag_grid_init subroutine.
318  !!
319  !! @note When using regional output the files containing regional
320  !! outputs should be different from files containing global (default) output.
321  !! It is a FATAL error to have one file containing both regional and global
322  !! results. For maximum flexibility and independence from PE counts one file
323  !! should contain just one region.
324  !!
325  !!
326  !! Time averaging is supported in regional output.
327  !!
328  !! Physical fields (written in "physics windows" of atmospheric code) are
329  !! fully supported for regional outputs.
330  !!
331  !! <B><I>NOTE:</I></B> Most fields are defined in the data domain but use the
332  !! compute domain. In <TT>send_data</TT> the field can be passed in either
333  !! the data domain or in the compute domain. If the data domain is used, the
334  !! start and end indicies of the compute domain (isc, iec, . . .) should be
335  !! passed. If the compute domain is used no indices are needed. The indices
336  !! are for determining halo exclusively. If users want to output the field
337  !! partially they should use regional output as mentioned above.
338  !!
339  !! Weight in Time averaging is now supported, each time level may have a
340  !! different weight. The default of weight is 1.
341  !> @ingroup diag_manager_mod
342  INTERFACE send_data
343  MODULE PROCEDURE send_data_0d
344  MODULE PROCEDURE send_data_1d
345  MODULE PROCEDURE send_data_2d
346  MODULE PROCEDURE send_data_3d
347  MODULE PROCEDURE send_data_4d
348  END INTERFACE
349 
350  !> @brief Register a diagnostic field for a given module
351  !> @ingroup diag_manager_mod
353  MODULE PROCEDURE register_diag_field_scalar
354  MODULE PROCEDURE register_diag_field_array
355  END INTERFACE
356 
357  !> @brief Send tile-averaged data over to output fields.
358  !> @ingroup diag_manager_mod
360  MODULE PROCEDURE send_tile_averaged_data1d
361  MODULE PROCEDURE send_tile_averaged_data2d
362  MODULE PROCEDURE send_tile_averaged_data3d
363  END INTERFACE
364 
365  !> @brief Add a attribute to the output field
366  !> @ingroup diag_manager_mod
368  MODULE PROCEDURE diag_field_add_attribute_1d
369  MODULE PROCEDURE diag_field_add_attribute_0d
370  END INTERFACE diag_field_add_attribute
371 
372 !> @addtogroup diag_manager_mod
373 !> @{
374 CONTAINS
375 
376  !> @brief Registers a scalar field
377  !! @return field index for subsequent call to send_data.
378  INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, &
379  & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
380  & area, volume, realm, multiple_send_data)
381  CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
382  CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
383  TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
384  CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
385  CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
386  CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
387  CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
388  CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute
389  LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
390  CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
391  INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
392  INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
393  CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
394  LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple times
395  !! for the same time
396 
397  ! Fatal error if range is present and its extent is not 2.
398  IF ( PRESENT(range) ) THEN
399  IF ( SIZE(range) .NE. 2 ) THEN
400  ! <ERROR STATUS="FATAL">extent of range should be 2</ERROR>
401  CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', fatal)
402  END IF
403  END IF
404  if (use_modern_diag) then
405  if( do_diag_field_log) then
406  if ( PRESENT(do_not_log) ) THEN
407  if(.not. do_not_log) call log_diag_field_info(module_name, field_name, (/null_axis_id/), long_name,&
408  & units, missing_value, range, dynamic=.true.)
409  else
410  call log_diag_field_info(module_name, field_name, (/null_axis_id/), long_name, units,&
411  & missing_value, range, dynamic=.true.)
412  endif
413  endif
414  register_diag_field_scalar = fms_diag_object%fms_register_diag_field_scalar( &
415  & module_name, field_name, init_time, long_name=long_name, units=units, &
416  & missing_value=missing_value, var_range=range, standard_name=standard_name, &
417  & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm, &
418  multiple_send_data=multiple_send_data)
419  else
420  register_diag_field_scalar = register_diag_field_scalar_old(module_name, field_name, init_time, &
421  & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, &
422  & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
423  endif
424  end function register_diag_field_scalar
425 
426  !> @brief Registers an array field
427  !> @return field index for subsequent call to send_data.
428  INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_time, &
429  & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
430  & do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
431  CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
432  CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
433  INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis
434  TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
435  CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
436  CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
437  CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
438  CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute
439  LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< .True. if the mask changes over time
440  CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
441  LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information
442  LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
443  CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
444  CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
445  !! regridding the field in post-processing.
446  !! Valid options are "conserve_order1",
447  !! "conserve_order2", and "none".
448  INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number
449  INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
450  INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
451  CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
452  LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple times
453  !! for the same time
454 
455  if (use_modern_diag) then
456  if( do_diag_field_log) then
457  if ( PRESENT(do_not_log) ) THEN
458  if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, long_name,&
459  & units, missing_value, range, dynamic=.true.)
460  else
461  call log_diag_field_info(module_name, field_name, axes, long_name, units,&
462  & missing_value, range, dynamic=.true.)
463  endif
464  endif
465  register_diag_field_array = fms_diag_object%fms_register_diag_field_array( &
466  & module_name, field_name, axes, init_time, long_name=long_name, &
467  & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
468  & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
469  & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
470  multiple_send_data=multiple_send_data)
471  else
472  register_diag_field_array = register_diag_field_array_old(module_name, field_name, axes, init_time, &
473  & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
474  & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
475  & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
476  endif
477 end function register_diag_field_array
478 
479  !> @brief Return field index for subsequent call to send_data.
480  !! @return field index for subsequent call to send_data.
481  INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, units,&
482  & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
483  & tile_count, area, volume, realm)
484  CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on
485  CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
486  INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field
487  CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute
488  CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute
489  CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute
490  CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
491  CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range !< Range to be added as a attribute
492  LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< .True. if the mask changes over time
493  LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< Flag indicating if the field is dynamic
494  LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged
495  CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
496  !! regridding the field in post-processing
497  !! Valid options are "conserve_order1",
498  !! "conserve_order2", and "none".
499  INTEGER, OPTIONAL, INTENT(in) :: tile_count !! Number of tiles
500  INTEGER, OPTIONAL, INTENT(in) :: area !< Field ID for the area field associated
501  !! with this field
502  INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated
503  !! with this field
504  CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
505  !! modeling_realm attribute
506 
507  ! Fatal error if the module has not been initialized.
508  IF ( .NOT.module_is_initialized ) THEN
509  ! <ERROR STATUS="FATAL">diag_manager has NOT been initialized</ERROR>
510  CALL error_mesg ('diag_manager_mod::register_static_field', 'diag_manager has NOT been initialized', fatal)
511  END IF
512 
513  if (use_modern_diag) then
514  if( do_diag_field_log) then
515  if ( PRESENT(do_not_log) ) THEN
516  if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, long_name,&
517  & units, missing_value, range, dynamic=.false.)
518  else
519  call log_diag_field_info(module_name, field_name, axes, long_name, units,&
520  & missing_value, range, dynamic=.false.)
521  endif
522  endif
523  register_static_field = fms_diag_object%fms_register_static_field(module_name, field_name, axes, &
524  & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
525  & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
526  & tile_count=tile_count, area=area, volume=volume, realm=realm)
527  else
528  register_static_field = register_static_field_old(module_name, field_name, axes, &
529  & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
530  & standard_name=standard_name, dynamic=dynamic, do_not_log=do_not_log, interp_method=interp_method,&
531  & tile_count=tile_count, area=area, volume=volume, realm=realm)
532  endif
533 END FUNCTION register_static_field
534 
535  !> @brief Registers a scalar field
536  !! @return field index for subsequent call to send_data.
537  INTEGER FUNCTION register_diag_field_scalar_old(module_name, field_name, init_time, &
538  & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
539  & area, volume, realm)
540  CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
541  CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
542  TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
543  CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
544  CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
545  CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
546  CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
547  CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute
548  LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
549  CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
550  INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
551  INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
552  CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
553 
554  IF ( PRESENT(err_msg) ) err_msg = ''
555 
556  IF ( PRESENT(init_time) ) THEN
558  & (/null_axis_id/), init_time,long_name, units, missing_value, range, &
559  & standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg,&
560  & area=area, volume=volume, realm=realm)
561  ELSE
562  register_diag_field_scalar_old = register_static_field(module_name, field_name,&
563  & (/null_axis_id/),long_name, units, missing_value, range,&
564  & standard_name=standard_name, do_not_log=do_not_log, realm=realm)
565  END IF
566  END FUNCTION register_diag_field_scalar_old
567 
568  !> @brief Registers an array field
569  !> @return field index for subsequent call to send_data.
570  INTEGER FUNCTION register_diag_field_array_old(module_name, field_name, axes, init_time, &
571  & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
572  & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
573  CHARACTER(len=*), INTENT(in) :: module_name, field_name
574  INTEGER, INTENT(in) :: axes(:)
575  TYPE(time_type), INTENT(in) :: init_time
576  CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name
577  CLASS(*), OPTIONAL, INTENT(in) :: missing_value
578  CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range
579  LOGICAL, OPTIONAL, INTENT(in) :: mask_variant,verbose
580  LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged
581  CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg
582  CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
583  !! regridding the field in post-processing.
584  !! Valid options are "conserve_order1",
585  !! "conserve_order2", and "none".
586  INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number
587  INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
588  INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
589  CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
590 
591  INTEGER :: field, j, ind, file_num, freq
592  INTEGER :: output_units
593  INTEGER :: stdout_unit
594  LOGICAL :: mask_variant1, verbose1
595  CHARACTER(len=128) :: msg
596  TYPE(time_type) :: diag_file_init_time !< The initial time of the diag_file
597 
598  ! get stdout unit number
599  stdout_unit = stdout()
600 
601  IF ( PRESENT(mask_variant) ) THEN
602  mask_variant1 = mask_variant
603  ELSE
604  mask_variant1 = .false.
605  END IF
606 
607  IF ( PRESENT(verbose) ) THEN
608  verbose1 = verbose
609  ELSE
610  verbose1 = .false.
611  END IF
612 
613  IF ( PRESENT(err_msg) ) err_msg = ''
614 
615  ! Fatal error if range is present and its extent is not 2.
616  IF ( PRESENT(range) ) THEN
617  IF ( SIZE(range) .NE. 2 ) THEN
618  ! <ERROR STATUS="FATAL">extent of range should be 2</ERROR>
619  CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', fatal)
620  END IF
621  END IF
622 
623  ! Call register static, then set static back to false
624  register_diag_field_array_old = register_static_field(module_name, field_name, axes,&
625  & long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,&
626  & dynamic=.true., do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, realm=realm)
627 
628  IF ( .NOT.first_send_data_call ) THEN
629  ! <ERROR STATUS="WARNING">
630  ! module/output_field <module_name>/<field_name> registered AFTER first
631  ! send_data call, TOO LATE
632  ! </ERROR>
633  IF ( mpp_pe() == mpp_root_pe() ) &
634  & CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '&
635  &//trim(module_name)//'/'// trim(field_name)//&
636  &' registered AFTER first send_data call, TOO LATE', warning)
637  END IF
638 
639  IF ( register_diag_field_array_old < 0 ) THEN
640  ! <ERROR STATUS="WARNING">
641  ! module/output_field <modul_name>/<field_name> NOT found in diag_table
642  ! </ERROR>
643  IF ( debug_diag_manager .OR. verbose1 ) THEN
644  IF ( mpp_pe() == mpp_root_pe() ) &
645  & CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '&
646  &//trim(module_name)//'/'// trim(field_name)//' NOT found in diag_table',&
647  & warning)
648  END IF
649  ELSE
650  input_fields(register_diag_field_array_old)%static = .false.
652 
653 
654  ! Verify that area and volume do not point to the same variable
655  IF ( PRESENT(volume).AND.PRESENT(area) ) THEN
656  IF ( area.EQ.volume ) THEN
657  IF (PRESENT(err_msg)) THEN
658  err_msg = 'diag_manager_mod::register_diag_field: module/output_field '&
659  &//trim(module_name)//'/'// trim(field_name)//' AREA and VOLUME CANNOT be the same variable.&
660  & Contact the developers.'
662  RETURN
663  ELSE
664  CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '&
665  &//trim(module_name)//'/'// trim(field_name)//' AREA and VOLUME CANNOT be the same variable.&
666  & Contact the developers.',&
667  & fatal)
668  ENDIF
669  END IF
670  END IF
671 
672  ! Check for the existence of the area/volume field(s)
673  IF ( PRESENT(area) ) THEN
674  IF ( area < 0 ) THEN
675  IF (PRESENT(err_msg)) THEN
676  err_msg = 'diag_manager_mod::register_diag_field: module/output_field '&
677  &//trim(module_name)//'/'// trim(field_name)//' AREA measures field NOT found in diag_table.&
678  & Contact the model liaison.'
680  RETURN
681  ELSE
682  CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '&
683  &//trim(module_name)//'/'// trim(field_name)//' AREA measures field NOT found in diag_table.&
684  & Contact the model liaison.',&
685  & fatal)
686  ENDIF
687  END IF
688  END IF
689  IF ( PRESENT(volume) ) THEN
690  IF ( volume < 0 ) THEN
691  IF (PRESENT(err_msg)) THEN
692  err_msg = 'diag_manager_mod::register_diag_field: module/output_field '&
693  &//trim(module_name)//'/'// trim(field_name)//' VOLUME measures field NOT found in diag_table.&
694  & Contact the model liaison.'
696  RETURN
697  ELSE
698  CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '&
699  &//trim(module_name)//'/'// trim(field_name)//' VOLUME measures field NOT found in diag_table.&
700  & Contact the model liaison.',&
701  & fatal)
702  ENDIF
703  END IF
704  END IF
705 
706  IF ( PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
707 
708  DO j = 1, input_fields(field)%num_output_fields
709  ind = input_fields(field)%output_fields(j)
710  output_fields(ind)%static = .false.
711  ! Set up times in output_fields
712  ! Get output frequency from for the appropriate output file
713  file_num = output_fields(ind)%output_file
714  IF ( file_num == max_files ) cycle
715  IF ( output_fields(ind)%local_output ) THEN
716  IF ( output_fields(ind)%need_compute) THEN
717  files(file_num)%local = .true.
718  END IF
719  END IF
720 
721  ! Need to sync start_time of file with init time of model
722  ! and close_time calculated with the duration of the file.
723  ! Also, increase next_open until it is greater than init_time.
724  CALL sync_file_times(file_num, init_time, err_msg=msg)
725  IF ( msg /= '' ) THEN
726  IF ( fms_error_handler('diag_manager_mod::register_diag_field', trim(msg), err_msg) ) RETURN
727  END IF
728 
729  freq = files(file_num)%output_freq
730  diag_file_init_time = get_file_start_time(file_num)
731  output_units = files(file_num)%output_units
732  output_fields(ind)%last_output = diag_file_init_time
733  output_fields(ind)%next_output = diag_time_inc(diag_file_init_time, freq, output_units, err_msg=msg)
734  IF ( msg /= '' ) THEN
735  IF ( fms_error_handler('diag_manager_mod::register_diag_field',&
736  & ' file='//trim(files(file_num)%name)//': '//trim(msg),err_msg)) RETURN
737  END IF
738  output_fields(ind)%next_next_output = &
739  & diag_time_inc(output_fields(ind)%next_output, freq, output_units, err_msg=msg)
740  IF ( msg /= '' ) THEN
741  IF ( fms_error_handler('diag_manager_mod::register_diag_field',&
742  &' file='//trim(files(file_num)%name)//': '//trim(msg),err_msg) ) RETURN
743  END IF
744  IF ( debug_diag_manager .AND. mpp_pe() == mpp_root_pe() .AND. output_fields(ind)%local_output ) THEN
745  WRITE (msg,'(" lon(",F5.1,", ",F5.1,"), lat(",F5.1,", ",F5.1,"), dep(",F5.1,", ",F5.1,")")') &
746  & output_fields(ind)%output_grid%start(1),output_fields(ind)%output_grid%end(1),&
747  & output_fields(ind)%output_grid%start(2),output_fields(ind)%output_grid%end(2),&
748  & output_fields(ind)%output_grid%start(3),output_fields(ind)%output_grid%end(3)
749  WRITE(stdout_unit,* ) 'module/output_field '//trim(module_name)//'/'//trim(field_name)// &
750  & ' will be output in region:'//trim(msg)
751  END IF
752 
753  ! Set the cell_measures attribute in the out file
754  CALL init_field_cell_measures(output_fields(ind), area=area, volume=volume, err_msg=err_msg)
755  IF ( len_trim(err_msg).GT.0 ) THEN
756  CALL error_mesg ('diag_manager_mod::register_diag_field',&
757  & trim(err_msg)//' for module/field '//trim(module_name)//'/'//trim(field_name),&
758  & fatal)
759  END IF
760 
761  END DO
762  END IF
763 
764  END FUNCTION register_diag_field_array_old
765  !> @brief Return field index for subsequent call to send_data.
766  !! @return field index for subsequent call to send_data.
767  INTEGER FUNCTION register_static_field_old(module_name, field_name, axes, long_name, units,&
768  & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
769  & tile_count, area, volume, realm)
770  CHARACTER(len=*), INTENT(in) :: module_name, field_name
771  INTEGER, DIMENSION(:), INTENT(in) :: axes
772  CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name
773  CLASS(*), OPTIONAL, INTENT(in) :: missing_value
774  CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range
775  LOGICAL, OPTIONAL, INTENT(in) :: mask_variant
776  LOGICAL, OPTIONAL, INTENT(in) :: dynamic
777  LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged
778  CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
779  !! regridding the field in post-processing.
780  !! Valid options are "conserve_order1",
781  !! "conserve_order2", and "none".
782  INTEGER, OPTIONAL, INTENT(in) :: tile_count
783  INTEGER, OPTIONAL, INTENT(in) :: area !< Field ID for the area field associated with this field
784  INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated with this field
785  CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the modeling_realm attribute
786 
787  REAL :: missing_value_use !< Local copy of missing_value
788  REAL, DIMENSION(2) :: range_use !< Local copy of range
789  INTEGER :: field, num_axes, j, out_num, k
790  INTEGER, DIMENSION(3) :: siz, local_siz, local_start, local_end ! indices of local domain of global axes
791  INTEGER :: tile, file_num
792  LOGICAL :: mask_variant1, dynamic1, allow_log
793  CHARACTER(len=128) :: msg
794  INTEGER :: domain_type, i
795  character(len=256) :: axis_name
796 
797  ! Fatal error if the module has not been initialized.
798  IF ( .NOT.module_is_initialized ) THEN
799  ! <ERROR STATUS="FATAL">diag_manager has NOT been initialized</ERROR>
800  CALL error_mesg ('diag_manager_mod::register_static_field_old', 'diag_manager has NOT been initialized', fatal)
801  END IF
802 
803  ! Check if OPTIONAL parameters were passed in.
804  IF ( PRESENT(missing_value) ) THEN
805  IF ( use_cmor ) THEN
806  missing_value_use = cmor_missing_value
807  ELSE
808  SELECT TYPE (missing_value)
809  TYPE IS (real(kind=r4_kind))
810  missing_value_use = missing_value
811  TYPE IS (real(kind=r8_kind))
812  missing_value_use = real(missing_value)
813  CLASS DEFAULT
814  CALL error_mesg ('diag_manager_mod::register_static_field',&
815  & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
816  END SELECT
817  END IF
818  END IF
819 
820  IF ( PRESENT(mask_variant) ) THEN
821  mask_variant1 = mask_variant
822  ELSE
823  mask_variant1 = .false.
824  END IF
825 
826  IF ( PRESENT(dynamic) ) THEN
827  dynamic1 = dynamic
828  ELSE
829  dynamic1 = .false.
830  END IF
831 
832  IF ( PRESENT(tile_count) ) THEN
833  tile = tile_count
834  ELSE
835  tile = 1
836  END IF
837 
838  IF ( PRESENT(do_not_log) ) THEN
839  allow_log = .NOT.do_not_log
840  ELSE
841  allow_log = .true.
842  END IF
843 
844  ! Fatal error if range is present and its extent is not 2.
845  IF ( PRESENT(range) ) THEN
846  IF ( SIZE(range) .NE. 2 ) THEN
847  ! <ERROR STATUS="FATAL">extent of range should be 2</ERROR>
848  CALL error_mesg ('diag_manager_mod::register_static_field', 'extent of range should be 2', fatal)
849  END IF
850  END IF
851 
852  ! only writes log if do_diag_field_log is true in the namelist (default false)
853  ! if do_diag_field_log is true and do_not_log arg is present as well, it will only print if do_not_log = false
854  IF ( do_diag_field_log.AND.allow_log ) THEN
855  CALL log_diag_field_info (module_name, field_name, axes, &
856  & long_name, units, missing_value=missing_value, range=range, &
857  & dynamic=dynamic1)
858  END IF
859 
860  register_static_field_old = find_input_field(module_name, field_name, 1)
862  ! Negative index returned if this field was not found in the diag_table.
863  IF ( register_static_field_old < 0 ) RETURN
864 
865  ! Check that the axes are compatible with each other
866  domain_type = axis_compatible_check(axes,field_name)
867 
868  IF ( tile > 1 ) THEN
869  IF ( .NOT.input_fields(field)%register ) THEN
870  ! <ERROR STATUS="FATAL">
871  ! module/output_field <module_name>/<field_name> is not registered for tile_count = 1,
872  ! should not register for tile_count > 1
873  ! </ERROR>
874  CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '//trim(module_name)//'/'//&
875  & trim(field_name)//' is not registered for tile_count = 1, should not register for tile_count > 1',&
876  & fatal)
877  END IF
878 
879  CALL init_input_field(module_name, field_name, tile)
880  register_static_field_old = find_input_field(module_name, field_name, tile)
881  DO j = 1, input_fields(field)%num_output_fields
882  out_num = input_fields(field)%output_fields(j)
883  file_num = output_fields(out_num)%output_file
884  IF(input_fields(field)%local) THEN
885  CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
886  & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack,&
887  & tile, input_fields(field)%local_coord)
888  ELSE
889  CALL init_output_field(module_name, field_name,output_fields(out_num)%output_name,&
890  & files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack, tile)
891  END IF
892  END DO
894  END IF
895 
896  ! Store information for this input field into input field table
897 
898  ! Set static to true, if called by register_diag_field this is
899  ! flipped back to false
900  input_fields(field)%static = .true.
901  ! check if the field is registered twice
902  IF ( input_fields(field)%register .AND. mpp_pe() == mpp_root_pe() ) THEN
903  ! <ERROR STATUS="FATAL">
904  ! module/output_field <module_name>/<field_name> ALREADY Registered, should
905  ! not register twice
906  ! </ERROR>
907  CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '//trim(module_name)//'/'//&
908  & trim(field_name)//' ALREADY registered, should not register twice', fatal)
909  END IF
910 
911  ! Verify that area and volume do not point to the same variable
912  IF ( PRESENT(volume).AND.PRESENT(area) ) THEN
913  IF ( area.EQ.volume ) THEN
914  CALL error_mesg ('diag_manager_mod::register_static_field_old', 'module/output_field '&
915  &//trim(module_name)//'/'// trim(field_name)//' AREA and VOLUME CANNOT be the same variable.&
916  & Contact the developers.',&
917  & fatal)
918  END IF
919  END IF
920 
921  ! Check for the existence of the area/volume field(s)
922  IF ( PRESENT(area) ) THEN
923  IF ( area < 0 ) THEN
924  CALL error_mesg ('diag_manager_mod::register_static_field_old', 'module/output_field '&
925  &//trim(module_name)//'/'// trim(field_name)//' AREA measures field NOT found in diag_table.&
926  & Contact the model liaison.n',&
927  & fatal)
928  END IF
929  END IF
930  IF ( PRESENT(volume) ) THEN
931  IF ( volume < 0 ) THEN
932  CALL error_mesg ('diag_manager_mod::register_static_field_old', 'module/output_field '&
933  &//trim(module_name)//'/'// trim(field_name)//' VOLUME measures field NOT found in diag_table&
934  & Contact the model liaison.',&
935  & fatal)
936  END IF
937  END IF
938 
939  ! Set flag that this field was registered
940  input_fields(field)%register = .true.
941  ! set flag for mask: does it change with time?
942  input_fields(field)%mask_variant = mask_variant1
943  ! Set flag for mask warning
944  input_fields(field)%issued_mask_ignore_warning = .false.
945 
946  ! Check for more OPTIONAL parameters.
947  IF ( PRESENT(long_name) ) THEN
948  input_fields(field)%long_name = trim(long_name)
949  ELSE
950  input_fields(field)%long_name = input_fields(field)%field_name
951  END IF
952 
953  IF ( PRESENT(standard_name) ) input_fields(field)%standard_name = standard_name
954 
955  IF ( PRESENT(units) ) THEN
956  input_fields(field)%units = trim(units)
957  ELSE
958  input_fields(field)%units = 'none'
959  END IF
960 
961  IF ( PRESENT(missing_value) ) THEN
962  input_fields(field)%missing_value = missing_value_use
963  input_fields(field)%missing_value_present = .true.
964  ELSE
965  input_fields(field)%missing_value_present = .false.
966  END IF
967 
968  IF ( PRESENT(range) ) THEN
969  SELECT TYPE (range)
970  TYPE IS (real(kind=r4_kind))
971  range_use = range
972  TYPE IS (real(kind=r8_kind))
973  range_use = real(range)
974  CLASS DEFAULT
975  CALL error_mesg ('diag_manager_mod::register_static_field',&
976  & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
977  END SELECT
978  input_fields(field)%range = range_use
979  ! don't use the range if it is not a valid range
980  input_fields(field)%range_present = range_use(2) .gt. range_use(1)
981  ELSE
982  input_fields(field)%range = (/ 1., 0. /)
983  input_fields(field)%range_present = .false.
984  END IF
985 
986  IF ( PRESENT(interp_method) ) THEN
987  IF ( trim(interp_method) .NE. 'conserve_order1' .AND.&
988  & trim(interp_method) .NE. 'conserve_order2' .AND.&
989  & trim(interp_method) .NE. 'none' ) THEN
990  ! <ERROR STATUS="FATAL">
991  ! when registering module/output_field <module_name>/<field_name> then optional
992  ! argument interp_method = <interp_method>, but it should be "conserve_order1",
993  ! "conserve_order2", or "none"
994  ! </ERROR>
995  CALL error_mesg ('diag_manager_mod::register_diag_field',&
996  & 'when registering module/output_field '//trim(module_name)//'/'//&
997  & trim(field_name)//', the optional argument interp_method = '//trim(interp_method)//&
998  & ', but it should be "conserve_order1", "conserve_order2", or "none"', fatal)
999  END IF
1000  input_fields(field)%interp_method = trim(interp_method)
1001  ELSE
1002  input_fields(field)%interp_method = ''
1003  END IF
1004 
1005  ! Store the axis info
1006  num_axes = SIZE(axes(:)) ! num_axes should be <= 3.
1007  input_fields(field)%axes(1:num_axes) = axes
1008  input_fields(field)%num_axes = num_axes
1009 
1010  siz = 1
1011  DO j = 1, num_axes
1012  IF ( axes(j) .LE. 0 ) THEN
1013  ! <ERROR STATUS="FATAL">
1014  ! module/output_field <module_name>/<field_name> has non-positive axis_id
1015  ! </ERROR>
1016  CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '//trim(module_name)//'/'//&
1017  & trim(field_name)//' has non-positive axis_id', fatal)
1018  END IF
1019  siz(j) = get_axis_length(axes(j))
1020  END DO
1021 
1022  ! Default length for axes is 1
1023  DO j = 1, 3
1024  input_fields(field)%size(j) = siz(j)
1025  END DO
1026 
1027  local_siz = 1
1028  local_start = 1
1029  local_end= 1
1030  ! Need to loop through all output_fields associated and allocate their buffers
1031  DO j = 1, input_fields(field)%num_output_fields
1032  out_num = input_fields(field)%output_fields(j)
1033  ! Range is required when pack >= 4
1034  IF ( output_fields(out_num)%pack>=4 .AND. .NOT.input_fields(field)%range_present ) THEN
1035  IF(mpp_pe() .EQ. mpp_root_pe()) THEN
1036  ! <ERROR STATUS="FATAL">
1037  ! output_field <field_name> has pack >= 4, range is REQUIRED in register_diag_field
1038  ! </ERROR>
1039  CALL error_mesg ('diag_manager_mod::register_diag_field ', 'output_field '//trim(field_name)// &
1040  ' has pack >=4, range is REQUIRED in register_diag_field', fatal)
1041  END IF
1042  END IF
1043  ! reset the number of diurnal samples to 1 if the field is static (and, therefore,
1044  ! doesn't vary diurnally)
1045  IF ( .NOT.dynamic1 ) output_fields(out_num)%n_diurnal_samples = 1
1046 
1047  !Check that the domain associated with the inputted field matches
1048  !the domain associated output files to which it will be written.
1049  file_num = output_fields(out_num)%output_file
1050  if (domain_type .eq. diag_axis_2ddomain) then
1051  if (files(file_num)%use_domainUG) then
1052  call error_mesg("diag_manager_mod::register_static_field_old", &
1053  "Diagnostics living on a structured grid" &
1054  //" and an unstructured grid cannot exist" &
1055  //" in the same file (" &
1056  //trim(files(file_num)%name)//")", &
1057  fatal)
1058  elseif (.not. files(file_num)%use_domain2D) then
1059  files(file_num)%use_domain2D = .true.
1060  endif
1061  elseif (domain_type .eq. diag_axis_ugdomain) then
1062  if (files(file_num)%use_domain2D) then
1063  call error_mesg("diag_manager_mod::register_static_field_old", &
1064  "Diagnostics living on a structured grid" &
1065  //" and an unstructured grid cannot exist" &
1066  //" in the same file (" &
1067  //trim(files(file_num)%name)//")", &
1068  fatal)
1069  elseif (.not. files(file_num)%use_domainUG) then
1070  files(file_num)%use_domainUG = .true.
1071  endif
1072  endif
1073 
1074 
1075  ! if local_output (size of output_fields does NOT equal size of input_fields)
1076  IF ( output_fields(out_num)%reduced_k_range ) THEN
1077  CALL get_subfield_vert_size(axes, out_num)
1078 
1079 !----------
1080 !ug support
1081  !Send_data requires that the reduced k dimension be the 3rd dimension
1082  !of the buffer, so set it to be the correct size. If the diagnostic
1083  !is unstructured, set the second dimension of the buffer to be 1.
1084  if (domain_type .eq. diag_axis_ugdomain) then
1085  local_start(2) = output_fields(out_num)%output_grid%l_start_indx(2)
1086  local_end(2) = output_fields(out_num)%output_grid%l_end_indx(2)
1087  local_siz(2) = local_end(2) - local_start(2) + 1
1088  allocate(output_fields(out_num)%buffer(siz(1),local_siz(2),siz(3), &
1089  output_fields(out_num)%n_diurnal_samples))
1090  output_fields(out_num)%region_elements = siz(1)*local_siz(2)*siz(3)
1091  output_fields(out_num)%reduced_k_unstruct = .true.
1092  else
1093  local_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
1094  local_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
1095  local_siz(3) = local_end(3) - local_start(3) + 1
1096  allocate(output_fields(out_num)%buffer(siz(1),siz(2),local_siz(3), &
1097  output_fields(out_num)%n_diurnal_samples))
1098  output_fields(out_num)%region_elements = siz(1)*siz(2)*local_siz(3)
1099  output_fields(out_num)%reduced_k_unstruct = .false.
1100  endif
1101  output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1102 !----------
1103 
1104  IF ( output_fields(out_num)%time_max ) THEN
1105  output_fields(out_num)%buffer = max_value
1106  ELSE IF ( output_fields(out_num)%time_min ) THEN
1107  output_fields(out_num)%buffer = min_value
1108  ELSE
1109  output_fields(out_num)%buffer = empty
1110  END IF
1111  ELSE IF ( output_fields(out_num)%local_output ) THEN
1112  IF ( SIZE(axes(:)) .LE. 1 ) THEN
1113  ! <ERROR STATUS="FATAL">axes of <field_name> must >= 2 for local output</ERROR>
1114  CALL error_mesg ('diag_manager_mod::register_diag_field', 'axes of '//trim(field_name)//&
1115  & ' must >= 2 for local output', fatal)
1116  END IF
1117  CALL get_subfield_size(axes, out_num)
1118  IF ( output_fields(out_num)%need_compute ) THEN
1119  DO k = 1, num_axes
1120  local_start(k) = output_fields(out_num)%output_grid%l_start_indx(k)
1121  local_end(k) = output_fields(out_num)%output_grid%l_end_indx(k)
1122  local_siz(k) = local_end(k) - local_start(k) +1
1123  END DO
1124  ALLOCATE(output_fields(out_num)%buffer(local_siz(1), local_siz(2), local_siz(3),&
1125  & output_fields(out_num)%n_diurnal_samples))
1126  IF(output_fields(out_num)%time_max) THEN
1127  output_fields(out_num)%buffer = max_value
1128  ELSE IF(output_fields(out_num)%time_min) THEN
1129  output_fields(out_num)%buffer = min_value
1130  ELSE
1131  output_fields(out_num)%buffer = empty
1132  END IF
1133  output_fields(out_num)%region_elements = local_siz(1)*local_siz(2)*local_siz(3)
1134  output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1135  files(output_fields(out_num)%output_file)%local = .true.
1136  END IF
1137  ELSE ! the field is output globally
1138  ! size of output_fields equal size of input_fields
1139  ALLOCATE(output_fields(out_num)%buffer(siz(1), siz(2), siz(3),&
1140  & output_fields(out_num)%n_diurnal_samples))
1141  IF(output_fields(out_num)%time_max) THEN
1142  output_fields(out_num)%buffer = max_value
1143  ELSE IF(output_fields(out_num)%time_min) THEN
1144  output_fields(out_num)%buffer = min_value
1145  ELSE
1146  output_fields(out_num)%buffer = empty
1147  END IF
1148  output_fields(out_num)%total_elements = siz(1)*siz(2)*siz(3)
1149  END IF
1150 
1151  ! Reset to false in register_field if this is not static
1152  output_fields(out_num)%static = .true.
1153  ! check if time average is true for static field
1154  IF ( .NOT.dynamic1 .AND. output_fields(out_num)%time_ops ) THEN
1155  WRITE (msg,'(a,"/",a)') trim(module_name), trim(field_name)
1156  IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN
1157  ! <ERROR STATUS="WARNING">
1158  ! module/field <module_name>/<field_name> is STATIC.
1159  ! Cannot perform time operations average, maximum or
1160  ! minimum on static fields. Setting the time operation to 'NONE'
1161  ! for this field.
1162  ! </ERROR>
1163  CALL error_mesg ('diag_manager_mod::register_static_field_old',&
1164  & 'module/field '//trim(msg)//' is STATIC. Cannot perform time operations&
1165  & average, maximum, or minimum on static fields. Setting the time operation&
1166  & to "NONE" for this field.', warning)
1167  END IF
1168  output_fields(out_num)%time_ops = .false.
1169  output_fields(out_num)%time_average = .false.
1170  output_fields(out_num)%time_method = 'point'
1171  END IF
1172 
1173  ! assume that the number of axes of output_fields = that of input_fields
1174  ! this should be changed later to take into account time-of-day axis
1175  output_fields(out_num)%num_axes = input_fields(field)%num_axes
1176  ! Axes are copied from input_fields if output globally or from subaxes if output locally
1177  IF ( .NOT.output_fields(out_num)%local_output ) THEN
1178  output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1179  & input_fields(field)%axes(1:input_fields(field)%num_axes)
1180  ELSE
1181  output_fields(out_num)%axes(1:input_fields(field)%num_axes) =&
1182  & output_fields(out_num)%output_grid%subaxes(1:input_fields(field)%num_axes)
1183  END IF
1184 
1185  ! if necessary, initialize the diurnal time axis and append its index in the
1186  ! output field axes array
1187  IF ( output_fields(out_num)%n_diurnal_samples > 1 ) THEN
1188  output_fields(out_num)%axes(output_fields(out_num)%num_axes+1) =&
1189  & init_diurnal_axis(output_fields(out_num)%n_diurnal_samples)
1190  output_fields(out_num)%num_axes = output_fields(out_num)%num_axes+1
1191  END IF
1192 
1193  IF ( output_fields(out_num)%reduced_k_range ) THEN
1194 !----------
1195 !ug support
1196  if (domain_type .eq. diag_axis_ugdomain) then
1197  output_fields(out_num)%axes(2) = output_fields(out_num)%output_grid%subaxes(2)
1198  else
1199  output_fields(out_num)%axes(3) = output_fields(out_num)%output_grid%subaxes(3)
1200  endif
1201 !----------
1202  END IF
1203 
1204  ! Initialize a time variable used in an error check
1205  output_fields(out_num)%Time_of_prev_field_data = time_zero
1206 
1207  ! Set the cell_measures attribute in the out file
1208  CALL init_field_cell_measures(output_fields(out_num), area=area, volume=volume, err_msg=msg)
1209  IF ( len_trim(msg).GT.0 ) THEN
1210  CALL error_mesg ('diag_manager_mod::register_static_field_old',&
1211  & trim(msg)//' for module/field '//trim(module_name)//'/'//trim(field_name),&
1212  & fatal)
1213  END IF
1214 
1215  ! Add the modeling_realm attribute
1216  IF ( PRESENT(realm) ) THEN
1217  CALL prepend_attribute(output_fields(out_num), 'modeling_realm', lowercase(trim(realm)))
1218  END IF
1219  END DO
1220 
1221  IF ( input_fields(field)%mask_variant ) THEN
1222  DO j = 1, input_fields(field)%num_output_fields
1223  out_num = input_fields(field)%output_fields(j)
1224  IF(output_fields(out_num)%time_average) THEN
1225 !----------
1226 !ug support
1227  !Send_data requires that the reduced k dimension be the 3rd dimension
1228  !of the counter array, so set it to be the correct size. If the diagnostic
1229  !is unstructured, set the second dimension of the counter array to be 1.
1230  if (output_fields(out_num)%reduced_k_range .and. &
1231  domain_type .eq. diag_axis_ugdomain) then
1232  allocate(output_fields(out_num)%counter(siz(1),local_siz(2),siz(3), &
1233  output_fields(out_num)%n_diurnal_samples))
1234  else
1235  allocate(output_fields(out_num)%counter(siz(1),siz(2),siz(3), &
1236  output_fields(out_num)%n_diurnal_samples))
1237  endif
1238 !----------
1239  output_fields(out_num)%counter = 0.0
1240  END IF
1241  END DO
1242  END IF
1243  END FUNCTION register_static_field_old
1244 
1245  !> @brief Return the diagnostic field ID of a given variable.
1246  !! @return get_diag_field_id will return the ID returned during the register_diag_field call.
1247  !! If the variable is not in the diag_table, then the value "DIAG_FIELD_NOT_FOUND" will be
1248  !! returned.
1249  INTEGER FUNCTION get_diag_field_id(module_name, field_name)
1250  CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
1251  CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
1252 
1253  integer :: i !< For do loops
1254 
1255  get_diag_field_id = diag_field_not_found
1256  if (use_modern_diag) then
1257  get_diag_field_id = fms_diag_object%fms_get_diag_field_id_from_name(module_name, field_name)
1258  else
1259  ! find_input_field will return DIAG_FIELD_NOT_FOUND if the field is not
1260  ! included in the diag_table
1261  get_diag_field_id = find_input_field(module_name, field_name, tile_count=1)
1262  endif
1263  END FUNCTION get_diag_field_id
1264 
1265  !> @brief Finds the corresponding related output field and file for a given input field
1266  !! @return Logical get_related_field
1267  LOGICAL FUNCTION get_related_field(field, rel_field, out_field_id, out_file_id)
1268  INTEGER, INTENT(in) :: field !< input field ID to find the corresponding
1269  TYPE(output_field_type), INTENT(in) :: rel_field !< Output field that field must correspond to
1270  INTEGER, INTENT(out) :: out_field_id !< output_field index of related output field
1271  INTEGER, INTENT(out) :: out_file_id !< file index of the out_field_id output field
1272 
1273  INTEGER :: i, cm_ind, cm_file_num
1274  INTEGER :: rel_file
1275 
1276  ! Output file index of field to compare to
1277  rel_file = rel_field%output_file
1278 
1279  ! Default return values
1280  out_field_id = -1
1281  out_file_id = -1
1282  get_related_field = .false.
1283 
1284  ! First check if any fields are in the same file as rel_field
1285  DO i = 1, input_fields(field)%num_output_fields
1286  cm_ind = input_fields(field)%output_fields(i)
1287  cm_file_num = output_fields(cm_ind)%output_file
1288 
1289  IF ( cm_file_num.EQ.rel_file.AND.&
1290  & (( (output_fields(cm_ind)%time_ops.EQV.rel_field%time_ops) .AND.&
1291  & (output_fields(cm_ind)%next_output.EQ.rel_field%next_output) .AND.&
1292  & (output_fields(cm_ind)%last_output.EQ.rel_field%last_output) ).OR.&
1293  & (output_fields(cm_ind)%static.OR.rel_field%static) ) ) THEN
1294  get_related_field = .true.
1295  out_field_id = cm_ind
1296  out_file_id = cm_file_num
1297  EXIT
1298  END IF
1299  END DO
1300 
1301  ! Now look for the field in a different file
1302  IF ( .NOT.get_related_field ) THEN
1303  DO i = 1, input_fields(field)%num_output_fields
1304  cm_ind = input_fields(field)%output_fields(i)
1305  cm_file_num = output_fields(cm_ind)%output_file
1306 
1307  ! If time_method, freq, output_units, next_output, and last_output the same, or
1308  ! the output_field is static then valid for cell_measures
1309 !!$ For now, only static fields can be in an external file
1310 !!$ IF ( ( (files(cm_file_num)%output_freq.EQ.files(rel_file)%output_freq) .AND.&
1311 !!$ & (files(cm_file_num)%output_units.EQ.files(rel_file)%output_units) .AND.&
1312 !!$ & (output_fields(cm_ind)%time_ops.EQV.rel_field%time_ops) .AND.&
1313 !!$ & (output_fields(cm_ind)%next_output.EQ.rel_field%next_output) .AND.&
1314 !!$ & (output_fields(cm_ind)%last_output.EQ.rel_field%last_output) ).OR.&
1315 !!$ & ( output_fields(cm_ind)%static.OR.rel_field%static ) ) THEN
1316  IF ( output_fields(cm_ind)%static.OR.rel_field%static ) THEN
1317  get_related_field = .true.
1318  out_field_id = cm_ind
1319  out_file_id = cm_file_num
1320  EXIT
1321  END IF
1322  END DO
1323  END IF
1324  END FUNCTION get_related_field
1325 
1326  !> @brief If needed, add cell_measures and associated_file attribute to out field/file
1327  SUBROUTINE init_field_cell_measures(output_field, area, volume, err_msg)
1328  TYPE(output_field_type), INTENT(inout) :: output_field !< Output field that needs the cell_measures
1329  INTEGER, INTENT(in), OPTIONAL :: area !< Field ID for area
1330  INTEGER, INTENT(in), OPTIONAL :: volume !< Field ID for volume
1331  CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
1332 
1333  INTEGER :: cm_ind, cm_file_num, file_num
1334 
1335  IF ( PRESENT(err_msg) ) THEN
1336  err_msg = ''
1337  END IF
1338 
1339  ! Verify that area/volume are defined (.gt.0
1340  IF ( PRESENT(area) ) THEN
1341  IF ( area.LE.0 ) THEN
1342  IF ( fms_error_handler('diag_manager_mod::init_field_cell_measure',&
1343  & 'AREA field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1344  & '/'//trim(input_fields(output_field%input_field)%field_name), err_msg) ) RETURN
1345  END IF
1346  END IF
1347 
1348  IF ( PRESENT(volume) ) THEN
1349  IF ( volume.LE.0 ) THEN
1350  IF ( fms_error_handler('diag_manager_mod::init_field_cell_measure',&
1351  &'VOLUME field not in diag_table for field '//trim(input_fields(output_field%input_field)%module_name)//&
1352  & '/'//trim(input_fields(output_field%input_field)%field_name), err_msg) ) RETURN
1353  END IF
1354  END IF
1355 
1356  ! Get the file number that the output_field will be written to
1357  file_num = output_field%output_file
1358 
1359  ! Take care of the cell_measures attribute
1360  IF ( PRESENT(area) ) THEN
1361  IF ( get_related_field(area, output_field, cm_ind, cm_file_num) ) THEN
1362  CALL prepend_attribute(output_field, 'cell_measures',&
1363  & 'area: '//trim(output_fields(cm_ind)%output_name))
1364  IF ( cm_file_num.NE.file_num ) THEN
1365  ! Not in the same file, set the global attribute associated_files
1366  CALL add_associated_files(file_num, cm_file_num, cm_ind)
1367  END IF
1368  ELSE
1369  IF ( fms_error_handler('diag_manager_mod::init_field_cell_measures',&
1370  & 'AREA measures field "'//trim(input_fields(area)%module_name)//'/'//&
1371  & trim(input_fields(area)%field_name)//&
1372  & '" NOT in diag_table with correct output frequency for field '//&
1373  & trim(input_fields(output_field%input_field)%module_name)//&
1374  & '/'//trim(input_fields(output_field%input_field)%field_name), err_msg) ) RETURN
1375  END IF
1376  END IF
1377 
1378 
1379  IF ( PRESENT(volume) ) THEN
1380  IF ( get_related_field(volume, output_field, cm_ind, cm_file_num) ) THEN
1381  CALL prepend_attribute(output_field, 'cell_measures',&
1382  & 'volume: '//trim(output_fields(cm_ind)%output_name))
1383  IF ( cm_file_num.NE.file_num ) THEN
1384  ! Not in the same file, set the global attribute associated_files
1385  CALL add_associated_files(file_num, cm_file_num, cm_ind)
1386  END IF
1387  ELSE
1388  IF ( fms_error_handler('diag_manager_mod::init_field_cell_measures',&
1389  & 'VOLUME measures field "'//trim(input_fields(volume)%module_name)//'/'//&
1390  & trim(input_fields(volume)%field_name)//&
1391  & '" NOT in diag_table with correct output frequency for field '//&
1392  & trim(input_fields(output_field%input_field)%module_name)//&
1393  & '/'//trim(input_fields(output_field%input_field)%field_name), err_msg) ) RETURN
1394  END IF
1395  END IF
1396  END SUBROUTINE init_field_cell_measures
1397 
1398  !> @brief Add to the associated files attribute
1399  !!
1400  !! @throw FATAL, "Length of asso_file_name is not long enough to hold the associated file name."
1401  !! The length of character array asso_file_name is not long enough to hold the full file name
1402  !! of the associated_file. Please contact the developer to increase the length of the variable.
1403  SUBROUTINE add_associated_files(file_num, cm_file_num, cm_ind)
1404  INTEGER, intent(in) :: file_num !< File number that needs the associated_files attribute
1405  INTEGER, intent(in) :: cm_file_num !< file number that contains the associated field
1406  INTEGER, intent(in) :: cm_ind !< index of the output_field in the associated file
1407 
1408  INTEGER :: year, month, day, hour, minute, second
1409  INTEGER :: n
1410  CHARACTER(len=25) :: date_prefix
1411  CHARACTER(len=FMS_FILE_LEN) :: asso_file_name
1412 
1413  ! Create the date_string
1414  IF ( prepend_date ) THEN
1415  CALL get_date(diag_init_time, year, month, day, hour, minute, second)
1416  WRITE (date_prefix, '(1I20.4, 2I2.2,".")') year, month, day
1417  date_prefix=adjustl(date_prefix)
1418  ELSE
1419  date_prefix=''
1420  END IF
1421 
1422  ! Get the base file name
1423  ! Verify asso_file_name is long enough to hold the file name,
1424  ! plus 17 for the additional '.ens_??.tile?.nc' (and a null character)
1425  IF ( len_trim(files(cm_file_num)%name)+17 > len(asso_file_name) ) THEN
1426  CALL error_mesg ('diag_manager_mod::add_associated_files',&
1427  & 'Length of asso_file_name is not long enough to hold the associated file name. '&
1428  & //'Contact the developer', fatal)
1429  ELSE
1430  asso_file_name = trim(files(cm_file_num)%name)
1431  END IF
1432 
1433  ! Add the ensemble number string into the file name
1434  ! As frepp does not have native support for multiple ensemble runs
1435  ! this will not be done. However, the code is left here for the time
1436  ! frepp does.
1437  !CALL get_instance_filename(TRIM(asso_file_name), asso_file_name)
1438 
1439  ! Append .nc suffix, if needed. Note that we no longer try to append cubic sphere tile
1440  ! number to the name of the associated file.
1441  n = max(len_trim(asso_file_name),3)
1442  if (asso_file_name(n-2:n).NE.'.nc') asso_file_name = trim(asso_file_name)//'.nc'
1443 
1444  ! Should look like :associated_files = " output_name: output_file_name " ;
1445  CALL prepend_attribute(files(file_num), 'associated_files',&
1446  & trim(output_fields(cm_ind)%output_name)//': '//&
1447  & trim(date_prefix)//trim(asso_file_name))
1448  END SUBROUTINE add_associated_files
1449 
1450  !> @return true if send is successful
1451  LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg)
1452  INTEGER, INTENT(in) :: diag_field_id
1453  CLASS(*), INTENT(in) :: field
1454  TYPE(time_type), INTENT(in), OPTIONAL :: time
1455  CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
1456 
1457  CLASS(*), allocatable :: field_out(:, :, :) !< Local copy of field
1458 
1459  ! If diag_field_id is < 0 it means that this field is not registered, simply return
1460  IF ( diag_field_id <= 0 ) THEN
1461  send_data_0d = .false.
1462  RETURN
1463  END IF
1464 
1465  ! First copy the data to a three d array with last element 1
1466  SELECT TYPE (field)
1467  TYPE IS (real(kind=r4_kind))
1468  allocate(real(r4_kind) :: field_out(1,1,1))
1469  select type(field_out)
1470  type is (real(r4_kind))
1471  field_out(1, 1, 1) = field
1472  class default
1473  call error_mesg('diag_manager_mod::send_data_0d', &
1474  & 'Error allocating field out as real(r4_kind)', fatal)
1475  end select
1476  TYPE IS (real(kind=r8_kind))
1477  allocate(real(r8_kind) :: field_out(1,1,1))
1478  select type(field_out)
1479  type is (real(r8_kind))
1480  field_out(1, 1, 1) = field
1481  class default
1482  call error_mesg('diag_manager_mod::send_data_0d', &
1483  & 'Error allocating field out as real(r8_kind)', fatal)
1484  end select
1485  CLASS DEFAULT
1486  CALL error_mesg ('diag_manager_mod::send_data_0d',&
1487  & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1488  END SELECT
1489 
1490  send_data_0d = diag_send_data(diag_field_id, field_out, time, err_msg=err_msg)
1491  END FUNCTION send_data_0d
1492 
1493  !> @return true if send is successful
1494  LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
1495  INTEGER, INTENT(in) :: diag_field_id
1496  CLASS(*), DIMENSION(:), INTENT(in) :: field
1497  CLASS(*), INTENT(in), OPTIONAL :: weight
1498  CLASS(*), INTENT(in), DIMENSION(:), OPTIONAL :: rmask
1499  TYPE (time_type), INTENT(in), OPTIONAL :: time
1500  INTEGER, INTENT(in), OPTIONAL :: is_in, ie_in
1501  LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask
1502  CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
1503 
1504  CLASS(*), ALLOCATABLE :: field_out(:,:,:) !< Local copy of field
1505  LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out !< Local copy of mask
1506 
1507  ! If diag_field_id is < 0 it means that this field is not registered, simply return
1508  IF ( diag_field_id <= 0 ) THEN
1509  send_data_1d = .false.
1510  RETURN
1511  END IF
1512 
1513  ! First copy the data to a three d array with last element 1
1514  ! type checking done in diag_send_data
1515  SELECT TYPE (field)
1516  TYPE IS (real(kind=r4_kind))
1517  allocate(real(r4_kind) :: field_out(SIZE(field),1,1))
1518  select type(field_out)
1519  type is (real(r4_kind))
1520  field_out(:, 1, 1) = field
1521  class default
1522  call error_mesg('diag_manager_mod::send_data_1d', &
1523  & 'Error allocating field out as real(r4_kind)', fatal)
1524  end select
1525  TYPE IS (real(kind=r8_kind))
1526  allocate(real(r8_kind) :: field_out(SIZE(field),1,1))
1527  select type(field_out)
1528  type is (real(r8_kind))
1529  field_out(:, 1, 1) = field
1530  class default
1531  call error_mesg('diag_manager_mod::send_data_1d', &
1532  & 'Error allocating field out as real(r8_kind)', fatal)
1533  end select
1534  CLASS DEFAULT
1535  CALL error_mesg ('diag_manager_mod::send_data_1d',&
1536  & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1537  END SELECT
1538 
1539  ! Default values for mask
1540  IF ( PRESENT(mask) ) THEN
1541  mask_out(:, 1, 1) = mask
1542  ELSE
1543  mask_out = .true.
1544  END IF
1545 
1546  IF ( PRESENT(rmask) ) THEN
1547  SELECT TYPE (rmask)
1548  TYPE IS (real(kind=r4_kind))
1549  WHERE (rmask < 0.5_r4_kind) mask_out(:, 1, 1) = .false.
1550  TYPE IS (real(kind=r8_kind))
1551  WHERE (rmask < 0.5_r8_kind) mask_out(:, 1, 1) = .false.
1552  CLASS DEFAULT
1553  CALL error_mesg ('diag_manager_mod::send_data_1d',&
1554  & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1555  END SELECT
1556  END IF
1557 
1558  IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN
1559  IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN
1560  send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,&
1561  & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1562  ELSE
1563  send_data_1d = diag_send_data(diag_field_id, field_out, time, mask=mask_out,&
1564  & weight=weight, err_msg=err_msg)
1565  END IF
1566  ELSE
1567  IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN
1568  send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,&
1569  & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
1570  ELSE
1571  send_data_1d = diag_send_data(diag_field_id, field_out, time, weight=weight, err_msg=err_msg)
1572  END IF
1573  END IF
1574  END FUNCTION send_data_1d
1575 
1576  !> @return true if send is successful
1577  LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, &
1578  & mask, rmask, ie_in, je_in, weight, err_msg)
1579  INTEGER, INTENT(in) :: diag_field_id
1580  CLASS(*), INTENT(in), DIMENSION(:,:) :: field
1581  CLASS(*), INTENT(in), OPTIONAL :: weight
1582  TYPE (time_type), INTENT(in), OPTIONAL :: time
1583  INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ie_in, je_in
1584  LOGICAL, INTENT(in), DIMENSION(:,:), OPTIONAL :: mask
1585  CLASS(*), INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask
1586  CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
1587 
1588  CLASS(*), ALLOCATABLE :: field_out(:,:,:) !< Local copy of field
1589  LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out !< Local copy of mask
1590 
1591  ! If diag_field_id is < 0 it means that this field is not registered, simply return
1592  IF ( diag_field_id <= 0 ) THEN
1593  send_data_2d = .false.
1594  RETURN
1595  END IF
1596 
1597  ! First copy the data to a three d array with last element 1
1598  SELECT TYPE (field)
1599  TYPE IS (real(kind=r4_kind))
1600  allocate(real(r4_kind) :: field_out(SIZE(field,1),SIZE(field,2),1))
1601  select type(field_out)
1602  type is (real(r4_kind))
1603  field_out(:, :, 1) = field
1604  class default
1605  call error_mesg('diag_manager_mod::send_data_2d', &
1606  & 'Error allocating field out as real(r4_kind)', fatal)
1607  end select
1608  TYPE IS (real(kind=r8_kind))
1609  allocate(real(r8_kind) :: field_out(SIZE(field,1),SIZE(field,2),1))
1610  select type(field_out)
1611  type is (real(r8_kind))
1612  field_out(:, :, 1) = field
1613  class default
1614  call error_mesg('diag_manager_mod::send_data_2d', &
1615  & 'Error allocating field out as real(r8_kind)', fatal)
1616  end select
1617  CLASS DEFAULT
1618  CALL error_mesg ('diag_manager_mod::send_data_2d',&
1619  & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1620  END SELECT
1621 
1622  ! Default values for mask
1623  IF ( PRESENT(mask) ) THEN
1624  mask_out(:, :, 1) = mask
1625  ELSE
1626  mask_out = .true.
1627  END IF
1628 
1629  IF ( PRESENT(rmask) ) THEN
1630  SELECT TYPE (rmask)
1631  TYPE IS (real(kind=r4_kind))
1632  WHERE ( rmask < 0.5_r4_kind ) mask_out(:, :, 1) = .false.
1633  TYPE IS (real(kind=r8_kind))
1634  WHERE ( rmask < 0.5_r8_kind ) mask_out(:, :, 1) = .false.
1635  CLASS DEFAULT
1636  CALL error_mesg ('diag_manager_mod::send_data_2d',&
1637  & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1638  END SELECT
1639  END IF
1640 
1641  IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN
1642  send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,&
1643  & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1644  ELSE
1645  send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,&
1646  & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
1647  END IF
1648  END FUNCTION send_data_2d
1649 
1650  !> @return true if send is successful
1651  LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
1652  & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1653  INTEGER, INTENT(in) :: diag_field_id
1654  CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field
1655  CLASS(*), INTENT(in), OPTIONAL :: weight
1656  TYPE (time_type), INTENT(in), OPTIONAL :: time
1657  INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1658  LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask
1659  CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask
1660  CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
1661 
1662  if (present(mask) .and. present(rmask)) then
1663  send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, &
1664  mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, &
1665  err_msg=err_msg)
1666  elseif (present(rmask)) then
1667  send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, &
1668  rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1669  elseif (present(mask)) then
1670  send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, &
1671  mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1672  else
1673  send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, &
1674  ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
1675  endif
1676  END FUNCTION send_data_3d
1677 
1678  !> @return true if send is successful
1679 !TODO documentation, separate the old and new
1680  LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, &
1681  & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
1682  INTEGER, INTENT(in) :: diag_field_id
1683  CLASS(*), DIMENSION(:,:,:), INTENT(in),TARGET :: field
1684  CLASS(*), INTENT(in), OPTIONAL :: weight
1685  TYPE (time_type), INTENT(in), OPTIONAL :: time
1686  INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
1687  LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask
1688  CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask
1689  CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
1690 
1691  REAL :: weight1
1692  REAL :: missvalue
1693  INTEGER :: pow_value
1694  INTEGER :: ksr, ker
1695  INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4
1696  INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k
1697  INTEGER, DIMENSION(3) :: l_start !< local start indices on 3 axes for regional output
1698  INTEGER, DIMENSION(3) :: l_end !< local end indices on 3 axes for regional output
1699  INTEGER :: hi !< halo size in x direction
1700  INTEGER :: hj !< halo size in y direction
1701  INTEGER :: twohi !< halo size in x direction
1702  INTEGER :: twohj !< halo size in y direction
1703  INTEGER :: sample !< index along the diurnal time axis
1704  INTEGER :: day !< components of the current date
1705  INTEGER :: second !< components of the current date
1706  INTEGER :: tick !< components of the current date
1707  INTEGER :: status
1708  INTEGER :: numthreads
1709  INTEGER :: active_omp_level
1710 #if defined(_OPENMP)
1711  INTEGER :: omp_get_num_threads !< OMP function
1712  INTEGER :: omp_get_level !< OMP function
1713 #endif
1714  LOGICAL :: average, phys_window, need_compute
1715  LOGICAL :: reduced_k_range, local_output
1716  LOGICAL :: time_max, time_min, time_rms, time_sum
1717  LOGICAL :: missvalue_present
1718  LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: oor_mask
1719  CHARACTER(len=256) :: err_msg_local
1720  CHARACTER(len=128) :: error_string, error_string1
1721 
1722  REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field
1723  class(*), allocatable, dimension(:,:,:,:) :: field_remap !< 4d remapped array
1724  logical, allocatable, dimension(:,:,:,:) :: mask_remap !< 4d remapped array
1725  class(*), allocatable, dimension(:,:,:,:) :: rmask_remap !< 4d remapped array
1726  REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask
1727  REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 !<A pointer to r8 type of rmask
1728 
1729  TYPE(fmsdiagoutfieldindex_type), ALLOCATABLE:: ofield_index_cfg !<Instance used in calling math functions.
1730  TYPE(fmsdiagoutfield_type), ALLOCATABLE:: ofield_cfg !<Instance used in calling math functions.
1731  LOGICAL :: mf_result !<Logical result returned from some math (buffer udate) functions.
1732 
1733  REAL :: rmask_threshold !< Holds the values 0.5_r4_kind or 0.5_r8_kind, or related threhold values
1734  !! needed to be passed to the math/buffer update functions.
1735  character(len=:), allocatable :: field_name !< Name of the field
1736 
1737  ! If diag_field_id is < 0 it means that this field is not registered, simply return
1738  IF ( diag_field_id <= 0 ) THEN
1739  diag_send_data = .false.
1740  RETURN
1741  ELSE
1742  diag_send_data = .true.
1743  END IF
1744 
1745  IF ( PRESENT(err_msg) ) err_msg = ''
1746  IF ( .NOT.module_is_initialized ) THEN
1747  IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'diag_manager NOT initialized', err_msg) ) RETURN
1748  END IF
1749  err_msg_local = ''
1750  ! The following lines are commented out as they have not been included in the code prior to now,
1751  ! and there are a lot of send_data calls before register_diag_field calls. A method to do this safely
1752  ! needs to be developed.
1753  !
1754  ! Set first_send_data_call to .FALSE. on first non-static field.
1755 !!$ IF ( .NOT.input_fields(diag_field_id)%static .AND. first_send_data_call ) THEN
1756 !!$ first_send_data_call = .FALSE.
1757 !!$ END IF
1758 
1759  ! First copy the data to a three d array
1760  ALLOCATE(field_out(SIZE(field,1),SIZE(field,2),SIZE(field,3)), stat=status)
1761  IF ( status .NE. 0 ) THEN
1762  WRITE (err_msg_local, fmt='("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1763  & SIZE(field,1), SIZE(field,2), SIZE(field,3), status
1764  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN
1765  END IF
1766  SELECT TYPE (field)
1767  TYPE IS (real(kind=r4_kind))
1768  field_out = field
1769  TYPE IS (real(kind=r8_kind))
1770  field_out = real(field)
1771  CLASS DEFAULT
1772  CALL error_mesg ('diag_manager_mod::send_data_3d',&
1773  & 'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//&
1774  & 'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', fatal)
1775  END SELECT
1776  ! Split old and modern2023 here
1777  modern_if: iF (use_modern_diag) then
1778  field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id)
1779  call copy_3d_to_4d(field, field_remap, trim(field_name)//"'s data")
1780  if (present(rmask)) call copy_3d_to_4d(rmask, rmask_remap, trim(field_name)//"'s mask")
1781  if (present(mask)) then
1782  allocate(mask_remap(1:size(mask,1), 1:size(mask,2), 1:size(mask,3), 1))
1783  mask_remap(:,:,:,1) = mask
1784  endif
1785  call fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, &
1786  time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
1787  err_msg)
1788  deallocate (field_remap)
1789  if (allocated(mask_remap)) deallocate(mask_remap)
1790  if (allocated(rmask_remap)) deallocate(rmask_remap)
1791  elSE ! modern_if
1792  ! oor_mask is only used for checking out of range values.
1793  ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), stat=status)
1794  IF ( status .NE. 0 ) THEN
1795  WRITE (err_msg_local, fmt='("Unable to allocate oor_mask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
1796  & SIZE(field,1), SIZE(field,2), SIZE(field,3), status
1797  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN
1798  END IF
1799 
1800  IF ( PRESENT(mask) ) THEN
1801  oor_mask = mask
1802  ELSE
1803  oor_mask = .true.
1804  END IF
1805 
1806  rmask_ptr_r4 => null()
1807  rmask_ptr_r8 => null()
1808  IF ( PRESENT(rmask) ) THEN
1809  SELECT TYPE (rmask)
1810  TYPE IS (real(kind=r4_kind))
1811  WHERE ( rmask < 0.5_r4_kind ) oor_mask = .false.
1812  rmask_threshold = 0.5_r4_kind
1813  rmask_ptr_r4 => rmask
1814  TYPE IS (real(kind=r8_kind))
1815  WHERE ( rmask < 0.5_r8_kind ) oor_mask = .false.
1816  rmask_threshold = 0.5_r8_kind
1817  rmask_ptr_r8 => rmask
1818  CLASS DEFAULT
1819  CALL error_mesg ('diag_manager_mod::send_data_3d',&
1820  & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1821  END SELECT
1822  END IF
1823 
1824  ! send_data works in either one or another of two modes.
1825  ! 1. Input field is a window (e.g. FMS physics)
1826  ! 2. Input field includes halo data
1827  ! It cannot handle a window of data that has halos.
1828  ! (A field with no windows or halos can be thought of as a special case of either mode.)
1829  ! The logic for indexing is quite different for these two modes, but is not clearly separated.
1830  ! If both the beggining and ending indices are present, then field is assumed to have halos.
1831  ! If only beggining indices are present, then field is assumed to be a window.
1832 
1833  ! There are a number of ways a user could mess up this logic, depending on the combination
1834  ! of presence/absence of is,ie,js,je. The checks below should catch improper combinations.
1835  IF ( PRESENT(ie_in) ) THEN
1836  IF ( .NOT.PRESENT(is_in) ) THEN
1837  IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'ie_in present without is_in', err_msg) ) THEN
1838  DEALLOCATE(field_out)
1839  DEALLOCATE(oor_mask)
1840  RETURN
1841  END IF
1842  END IF
1843  IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN
1844  IF ( fms_error_handler('diag_manager_modsend_data_3d',&
1845  & 'is_in and ie_in present, but js_in present without je_in', err_msg) ) THEN
1846  DEALLOCATE(field_out)
1847  DEALLOCATE(oor_mask)
1848  RETURN
1849  END IF
1850  END IF
1851  END IF
1852  IF ( PRESENT(je_in) ) THEN
1853  IF ( .NOT.PRESENT(js_in) ) THEN
1854  IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'je_in present without js_in', err_msg) ) THEN
1855  DEALLOCATE(field_out)
1856  DEALLOCATE(oor_mask)
1857  RETURN
1858  END IF
1859  END IF
1860  IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN
1861  IF ( fms_error_handler('diag_manager_mod::send_data_3d',&
1862  & 'js_in and je_in present, but is_in present without ie_in', err_msg)) THEN
1863  DEALLOCATE(field_out)
1864  DEALLOCATE(oor_mask)
1865  RETURN
1866  END IF
1867  END IF
1868  END IF
1869 
1870  ! If is, js, or ks not present default them to 1
1871  is = 1
1872  js = 1
1873  ks = 1
1874  IF ( PRESENT(is_in) ) is = is_in
1875  IF ( PRESENT(js_in) ) js = js_in
1876  IF ( PRESENT(ks_in) ) ks = ks_in
1877  n1 = SIZE(field, 1)
1878  n2 = SIZE(field, 2)
1879  n3 = SIZE(field, 3)
1880  ie = is+n1-1
1881  je = js+n2-1
1882  ke = ks+n3-1
1883  IF ( PRESENT(ie_in) ) ie = ie_in
1884  IF ( PRESENT(je_in) ) je = je_in
1885  IF ( PRESENT(ke_in) ) ke = ke_in
1886  twohi = n1-(ie-is+1)
1887  IF ( mod(twohi,2) /= 0 ) THEN
1888  IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in first dimension', &
1889  & err_msg) ) THEN
1890  DEALLOCATE(field_out)
1891  DEALLOCATE(oor_mask)
1892  RETURN
1893  END IF
1894  END IF
1895  twohj = n2-(je-js+1)
1896  IF ( mod(twohj,2) /= 0 ) THEN
1897  IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in second dimension', &
1898  & err_msg) ) THEN
1899  DEALLOCATE(field_out)
1900  DEALLOCATE(oor_mask)
1901  RETURN
1902  END IF
1903  END IF
1904  hi = twohi/2
1905  hj = twohj/2
1906 
1907  ! The next line is necessary to ensure that is,ie,js,ie are relative to field(1:,1:)
1908  ! But this works only when there is no windowing.
1909  IF ( PRESENT(ie_in) .AND. PRESENT(je_in) ) THEN
1910  is=1+hi
1911  ie=n1-hi
1912  js=1+hj
1913  je=n2-hj
1914  END IF
1915 
1916  ! used for field, mask and rmask bounds
1917  f1=1+hi
1918  f2=n1-hi
1919  f3=1+hj
1920  f4=n2-hj
1921 
1922  ! weight is for time averaging where each time level may has a different weight
1923  IF ( PRESENT(weight) ) THEN
1924  SELECT TYPE (weight)
1925  TYPE IS (real(kind=r4_kind))
1926  weight1 = weight
1927  TYPE IS (real(kind=r8_kind))
1928  weight1 = real(weight)
1929  CLASS DEFAULT
1930  CALL error_mesg ('diag_manager_mod::send_data_3d',&
1931  & 'The weight is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
1932  END SELECT
1933  ELSE
1934  weight1 = 1.
1935  END IF
1936 
1937  ! Is there a missing_value?
1938  missvalue_present = input_fields(diag_field_id)%missing_value_present
1939  IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value
1940 
1941  number_of_outputs = input_fields(diag_field_id)%num_output_fields
1942 !$OMP CRITICAL
1943  input_fields(diag_field_id)%numthreads = 1
1944  active_omp_level=0
1945 #if defined(_OPENMP)
1946  input_fields(diag_field_id)%numthreads = omp_get_num_threads()
1947  input_fields(diag_field_id)%active_omp_level = omp_get_level()
1948 #endif
1949  numthreads = input_fields(diag_field_id)%numthreads
1950  active_omp_level = input_fields(diag_field_id)%active_omp_level
1951 !$OMP END CRITICAL
1952 
1953  if(present(time)) input_fields(diag_field_id)%time = time
1954 
1955  ! Issue a warning if any value in field is outside the valid range
1956  IF ( input_fields(diag_field_id)%range_present ) THEN
1957  IF ( issue_oor_warnings .OR. oor_warnings_fatal ) THEN
1958  WRITE (error_string, '("[",ES14.5E3,",",ES14.5E3,"]")')&
1959  & input_fields(diag_field_id)%range(1:2)
1960  WRITE (error_string1, '("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')&
1961  & minval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke)),&
1962  & maxval(field_out(f1:f2,f3:f4,ks:ke),mask=oor_mask(f1:f2,f3:f4,ks:ke))
1963  IF ( missvalue_present ) THEN
1964  IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1965  & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1966  & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
1967  & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) ) THEN
1968  ! <ERROR STATUS="WARNING/FATAL">
1969  ! A value for <module_name> in field <field_name> (Min: <min_val>, Max: <max_val>)
1970  ! is outside the range [<lower_val>,<upper_val>] and not equal to the missing
1971  ! value.
1972  ! </ERROR>
1973  CALL error_mesg('diag_manager_mod::send_data_3d',&
1974  & 'A value for '//&
1975  &trim(input_fields(diag_field_id)%module_name)//' in field '//&
1976  &trim(input_fields(diag_field_id)%field_name)//' '&
1977  &//trim(error_string1)//&
1978  &' is outside the range '//trim(error_string)//',&
1979  & and not equal to the missing value.',&
1980  &oor_warning)
1981  END IF
1982  ELSE
1983  IF ( any(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
1984  & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
1985  & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) ) THEN
1986  ! <ERROR STATUS="WARNING/FATAL">
1987  ! A value for <module_name> in field <field_name> (Min: <min_val>, Max: <max_val>)
1988  ! is outside the range [<lower_val>,<upper_val>].
1989  ! </ERROR>
1990  CALL error_mesg('diag_manager_mod::send_data_3d',&
1991  & 'A value for '//&
1992  &trim(input_fields(diag_field_id)%module_name)//' in field '//&
1993  &trim(input_fields(diag_field_id)%field_name)//' '&
1994  &//trim(error_string1)//&
1995  &' is outside the range '//trim(error_string)//'.',&
1996  &oor_warning)
1997  END IF
1998  END IF
1999  END IF
2000  END IF
2001 
2002  ! Loop through each output field that depends on this input field
2003  num_out_fields: DO ii = 1, number_of_outputs
2004  ! Get index to an output field
2005  out_num = input_fields(diag_field_id)%output_fields(ii)
2006 
2007  ! is this field output on a local domain only?
2008  local_output = output_fields(out_num)%local_output
2009  ! if local_output, does the current PE take part in send_data?
2010  need_compute = output_fields(out_num)%need_compute
2011 
2012  reduced_k_range = output_fields(out_num)%reduced_k_range
2013 
2014  ! skip all PEs not participating in outputting this field
2015  IF ( local_output .AND. (.NOT.need_compute) ) cycle
2016 
2017  ! Get index to output file for this field
2018  file_num = output_fields(out_num)%output_file
2019  IF(file_num == max_files) cycle
2020  ! Output frequency and units for this file is
2021  freq = files(file_num)%output_freq
2022  units = files(file_num)%output_units
2023  ! Is this output field being time averaged?
2024  average = output_fields(out_num)%time_average
2025  ! Is this output field the rms?
2026  ! If so, then average is also .TRUE.
2027  time_rms = output_fields(out_num)%time_rms
2028  ! Power value for rms or pow(x) calculations
2029  pow_value = output_fields(out_num)%pow_value
2030  ! Looking for max and min value of this field over the sampling interval?
2031  time_max = output_fields(out_num)%time_max
2032  time_min = output_fields(out_num)%time_min
2033  ! Sum output over time interval
2034  time_sum = output_fields(out_num)%time_sum
2035  IF ( output_fields(out_num)%total_elements > SIZE(field_out(f1:f2,f3:f4,ks:ke)) ) THEN
2036  output_fields(out_num)%phys_window = .true.
2037  ELSE
2038  output_fields(out_num)%phys_window = .false.
2039  END IF
2040  phys_window = output_fields(out_num)%phys_window
2041  IF ( need_compute ) THEN
2042  l_start = output_fields(out_num)%output_grid%l_start_indx
2043  l_end = output_fields(out_num)%output_grid%l_end_indx
2044  END IF
2045 
2046  ! compute the diurnal index
2047  sample = 1
2048  IF ( PRESENT(time) ) THEN
2049  CALL get_time(time,second,day,tick) ! current date
2050  sample = floor( (second+real(tick)/get_ticks_per_second()) &
2051  & * output_fields(out_num)%n_diurnal_samples/seconds_per_day) + 1
2052  END IF
2053 
2054  ! Get the vertical layer start and end index.
2055  IF ( reduced_k_range ) THEN
2056 !----------
2057 !ug support
2058  if (output_fields(out_num)%reduced_k_unstruct) then
2059  f3 = output_fields(out_num)%output_grid%l_start_indx(2)
2060  f4 = output_fields(out_num)%output_grid%l_end_indx(2)
2061  js = 1
2062  je = f4 - f3 + 1
2063  endif
2064  l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3)
2065  l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3)
2066 !----------
2067  END IF
2068  ksr= l_start(3)
2069  ker= l_end(3)
2070 
2071  ! Initialize output time for fields output every time step
2072  IF ( freq == every_time .AND. .NOT.output_fields(out_num)%static ) THEN
2073  IF (PRESENT(time)) THEN
2074  IF ( numthreads .ne. 1 .or. active_omp_level .gt. 1) THEN
2075  ! Openmp parallel region:
2076  ! Outputs will be done in diag_send_complete
2077  ! Always overwrite next_output so that this will be used in files
2078  IF ( time > output_fields(out_num)%last_output ) THEN
2079  output_fields(out_num)%next_output = time
2080  END IF
2081  ELSE
2082  ! Non-openmp parallel region:
2083  ! Outputs will be done in this function
2084  ! Only overwrite next_output time when it is equal to last_output
2085  IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output ) THEN
2086  output_fields(out_num)%next_output = time
2087  END IF
2088  END IF
2089  ELSE IF ( output_fields(out_num)%next_output == output_fields(out_num)%last_output ) THEN
2090  WRITE (error_string,'(a,"/",a)')&
2091  & trim(input_fields(diag_field_id)%module_name),&
2092  & trim(output_fields(out_num)%output_name)
2093  IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//trim(error_string)//&
2094  & ', time must be present when output frequency = EVERY_TIME', err_msg)) THEN
2095  DEALLOCATE(field_out)
2096  DEALLOCATE(oor_mask)
2097  RETURN
2098  END IF
2099  END IF
2100  END IF
2101  IF ( .NOT.output_fields(out_num)%static .AND. .NOT.PRESENT(time) ) THEN
2102  WRITE (error_string,'(a,"/",a)')&
2103  & trim(input_fields(diag_field_id)%module_name), &
2104  & trim(output_fields(out_num)%output_name)
2105  IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//trim(error_string)//&
2106  & ', time must be present for nonstatic field', err_msg)) THEN
2107  DEALLOCATE(field_out)
2108  DEALLOCATE(oor_mask)
2109  RETURN
2110  END IF
2111  END IF
2112 
2113  ! Is it time to output for this field; CAREFUL ABOUT > vs >= HERE
2114  !--- The fields send out within openmp parallel region will be written out in
2115  !--- diag_send_complete.
2116  IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) ) then
2117  IF ( .NOT.output_fields(out_num)%static .AND. freq /= end_of_run ) THEN
2118  IF ( time > output_fields(out_num)%next_output ) THEN
2119  ! A non-static field that has skipped a time level is an error
2120  IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 ) THEN
2121  IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN
2122  WRITE (error_string,'(a,"/",a)')&
2123  & trim(input_fields(diag_field_id)%module_name), &
2124  & trim(output_fields(out_num)%output_name)
2125  IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//&
2126  & trim(error_string)//' is skipped one time level in output data', err_msg)) THEN
2127  DEALLOCATE(field_out)
2128  DEALLOCATE(oor_mask)
2129  RETURN
2130  END IF
2131  END IF
2132  END IF
2133 
2134  status = writing_field(out_num, .false., error_string, time)
2135  IF(status == -1) THEN
2136  IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN
2137  IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//trim(error_string)&
2138  & //', write EMPTY buffer', err_msg)) THEN
2139  DEALLOCATE(field_out)
2140  DEALLOCATE(oor_mask)
2141  RETURN
2142  END IF
2143  END IF
2144  END IF
2145  END IF !time > output_fields(out_num)%next_output
2146  END IF !.not.output_fields(out_num)%static .and. freq /= END_OF_RUN
2147  ! Finished output of previously buffered data, now deal with buffering new data
2148  END IF
2149 
2150  if (present(time)) then
2151  !! If the last_output is greater than the time passed in, it is not time to start averaging the data
2152  if (output_fields(out_num)%last_output > time) cycle
2153  endif
2154 
2155  IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN
2156  CALL check_bounds_are_exact_dynamic(out_num, diag_field_id, time, err_msg=err_msg_local)
2157  IF ( err_msg_local /= '' ) THEN
2158  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
2159  DEALLOCATE(field_out)
2160  DEALLOCATE(oor_mask)
2161  RETURN
2162  END IF
2163  END IF
2164  END IF
2165 
2166  IF (use_refactored_send) THEN
2167  ALLOCATE( ofield_index_cfg )
2168  CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, &
2169  & hi, hj, f1, f2, f3, f4)
2170 
2171  ALLOCATE( ofield_cfg )
2172  CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num), PRESENT(mask), freq)
2173 
2174  IF ( average ) THEN
2175  !!TODO (Future work): the copy that is filed_out should not be necessary
2176  mf_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, &
2177  & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,&
2178  & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), &
2179  & mask, weight1 ,missvalue, &
2180  & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,&
2181  & input_fields(diag_field_id)%issued_mask_ignore_warning, &
2182  & l_start, l_end, err_msg, err_msg_local )
2183  IF (mf_result .eqv. .false.) THEN
2184  DEALLOCATE(ofield_index_cfg)
2185  DEALLOCATE(ofield_cfg)
2186  DEALLOCATE(field_out)
2187  DEALLOCATE(oor_mask)
2188  RETURN
2189  END IF
2190  ELSE !!NOT AVERAGE
2191  mf_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_out, sample, &
2192  & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , &
2193  & output_fields(out_num)%count_0d(sample), &
2194  & mask, missvalue, l_start, l_end, err_msg, err_msg_local)
2195  IF (mf_result .eqv. .false.) THEN
2196  DEALLOCATE(ofield_index_cfg)
2197  DEALLOCATE(ofield_cfg)
2198  DEALLOCATE(field_out)
2199  DEALLOCATE(oor_mask)
2200  RETURN
2201  END IF
2202  END IF
2203 
2204  IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN
2205  CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local)
2206  IF ( err_msg_local /= '' ) THEN
2207  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg)) THEN
2208  DEALLOCATE(field_out)
2209  DEALLOCATE(oor_mask)
2210  RETURN
2211  END IF
2212  END IF
2213  END IF
2214 
2215  !!TODO: (Discusssion) One of the calls below will not compile depending
2216  !! on the value of REAL. This is to the mixed use of REAL, R4, R8 and CLASS(*)
2217  !! in send_data_3d. A copy of rmask can be made to avoid but it would be wasteful.
2218  !! The option used for now is that the original code to copy missing values is
2219  !! is used at the end of this procedure.
2220  !IF ( PRESENT(rmask) .AND. missvalue_present ) THEN
2221  ! SELECT TYPE (rmask)
2222  ! TYPE IS (real(kind=r4_kind))
2223  ! call fieldbuff_copy_missvals(ofield_cfg, ofield_index_cfg, &
2224  ! & output_fields(out_num)%buffer, sample, &
2225  ! & l_start, l_end, rmask_ptr_r4, rmask_threshold, missvalue)
2226  ! TYPE IS (real(kind=r8_kind))
2227  ! call fieldbuff_copy_missvals(ofield_cfg, ofield_index_cfg, &
2228  ! & output_fields(out_num)%buffer, sample, &
2229  ! & l_start, l_end, rmask_ptr_r8, rmask_threshold, missvalue)
2230  ! CLASS DEFAULT
2231  ! CALL error_mesg ('diag_manager_mod::send_data_3d',&
2232  ! & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
2233  ! END SELECT
2234  !END IF
2235 
2236  IF(ALLOCATED(ofield_index_cfg)) THEN
2237  DEALLOCATE(ofield_index_cfg)
2238  ENDIF
2239  IF(ALLOCATED(ofield_cfg)) THEN
2240  DEALLOCATE(ofield_cfg)
2241  ENDIF
2242 
2243  ELSE !! END USE_REFACTORED_SEND; Don''t use CYCLE option.
2244 
2245  ! Take care of submitted field data
2246  IF ( average ) THEN
2247  IF ( input_fields(diag_field_id)%mask_variant ) THEN
2248  IF ( need_compute ) THEN
2249  WRITE (error_string,'(a,"/",a)') &
2250  & trim(input_fields(diag_field_id)%module_name), &
2251  & trim(output_fields(out_num)%output_name)
2252  IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//trim(error_string)//&
2253  & ', regional output NOT supported with mask_variant', err_msg)) THEN
2254  DEALLOCATE(field_out)
2255  DEALLOCATE(oor_mask)
2256  RETURN
2257  END IF
2258  END IF
2259 
2260  ! Should reduced_k_range data be supported with the mask_variant option ?????
2261  ! If not, error message should be produced and the reduced_k_range loop below eliminated
2262  IF ( PRESENT(mask) ) THEN
2263  IF ( missvalue_present ) THEN
2264  IF ( debug_diag_manager ) THEN
2265  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2266  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
2267  IF ( err_msg_local /= '' ) THEN
2268  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
2269  DEALLOCATE(field_out)
2270  DEALLOCATE(oor_mask)
2271  RETURN
2272  END IF
2273  END IF
2274  END IF
2275  IF( numthreads>1 .AND. phys_window ) then
2276  IF ( reduced_k_range ) THEN
2277  DO k= ksr, ker
2278  k1= k - ksr + 1
2279  DO j=js, je
2280  DO i=is, ie
2281  IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN
2282  IF ( pow_value /= 1 ) THEN
2283  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2284  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2285  & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2286  ELSE
2287  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2288  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2289  & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2290  END IF
2291  output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2292  & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2293  END IF
2294  END DO
2295  END DO
2296  END DO
2297  ELSE
2298  DO k=ks, ke
2299  DO j=js, je
2300  DO i=is, ie
2301  IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN
2302  IF ( pow_value /= 1 ) THEN
2303  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2304  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2305  & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2306  ELSE
2307  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2308  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2309  & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2310  END IF
2311  output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2312  &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2313  END IF
2314  END DO
2315  END DO
2316  END DO
2317  END IF
2318  ELSE
2319 !$OMP CRITICAL
2320  IF ( reduced_k_range ) THEN
2321  DO k= ksr, ker
2322  k1= k - ksr + 1
2323  DO j=js, je
2324  DO i=is, ie
2325  IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN
2326  IF ( pow_value /= 1 ) THEN
2327  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2328  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2329  & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
2330  ELSE
2331  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2332  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2333  & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
2334  END IF
2335  output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
2336  & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
2337  END IF
2338  END DO
2339  END DO
2340  END DO
2341  ELSE
2342  DO k=ks, ke
2343  DO j=js, je
2344  DO i=is, ie
2345  IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN
2346  IF ( pow_value /= 1 ) THEN
2347  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2348  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2349  & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
2350  ELSE
2351  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2352  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2353  & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
2354  END IF
2355  output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
2356  &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
2357  END IF
2358  END DO
2359  END DO
2360  END DO
2361  END IF
2362 !$OMP END CRITICAL
2363  END IF
2364  ELSE
2365  WRITE (error_string,'(a,"/",a)')&
2366  & trim(input_fields(diag_field_id)%module_name), &
2367  & trim(output_fields(out_num)%output_name)
2368  IF(fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//trim(error_string)//&
2369  & ', variable mask but no missing value defined', err_msg)) THEN
2370  DEALLOCATE(field_out)
2371  DEALLOCATE(oor_mask)
2372  RETURN
2373  END IF
2374  END IF
2375  ELSE ! no mask present
2376  WRITE (error_string,'(a,"/",a)')&
2377  & trim(input_fields(diag_field_id)%module_name), &
2378  & trim(output_fields(out_num)%output_name)
2379  IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//trim(error_string)//&
2380  & ', variable mask but no mask given', err_msg)) THEN
2381  DEALLOCATE(field_out)
2382  DEALLOCATE(oor_mask)
2383  RETURN
2384  END IF
2385  END IF
2386  ELSE ! mask_variant=false
2387  IF ( PRESENT(mask) ) THEN
2388  IF ( missvalue_present ) THEN
2389  IF ( need_compute ) THEN
2390  IF (numthreads>1 .AND. phys_window) then
2391  DO k = l_start(3), l_end(3)
2392  k1 = k-l_start(3)+1
2393  DO j = js, je
2394  DO i = is, ie
2395  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2396  & j <= l_end(2)+hj ) THEN
2397  i1 = i-l_start(1)-hi+1
2398  j1= j-l_start(2)-hj+1
2399  IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN
2400  IF ( pow_value /= 1 ) THEN
2401  output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2402  & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2403  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2404  ELSE
2405  output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2406  & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2407  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2408  END IF
2409  ELSE
2410  output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2411  END IF
2412  END IF
2413  END DO
2414  END DO
2415  END DO
2416  ELSE
2417 !$OMP CRITICAL
2418  DO k = l_start(3), l_end(3)
2419  k1 = k-l_start(3)+1
2420  DO j = js, je
2421  DO i = is, ie
2422  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2423  & j <= l_end(2)+hj ) THEN
2424  i1 = i-l_start(1)-hi+1
2425  j1= j-l_start(2)-hj+1
2426  IF ( mask(i-is+1+hi, j-js+1+hj, k) ) THEN
2427  IF ( pow_value /= 1 ) THEN
2428  output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2429  & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2430  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2431  ELSE
2432  output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2433  & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2434  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2435  END IF
2436  ELSE
2437  output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2438  END IF
2439  END IF
2440  END DO
2441  END DO
2442  END DO
2443 !$OMP END CRITICAL
2444  ENDIF
2445 !$OMP CRITICAL
2446  DO j = js, je
2447  DO i = is, ie
2448  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2449  & j <= l_end(2)+hj ) THEN
2450  output_fields(out_num)%num_elements(sample) = &
2451  output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2452  END IF
2453  END DO
2454  END DO
2455 !$OMP END CRITICAL
2456  ELSE IF ( reduced_k_range ) THEN
2457  IF (numthreads>1 .AND. phys_window) then
2458  DO k=ksr, ker
2459  k1 = k - ksr + 1
2460  DO j=js, je
2461  DO i=is, ie
2462  IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN
2463  IF ( pow_value /= 1 ) THEN
2464  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2465  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2466  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2467  ELSE
2468  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2469  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2470  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2471  END IF
2472  ELSE
2473  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2474  END IF
2475  END DO
2476  END DO
2477  END DO
2478  ELSE
2479 !$OMP CRITICAL
2480  DO k=ksr, ker
2481  k1 = k - ksr + 1
2482  DO j=js, je
2483  DO i=is, ie
2484  IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN
2485  IF ( pow_value /= 1 ) THEN
2486  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2487  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2488  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2489  ELSE
2490  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2491  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2492  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2493  END IF
2494  ELSE
2495  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
2496  END IF
2497  END DO
2498  END DO
2499  END DO
2500 !$OMP END CRITICAL
2501  END IF
2502  ELSE
2503  IF ( debug_diag_manager ) THEN
2504  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2505  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
2506  IF ( err_msg_local /= '' ) THEN
2507  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
2508  DEALLOCATE(field_out)
2509  DEALLOCATE(oor_mask)
2510  RETURN
2511  END IF
2512  END IF
2513  END IF
2514  IF (numthreads>1 .AND. phys_window) then
2515  DO k=ks, ke
2516  DO j=js, je
2517  DO i=is, ie
2518  IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN
2519  IF ( pow_value /= 1 ) THEN
2520  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2521  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2522  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2523  ELSE
2524  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2525  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2526  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2527  END IF
2528  ELSE
2529  output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2530  END IF
2531  END DO
2532  END DO
2533  END DO
2534  ELSE
2535 !$OMP CRITICAL
2536  DO k=ks, ke
2537  DO j=js, je
2538  DO i=is, ie
2539  IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN
2540  IF ( pow_value /= 1 ) THEN
2541  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2542  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2543  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2544  ELSE
2545  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2546  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2547  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2548  END IF
2549  ELSE
2550  output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
2551  END IF
2552  END DO
2553  END DO
2554  END DO
2555 !$OMP END CRITICAL
2556  END IF
2557  END IF
2558 !$OMP CRITICAL
2559  IF ( need_compute .AND. .NOT.phys_window ) THEN
2560  IF ( any(mask(l_start(1)+hi:l_end(1)+hi,l_start(2)+hj:l_end(2)+hj,l_start(3):l_end(3))) ) &
2561  & output_fields(out_num)%count_0d(sample) =&
2562  & output_fields(out_num)%count_0d(sample) + weight1
2563  ELSE
2564  IF ( any(mask(f1:f2,f3:f4,ks:ke)) ) output_fields(out_num)%count_0d(sample) =&
2565  & output_fields(out_num)%count_0d(sample)+weight1
2566  END IF
2567 !$OMP END CRITICAL
2568 
2569  ELSE ! missing value NOT present
2570  IF ( (.NOT.all(mask(f1:f2,f3:f4,ks:ke)) .AND. mpp_pe() .EQ. mpp_root_pe()).AND.&
2571  & .NOT.input_fields(diag_field_id)%issued_mask_ignore_warning ) THEN
2572  ! <ERROR STATUS="WARNING">
2573  ! Mask will be ignored since missing values were not specified for field <field_name>
2574  ! in module <module_name>
2575  ! </ERROR>
2576  CALL error_mesg('diag_manager_mod::send_data_3d',&
2577  & 'Mask will be ignored since missing values were not specified for field '//&
2578  & trim(input_fields(diag_field_id)%field_name)//' in module '//&
2579  & trim(input_fields(diag_field_id)%module_name), warning)
2580  input_fields(diag_field_id)%issued_mask_ignore_warning = .true.
2581  END IF
2582  IF ( need_compute ) THEN
2583  IF (numthreads>1 .AND. phys_window) then
2584  DO j = js, je
2585  DO i = is, ie
2586  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2587  & j <= l_end(2)+hj ) THEN
2588  i1 = i-l_start(1)-hi+1
2589  j1 = j-l_start(2)-hj+1
2590  IF ( pow_value /= 1 ) THEN
2591  output_fields(out_num)%buffer(i1,j1,:,sample)= &
2592  & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2593  & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2594  ELSE
2595  output_fields(out_num)%buffer(i1,j1,:,sample)= &
2596  & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2597  & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2598  END IF
2599  END IF
2600  END DO
2601  END DO
2602  ELSE
2603 !$OMP CRITICAL
2604  DO j = js, je
2605  DO i = is, ie
2606  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2607  & j <= l_end(2)+hj ) THEN
2608  i1 = i-l_start(1)-hi+1
2609  j1 = j-l_start(2)-hj+1
2610  IF ( pow_value /= 1 ) THEN
2611  output_fields(out_num)%buffer(i1,j1,:,sample)= &
2612  & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2613  & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2614  ELSE
2615  output_fields(out_num)%buffer(i1,j1,:,sample)= &
2616  & output_fields(out_num)%buffer(i1,j1,:,sample)+ &
2617  & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2618  END IF
2619  END IF
2620  END DO
2621  END DO
2622 !$OMP END CRITICAL
2623  END IF
2624 !$OMP CRITICAL
2625  DO j = js, je
2626  DO i = is, ie
2627  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2628  & j <= l_end(2)+hj ) THEN
2629  output_fields(out_num)%num_elements(sample)=&
2630  & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2631 
2632  END IF
2633  END DO
2634  END DO
2635 !$OMP END CRITICAL
2636  ELSE IF ( reduced_k_range ) THEN
2637  IF (numthreads>1 .AND. phys_window) then
2638  ksr= l_start(3)
2639  ker= l_end(3)
2640  IF ( pow_value /= 1 ) THEN
2641  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2642  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2643  & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2644  ELSE
2645  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2646  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2647  & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2648  END IF
2649  ELSE
2650 !$OMP CRITICAL
2651  ksr= l_start(3)
2652  ker= l_end(3)
2653  IF ( pow_value /= 1 ) THEN
2654  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2655  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2656  & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2657  ELSE
2658  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2659  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
2660  & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2661  END IF
2662 !$OMP END CRITICAL
2663  END IF
2664  ELSE
2665  IF ( debug_diag_manager ) THEN
2666  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2667  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
2668  IF ( err_msg_local /= '') THEN
2669  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
2670  DEALLOCATE(field_out)
2671  DEALLOCATE(oor_mask)
2672  RETURN
2673  END IF
2674  END IF
2675  END IF
2676  IF (numthreads>1 .AND. phys_window) then
2677  IF ( pow_value /= 1 ) THEN
2678  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2679  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2680  & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2681  ELSE
2682  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2683  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2684  & field_out(f1:f2,f3:f4,ks:ke)*weight1
2685  END IF
2686  ELSE
2687 !$OMP CRITICAL
2688  IF ( pow_value /= 1 ) THEN
2689  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2690  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2691  & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
2692  ELSE
2693  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
2694  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
2695  & field_out(f1:f2,f3:f4,ks:ke)*weight1
2696  END IF
2697 !$OMP END CRITICAL
2698  END IF
2699  END IF
2700 !$OMP CRITICAL
2701  IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
2702  & output_fields(out_num)%count_0d(sample) + weight1
2703 !$OMP END CRITICAL
2704  END IF
2705  ELSE ! mask NOT present
2706  IF ( missvalue_present ) THEN
2707  IF ( need_compute ) THEN
2708  if( numthreads>1 .AND. phys_window ) then
2709  DO k = l_start(3), l_end(3)
2710  k1 = k - l_start(3) + 1
2711  DO j = js, je
2712  DO i = is, ie
2713  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2714  & j <= l_end(2)+hj) THEN
2715  i1 = i-l_start(1)-hi+1
2716  j1= j-l_start(2)-hj+1
2717  IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
2718  IF ( pow_value /= 1 ) THEN
2719  output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2720  & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2721  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2722  ELSE
2723  output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2724  & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2725  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2726  END IF
2727  ELSE
2728  output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2729  END IF
2730  END IF
2731  END DO
2732  END DO
2733  END DO
2734  ELSE
2735 !$OMP CRITICAL
2736  DO k = l_start(3), l_end(3)
2737  k1 = k - l_start(3) + 1
2738  DO j = js, je
2739  DO i = is, ie
2740  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2741  & j <= l_end(2)+hj) THEN
2742  i1 = i-l_start(1)-hi+1
2743  j1= j-l_start(2)-hj+1
2744  IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
2745  IF ( pow_value /= 1 ) THEN
2746  output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2747  & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2748  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2749  ELSE
2750  output_fields(out_num)%buffer(i1,j1,k1,sample) =&
2751  & output_fields(out_num)%buffer(i1,j1,k1,sample) +&
2752  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2753  END IF
2754  ELSE
2755  output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
2756  END IF
2757  END IF
2758  END DO
2759  END DO
2760  END DO
2761 !$OMP END CRITICAL
2762  END IF
2763 !$OMP CRITICAL
2764  DO j = js, je
2765  DO i = is, ie
2766  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2767  & j <= l_end(2)+hj) THEN
2768  output_fields(out_num)%num_elements(sample) =&
2769  & output_fields(out_num)%num_elements(sample) + l_end(3) - l_start(3) + 1
2770  END IF
2771  END DO
2772  END DO
2773  IF ( .NOT.phys_window ) THEN
2774  outer0: DO k = l_start(3), l_end(3)
2775  DO j=l_start(2)+hj, l_end(2)+hj
2776  DO i=l_start(1)+hi, l_end(1)+hi
2777  IF ( field_out(i,j,k) /= missvalue ) THEN
2778  output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample)&
2779  & + weight1
2780  EXIT outer0
2781  END IF
2782  END DO
2783  END DO
2784  END DO outer0
2785  END IF
2786 !$OMP END CRITICAL
2787  ELSE IF ( reduced_k_range ) THEN
2788  if( numthreads>1 .AND. phys_window ) then
2789  ksr= l_start(3)
2790  ker= l_end(3)
2791  DO k = ksr, ker
2792  k1 = k - ksr + 1
2793  DO j=js, je
2794  DO i=is, ie
2795  IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
2796  IF ( pow_value /= 1 ) THEN
2797  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2798  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2799  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2800  ELSE
2801  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2802  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2803  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2804  END IF
2805  ELSE
2806  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2807  END IF
2808  END DO
2809  END DO
2810  END DO
2811  else
2812 !$OMP CRITICAL
2813  ksr= l_start(3)
2814  ker= l_end(3)
2815  DO k = ksr, ker
2816  k1 = k - ksr + 1
2817  DO j=js, je
2818  DO i=is, ie
2819  IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
2820  IF ( pow_value /= 1 ) THEN
2821  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2822  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2823  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2824  ELSE
2825  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
2826  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
2827  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2828  END IF
2829  ELSE
2830  output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
2831  END IF
2832  END DO
2833  END DO
2834  END DO
2835 !$OMP END CRITICAL
2836  END IF
2837 !$OMP CRITICAL
2838  outer3: DO k = ksr, ker
2839  k1=k-ksr+1
2840  DO j=f3, f4
2841  DO i=f1, f2
2842  IF ( field_out(i,j,k) /= missvalue ) THEN
2843  output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2844  & + weight1
2845  EXIT outer3
2846  END IF
2847  END DO
2848  END DO
2849  END DO outer3
2850 !$OMP END CRITICAL
2851  ELSE
2852  IF ( debug_diag_manager ) THEN
2853  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
2854  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
2855  IF ( err_msg_local /= '' ) THEN
2856  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
2857  DEALLOCATE(field_out)
2858  DEALLOCATE(oor_mask)
2859  RETURN
2860  END IF
2861  END IF
2862  END IF
2863  IF( numthreads > 1 .AND. phys_window ) then
2864  DO k=ks, ke
2865  DO j=js, je
2866  DO i=is, ie
2867  IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
2868  IF ( pow_value /= 1 ) THEN
2869  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2870  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2871  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2872  ELSE
2873  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2874  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2875  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2876  END IF
2877  ELSE
2878  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2879  END IF
2880  END DO
2881  END DO
2882  END DO
2883  ELSE
2884 !$OMP CRITICAL
2885  DO k=ks, ke
2886  DO j=js, je
2887  DO i=is, ie
2888  IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
2889  IF ( pow_value /= 1 ) THEN
2890  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2891  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2892  & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
2893  ELSE
2894  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
2895  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
2896  & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
2897  END IF
2898  ELSE
2899  output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
2900  END IF
2901  END DO
2902  END DO
2903  END DO
2904 !$OMP END CRITICAL
2905  END IF
2906 !$OMP CRITICAL
2907  outer1: DO k=ks, ke
2908  DO j=f3, f4
2909  DO i=f1, f2
2910  IF ( field_out(i,j,k) /= missvalue ) THEN
2911  output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) &
2912  & + weight1
2913  EXIT outer1
2914  END IF
2915  END DO
2916  END DO
2917  END DO outer1
2918 !$OMP END CRITICAL
2919  END IF
2920  ELSE ! no missing value defined, No mask
2921  IF ( need_compute ) THEN
2922  IF( numthreads > 1 .AND. phys_window ) then
2923  DO j = js, je
2924  DO i = is, ie
2925  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2926  & j <= l_end(2)+hj ) THEN
2927  i1 = i-l_start(1)-hi+1
2928  j1= j-l_start(2)-hj+1
2929  IF ( pow_value /= 1 ) THEN
2930  output_fields(out_num)%buffer(i1,j1,:,sample)= &
2931  & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2932  & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2933  ELSE
2934  output_fields(out_num)%buffer(i1,j1,:,sample)= &
2935  & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2936  & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2937  END IF
2938  END IF
2939  END DO
2940  END DO
2941  ELSE
2942 !$OMP CRITICAL
2943  DO j = js, je
2944  DO i = is, ie
2945  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2946  & j <= l_end(2)+hj ) THEN
2947  i1 = i-l_start(1)-hi+1
2948  j1= j-l_start(2)-hj+1
2949  IF ( pow_value /= 1 ) THEN
2950  output_fields(out_num)%buffer(i1,j1,:,sample)= &
2951  & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2952  & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
2953  ELSE
2954  output_fields(out_num)%buffer(i1,j1,:,sample)= &
2955  & output_fields(out_num)%buffer(i1,j1,:,sample) +&
2956  & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
2957  END IF
2958  END IF
2959  END DO
2960  END DO
2961 !$OMP END CRITICAL
2962  END IF
2963 
2964 !$OMP CRITICAL
2965  DO j = js, je
2966  DO i = is, ie
2967  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
2968  & j <= l_end(2)+hj ) THEN
2969  output_fields(out_num)%num_elements(sample) =&
2970  & output_fields(out_num)%num_elements(sample)+l_end(3)-l_start(3)+1
2971  END IF
2972  END DO
2973  END DO
2974 !$OMP END CRITICAL
2975  ! Accumulate time average
2976  ELSE IF ( reduced_k_range ) THEN
2977  ksr= l_start(3)
2978  ker= l_end(3)
2979  IF( numthreads > 1 .AND. phys_window ) then
2980  IF ( pow_value /= 1 ) THEN
2981  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2982  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2983  & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2984  ELSE
2985  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2986  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2987  & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2988  END IF
2989  ELSE
2990 !$OMP CRITICAL
2991  IF ( pow_value /= 1 ) THEN
2992  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2993  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2994  & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
2995  ELSE
2996  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
2997  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
2998  & field_out(f1:f2,f3:f4,ksr:ker)*weight1
2999  END IF
3000 !$OMP END CRITICAL
3001  END IF
3002  ELSE
3003  IF ( debug_diag_manager ) THEN
3004  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3005  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
3006  IF ( err_msg_local /= '' ) THEN
3007  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
3008  DEALLOCATE(field_out)
3009  DEALLOCATE(oor_mask)
3010  RETURN
3011  END IF
3012  END IF
3013  END IF
3014  IF( numthreads > 1 .AND. phys_window ) then
3015  IF ( pow_value /= 1 ) THEN
3016  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3017  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3018  & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3019  ELSE
3020  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3021  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3022  & field_out(f1:f2,f3:f4,ks:ke)*weight1
3023  END IF
3024  ELSE
3025 !$OMP CRITICAL
3026  IF ( pow_value /= 1 ) THEN
3027  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3028  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3029  & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
3030  ELSE
3031  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
3032  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
3033  & field_out(f1:f2,f3:f4,ks:ke)*weight1
3034  END IF
3035 !$OMP END CRITICAL
3036  END IF
3037  END IF
3038 !$OMP CRITICAL
3039  IF ( .NOT.phys_window ) output_fields(out_num)%count_0d(sample) =&
3040  & output_fields(out_num)%count_0d(sample) + weight1
3041 !$OMP END CRITICAL
3042  END IF
3043  END IF ! if mask present
3044  END IF !if mask_variant
3045 !$OMP CRITICAL
3046  IF ( .NOT.need_compute .AND. .NOT.reduced_k_range )&
3047  & output_fields(out_num)%num_elements(sample) =&
3048  & output_fields(out_num)%num_elements(sample) + (ie-is+1)*(je-js+1)*(ke-ks+1)
3049  IF ( reduced_k_range ) &
3050  & output_fields(out_num)%num_elements(sample) = output_fields(out_num)%num_elements(sample) +&
3051  & (ie-is+1)*(je-js+1)*(ker-ksr+1)
3052 !$OMP END CRITICAL
3053  ! Add processing for Max and Min
3054  ELSE IF ( time_max ) THEN
3055  IF ( PRESENT(mask) ) THEN
3056  IF ( need_compute ) THEN
3057  DO k = l_start(3), l_end(3)
3058  k1 = k - l_start(3) + 1
3059  DO j = js, je
3060  DO i = is, ie
3061  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3062  & j <= l_end(2)+hj ) THEN
3063  i1 = i-l_start(1)-hi+1
3064  j1= j-l_start(2)-hj+1
3065  IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k)>&
3066  & output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
3067  output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3068  END IF
3069  END IF
3070  END DO
3071  END DO
3072  END DO
3073  ! Maximum time value with masking
3074  ELSE IF ( reduced_k_range ) THEN
3075  ksr = l_start(3)
3076  ker = l_end(3)
3077  WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) >&
3078  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) )&
3079  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3080  ELSE
3081  IF ( debug_diag_manager ) THEN
3082  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3083  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
3084  IF ( err_msg_local /= '' ) THEN
3085  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
3086  DEALLOCATE(field_out)
3087  DEALLOCATE(oor_mask)
3088  RETURN
3089  END IF
3090  END IF
3091  END IF
3092  WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke)>&
3093  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3094  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3095  END IF
3096  ELSE
3097  IF ( need_compute ) THEN
3098  DO k = l_start(3), l_end(3)
3099  k1 = k - l_start(3) + 1
3100  DO j = js, je
3101  DO i = is, ie
3102  IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3103  & j <= l_end(2)+hj ) THEN
3104  i1 = i-l_start(1)-hi+1
3105  j1 = j-l_start(2)-hj+1
3106  IF ( field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
3107  output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3108  END IF
3109  END IF
3110  END DO
3111  END DO
3112  END DO
3113  ! Maximum time value
3114  ELSE IF ( reduced_k_range ) THEN
3115  ksr = l_start(3)
3116  ker = l_end(3)
3117  WHERE ( field_out(f1:f2,f3:f4,ksr:ker) >&
3118  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3119  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3120  ELSE
3121  IF ( debug_diag_manager ) THEN
3122  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3123  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
3124  IF ( err_msg_local /= '' ) THEN
3125  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
3126  DEALLOCATE(field_out)
3127  DEALLOCATE(oor_mask)
3128  RETURN
3129  END IF
3130  END IF
3131  END IF
3132  WHERE ( field_out(f1:f2,f3:f4,ks:ke) >&
3133  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3134  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3135  END IF
3136  END IF
3137  output_fields(out_num)%count_0d(sample) = 1
3138  ELSE IF ( time_min ) THEN
3139  IF ( PRESENT(mask) ) THEN
3140  IF ( need_compute ) THEN
3141  DO k = l_start(3), l_end(3)
3142  k1 = k - l_start(3) + 1
3143  DO j = js, je
3144  DO i = is, ie
3145  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3146  & j <= l_end(2)+hj ) THEN
3147  i1 = i-l_start(1)-hi+1
3148  j1 = j-l_start(2)-hj+1
3149  IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND. field_out(i-is+1+hi,j-js+1+hj,k) <&
3150  & output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
3151  output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3152  END IF
3153  END IF
3154  END DO
3155  END DO
3156  END DO
3157  ! Minimum time value with masking
3158  ELSE IF ( reduced_k_range ) THEN
3159  ksr= l_start(3)
3160  ker= l_end(3)
3161  WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. field_out(f1:f2,f3:f4,ksr:ker) <&
3162  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3163  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3164  ELSE
3165  IF ( debug_diag_manager ) THEN
3166  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3167  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
3168  IF ( err_msg_local /= '' ) THEN
3169  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
3170  DEALLOCATE(field_out)
3171  DEALLOCATE(oor_mask)
3172  RETURN
3173  END IF
3174  END IF
3175  END IF
3176  WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND. field_out(f1:f2,f3:f4,ks:ke) <&
3177  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
3178  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3179  END IF
3180  ELSE
3181  IF ( need_compute ) THEN
3182  DO k = l_start(3), l_end(3)
3183  k1 = k - l_start(3) + 1
3184  DO j = js, je
3185  DO i = is, ie
3186  IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj) THEN
3187  i1 = i-l_start(1)-hi+1
3188  j1= j-l_start(2)-hj+1
3189  IF ( field_out(i-is+1+hi,j-js+1+hj,k) <&
3190  & output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
3191  output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
3192  END IF
3193  END IF
3194  END DO
3195  END DO
3196  END DO
3197  ! Minimum time value
3198  ELSE IF ( reduced_k_range ) THEN
3199  ksr= l_start(3)
3200  ker= l_end(3)
3201  WHERE ( field_out(f1:f2,f3:f4,ksr:ker) <&
3202  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
3203  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3204  ELSE
3205  IF ( debug_diag_manager ) THEN
3206  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3207  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
3208  IF ( err_msg_local /= '' ) THEN
3209  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
3210  DEALLOCATE(field_out)
3211  DEALLOCATE(oor_mask)
3212  RETURN
3213  END IF
3214  END IF
3215  END IF
3216  WHERE ( field_out(f1:f2,f3:f4,ks:ke) <&
3217  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
3218  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3219  END IF
3220  END IF
3221  output_fields(out_num)%count_0d(sample) = 1
3222  ELSE IF ( time_sum ) THEN
3223  IF ( PRESENT(mask) ) THEN
3224  IF ( need_compute ) THEN
3225  DO k = l_start(3), l_end(3)
3226  k1 = k - l_start(3) + 1
3227  DO j = js, je
3228  DO i = is, ie
3229  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3230  & j <= l_end(2)+hj ) THEN
3231  i1 = i-l_start(1)-hi+1
3232  j1 = j-l_start(2)-hj+1
3233  IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN
3234  output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3235  output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3236  field_out(i-is+1+hi,j-js+1+hj,k)
3237  END IF
3238  END IF
3239  END DO
3240  END DO
3241  END DO
3242  ! Minimum time value with masking
3243  ELSE IF ( reduced_k_range ) THEN
3244  ksr= l_start(3)
3245  ker= l_end(3)
3246  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3247  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3248  & field_out(f1:f2,f3:f4,ksr:ker)
3249  ELSE
3250  IF ( debug_diag_manager ) THEN
3251  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3252  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
3253  IF ( err_msg_local /= '' ) THEN
3254  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
3255  DEALLOCATE(field_out)
3256  DEALLOCATE(oor_mask)
3257  RETURN
3258  END IF
3259  END IF
3260  END IF
3261  WHERE ( mask(f1:f2,f3:f4,ks:ke) ) &
3262  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3263  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3264  & field_out(f1:f2,f3:f4,ks:ke)
3265  END IF
3266  ELSE
3267  IF ( need_compute ) THEN
3268  DO k = l_start(3), l_end(3)
3269  k1 = k - l_start(3) + 1
3270  DO j = js, je
3271  DO i = is, ie
3272  IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj) THEN
3273  i1 = i-l_start(1)-hi+1
3274  j1= j-l_start(2)-hj+1
3275  output_fields(out_num)%buffer(i1,j1,k1,sample) = &
3276  & output_fields(out_num)%buffer(i1,j1,k1,sample) + &
3277  & field_out(i-is+1+hi,j-js+1+hj,k)
3278  END IF
3279  END DO
3280  END DO
3281  END DO
3282  ELSE IF ( reduced_k_range ) THEN
3283  ksr= l_start(3)
3284  ker= l_end(3)
3285  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
3286  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
3287  & field_out(f1:f2,f3:f4,ksr:ker)
3288  ELSE
3289  IF ( debug_diag_manager ) THEN
3290  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3291  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
3292  IF ( err_msg_local /= '' ) THEN
3293  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
3294  DEALLOCATE(field_out)
3295  DEALLOCATE(oor_mask)
3296  RETURN
3297  END IF
3298  END IF
3299  END IF
3300  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
3301  & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
3302  & field_out(f1:f2,f3:f4,ks:ke)
3303  END IF
3304  END IF
3305  output_fields(out_num)%count_0d(sample) = 1
3306  ELSE ! ( not average, not min, not max, not sum )
3307  output_fields(out_num)%count_0d(sample) = 1
3308  IF ( need_compute ) THEN
3309  DO j = js, je
3310  DO i = is, ie
3311  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj) THEN
3312  i1 = i-l_start(1)-hi+1
3313  j1 = j-l_start(2)-hj+1
3314  output_fields(out_num)%buffer(i1,j1,:,sample) =&
3315  & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
3316  END IF
3317  END DO
3318  END DO
3319  ! instantaneous output
3320  ELSE IF ( reduced_k_range ) THEN
3321  ksr = l_start(3)
3322  ker = l_end(3)
3323  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
3324  ELSE
3325  IF ( debug_diag_manager ) THEN
3326  CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
3327  CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
3328  IF ( err_msg_local /= '' ) THEN
3329  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
3330  DEALLOCATE(field_out)
3331  DEALLOCATE(oor_mask)
3332  RETURN
3333  END IF
3334  END IF
3335  END IF
3336  output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
3337  END IF
3338 
3339  IF ( PRESENT(mask) .AND. missvalue_present ) THEN
3340  IF ( need_compute ) THEN
3341  DO k = l_start(3), l_end(3)
3342  k1 = k - l_start(3) + 1
3343  DO j = js, je
3344  DO i = is, ie
3345  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. &
3346  & j <= l_end(2)+hj ) THEN
3347  i1 = i-l_start(1)-hi+1
3348  j1 = j-l_start(2)-hj+1
3349  IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3350  & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3351  END IF
3352  END DO
3353  END DO
3354  END DO
3355  ELSE IF ( reduced_k_range ) THEN
3356  ksr= l_start(3)
3357  ker= l_end(3)
3358  DO k=ksr, ker
3359  k1= k - ksr + 1
3360  DO j=js, je
3361  DO i=is, ie
3362  IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) ) &
3363  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3364  END DO
3365  END DO
3366  END DO
3367  ELSE
3368  DO k=ks, ke
3369  DO j=js, je
3370  DO i=is, ie
3371  IF ( .NOT.mask(i-is+1+hi,j-js+1+hj,k) )&
3372  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3373  END DO
3374  END DO
3375  END DO
3376  END IF
3377  END IF
3378  END IF !average
3379 
3380  IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN
3381  CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local)
3382  IF ( err_msg_local /= '' ) THEN
3383  IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg)) THEN
3384  DEALLOCATE(field_out)
3385  DEALLOCATE(oor_mask)
3386  RETURN
3387  END IF
3388  END IF
3389  END IF
3390 
3391  END IF !! END OF IS_USE_REFACTORED SEND
3392 
3393  ! If rmask and missing value present, then insert missing value
3394  IF ( PRESENT(rmask) .AND. missvalue_present ) THEN
3395  IF ( need_compute ) THEN
3396  SELECT TYPE (rmask)
3397  TYPE IS (real(kind=r4_kind))
3398  DO k = l_start(3), l_end(3)
3399  k1 = k - l_start(3) + 1
3400  DO j = js, je
3401  DO i = is, ie
3402  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3403  & j <= l_end(2)+hj ) THEN
3404  i1 = i-l_start(1)-hi+1
3405  j1 = j-l_start(2)-hj+1
3406  IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3407  & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3408  END IF
3409  END DO
3410  END DO
3411  END DO
3412  TYPE IS (real(kind=r8_kind))
3413  DO k = l_start(3), l_end(3)
3414  k1 = k - l_start(3) + 1
3415  DO j = js, je
3416  DO i = is, ie
3417  IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.&
3418  & j <= l_end(2)+hj ) THEN
3419  i1 = i-l_start(1)-hi+1
3420  j1 = j-l_start(2)-hj+1
3421  IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3422  & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
3423  END IF
3424  END DO
3425  END DO
3426  END DO
3427  CLASS DEFAULT
3428  CALL error_mesg ('diag_manager_mod::send_data_3d',&
3429  & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3430  END SELECT
3431  ELSE IF ( reduced_k_range ) THEN
3432  ksr= l_start(3)
3433  ker= l_end(3)
3434  SELECT TYPE (rmask)
3435  TYPE IS (real(kind=r4_kind))
3436  DO k= ksr, ker
3437  k1 = k - ksr + 1
3438  DO j=js, je
3439  DO i=is, ie
3440  IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3441  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3442  END DO
3443  END DO
3444  END DO
3445  TYPE IS (real(kind=r8_kind))
3446  DO k= ksr, ker
3447  k1 = k - ksr + 1
3448  DO j=js, je
3449  DO i=is, ie
3450  IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3451  & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
3452  END DO
3453  END DO
3454  END DO
3455  CLASS DEFAULT
3456  CALL error_mesg ('diag_manager_mod::send_data_3d',&
3457  & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3458  END SELECT
3459  ELSE
3460  SELECT TYPE (rmask)
3461  TYPE IS (real(kind=r4_kind))
3462  DO k=ks, ke
3463  DO j=js, je
3464  DO i=is, ie
3465  IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
3466  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3467  END DO
3468  END DO
3469  END DO
3470  TYPE IS (real(kind=r8_kind))
3471  DO k=ks, ke
3472  DO j=js, je
3473  DO i=is, ie
3474  IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
3475  & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
3476  END DO
3477  END DO
3478  END DO
3479  CLASS DEFAULT
3480  CALL error_mesg ('diag_manager_mod::send_data_3d',&
3481  & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
3482  END SELECT
3483  END IF
3484  END IF
3485 
3486  END DO num_out_fields
3487 
3488  DEALLOCATE(field_out)
3489  DEALLOCATE(oor_mask)
3490  endIF modern_if
3491  END FUNCTION diag_send_data
3492 
3493  !> @brief Updates the output buffer for a field based on the data for current time step
3494  !! @return true if send is successful
3495  LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, &
3496  & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
3497  INTEGER, INTENT(in) :: diag_field_id !< The field id returned from the register call
3498  CLASS(*), INTENT(in) :: field(:,:,:,:) !< The field data for the current time step
3499  CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight to multiply the data by when averaging
3500  TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current model time
3501  INTEGER, INTENT(in), OPTIONAL :: is_in !< Starting i index of the data
3502  INTEGER, INTENT(in), OPTIONAL :: js_in !< Starting j index of the data
3503  INTEGER, INTENT(in), OPTIONAL :: ks_in !< Starting k index of the data
3504  INTEGER, INTENT(in), OPTIONAL :: ie_in !< Ending i index of the data
3505  INTEGER, INTENT(in), OPTIONAL :: je_in !< Ending j index of the data
3506  INTEGER, INTENT(in), OPTIONAL :: ke_in !< Ending k index of the data
3507  LOGICAL, INTENT(in), OPTIONAL :: mask(:,:,:,:) !< Logical mask indicating the points to not average
3508  CLASS(*), INTENT(in), OPTIONAL :: rmask(:,:,:,:) !< Real mask indicating the points to not averafe
3509  CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< If some errors occurs, send_data will return the
3510  !! error message instead of crashing
3511 
3512  class(*), allocatable :: rmask_local(:,:,:,:) !< Real version of the mask variable
3513  logical, allocatable :: mask_local(:,:,:,:) !< Local version of the mask variable
3514 
3515  ! If diag_field_id is < 0 it means that this field is not registered, simply return
3516  IF ( diag_field_id <= 0 ) THEN
3517  send_data_4d = .false.
3518  RETURN
3519  ENDIF
3520 
3521  if (.not. use_modern_diag) &
3522  call mpp_error(fatal, "Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.")
3523 
3524  !< The error checking is done in accept_data
3525  if (present(mask)) mask_local = mask
3526  if (present(rmask)) rmask_local = rmask
3527 
3528  call fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, &
3529  time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
3530  err_msg)
3531  send_data_4d = .true.
3532 
3533  if (present(err_msg)) then
3534  if (err_msg .ne. "") then
3535  call mpp_error(note, trim(err_msg))
3536  send_data_4d = .false.
3537  return
3538  endif
3539  endif
3540 
3541  if (allocated(rmask_local)) deallocate(rmask_local)
3542  if (allocated(mask_local)) deallocate(mask_local)
3543  end function send_data_4d
3544 
3545  !> @return true if send is successful
3546  LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask )
3547  INTEGER, INTENT(in) :: id !< id od the diagnostic field
3548  REAL, INTENT(in) :: field(:,:) !< field to average and send
3549  REAL, INTENT(in) :: area (:,:) !< area of tiles (== averaging weights), arbitrary units
3550  TYPE(time_type), INTENT(in) :: time !< current time
3551  LOGICAL, INTENT(in),OPTIONAL :: mask (:,:) !< land mask
3552 
3553  REAL, DIMENSION(SIZE(field,1)) :: out(size(field,1))
3554 
3555  ! If id is < 0 it means that this field is not registered, simply return
3556  IF ( id <= 0 ) THEN
3557  send_tile_averaged_data1d = .false.
3558  RETURN
3559  END IF
3560 
3561  CALL average_tiles1d (id, field, area, mask, out)
3562  send_tile_averaged_data1d = send_data(id, out, time=time, mask=any(mask,dim=2))
3563  END FUNCTION send_tile_averaged_data1d
3564 
3565  !> @brief Calculates average for a field with the given area and land mask
3566  SUBROUTINE average_tiles1d(diag_field_id, x, area, mask, out)
3567  INTEGER, INTENT(in) :: diag_field_id
3568  REAL, DIMENSION(:,:), INTENT(in) :: x !< (ug_index, tile) field to average
3569  REAL, DIMENSION(:,:), INTENT(in) :: area !< (ug_index, tile) fractional area
3570  LOGICAL, DIMENSION(:,:), INTENT(in) :: mask !< (ug_index, tile) land mask
3571  REAL, DIMENSION(:), INTENT(out) :: out !< (ug_index) result of averaging
3572 
3573  INTEGER :: it !< iterator over tile number
3574  REAL, DIMENSION(SIZE(x,1)) :: s !< area accumulator
3575  REAL :: local_missing_value
3576 
3577  ! # FATAL if diag_field_id is less than 0, indicates field was not in diag_table.
3578  ! The calling functions should not have passed in an invalid diag_field_id
3579  IF ( diag_field_id <= 0 ) THEN
3580  ! <ERROR STATUS="FATAL">
3581  ! diag_field_id less than 0. Contact developers.
3582  ! </ERROR>
3583  CALL error_mesg('diag_manager_mod::average_tiles1d',&
3584  & "diag_field_id less than 0. Contact developers.", fatal)
3585  END IF
3586 
3587  ! Initialize local_missing_value
3588  IF ( input_fields(diag_field_id)%missing_value_present ) THEN
3589  local_missing_value = input_fields(diag_field_id)%missing_value
3590  ELSE
3591  local_missing_value = 0.0
3592  END IF
3593 
3594  ! Initialize s and out to zero.
3595  s(:) = 0.0
3596  out(:) = 0.0
3597 
3598  DO it = 1, SIZE(area,dim=2)
3599  WHERE ( mask(:,it) )
3600  out(:) = out(:) + x(:,it)*area(:,it)
3601  s(:) = s(:) + area(:,it)
3602  END WHERE
3603  END DO
3604 
3605  WHERE ( s(:) > 0 )
3606  out(:) = out(:)/s(:)
3607  ELSEWHERE
3608  out(:) = local_missing_value
3609  END WHERE
3610  END SUBROUTINE average_tiles1d
3611 
3612  !> @return true if send is successful
3613  LOGICAL FUNCTION send_tile_averaged_data2d ( id, field, area, time, mask )
3614  INTEGER, INTENT(in) :: id !< id od the diagnostic field
3615  REAL, INTENT(in) :: field(:,:,:) !< field to average and send
3616  REAL, INTENT(in) :: area (:,:,:) !< area of tiles (== averaging weights), arbitrary units
3617  TYPE(time_type), INTENT(in) :: time !< current time
3618  LOGICAL, INTENT(in),OPTIONAL :: mask (:,:,:) !< land mask
3619 
3620  REAL, DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(size(field,1), size(field,2))
3621 
3622  ! If id is < 0 it means that this field is not registered, simply return
3623  IF ( id <= 0 ) THEN
3624  send_tile_averaged_data2d = .false.
3625  RETURN
3626  END IF
3627 
3628  CALL average_tiles(id, field, area, mask, out)
3629  send_tile_averaged_data2d = send_data(id, out, time, mask=any(mask,dim=3))
3630  END FUNCTION send_tile_averaged_data2d
3631 
3632  !> @return true if send is successful
3633  LOGICAL FUNCTION send_tile_averaged_data3d( id, field, area, time, mask )
3634  INTEGER, INTENT(in) :: id !< id of the diagnostic field
3635  REAL, DIMENSION(:,:,:,:), INTENT(in) :: field !< (lon, lat, tile, lev) field to average and send
3636  REAL, DIMENSION(:,:,:), INTENT(in) :: area (:,:,:) !< (lon, lat, tile) tile areas ( == averaging
3637  !! weights), arbitrary units
3638  TYPE(time_type), INTENT(in) :: time !< current time
3639  LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask !< (lon, lat, tile) land mask
3640 
3641  REAL, DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out
3642  LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3
3643  INTEGER :: it
3644 
3645  ! If id is < 0 it means that this field is not registered, simply return
3646  IF ( id <= 0 ) THEN
3647  send_tile_averaged_data3d = .false.
3648  RETURN
3649  END IF
3650 
3651  DO it=1, SIZE(field,4)
3652  CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) )
3653  END DO
3654 
3655  mask3(:,:,1) = any(mask,dim=3)
3656  DO it = 2, SIZE(field,4)
3657  mask3(:,:,it) = mask3(:,:,1)
3658  END DO
3659 
3660  send_tile_averaged_data3d = send_data( id, out, time, mask=mask3 )
3661  END FUNCTION send_tile_averaged_data3d
3662 
3663  !> @brief Calculates tile average of a field
3664  SUBROUTINE average_tiles(diag_field_id, x, area, mask, out)
3665  INTEGER, INTENT(in) :: diag_field_id
3666  REAL, DIMENSION(:,:,:), INTENT(in) :: x !< (lon, lat, tile) field to average
3667  REAL, DIMENSION(:,:,:), INTENT(in) :: area !< (lon, lat, tile) fractional area
3668  LOGICAL, DIMENSION(:,:,:), INTENT(in) :: mask !< (lon, lat, tile) land mask
3669  REAL, DIMENSION(:,:), INTENT(out) :: out !< (lon, lat) result of averaging
3670 
3671  INTEGER :: it !< iterator over tile number
3672  REAL, DIMENSION(SIZE(x,1),SIZE(x,2)) :: s !< area accumulator
3673  REAL :: local_missing_value
3674 
3675  ! # FATAL if diag_field_id is less than 0, indicates field was not in diag_table.
3676  ! The calling functions should not have passed in an invalid diag_field_id
3677  IF ( diag_field_id <= 0 ) THEN
3678  ! <ERROR STATUS="FATAL">
3679  ! diag_field_id less than 0. Contact developers.
3680  ! </ERROR>
3681  CALL error_mesg('diag_manager_mod::average_tiles',&
3682  & "diag_field_id less than 0. Contact developers.", fatal)
3683  END IF
3684 
3685  ! Initialize local_missing_value
3686  IF ( input_fields(diag_field_id)%missing_value_present ) THEN
3687  local_missing_value = input_fields(diag_field_id)%missing_value
3688  ELSE
3689  local_missing_value = 0.0
3690  END IF
3691 
3692  ! Initialize s and out to zero.
3693  s(:,:) = 0.0
3694  out(:,:) = 0.0
3695 
3696  DO it = 1, SIZE(area,3)
3697  WHERE ( mask(:,:,it) )
3698  out(:,:) = out(:,:) + x(:,:,it)*area(:,:,it)
3699  s(:,:) = s(:,:) + area(:,:,it)
3700  END WHERE
3701  END DO
3702 
3703  WHERE ( s(:,:) > 0 )
3704  out(:,:) = out(:,:)/s(:,:)
3705  ELSEWHERE
3706  out(:,:) = local_missing_value
3707  END WHERE
3708  END SUBROUTINE average_tiles
3709 
3710  !> @return Integer writing_field
3711  INTEGER FUNCTION writing_field(out_num, at_diag_end, error_string, time)
3712  INTEGER, INTENT(in) :: out_num
3713  LOGICAL, INTENT(in) :: at_diag_end
3714  CHARACTER(len=*), INTENT(out) :: error_string
3715  TYPE(time_type), INTENT(in) :: time
3716 
3717  TYPE(time_type) :: middle_time
3718  TYPE(time_type) :: filename_time
3719  LOGICAL :: time_max, time_min, reduced_k_range, missvalue_present
3720  LOGICAL :: average, time_rms, need_compute, phys_window
3721  INTEGER :: in_num, file_num, freq, units
3722  INTEGER :: b1,b2,b3,b4 !< size of buffer along x,y,z,and diurnal axes
3723  INTEGER :: i, j, k, m
3724  REAL :: missvalue, num
3725  writing_field = 0
3726 
3727  need_compute = output_fields(out_num)%need_compute
3728 
3729  in_num = output_fields(out_num)%input_field
3730  IF ( input_fields(in_num)%static ) RETURN
3731 
3732  missvalue = input_fields(in_num)%missing_value
3733  missvalue_present = input_fields(in_num)%missing_value_present
3734  reduced_k_range = output_fields(out_num)%reduced_k_range
3735  phys_window = output_fields(out_num)%phys_window
3736  ! Is this output field being time averaged?
3737  average = output_fields(out_num)%time_average
3738  ! Are we taking the rms of the field?
3739  ! If so, then average is also .TRUE.
3740  time_rms = output_fields(out_num)%time_rms
3741  ! Looking for max and min value of this field over the sampling interval?
3742  time_max = output_fields(out_num)%time_max
3743  time_min = output_fields(out_num)%time_min
3744  file_num = output_fields(out_num)%output_file
3745  freq = files(file_num)%output_freq
3746  units = files(file_num)%output_units
3747 
3748  ! If average get size: Average intervals are last_output, next_output
3749  IF ( average ) THEN
3750  b1=SIZE(output_fields(out_num)%buffer,1)
3751  b2=SIZE(output_fields(out_num)%buffer,2)
3752  b3=SIZE(output_fields(out_num)%buffer,3)
3753  b4=SIZE(output_fields(out_num)%buffer,4)
3754  IF ( input_fields(in_num)%mask_variant ) THEN
3755  DO m=1, b4
3756  DO k=1, b3
3757  DO j=1, b2
3758  DO i=1, b1
3759  IF ( output_fields(out_num)%counter(i,j,k,m) > 0. )THEN
3760  output_fields(out_num)%buffer(i,j,k,m) = &
3761  & output_fields(out_num)%buffer(i,j,k,m)/output_fields(out_num)%counter(i,j,k,m)
3762  IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) = &
3763  sqrt(output_fields(out_num)%buffer(i,j,k,m))
3764  ELSE
3765  output_fields(out_num)%buffer(i,j,k,m) = missvalue
3766  END IF
3767  END DO
3768  END DO
3769  END DO
3770  END DO
3771  ELSE !not mask variant
3772  DO m = 1, b4
3773  IF ( phys_window ) THEN
3774  IF ( need_compute .OR. reduced_k_range ) THEN
3775  num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%region_elements)
3776  ELSE
3777  num = real(output_fields(out_num)%num_elements(m)/output_fields(out_num)%total_elements)
3778  END IF
3779  ELSE
3780  num = output_fields(out_num)%count_0d(m)
3781  END IF
3782  IF ( num > 0. ) THEN
3783  IF ( missvalue_present ) THEN
3784  DO k=1, b3
3785  DO j=1, b2
3786  DO i=1, b1
3787  IF ( output_fields(out_num)%buffer(i,j,k,m) /= missvalue ) THEN
3788  output_fields(out_num)%buffer(i,j,k,m) = output_fields(out_num)%buffer(i,j,k,m)/num
3789  IF ( time_rms ) output_fields(out_num)%buffer(i,j,k,m) =&
3790  & sqrt(output_fields(out_num)%buffer(i,j,k,m))
3791  END IF
3792  END DO
3793  END DO
3794  END DO
3795  ELSE
3796  output_fields(out_num)%buffer(:,:,:,m) = output_fields(out_num)%buffer(:,:,:,m)/num
3797  IF ( time_rms ) output_fields(out_num)%buffer(:,:,:,m) =&
3798  & sqrt(output_fields(out_num)%buffer(:,:,:,m))
3799  END IF
3800  ELSE IF ( .NOT. at_diag_end ) THEN
3801  IF ( missvalue_present ) THEN
3802  IF(any(output_fields(out_num)%buffer /= missvalue)) THEN
3803  WRITE (error_string,'(a,"/",a)')&
3804  & trim(input_fields(in_num)%module_name), &
3805  & trim(output_fields(out_num)%output_name)
3806  writing_field = -1
3807  RETURN
3808  END IF
3809  END IF
3810  END IF
3811  END DO
3812  END IF ! mask_variant
3813  ELSE IF ( time_min .OR. time_max ) THEN
3814  IF ( missvalue_present ) THEN
3815  WHERE ( abs(output_fields(out_num)%buffer) == min_value )
3816  output_fields(out_num)%buffer = missvalue
3817  END WHERE
3818  END IF ! if missvalue is NOT present buffer retains max_value or min_value
3819  END IF !average
3820 
3821  ! Output field
3822  IF ( at_diag_end .AND. freq == end_of_run ) output_fields(out_num)%next_output = time
3823 ! if (time .eq. output_fields(out_num)%next_output) then
3824  IF ( (output_fields(out_num)%time_ops) .AND. (.NOT. mix_snapshot_average_fields) ) THEN
3825  middle_time = (output_fields(out_num)%last_output+output_fields(out_num)%next_output)/2
3826  if (trim(files(file_num)%filename_time_bounds) == "begin") then
3827  filename_time = output_fields(out_num)%last_output
3828  elseif (trim(files(file_num)%filename_time_bounds) == "middle") then
3829  filename_time = middle_time
3830  elseif (trim(files(file_num)%filename_time_bounds) == "end") then
3831  filename_time = output_fields(out_num)%next_output
3832  endif
3833 
3834  CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time, &
3835  & filename_time=filename_time)
3836  ELSE
3837  CALL diag_data_out(file_num, out_num, &
3838  & output_fields(out_num)%buffer, output_fields(out_num)%next_output)
3839  END IF
3840 !output_fields(out_num)%last_output = output_fields(out_num)%next_output
3841 ! endif
3842  IF ( at_diag_end ) RETURN
3843 
3844  ! Take care of cleaning up the time counters and the storeage size
3845  output_fields(out_num)%last_output = output_fields(out_num)%next_output
3846  IF ( freq == end_of_run ) THEN
3847  output_fields(out_num)%next_output = time
3848  ELSE
3849  IF ( freq == every_time ) THEN
3850  output_fields(out_num)%next_output = time
3851  ELSE
3852  output_fields(out_num)%next_output = output_fields(out_num)%next_next_output
3853  output_fields(out_num)%next_next_output = &
3854  & diag_time_inc(output_fields(out_num)%next_next_output, freq, units)
3855  END IF
3856  output_fields(out_num)%count_0d(:) = 0.0
3857  output_fields(out_num)%num_elements(:) = 0
3858  IF ( time_max ) THEN
3859  output_fields(out_num)%buffer = max_value
3860  ELSE IF ( time_min ) THEN
3861  output_fields(out_num)%buffer = min_value
3862  ELSE
3863  output_fields(out_num)%buffer = empty
3864  END IF
3865  IF ( input_fields(in_num)%mask_variant .AND. average ) output_fields(out_num)%counter = 0.0
3866  END IF
3867  END FUNCTION writing_field
3868 
3869  SUBROUTINE diag_manager_set_time_end(Time_end_in)
3870  TYPE (time_type), INTENT(in) :: time_end_in
3871 
3872  time_end = time_end_in
3873  if (use_modern_diag) then
3874  call fms_diag_object%set_time_end(time_end_in)
3875  endif
3876 
3877  END SUBROUTINE diag_manager_set_time_end
3878 
3879  !-----------------------------------------------------------------------
3880  !> @brief The subroutine 'diag_send_complete_instant' allows the user to
3881  !! save diagnostic data on variable intervals (user defined in code logic)
3882  !! to the same file. The argument (time_type) will be written to the
3883  !! time axis correspondingly.
3884  !!
3885  !> The user is responsible for any averaging of accumulated data
3886  !! as this routine is not designed for instantaneous values. This routine
3887  !! works only for send_data calls within OpenMP regions as they are buffered
3888  !! until the complete signal is given.
3890  TYPE (time_type), INTENT(in) :: time
3891  !--- local variables
3892  integer :: file, j, freq, in_num, file_num, out_num
3893 
3894  DO file = 1, num_files
3895  freq = files(file)%output_freq
3896  IF (freq == 0) then
3897  DO j = 1, files(file)%num_fields
3898  out_num = files(file)%fields(j)
3899  in_num = output_fields(out_num)%input_field
3900  IF ( (input_fields(in_num)%numthreads == 1) .AND.&
3901  & (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3902  file_num = output_fields(out_num)%output_file
3903  CALL diag_data_out(file_num, out_num, &
3904  & output_fields(out_num)%buffer, time)
3905  END DO
3906  END IF
3907  END DO
3908  END SUBROUTINE diag_send_complete_instant
3909 
3910  !-----------------------------------------------------------------------
3911  !> @brief Saves diagnostic data for the given time value.
3912  SUBROUTINE diag_send_complete(time_step, err_msg)
3913  TYPE (time_type), INTENT(in) :: time_step
3914  character(len=*), INTENT(out), optional :: err_msg
3915 
3916  type(time_type) :: next_time, time
3917  integer :: file, j, out_num, in_num, freq, status
3918  logical :: local_output, need_compute
3919  CHARACTER(len=128) :: error_string
3920 
3921  IF ( time_end == time_zero ) THEN
3922  ! <ERROR STATUS="FATAL">
3923  ! diag_manager_set_time_end must be called before diag_send_complete
3924  ! </ERROR>
3925  CALL error_mesg('diag_manager_mod::diag_send_complete',&
3926  & "diag_manager_set_time_end must be called before diag_send_complete", fatal)
3927  END IF
3928 
3929  if (use_modern_diag) then
3930  call fms_diag_object%fms_diag_send_complete(time_step)
3931  return
3932  endif
3933 
3934  DO file = 1, num_files
3935  freq = files(file)%output_freq
3936  DO j = 1, files(file)%num_fields
3937  out_num = files(file)%fields(j) !this is position of output_field in array output_fields
3938  in_num = output_fields(out_num)%input_field
3939 
3940  IF ( (input_fields(in_num)%numthreads == 1) .AND. (input_fields(in_num)%active_omp_level.LE.1) ) cycle
3941  IF ( output_fields(out_num)%static .OR. freq == end_of_run ) cycle
3942  time = input_fields(in_num)%time
3943  IF ( time >= time_end ) cycle
3944 
3945  ! is this field output on a local domain only?
3946  local_output = output_fields(out_num)%local_output
3947  ! if local_output, does the current PE take part in send_data?
3948  need_compute = output_fields(out_num)%need_compute
3949  ! skip all PEs not participating in outputting this field
3950  IF ( local_output .AND. (.NOT.need_compute) ) cycle
3951  next_time = time + time_step
3952 
3953  IF ( next_time > output_fields(out_num)%next_output ) THEN
3954  ! A non-static field that has skipped a time level is an error
3955  IF ( next_time > output_fields(out_num)%next_next_output .AND. freq > 0 ) THEN
3956  IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN
3957  WRITE (error_string,'(a,"/",a)')&
3958  & trim(input_fields(in_num)%module_name), &
3959  & trim(output_fields(out_num)%output_name)
3960  IF ( fms_error_handler('diag_send_complete',&
3961  & 'module/output_field '//trim(error_string)//&
3962  & ' is skipped one time level in output data', err_msg)) RETURN
3963  END IF
3964  END IF
3965 
3966  status = writing_field(out_num, .false., error_string, next_time)
3967  IF ( status == -1 ) THEN
3968  IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN
3969  IF(fms_error_handler('diag_manager_mod::diag_send_complete','module/output_field '//&
3970  & trim(error_string)//', write EMPTY buffer', err_msg)) RETURN
3971  END IF
3972  END IF
3973  END IF !time > output_fields(out_num)%next_output
3974  END DO
3975  END DO
3976 
3977  END SUBROUTINE diag_send_complete
3978 
3979  !> @brief Flushes diagnostic buffers where necessary. Close diagnostics files.
3980  !! A warning will be issued here if a field in diag_table is not registered
3981  SUBROUTINE diag_manager_end(time)
3982  TYPE(time_type), INTENT(in) :: time
3983 
3984  INTEGER :: file
3985 
3986  IF ( do_diag_field_log ) THEN
3987  close (diag_log_unit)
3988  END IF
3989  DO file = 1, num_files
3990  CALL closing_file(file, time)
3991  END DO
3992  if (allocated(fileobju)) deallocate(fileobju)
3993  if (allocated(fileobj)) deallocate(fileobj)
3994  if (allocated(fileobjnd)) deallocate(fileobjnd)
3995  if (allocated(fnum_for_domain)) deallocate(fnum_for_domain)
3996 
3997  if (use_modern_diag) then
3998  call fms_diag_object%diag_end(time)
3999  endif
4000  END SUBROUTINE diag_manager_end
4001 
4002  !> @brief Replaces diag_manager_end; close just one file: files(file)
4003  SUBROUTINE closing_file(file, time)
4004  INTEGER, INTENT(in) :: file
4005  TYPE(time_type), INTENT(in) :: time
4006 
4007  INTEGER :: j, i, input_num, freq, status
4008  INTEGER :: stdout_unit
4009  LOGICAL :: reduced_k_range, need_compute, local_output
4010  CHARACTER(len=128) :: message
4011 
4012  stdout_unit = stdout()
4013 
4014  ! Output all registered, non_static output_fields
4015  DO j = 1, files(file)%num_fields
4016  i = files(file)%fields(j) !this is position of output_field in array output_fields
4017 
4018  ! is this field output on a local domain only?
4019  local_output = output_fields(i)%local_output
4020  ! if local_output, does the current PE take part in send_data?
4021  need_compute = output_fields(i)%need_compute
4022 
4023  reduced_k_range = output_fields(i)%reduced_k_range
4024 
4025  ! skip all PEs not participating in outputting this field
4026  IF ( local_output .AND. (.NOT. need_compute) ) cycle
4027  ! skip fields that were not registered or non-static
4028  input_num = output_fields(i)%input_field
4029  IF ( input_fields(input_num)%static ) cycle
4030  IF ( .NOT.input_fields(input_num)%register ) cycle
4031  freq = files(file)%output_freq
4032  IF ( freq /= end_of_run .AND. files(file)%file_unit < 0 &
4033  & .AND. all(output_fields(i)%num_elements(:) == 0)&
4034  & .AND. all(output_fields(i)%count_0d(:) == 0) ) cycle
4035  ! Is it time to output for this field; CAREFUL ABOUT >= vs > HERE
4036  ! For end should be >= because no more data is coming
4037  IF ( time >= output_fields(i)%next_output .OR. freq == end_of_run ) THEN
4038  IF ( time >= output_fields(i)%next_next_output .AND. freq > 0 ) THEN
4039  WRITE (message,'(a,"/",a)') trim(input_fields(input_num)%module_name), &
4040  & trim(output_fields(i)%output_name)
4041  ! <ERROR STATUS="WARNING">
4042  ! <input_fields(input_num)%module_name>/<output_fields(i)%output_name> skip one time
4043  ! level, maybe send_data never called
4044  ! </ERROR>
4045  IF ( mpp_pe() .EQ. mpp_root_pe() ) &
4046  & CALL error_mesg('diag_manager_mod::closing_file', 'module/output_field ' //&
4047  & trim(message)//', skip one time level, maybe send_data never called', warning)
4048  status = writing_field(i, .true.,message,time)
4049  ELSE
4050  status = writing_field(i, .true., message, time)
4051  END IF
4052  ELSEIF ( .NOT.output_fields(i)%written_once ) THEN
4053  ! <ERROR STATUS="NOTE">
4054  ! <output_fields(i)%output_name) NOT available, check if output interval > runlength.
4055  ! NetCDF fill_values are written
4056  ! </ERROR>
4057  CALL error_mesg('Potential error in diag_manager_end ',&
4058  & trim(output_fields(i)%output_name)//' NOT available,'//&
4059  & ' check if output interval > runlength. Netcdf fill_values are written', note)
4060  output_fields(i)%buffer = fill_value
4061  CALL diag_data_out(file, i, output_fields(i)%buffer, time, .true.)
4062  END IF
4063  END DO
4064  ! Now it's time to output static fields
4065  CALL write_static(file)
4066 
4067  ! Write out the number of bytes of data saved to this file
4068  IF ( write_bytes_in_file ) THEN
4069  CALL mpp_sum (files(file)%bytes_written)
4070  IF ( mpp_pe() == mpp_root_pe() )&
4071  & WRITE (stdout_unit,'(a,i12,a,a)') 'Diag_Manager: ',files(file)%bytes_written, &
4072  & ' bytes of data written to file ',trim(files(file)%name)
4073  END IF
4074  END SUBROUTINE closing_file
4075 
4076  !> @brief Initialize Diagnostics Manager.
4077  !! @details Open and read diag_table. Select fields and files for diagnostic output.
4078  SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
4079  INTEGER, OPTIONAL, INTENT(IN) :: diag_model_subset
4080  INTEGER, DIMENSION(6), OPTIONAL, INTENT(IN) :: time_init !< Model time diag_manager initialized
4081  CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
4082 
4083  CHARACTER(len=*), PARAMETER :: sep = '|'
4084 
4085  INTEGER, PARAMETER :: fltkind = r4_kind
4086  INTEGER, PARAMETER :: dblkind = r8_kind
4087  INTEGER :: diag_subset_output
4088  INTEGER :: mystat
4089  INTEGER, ALLOCATABLE, DIMENSION(:) :: pelist
4090  INTEGER :: stdlog_unit, stdout_unit
4091  integer :: j
4092  CHARACTER(len=256) :: err_msg_local
4093 
4094  namelist /diag_manager_nml/ append_pelist_name, mix_snapshot_average_fields, max_output_fields, &
4095  & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
4096  & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
4097  & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
4098  & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, &
4099  & field_log_separator, use_refactored_send
4100 
4101  ! If the module was already initialized do nothing
4102  IF ( module_is_initialized ) RETURN
4103 
4104  ! Clear the err_msg variable if contains any residual information
4105  IF ( PRESENT(err_msg) ) err_msg = ''
4106 
4107  ! Initialize diag_util_mod and diag_data_mod
4108  ! These init routine only write out the version number to the log file
4109  call diag_util_init()
4110  call diag_data_init()
4111 
4112  ! Determine pack_size from how many bytes a real value has (how compiled)
4113  pack_size = SIZE(transfer(0.0_dblkind, (/0.0, 0.0, 0.0, 0.0/)))
4114  IF (pack_size .EQ. 1) then
4115  pack_size_str = "double"
4116  else if (pack_size .EQ. 2) then
4117  pack_size_str = "float"
4118  else
4119  IF ( fms_error_handler('diag_manager_mod::diag_manager_init', 'unknown pack_size. Must be 1, or 2.', &
4120  & err_msg) ) RETURN
4121  END IF
4122 
4123  ! Get min and max values for real(kind=R4_KIND)
4124  min_value = huge(0.0_fltkind)
4125  max_value = -min_value
4126 
4127  ! get stdlog and stdout unit number
4128  stdlog_unit = stdlog()
4129  stdout_unit = stdout()
4130 
4131  ! version number to logfile
4132  CALL write_version_number("DIAG_MANAGER_MOD", version)
4133 
4134  time_zero = set_time(0,0)
4135  !--- initialize time_end to time_zero
4136  time_end = time_zero
4137  diag_subset_output = diag_all
4138  IF ( PRESENT(diag_model_subset) ) THEN
4139  IF ( diag_model_subset >= diag_other .AND. diag_model_subset <= diag_all ) THEN
4140  diag_subset_output = diag_model_subset
4141  ELSE
4142  IF ( fms_error_handler('diag_manager_mod::diag_manager_init', 'invalid value of diag_model_subset', &
4143  & err_msg) ) RETURN
4144  END IF
4145  END IF
4146 
4147  READ (input_nml_file, nml=diag_manager_nml, iostat=mystat)
4148  ! Check the status of reading the diag_manager_nml
4149 
4150  IF ( check_nml_error(iostat=mystat, nml_name='DIAG_MANAGER_NML') < 0 ) THEN
4151  IF ( mpp_pe() == mpp_root_pe() ) THEN
4152  CALL error_mesg('diag_manager_mod::diag_manager_init', &
4153  & 'DIAG_MANAGER_NML not found in input nml file. Using defaults.', warning)
4154  END IF
4155  END IF
4156 
4157  IF (.not. use_modern_diag .and. use_clock_average) &
4158  call mpp_error(fatal, "diag_manager_mod: You cannot set use_modern_diag=.false. and &
4159  & use_clock_average=.true. in diag_manager_nml")
4160 
4161  IF ( mpp_pe() == mpp_root_pe() ) THEN
4162  WRITE (stdlog_unit, diag_manager_nml)
4163  END IF
4164 
4165  ! Issue note about using the CMOR missing value.
4166  IF ( use_cmor ) THEN
4167  err_msg_local = ''
4168  WRITE (err_msg_local,'(ES8.1E2)') cmor_missing_value
4169  CALL error_mesg('diag_manager_mod::diag_manager_init', 'Using CMOR missing value ('//trim(err_msg_local)// &
4170  & ').', note)
4171  END IF
4172 
4173  ! How to handle Out of Range Warnings.
4174  IF ( oor_warnings_fatal ) THEN
4175  oor_warning = fatal
4176  CALL error_mesg('diag_manager_mod::diag_manager_init', 'Out &
4177  &of Range warnings are fatal.', note)
4178  ELSEIF ( .NOT.issue_oor_warnings ) THEN
4179  CALL error_mesg('diag_manager_mod::diag_manager_init', 'Out &
4180  &of Range warnings will be ignored.', note)
4181  END IF
4182 
4183  IF ( mix_snapshot_average_fields ) THEN
4184  IF ( .not. use_modern_diag ) THEN
4185  CALL error_mesg('diag_manager_mod::diag_manager_init', 'Setting diag_manager_nml variable '//&
4186  & 'mix_snapshot_average_fields = .TRUE. will cause ERRORS in the time coordinates '//&
4187  & 'of all time averaged fields. Strongly recommend setting mix_snapshot_average_fields '//&
4188  & '= .FALSE.', note)
4189  ELSE
4190  CALL error_mesg('diag_manager_mod::diag_manager_init', 'mix_snapshot_average_fields = .TRUE. is not '//&
4191  & 'supported if use_modern_diag = .TRUE. Please set mix_snapshot_average_fields '//&
4192  & 'to .FALSE. and put instantaneous and averaged fields in separate files!', fatal)
4193  END IF
4194  END IF
4195  ALLOCATE(output_fields(max_output_fields))
4196  ALLOCATE(input_fields(max_input_fields))
4197  DO j = 1, max_input_fields
4198  ALLOCATE(input_fields(j)%output_fields(max_out_per_in_field))
4199  END DO
4200 !> Allocate files
4201  ALLOCATE(files(max_files))
4202  ALLOCATE(fileobju(max_files))
4203  ALLOCATE(fileobj(max_files))
4204  ALLOCATE(fileobjnd(max_files))
4205  ALLOCATE(fnum_for_domain(max_files))
4206  !> Initialize fnum_for_domain with "dn" which stands for done
4207  fnum_for_domain(:) = "dn"
4208  ALLOCATE(pelist(mpp_npes()))
4209  CALL mpp_get_current_pelist(pelist, pelist_name)
4210 
4211  ! set the diag_init_time if time_init present. Otherwise, set it to base_time
4212  IF ( PRESENT(time_init) ) THEN
4213  diag_init_time = set_date(time_init(1), time_init(2), time_init(3), time_init(4),&
4214  & time_init(5), time_init(6))
4215  ELSE
4216  diag_init_time = get_base_time()
4217  IF ( prepend_date .EQV. .true. ) THEN
4218  CALL error_mesg('diag_manager_mod::diag_manager_init',&
4219  & 'prepend_date only supported when diag_manager_init is called with time_init present.', note)
4220  prepend_date = .false.
4221  END IF
4222  END IF
4223 
4224  if (use_modern_diag) then
4225  CALL error_mesg('diag_manager_mod::diag_manager_init',&
4226  & 'You are using the yaml version of the diag table', note)
4227  CALL fms_diag_object%init(diag_subset_output, time_init)
4228  endif
4229  if (.not. use_modern_diag) then
4230  CALL error_mesg('diag_manager_mod::diag_manager_init',&
4231  & 'You are using the legacy version of the diag table', note)
4232  CALL parse_diag_table(diag_subset=diag_subset_output, istat=mystat, err_msg=err_msg_local)
4233  IF ( mystat /= 0 ) THEN
4234  IF ( fms_error_handler('diag_manager_mod::diag_manager_init',&
4235  & 'Error parsing diag_table. '//trim(err_msg_local), err_msg) ) RETURN
4236  END IF
4237  endif
4238  !initialize files%bytes_written to zero
4239  files(:)%bytes_written = 0
4240 
4241  ! open diag field log file
4242  IF ( do_diag_field_log.AND.mpp_pe().EQ.mpp_root_pe() ) THEN
4243  open(newunit=diag_log_unit, file='diag_field_log.out.'//string(mpp_pe()), action='WRITE')
4244  WRITE (diag_log_unit,'(777a)') &
4245  & 'Module', field_log_separator, 'Field', field_log_separator, &
4246  & 'Long Name', field_log_separator, 'Units', field_log_separator, &
4247  & 'Number of Axis', field_log_separator, 'Time Axis', field_log_separator, &
4248  & 'Missing Value', field_log_separator, 'Min Value', field_log_separator, &
4249  & 'Max Value', field_log_separator, 'AXES LIST'
4250  END IF
4251 
4252  module_is_initialized = .true.
4253  ! create axis_id for scalars here
4254  if(.not. use_modern_diag) null_axis_id = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none')
4255  RETURN
4256  END SUBROUTINE diag_manager_init
4257 
4258  !> @brief Return base date for diagnostics.
4259  !! @details Return date information for diagnostic reference time.
4260  SUBROUTINE get_base_date(year, month, day, hour, minute, second)
4261  INTEGER, INTENT(out) :: year, month, day, hour, minute, second
4262 
4263  ! <ERROR STATUS="FATAL">module has not been initialized</ERROR>
4264  IF (.NOT.module_is_initialized) CALL error_mesg ('diag_manager_mod::get_base_date', &
4265  & 'module has not been initialized', fatal)
4266  year = get_base_year()
4267  month = get_base_month()
4268  day = get_base_day()
4269  hour = get_base_hour()
4270  minute = get_base_minute()
4271  second = get_base_second()
4272  END SUBROUTINE get_base_date
4273 
4274  !> @brief Determine whether data is needed for the current model time step.
4275  !! @return Logical need_data
4276  !! @details Determine whether data is needed for the current model time step.
4277  !! Since diagnostic data are buffered, the "next" model time is passed
4278  !! instead of the current model time. This call can be used to minimize
4279  !! overhead for complicated diagnostics.
4280  LOGICAL FUNCTION need_data(diag_field_id, next_model_time)
4281  TYPE(time_type), INTENT(in) :: next_model_time !< next_model_time = current model time + model time_step
4282  INTEGER, INTENT(in) :: diag_field_id
4283 
4284  INTEGER :: i, out_num
4285 
4286  need_data = .false.
4287  IF ( diag_field_id < 0 ) RETURN ! this field is unused
4288  DO i = 1, input_fields(diag_field_id)%num_output_fields
4289  ! Get index to an output field
4290  out_num = input_fields(diag_field_id)%output_fields(i)
4291  IF ( .NOT.output_fields(out_num)%static ) THEN
4292  IF ( next_model_time > output_fields(out_num)%next_output ) need_data=.true.
4293  ! Is this output field being time averaged?
4294  ! assume average data based on every timestep
4295  ! needs to be changed when different forms of averaging are implemented
4296  IF ( output_fields(out_num)%time_average) need_data = .true.
4297  END IF
4298  END DO
4299  RETURN
4300  END FUNCTION need_data
4301 
4302  !> @brief Finds or initializes a diurnal time axis and returns its' ID.
4303  !! @return Integer init_diurnal_axis
4304  !! @details Given number of time intervals in the day, finds or initializes a diurnal time axis
4305  !! and returns its ID. It uses get_base_date, so should be in the file where it's accessible.
4306  !! The units are 'days since BASE_DATE', all diurnal axes belong to the set 'diurnal'
4307  INTEGER FUNCTION init_diurnal_axis(n_samples)
4308  INTEGER, INTENT(in) :: n_samples !< number of intervals during the day
4309 
4310  REAL :: center_data (n_samples) !< central points of time intervals
4311  REAL :: edges (n_samples+1) !< boundaries of time intervals
4312  INTEGER :: edges_id !< id of the corresponding edges
4313  INTEGER :: i
4314  INTEGER :: year !< components of the base date
4315  INTEGER :: month !< components of the base date
4316  INTEGER :: day !< components of the base date
4317  INTEGER :: hour !< components of the base date
4318  INTEGER :: minute !< components of the base date
4319  INTEGER :: second !< components of the base date
4320  CHARACTER(32) :: name !< name of the axis
4321  CHARACTER(128) :: units !< units of time
4322 
4323  CALL get_base_date(year, month, day, hour, minute, second)
4324  WRITE (units,11) 'hours', year, month, day, hour, minute, second
4325 11 FORMAT(a,' since ',i4.4,'-',i2.2,'-',i2.2,' ',i2.2,':',i2.2,':',i2.2)
4326  ! compute central points and units
4327  edges(1) = 0.0
4328  DO i = 1, n_samples
4329  center_data(i) = 24.0*(real(i)-0.5)/n_samples
4330  edges(i+1) = 24.0* real(i)/n_samples
4331  END DO
4332 
4333  ! define edges
4334  name = ''
4335  WRITE (name,'(a,i2.2)') 'time_of_day_edges_', n_samples
4336  edges_id = get_axis_num(name, 'diurnal')
4337  IF ( edges_id <= 0 ) THEN
4338  edges_id = diag_axis_init(name,edges,units,'N','time of day edges', set_name='diurnal')
4339  END IF
4340 
4341  ! define axis itself
4342  name = ''
4343  WRITE (name,'(a,i2.2)') 'time_of_day_', n_samples
4344  init_diurnal_axis = get_axis_num(name, 'diurnal')
4345  IF ( init_diurnal_axis <= 0 ) THEN
4346  init_diurnal_axis = diag_axis_init(name, center_data, units, 'N', 'time of day', &
4347  set_name='diurnal', edges=edges_id)
4348  END IF
4349  END FUNCTION init_diurnal_axis
4350 
4351  SUBROUTINE diag_field_attribute_init(diag_field_id, name, type, cval, ival, rval)
4352  INTEGER, INTENT(in) :: diag_field_id !< input field ID, obtained from diag_manager_mod::register_diag_field.
4353  CHARACTER(len=*), INTENT(in) :: name !< Name of the attribute
4354  INTEGER, INTENT(in) :: type !< NetCDF type (NF90_FLOAT, NF90_INT, NF90_CHAR)
4355  CHARACTER(len=*), INTENT(in), OPTIONAL :: cval !< Character string attribute value
4356  INTEGER, DIMENSION(:), INTENT(in), OPTIONAL :: ival !< Integer attribute value(s)
4357  REAL, DIMENSION(:), INTENT(in), OPTIONAL :: rval !< Real attribute value(s)
4358 
4359  INTEGER :: istat, length, i, j, this_attribute, out_field
4360 
4361  IF ( .NOT.first_send_data_call ) THEN
4362  ! Call error due to unable to add attribute after send_data called
4363  ! <ERROR STATUS="FATAL">
4364  ! Attempting to add attribute <name> to module/input_field <module_name>/<field_name>
4365  ! after first send_data call. Too late.
4366  ! </ERROR>
4367  CALL error_mesg('diag_manager_mod::diag_field_add_attribute', 'Attempting to add attribute "'&
4368  &//trim(name)//'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//'/'&
4369  &//trim(input_fields(diag_field_id)%field_name)//'" after first send_data call. Too late.', fatal)
4370  END IF
4371 
4372  ! Simply return if diag_field_id <= 0 --- not in diag_table
4373  IF ( diag_field_id .LE. 0 ) THEN
4374  RETURN
4375  ELSE
4376  DO j=1,input_fields(diag_field_id)%num_output_fields
4377  out_field = input_fields(diag_field_id)%output_fields(j)
4378 
4379  ! Allocate memory for the attributes
4380  CALL attribute_init(output_fields(out_field))
4381 
4382  ! Check if attribute already exists
4383  this_attribute = 0
4384  DO i=1, output_fields(out_field)%num_attributes
4385  IF ( trim(output_fields(out_field)%attributes(i)%name) .EQ. trim(name) ) THEN
4386  this_attribute = i
4387  EXIT
4388  END IF
4389  END DO
4390 
4391  IF ( this_attribute.NE.0 .AND. (type.EQ.nf90_int .OR. type.EQ.nf90_float) ) THEN
4392  ! <ERROR STATUS="FATAL">
4393  ! Attribute <name> already defined for module/input_field <module_name>/<field_name>.
4394  ! Contact the developers
4395  ! </ERROR>
4396  CALL error_mesg('diag_manager_mod::diag_field_add_attribute',&
4397  & 'Attribute "'//trim(name)//'" already defined for module/input_field "'&
4398  &//trim(input_fields(diag_field_id)%module_name)//'/'&
4399  &//trim(input_fields(diag_field_id)%field_name)//'". Contact the developers.', fatal)
4400  ELSE IF ( this_attribute.NE.0 .AND. type.EQ.nf90_char .AND. debug_diag_manager ) THEN
4401  ! <ERROR STATUS="NOTE">
4402  ! Attribute <name> already defined for module/input_field <module_name>/<field_name>.
4403  ! Prepending.
4404  ! </ERROR>
4405  CALL error_mesg('diag_manager_mod::diag_field_add_attribute',&
4406  & 'Attribute "'//trim(name)//'" already defined for module/input_field "'&
4407  &//trim(input_fields(diag_field_id)%module_name)//'/'&
4408  &//trim(input_fields(diag_field_id)%field_name)//'". Prepending.', note)
4409  ELSE IF ( this_attribute.EQ.0 ) THEN
4410  ! Defining a new attribute
4411  ! Increase the number of field attributes
4412  this_attribute = output_fields(out_field)%num_attributes + 1
4413  ! Checking to see if num_attributes == max_field_attributes, and return error message
4414  IF ( this_attribute .GT. max_field_attributes ) THEN
4415  ! <ERROR STATUS="FATAL">
4416  ! Number of attributes exceeds max_field_attributes for attribute <name>
4417  ! to module/input_field <module_name>/<field_name>.
4418  ! Increase diag_manager_nml:max_field_attributes.
4419  ! </ERROR>
4420  CALL error_mesg('diag_manager_mod::diag_field_add_attribute',&
4421  & 'Number of attributes exceeds max_field_attributes for attribute "'&
4422  &//trim(name)//'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//'/'&
4423  &//trim(input_fields(diag_field_id)%field_name)&
4424  &//'". Increase diag_manager_nml:max_field_attributes.', fatal)
4425  ELSE
4426  output_fields(out_field)%num_attributes = this_attribute
4427  ! Set name and type
4428  output_fields(out_field)%attributes(this_attribute)%name = name
4429  output_fields(out_field)%attributes(this_attribute)%type = type
4430  ! Initialize catt to a blank string, as len_trim doesn't always work on an uninitialized string
4431  output_fields(out_field)%attributes(this_attribute)%catt = ''
4432  END IF
4433  END IF
4434 
4435  SELECT CASE (type)
4436  CASE (nf90_int)
4437  IF ( .NOT.PRESENT(ival) ) THEN
4438  ! <ERROR STATUS="FATAL">
4439  ! Number type claims INTEGER, but ival not present for attribute <name> to
4440  ! module/input_field <module_name>/<field_name>.
4441  ! Contact the developers.
4442  ! </ERROR>
4443  CALL error_mesg('diag_manager_mod::diag_field_add_attribute',&
4444  & 'Attribute type claims INTEGER, but ival not present for attribute "'&
4445  &//trim(name)//'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//'/'&
4446  &//trim(input_fields(diag_field_id)%field_name)//'". Contact then developers.', fatal)
4447  END IF
4448  length = SIZE(ival)
4449  ! Allocate iatt(:) to size of ival
4450  ALLOCATE(output_fields(out_field)%attributes(this_attribute)%iatt(length), stat=istat)
4451  IF ( istat.NE.0 ) THEN
4452  ! <ERROR STATUS="FATAL">
4453  ! Unable to allocate iatt for attribute <name> to module/input_field <module_name>/<field_name>
4454  ! </ERROR>
4455  CALL error_mesg('diag_manager_mod::diag_field_add_attribute','Unable to allocate iatt for attribute "'&
4456  &//trim(name)//'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//'/'&
4457  &//trim(input_fields(diag_field_id)%field_name)//'"', fatal)
4458  END IF
4459  ! Set remaining fields
4460  output_fields(out_field)%attributes(this_attribute)%len = length
4461  output_fields(out_field)%attributes(this_attribute)%iatt = ival
4462  CASE (nf90_float)
4463  IF ( .NOT.PRESENT(rval) ) THEN
4464  ! <ERROR STATUS="FATAL">
4465  ! Attribute type claims READ, but rval not present for attribute <name> to
4466  ! module/input_field <module_name>/<field_name>.
4467  ! Contact the developers.
4468  ! </ERROR>
4469  CALL error_mesg('diag_manager_mod::diag_field_add_attribute',&
4470  & 'Attribute type claims REAL, but rval not present for attribute "'&
4471  &//trim(name)//'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//'/'&
4472  &//trim(input_fields(diag_field_id)%field_name)//'". Contact the developers.', fatal)
4473  END IF
4474  length = SIZE(rval)
4475  ! Allocate iatt(:) to size of rval
4476  ALLOCATE(output_fields(out_field)%attributes(this_attribute)%fatt(length), stat=istat)
4477  IF ( istat.NE.0 ) THEN
4478  ! <ERROR STATUS="FATAL">
4479  ! Unable to allocate fatt for attribute <name> to module/input_field <module_name>/<field_name>
4480  ! </ERROR>
4481  CALL error_mesg('diag_manager_mod::diag_field_add_attribute','Unable to allocate fatt for attribute "'&
4482  &//trim(name)//'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//'/'&
4483  &//trim(input_fields(diag_field_id)%field_name)//'"', fatal)
4484  END IF
4485  ! Set remaining fields
4486  output_fields(out_field)%attributes(this_attribute)%len = length
4487  output_fields(out_field)%attributes(this_attribute)%fatt = rval
4488  CASE (nf90_char)
4489  IF ( .NOT.PRESENT(cval) ) THEN
4490  ! <ERROR STATUS="FATAL">
4491  ! Attribute type claims CHARACTER, but cval not present for attribute <name>
4492  ! to module/input_field <module_name>/<field_name>.
4493  ! Contact the developers.
4494  ! </ERROR>
4495  CALL error_mesg('diag_manager_mod::diag_field_add_attribute',&
4496  & 'Attribute type claims CHARACTER, but cval not present for attribute "'&
4497  &//trim(name)//'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//'/'&
4498  &//trim(input_fields(diag_field_id)%field_name)//'". Contact the developers.', fatal)
4499  END IF
4500  CALL prepend_attribute(output_fields(out_field), trim(name), trim(cval))
4501  CASE default
4502  ! <ERROR STATUS="FATAL">
4503  ! Unknown attribute type for attribute <name> to module/input_field <module_name>/<field_name>.
4504  ! Contact the developers.
4505  ! </ERROR>
4506  CALL error_mesg('diag_manager_mod::diag_field_add_attribute', 'Unknown attribute type for attribute "'&
4507  &//trim(name)//'" to module/input_field "'//trim(input_fields(diag_field_id)%module_name)//'/'&
4508  &//trim(input_fields(diag_field_id)%field_name)//'". Contact the developers.', fatal)
4509  END SELECT
4510  END DO
4511  END IF
4512  END SUBROUTINE diag_field_attribute_init
4513 
4514  !> @brief Add a scalr attribute to the diag field corresponding to a given id
4515  subroutine diag_field_add_attribute_0d(diag_field_id, att_name, att_value)
4516  INTEGER, INTENT(in) :: diag_field_id !< ID number for field to add attribute to
4517  CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name
4518  class(*), INTENT(in) :: att_value !< new attribute value
4519 
4520  if (use_modern_diag) then
4521  select type(att_value)
4522  type is (real(kind=r4_kind))
4523  call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4524  type is (real(kind=r8_kind))
4525  call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4526  type is (integer(kind=i4_kind))
4527  call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4528  type is (character(len=*))
4529  call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
4530  class default
4531  call mpp_error(fatal, "Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4532  "are float, double, integer, and string")
4533  end select
4534  else
4535  select type(att_value)
4536  type is (real(kind=r4_kind))
4537  CALL diag_field_attribute_init(diag_field_id, att_name, nf90_float, rval=real((/att_value/)))
4538  type is (real(kind=r8_kind))
4539  CALL diag_field_attribute_init(diag_field_id, att_name, nf90_float, rval=real((/att_value/)))
4540  type is (integer(kind=i4_kind))
4541  CALL diag_field_attribute_init(diag_field_id, att_name, nf90_int, ival=(/att_value/))
4542  type is (character(len=*))
4543  CALL diag_field_attribute_init(diag_field_id, att_name, nf90_char, cval=att_value)
4544  class default
4545  call mpp_error(fatal, "Diag_field_add_attribute 0d:: unsupported type. The acceptable types "//&
4546  "are float, double, integer, and string")
4547  end select
4548  endif
4549 
4550  end subroutine diag_field_add_attribute_0d
4551 
4552  !> @brief Add an 1D array attribute to the diag field corresponding to a given id
4553  subroutine diag_field_add_attribute_1d(diag_field_id, att_name, att_value)
4554  INTEGER, INTENT(in) :: diag_field_id !< ID number for field to add attribute to
4555  CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name
4556  class(*), INTENT(in) :: att_value(:) !< new attribute value
4557 
4558  if (use_modern_diag) then
4559  call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
4560  else
4561  select type(att_value)
4562  type is (real(kind=r4_kind))
4563  CALL diag_field_attribute_init(diag_field_id, att_name, nf90_float, rval=real(att_value))
4564  type is (real(kind=r8_kind))
4565  CALL diag_field_attribute_init(diag_field_id, att_name, nf90_float, rval=real(att_value))
4566  type is (integer(kind=i4_kind))
4567  CALL diag_field_attribute_init(diag_field_id, att_name, nf90_int, ival=att_value)
4568  class default
4569  call mpp_error(fatal, "Diag_field_add_attribute 1d:: unsupported type. The acceptable types "//&
4570  "are float, double, and integer")
4571  end select
4572  endif
4573  end subroutine diag_field_add_attribute_1d
4574 
4575  !> @brief Add the cell_measures attribute to a diag out field
4576  !!
4577  !> Add the cell_measures attribute to a give diag field. This is useful if the
4578  !! area/volume fields for the diagnostic field are defined in another module after
4579  !! the diag_field.
4580  SUBROUTINE diag_field_add_cell_measures(diag_field_id, area, volume)
4581  INTEGER, INTENT(in) :: diag_field_id
4582  INTEGER, INTENT(in), OPTIONAL :: area !< diag ids of area
4583  INTEGER, INTENT(in), OPTIONAL :: volume !< diag ids of volume
4584 
4585  integer :: j, ind
4586 
4587  IF ( diag_field_id.GT.0 ) THEN
4588  IF ( .NOT.PRESENT(area) .AND. .NOT.present(volume) ) THEN
4589  CALL error_mesg('diag_manager_mod::diag_field_add_cell_measures', &
4590  & 'either area or volume arguments must be present', fatal )
4591  END IF
4592 
4593  if (use_modern_diag) then
4594  call fms_diag_object%fms_diag_field_add_cell_measures(diag_field_id, area, volume)
4595  return
4596  ENDIF
4597 
4598  DO j=1, input_fields(diag_field_id)%num_output_fields
4599  ind = input_fields(diag_field_id)%output_fields(j)
4600  CALL init_field_cell_measures(output_fields(ind), area=area, volume=volume)
4601  END DO
4602  END IF
4603  END SUBROUTINE diag_field_add_cell_measures
4604 
4605  !> @brief Copies a 3d buffer to a 4d buffer
4606  subroutine copy_3d_to_4d(data_in, data_out, field_name)
4607  class(*), intent(in) :: data_in(:,:,:) !< Data to copy
4608  character(len=*), intent(in) :: field_name !< Name of the field copying (for error messages)
4609  class(*), allocatable, intent(out) :: data_out(:,:,:,:) !< 4D version of the data
4610 
4611  !TODO this should be extended to integers
4612  select type(data_in)
4613  type is (real(kind=r8_kind))
4614  allocate(real(kind=r8_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1))
4615  select type (data_out)
4616  type is (real(kind=r8_kind))
4617  data_out(:,:,:,1) = data_in
4618  class default
4619  call mpp_error(fatal, "The copy of "//trim(field_name)//&
4620  " was not allocated to the correct type (r8_kind). This shouldn't have happened")
4621  end select
4622  type is (real(kind=r4_kind))
4623  allocate(real(kind=r4_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1))
4624  select type (data_out)
4625  type is (real(kind=r4_kind))
4626  data_out(:,:,:,1) = data_in
4627  class default
4628  call mpp_error(fatal, "The copy of "//trim(field_name)//&
4629  " was not allocated to the correct type (r4_kind). This shouldn't have happened")
4630  end select
4631  class default
4632  call mpp_error(fatal, "The data for "//trim(field_name)//&
4633  &" is not a valid type. Currently only r4 and r8 are supported")
4634  end select
4635  end subroutine copy_3d_to_4d
4636 
4637 END MODULE diag_manager_mod
4638 !> @}
4639 ! close documentation grouping
integer(i4_kind) function, public axis_compatible_check(id, varname)
Checks if the axes are compatible.
Definition: diag_axis.F90:744
integer function, public get_axis_length(id)
Return the length of the axis.
Definition: diag_axis.F90:611
integer function, public get_axis_num(axis_name, set_name)
Returns index into axis table corresponding to a given axis name.
Definition: diag_axis.F90:846
type(domain2d) function, public get_domain2d(ids)
Return the 2D domain for the axis IDs given.
Definition: diag_axis.F90:698
integer function, public get_tile_count(ids)
Return the tile count for the axis.
Definition: diag_axis.F90:658
subroutine, public get_diag_axis_name(id, axis_name)
Return the short name of the axis.
Definition: diag_axis.F90:588
integer(i4_kind), parameter, public diag_axis_2ddomain
For unstructured grid support.
Definition: diag_axis.F90:62
integer function, public diag_axis_init(name, array_data, units, cart_name, long_name, direction, set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position)
Initialize the axis, and return the axis ID.
Definition: diag_axis.F90:110
integer(i4_kind), parameter, public diag_axis_ugdomain
For unstructured grid support.
Definition: diag_axis.F90:63
Add an arbitrary attribute and value to the diagnostic axis.
Definition: diag_axis.F90:88
integer max_output_fields
Maximum number of output fields. Increase via diag_manager_nml.
Definition: diag_data.F90:357
real fill_value
Fill value used. Value will be NF90_FILL_REAL if using the netCDF module, otherwise will be 9....
Definition: diag_data.F90:397
integer pack_size
1 for double and 2 for float
Definition: diag_data.F90:407
integer function get_base_minute()
gets the module variable base_minute
Definition: diag_data.F90:549
integer function get_base_year()
gets the module variable base_year
Definition: diag_data.F90:517
integer function get_base_hour()
gets the module variable base_hour
Definition: diag_data.F90:541
logical use_cmor
Indicates if we should overwrite the MISSING_VALUE to use the CMOR missing value.
Definition: diag_data.F90:372
logical flush_nc_files
Control if diag_manager will force a flush of the netCDF file on each write. Note: changing this to ....
Definition: diag_data.F90:365
integer max_axis_attributes
Maximum number of user definable attributes per axis.
Definition: diag_data.F90:385
character(len=6) pack_size_str
Pack size as a string to be used in fms2_io register call set to "double" or "float".
Definition: diag_data.F90:408
logical use_modern_diag
Namelist flag to use the modernized diag_manager code.
Definition: diag_data.F90:390
type(time_type) function get_base_time()
gets the module variable base_time
Definition: diag_data.F90:509
integer max_axes
Maximum number of independent axes.
Definition: diag_data.F90:361
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 max_out_per_in_field
Maximum number of output_fields per input_field. Increase via diag_manager_nml.
Definition: diag_data.F90:359
integer max_input_fields
Maximum number of input fields. Increase via diag_manager_nml.
Definition: diag_data.F90:358
logical use_clock_average
.TRUE. if the averaging of variable is done based on the clock For example, if doing daily averages a...
Definition: diag_data.F90:391
logical issue_oor_warnings
Issue warnings if the output field has values outside the given range for a variable.
Definition: diag_data.F90:373
logical region_out_use_alt_value
Will determine which value to use when checking a regional output if the region is the full axis or a...
Definition: diag_data.F90:377
integer num_output_fields
Number of output fields in use.
Definition: diag_data.F90:350
integer function get_base_day()
gets the module variable base_day
Definition: diag_data.F90:533
type(time_type) diag_init_time
Time diag_manager_init called. If init_time not included in diag_manager_init call,...
Definition: diag_data.F90:416
integer max_files
Maximum number of output files allowed. Increase via diag_manager_nml.
Definition: diag_data.F90:356
integer num_files
Number of output files currenly in use by the diag_manager.
Definition: diag_data.F90:348
integer max_file_attributes
Maximum number of user definable global attributes per file.
Definition: diag_data.F90:384
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
character(len=2), dimension(:), allocatable fnum_for_domain
If this file number in the array is for the "unstructured" or "2d" domain.
Definition: diag_data.F90:431
subroutine diag_data_init()
Initialize and write the version number of this file to the log file.
Definition: diag_data.F90:448
integer function get_base_month()
gets the module variable base_month
Definition: diag_data.F90:525
logical module_is_initialized
Indicate if diag_manager has been initialized.
Definition: diag_data.F90:437
logical oor_warnings_fatal
Cause a fatal error if the output field has a value outside the given range for a variable.
Definition: diag_data.F90:375
integer function get_base_second()
gets the module variable base_second
Definition: diag_data.F90:557
logical use_refactored_send
Namelist flag to use refactored send_data math funcitons.
Definition: diag_data.F90:389
integer max_field_attributes
Maximum number of user definable attributes per field. Liptak: Changed from 2 to 4 20170718.
Definition: diag_data.F90:382
Define the region for field output.
Definition: diag_data.F90:171
Type to hold the output field description.
Definition: diag_data.F90:249
subroutine, public diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon)
Send the global grid to the diag_manager_mod for regional output.
Definition: diag_grid.F90:131
subroutine, public diag_grid_end()
Unallocate the diag_global_grid variable.
Definition: diag_grid.F90:349
logical function, public need_data(diag_field_id, next_model_time)
Determine whether data is needed for the current model time step.
logical function get_related_field(field, rel_field, out_field_id, out_file_id)
Finds the corresponding related output field and file for a given input field.
logical function send_data_2d(diag_field_id, field, time, is_in, js_in, mask, rmask, ie_in, je_in, weight, err_msg)
integer function register_diag_field_scalar(module_name, field_name, init_time, long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume, realm, multiple_send_data)
Registers a scalar field.
integer function, public register_static_field(module_name, field_name, axes, long_name, units, missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method, tile_count, area, volume, realm)
Return field index for subsequent call to send_data.
subroutine copy_3d_to_4d(data_in, data_out, field_name)
Copies a 3d buffer to a 4d buffer.
logical function send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
Updates the output buffer for a field based on the data for current time step.
subroutine diag_field_attribute_init(diag_field_id, name, type, cval, ival, rval)
logical function send_tile_averaged_data3d(id, field, area, time, mask)
integer function register_diag_field_array(module_name, field_name, axes, init_time, long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
Registers an array field.
integer function register_diag_field_scalar_old(module_name, field_name, init_time, long_name, units, missing_value, range, standard_name, do_not_log, err_msg, area, volume, realm)
Registers a scalar field.
integer function register_static_field_old(module_name, field_name, axes, long_name, units, missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method, tile_count, area, volume, realm)
Return field index for subsequent call to send_data.
subroutine closing_file(file, time)
Replaces diag_manager_end; close just one file: files(file)
subroutine, public diag_field_add_cell_measures(diag_field_id, area, volume)
Add the cell_measures attribute to a diag out field.
subroutine init_field_cell_measures(output_field, area, volume, err_msg)
If needed, add cell_measures and associated_file attribute to out field/file.
integer function register_diag_field_array_old(module_name, field_name, axes, init_time, long_name, units, missing_value, range, mask_variant, standard_name, verbose, do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
Registers an array field.
subroutine, public diag_send_complete_instant(time)
The subroutine 'diag_send_complete_instant' allows the user to save diagnostic data on variable inter...
subroutine average_tiles(diag_field_id, x, area, mask, out)
Calculates tile average of a field.
logical function send_data_0d(diag_field_id, field, time, err_msg)
subroutine add_associated_files(file_num, cm_file_num, cm_ind)
Add to the associated files attribute.
integer function writing_field(out_num, at_diag_end, error_string, time)
subroutine, public diag_manager_init(diag_model_subset, time_init, err_msg)
Initialize Diagnostics Manager.
integer function, public get_diag_field_id(module_name, field_name)
Return the diagnostic field ID of a given variable.
subroutine, public get_base_date(year, month, day, hour, minute, second)
Return base date for diagnostics.
logical function send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
subroutine average_tiles1d(diag_field_id, x, area, mask, out)
Calculates average for a field with the given area and land mask.
logical function diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
subroutine diag_field_add_attribute_0d(diag_field_id, att_name, att_value)
Add a scalr attribute to the diag field corresponding to a given id.
logical function send_tile_averaged_data1d(id, field, area, time, mask)
logical function send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
subroutine, public diag_manager_end(time)
Flushes diagnostic buffers where necessary. Close diagnostics files. A warning will be issued here if...
logical function send_tile_averaged_data2d(id, field, area, time, mask)
integer function init_diurnal_axis(n_samples)
Finds or initializes a diurnal time axis and returns its' ID.
subroutine diag_field_add_attribute_1d(diag_field_id, att_name, att_value)
Add an 1D array attribute to the diag field corresponding to a given id.
subroutine, public diag_send_complete(time_step, err_msg)
Saves diagnostic data for the given time value.
Add a attribute to the output field.
Register a diagnostic field for a given module.
Send data over to output fields.
Send tile-averaged data over to output fields.
subroutine, public get_diag_global_att(gAtt)
Return the global attribute type.
subroutine, public set_diag_global_att(component, gridType, tileName)
Set the global attribute type.
subroutine, public parse_diag_table(diag_subset, istat, err_msg)
Parse the diag_table in preparation for diagnostic output.
Definition: diag_table.F90:318
subroutine, public get_subfield_size(axes, outnum)
Get the size, start, and end indices for output fields.
Definition: diag_util.F90:134
subroutine, public init_input_field(module_name, field_name, tile_count)
Initialize the input field.
Definition: diag_util.F90:1310
subroutine, public check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
Check if the array indices for output_fields(out_num) are equal to the output_fields(out_num)buffer u...
Definition: diag_util.F90:1017
integer function, public find_input_field(module_name, field_name, tile_count)
Return the field number for the given module name, field name, and tile number.
Definition: diag_util.F90:1291
subroutine, public write_static(file)
Output all static fields in this file.
Definition: diag_util.F90:2207
subroutine, public diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time)
Write data out to file, and if necessary flush the buffers.
Definition: diag_util.F90:2057
subroutine, public init_output_field(module_name, field_name, output_name, output_file, time_method, pack, tile_count, local_coord)
Initialize the output field.
Definition: diag_util.F90:1343
type(time_type) function, public get_file_start_time(file_num)
Get the a diag_file's start_time as it is defined in the diag_table.
Definition: diag_util.F90:2503
subroutine, public sync_file_times(file_id, init_time, err_msg)
Synchronize the file's start and close times with the model start and end times.
Definition: diag_util.F90:1244
character(len=1), public field_log_separator
separator used for csv-style log of registered fields set by nml in diag_manager init
Definition: diag_util.F90:116
subroutine, public check_out_of_bounds(out_num, diag_field_id, err_msg)
Checks if the array indices for output_fields(out_num) are outside the output_fields(out_num)buffer u...
Definition: diag_util.F90:842
subroutine, public get_subfield_vert_size(axes, outnum)
Get size, start and end indices for output fields.
Definition: diag_util.F90:416
subroutine, public log_diag_field_info(module_name, field_name, axes, long_name, units, missing_value, range, dynamic)
Writes brief diagnostic field info to the log file.
Definition: diag_util.F90:636
subroutine, public update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
Update the output_fields x, y, and z min and max boundaries (array indices) with the six specified bo...
Definition: diag_util.F90:747
subroutine, public diag_util_init()
Write the version number of this file to the log file.
Definition: diag_util.F90:124
subroutine, public check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
This is an adaptor to the check_bounds_are_exact_dynamic_modern function to maintain an interface ser...
Definition: diag_util.F90:990
Allocates the atttype in out_file.
Definition: diag_util.F90:97
Prepend a value to a string attribute in the output field or output file.
Definition: diag_util.F90:90
Interface fieldbuff_copy_fieldvals updates elements of the field output buffer with copies of corresp...
Interface fieldbuff_copy_missvals updates elements of the field output buffer with the missvalue inpu...
Interface fieldbuff_update updates elements of field output buffer based on input field data and math...
Class fmsDiagOutfield_type (along with class ms_diag_outfield_index_type ) contain information used i...
Class fms_diag_outfield_index_type which (along with class fmsDiagOutfield_type) encapsulate related ...
integer function, public check_nml_error(IOSTAT, NML_NAME)
Checks the iostat argument that is returned after reading a namelist and determines if the error code...
Definition: fms.F90:523
subroutine, public write_version_number(version, tag, unit)
Prints to the log file (or a specified unit) the version id string and tag name.
Definition: fms.F90:701
logical function, public fms_error_handler(routine, message, err_msg)
Facilitates the control of fatal error conditions.
Definition: fms.F90:468
subroutine, public error_mesg(routine, message, level)
Print notes, warnings and error messages; terminates program for warning and error messages....
Definition: fms.F90:441
character(:) function, allocatable, public string(v, fmt)
Converts a number or a Boolean value to a string.
integer function stdout()
This function returns the current standard fortran unit numbers for output.
Definition: mpp_util.inc:42
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
Definition: mpp_util.inc:58
integer function mpp_npes()
Returns processor count for current pelist.
Definition: mpp_util.inc:420
integer function mpp_pe()
Returns processor ID.
Definition: mpp_util.inc:406
Error handler.
Definition: mpp.F90:385
Reduction operation.
Definition: mpp.F90:627
integer function, public get_ticks_per_second()
Returns the number of ticks per second.
subroutine, public get_time(Time, seconds, days, ticks, err_msg)
Returns days and seconds ( < 86400 ) corresponding to a time. err_msg should be checked for any error...
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...
Given an input date in year, month, days, etc., creates a time_type that represents this time interva...
Given some number of seconds and days, returns the corresponding time_type.
Type to represent amounts of time. Implemented as seconds and days to allow for larger intervals.
Get the current pelist. The two flavors of this subroutine differ in the type of their comm/commID ar...
Definition: mpp.F90:433