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