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