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