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