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