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