FMS  2024.01.00
Flexible Modeling System
diag_util.F90
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_util_mod diag_util_mod
20 !> @ingroup diag_manager
21 !! @brief Functions and subroutines necessary for the <TT>diag_manager_mod</TT>.
22 !! @author Seth Underwood
23 
24 MODULE diag_util_mod
25 
26 use platform_mod
27 use,intrinsic :: iso_fortran_env, only: real128
28 use,intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, &
29  c_int32_t,c_int16_t,c_intptr_t
30 
31  ! <FUTURE>
32  ! Make an interface <TT>check_bounds_are_exact</TT> for the subroutines <TT>check_bounds_are_exact_static</TT>
33  ! and
34  ! <TT>check_bounds_are_exact_dynamic</TT>.
35  ! <PRE>
36  ! INTERFACE check_bounds_are_exact
37  ! MODULE PROCEDURE check_bounds_are_exact_static
38  ! MODULE PROCEDURE check_bounds_are_exact_dynamic
39  ! END INTERFACE check_bounds_are_exact
40  ! </PRE>
41  ! </FUTURE>
42 
43  USE diag_data_mod, ONLY: output_fields, input_fields, files, do_diag_field_log, diag_log_unit,&
44  & very_large_axis_length, time_zero, very_large_file_freq, end_of_run, every_time,&
45  & diag_seconds, diag_minutes, diag_hours, diag_days, diag_months, diag_years, get_base_time,&
49  & mix_snapshot_average_fields, global_descriptor, cmor_missing_value, use_cmor, pack_size,&
53  USE diag_data_mod, ONLY: fileobju, fileobj, fnum_for_domain, fileobjnd
58  USE diag_output_mod, ONLY: diag_output_init, write_axis_meta_data,&
60  USE diag_output_mod, ONLY: diag_field_write, diag_write_time !<fms2_io
61  USE diag_grid_mod, ONLY: get_local_indexes
62  USE fms_diag_time_utils_mod, ONLY: diag_time_inc, get_time_string, get_date_dif
63  USE fms_mod, ONLY: error_mesg, fatal, warning, note, mpp_pe, mpp_root_pe, lowercase, fms_error_handler,&
64  & string, write_version_number
65  USE mpp_domains_mod,ONLY: domain1d, domain2d, mpp_get_compute_domain, null_domain1d, null_domain2d,&
66  & OPERATOR(.NE.), OPERATOR(.EQ.), mpp_modify_domain, mpp_get_domain_components,&
68  & domainug, null_domainug
69  USE time_manager_mod,ONLY: time_type, OPERATOR(==), OPERATOR(>), no_calendar, increment_date,&
71  & OPERATOR(<), OPERATOR(>=), OPERATOR(<=), OPERATOR(==)
72  USE mpp_mod, ONLY: mpp_npes
73  USE constants_mod, ONLY: seconds_per_day, seconds_per_hour, seconds_per_minute
74  USE fms2_io_mod
75  USE fms_diag_bbox_mod, ONLY: fmsdiagibounds_type
76  USE netcdf, ONLY: nf90_char
77 
78  IMPLICIT NONE
79  PRIVATE
87 
88 
89  !> @brief Prepend a value to a string attribute in the output field or output file.
90  !> @ingroup diag_util_mod
92  MODULE PROCEDURE prepend_attribute_field
93  MODULE PROCEDURE prepend_attribute_file
94  END INTERFACE prepend_attribute
95 
96  !> @brief Allocates the atttype in out_file.
97  !> @ingroup diag_util_mod
98  INTERFACE attribute_init
99  MODULE PROCEDURE attribute_init_field
100  MODULE PROCEDURE attribute_init_file
101  END INTERFACE attribute_init
102 
104  module procedure fms_diag_check_out_of_bounds_r4
105  module procedure fms_diag_check_out_of_bounds_r8
106  END INTERFACE fms_diag_check_out_of_bounds
107 
108 
109 !> @addtogroup diag_util_mod
110 !> @{
111 
112  ! Include variable "version" to be written to log file.
113 #include <file_version.h>
114 
115  LOGICAL :: module_initialized = .false.
116 
117  character(len=1), public :: field_log_separator = '|' !< separator used for csv-style log of registered fields
118  !! set by nml in diag_manager init
119 
120 
121 CONTAINS
122 
123  !> @brief Write the version number of this file to the log file.
124  SUBROUTINE diag_util_init()
125  IF (module_initialized) THEN
126  RETURN
127  END IF
128 
129  ! Write version number out to log file
130  call write_version_number("DIAG_UTIL_MOD", version)
131  END SUBROUTINE diag_util_init
132 
133  !> @brief Get the size, start, and end indices for output fields.
134  SUBROUTINE get_subfield_size(axes, outnum)
135  INTEGER, INTENT(in) :: axes(:) !< axes of the input_field
136  INTEGER, INTENT(in) :: outnum !< position in array output_fields
137 
138  REAL, ALLOCATABLE :: global_lat(:), global_lon(:), global_depth(:)
139  INTEGER :: global_axis_size, global_axis_sizey
140  INTEGER :: i,xbegin,xend,ybegin,yend,xbegin_l,xend_l,ybegin_l,yend_l
141  CHARACTER(len=1) :: cart
142  TYPE(domain2d) :: domain2, domain2_new
143  TYPE(domain1d) :: domain1, domain1x, domain1y
144  REAL :: start(3) !< start coordinates in 3 axes
145  REAL :: end(3) !< end coordinates in 3 axes
146  INTEGER :: gstart_indx(3)!< global start indices of output domain in 3 axes
147  INTEGER :: gend_indx(3) !< global end indices of output domain in 3 axes
148  REAL, ALLOCATABLE :: subaxis_x(:) !< containing local coordinates in x,y,z axes
149  REAL, ALLOCATABLE :: subaxis_y(:) !< containing local coordinates in x,y,z axes
150  REAL, ALLOCATABLE :: subaxis_z(:) !< containing local coordinates in x,y,z axes
151  CHARACTER(len=128) :: msg
152  INTEGER :: ishift, jshift
153  INTEGER :: grv !< Value used to determine if the region defined in the diag_table is for the whole
154  !! axis, or a sub-axis
155  CHARACTER(len=128), DIMENSION(2) :: axis_domain_name
156 
157  !initilization for local output
158  ! initially out of (lat/lon/depth) range
159  start = -1.e10
160  end = -1.e10
161  gstart_indx = -1
162  gend_indx = -1
163 
164  ! get the value to compare to determine if writing full axis data
165  IF ( region_out_use_alt_value ) THEN
166  grv = glo_reg_val_alt
167  ELSE
168  grv = glo_reg_val
169  END IF
170 
171  ! get axis data (lat, lon, depth) and indices
172  start = output_fields(outnum)%output_grid%start
173  end = output_fields(outnum)%output_grid%end
174 
175  CALL get_diag_axis_domain_name(axes(1), axis_domain_name(1))
176  CALL get_diag_axis_domain_name(axes(2), axis_domain_name(2))
177 
178  IF ( index(lowercase(axis_domain_name(1)), 'cubed') == 0 .AND. &
179  & index(lowercase(axis_domain_name(2)), 'cubed') == 0 ) THEN
180  DO i = 1, SIZE(axes(:))
181  global_axis_size = get_axis_global_length(axes(i))
182  output_fields(outnum)%output_grid%subaxes(i) = -1
183  CALL get_diag_axis_cart(axes(i), cart)
184  SELECT CASE(cart)
185  CASE ('X')
186  ! <ERROR STATUS="FATAL">wrong order of axes. X should come first.</ERROR>
187  IF( i.NE.1 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
188  & 'wrong order of axes, X should come first',fatal)
189  ALLOCATE(global_lon(global_axis_size))
190  CALL get_diag_axis_data(axes(i),global_lon)
191  IF( int(start(i)) == grv .AND. int(end(i)) == grv ) THEN
192  gstart_indx(i) = 1
193  gend_indx(i) = global_axis_size
194  output_fields(outnum)%output_grid%subaxes(i) = axes(i)
195  ELSE
196  gstart_indx(i) = get_index(start(i),global_lon)
197  gend_indx(i) = get_index(end(i),global_lon)
198  END IF
199  ALLOCATE(subaxis_x(gstart_indx(i):gend_indx(i)))
200  subaxis_x=global_lon(gstart_indx(i):gend_indx(i))
201  CASE ('Y')
202  ! <ERROR STATUS="FATAL">wrong order of axes, Y should come second.</ERROR>
203  IF( i.NE.2 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
204  & 'wrong order of axes, Y should come second',fatal)
205  ALLOCATE(global_lat(global_axis_size))
206  CALL get_diag_axis_data(axes(i),global_lat)
207  IF( int(start(i)) == grv .AND. int(end(i)) == grv ) THEN
208  gstart_indx(i) = 1
209  gend_indx(i) = global_axis_size
210  output_fields(outnum)%output_grid%subaxes(i) = axes(i)
211  ELSE
212  gstart_indx(i) = get_index(start(i),global_lat)
213  gend_indx(i) = get_index(end(i),global_lat)
214  END IF
215  ALLOCATE(subaxis_y(gstart_indx(i):gend_indx(i)))
216  subaxis_y=global_lat(gstart_indx(i):gend_indx(i))
217  CASE ('Z')
218  ! <ERROR STATUS="FATAL">wrong values in vertical axis of region</ERROR>
219  IF ( start(i)*end(i)<0. ) CALL error_mesg('diag_util_mod::get_subfield_size',&
220  & 'wrong values in vertical axis of region',fatal)
221  IF ( start(i)>=0. .AND. end(i)>0. ) THEN
222  ALLOCATE(global_depth(global_axis_size))
223  CALL get_diag_axis_data(axes(i),global_depth)
224  gstart_indx(i) = get_index(start(i),global_depth)
225  gend_indx(i) = get_index(end(i),global_depth)
226  ALLOCATE(subaxis_z(gstart_indx(i):gend_indx(i)))
227  subaxis_z=global_depth(gstart_indx(i):gend_indx(i))
228  output_fields(outnum)%output_grid%subaxes(i) =&
229  & diag_subaxes_init(axes(i),subaxis_z, gstart_indx(i),gend_indx(i))
230  DEALLOCATE(subaxis_z,global_depth)
231  ELSE ! regional vertical axis is the same as global vertical axis
232  gstart_indx(i) = 1
233  gend_indx(i) = global_axis_size
234  output_fields(outnum)%output_grid%subaxes(i) = axes(i)
235  ! <ERROR STATUS="FATAL">i should equal 3 for z axis</ERROR>
236  IF( i /= 3 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
237  & 'i should equal 3 for z axis', fatal)
238  END IF
239  CASE default
240  ! <ERROR STATUS="FATAL">Wrong axis_cart</ERROR>
241  CALL error_mesg('diag_util_mod::get_subfield_size', 'Wrong axis_cart', fatal)
242  END SELECT
243  END DO
244 
245  DO i = 1, SIZE(axes(:))
246  IF ( gstart_indx(i) == -1 .OR. gend_indx(i) == -1 ) THEN
247  ! <ERROR STATUS="FATAL">
248  ! can not find gstart_indx/gend_indx for <output_fields(outnum)%output_name>,
249  ! check region bounds for axis <i>.
250  ! </ERROR>
251  WRITE(msg,'(A,I2)') ' check region bounds for axis ', i
252  CALL error_mesg('diag_util_mod::get_subfield_size', 'can not find gstart_indx/gend_indx for '&
253  & //trim(output_fields(outnum)%output_name)//','//trim(msg), fatal)
254  END IF
255  END DO
256  ELSE ! cubed sphere
257  ! get the i and j start and end indexes
258  CALL get_local_indexes(lonstart=start(1), lonend=end(1), &
259  & latstart=start(2), latend=end(2), &
260  & istart=gstart_indx(1), iend=gend_indx(1), &
261  & jstart=gstart_indx(2), jend=gend_indx(2))
262  global_axis_size = get_axis_global_length(axes(1))
263  ALLOCATE(global_lon(global_axis_size))
264  global_axis_sizey = get_axis_global_length(axes(2))
265  ALLOCATE(global_lat(global_axis_sizey))
266  CALL get_diag_axis_data(axes(1),global_lon)
267  CALL get_diag_axis_data(axes(2),global_lat)
268 
269  !Potential fix for out-of-bounds error for global_lon and global_lat.
270  IF ((gstart_indx(1) .GT. 0 .AND. gstart_indx(2) .GT. 0) .AND. &
271  (gstart_indx(1) .LE. global_axis_size .AND. gstart_indx(2) .LE. global_axis_sizey) .AND. &
272  (gend_indx(1) .GT. 0 .AND. gend_indx(2) .GT. 0) .AND. &
273  (gend_indx(1) .LE. global_axis_size .AND. gend_indx(2) .LE. global_axis_sizey)) THEN
274  ALLOCATE(subaxis_x(gstart_indx(1):gend_indx(1)))
275  ALLOCATE(subaxis_y(gstart_indx(2):gend_indx(2)))
276  subaxis_x=global_lon(gstart_indx(1):gend_indx(1))
277  subaxis_y=global_lat(gstart_indx(2):gend_indx(2))
278  END IF
279 
280  ! Now deal with the Z component
281  IF ( SIZE(axes(:)) > 2 ) THEN
282  global_axis_size = get_axis_global_length(axes(3))
283  output_fields(outnum)%output_grid%subaxes(3) = -1
284  CALL get_diag_axis_cart(axes(3), cart)
285  ! <ERROR STATUS="FATAL">
286  ! axis(3) should be Z-axis
287  ! </ERROR>
288  IF ( lowercase(cart) /= 'z' ) CALL error_mesg('diag_util_mod::get_subfield_size', &
289  &'axis(3) should be Z-axis', fatal)
290  ! <ERROR STATUS="FATAL">
291  ! wrong values in vertical axis of region
292  ! </ERROR>
293  IF ( start(3)*end(3)<0. ) CALL error_mesg('diag_util_mod::get_subfield_size',&
294  & 'wrong values in vertical axis of region',fatal)
295  IF ( start(3)>=0. .AND. end(3)>0. ) THEN
296  ALLOCATE(global_depth(global_axis_size))
297  CALL get_diag_axis_data(axes(3),global_depth)
298  gstart_indx(3) = get_index(start(3),global_depth)
299  IF( start(3) == 0.0 ) gstart_indx(3) = 1
300  gend_indx(3) = get_index(end(3),global_depth)
301  IF( start(3) >= maxval(global_depth) ) gstart_indx(3)= global_axis_size
302  IF( end(3) >= maxval(global_depth) ) gend_indx(3) = global_axis_size
303 
304  ALLOCATE(subaxis_z(gstart_indx(3):gend_indx(3)))
305  subaxis_z=global_depth(gstart_indx(3):gend_indx(3))
306  output_fields(outnum)%output_grid%subaxes(3) =&
307  & diag_subaxes_init(axes(3),subaxis_z, gstart_indx(3),gend_indx(3))
308  DEALLOCATE(subaxis_z,global_depth)
309  ELSE ! regional vertical axis is the same as global vertical axis
310  gstart_indx(3) = 1
311  gend_indx(3) = global_axis_size
312  output_fields(outnum)%output_grid%subaxes(3) = axes(3)
313  END IF
314  END IF
315  END IF
316 
317  ! get domain and compute_domain(xbegin,xend,ybegin,yend)
318  xbegin = -1
319  xend = -1
320  ybegin = -1
321  yend = -1
322 
323  domain2 = get_domain2d(axes)
324  IF ( domain2 .NE. null_domain2d ) THEN
325  CALL mpp_get_compute_domain(domain2, xbegin, xend, ybegin, yend)
326  CALL mpp_get_domain_components(domain2, domain1x, domain1y)
327  ELSE
328  DO i = 1, min(SIZE(axes(:)),2)
329  domain1 = get_domain1d(axes(i))
330  IF ( domain1 .NE. null_domain1d ) THEN
331  CALL get_diag_axis_cart(axes(i),cart)
332  SELECT CASE(cart)
333  CASE ('X')
334  domain1x = get_domain1d(axes(i))
335  CALL mpp_get_compute_domain(domain1x, xbegin, xend)
336  CASE ('Y')
337  domain1y = get_domain1d(axes(i))
338  CALL mpp_get_compute_domain(domain1y, ybegin, yend)
339  CASE default ! do nothing here
340  END SELECT
341  ELSE
342  ! <ERROR STATUS="FATAL">No domain available</ERROR>
343  CALL error_mesg('diag_util_mod::get_subfield_size', 'NO domain available', fatal)
344  END IF
345  END DO
346  END IF
347 
348  CALL get_axes_shift(axes, ishift, jshift)
349  xend = xend+ishift
350  yend = yend+jshift
351 
352  IF ( xbegin == -1 .OR. xend == -1 .OR. ybegin == -1 .OR. yend == -1 ) THEN
353  ! <ERROR STATUS="FATAL">wrong compute domain indices</ERROR>
354  CALL error_mesg('diag_util_mod::get_subfield_size', 'wrong compute domain indices',fatal)
355  END IF
356 
357  ! get the area containing BOTH compute domain AND local output area
358  IF( gstart_indx(1) > xend .OR. xbegin > gend_indx(1) ) THEN
359  output_fields(outnum)%output_grid%l_start_indx(1) = -1
360  output_fields(outnum)%output_grid%l_end_indx(1) = -1
361  output_fields(outnum)%need_compute = .false. ! not involved
362  ELSEIF ( gstart_indx(2) > yend .OR. ybegin > gend_indx(2) ) THEN
363  output_fields(outnum)%output_grid%l_start_indx(2) = -1
364  output_fields(outnum)%output_grid%l_end_indx(2) = -1
365  output_fields(outnum)%need_compute = .false. ! not involved
366  ELSE
367  output_fields(outnum)%output_grid%l_start_indx(1) = max(xbegin, gstart_indx(1))
368  output_fields(outnum)%output_grid%l_start_indx(2) = max(ybegin, gstart_indx(2))
369  output_fields(outnum)%output_grid%l_end_indx(1) = min(xend, gend_indx(1))
370  output_fields(outnum)%output_grid%l_end_indx(2) = min(yend, gend_indx(2))
371  output_fields(outnum)%need_compute = .true. ! involved in local output
372  END IF
373 
374  IF ( output_fields(outnum)%need_compute ) THEN
375  ! need to modify domain1d and domain2d for subaxes
376  xbegin_l = output_fields(outnum)%output_grid%l_start_indx(1)
377  xend_l = output_fields(outnum)%output_grid%l_end_indx(1)
378  ybegin_l = output_fields(outnum)%output_grid%l_start_indx(2)
379  yend_l = output_fields(outnum)%output_grid%l_end_indx(2)
380  CALL mpp_modify_domain(domain2, domain2_new, xbegin_l,xend_l, ybegin_l,yend_l,&
381  & gstart_indx(1),gend_indx(1), gstart_indx(2),gend_indx(2))
382 
383  output_fields(outnum)%output_grid%subaxes(1) =&
384  & diag_subaxes_init(axes(1),subaxis_x, gstart_indx(1),gend_indx(1),domain2_new)
385  output_fields(outnum)%output_grid%subaxes(2) =&
386  & diag_subaxes_init(axes(2),subaxis_y, gstart_indx(2),gend_indx(2),domain2_new)
387  DO i = 1, SIZE(axes(:))
388  IF ( output_fields(outnum)%output_grid%subaxes(i) == -1 ) THEN
389  ! <ERROR STATUS="FATAL">
390  ! <output_fields(outnum)%output_name> error at i = <i>
391  ! </ERROR>
392  WRITE(msg,'(a,"/",I4)') 'at i = ',i
393  CALL error_mesg('diag_util_mod::get_subfield_size '//trim(output_fields(outnum)%output_name),&
394  'error '//trim(msg), fatal)
395  END IF
396  END DO
397 
398  ! local start index should start from 1
399  output_fields(outnum)%output_grid%l_start_indx(1) = max(xbegin, gstart_indx(1)) - xbegin + 1
400  output_fields(outnum)%output_grid%l_start_indx(2) = max(ybegin, gstart_indx(2)) - ybegin + 1
401  output_fields(outnum)%output_grid%l_end_indx(1) = min(xend, gend_indx(1)) - xbegin + 1
402  output_fields(outnum)%output_grid%l_end_indx(2) = min(yend, gend_indx(2)) - ybegin + 1
403  IF ( SIZE(axes(:))>2 ) THEN
404  output_fields(outnum)%output_grid%l_start_indx(3) = gstart_indx(3)
405  output_fields(outnum)%output_grid%l_end_indx(3) = gend_indx(3)
406  ELSE
407  output_fields(outnum)%output_grid%l_start_indx(3) = 1
408  output_fields(outnum)%output_grid%l_end_indx(3) = 1
409  END IF
410  END IF
411  IF ( ALLOCATED(subaxis_x) ) DEALLOCATE(subaxis_x, global_lon)
412  IF ( ALLOCATED(subaxis_y) ) DEALLOCATE(subaxis_y, global_lat)
413  END SUBROUTINE get_subfield_size
414 
415  !> @brief Get size, start and end indices for output fields.
416  SUBROUTINE get_subfield_vert_size(axes, outnum)
417  INTEGER, DIMENSION(:), INTENT(in) :: axes !< axes of the input_field
418  INTEGER, INTENT(in) :: outnum !< position in array output_fields
419 
420  REAL, DIMENSION(3) :: start !< start and end coordinates in 3 axes
421  REAL, DIMENSION(3) :: end !< start and end coordinates in 3 axes
422  REAL, ALLOCATABLE, DIMENSION(:) :: global_depth
423  REAL, ALLOCATABLE, DIMENSION(:) :: subaxis_z !< containing local coordinates in x,y,z axes
424  INTEGER :: i, global_axis_size
425  INTEGER, DIMENSION(3) :: gstart_indx !< global start and end indices of output domain in 3 axes
426  INTEGER, DIMENSION(3) :: gend_indx !< global start and end indices of output domain in 3 axes
427  CHARACTER(len=1) :: cart
428  CHARACTER(len=128) :: msg
429 !----------
430 !ug support
431  integer :: vert_dim_num
432 !----------
433 
434  !initilization for local output
435  start = -1.e10
436  end = -1.e10 ! initially out of (lat/lon/depth) range
437  gstart_indx = -1
438  gend_indx=-1
439 
440  ! get axis data (lat, lon, depth) and indices
441  start= output_fields(outnum)%output_grid%start
442  end = output_fields(outnum)%output_grid%end
443 
444 !----------
445 !ug support
446  vert_dim_num = 3
447 !----------
448  DO i = 1, SIZE(axes(:))
449  global_axis_size = get_axis_global_length(axes(i))
450  output_fields(outnum)%output_grid%subaxes(i) = -1
451  CALL get_diag_axis_cart(axes(i), cart)
452  SELECT CASE(cart)
453  CASE ('X')
454  ! <ERROR STATUS="FATAL">wrong order of axes, X should come first</ERROR>
455  IF ( i.NE.1 ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
456  & 'wrong order of axes, X should come first',fatal)
457  gstart_indx(i) = 1
458  gend_indx(i) = global_axis_size
459  output_fields(outnum)%output_grid%subaxes(i) = axes(i)
460  CASE ('Y')
461  ! <ERROR STATUS="FATAL">wrong order of axes, Y should come second</ERROR>
462  IF( i.NE.2 ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
463  & 'wrong order of axes, Y should come second',fatal)
464  gstart_indx(i) = 1
465  gend_indx(i) = global_axis_size
466  output_fields(outnum)%output_grid%subaxes(i) = axes(i)
467 !----------
468 !ug support
469  case ("U")
470  if (i .ne. 1) then
471  call error_mesg("diag_util_mod::get_subfield_vert_size", &
472  "the unstructured axis must be the first dimension.", &
473  fatal)
474  endif
475  gstart_indx(i) = 1
476  gend_indx(i) = global_axis_size
477  output_fields(outnum)%output_grid%subaxes(i) = axes(i)
478  vert_dim_num = 2
479  start(vert_dim_num) = start(3)
480  end(vert_dim_num) = end(3)
481 !----------
482  CASE ('Z')
483 !----------
484 !ug support
485  if (i .ne. vert_dim_num) then
486  call error_mesg("diag_util_mod::get_subfield_vert_size",&
487  "i should equal vert_dim_num for z axis", &
488  fatal)
489  endif
490 !----------
491  ! <ERROR STATUS="FATAL">wrong values in vertical axis of region</ERROR>
492  IF( start(i)*end(i) < 0. ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
493  & 'wrong values in vertical axis of region',fatal)
494  IF( start(i) >= 0. .AND. end(i) > 0. ) THEN
495  ALLOCATE(global_depth(global_axis_size))
496  CALL get_diag_axis_data(axes(i),global_depth)
497  gstart_indx(i) = get_index(start(i),global_depth)
498  IF( start(i) == 0.0 ) gstart_indx(i) = 1
499 
500  gend_indx(i) = get_index(end(i),global_depth)
501  IF( start(i) >= maxval(global_depth) ) gstart_indx(i)= global_axis_size
502  IF( end(i) >= maxval(global_depth) ) gend_indx(i) = global_axis_size
503 
504  ALLOCATE(subaxis_z(gstart_indx(i):gend_indx(i)))
505  subaxis_z=global_depth(gstart_indx(i):gend_indx(i))
506  output_fields(outnum)%output_grid%subaxes(i) = &
507  diag_subaxes_init(axes(i),subaxis_z, gstart_indx(i),gend_indx(i))
508  DEALLOCATE(subaxis_z,global_depth)
509  ELSE ! vertical axis is the same as global vertical axis
510  gstart_indx(i) = 1
511  gend_indx(i) = global_axis_size
512  output_fields(outnum)%output_grid%subaxes(i) = axes(i)
513  END IF
514  CASE default
515  ! <ERROR STATUS="FATAL">Wrong axis_cart</ERROR>
516  CALL error_mesg('diag_util_mod::get_subfield_vert_size', 'Wrong axis_cart', fatal)
517  END SELECT
518  END DO
519 
520  DO i = 1,SIZE(axes(:))
521  IF ( gstart_indx(i) == -1 .OR. gend_indx(i) == -1 ) THEN
522  ! <ERROR STATUS="FATAL">
523  ! can not find gstart_indx/gend_indx for <output_fields(outnum)%output_name>
524  ! check region bounds for axis
525  ! </ERROR>
526  WRITE(msg,'(A,I2)') ' check region bounds for axis ', i
527  CALL error_mesg('diag_util_mod::get_subfield_vert_size', 'can not find gstart_indx/gend_indx for '&
528  & //trim(output_fields(outnum)%output_name)//','//trim(msg), fatal)
529  END IF
530  END DO
531 
532  DO i= 1, 2
533  output_fields(outnum)%output_grid%l_start_indx(i) = gstart_indx(i)
534  output_fields(outnum)%output_grid%l_end_indx(i) = gend_indx(i)
535  END DO
536 
537  IF( SIZE(axes(:)) > 2 ) THEN
538  output_fields(outnum)%output_grid%l_start_indx(3) = gstart_indx(3)
539  output_fields(outnum)%output_grid%l_end_indx(3) = gend_indx(3)
540  ELSE
541  output_fields(outnum)%output_grid%l_start_indx(3) = 1
542  output_fields(outnum)%output_grid%l_end_indx(3) = 1
543  END IF
544  END SUBROUTINE get_subfield_vert_size
545 
546  !> @brief Find index <TT>i</TT> of array such that <TT>array(i)</TT> is closest to number.
547  INTEGER FUNCTION get_index(number, array)
548  REAL, INTENT(in) :: number !<
549  REAL, INTENT(in), DIMENSION(:) :: array !<
550 
551  INTEGER :: i, n
552  LOGICAL :: found
553 
554  n = SIZE(array(:))
555  ! check if array is monotonous
556  DO i = 2, n-1
557  IF( (array(i-1)<array(i).AND.array(i)>array(i+1)) .OR. (array(i-1)>array(i).AND.array(i)<array(i+1))) THEN
558  ! <ERROR STATUS="FATAL">array NOT monotonously ordered</ERROR>
559  CALL error_mesg('diag_util_mod::get_index', 'array NOT monotonously ordered',fatal)
560  END IF
561  END DO
562  get_index = -1
563  found = .false.
564  ! search in increasing array
565  DO i = 1, n-1
566  IF ( (array(i)<=number).AND.(array(i+1)>= number) ) THEN
567  IF( number - array(i) <= array(i+1) - number ) THEN
568  get_index = i
569  found=.true.
570  ELSE
571  get_index = i+1
572  found=.true.
573  ENDIF
574  EXIT
575  END IF
576  END DO
577  ! if not found, search in decreasing array
578  IF( .NOT.found ) THEN
579  DO i = 1, n-1
580  IF ( (array(i)>=number).AND.(array(i+1)<= number) ) THEN
581  IF ( array(i)-number <= number-array(i+1) ) THEN
582  get_index = i
583  found = .true.
584  ELSE
585  get_index = i+1
586  found = .true.
587  END IF
588  EXIT
589  END IF
590  END DO
591  END IF
592  ! if still not found, is it less than the first element
593  ! or greater than last element? (Increasing Array)
594  ! But it must be within 2x the axis spacing
595  ! i.e. array(1)-(array(3)-array(1)).LT.number .AND. or 2*array(1)-array(3).LT.number
596  IF ( .NOT. found ) THEN
597  IF ( 2*array(1)-array(3).LT.number .AND. number.LT.array(1) ) THEN
598  get_index = 1
599  found = .true.
600  ELSE IF ( array(n).LT.number .AND. number.LT.2*array(n)-array(n-2) ) THEN
601  get_index = n
602  found = .true.
603  ELSE
604  found = .false.
605  END IF
606  END IF
607 
608  ! if still not found, is it greater than the first element
609  ! or less than the last element? (Decreasing Array)
610  ! But it must be within 2x the axis spacing (see above)
611  IF ( .NOT. found ) THEN
612  IF ( 2*array(1)-array(3).GT.number .AND. number.GT.array(1) ) THEN
613  get_index = 1
614  found = .true.
615  ELSE IF ( array(n).GT.number .AND. number.GT.2*array(n)-array(n-2) ) THEN
616  get_index = n
617  found = .true.
618  ELSE
619  found = .false.
620  END IF
621  END IF
622  END FUNCTION get_index
623 
624  !> @brief Writes brief diagnostic field info to the log file.
625  !! @details If the <TT>do_diag_field_log</TT> namelist parameter is .TRUE.,
626  !! then a line briefly describing diagnostic field is added to
627  !! the log file. Normally users should not call this subroutine
628  !! directly, since it is called by register_static_field and
629  !! register_diag_field if do_not_log is not set to .TRUE.. It is
630  !! used, however, in LM3 to avoid excessive logs due to the
631  !! number of fields registered for each of the tile types. LM3
632  !! code uses a do_not_log parameter in the registration calls,
633  !! and subsequently calls this subroutine to log field information
634  !! under a generic name.
635  SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,&
636  & missing_value, range, dynamic )
637  CHARACTER(len=*), INTENT(in) :: module_name !< Module name
638  CHARACTER(len=*), INTENT(in) :: field_name !< Field name
639  INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs
640  CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field.
641  CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field.
642  CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value.
643  CLASS(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field.
644  LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< <TT>.TRUE.</TT> if field is not static.
645 
646  ! ---- local vars
647  CHARACTER(len=256) :: lmodule, lfield, lname, lunits
648  CHARACTER(len=64) :: lmissval, lmin, lmax
649  CHARACTER(len=8) :: numaxis, timeaxis
650  CHARACTER(len=1) :: sep = '|'
651  CHARACTER(len=256) :: axis_name, axes_list
652  INTEGER :: i
653  REAL :: missing_value_use !< Local copy of missing_value
654  REAL, DIMENSION(2) :: range_use !< Local copy of range
655 
656  IF ( .NOT.do_diag_field_log ) RETURN
657  IF ( mpp_pe().NE.mpp_root_pe() ) RETURN
658 
659  ! Fatal error if range is present and its extent is not 2.
660  IF ( PRESENT(range) ) THEN
661  IF ( SIZE(range) .NE. 2 ) THEN
662  CALL error_mesg('diag_util_mod::fms_log_field_info', 'extent of range should be 2', fatal)
663  END IF
664  END IF
665 
666  lmodule = trim(module_name)
667  lfield = trim(field_name)
668 
669  IF ( PRESENT(long_name) ) THEN
670  lname = trim(long_name)
671  ELSE
672  lname = ''
673  END IF
674 
675  IF ( PRESENT(units) ) THEN
676  lunits = trim(units)
677  ELSE
678  lunits = ''
679  END IF
680 
681  WRITE (numaxis,'(i1)') SIZE(axes)
682 
683  IF (PRESENT(missing_value)) THEN
684  IF ( use_cmor ) THEN
685  WRITE (lmissval,*) cmor_missing_value
686  ELSE
687  SELECT TYPE (missing_value)
688  TYPE IS (real(kind=r4_kind))
689  missing_value_use = missing_value
690  TYPE IS (real(kind=r8_kind))
691  missing_value_use = real(missing_value)
692  CLASS DEFAULT
693  CALL error_mesg ('diag_util_mod::log_diag_field_info',&
694  & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
695  END SELECT
696  WRITE (lmissval,*) missing_value_use
697  END IF
698  ELSE
699  lmissval = ''
700  ENDIF
701 
702  IF ( PRESENT(range) ) THEN
703  SELECT TYPE (range)
704  TYPE IS (real(kind=r4_kind))
705  range_use = range
706  TYPE IS (real(kind=r8_kind))
707  range_use = real(range)
708  CLASS DEFAULT
709  CALL error_mesg ('diag_util_mod::log_diag_field_info',&
710  & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', fatal)
711  END SELECT
712  WRITE (lmin,*) range_use(1)
713  WRITE (lmax,*) range_use(2)
714  ELSE
715  lmin = ''
716  lmax = ''
717  END IF
718 
719  IF ( PRESENT(dynamic) ) THEN
720  IF (dynamic) THEN
721  timeaxis = 'T'
722  ELSE
723  timeaxis = 'F'
724  END IF
725  ELSE
726  timeaxis = ''
727  END IF
728 
729  axes_list=''
730  DO i = 1, SIZE(axes)
731  CALL get_diag_axis_name(axes(i),axis_name)
732  IF ( trim(axes_list) /= '' ) axes_list = trim(axes_list)//','
733  axes_list = trim(axes_list)//trim(axis_name)
734  END DO
735 
736  WRITE (diag_log_unit,'(777a)') &
737  & trim(lmodule), field_log_separator, trim(lfield), field_log_separator, trim(lname), field_log_separator,&
738  & trim(lunits), field_log_separator, trim(numaxis), field_log_separator, trim(timeaxis), field_log_separator,&
739  & trim(lmissval), field_log_separator, trim(lmin), field_log_separator, trim(lmax), field_log_separator,&
740  & trim(axes_list)
741  END SUBROUTINE log_diag_field_info
742 
743 
744 
745  !> @brief Update the <TT>output_fields</TT> x, y, and z min and max boundaries (array indices)
746  !! with the six specified bounds values.
747  SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
748  INTEGER, INTENT(in) :: out_num !< output field ID
749  INTEGER, INTENT(in) :: lower_i !< Lower i bound.
750  INTEGER, INTENT(in) :: upper_i !< Upper i bound.
751  INTEGER, INTENT(in) :: lower_j !< Lower j bound.
752  INTEGER, INTENT(in) :: upper_j !< Upper j bound.
753  INTEGER, INTENT(in) :: lower_k !< Lower k bound.
754  INTEGER, INTENT(in) :: upper_k !< Upper k bound.
755  CALL output_fields(out_num)%buff_bounds%update_bounds &
756  & ( lower_i, upper_i, lower_j, upper_j, lower_k, upper_k )
757  END SUBROUTINE update_bounds
758 
759 
760 
761  !> @brief Compares the bounding indices of an array specified in "current_bounds"
762 !! to the corresponding lower and upper bounds specified in "bounds"
763 !! Comparison is done by the two user specified input functions lowerb_comp and upperb_comp.
764 !! If any compariosn function returns true, then, after filling error_str, this routine also returns
765 !! true. The suplied comparison functions should return true for errors : for indices out of bounds,
766 !! or indices are not equal when expected to be equal.
767 LOGICAL FUNCTION compare_buffer_bounds_to_size(current_bounds, bounds, error_str, lowerb_comp, upperb_comp)
768  TYPE (fmsdiagibounds_type), INTENT(in) :: current_bounds !<A bounding box holding the current bounds
769  !! of an array.
770  TYPE (fmsdiagibounds_type), INTENT(in):: bounds !< The bounding box to check against.
771  CHARACTER(*), INTENT(out) :: error_str !< The return status, which is set to non-empty message
772  !! if the check fails.
773 
774  !> @brief Interface lowerb_comp should be used for comparison to lower bounds of buffer.
775  INTERFACE
776  LOGICAL FUNCTION lowerb_comp(a , b)
777  INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other.
778  INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other.
779  END FUNCTION lowerb_comp
780  END INTERFACE
781 
782  !> @brief Interface lowerb_comp should be used for comparison to upper bounds of buffer.
783  INTERFACE
784  LOGICAL FUNCTION upperb_comp(a, b)
785  INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other.
786  INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other.
787  END FUNCTION upperb_comp
788  END INTERFACE
789 
791 
792  IF (lowerb_comp( bounds%get_imin() , current_bounds%get_imin()) .OR. &
793  upperb_comp( bounds%get_imax() , current_bounds%get_imax()).OR.&
794  lowerb_comp( bounds%get_jmin() , current_bounds%get_jmin()) .OR.&
795  upperb_comp( bounds%get_jmax() , current_bounds%get_jmax()) .OR.&
796  lowerb_comp( bounds%get_kmin() , current_bounds%get_kmin()) .OR.&
797  upperb_comp( bounds%get_kmax() , current_bounds%get_kmax())) THEN
799  error_str ='Buffer bounds= : , : , : Actual bounds= : , : , : '
800  WRITE(error_str(15:17),'(i3)') current_bounds%get_imin()
801  WRITE(error_str(19:21),'(i3)') current_bounds%get_imax()
802  WRITE(error_str(23:25),'(i3)') current_bounds%get_jmin()
803  WRITE(error_str(27:29),'(i3)') current_bounds%get_jmax()
804  WRITE(error_str(31:33),'(i3)') current_bounds%get_kmin()
805  WRITE(error_str(35:37),'(i3)') current_bounds%get_kmax()
806  WRITE(error_str(54:56),'(i3)') bounds%get_imin()
807  WRITE(error_str(58:60),'(i3)') bounds%get_imax()
808  WRITE(error_str(62:64),'(i3)') bounds%get_jmin()
809  WRITE(error_str(66:68),'(i3)') bounds%get_jmax()
810  WRITE(error_str(70:72),'(i3)') bounds%get_kmin()
811  WRITE(error_str(74:76),'(i3)') bounds%get_kmax()
812  ELSE
814  error_str = ''
815  END IF
817 
818 !> @brief return true iff a<b.
819 LOGICAL FUNCTION a_lessthan_b(a , b)
820  INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other.
821  INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other.
822  a_lessthan_b = a < b
823 END FUNCTION a_lessthan_b
824 
825 !> @brief return true iff a>b.
826 LOGICAL FUNCTION a_greaterthan_b(a, b)
827  INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other.
828  INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other.
829  a_greaterthan_b = a > b
830 END FUNCTION a_greaterthan_b
831 
832 !> @brief return true iff a /= b
833 LOGICAL FUNCTION a_noteq_b(a, b)
834 INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other.
835 INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other.
836 a_noteq_b = a /= b
837 END FUNCTION a_noteq_b
838 
839  !> @brief Checks if the array indices for <TT>output_fields(out_num)</TT> are outside the
840  !! <TT>output_fields(out_num)%buffer</TT> upper and lower bounds.
841  !! If there is an error then error message will be filled.
842 SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg)
843  INTEGER, INTENT(in) :: out_num !< Output field ID number.
844  INTEGER, INTENT(in) :: diag_field_id !< Input field ID number.
845  CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of <TT>check_out_of_bounds</TT>. An empty
846  !! error string indicates the x, y, and z indices are not outside the
847 
848  CHARACTER(len=128) :: error_string1, error_string2
849  LOGICAL :: out_of_bounds = .true.
850  TYPE (fmsdiagibounds_type) :: array_bounds
851  associate(buff_bounds => output_fields(out_num)%buff_bounds)
852 
853  CALL array_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer)
854 
855  out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, &
856  & error_string2, a_lessthan_b, a_greaterthan_b)
857 
858  IF (out_of_bounds .EQV. .true.) THEN
859  WRITE(error_string1,'(a,"/",a)') trim(input_fields(diag_field_id)%module_name), &
860  & trim(output_fields(out_num)%output_name)
861  err_msg = 'module/output_field='//trim(error_string1)//&
862  & ' Bounds of buffer exceeded. '//trim(error_string2)
863  ! imax, imin, etc need to be reset in case the program is not terminated.
864  call buff_bounds%reset(very_large_axis_length, 0)
865  ELSE
866  err_msg = ''
867  END IF
868  end associate
869 END SUBROUTINE check_out_of_bounds
870 
871  !> @brief Checks if the array indices for <TT>output_fields(out_num)</TT> are outside the
872  !! <TT>output_fields(out_num)%buffer</TT> upper and lower bounds.
873  !! If there is an error then error message will be filled.
874 SUBROUTINE fms_diag_check_out_of_bounds_r4(ofb, bounds, output_name, module_name, err_msg)
875  REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check
876  TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against
877  CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message
878  CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message
879  CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of <TT>check_out_of_bounds</TT>. An empty
880  !! error string indicates the x, y, and z indices are not outside the
881 
882  CHARACTER(len=128) :: error_string1, error_string2
883  LOGICAL :: out_of_bounds = .true.
884  TYPE (fmsDiagIbounds_type) :: array_bounds
885 
886  CALL array_bounds%reset_bounds_from_array_5D(ofb)
887 
888  out_of_bounds = compare_buffer_bounds_to_size(array_bounds, bounds, &
889  & error_string2, a_lessthan_b, a_greaterthan_b)
890 
891  IF (out_of_bounds .EQV. .true.) THEN
892  WRITE(error_string1,'(a,"/",a)') trim(module_name), trim(output_name)
893  err_msg = 'module/output_field='//trim(error_string1)//&
894  & ' Bounds of buffer exceeded. '//trim(error_string2)
895  ! imax, imin, etc need to be reset in case the program is not terminated.
896  call bounds%reset(very_large_axis_length,0)
897  ELSE
898  err_msg = ''
899  END IF
900 END SUBROUTINE fms_diag_check_out_of_bounds_r4
901 
902  !> @brief Checks if the array indices for output_field buffer (ofb) are outside the
903  !! are outside the bounding box (bounds).
904  !! If there is an error then error message will be filled.
905 
906 SUBROUTINE fms_diag_check_out_of_bounds_r8(ofb, bounds, output_name, module_name, err_msg)
907  REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check
908  TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against
909  CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message
910  CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message
911  CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of <TT>check_out_of_bounds</TT>. An empty
912  !! error string indicates the x, y, and z indices are not outside the
913 
914  CHARACTER(len=128) :: error_string1, error_string2
915  LOGICAL :: out_of_bounds = .true.
916  TYPE (fmsDiagIbounds_type) :: array_bounds !<A bounding box holdstore the current bounds ofb
917 
918  CALL array_bounds%reset_bounds_from_array_5D(ofb)
919 
920  out_of_bounds = compare_buffer_bounds_to_size(array_bounds, bounds, &
921  & error_string2, a_lessthan_b, a_greaterthan_b)
922 
923  IF (out_of_bounds .EQV. .true.) THEN
924  WRITE(error_string1,'(a,"/",a)') trim(module_name), trim(output_name)
925  err_msg = 'module/output_field='//trim(error_string1)//&
926  & ' Bounds of buffer exceeded. '//trim(error_string2)
927  ! imax, imin, etc need to be reset in case the program is not terminated.
928  call bounds%reset(very_large_axis_length,0)
929  ELSE
930  err_msg = ''
931  END IF
932 END SUBROUTINE fms_diag_check_out_of_bounds_r8
933 
934 
935 !> @brief Checks that array indices specified in the bounding box "current_bounds"
936 !! are identical to those in the bounding box "bounds" match exactly. The check
937 !! occurs only when the time changed.
938 !! If there is an error then error message will be filled.
939 SUBROUTINE fms_diag_check_bounds_are_exact_dynamic(current_bounds, bounds, output_name, module_name, &
940  & Time, field_prev_Time, err_msg)
941  TYPE (fmsdiagibounds_type), INTENT(in) :: current_bounds !<A bounding box holding the current bounds
942  !! of an array.
943  TYPE (fmsdiagibounds_type), INTENT(inout) :: bounds !<The bounding box to check against
944  CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message
945  CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message
946  TYPE(time_type), INTENT(in) :: time !< Time to use in check. The check is only performed if
947  !! <TT>output_fields(out_num)%Time_of_prev_field_data</TT> is not
948  !! equal to <TT>Time</TT> or <TT>Time_zero</TT>.
949  TYPE(time_type), INTENT(inout) :: field_prev_time !< <TT>output_fields(out_num)%Time_of_prev_field_data</TT>
950  CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of <TT>check_bounds_are_exact_dynamic</TT>.
951  !! An empty error string indicates the x, y, and z indices are
952  !! equal to the buffer array boundaries.
953 
954  CHARACTER(len=128) :: error_string1, error_string2
955  LOGICAL :: do_check
956  LOGICAL :: lims_not_exact
957 
958  err_msg = ''
959 
960  ! Check bounds only when the value of Time changes. When windows are used,
961  ! a change in Time indicates that a new loop through the windows has begun,
962  ! so a check of the previous loop can be done.
963  IF ( time == field_prev_time ) THEN
964  do_check = .false.
965  ELSE
966  IF ( field_prev_time == time_zero ) THEN
967  ! It may or may not be OK to check, I don't know how to tell.
968  ! Check will be done on subsequent calls anyway.
969  do_check = .false.
970  ELSE
971  do_check = .true.
972  END IF
973  field_prev_time = time
974  END IF
975 
976  IF ( do_check ) THEN
977  lims_not_exact = compare_buffer_bounds_to_size(current_bounds, bounds, &
978  & error_string2, a_noteq_b, a_noteq_b)
979  IF( lims_not_exact .eqv. .true.) THEN
980  WRITE(error_string1,'(a,"/",a)') trim(module_name), trim(output_name)
981  err_msg = trim(error_string1)//' Bounds of data do not match those of buffer. '//trim(error_string2)
982  END IF
983  call bounds%reset(very_large_axis_length, 0)
984  END IF
986 
987 
988 !> @brief This is an adaptor to the check_bounds_are_exact_dynamic_modern function to
989 !! maintain an interface servicing the legacy diag_manager.
990 SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
991  INTEGER, INTENT(in) :: out_num !< Output field ID number.
992  INTEGER, INTENT(in) :: diag_field_id !< Input field ID number.
993  TYPE(time_type), INTENT(in) :: time !< Time to use in check. The check is only performed if
994  !! <TT>output_fields(out_num)%Time_of_prev_field_data</TT> is not
995  !! equal to <TT>Time</TT> or <TT>Time_zero</TT>.
996  CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of <TT>check_bounds_are_exact_dynamic</TT>.
997  !! An empty error string indicates the x, y, and z indices are
998  !! equal to the buffer array boundaries.
999  CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message
1000  CHARACTER(:), ALLOCATABLE :: module_name !< module name for placing in error message
1001  TYPE (fmsdiagibounds_type) :: current_bounds !< a bounding box to store the current bounds of the array.
1002 
1003  output_name = output_fields(out_num)%output_name
1004  module_name = input_fields(diag_field_id)%module_name
1005 
1006  CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer)
1007 
1008  CALL fms_diag_check_bounds_are_exact_dynamic(current_bounds, output_fields(out_num)%buff_bounds, &
1009  & output_name, module_name, &
1010  & time, output_fields(out_num)%Time_of_prev_field_data, err_msg)
1011 
1012 END SUBROUTINE check_bounds_are_exact_dynamic
1013 
1014 
1015  !> @brief Check if the array indices for <TT>output_fields(out_num)</TT> are equal to the
1016  !! <TT>output_fields(out_num)%buffer</TT> upper and lower bounds.
1017  SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
1018  INTEGER, INTENT(in) :: out_num !< Output field ID
1019  INTEGER, INTENT(in) :: diag_field_id !< Input field ID.
1020  CHARACTER(len=*), INTENT(out) :: err_msg !< The return status, which is set to non-empty message
1021  !! if the check fails.
1022  CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message
1023  CHARACTER(:), ALLOCATABLE :: module_name !< output name for placing in error message
1024  TYPE (fmsdiagibounds_type) :: current_bounds !< a bounding box to store the current bounds of the array.
1025 
1026  output_name = output_fields(out_num)%output_name
1027  module_name = input_fields(diag_field_id)%module_name
1028 
1029  CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer)
1030 
1031  CALL fms_diag_check_bounds_are_exact_static(current_bounds, output_fields(out_num)%buff_bounds, &
1032  & output_name, module_name, err_msg)
1033  END SUBROUTINE check_bounds_are_exact_static
1034 
1035 
1036  !> @brief Check if the array indices specified in the bounding box "current_bounds" are equal to those
1037  !! specified in the bounding box "bounds" output_fields are equal to the buffer upper and lower bounds.
1038  !! If there is an error then error message will be filled.
1039  SUBROUTINE fms_diag_check_bounds_are_exact_static(current_bounds, bounds, output_name, module_name, err_msg)
1040  TYPE (fmsdiagibounds_type), INTENT(in) :: current_bounds !<A bounding box holding the current bounds
1041  !! of the array.
1042  TYPE (fmsdiagibounds_type), INTENT(inout) :: bounds !<The bounding box to check against
1043  CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message
1044  CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message
1045  CHARACTER(len=*), INTENT(out) :: err_msg !< The return status, which is set to non-empty message
1046  !! if the check fails.
1047 
1048  CHARACTER(len=128) :: error_string1, error_string2
1049  LOGICAL :: lims_not_exact
1050 
1051  err_msg = ''
1052  lims_not_exact = compare_buffer_bounds_to_size(current_bounds, bounds, &
1053  & error_string2, a_noteq_b, a_noteq_b)
1054  IF( lims_not_exact .eqv. .true.) THEN
1055  WRITE(error_string1,'(a,"/",a)') trim(module_name), trim(output_name)
1056  err_msg = trim(error_string1)//' Bounds of data do not match those of buffer. '//trim(error_string2)
1057  END IF
1058  call bounds%reset(very_large_axis_length, 0)
1060 
1061 
1062  !> @brief Initialize the output file.
1063  SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_name, tile_count,&
1064  & new_file_freq, new_file_freq_units, start_time, file_duration, file_duration_units, filename_time_bounds)
1065  CHARACTER(len=*), INTENT(in) :: name !< File name.
1066  CHARACTER(len=*), INTENT(in) :: long_name !< Long name for time axis.
1067  INTEGER, INTENT(in) :: output_freq !< How often data is to be written to the file.
1068  INTEGER, INTENT(in) :: output_units !< The output frequency unit. (MIN, HOURS, DAYS, etc.)
1069  INTEGER, INTENT(in) :: format !< Number type/kind the data is to be written out to the file.
1070  INTEGER, INTENT(in) :: time_units !< Time axis units.
1071  INTEGER, INTENT(in) :: tile_count !< Tile number.
1072  INTEGER, INTENT(in), OPTIONAL :: new_file_freq !< How often a new file is to be created.
1073  INTEGER, INTENT(in), OPTIONAL :: new_file_freq_units !< The new file frequency unit. (MIN, HOURS, DAYS, etc.)</IN>
1074  INTEGER, INTENT(in), OPTIONAL :: file_duration !< How long file is to be used.
1075  INTEGER, INTENT(in), OPTIONAL :: file_duration_units !< File duration unit. (MIN, HOURS, DAYS, etc.)
1076  TYPE(time_type), INTENT(in), OPTIONAL :: start_time !< Time when the file is to start
1077  CHARACTER(len=*), INTENT(in), OPTIONAL :: filename_time_bounds !< Set time bound file name to
1078  ! use "begin" "middle" or "end"
1079  INTEGER :: new_file_freq1, new_file_freq_units1
1080  INTEGER :: file_duration1, file_duration_units1
1081  INTEGER :: n
1082  LOGICAL :: same_file_err !< .FALSE. indicates that if the file name had
1083  !! previously been registered, this new file
1084  !! contained differences from the previous.
1085  REAL, DIMENSION(1) :: tdata
1086  CHARACTER(len=128) :: time_units_str
1087 
1088  ! Check if this file has already been defined
1089  same_file_err=.false. ! To indicate that if this file was previously defined
1090  ! no differences in this registration was detected.
1091  DO n=1,num_files
1092  IF ( trim(files(n)%name) == trim(name) ) THEN
1093  ! File is defined, check if all inputs are the same
1094  ! Start with the required parameters
1095  IF ( files(n)%output_freq.NE.output_freq .OR.&
1096  & files(n)%output_units.NE.output_units .OR.&
1097  & files(n)%format.NE.format .OR.&
1098  & files(n)%time_units.NE.time_units .OR.&
1099  & trim(files(n)%long_name).NE.trim(long_name) .OR.&
1100  & files(n)%tile_count.NE.tile_count ) THEN
1101  same_file_err=.true.
1102  END IF
1103 
1104  ! Now check the OPTIONAL parameters
1105  IF ( PRESENT(new_file_freq) ) THEN
1106  IF ( files(n)%new_file_freq.NE.new_file_freq ) THEN
1107  same_file_err=.true.
1108  END IF
1109  END IF
1110 
1111  IF ( PRESENT(new_file_freq_units) ) THEN
1112  IF ( files(n)%new_file_freq_units.NE.new_file_freq_units ) THEN
1113  same_file_err=.true.
1114  END IF
1115  END IF
1116 
1117  IF ( PRESENT(start_time) ) THEN
1118  IF ( files(n)%start_time==start_time ) THEN
1119  same_file_err=.true.
1120  END IF
1121  END IF
1122 
1123  IF ( PRESENT(file_duration) ) THEN
1124  IF ( files(n)%duration.NE.file_duration) THEN
1125  same_file_err=.true.
1126  END IF
1127  END IF
1128 
1129  IF ( PRESENT(file_duration_units) ) THEN
1130  IF ( files(n)%duration_units.NE.file_duration_units ) THEN
1131  same_file_err=.true.
1132  END IF
1133  END IF
1134 
1135  ! If the same file was defined twice, simply return, else FATAL
1136  IF ( same_file_err ) THEN
1137  ! Something in this file is not identical to the previously defined
1138  ! file of the same name. FATAL
1139  CALL error_mesg('diag_util_mod::init_file',&
1140  & 'The file "'//trim(name)//'" is defined multiple times in&
1141  & the diag_table.', fatal)
1142  ELSE
1143  ! Issue a note that the same file is defined multiple times
1144  CALL error_mesg('diag_util_mod::init_file',&
1145  & 'The file "'//trim(name)//'" is defined multiple times in&
1146  & the diag_table.', note)
1147  ! Return to the calling function
1148  RETURN
1149  END IF
1150  END IF
1151  END DO
1152 
1153  ! Get a number for this file
1154  num_files = num_files + 1
1155  IF ( num_files >= max_files ) THEN
1156  ! <ERROR STATUS="FATAL">
1157  ! max_files exceeded, increase max_files via the max_files variable
1158  ! in the namelist diag_manager_nml.
1159  ! </ERROR>
1160  CALL error_mesg('diag_util_mod::init_file',&
1161  & ' max_files exceeded, increase max_files via the max_files variable&
1162  & in the namelist diag_manager_nml.', fatal)
1163  END IF
1164 
1165  IF ( PRESENT(new_file_freq) ) THEN
1166  new_file_freq1 = new_file_freq
1167  ELSE
1168  new_file_freq1 = very_large_file_freq
1169  END IF
1170 
1171  IF ( PRESENT(new_file_freq_units) ) THEN
1172  new_file_freq_units1 = new_file_freq_units
1173  ELSE IF ( get_calendar_type() == no_calendar ) THEN
1174  new_file_freq_units1 = diag_days
1175  ELSE
1176  new_file_freq_units1 = diag_years
1177  END IF
1178 
1179  IF ( PRESENT(file_duration) ) THEN
1180  file_duration1 = file_duration
1181  ELSE
1182  file_duration1 = new_file_freq1
1183  END IF
1184 
1185  IF ( PRESENT(file_duration_units) ) THEN
1186  file_duration_units1 = file_duration_units
1187  ELSE
1188  file_duration_units1 = new_file_freq_units1
1189  END IF
1190 
1191  files(num_files)%tile_count = tile_count
1192  files(num_files)%name = trim(name)
1193  files(num_files)%output_freq = output_freq
1194  files(num_files)%output_units = output_units
1195  files(num_files)%format = FORMAT
1196  files(num_files)%time_units = time_units
1197  files(num_files)%long_name = trim(long_name)
1198  files(num_files)%num_fields = 0
1199  files(num_files)%local = .false.
1200  files(num_files)%last_flush = get_base_time()
1201  files(num_files)%file_unit = -1
1202  files(num_files)%new_file_freq = new_file_freq1
1203  files(num_files)%new_file_freq_units = new_file_freq_units1
1204  files(num_files)%duration = file_duration1
1205  files(num_files)%duration_units = file_duration_units1
1206 !> Initialize the times to 0
1207  files(num_files)%rtime_current = -1.0
1208  files(num_files)%time_index = 0
1209  files(num_files)%filename_time_bounds = filename_time_bounds
1210 
1211  IF ( PRESENT(start_time) ) THEN
1212  files(num_files)%start_time = start_time
1213  ELSE
1214  files(num_files)%start_time = get_base_time()
1215  END IF
1216  files(num_files)%next_open=diag_time_inc(files(num_files)%start_time,new_file_freq1,new_file_freq_units1)
1217  files(num_files)%close_time = diag_time_inc(files(num_files)%start_time,file_duration1, file_duration_units1)
1218  IF ( files(num_files)%close_time>files(num_files)%next_open ) THEN
1219  ! <ERROR STATUS="FATAL">
1220  ! close time GREATER than next_open time, check file duration,
1221  ! file frequency in <files(num_files)%name>
1222  ! </ERROR>
1223  CALL error_mesg('diag_util_mod::init_file', 'close time GREATER than next_open time, check file duration,&
1224  & file frequency in '//files(num_files)%name, fatal)
1225  END IF
1226 
1227  ! add time_axis_id and time_bounds_id here
1228  WRITE(time_units_str, 11) trim(time_unit_list(files(num_files)%time_units)), get_base_year(),&
1229  & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_base_second()
1230 11 FORMAT(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
1231  files(num_files)%time_axis_id = diag_axis_init(trim(long_name), tdata, time_units_str, 'T',&
1232  & trim(long_name) , set_name=trim(name) )
1233  !---- register axis for storing time boundaries
1234  files(num_files)%time_bounds_id = diag_axis_init( 'nv',(/1.,2./),'none','N','vertex number',&
1235  & set_name='nv')
1236  END SUBROUTINE init_file
1237 
1238  !> @brief Synchronize the file's start and close times with the model start and end times.
1239  !! @details <TT>sync_file_times</TT> checks to see if the file start time is less than the
1240  !! model's init time (passed in as the only argument). If it is less, then the
1241  !! both the file start time and end time are synchronized using the passed in initial time
1242  !! and the duration as calculated by the <TT>diag_time_inc</TT> function. <TT>sync_file_times</TT>
1243  !! will also increase the <TT>next_open</TT> until it is greater than the init_time.
1244  SUBROUTINE sync_file_times(file_id, init_time, err_msg)
1245  INTEGER, INTENT(in) :: file_id !< The file ID
1246  TYPE(time_type), INTENT(in) :: init_time !< Initial time use for the synchronization.
1247  CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Return error message
1248 
1249  CHARACTER(len=128) :: msg
1250 
1251  IF ( PRESENT(err_msg) ) err_msg = ''
1252 
1253  IF ( files(file_id)%start_time < init_time ) THEN
1254  ! Sync the start_time of the file with the initial time of the model
1255  files(file_id)%start_time = init_time
1256  ! Sync the file's close time also
1257  files(file_id)%close_time = diag_time_inc(files(file_id)%start_time,&
1258  & files(file_id)%duration, files(file_id)%duration_units)
1259  END IF
1260 
1261  ! Need to increase next_open until it is greate than init_time
1262  DO WHILE ( files(file_id)%next_open <= init_time )
1263  files(file_id)%next_open = diag_time_inc(files(file_id)%next_open,&
1264  & files(file_id)%new_file_freq, files(file_id)%new_file_freq_units, err_msg=msg)
1265  IF ( msg /= '' ) THEN
1266  IF ( fms_error_handler('diag_util_mod::sync_file_times',&
1267  & ' file='//trim(files(file_id)%name)//': '//trim(msg), err_msg) ) RETURN
1268  END IF
1269  END DO
1270  END SUBROUTINE sync_file_times
1271 
1272  !> @brief Return the file number for file name and tile.
1273  !! @return Integer find_file
1274  INTEGER FUNCTION find_file(name, tile_count)
1275  INTEGER, INTENT(in) :: tile_count !< Tile number.
1276  CHARACTER(len=*), INTENT(in) :: name !< File name.
1277 
1278  INTEGER :: i
1279 
1280  find_file = -1
1281  DO i = 1, num_files
1282  IF( trim(files(i)%name) == trim(name) .AND. tile_count == files(i)%tile_count ) THEN
1283  find_file = i
1284  RETURN
1285  END IF
1286  END DO
1287  END FUNCTION find_file
1288 
1289  !> @brief Return the field number for the given module name, field name, and tile number.
1290  !! @return Integer find_input_field
1291  INTEGER FUNCTION find_input_field(module_name, field_name, tile_count)
1292  CHARACTER(len=*), INTENT(in) :: module_name !< Module name.
1293  CHARACTER(len=*), INTENT(in) :: field_name !< field name.
1294  INTEGER, INTENT(in) :: tile_count !< Tile number.
1295 
1296  INTEGER :: i
1297 
1298  find_input_field = diag_field_not_found ! Default return value if not found.
1299  DO i = 1, num_input_fields
1300  IF(tile_count == input_fields(i)%tile_count .AND.&
1301  & trim(input_fields(i)%module_name) == trim(module_name) .AND.&
1302  & lowercase(trim(input_fields(i)%field_name)) == lowercase(trim(field_name))) THEN
1303  find_input_field = i
1304  RETURN
1305  END IF
1306  END DO
1307  END FUNCTION find_input_field
1308 
1309  !> @brief Initialize the input field.
1310  SUBROUTINE init_input_field(module_name, field_name, tile_count)
1311  CHARACTER(len=*), INTENT(in) :: module_name !< Module name.
1312  CHARACTER(len=*), INTENT(in) :: field_name !< Input field name.
1313  INTEGER, INTENT(in) :: tile_count !< Tile number.
1314 
1315  ! Get a number for this input_field if not already set up
1316  IF ( find_input_field(module_name, field_name, tile_count) < 0 ) THEN
1317  num_input_fields = num_input_fields + 1
1318  IF ( num_input_fields > max_input_fields ) THEN
1319  ! <ERROR STATUS="FATAL">max_input_fields exceeded, increase it via diag_manager_nml</ERROR>
1320  CALL error_mesg('diag_util_mod::init_input_field',&
1321  & 'max_input_fields exceeded, increase it via diag_manager_nml', fatal)
1322  END IF
1323  ELSE
1324  ! If this is already initialized do not need to do anything
1325  RETURN
1326  END IF
1327 
1328  input_fields(num_input_fields)%module_name = trim(module_name)
1329  input_fields(num_input_fields)%field_name = trim(field_name)
1330  input_fields(num_input_fields)%num_output_fields = 0
1331  ! Set flag that this field has not been registered
1332  input_fields(num_input_fields)%register = .false.
1333  input_fields(num_input_fields)%local = .false.
1334  input_fields(num_input_fields)%standard_name = 'none'
1335  input_fields(num_input_fields)%tile_count = tile_count
1336  input_fields(num_input_fields)%numthreads = 1
1337  input_fields(num_input_fields)%active_omp_level = 0
1338  input_fields(num_input_fields)%time = time_zero
1339  END SUBROUTINE init_input_field
1340 
1341  !> @brief Initialize the output field.
1342  SUBROUTINE init_output_field(module_name, field_name, output_name, output_file,&
1343  & time_method, pack, tile_count, local_coord)
1344  CHARACTER(len=*), INTENT(in) :: module_name !< Module name.
1345  CHARACTER(len=*), INTENT(in) :: field_name !< Output field name.
1346  CHARACTER(len=*), INTENT(in) :: output_name !< Output name written to file.
1347  CHARACTER(len=*), INTENT(in) :: output_file !< File where field should be written.
1348  CHARACTER(len=*), INTENT(in) :: time_method !< Data reduction method.
1349  !! See <LINK SRC="diag_manager.html">diag_manager_mod</LINK>
1350  !! for valid methods.</IN>
1351  INTEGER, INTENT(in) :: pack !< Packing method.
1352  INTEGER, INTENT(in) :: tile_count !< Tile number.
1353  TYPE(coord_type), INTENT(in), OPTIONAL :: local_coord !< Region to be written.
1354  !! If missing, then all data to be written.</IN>
1355  INTEGER :: out_num, in_num, file_num, file_num_tile1
1356  INTEGER :: num_fields, i, method_selected, l1
1357  INTEGER :: ioerror
1358  REAL :: pow_value
1359  INTEGER :: grv !< Value used to determine if the region defined in the diag_table is for the whole
1360  !! axis, or a sub-axis
1361  CHARACTER(len=128) :: error_msg
1362  CHARACTER(len=50) :: t_method
1363  character(len=256) :: tmp_name
1364 
1365  ! Value to use to determine if a region is to be output on the full axis, or sub-axis
1366  ! get the value to compare to determine if writing full axis data
1367  IF ( region_out_use_alt_value ) THEN
1368  grv = glo_reg_val_alt
1369  ELSE
1370  grv = glo_reg_val
1371  END IF
1372 
1373 
1374  ! Get a number for this output field
1375  num_output_fields = num_output_fields + 1
1376  IF ( num_output_fields > max_output_fields ) THEN
1377  ! <ERROR STATUS="FATAL">max_output_fields = <max_output_fields> exceeded. Increase via diag_manager_nml</ERROR>
1378  WRITE (unit=error_msg,fmt=*) max_output_fields
1379  CALL error_mesg('diag_util_mod::init_output_field', 'max_output_fields = '//trim(error_msg)//' exceeded.&
1380  & Increase via diag_manager_nml', fatal)
1381  END IF
1382  out_num = num_output_fields
1383 
1384  ! First, find the index to the associated input field
1385  in_num = find_input_field(module_name, field_name, tile_count)
1386  IF ( in_num < 0 ) THEN
1387  IF ( tile_count > 1 ) THEN
1388  WRITE (error_msg,'(A,"/",A,"/",A)') trim(module_name),trim(field_name),&
1389  & "tile_count="//trim(string(tile_count))
1390  ELSE
1391  WRITE (error_msg,'(A,"/",A)') trim(module_name),trim(field_name)
1392  END IF
1393  ! <ERROR STATUS="FATAL">module_name/field_name <module_name>/<field_name>[/tile_count=<tile_count>]
1394  ! NOT registered</ERROR>
1395  CALL error_mesg('diag_util_mod::init_output_field',&
1396  & 'module_name/field_name '//trim(error_msg)//' NOT registered', fatal)
1397  END IF
1398 
1399  ! Add this output field into the list for this input field
1400  input_fields(in_num)%num_output_fields =&
1401  & input_fields(in_num)%num_output_fields + 1
1402  IF ( input_fields(in_num)%num_output_fields > max_out_per_in_field ) THEN
1403  ! <ERROR STATUS="FATAL">
1404  ! MAX_OUT_PER_IN_FIELD = <MAX_OUT_PER_IN_FIELD> exceeded for <module_name>/<field_name>,
1405  ! increase MAX_OUT_PER_IN_FIELD
1406  ! in the diag_manager_nml namelist.
1407  ! </ERROR>
1408  WRITE (unit=error_msg,fmt=*) max_out_per_in_field
1409  CALL error_mesg('diag_util_mod::init_output_field',&
1410  & 'MAX_OUT_PER_IN_FIELD exceeded for '//trim(module_name)//"/"//trim(field_name)//&
1411  &', increase MAX_OUT_PER_IN_FIELD in the diag_manager_nml namelist', fatal)
1412  END IF
1413  input_fields(in_num)%output_fields(input_fields(in_num)%num_output_fields) = out_num
1414 
1415  ! Also put pointer to input field in this output field
1416  output_fields(out_num)%input_field = in_num
1417 
1418  ! Next, find the number for the corresponding file
1419  IF ( trim(output_file).EQ.'null' ) THEN
1420  file_num = max_files
1421  ELSE
1422  file_num = find_file(output_file, 1)
1423  IF ( file_num < 0 ) THEN
1424  ! <ERROR STATUS="FATAL">
1425  ! file <file_name> is NOT found in the diag_table.
1426  ! </ERROR>
1427  CALL error_mesg('diag_util_mod::init_output_field', 'file '&
1428  & //trim(output_file)//' is NOT found in the diag_table', fatal)
1429  END IF
1430  IF ( tile_count > 1 ) THEN
1431  file_num_tile1 = file_num
1432  file_num = find_file(output_file, tile_count)
1433  IF(file_num < 0) THEN
1434  CALL init_file(files(file_num_tile1)%name, files(file_num_tile1)%output_freq,&
1435  & files(file_num_tile1)%output_units, files(file_num_tile1)%format,&
1436  & files(file_num_tile1)%time_units, files(file_num_tile1)%long_name,&
1437  & tile_count, files(file_num_tile1)%new_file_freq,&
1438  & files(file_num_tile1)%new_file_freq_units, files(file_num_tile1)%start_time,&
1439  & files(file_num_tile1)%duration, files(file_num_tile1)%duration_units )
1440  file_num = find_file(output_file, tile_count)
1441  IF ( file_num < 0 ) THEN
1442  ! <ERROR STATUS="FATAL">
1443  ! file <output_file> is not initialized for tile_count = <tile_count>
1444  ! </ERROR>
1445  CALL error_mesg('diag_util_mod::init_output_field', 'file '//trim(output_file)//&
1446  & ' is not initialized for tile_count = '//trim(string(tile_count)), fatal)
1447  END IF
1448  END IF
1449  END IF
1450  END IF
1451 
1452  ! Insert this field into list for this file
1453  files(file_num)%num_fields = files(file_num)%num_fields + 1
1454  IF ( files(file_num)%num_fields > max_fields_per_file ) THEN
1455  WRITE (unit=error_msg, fmt=*) max_fields_per_file
1456  ! <ERROR STATUS="FATAL">
1457  ! MAX_FIELDS_PER_FILE = <MAX_FIELDS_PER_FILE> exceeded. Increase MAX_FIELDS_PER_FILE in diag_data.F90.
1458  ! </ERROR>
1459  CALL error_mesg('diag_util_mod::init_output_field',&
1460  & 'MAX_FIELDS_PER_FILE = '//trim(error_msg)// &
1461  & ' exceeded. Increase MAX_FIELDS_PER_FILE in diag_data.F90.', fatal)
1462  END IF
1463  num_fields = files(file_num)%num_fields
1464  files(file_num)%fields(num_fields) = out_num
1465 
1466  ! Set the file for this output field
1467  output_fields(out_num)%output_file = file_num
1468 
1469  ! Enter the other data for this output field
1470  output_fields(out_num)%output_name = trim(output_name)
1471  output_fields(out_num)%pack = pack
1472  output_fields(out_num)%pow_value = 1
1473  output_fields(out_num)%num_axes = 0
1474  output_fields(out_num)%total_elements = 0
1475  output_fields(out_num)%region_elements = 0
1476 
1477  call output_fields(out_num)%buff_bounds%reset(very_large_axis_length, 0)
1478 
1479  ! initialize the size of the diurnal axis to 1
1480  output_fields(out_num)%n_diurnal_samples = 1
1481 
1482  ! Initialize all time method to false
1483  method_selected = 0
1484  output_fields(out_num)%time_average = .false.
1485  output_fields(out_num)%time_rms = .false.
1486  output_fields(out_num)%time_min = .false.
1487  output_fields(out_num)%time_max = .false.
1488  output_fields(out_num)%time_sum = .false.
1489  output_fields(out_num)%time_ops = .false.
1490  output_fields(out_num)%written_once = .false.
1491 
1492  t_method = lowercase(time_method)
1493  ! cannot time average fields output every time
1494  IF ( files(file_num)%output_freq == every_time ) THEN
1495  output_fields(out_num)%time_average = .false.
1496  method_selected = method_selected+1
1497  t_method = 'point'
1498  ELSEIF ( index(t_method,'diurnal') == 1 ) THEN
1499  ! get the integer number from the t_method
1500  READ (unit=t_method(8:len_trim(t_method)), fmt=*, iostat=ioerror) output_fields(out_num)%n_diurnal_samples
1501  IF ( ioerror /= 0 ) THEN
1502  ! <ERROR STATUS="FATAL">
1503  ! could not find integer number of diurnal samples in string "<t_method>"
1504  ! </ERROR>
1505  CALL error_mesg('diag_util_mod::init_output_field',&
1506  & 'could not find integer number of diurnal samples in string "' //trim(t_method)//'"', fatal)
1507  ELSE IF ( output_fields(out_num)%n_diurnal_samples <= 0 ) THEN
1508  ! <ERROR STATUS="FATAL">
1509  ! The integer value of diurnal samples must be greater than zero.
1510  ! </ERROR>
1511  CALL error_mesg('diag_util_mod::init_output_field',&
1512  & 'The integer value of diurnal samples must be greater than zero.', fatal)
1513  END IF
1514  output_fields(out_num)%time_average = .true.
1515  method_selected = method_selected+1
1516  t_method='mean'
1517  ELSEIF ( index(t_method,'pow') == 1 ) THEN
1518  ! Get the integer number from the t_method
1519  READ (unit=t_method(4:len_trim(t_method)), fmt=*, iostat=ioerror) pow_value
1520  IF ( ioerror /= 0 .OR. output_fields(out_num)%pow_value < 1 .OR. floor(pow_value) /= ceiling(pow_value) ) THEN
1521  ! <ERROR STATUS="FATAL">
1522  ! Invalid power number in time operation "<t_method>". Must be a positive integer.
1523  ! </ERROR>
1524  CALL error_mesg('diag_util_mod::init_output_field',&
1525  & 'Invalid power number in time operation "'//trim(t_method)//'". Must be a positive integer', fatal)
1526  END IF
1527  output_fields(out_num)%pow_value = int(pow_value)
1528  output_fields(out_num)%time_average = .true.
1529  method_selected = method_selected+1
1530  t_method = 'mean_pow('//t_method(4:len_trim(t_method))//')'
1531  ELSE
1532  SELECT CASE(trim(t_method))
1533  CASE ( '.true.', 'mean', 'average', 'avg' )
1534  output_fields(out_num)%time_average = .true.
1535  method_selected = method_selected+1
1536  t_method = 'mean'
1537  CASE ( 'rms' )
1538  output_fields(out_num)%time_average = .true.
1539  output_fields(out_num)%time_rms = .true.
1540  output_fields(out_num)%pow_value = 2.0
1541  method_selected = method_selected+1
1542  t_method = 'root_mean_square'
1543  CASE ( '.false.', 'none', 'point' )
1544  output_fields(out_num)%time_average = .false.
1545  method_selected = method_selected+1
1546  t_method = 'point'
1547  CASE ( 'maximum', 'max' )
1548  output_fields(out_num)%time_max = .true.
1549  l1 = len_trim(output_fields(out_num)%output_name)
1550  if (l1 .ge. 3) then
1551  tmp_name = trim(adjustl(output_fields(out_num)%output_name(l1-2:l1)))
1552  IF (lowercase(trim(tmp_name)) /= 'max' ) then
1553  output_fields(out_num)%output_name = trim(output_name)//'_max'
1554  endif
1555  endif
1556  method_selected = method_selected+1
1557  t_method = 'max'
1558  CASE ( 'minimum', 'min' )
1559  output_fields(out_num)%time_min = .true.
1560  l1 = len_trim(output_fields(out_num)%output_name)
1561  if (l1 .ge. 3) then
1562  tmp_name = trim(adjustl(output_fields(out_num)%output_name(l1-2:l1)))
1563  IF (lowercase(trim(tmp_name)) /= 'min' ) then
1564  output_fields(out_num)%output_name = trim(output_name)//'_min'
1565  endif
1566  endif
1567  method_selected = method_selected+1
1568  t_method = 'min'
1569  CASE ( 'sum', 'cumsum' )
1570  output_fields(out_num)%time_sum = .true.
1571  l1 = len_trim(output_fields(out_num)%output_name)
1572  IF ( output_fields(out_num)%output_name(l1-2:l1) /= 'sum' )&
1573  & output_fields(out_num)%output_name = trim(output_name)//'_sum'
1574  method_selected = method_selected+1
1575  t_method = 'sum'
1576  END SELECT
1577  END IF
1578 
1579  ! reconcile logical flags
1580  output_fields(out_num)%time_ops = output_fields(out_num)%time_min.OR.output_fields(out_num)%time_max&
1581  & .OR.output_fields(out_num)%time_average .OR. output_fields(out_num)%time_sum
1582 
1583  output_fields(out_num)%phys_window = .false.
1584  ! need to initialize grid_type = -1(start, end, l_start_indx,l_end_indx etc...)
1585  IF ( PRESENT(local_coord) ) THEN
1586  input_fields(in_num)%local = .true.
1587  input_fields(in_num)%local_coord = local_coord
1588  IF ( int(local_coord%xbegin) == grv .AND. int(local_coord%xend) == grv .AND.&
1589  & int(local_coord%ybegin) == grv .AND. int(local_coord%yend) == grv ) THEN
1590  output_fields(out_num)%local_output = .false.
1591  output_fields(out_num)%need_compute = .false.
1592  output_fields(out_num)%reduced_k_range = .true.
1593  ELSE
1594  output_fields(out_num)%local_output = .true.
1595  output_fields(out_num)%need_compute = .false.
1596  output_fields(out_num)%reduced_k_range = .false.
1597  END IF
1598 
1599  output_fields(out_num)%output_grid%start(1) = local_coord%xbegin
1600  output_fields(out_num)%output_grid%start(2) = local_coord%ybegin
1601  output_fields(out_num)%output_grid%start(3) = local_coord%zbegin
1602  output_fields(out_num)%output_grid%end(1) = local_coord%xend
1603  output_fields(out_num)%output_grid%end(2) = local_coord%yend
1604  output_fields(out_num)%output_grid%end(3) = local_coord%zend
1605  DO i = 1, 3
1606  output_fields(out_num)%output_grid%l_start_indx(i) = -1
1607  output_fields(out_num)%output_grid%l_end_indx(i) = -1
1608  output_fields(out_num)%output_grid%subaxes(i) = -1
1609  END DO
1610  ELSE
1611  output_fields(out_num)%local_output = .false.
1612  output_fields(out_num)%need_compute = .false.
1613  output_fields(out_num)%reduced_k_range = .false.
1614  END IF
1615 
1616  ! <ERROR STATUS="FATAL">
1617  ! improper time method in diag_table for output field <output_name>
1618  ! </ERROR>
1619  IF ( method_selected /= 1 ) CALL error_mesg('diag_util_mod::init_output_field',&
1620  &'improper time method in diag_table for output field:'//trim(output_name),fatal)
1621 
1622  output_fields(out_num)%time_method = trim(t_method)
1623 
1624  ! allocate counters: NOTE that for simplicity we always allocate them, even
1625  ! if they are superceeded by 4D "counter" array. This isn't most memory
1626  ! efficient, approach, but probably tolerable since they are so small anyway
1627  ALLOCATE(output_fields(out_num)%count_0d(output_fields(out_num)%n_diurnal_samples))
1628  ALLOCATE(output_fields(out_num)%num_elements(output_fields(out_num)%n_diurnal_samples))
1629  output_fields(out_num)%count_0d(:) = 0
1630  output_fields(out_num)%num_elements(:) = 0
1631  output_fields(out_num)%num_attributes = 0
1632  END SUBROUTINE init_output_field
1633 
1634  !> @brief Open file for output, and write the meta data.
1635  SUBROUTINE opening_file(file, time, filename_time)
1636  ! WARNING: Assumes that all data structures are fully initialized
1637  INTEGER, INTENT(in) :: file !< File ID.
1638  TYPE(time_type), INTENT(in) :: time !< Time for the file time stamp
1639  TYPE(time_type), INTENT(in), optional :: filename_time !< Time used in setting the filename when
1640  !! writting periodic files
1641 
1642  TYPE(time_type) :: fname_time !< Time used in setting the filename when writting periodic files
1643  REAL, DIMENSION(2) :: open_file_data
1644  INTEGER :: j, field_num, input_field_num, num_axes, k
1645  INTEGER :: field_num1
1646  INTEGER :: position
1647  INTEGER :: dir, edges
1648  INTEGER :: year, month, day, hour, minute, second
1649  INTEGER, DIMENSION(1) :: time_axis_id, time_bounds_id
1650  ! size of this axes array must be at least max num. of
1651  ! axes per field + 2; the last two elements are for time
1652  ! and time bounds dimensions
1653  INTEGER, DIMENSION(6) :: axes
1654  INTEGER, ALLOCATABLE :: axesc(:) ! indices if compressed axes associated with the field
1655  LOGICAL :: time_ops, aux_present, match_aux_name, req_present, match_req_fields
1656  CHARACTER(len=7) :: avg_name = 'average'
1657  CHARACTER(len=128) :: time_units, timeb_units, avg, error_string, filename, aux_name, req_fields, fieldname
1658  CHARACTER(len=128) :: suffix, base_name
1659  CHARACTER(len=32) :: time_name, timeb_name,time_longname, timeb_longname, cart_name
1660  CHARACTER(len=256) :: fname
1661  CHARACTER(len=24) :: start_date
1662  TYPE(domain1d) :: domain
1663  TYPE(domain2d) :: domain2
1664  TYPE(domainug) :: domainU
1665  INTEGER :: is, ie, last, ind
1666  class(fmsnetcdffile_t), pointer :: fileob
1667  integer :: actual_num_axes !< The actual number of axes to write including time
1668 
1669  aux_present = .false.
1670  match_aux_name = .false.
1671  req_present = .false.
1672  match_req_fields = .false.
1673 
1674  ! Here is where time_units string must be set up; time since base date
1675  WRITE (time_units, 11) trim(time_unit_list(files(file)%time_units)), get_base_year(),&
1676  & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_base_second()
1677 11 FORMAT(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
1678  base_name = files(file)%name
1679  IF ( files(file)%new_file_freq < very_large_file_freq ) THEN
1680  position = index(files(file)%name, '%')
1681  IF ( position > 0 ) THEN
1682  base_name = base_name(1:position-1)
1683  ELSE
1684  ! <ERROR STATUS="FATAL">
1685  ! filename <files(file)%name> does not contain % for time stamp string
1686  ! </ERROR>
1687  CALL error_mesg('diag_util_mod::opening_file',&
1688  & 'file name '//trim(files(file)%name)//' does not contain % for time stamp string', fatal)
1689  END IF
1690  if (present(filename_time)) then
1691  fname_time = filename_time
1692  else
1693  fname_time = time
1694  endif
1695  suffix = get_time_string(files(file)%name, fname_time)
1696  ELSE
1697  suffix = ' '
1698  END IF
1699 
1700  ! Add ensemble ID to filename
1701  fname=base_name
1702  call get_instance_filename(fname, base_name)
1703 
1704  ! Set the filename
1705  filename = trim(base_name)//trim(suffix)
1706 
1707  ! prepend the file start date if prepend_date == .TRUE.
1708  IF ( prepend_date ) THEN
1709  call get_date(diag_init_time, year, month, day, hour, minute, second)
1710  write (start_date, '(1I20.4, 2I2.2)') year, month, day
1711 
1712  filename = trim(adjustl(start_date))//'.'//trim(filename)
1713  END IF
1714 
1715  ! Loop through all fields with this file to output axes
1716  ! JWD: This is a klooge; need something more robust
1717  domain2 = null_domain2d
1718  domainu = null_domainug
1719  DO j = 1, files(file)%num_fields
1720  field_num = files(file)%fields(j)
1721  if (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) cycle
1722  num_axes = output_fields(field_num)%num_axes
1723  IF ( num_axes > 1 ) THEN
1724  domain2 = get_domain2d( output_fields(field_num)%axes(1:num_axes) )
1725  domainu = get_domainug( output_fields(field_num)%axes(1) )
1726  IF ( domain2 .NE. null_domain2d ) EXIT
1727  ELSEIF (num_axes == 1) THEN
1728  if (domainu .EQ. null_domainug) then
1729  domainu = get_domainug( output_fields(field_num)%axes(num_axes) )
1730  endif
1731  END IF
1732  END DO
1733 
1734  IF (domainu .NE. null_domainug .AND. domain2 .NE. null_domain2d) THEN
1735  CALL error_mesg('diag_util_mod::opening_file', &
1736  'Domain2 and DomainU are somehow both set.', &
1737  fatal)
1738  ENDIF
1739 
1740  IF ( allocated(files(file)%attributes) ) THEN
1741  CALL diag_output_init(filename, global_descriptor,&
1742  & files(file)%file_unit, domain2, domainu,&
1743  & fileobj(file),fileobju(file), fileobjnd(file), fnum_for_domain(file),&
1744  & attributes=files(file)%attributes(1:files(file)%num_attributes))
1745  ELSE
1746  CALL diag_output_init(filename, global_descriptor,&
1747  & files(file)%file_unit, domain2,domainu, &
1748  & fileobj(file),fileobju(file),fileobjnd(file),fnum_for_domain(file))
1749  END IF
1750  !> update fnum_for_domain with the correct domain
1751  files(file)%bytes_written = 0
1752  ! Does this file contain time_average fields?
1753  time_ops = .false.
1754  DO j = 1, files(file)%num_fields
1755  field_num = files(file)%fields(j)
1756  IF ( output_fields(field_num)%time_ops ) THEN
1757  time_ops = .true.
1758  EXIT
1759  END IF
1760  END DO
1761  ! Loop through all fields with this file to output axes
1762  DO j = 1, files(file)%num_fields
1763  field_num = files(file)%fields(j)
1764  input_field_num = output_fields(field_num)%input_field
1765  IF (.NOT.input_fields(input_field_num)%register) THEN
1766  WRITE (error_string,'(A,"/",A)') trim(input_fields(input_field_num)%module_name),&
1767  & trim(input_fields(input_field_num)%field_name)
1768  IF(mpp_pe() .EQ. mpp_root_pe()) THEN
1769  CALL error_mesg('diag_util_mod::opening_file',&
1770  & 'module/field_name ('//trim(error_string)//') NOT registered', warning)
1771  END IF
1772  cycle
1773  END IF
1774  if (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) cycle
1775 
1776  ! Put the time axis in the axis field
1777  num_axes = output_fields(field_num)%num_axes
1778  axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
1779  ! make sure that axis_id are not -1
1780  DO k = 1, num_axes
1781  IF ( axes(k) < 0 ) THEN
1782  WRITE(error_string,'(a)') output_fields(field_num)%output_name
1783  ! <ERROR STATUS="FATAL">
1784  ! ouptut_name <output_fields(field_num)%output_name> has axis_id = -1
1785  ! </ERROR>
1786  CALL error_mesg('diag_util_mod::opening_file','output_name '//trim(error_string)//&
1787  & ' has axis_id = -1', fatal)
1788  END IF
1789  END DO
1790  ! check if aux is present in any axes
1791  IF ( .NOT.aux_present ) THEN
1792  DO k = 1, num_axes
1793  aux_name = get_axis_aux(axes(k))
1794  IF ( trim(aux_name) /= 'none' ) THEN
1795  aux_present = .true.
1796  EXIT
1797  END IF
1798  END DO
1799  END IF
1800  ! check if required fields are present in any axes
1801  IF ( .NOT.req_present ) THEN
1802  DO k = 1, num_axes
1803  req_fields = get_axis_reqfld(axes(k))
1804  IF ( trim(req_fields) /= 'none' ) THEN
1805  CALL error_mesg('diag_util_mod::opening_file','required fields found: '//&
1806  &trim(req_fields)//' in file '//trim(files(file)%name),note)
1807  req_present = .true.
1808  EXIT
1809  END IF
1810  END DO
1811  END IF
1812 
1813  axes(num_axes + 1) = files(file)%time_axis_id
1814 !> Allocate the is_time_axis_registered field and set it to false for the first trip
1815  if (.not. allocated(files(file)%is_time_axis_registered)) then
1816  allocate(files(file)%is_time_axis_registered)
1817  files(file)%is_time_axis_registered = .false.
1818  endif
1819  if (time_ops) then
1820  !< If the file contains time_average fields write the "time" and "nv" dimension
1821  actual_num_axes = num_axes + 2
1822  axes(num_axes + 2) = files(file)%time_bounds_id
1823  else
1824  !< If the file doesn't contain time_average fields write the "time" dimension
1825  actual_num_axes = num_axes + 1
1826  endif
1827 
1828  if (fnum_for_domain(file) == "2d") then
1829  CALL write_axis_meta_data(files(file)%file_unit, axes(1:actual_num_axes),fileobj(file), time_ops=time_ops, &
1830  time_axis_registered=files(file)%is_time_axis_registered)
1831  elseif (fnum_for_domain(file) == "nd") then
1832  CALL write_axis_meta_data(files(file)%file_unit, axes(1:actual_num_axes),fileobjnd(file), time_ops=time_ops,&
1833  time_axis_registered=files(file)%is_time_axis_registered)
1834  elseif (fnum_for_domain(file) == "ug") then
1835  CALL write_axis_meta_data(files(file)%file_unit, axes(1:actual_num_axes),fileobju(file), time_ops=time_ops, &
1836  time_axis_registered=files(file)%is_time_axis_registered)
1837  endif
1838 
1839  ! write metadata for axes used in compression-by-gathering, e.g. for unstructured
1840  ! grid
1841  DO k = 1, num_axes
1842  IF (axis_is_compressed(axes(k))) THEN
1843  CALL get_compressed_axes_ids(axes(k), axesc) ! returns allocatable array
1844  if (fnum_for_domain(file) == "ug") then
1845  CALL write_axis_meta_data(files(file)%file_unit, axesc,fileobju(file), &
1846  time_axis_registered=files(file)%is_time_axis_registered)
1847  else
1848  CALL error_mesg('diag_util_mod::opening_file::'//trim(filename), "Compressed "//&
1849  "dimensions are only allowed with axis in the unstructured dimension", fatal)
1850  endif
1851  DEALLOCATE(axesc)
1852  ENDIF
1853  ENDDO
1854  END DO
1855 
1856  ! Looking for the first NON-static field in a file
1857  field_num1 = files(file)%fields(1)
1858  DO j = 1, files(file)%num_fields
1859  field_num = files(file)%fields(j)
1860  IF ( output_fields(field_num)%time_ops ) THEN
1861  field_num1 = field_num
1862  EXIT
1863  END IF
1864  END DO
1865  nfields_loop: DO j = 1, files(file)%num_fields
1866  field_num = files(file)%fields(j)
1867  input_field_num = output_fields(field_num)%input_field
1868  IF (.NOT.input_fields(input_field_num)%register) cycle
1869  IF (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) cycle
1870  ! Make sure that 1 file contains either time_average or instantaneous fields
1871  ! cannot have both time_average and instantaneous in 1 file
1872  IF ( .NOT.mix_snapshot_average_fields ) THEN
1873  IF ( (output_fields(field_num)%time_ops.NEQV.output_fields(field_num1)%time_ops) .AND.&
1874  & .NOT.output_fields(field_num1)%static .AND. .NOT.output_fields(field_num)%static) THEN
1875  IF ( mpp_pe() == mpp_root_pe() ) THEN
1876  ! <ERROR STATUS="FATAL">
1877  ! <files(file)%name> can NOT have BOTH time average AND instantaneous fields.
1878  ! Create a new file or set mix_snapshot_average_fields=.TRUE. in the namelist diag_manager_nml.
1879  ! </ERROR>
1880  CALL error_mesg('diag_util_mod::opening_file','file '//trim(files(file)%name)// &
1881  &' can NOT have BOTH time average AND instantaneous fields.'//&
1882  &' Create a new file or set mix_snapshot_average_fields=.TRUE. in the namelist diag_manager_nml.'&
1883  &, fatal)
1884  END IF
1885  END IF
1886  END IF
1887  ! check if any field has the same name as aux_name
1888  IF ( aux_present .AND. .NOT.match_aux_name ) THEN
1889  fieldname = output_fields(field_num)%output_name
1890  IF ( index(aux_name, trim(fieldname)) > 0 ) match_aux_name = .true.
1891  END IF
1892  ! check if any field has the same name as req_fields
1893  IF ( req_present .AND. .NOT.match_req_fields ) THEN
1894  fieldname = output_fields(field_num)%output_name
1895  is = 1; last = len_trim(req_fields)
1896  DO
1897  ind = index(req_fields(is:last),' ')
1898  IF (ind .eq. 0) ind = last-is+2
1899  ie = is+(ind-2)
1900  if (req_fields(is:ie) .EQ. trim(fieldname)) then
1901  match_req_fields = .true.
1902  !CALL error_mesg('diag_util_mod::opening_file','matched required field: '//TRIM(fieldname),NOTE)
1903  EXIT
1904  END IF
1905  is = is+ind
1906  if (is .GT. last) EXIT
1907  END DO
1908  END IF
1909 
1910  ! Put the time axis in the axis field
1911  num_axes = output_fields(field_num)%num_axes
1912  axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
1913  IF ( .NOT.output_fields(field_num)%static ) THEN
1914  num_axes=num_axes+1
1915  axes(num_axes) = files(file)%time_axis_id
1916  END IF
1917  IF(output_fields(field_num)%time_average) THEN
1918  avg = avg_name
1919  ELSE IF(output_fields(field_num)%time_max) THEN
1920  avg = avg_name
1921  ELSE IF(output_fields(field_num)%time_min) THEN
1922  avg = avg_name
1923  ELSE
1924  avg = " "
1925  END IF
1926 !> Use the correct file object
1927  if (fnum_for_domain(file) == "2d") then
1928  fileob => fileobj(file)
1929  elseif (fnum_for_domain(file) == "nd") then
1930  fileob => fileobjnd(file)
1931  elseif (fnum_for_domain(file) == "ug") then
1932  fileob => fileobju(file)
1933  endif
1934  IF ( input_fields(input_field_num)%missing_value_present ) THEN
1935  IF ( len_trim(input_fields(input_field_num)%interp_method) > 0 ) THEN
1936  output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
1937  & output_fields(field_num)%output_name, axes(1:num_axes),&
1938  & input_fields(input_field_num)%units,&
1939  & input_fields(input_field_num)%long_name,&
1940  & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
1941  & input_fields(input_field_num)%missing_value, avg_name = avg,&
1942  & time_method=output_fields(field_num)%time_method,&
1943  & standard_name = input_fields(input_field_num)%standard_name,&
1944  & interp_method = input_fields(input_field_num)%interp_method,&
1945  & attributes=output_fields(field_num)%attributes,&
1946  & num_attributes=output_fields(field_num)%num_attributes,&
1947  & use_ugdomain=files(file)%use_domainUG , &
1948  & fileob=fileob)
1949  ELSE
1950  output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
1951  & output_fields(field_num)%output_name, axes(1:num_axes),&
1952  & input_fields(input_field_num)%units,&
1953  & input_fields(input_field_num)%long_name,&
1954  & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
1955  & input_fields(input_field_num)%missing_value, avg_name = avg,&
1956  & time_method=output_fields(field_num)%time_method,&
1957  & standard_name = input_fields(input_field_num)%standard_name,&
1958  & attributes=output_fields(field_num)%attributes,&
1959  & num_attributes=output_fields(field_num)%num_attributes,&
1960  & use_ugdomain=files(file)%use_domainUG , &
1961  & fileob=fileob)
1962 
1963  END IF
1964  ! NEED TO TAKE CARE OF TIME AVERAGING INFO TOO BOTH CASES
1965  ELSE
1966  IF ( len_trim(input_fields(input_field_num)%interp_method) > 0 ) THEN
1967  output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
1968  & output_fields(field_num)%output_name, axes(1:num_axes),&
1969  & input_fields(input_field_num)%units,&
1970  & input_fields(input_field_num)%long_name,&
1971  & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
1972  & avg_name = avg,&
1973  & time_method=output_fields(field_num)%time_method,&
1974  & standard_name = input_fields(input_field_num)%standard_name,&
1975  & interp_method = input_fields(input_field_num)%interp_method,&
1976  & attributes=output_fields(field_num)%attributes,&
1977  & num_attributes=output_fields(field_num)%num_attributes,&
1978  & use_ugdomain=files(file)%use_domainUG , &
1979  & fileob=fileob)
1980 
1981  ELSE
1982  output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
1983  & output_fields(field_num)%output_name, axes(1:num_axes),&
1984  & input_fields(input_field_num)%units,&
1985  & input_fields(input_field_num)%long_name,&
1986  & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
1987  & avg_name = avg,&
1988  & time_method=output_fields(field_num)%time_method,&
1989  & standard_name = input_fields(input_field_num)%standard_name,&
1990  & attributes=output_fields(field_num)%attributes,&
1991  & num_attributes=output_fields(field_num)%num_attributes,&
1992  & use_ugdomain=files(file)%use_domainUG , &
1993  & fileob=fileob)
1994 
1995  END IF
1996  END IF
1997  END DO nfields_loop
1998  ! If any of the fields in the file are time averaged, need to output the axes
1999  ! Use double precision since time axis is double precision
2000  IF ( time_ops ) THEN
2001  time_axis_id(1) = files(file)%time_axis_id
2002  files(file)%f_avg_start = write_field_meta_data(files(file)%file_unit,&
2003  & avg_name // '_T1', time_axis_id, time_units,&
2004  & "Start time for average period", pack=pack_size , &
2005  & fileob=fileob)
2006  files(file)%f_avg_end = write_field_meta_data(files(file)%file_unit,&
2007  & avg_name // '_T2', time_axis_id, time_units,&
2008  & "End time for average period", pack=pack_size , &
2009  & fileob=fileob)
2010  files(file)%f_avg_nitems = write_field_meta_data(files(file)%file_unit,&
2011  & avg_name // '_DT', time_axis_id,&
2012  & trim(time_unit_list(files(file)%time_units)),&
2013  & "Length of average period", pack=pack_size , &
2014  & fileob=fileob)
2015  END IF
2016 
2017  IF ( time_ops ) THEN
2018  time_axis_id(1) = files(file)%time_axis_id
2019  time_bounds_id(1) = files(file)%time_bounds_id
2020  CALL get_diag_axis( time_axis_id(1), time_name, time_units, time_longname,&
2021  & cart_name, dir, edges, domain, domainu, open_file_data)
2022  CALL get_diag_axis( time_bounds_id(1), timeb_name, timeb_units, timeb_longname,&
2023  & cart_name, dir, edges, domain, domainu, open_file_data)
2024  ! CF Compliance requires the unit on the _bnds axis is the same as 'time'
2025  files(file)%f_bounds = write_field_meta_data(files(file)%file_unit,&
2026  & trim(time_name)//'_bnds', (/time_bounds_id,time_axis_id/),&
2027  & time_units, trim(time_name)//' axis boundaries', pack=pack_size , &
2028  & fileob=fileob)
2029  END IF
2030  ! Let lower levels know that all meta data has been sent
2031  call done_meta_data(files(file)%file_unit)
2032 
2033  IF( aux_present .AND. .NOT.match_aux_name ) THEN
2034  ! <ERROR STATUS="WARNING">
2035  ! one axis has auxiliary but the corresponding field is NOT
2036  ! found in file <file_name>
2037  ! </ERROR>
2038  IF ( mpp_pe() == mpp_root_pe() ) CALL error_mesg('diag_util_mod::opening_file',&
2039  &'one axis has auxiliary but the corresponding field is NOT found in file '// &
2040  & trim(files(file)%name), warning)
2041  END IF
2042  IF( req_present .AND. .NOT.match_req_fields ) THEN
2043  ! <ERROR STATUS="FATAL">
2044  ! one axis has required fields but the corresponding field is NOT
2045  ! found in file <file_name>
2046  ! </ERROR>
2047  IF ( mpp_pe() == mpp_root_pe() ) CALL error_mesg('diag_util_mod::opening_file',&
2048  &'one axis has required fields ('//trim(req_fields)//') but the '// &
2049  &'corresponding fields are NOT found in file '//trim(files(file)%name), fatal)
2050  END IF
2051  ! Clean up pointer
2052  if (associated(fileob)) nullify(fileob)
2053  END SUBROUTINE opening_file
2054 
2055  !> @brief Write data out to file, and if necessary flush the buffers.
2056  SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time)
2057  INTEGER, INTENT(in) :: file !< File ID.
2058  INTEGER, INTENT(in) :: field !< Field ID.
2059  REAL, DIMENSION(:,:,:,:), INTENT(inout) :: dat !< Data to write out.
2060  TYPE(time_type), INTENT(in) :: time !< Current model time.
2061  LOGICAL, OPTIONAL, INTENT(in):: final_call_in !< <TT>.TRUE.</TT> if this is the last write for file.
2062  LOGICAL, OPTIONAL, INTENT(in):: static_write_in !< <TT>.TRUE.</TT> if static fields are to be written to file.
2063  type(time_type), intent(in), optional :: filename_time !< Time used in setting the filename when
2064  !! writting periodic files
2065 
2066  LOGICAL :: final_call, do_write, static_write
2067  REAL :: dif, time_data(2, 1, 1, 1), dt_time(1, 1, 1, 1), start_dif, end_dif
2068  REAL :: time_in_file !< Time in file at the beginning of this call
2069 
2070  !< Save the current time in the file. If the time in the file is not the same as the
2071  !! current time, files(file)%rtime_current will be updated
2072  time_in_file = files(file)%rtime_current
2073 
2074  do_write = .true.
2075  final_call = .false.
2076  IF ( PRESENT(final_call_in) ) final_call = final_call_in
2077  static_write = .false.
2078  IF ( PRESENT(static_write_in) ) static_write = static_write_in
2079 !> dif is the time as a real that is evaluated
2080  dif = get_date_dif(time, get_base_time(), files(file)%time_units)
2081 
2082  ! get file_unit, open new file and close curent file if necessary
2083  IF ( .NOT.static_write .OR. files(file)%file_unit < 0 ) &
2084  CALL check_and_open(file, time, do_write, filename_time=filename_time)
2085  IF ( .NOT.do_write ) RETURN ! no need to write data
2086 !> Set up the time index and write the correct time value to the time array
2087  if (dif > files(file)%rtime_current) then
2088  files(file)%time_index = files(file)%time_index + 1
2089  files(file)%rtime_current = dif
2090  if (fnum_for_domain(file) == "2d") then
2091  call diag_write_time (fileobj(file), files(file)%rtime_current, files(file)%time_index, &
2092  time_name=fileobj(file)%time_name)
2093  elseif (fnum_for_domain(file) == "ug") then
2094  call diag_write_time (fileobju(file), files(file)%rtime_current, files(file)%time_index, &
2095  time_name=fileobju(file)%time_name)
2096  elseif (fnum_for_domain(file) == "nd") then
2097  call diag_write_time (fileobjnd(file), files(file)%rtime_current, files(file)%time_index, &
2098  time_name=fileobjnd(file)%time_name)
2099  else
2100  call error_mesg("diag_util_mod::diag_data_out","Error opening the file "//files(file)%name,fatal)
2101  endif
2102  elseif (dif < files(file)%rtime_current .and. .not.(static_write) ) then
2103  call error_mesg("diag_util_mod::diag_data_out","The time for the file "//trim(files(file)%name)//&
2104  " has gone backwards. There may be missing values for some of the variables",note)
2105  endif
2106 !> Write data
2107  call diag_field_write (output_fields(field)%output_name, dat, static_write, file, fileobju, &
2108  fileobj, fileobjnd, fnum_for_domain(file), time_in=files(file)%time_index)
2109  ! record number of bytes written to this file
2110  files(file)%bytes_written = files(file)%bytes_written +&
2111  & (SIZE(dat,1)*SIZE(dat,2)*SIZE(dat,3))*(8/output_fields(field)%pack)
2112  IF ( .NOT.output_fields(field)%written_once ) output_fields(field)%written_once = .true.
2113  ! *** inserted this line because start_dif < 0 for static fields ***
2114  IF ( .NOT.output_fields(field)%static ) THEN
2115  start_dif = get_date_dif(output_fields(field)%last_output, get_base_time(),files(file)%time_units)
2116  IF ( .NOT.mix_snapshot_average_fields ) THEN
2117  end_dif = get_date_dif(output_fields(field)%next_output, get_base_time(), files(file)%time_units)
2118  ELSE
2119  end_dif = dif
2120  END IF
2121  END IF
2122 
2123  if (files(file)%rtime_current > time_in_file) then !< If time was written in this call
2124  if (output_fields(field)%time_ops) then !< If this is a time_average field
2125  ! Output the axes if this is first time-averaged field
2126  time_data(1, 1, 1, 1) = start_dif
2127  call diag_field_write (files(file)%f_avg_start%fieldname, time_data(1:1,:,:,:), static_write, file, &
2128  fileobju, fileobj, fileobjnd, &
2129  fnum_for_domain(file), time_in=files(file)%time_index)
2130  time_data(2, 1, 1, 1) = end_dif
2131  call diag_field_write (files(file)%f_avg_end%fieldname, time_data(2:2,:,:,:), static_write, file, &
2132  fileobju, fileobj, fileobjnd, &
2133  fnum_for_domain(file), time_in=files(file)%time_index)
2134  ! Compute the length of the average
2135  dt_time(1, 1, 1, 1) = end_dif - start_dif
2136  call diag_field_write (files(file)%f_avg_nitems%fieldname, dt_time(1:1,:,:,:), static_write, file, &
2137  fileobju, fileobj, fileobjnd, &
2138  fnum_for_domain(file), time_in=files(file)%time_index)
2139  ! Include boundary variable for CF compliance
2140  call diag_field_write (files(file)%f_bounds%fieldname, time_data(1:2,:,:,:), static_write, file, &
2141  fileobju, fileobj, fileobjnd, &
2142  fnum_for_domain(file), time_in=files(file)%time_index)
2143  END IF
2144  END IF
2145 
2146  ! If write time is greater (equal for the last call) than last_flush for this file, flush it
2147  IF ( final_call ) THEN
2148  IF ( time >= files(file)%last_flush ) THEN
2149  files(file)%last_flush = time
2150  END IF
2151  ELSE
2152  IF ( time > files(file)%last_flush .AND. (flush_nc_files.OR.debug_diag_manager) ) THEN
2153  call diag_flush(file, fileobju, fileobj, fileobjnd, fnum_for_domain(file))
2154  files(file)%last_flush = time
2155  END IF
2156  END IF
2157  END SUBROUTINE diag_data_out
2158 
2159  !> @brief Checks if it is time to open a new file.
2160  !! @details Checks if it is time to open a new file. If yes, it first closes the
2161  !! current file, opens a new file and returns file_unit
2162  !! previous diag_manager_end is replaced by closing_file and output_setup by opening_file.
2163  SUBROUTINE check_and_open(file, time, do_write, filename_time)
2164  INTEGER, INTENT(in) :: file !<File ID.
2165  TYPE(time_type), INTENT(in) :: time !< Current model time.
2166  LOGICAL, INTENT(out) :: do_write !< <TT>.TRUE.</TT> if file is expecting more data to write,
2167  !! <TT>.FALSE.</TT> otherwise.
2168  TYPE(time_type), INTENT(in), optional :: filename_time !< Time used in setting the filename when
2169  !! writting periodic files
2170 
2171  IF ( time >= files(file)%start_time ) THEN
2172  IF ( files(file)%file_unit < 0 ) THEN ! need to open a new file
2173  CALL opening_file(file, time, filename_time=filename_time)
2174  do_write = .true.
2175  ELSE
2176  do_write = .true.
2177  IF ( time > files(file)%close_time .AND. time < files(file)%next_open ) THEN
2178  do_write = .false. ! file still open but receives NO MORE data
2179  ELSE IF ( time > files(file)%next_open ) THEN ! need to close current file and open a new one
2180  CALL write_static(file) ! write all static fields and close this file
2181  CALL opening_file(file, time, filename_time=filename_time)
2182  files(file)%time_index = 0 !< Reset the number of times in the files back to 0
2183  files(file)%start_time = files(file)%next_open
2184  files(file)%close_time =&
2185  & diag_time_inc(files(file)%start_time,files(file)%duration, files(file)%duration_units)
2186  files(file)%next_open =&
2187  & diag_time_inc(files(file)%next_open, files(file)%new_file_freq,&
2188  & files(file)%new_file_freq_units)
2189  IF ( files(file)%close_time > files(file)%next_open ) THEN
2190  ! <ERROR STATUS="FATAL">
2191  ! <file_name> has close time GREATER than next_open time,
2192  ! check file duration and frequency
2193  ! </ERROR>
2194  CALL error_mesg('diag_util_mod::check_and_open',&
2195  & files(file)%name// &
2196  & ' has close time GREATER than next_open time, check file duration and frequency',fatal)
2197  END IF
2198  END IF ! no need to open new file, simply return file_unit
2199  END IF
2200  ELSE
2201  do_write = .false.
2202  END IF
2203  END SUBROUTINE check_and_open
2204 
2205  !> @brief Output all static fields in this file
2206  SUBROUTINE write_static(file)
2207  INTEGER, INTENT(in) :: file !< File ID.
2208  INTEGER :: j, i, input_num
2209 
2210  DO j = 1, files(file)%num_fields
2211  i = files(file)%fields(j)
2212  input_num = output_fields(i)%input_field
2213  ! skip fields that were not registered
2214  IF ( .NOT.input_fields(input_num)%register ) cycle
2215  IF ( output_fields(i)%local_output .AND. .NOT. output_fields(i)%need_compute) cycle
2216  ! only output static fields here
2217  IF ( .NOT.output_fields(i)%static ) cycle
2218  CALL diag_data_out(file, i, output_fields(i)%buffer, files(file)%last_flush, .true., .true.)
2219  END DO
2220 !! New FMS_IO close
2221  ! File is stil open. This is to protect when the diag_table has no Fields
2222  ! going to this file, and it was never opened (b/c diag_data_out was not
2223  ! called)
2224  if (fnum_for_domain(file) == "2d" )then
2225  if (check_if_open(fileobj(file))) call close_file (fileobj(file) )
2226  elseif (fnum_for_domain(file) == "nd") then
2227  if (check_if_open(fileobjnd(file)) ) then
2228  call close_file (fileobjnd(file))
2229  endif
2230  elseif (fnum_for_domain(file) == "ug") then
2231  if (check_if_open(fileobju(file))) call close_file (fileobju(file))
2232  endif
2233  files(file)%file_unit = -1
2234  END SUBROUTINE write_static
2235 
2236  !> @brief Checks to see if <TT>output_name</TT> and <TT>output_file</TT> are unique in <TT>output_fields</TT>.
2237  SUBROUTINE check_duplicate_output_fields(err_msg)
2238  CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Error message. If empty, then no duplicates found.
2239 
2240  INTEGER :: i, j, tmp_file
2241  CHARACTER(len=128) :: tmp_name
2242  CHARACTER(len=256) :: err_msg_local
2243 
2244  IF ( PRESENT(err_msg) ) err_msg=''
2245  ! Do the checking when more than 1 output_fileds present
2246  IF ( num_output_fields <= 1 ) RETURN
2247  err_msg_local = ''
2248 
2249  i_loop: DO i = 1, num_output_fields-1
2250  tmp_name = trim(output_fields(i)%output_name)
2251  tmp_file = output_fields(i)%output_file
2252  DO j = i+1, num_output_fields
2253  IF ( (tmp_name == trim(output_fields(j)%output_name)) .AND. &
2254  &(tmp_file == output_fields(j)%output_file)) THEN
2255  err_msg_local = ' output_field "'//trim(tmp_name)//&
2256  &'" duplicated in file "'//trim(files(tmp_file)%name)//'"'
2257  EXIT i_loop
2258  END IF
2259  END DO
2260  END DO i_loop
2261  IF ( err_msg_local /= '' ) THEN
2262  IF ( fms_error_handler(' ERROR in diag_table',err_msg_local,err_msg) ) RETURN
2263  END IF
2264  END SUBROUTINE check_duplicate_output_fields
2265 
2266  !> @brief Allocates the atttype in out_field
2267  SUBROUTINE attribute_init_field(out_field, err_msg)
2268  TYPE(output_field_type), INTENT(inout) :: out_field !< output field to allocate memory for attribute
2269  CHARACTER(LEN=*), INTENT(out), OPTIONAL :: err_msg !< Error message, passed back to calling function
2270 
2271  INTEGER :: istat
2272 
2273  ! Need to initialize err_msg if present
2274  IF ( PRESENT(err_msg) ) err_msg = ''
2275 
2276  ! Allocate memory for the attributes
2277  IF ( .NOT.allocated(out_field%attributes) ) THEN
2278  ALLOCATE(out_field%attributes(max_field_attributes), stat=istat)
2279  IF ( istat.NE.0 ) THEN
2280  ! <ERROR STATUS="FATAL">
2281  ! Unable to allocate memory for attribute <name> to module/input_field <module_name>/<field_name>
2282  ! </ERROR>
2283  IF ( fms_error_handler('diag_util_mod::attribute_init_field',&
2284  & 'Unable to allocate memory for attributes', err_msg) ) THEN
2285  RETURN
2286  END IF
2287  ELSE
2288  ! Set equal to 0. It will be increased when attributes added
2289  out_field%num_attributes = 0
2290  END IF
2291  END IF
2292  END SUBROUTINE attribute_init_field
2293 
2294  !> @brief Prepends the attribute value to an already existing attribute. If the
2295  !! attribute isn't yet defined, then creates a new attribute
2296  SUBROUTINE prepend_attribute_field(out_field, att_name, prepend_value, err_msg)
2297  TYPE(output_field_type), INTENT(inout) :: out_field !< output field that will get the attribute
2298  CHARACTER(len=*), INTENT(in) :: att_name !< Name of the attribute
2299  CHARACTER(len=*), INTENT(in) :: prepend_value !< Value to prepend
2300  CHARACTER(len=*), INTENT(out) , OPTIONAL :: err_msg !< Error message, passed back to calling routine
2301 
2302  INTEGER :: length, i, this_attribute
2303  CHARACTER(len=512) :: err_msg_local
2304 
2305  ! Initialize string characters
2306  err_msg_local=''
2307  IF ( PRESENT(err_msg) ) err_msg = ''
2308 
2309  ! Make sure the attributes for this out field have been initialized
2310  CALL attribute_init_field(out_field, err_msg_local)
2311  IF ( trim(err_msg_local) .NE. '' ) THEN
2312  IF ( fms_error_handler('diag_util_mod::prepend_attribute_field', trim(err_msg_local), err_msg) ) THEN
2313  RETURN
2314  END IF
2315  END IF
2316 
2317  ! Find if attribute exists
2318  this_attribute = 0
2319  DO i=1, out_field%num_attributes
2320  IF ( trim(out_field%attributes(i)%name) .EQ. trim(att_name) ) THEN
2321  this_attribute = i
2322  EXIT
2323  END IF
2324  END DO
2325 
2326  IF ( this_attribute > 0 ) THEN
2327  IF ( out_field%attributes(this_attribute)%type .NE. nf90_char ) THEN
2328  ! <ERROR STATUS="FATAL">
2329  ! Attribute <name> is not a character attribute.
2330  ! </ERROR>
2331  IF ( fms_error_handler('diag_util_mod::prepend_attribute_field', &
2332  & 'Attribute "'//trim(att_name)//'" is not a character attribute.',&
2333  & err_msg) ) THEN
2334  RETURN
2335  END IF
2336  END IF
2337  ELSE
2338  ! Defining a new attribute
2339  ! Increase the number of field attributes
2340  this_attribute = out_field%num_attributes + 1
2341  IF ( this_attribute .GT. max_field_attributes ) THEN
2342  ! <ERROR STATUS="FATAL">
2343  ! Number of attributes exceeds max_field_attributes for attribute <name>.
2344  ! Increase diag_manager_nml:max_field_attributes.
2345  ! </ERROR>
2346  IF ( fms_error_handler('diag_util_mod::prepend_attribute_field',&
2347  & 'Number of attributes exceeds max_field_attributes for attribute "'&
2348  & //trim(att_name)//'". Increase diag_manager_nml:max_field_attributes.',&
2349  & err_msg) ) THEN
2350  RETURN
2351  END IF
2352  ELSE
2353  out_field%num_attributes = this_attribute
2354  ! Set name and type
2355  out_field%attributes(this_attribute)%name = att_name
2356  out_field%attributes(this_attribute)%type = nf90_char
2357  ! Initialize catt to a blank string, as len_trim doesn't always work on an uninitialized string
2358  out_field%attributes(this_attribute)%catt = ''
2359  END IF
2360  END IF
2361 
2362  ! Check if string is already included, and return if found
2363  IF ( index(trim(out_field%attributes(this_attribute)%catt), trim(prepend_value)).EQ.0 ) THEN
2364  ! Check if new string length goes beyond the length of catt
2365  length = len_trim(trim(prepend_value)//" "//trim(out_field%attributes(this_attribute)%catt))
2366  IF ( length.GT.len(out_field%attributes(this_attribute)%catt) ) THEN
2367  ! <ERROR STATUS="FATAL">
2368  ! Prepend length for attribute <name> is longer than allowed.
2369  ! </ERROR>
2370  IF ( fms_error_handler('diag_util_mod::prepend_attribute_field',&
2371  & 'Prepend length for attribute "'//trim(att_name)//'" is longer than allowed.',&
2372  & err_msg) ) THEN
2373  RETURN
2374  END IF
2375  END IF
2376  ! Set fields
2377  out_field%attributes(this_attribute)%catt =&
2378  & trim(prepend_value)//' '//trim(out_field%attributes(this_attribute)%catt)
2379  out_field%attributes(this_attribute)%len = length
2380  END IF
2381  END SUBROUTINE prepend_attribute_field
2382  !> @brief Allocates the atttype in out_file
2383  SUBROUTINE attribute_init_file(out_file, err_msg)
2384  TYPE(file_type), INTENT(inout) :: out_file !< output file to allocate memory for attribute
2385  CHARACTER(LEN=*), INTENT(out), OPTIONAL :: err_msg !< Error message, passed back to calling function
2386 
2387  INTEGER :: istat
2388 
2389  ! Initialize err_msg
2390  IF ( PRESENT(err_msg) ) err_msg = ''
2391 
2392  ! Allocate memory for the attributes
2393  IF ( .NOT.allocated(out_file%attributes) ) THEN
2394  ALLOCATE(out_file%attributes(max_field_attributes), stat=istat)
2395  IF ( istat.NE.0 ) THEN
2396  ! <ERROR STATUS="FATAL">
2397  ! Unable to allocate memory for file attributes
2398  ! </ERROR>
2399  IF ( fms_error_handler('diag_util_mod::attribute_init_file', &
2400  & 'Unable to allocate memory for file attributes', err_msg) ) THEN
2401  RETURN
2402  END IF
2403  ELSE
2404  ! Set equal to 0. It will be increased when attributes added
2405  out_file%num_attributes = 0
2406  END IF
2407  END IF
2408  END SUBROUTINE attribute_init_file
2409 
2410  !> @brief Prepends the attribute value to an already existing attribute. If the
2411  !! attribute isn't yet defined, then creates a new attribute
2412  SUBROUTINE prepend_attribute_file(out_file, att_name, prepend_value, err_msg)
2413  TYPE(file_type), INTENT(inout) :: out_file !< output file that will get the attribute
2414  CHARACTER(len=*), INTENT(in) :: att_name !< Name of the attribute
2415  CHARACTER(len=*), INTENT(in) :: prepend_value !< Value to prepend
2416  CHARACTER(len=*), INTENT(out) , OPTIONAL :: err_msg !< Error message, passed back to calling routine
2417 
2418  INTEGER :: length, i, this_attribute
2419  CHARACTER(len=512) :: err_msg_local
2420 
2421  ! Initialize string variables
2422  err_msg_local = ''
2423  IF ( PRESENT(err_msg) ) err_msg = ''
2424 
2425  ! Make sure the attributes for this out file have been initialized
2426  CALL attribute_init_file(out_file, err_msg_local)
2427  IF ( trim(err_msg_local) .NE. '' ) THEN
2428  IF ( fms_error_handler('diag_util_mod::prepend_attribute_file', trim(err_msg_local), err_msg) ) THEN
2429  RETURN
2430  END IF
2431  END IF
2432 
2433  ! Find if attribute exists
2434  this_attribute = 0
2435  DO i=1, out_file%num_attributes
2436  IF ( trim(out_file%attributes(i)%name) .EQ. trim(att_name) ) THEN
2437  this_attribute = i
2438  EXIT
2439  END IF
2440  END DO
2441 
2442  IF ( this_attribute > 0 ) THEN
2443  IF ( out_file%attributes(this_attribute)%type .NE. nf90_char ) THEN
2444  ! <ERROR STATUS="FATAL">
2445  ! Attribute <name> is not a character attribute.
2446  ! </ERROR>
2447  IF ( fms_error_handler('diag_util_mod::prepend_attribute_file',&
2448  & 'Attribute "'//trim(att_name)//'" is not a character attribute.',&
2449  & err_msg) ) THEN
2450  RETURN
2451  END IF
2452  END IF
2453  ELSE
2454  ! Defining a new attribute
2455  ! Increase the number of file attributes
2456  this_attribute = out_file%num_attributes + 1
2457  IF ( this_attribute .GT. max_file_attributes ) THEN
2458  ! <ERROR STATUS="FATAL">
2459  ! Number of attributes exceeds max_file_attributes for attribute <name>.
2460  ! Increase diag_manager_nml:max_file_attributes.
2461  ! </ERROR>
2462  IF ( fms_error_handler('diag_util_mod::prepend_attribute_file',&
2463  & 'Number of attributes exceeds max_file_attributes for attribute "'&
2464  &//trim(att_name)//'". Increase diag_manager_nml:max_file_attributes.',&
2465  & err_msg) ) THEN
2466  RETURN
2467  END IF
2468  ELSE
2469  out_file%num_attributes = this_attribute
2470  ! Set name and type
2471  out_file%attributes(this_attribute)%name = att_name
2472  out_file%attributes(this_attribute)%type = nf90_char
2473  ! Initialize catt to a blank string, as len_trim doesn't always work on an uninitialized string
2474  out_file%attributes(this_attribute)%catt = ''
2475  END IF
2476  END IF
2477 
2478  ! Only add string only if not already defined
2479  IF ( index(trim(out_file%attributes(this_attribute)%catt), trim(prepend_value)).EQ.0 ) THEN
2480  ! Check if new string length goes beyond the length of catt
2481  length = len_trim(trim(prepend_value)//" "//trim(out_file%attributes(this_attribute)%catt))
2482  IF ( length.GT.len(out_file%attributes(this_attribute)%catt) ) THEN
2483  ! <ERROR STATUS="FATAL">
2484  ! Prepend length for attribute <name> is longer than allowed.
2485  ! </ERROR>
2486  IF ( fms_error_handler('diag_util_mod::prepend_attribute_file',&
2487  & 'Prepend length for attribute "'//trim(att_name)//'" is longer than allowed.',&
2488  & err_msg) ) THEN
2489  RETURN
2490  END IF
2491  END IF
2492  ! Set files
2493  out_file%attributes(this_attribute)%catt =&
2494  & trim(prepend_value)//' '//trim(out_file%attributes(this_attribute)%catt)
2495  out_file%attributes(this_attribute)%len = length
2496  END IF
2497  END SUBROUTINE prepend_attribute_file
2498 
2499  !> @brief Get the a diag_file's start_time as it is defined in the diag_table
2500  !! @return the start_time for the file
2501  function get_file_start_time(file_num) &
2502  result(start_time)
2503  integer, intent(in) :: file_num !< File number of the file to get the start_time from
2504 
2505  TYPE(time_type) :: start_time !< The start_time to return
2506 
2507  start_time = files(file_num)%start_time
2508  end function get_file_start_time
2509 END MODULE diag_util_mod
2510 !> @}
2511 ! close documentation grouping
subroutine, public get_compressed_axes_ids(id, r)
given an index of compressed-by-gathering axis, return an array of axes used in compression....
Definition: diag_axis.F90:1262
subroutine, public get_diag_axis(id, name, units, long_name, cart_name, direction, edges, Domain, DomainU, array_data, num_attributes, attributes, domain_position)
Return information about the axis with index ID.
Definition: diag_axis.F90:468
subroutine, public get_diag_axis_cart(id, cart_name)
Return the axis cartesian.
Definition: diag_axis.F90:566
integer function, public get_axis_global_length(id)
Return the global length of the axis.
Definition: diag_axis.F90:650
type(domain2d) function, public get_domain2d(ids)
Return the 2D domain for the axis IDs given.
Definition: diag_axis.F90:699
type(domainug) function, public get_domainug(id)
Retrun the 1D domain for the axis ID given.
Definition: diag_axis.F90:731
subroutine, public get_diag_axis_data(id, axis_data)
Return the axis data.
Definition: diag_axis.F90:575
character(len=128) function, public get_axis_reqfld(id)
Return the required field names for the axis.
Definition: diag_axis.F90:641
subroutine, public get_diag_axis_name(id, axis_name)
Return the short name of the axis.
Definition: diag_axis.F90:589
character(len=128) function, public get_axis_aux(id)
Return the auxiliary name for the axis.
Definition: diag_axis.F90:632
integer function, public diag_axis_init(name, array_data, units, cart_name, long_name, direction, set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position)
Initialize the axis, and return the axis ID.
Definition: diag_axis.F90:111
logical function, public axis_is_compressed(id)
given an axis, returns TRUE if the axis uses compression-by-gathering: that is, if this is an axis fo...
Definition: diag_axis.F90:1242
subroutine, public get_axes_shift(ids, ishift, jshift)
Return the value of the shift for the axis IDs given.
Definition: diag_axis.F90:823
subroutine, public get_diag_axis_domain_name(id, name)
Return the name of the axis' domain.
Definition: diag_axis.F90:602
type(domain1d) function, public get_domain1d(id)
Retrun the 1D domain for the axis ID given.
Definition: diag_axis.F90:686
integer function, public diag_subaxes_init(axis, subdata, start_indx, end_indx, domain_2d)
Create a subaxis on a parent axis.
Definition: diag_axis.F90:383
integer max_output_fields
Maximum number of output fields. Increase via diag_manager_nml.
Definition: diag_data.F90:357
integer pack_size
1 for double and 2 for float
Definition: diag_data.F90:408
integer function get_base_minute()
gets the module variable base_minute
Definition: diag_data.F90:551
integer function get_base_year()
gets the module variable base_year
Definition: diag_data.F90:519
integer num_input_fields
Number of input fields in use.
Definition: diag_data.F90:349
integer function get_base_hour()
gets the module variable base_hour
Definition: diag_data.F90:543
logical use_cmor
Indicates if we should overwrite the MISSING_VALUE to use the CMOR missing value.
Definition: diag_data.F90:372
logical flush_nc_files
Control if diag_manager will force a flush of the netCDF file on each write. Note: changing this to ....
Definition: diag_data.F90:365
integer, parameter glo_reg_val_alt
Alternate value used in the region specification of the diag_table to indicate to use the full axis i...
Definition: diag_data.F90:109
type(time_type) function get_base_time()
gets the module variable base_time
Definition: diag_data.F90:511
integer, parameter diag_field_not_found
Return value for a diag_field that isn't found in the diag_table.
Definition: diag_data.F90:112
integer max_out_per_in_field
Maximum number of output_fields per input_field. Increase via diag_manager_nml.
Definition: diag_data.F90:359
integer max_input_fields
Maximum number of input fields. Increase via diag_manager_nml.
Definition: diag_data.F90:358
logical region_out_use_alt_value
Will determine which value to use when checking a regional output if the region is the full axis or a...
Definition: diag_data.F90:377
integer num_output_fields
Number of output fields in use.
Definition: diag_data.F90:350
integer function get_base_day()
gets the module variable base_day
Definition: diag_data.F90:535
type(time_type) diag_init_time
Time diag_manager_init called. If init_time not included in diag_manager_init call,...
Definition: diag_data.F90:417
integer max_files
Maximum number of output files allowed. Increase via diag_manager_nml.
Definition: diag_data.F90:356
integer num_files
Number of output files currenly in use by the diag_manager.
Definition: diag_data.F90:348
integer max_file_attributes
Maximum number of user definable global attributes per file.
Definition: diag_data.F90:384
real(r8_kind), parameter cmor_missing_value
CMOR standard missing value.
Definition: diag_data.F90:111
logical prepend_date
Should the history file have the start date prepended to the file name. .TRUE. is only supported if t...
Definition: diag_data.F90:386
character(len=2), dimension(:), allocatable fnum_for_domain
If this file number in the array is for the "unstructured" or "2d" domain.
Definition: diag_data.F90:433
integer function get_base_month()
gets the module variable base_month
Definition: diag_data.F90:527
integer, parameter glo_reg_val
Value used in the region specification of the diag_table to indicate to use the full axis instead of ...
Definition: diag_data.F90:107
integer function get_base_second()
gets the module variable base_second
Definition: diag_data.F90:559
integer, parameter max_fields_per_file
Maximum number of fields per file.
Definition: diag_data.F90:90
integer max_field_attributes
Maximum number of user definable attributes per field. Liptak: Changed from 2 to 4 20170718.
Definition: diag_data.F90:382
Define the region for field output.
Definition: diag_data.F90:171
Type to hold the output field description.
Definition: diag_data.F90:249
subroutine, public get_local_indexes(latStart, latEnd, lonStart, lonEnd, istart, iend, jstart, jend)
Find the local start and local end indexes on the local PE for regional output.
Definition: diag_grid.F90:392
subroutine, public diag_field_write(varname, buffer, static, file_num, fileobjU, fileobj, fileobjND, fnum_for_domain, time_in)
Writes diagnostic data out using fms2_io routine.
subroutine, public diag_output_init(file_name, file_title, file_unit, domain, domainU, fileobj, fileobjU, fileobjND, fnum_domain, attributes)
Opens the output file.
Definition: diag_output.F90:90
subroutine, public diag_flush(file_num, fileobjU, fileobj, fileobjND, fnum_for_domain)
Flushes the file into disk.
subroutine, public done_meta_data(file_unit)
Writes axis data to file.
subroutine, public diag_write_time(fileob, rtime_value, time_index, time_name)
Writes the time data to the history file.
subroutine, public write_axis_meta_data(file_unit, axes, fileob, time_ops, time_axis_registered)
Write the axis meta data to file.
type(diag_fieldtype) function, public write_field_meta_data(file_unit, name, axes, units, long_name, range, pack, mval, avg_name, time_method, standard_name, interp_method, attributes, num_attributes, use_UGdomain, fileob)
Write the field meta data to file.
subroutine, public get_subfield_size(axes, outnum)
Get the size, start, and end indices for output fields.
Definition: diag_util.F90:135
subroutine opening_file(file, time, filename_time)
Open file for output, and write the meta data.
Definition: diag_util.F90:1636
subroutine, public init_input_field(module_name, field_name, tile_count)
Initialize the input field.
Definition: diag_util.F90:1311
subroutine, public init_file(name, output_freq, output_units, format, time_units, long_name, tile_count, new_file_freq, new_file_freq_units, start_time, file_duration, file_duration_units, filename_time_bounds)
Initialize the output file.
Definition: diag_util.F90:1065
subroutine, public check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
Check if the array indices for output_fields(out_num) are equal to the output_fields(out_num)buffer u...
Definition: diag_util.F90:1018
integer function, public find_input_field(module_name, field_name, tile_count)
Return the field number for the given module name, field name, and tile number.
Definition: diag_util.F90:1292
subroutine, public write_static(file)
Output all static fields in this file.
Definition: diag_util.F90:2207
subroutine, public diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time)
Write data out to file, and if necessary flush the buffers.
Definition: diag_util.F90:2057
subroutine, public init_output_field(module_name, field_name, output_name, output_file, time_method, pack, tile_count, local_coord)
Initialize the output field.
Definition: diag_util.F90:1344
type(time_type) function, public get_file_start_time(file_num)
Get the a diag_file's start_time as it is defined in the diag_table.
Definition: diag_util.F90:2503
logical function a_lessthan_b(a, b)
return true iff a<b.
Definition: diag_util.F90:820
integer function find_file(name, tile_count)
Return the file number for file name and tile.
Definition: diag_util.F90:1275
subroutine, public check_duplicate_output_fields(err_msg)
Checks to see if output_name and output_file are unique in output_fields.
Definition: diag_util.F90:2238
subroutine, public sync_file_times(file_id, init_time, err_msg)
Synchronize the file's start and close times with the model start and end times.
Definition: diag_util.F90:1245
subroutine fms_diag_check_out_of_bounds_r8(ofb, bounds, output_name, module_name, err_msg)
Checks if the array indices for output_field buffer (ofb) are outside the are outside the bounding bo...
Definition: diag_util.F90:907
character(len=1), public field_log_separator
separator used for csv-style log of registered fields set by nml in diag_manager init
Definition: diag_util.F90:117
subroutine, public check_out_of_bounds(out_num, diag_field_id, err_msg)
Checks if the array indices for output_fields(out_num) are outside the output_fields(out_num)buffer u...
Definition: diag_util.F90:843
subroutine, public fms_diag_check_bounds_are_exact_static(current_bounds, bounds, output_name, module_name, err_msg)
Check if the array indices specified in the bounding box "current_bounds" are equal to those specifie...
Definition: diag_util.F90:1040
logical function a_greaterthan_b(a, b)
return true iff a>b.
Definition: diag_util.F90:827
subroutine, public get_subfield_vert_size(axes, outnum)
Get size, start and end indices for output fields.
Definition: diag_util.F90:417
logical function compare_buffer_bounds_to_size(current_bounds, bounds, error_str, lowerb_comp, upperb_comp)
Compares the bounding indices of an array specified in "current_bounds" to the corresponding lower an...
Definition: diag_util.F90:768
subroutine, public log_diag_field_info(module_name, field_name, axes, long_name, units, missing_value, range, dynamic)
Writes brief diagnostic field info to the log file.
Definition: diag_util.F90:637
subroutine, public update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
Update the output_fields x, y, and z min and max boundaries (array indices) with the six specified bo...
Definition: diag_util.F90:748
subroutine prepend_attribute_file(out_file, att_name, prepend_value, err_msg)
Prepends the attribute value to an already existing attribute. If the attribute isn't yet defined,...
Definition: diag_util.F90:2413
subroutine prepend_attribute_field(out_field, att_name, prepend_value, err_msg)
Prepends the attribute value to an already existing attribute. If the attribute isn't yet defined,...
Definition: diag_util.F90:2297
subroutine, public diag_util_init()
Write the version number of this file to the log file.
Definition: diag_util.F90:125
subroutine attribute_init_file(out_file, err_msg)
Allocates the atttype in out_file.
Definition: diag_util.F90:2384
logical function a_noteq_b(a, b)
return true iff a /= b
Definition: diag_util.F90:834
subroutine attribute_init_field(out_field, err_msg)
Allocates the atttype in out_field.
Definition: diag_util.F90:2268
subroutine check_and_open(file, time, do_write, filename_time)
Checks if it is time to open a new file.
Definition: diag_util.F90:2164
subroutine, public check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
This is an adaptor to the check_bounds_are_exact_dynamic_modern function to maintain an interface ser...
Definition: diag_util.F90:991
subroutine, public fms_diag_check_bounds_are_exact_dynamic(current_bounds, bounds, output_name, module_name, Time, field_prev_Time, err_msg)
Checks that array indices specified in the bounding box "current_bounds" are identical to those in th...
Definition: diag_util.F90:941
integer function get_index(number, array)
Find index i of array such that array(i) is closest to number.
Definition: diag_util.F90:548
subroutine fms_diag_check_out_of_bounds_r4(ofb, bounds, output_name, module_name, err_msg)
Checks if the array indices for output_fields(out_num) are outside the output_fields(out_num)buffer u...
Definition: diag_util.F90:875
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
character(len=128) function, public get_time_string(filename, current_time)
This function determines a string based on current time. This string is used as suffix in output file...
real function, public get_date_dif(t2, t1, units)
Return the difference between two times in units.
subroutine, public write_version_number(version, tag, unit)
Prints to the log file (or a specified unit) the version id string and tag name.
Definition: fms.F90:758
logical function, public fms_error_handler(routine, message, err_msg)
Facilitates the control of fatal error conditions.
Definition: fms.F90:525
subroutine, public error_mesg(routine, message, level)
Print notes, warnings and error messages; terminates program for warning and error messages....
Definition: fms.F90:498
integer function mpp_get_tile_npes(domain)
Returns number of processors used on current tile.
subroutine mpp_get_domain_components(domain, x, y, tile_count)
Retrieve 1D components of 2D decomposition.
integer function, dimension(size(domain%tile_id(:))) mpp_get_tile_id(domain)
Returns the tile_id on current pe.
logical function mpp_mosaic_defined()
Accessor function for value of mosaic_defined.
integer function mpp_get_current_ntile(domain)
Returns number of tile on current pe.
integer function mpp_get_ntile_count(domain)
Returns number of tiles in mosaic.
These routines retrieve the axis specifications associated with the compute domains....
Modifies the extents (compute, data and global) of a given domain.
One dimensional domain used to manage shared data access between pes.
The domain2D type contains all the necessary information to define the global, compute and data domai...
Domain information for managing data on unstructured grids.
integer function mpp_npes()
Returns processor count for current pelist.
Definition: mpp_util.inc:392
integer function mpp_pe()
Returns processor ID.
Definition: mpp_util.inc:378
logical function, public leap_year(Time, err_msg)
Returns true if the year corresponding to the input time is a leap year (for default calendar)....
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...
type(time_type) function, public increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
Increments a time by seconds and days.
integer function, public get_calendar_type()
Returns default calendar type for mapping from time to date.
Type to represent amounts of time. Implemented as seconds and days to allow for larger intervals.
Data structure holding a 3D bounding box. It is commonlyused to represent the interval bounds or limi...