!***********************************************************************
!* GNU Lesser General Public License
!*
!* This file is part of the GFDL Flexible Modeling System (FMS).
!*
!* FMS is free software: you can redistribute it and/or modify it under
!* the terms of the GNU Lesser General Public License as published by
!* the Free Software Foundation, either version 3 of the License, or (at
!* your option) any later version.
!*
!* FMS is distributed in the hope that it will be useful, but WITHOUT
!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
!* for more details.
!*
!* You should have received a copy of the GNU Lesser General Public
!* License along with FMS. If not, see .
!***********************************************************************
MODULE diag_util_mod
#include
!
! Seth Underwood
!
!
!
! Functions and subroutines necessary for the diag_manager_mod.
!
!
! diag_util_mod is a set of Fortran functions and subroutines used by the diag_manager_mod.
!
!
!
! Make an interface check_bounds_are_exact for the subroutines check_bounds_are_exact_static and
! check_bounds_are_exact_dynamic.
!
!
!
USE diag_data_mod, ONLY: output_fields, input_fields, files, do_diag_field_log, diag_log_unit,&
& VERY_LARGE_AXIS_LENGTH, time_zero, VERY_LARGE_FILE_FREQ, END_OF_RUN, EVERY_TIME,&
& DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, base_time,&
& time_unit_list, max_files, base_year, base_month, base_day, base_hour, base_minute,&
& base_second, num_files, max_files, max_fields_per_file, max_out_per_in_field,&
& max_input_fields,num_input_fields, max_output_fields, num_output_fields, coord_type,&
& mix_snapshot_average_fields, global_descriptor, CMOR_MISSING_VALUE, use_cmor, pack_size,&
& debug_diag_manager, flush_nc_files, output_field_type, max_field_attributes, max_file_attributes,&
& file_type, prepend_date, region_out_use_alt_value, GLO_REG_VAL, GLO_REG_VAL_ALT,&
& DIAG_FIELD_NOT_FOUND, diag_init_time
USE diag_axis_mod, ONLY: get_diag_axis_data, get_axis_global_length, get_diag_axis_cart,&
& get_domain1d, get_domain2d, diag_subaxes_init, diag_axis_init, get_diag_axis, get_axis_aux,&
& get_axes_shift, get_diag_axis_name, get_diag_axis_domain_name, get_domainUG, &
& get_axis_reqfld, axis_is_compressed, get_compressed_axes_ids
USE diag_output_mod, ONLY: diag_flush, diag_field_out, diag_output_init, write_axis_meta_data,&
& write_field_meta_data, done_meta_data
USE diag_grid_mod, ONLY: get_local_indexes
USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, mpp_pe, mpp_root_pe, lowercase, fms_error_handler,&
& write_version_number, do_cf_compliance
USE fms_io_mod, ONLY: get_tile_string, return_domain, string, get_instance_filename
USE mpp_domains_mod,ONLY: domain1d, domain2d, mpp_get_compute_domain, null_domain1d, null_domain2d,&
& OPERATOR(.NE.), OPERATOR(.EQ.), mpp_modify_domain, mpp_get_domain_components,&
& mpp_get_ntile_count, mpp_get_current_ntile, mpp_get_tile_id, mpp_mosaic_defined, mpp_get_tile_npes,&
& domainUG, null_domainUG
USE time_manager_mod,ONLY: time_type, OPERATOR(==), OPERATOR(>), NO_CALENDAR, increment_date,&
& increment_time, get_calendar_type, get_date, get_time, leap_year, OPERATOR(-),&
& OPERATOR(<), OPERATOR(>=), OPERATOR(<=), OPERATOR(==)
USE mpp_io_mod, ONLY: mpp_close
USE mpp_mod, ONLY: mpp_npes
USE fms_io_mod, ONLY: get_instance_filename, get_mosaic_tile_file_ug
USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE
#ifdef use_netCDF
USE netcdf, ONLY: NF90_CHAR
#endif
IMPLICIT NONE
PRIVATE
PUBLIC get_subfield_size, log_diag_field_info, update_bounds, check_out_of_bounds,&
& check_bounds_are_exact_dynamic, check_bounds_are_exact_static, init_file, diag_time_inc,&
& find_input_field, init_input_field, init_output_field, diag_data_out, write_static,&
& check_duplicate_output_fields, get_date_dif, get_subfield_vert_size, sync_file_times,&
& prepend_attribute, attribute_init, diag_util_init
!
!
! prepend a value to a string attribute in the output field or output file
!
!
! SUBROUTINE prepend_attribute(output_field, att_name, att_value)
! SUBROUTINE prepend_attribute(output_file, att_name, att_value)
!
!
! Prepend a character string to a character attribute for a give field, or to a global attribute
! in a give file.
!
!
!
!
!
INTERFACE prepend_attribute
MODULE PROCEDURE prepend_attribute_field
MODULE PROCEDURE prepend_attribute_file
END INTERFACE prepend_attribute
!
!
!
! Allocates the atttype in out_file
!
!
! SUBROUTINE attribute_init(out_file, err_msg)
!
!
! Allocates memory in out_file for the attributes. Will FATAL if err_msg is not included
! in the subroutine call.
!
! output field to allocate memory for attribute
! output file to allocate memory for attribute
! Error message, passed back to calling function
INTERFACE attribute_init
MODULE PROCEDURE attribute_init_field
MODULE PROCEDURE attribute_init_file
END INTERFACE attribute_init
!
! Include variable "version" to be written to log file.
#include
LOGICAL :: module_initialized = .FALSE.
CONTAINS
!
!
! Write the version number of this file
!
!
! SUBROUTINE diag_util_init
!
!
! Write the version number of this file to the log file.
!
SUBROUTINE diag_util_init()
IF (module_initialized) THEN
RETURN
END IF
! Write version number out to log file
call write_version_number("DIAG_UTIL_MOD", version)
END SUBROUTINE diag_util_init
!
!
!
! Get the size, start, and end indices for output fields.
!
!
! SUBROUTINE get_subfield_size(axes, outnum)
!
!
! Get the size, start and end indices for output_fields(outnum), then
! fill in output_fields(outnum)%output_grid%(start_indx, end_indx)
!
! Axes of the input_field.
! Position in array output_fields.
SUBROUTINE get_subfield_size(axes, outnum)
INTEGER, INTENT(in) :: axes(:) ! axes of the input_field
INTEGER, INTENT(in) :: outnum ! position in array output_fields
REAL, ALLOCATABLE :: global_lat(:), global_lon(:), global_depth(:)
INTEGER :: global_axis_size, global_axis_sizey
INTEGER :: i,xbegin,xend,ybegin,yend,xbegin_l,xend_l,ybegin_l,yend_l
CHARACTER(len=1) :: cart
TYPE(domain2d) :: Domain2, Domain2_new
TYPE(domain1d) :: Domain1, Domain1x, Domain1y
REAL :: start(3), end(3) ! start and end coordinates in 3 axes
INTEGER :: gstart_indx(3), gend_indx(3) ! global start and end indices of output domain in 3 axes
REAL, ALLOCATABLE :: subaxis_x(:), subaxis_y(:), subaxis_z(:) !containing local coordinates in x,y,z axes
CHARACTER(len=128) :: msg
INTEGER :: ishift, jshift
INTEGER :: grv !< Value used to determine if the region defined in the diag_table is for the whole axis, or a sub-axis
CHARACTER(len=128), DIMENSION(2) :: axis_domain_name
!initilization for local output
! initially out of (lat/lon/depth) range
start = -1.e10
end = -1.e10
gstart_indx = -1
gend_indx = -1
! get the value to compare to determine if writing full axis data
IF ( region_out_use_alt_value ) THEN
grv = GLO_REG_VAL_ALT
ELSE
grv = GLO_REG_VAL
END IF
! get axis data (lat, lon, depth) and indices
start = output_fields(outnum)%output_grid%start
end = output_fields(outnum)%output_grid%end
CALL get_diag_axis_domain_name(axes(1), axis_domain_name(1))
CALL get_diag_axis_domain_name(axes(2), axis_domain_name(2))
IF ( INDEX(lowercase(axis_domain_name(1)), 'cubed') == 0 .AND. &
& INDEX(lowercase(axis_domain_name(2)), 'cubed') == 0 ) THEN
DO i = 1, SIZE(axes(:))
global_axis_size = get_axis_global_length(axes(i))
output_fields(outnum)%output_grid%subaxes(i) = -1
CALL get_diag_axis_cart(axes(i), cart)
SELECT CASE(cart)
CASE ('X')
! wrong order of axes. X should come first.
IF( i.NE.1 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
& 'wrong order of axes, X should come first',FATAL)
ALLOCATE(global_lon(global_axis_size))
CALL get_diag_axis_data(axes(i),global_lon)
IF( INT(start(i)) == grv .AND. INT(end(i)) == grv ) THEN
gstart_indx(i) = 1
gend_indx(i) = global_axis_size
output_fields(outnum)%output_grid%subaxes(i) = axes(i)
ELSE
gstart_indx(i) = get_index(start(i),global_lon)
gend_indx(i) = get_index(END(i),global_lon)
END IF
ALLOCATE(subaxis_x(gstart_indx(i):gend_indx(i)))
subaxis_x=global_lon(gstart_indx(i):gend_indx(i))
CASE ('Y')
! wrong order of axes, Y should come second.
IF( i.NE.2 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
& 'wrong order of axes, Y should come second',FATAL)
ALLOCATE(global_lat(global_axis_size))
CALL get_diag_axis_data(axes(i),global_lat)
IF( INT(start(i)) == grv .AND. INT(END(i)) == grv ) THEN
gstart_indx(i) = 1
gend_indx(i) = global_axis_size
output_fields(outnum)%output_grid%subaxes(i) = axes(i)
ELSE
gstart_indx(i) = get_index(start(i),global_lat)
gend_indx(i) = get_index(END(i),global_lat)
END IF
ALLOCATE(subaxis_y(gstart_indx(i):gend_indx(i)))
subaxis_y=global_lat(gstart_indx(i):gend_indx(i))
CASE ('Z')
! wrong values in vertical axis of region
IF ( start(i)*END(i)<0. ) CALL error_mesg('diag_util_mod::get_subfield_size',&
& 'wrong values in vertical axis of region',FATAL)
IF ( start(i)>=0. .AND. END(i)>0. ) THEN
ALLOCATE(global_depth(global_axis_size))
CALL get_diag_axis_data(axes(i),global_depth)
gstart_indx(i) = get_index(start(i),global_depth)
gend_indx(i) = get_index(END(i),global_depth)
ALLOCATE(subaxis_z(gstart_indx(i):gend_indx(i)))
subaxis_z=global_depth(gstart_indx(i):gend_indx(i))
output_fields(outnum)%output_grid%subaxes(i) =&
& diag_subaxes_init(axes(i),subaxis_z, gstart_indx(i),gend_indx(i))
DEALLOCATE(subaxis_z,global_depth)
ELSE ! regional vertical axis is the same as global vertical axis
gstart_indx(i) = 1
gend_indx(i) = global_axis_size
output_fields(outnum)%output_grid%subaxes(i) = axes(i)
! i should equal 3 for z axis
IF( i /= 3 ) CALL error_mesg('diag_util_mod::get_subfield_size',&
& 'i should equal 3 for z axis', FATAL)
END IF
CASE default
! Wrong axis_cart
CALL error_mesg('diag_util_mod::get_subfield_size', 'Wrong axis_cart', FATAL)
END SELECT
END DO
DO i = 1, SIZE(axes(:))
IF ( gstart_indx(i) == -1 .OR. gend_indx(i) == -1 ) THEN
!
! can not find gstart_indx/gend_indx for ,
! check region bounds for axis .
!
WRITE(msg,'(A,I2)') ' check region bounds for axis ', i
CALL error_mesg('diag_util_mod::get_subfield_size', 'can not find gstart_indx/gend_indx for '&
& //TRIM(output_fields(outnum)%output_name)//','//TRIM(msg), FATAL)
END IF
END DO
ELSE ! cubed sphere
! get the i and j start and end indexes
CALL get_local_indexes(LONSTART=start(1), LONEND=END(1), &
& LATSTART=start(2), LATEND=END(2), &
& ISTART=gstart_indx(1), IEND=gend_indx(1), &
& JSTART=gstart_indx(2), JEND=gend_indx(2))
global_axis_size = get_axis_global_length(axes(1))
ALLOCATE(global_lon(global_axis_size))
global_axis_sizey = get_axis_global_length(axes(2))
ALLOCATE(global_lat(global_axis_sizey))
CALL get_diag_axis_data(axes(1),global_lon)
CALL get_diag_axis_data(axes(2),global_lat)
!Potential fix for out-of-bounds error for global_lon and global_lat.
IF ((gstart_indx(1) .GT. 0 .AND. gstart_indx(2) .GT. 0) .AND. &
(gstart_indx(1) .LE. global_axis_size .AND. gstart_indx(2) .LE. global_axis_sizey) .AND. &
(gend_indx(1) .GT. 0 .AND. gend_indx(2) .GT. 0) .AND. &
(gend_indx(1) .LE. global_axis_size .AND. gend_indx(2) .LE. global_axis_sizey)) THEN
ALLOCATE(subaxis_x(gstart_indx(1):gend_indx(1)))
ALLOCATE(subaxis_y(gstart_indx(2):gend_indx(2)))
subaxis_x=global_lon(gstart_indx(1):gend_indx(1))
subaxis_y=global_lat(gstart_indx(2):gend_indx(2))
END IF
! Now deal with the Z component
IF ( SIZE(axes(:)) > 2 ) THEN
global_axis_size = get_axis_global_length(axes(3))
output_fields(outnum)%output_grid%subaxes(3) = -1
CALL get_diag_axis_cart(axes(3), cart)
!
! axis(3) should be Z-axis
!
IF ( lowercase(cart) /= 'z' ) CALL error_mesg('diag_util_mod::get_subfield_size', &
&'axis(3) should be Z-axis', FATAL)
!
! wrong values in vertical axis of region
!
IF ( start(3)*END(3)<0. ) CALL error_mesg('diag_util_mod::get_subfield_size',&
& 'wrong values in vertical axis of region',FATAL)
IF ( start(3)>=0. .AND. END(3)>0. ) THEN
ALLOCATE(global_depth(global_axis_size))
CALL get_diag_axis_data(axes(3),global_depth)
gstart_indx(3) = get_index(start(3),global_depth)
IF( start(3) == 0.0 ) gstart_indx(3) = 1
gend_indx(3) = get_index(END(3),global_depth)
IF( start(3) >= MAXVAL(global_depth) ) gstart_indx(3)= global_axis_size
IF( END(3) >= MAXVAL(global_depth) ) gend_indx(3) = global_axis_size
ALLOCATE(subaxis_z(gstart_indx(3):gend_indx(3)))
subaxis_z=global_depth(gstart_indx(3):gend_indx(3))
output_fields(outnum)%output_grid%subaxes(3) =&
& diag_subaxes_init(axes(3),subaxis_z, gstart_indx(3),gend_indx(3))
DEALLOCATE(subaxis_z,global_depth)
ELSE ! regional vertical axis is the same as global vertical axis
gstart_indx(3) = 1
gend_indx(3) = global_axis_size
output_fields(outnum)%output_grid%subaxes(3) = axes(3)
END IF
END IF
END IF
! get domain and compute_domain(xbegin,xend,ybegin,yend)
xbegin = -1
xend = -1
ybegin = -1
yend = -1
Domain2 = get_domain2d(axes)
IF ( Domain2 .NE. NULL_DOMAIN2D ) THEN
CALL mpp_get_compute_domain(Domain2, xbegin, xend, ybegin, yend)
CALL mpp_get_domain_components(Domain2, Domain1x, Domain1y)
ELSE
DO i = 1, MIN(SIZE(axes(:)),2)
Domain1 = get_domain1d(axes(i))
IF ( Domain1 .NE. NULL_DOMAIN1D ) THEN
CALL get_diag_axis_cart(axes(i),cart)
SELECT CASE(cart)
CASE ('X')
Domain1x = get_domain1d(axes(i))
CALL mpp_get_compute_domain(Domain1x, xbegin, xend)
CASE ('Y')
Domain1y = get_domain1d(axes(i))
CALL mpp_get_compute_domain(Domain1y, ybegin, yend)
CASE default ! do nothing here
END SELECT
ELSE
! No domain available
CALL error_mesg('diag_util_mod::get_subfield_size', 'NO domain available', FATAL)
END IF
END DO
END IF
CALL get_axes_shift(axes, ishift, jshift)
xend = xend+ishift
yend = yend+jshift
IF ( xbegin == -1 .OR. xend == -1 .OR. ybegin == -1 .OR. yend == -1 ) THEN
! wrong compute domain indices
CALL error_mesg('diag_util_mod::get_subfield_size', 'wrong compute domain indices',FATAL)
END IF
! get the area containing BOTH compute domain AND local output area
IF( gstart_indx(1) > xend .OR. xbegin > gend_indx(1) ) THEN
output_fields(outnum)%output_grid%l_start_indx(1) = -1
output_fields(outnum)%output_grid%l_end_indx(1) = -1
output_fields(outnum)%need_compute = .FALSE. ! not involved
ELSEIF ( gstart_indx(2) > yend .OR. ybegin > gend_indx(2) ) THEN
output_fields(outnum)%output_grid%l_start_indx(2) = -1
output_fields(outnum)%output_grid%l_end_indx(2) = -1
output_fields(outnum)%need_compute = .FALSE. ! not involved
ELSE
output_fields(outnum)%output_grid%l_start_indx(1) = MAX(xbegin, gstart_indx(1))
output_fields(outnum)%output_grid%l_start_indx(2) = MAX(ybegin, gstart_indx(2))
output_fields(outnum)%output_grid%l_end_indx(1) = MIN(xend, gend_indx(1))
output_fields(outnum)%output_grid%l_end_indx(2) = MIN(yend, gend_indx(2))
output_fields(outnum)%need_compute = .TRUE. ! involved in local output
END IF
IF ( output_fields(outnum)%need_compute ) THEN
! need to modify domain1d and domain2d for subaxes
xbegin_l = output_fields(outnum)%output_grid%l_start_indx(1)
xend_l = output_fields(outnum)%output_grid%l_end_indx(1)
ybegin_l = output_fields(outnum)%output_grid%l_start_indx(2)
yend_l = output_fields(outnum)%output_grid%l_end_indx(2)
CALL mpp_modify_domain(Domain2, Domain2_new, xbegin_l,xend_l, ybegin_l,yend_l,&
& gstart_indx(1),gend_indx(1), gstart_indx(2),gend_indx(2))
output_fields(outnum)%output_grid%subaxes(1) =&
& diag_subaxes_init(axes(1),subaxis_x, gstart_indx(1),gend_indx(1),Domain2_new)
output_fields(outnum)%output_grid%subaxes(2) =&
& diag_subaxes_init(axes(2),subaxis_y, gstart_indx(2),gend_indx(2),Domain2_new)
DO i = 1, SIZE(axes(:))
IF ( output_fields(outnum)%output_grid%subaxes(i) == -1 ) THEN
!
! error at i =
!
WRITE(msg,'(a,"/",I4)') 'at i = ',i
CALL error_mesg('diag_util_mod::get_subfield_size '//TRIM(output_fields(outnum)%output_name),&
'error '//TRIM(msg), FATAL)
END IF
END DO
! local start index should start from 1
output_fields(outnum)%output_grid%l_start_indx(1) = MAX(xbegin, gstart_indx(1)) - xbegin + 1
output_fields(outnum)%output_grid%l_start_indx(2) = MAX(ybegin, gstart_indx(2)) - ybegin + 1
output_fields(outnum)%output_grid%l_end_indx(1) = MIN(xend, gend_indx(1)) - xbegin + 1
output_fields(outnum)%output_grid%l_end_indx(2) = MIN(yend, gend_indx(2)) - ybegin + 1
IF ( SIZE(axes(:))>2 ) THEN
output_fields(outnum)%output_grid%l_start_indx(3) = gstart_indx(3)
output_fields(outnum)%output_grid%l_end_indx(3) = gend_indx(3)
ELSE
output_fields(outnum)%output_grid%l_start_indx(3) = 1
output_fields(outnum)%output_grid%l_end_indx(3) = 1
END IF
END IF
IF ( ALLOCATED(subaxis_x) ) DEALLOCATE(subaxis_x, global_lon)
IF ( ALLOCATED(subaxis_y) ) DEALLOCATE(subaxis_y, global_lat)
END SUBROUTINE get_subfield_size
!
!
!
! Get size, start and end indices for output fields.
!
!
! SUBROUTINE get_subfield_vert_size(axes, outnum)
!
!
! Get size, start and end indices for output_fields(outnum), fill in
! output_fields(outnum)%output_grid%(start_indx, end_indx).
!
! Axes of the input_field
! Position in array output_fields.
SUBROUTINE get_subfield_vert_size(axes, outnum)
INTEGER, DIMENSION(:), INTENT(in) :: axes ! axes of the input_field
INTEGER, INTENT(in) :: outnum ! position in array output_fields
REAL, DIMENSION(3) :: start, end ! start and end coordinates in 3 axes
REAL, ALLOCATABLE, DIMENSION(:) :: global_depth
REAL, ALLOCATABLE, DIMENSION(:) :: subaxis_z !containing local coordinates in x,y,z axes
INTEGER :: i, global_axis_size
INTEGER, DIMENSION(3) :: gstart_indx, gend_indx ! global start and end indices of output domain in 3 axes
CHARACTER(len=1) :: cart
CHARACTER(len=128) :: msg
!----------
!ug support
integer :: vert_dim_num
!----------
!initilization for local output
start = -1.e10
end = -1.e10 ! initially out of (lat/lon/depth) range
gstart_indx = -1
gend_indx=-1
! get axis data (lat, lon, depth) and indices
start= output_fields(outnum)%output_grid%start
end = output_fields(outnum)%output_grid%end
!----------
!ug support
vert_dim_num = 3
!----------
DO i = 1, SIZE(axes(:))
global_axis_size = get_axis_global_length(axes(i))
output_fields(outnum)%output_grid%subaxes(i) = -1
CALL get_diag_axis_cart(axes(i), cart)
SELECT CASE(cart)
CASE ('X')
! wrong order of axes, X should come first
IF ( i.NE.1 ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
& 'wrong order of axes, X should come first',FATAL)
gstart_indx(i) = 1
gend_indx(i) = global_axis_size
output_fields(outnum)%output_grid%subaxes(i) = axes(i)
CASE ('Y')
! wrong order of axes, Y should come second
IF( i.NE.2 ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
& 'wrong order of axes, Y should come second',FATAL)
gstart_indx(i) = 1
gend_indx(i) = global_axis_size
output_fields(outnum)%output_grid%subaxes(i) = axes(i)
!----------
!ug support
case ("U")
if (i .ne. 1) then
call error_mesg("diag_util_mod::get_subfield_vert_size", &
"the unstructured axis must be the first dimension.", &
FATAL)
endif
gstart_indx(i) = 1
gend_indx(i) = global_axis_size
output_fields(outnum)%output_grid%subaxes(i) = axes(i)
vert_dim_num = 2
start(vert_dim_num) = start(3)
end(vert_dim_num) = end(3)
!----------
CASE ('Z')
!----------
!ug support
if (i .ne. vert_dim_num) then
call error_mesg("diag_util_mod::get_subfield_vert_size",&
"i should equal vert_dim_num for z axis", &
FATAL)
endif
!----------
! wrong values in vertical axis of region
IF( start(i)*END(i) < 0. ) CALL error_mesg('diag_util_mod::get_subfield_vert_size',&
& 'wrong values in vertical axis of region',FATAL)
IF( start(i) >= 0. .AND. END(i) > 0. ) THEN
ALLOCATE(global_depth(global_axis_size))
CALL get_diag_axis_data(axes(i),global_depth)
gstart_indx(i) = get_index(start(i),global_depth)
IF( start(i) == 0.0 ) gstart_indx(i) = 1
gend_indx(i) = get_index(END(i),global_depth)
IF( start(i) >= MAXVAL(global_depth) ) gstart_indx(i)= global_axis_size
IF( END(i) >= MAXVAL(global_depth) ) gend_indx(i) = global_axis_size
ALLOCATE(subaxis_z(gstart_indx(i):gend_indx(i)))
subaxis_z=global_depth(gstart_indx(i):gend_indx(i))
output_fields(outnum)%output_grid%subaxes(i) = &
diag_subaxes_init(axes(i),subaxis_z, gstart_indx(i),gend_indx(i))
DEALLOCATE(subaxis_z,global_depth)
ELSE ! vertical axis is the same as global vertical axis
gstart_indx(i) = 1
gend_indx(i) = global_axis_size
output_fields(outnum)%output_grid%subaxes(i) = axes(i)
END IF
CASE default
! Wrong axis_cart
CALL error_mesg('diag_util_mod::get_subfield_vert_size', 'Wrong axis_cart', FATAL)
END SELECT
END DO
DO i = 1,SIZE(axes(:))
IF ( gstart_indx(i) == -1 .OR. gend_indx(i) == -1 ) THEN
!
! can not find gstart_indx/gend_indx for
! check region bounds for axis
!
WRITE(msg,'(A,I2)') ' check region bounds for axis ', i
CALL error_mesg('diag_util_mod::get_subfield_vert_size', 'can not find gstart_indx/gend_indx for '&
& //TRIM(output_fields(outnum)%output_name)//','//TRIM(msg), FATAL)
END IF
END DO
DO i= 1, 2
output_fields(outnum)%output_grid%l_start_indx(i) = gstart_indx(i)
output_fields(outnum)%output_grid%l_end_indx(i) = gend_indx(i)
END DO
IF( SIZE(axes(:)) > 2 ) THEN
output_fields(outnum)%output_grid%l_start_indx(3) = gstart_indx(3)
output_fields(outnum)%output_grid%l_end_indx(3) = gend_indx(3)
ELSE
output_fields(outnum)%output_grid%l_start_indx(3) = 1
output_fields(outnum)%output_grid%l_end_indx(3) = 1
END IF
END SUBROUTINE get_subfield_vert_size
!
!
!
!
! Find index i of array such that array(i) is closest to number.
!
!
! INTEGER FUNCTION get_index(number, array)
!
!
! Find index i of array such that array(i) is closest to number.
! Array must be monotonouslly ordered.
!
!
!
INTEGER FUNCTION get_index(number, array)
REAL, INTENT(in) :: number
REAL, INTENT(in), DIMENSION(:) :: array
INTEGER :: i, n
LOGICAL :: found
n = SIZE(array(:))
! check if array is monotonous
DO i = 2, n-1
IF( (array(i-1)array(i+1)) .OR. (array(i-1)>array(i).AND.array(i)array NOT monotonously ordered
CALL error_mesg('diag_util_mod::get_index', 'array NOT monotonously ordered',FATAL)
END IF
END DO
get_index = -1
found = .FALSE.
! search in increasing array
DO i = 1, n-1
IF ( (array(i)<=number).AND.(array(i+1)>= number) ) THEN
IF( number - array(i) <= array(i+1) - number ) THEN
get_index = i
found=.TRUE.
ELSE
get_index = i+1
found=.TRUE.
ENDIF
EXIT
END IF
END DO
! if not found, search in decreasing array
IF( .NOT.found ) THEN
DO i = 1, n-1
IF ( (array(i)>=number).AND.(array(i+1)<= number) ) THEN
IF ( array(i)-number <= number-array(i+1) ) THEN
get_index = i
found = .TRUE.
ELSE
get_index = i+1
found = .TRUE.
END IF
EXIT
END IF
END DO
END IF
! if still not found, is it less than the first element
! or greater than last element? (Increasing Array)
! But it must be within 2x the axis spacing
! i.e. array(1)-(array(3)-array(1)).LT.number .AND. or 2*array(1)-array(3).LT.number
IF ( .NOT. found ) THEN
IF ( 2*array(1)-array(3).LT.number .AND. number.LT.array(1) ) THEN
get_index = 1
found = .TRUE.
ELSE IF ( array(n).LT.number .AND. number.LT.2*array(n)-array(n-2) ) THEN
get_index = n
found = .TRUE.
ELSE
found = .FALSE.
END IF
END IF
! if still not found, is it greater than the first element
! or less than the last element? (Decreasing Array)
! But it must be within 2x the axis spacing (see above)
IF ( .NOT. found ) THEN
IF ( 2*array(1)-array(3).GT.number .AND. number.GT.array(1) ) THEN
get_index = 1
found = .TRUE.
ELSE IF ( array(n).GT.number .AND. number.GT.2*array(n)-array(n-2) ) THEN
get_index = n
found = .TRUE.
ELSE
found = .FALSE.
END IF
END IF
END FUNCTION get_index
!
!
!
!
! Writes brief diagnostic field info to the log file.
!
!
! SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,
! missing_value, range, dynamic)
!
!
! If the do_diag_field_log namelist parameter is .TRUE.,
! then a line briefly describing diagnostic field is added to
! the log file. Normally users should not call this subroutine
! directly, since it is called by register_static_field and
! register_diag_field if do_not_log is not set to .TRUE.. It is
! used, however, in LM3 to avoid excessive logs due to the
! number of fields registered for each of the tile types. LM3
! code uses a do_not_log parameter in the registration calls,
! and subsequently calls this subroutine to log field information
! under a generic name.
!
! Module name.
! Field name.
! Axis IDs.
! Long name for field.
! Unit of field.
! Missing value value.
! Valid range of values for field.
! .TRUE. if field is not static.
SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,&
& missing_value, range, dynamic)
CHARACTER(len=*), INTENT(in) :: module_name, field_name
INTEGER, DIMENSION(:), INTENT(in) :: axes
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units
REAL, OPTIONAL, INTENT(in) :: missing_value
REAL, DIMENSION(2), OPTIONAL, INTENT(IN) :: range
LOGICAL, OPTIONAL, INTENT(in) :: dynamic
! ---- local vars
CHARACTER(len=256) :: lmodule, lfield, lname, lunits
CHARACTER(len=64) :: lmissval, lmin, lmax
CHARACTER(len=8) :: numaxis, timeaxis
CHARACTER(len=1) :: sep = '|'
CHARACTER(len=256) :: axis_name, axes_list
INTEGER :: i
IF ( .NOT.do_diag_field_log ) RETURN
IF ( mpp_pe().NE.mpp_root_pe() ) RETURN
lmodule = TRIM(module_name)
lfield = TRIM(field_name)
IF ( PRESENT(long_name) ) THEN
lname = TRIM(long_name)
ELSE
lname = ''
END IF
IF ( PRESENT(units) ) THEN
lunits = TRIM(units)
ELSE
lunits = ''
END IF
WRITE (numaxis,'(i1)') SIZE(axes)
IF (PRESENT(missing_value)) THEN
IF ( use_cmor ) THEN
WRITE (lmissval,*) CMOR_MISSING_VALUE
ELSE
WRITE (lmissval,*) missing_value
END IF
ELSE
lmissval = ''
ENDIF
IF ( PRESENT(range) ) THEN
WRITE (lmin,*) range(1)
WRITE (lmax,*) range(2)
ELSE
lmin = ''
lmax = ''
END IF
IF ( PRESENT(dynamic) ) THEN
IF (dynamic) THEN
timeaxis = 'T'
ELSE
timeaxis = 'F'
END IF
ELSE
timeaxis = ''
END IF
axes_list=''
DO i = 1, SIZE(axes)
CALL get_diag_axis_name(axes(i),axis_name)
IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//','
axes_list = TRIM(axes_list)//TRIM(axis_name)
END DO
!write (diag_log_unit,'(8(a,a),a)') &
WRITE (diag_log_unit,'(777a)') &
& TRIM(lmodule), sep, TRIM(lfield), sep, TRIM(lname), sep,&
& TRIM(lunits), sep, TRIM(numaxis), sep, TRIM(timeaxis), sep,&
& TRIM(lmissval), sep, TRIM(lmin), sep, TRIM(lmax), sep,&
& TRIM(axes_list)
END SUBROUTINE log_diag_field_info
!
!
!
! Update the output_fields min and max boundaries.
!
!
! SUBROUTINE 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).
!
! output_field ID.
! Lower i bound.
! Upper i bound.
! Lower j bound.
! Upper j bound.
! Lower k bound.
! Upper k bound.
SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k)
INTEGER, INTENT(in) :: out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k
output_fields(out_num)%imin = MIN(output_fields(out_num)%imin, lower_i)
output_fields(out_num)%imax = MAX(output_fields(out_num)%imax, upper_i)
output_fields(out_num)%jmin = MIN(output_fields(out_num)%jmin, lower_j)
output_fields(out_num)%jmax = MAX(output_fields(out_num)%jmax, upper_j)
output_fields(out_num)%kmin = MIN(output_fields(out_num)%kmin, lower_k)
output_fields(out_num)%kmax = MAX(output_fields(out_num)%kmax, upper_k)
END SUBROUTINE update_bounds
!
!
!
! Checks if the array indices for output_fields(out_num) are outside the output_fields(out_num)%buffer upper
! and lower bounds.
!
!
! SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg)
!
!
! check_out_of_bounds verifies the array min and max indices in the x, y, and z directions of
! output_fields(out_num) are not outside the upper and lower array boundaries of
! output_fields(out_num)%buffer. If the min and max indices are outside the upper and lower bounds of the buffer
! array, then check_out_of_bounds returns an error string.
!
!
! Output field ID number.
!
!
! Input field ID number.
!
!
! Return status of check_out_of_bounds. An empty error string indicates the x, y, and z indices are not outside the
! buffer array boundaries.
!
SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg)
INTEGER, INTENT(in) :: out_num, diag_field_id
CHARACTER(len=*), INTENT(out) :: err_msg
CHARACTER(len=128) :: error_string1, error_string2
IF ( output_fields(out_num)%imin < LBOUND(output_fields(out_num)%buffer,1) .OR.&
& output_fields(out_num)%imax > UBOUND(output_fields(out_num)%buffer,1) .OR.&
& output_fields(out_num)%jmin < LBOUND(output_fields(out_num)%buffer,2) .OR.&
& output_fields(out_num)%jmax > UBOUND(output_fields(out_num)%buffer,2) .OR.&
& output_fields(out_num)%kmin < LBOUND(output_fields(out_num)%buffer,3) .OR.&
& output_fields(out_num)%kmax > UBOUND(output_fields(out_num)%buffer,3) ) THEN
WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),&
& TRIM(output_fields(out_num)%output_name)
error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : '
WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1)
WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1)
WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2)
WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2)
WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3)
WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3)
WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin
WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax
WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin
WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax
WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin
WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax
err_msg = 'module/output_field='//TRIM(error_string1)//&
& ' Bounds of buffer exceeded. '//TRIM(error_string2)
! imax, imin, etc need to be reset in case the program is not terminated.
output_fields(out_num)%imax = 0
output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH
output_fields(out_num)%jmax = 0
output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH
output_fields(out_num)%kmax = 0
output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH
ELSE
err_msg = ''
END IF
END SUBROUTINE check_out_of_bounds
!
!
!
! Check if the array indices for output_fields(out_num) are equal to the output_fields(out_num)%buffer
! upper and lower bounds.
!
!
! SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
!
!
! check_bounds_are_exact_dynamic checks if the min and max array indices for output_fields(out_num) are
! equal to the upper and lower bounds of output_fields(out_num)%buffer. This check is only performed if
! output_fields(out_num)%Time_of_prev_field_data doesn't equal Time or Time_zero.
! check_bounds_are_exact_dynamic returns an error string if the array indices do not match the buffer bounds.
!
!
! Output field ID number.
!
!
! Input field ID number.
!
!
! Time to use in check. The check is only performed if output_fields(out_num)%Time_of_prev_field_data is not
! equal to Time or Time_zero.
!
!
! Return status of check_bounds_are_exact_dynamic. An empty error string indicates the x, y, and z indices are
! equal to the buffer array boundaries.
!
SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg)
INTEGER, INTENT(in) :: out_num, diag_field_id
TYPE(time_type), INTENT(in) :: Time
CHARACTER(len=*), INTENT(out) :: err_msg
CHARACTER(len=128) :: error_string1, error_string2
LOGICAL :: do_check
err_msg = ''
! Check bounds only when the value of Time changes. When windows are used,
! a change in Time indicates that a new loop through the windows has begun,
! so a check of the previous loop can be done.
IF ( Time == output_fields(out_num)%Time_of_prev_field_data ) THEN
do_check = .FALSE.
ELSE
IF ( output_fields(out_num)%Time_of_prev_field_data == Time_zero ) THEN
! It may or may not be OK to check, I don't know how to tell.
! Check will be done on subsequent calls anyway.
do_check = .FALSE.
ELSE
do_check = .TRUE.
END IF
output_fields(out_num)%Time_of_prev_field_data = Time
END IF
IF ( do_check ) THEN
IF ( output_fields(out_num)%imin /= LBOUND(output_fields(out_num)%buffer,1) .OR.&
& output_fields(out_num)%imax /= UBOUND(output_fields(out_num)%buffer,1) .OR.&
& output_fields(out_num)%jmin /= LBOUND(output_fields(out_num)%buffer,2) .OR.&
& output_fields(out_num)%jmax /= UBOUND(output_fields(out_num)%buffer,2) .OR.&
& output_fields(out_num)%kmin /= LBOUND(output_fields(out_num)%buffer,3) .OR.&
& output_fields(out_num)%kmax /= UBOUND(output_fields(out_num)%buffer,3) ) THEN
WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),&
& TRIM(output_fields(out_num)%output_name)
error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : '
WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1)
WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1)
WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2)
WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2)
WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3)
WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3)
WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin
WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax
WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin
WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax
WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin
WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax
err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2)
END IF
output_fields(out_num)%imax = 0
output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH
output_fields(out_num)%jmax = 0
output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH
output_fields(out_num)%kmax = 0
output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH
END IF
END SUBROUTINE check_bounds_are_exact_dynamic
!
!
!
! Check if the array indices for output_fields(out_num) are equal to the output_fields(out_num)%buffer
! upper and lower bounds.
!
!
! SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
!
!
!
! Output field ID
! Input field ID.
!
SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg)
INTEGER, INTENT(in) :: out_num, diag_field_id
CHARACTER(len=*), INTENT(out) :: err_msg
CHARACTER(len=128) :: error_string1, error_string2
err_msg = ''
IF ( output_fields(out_num)%imin /= LBOUND(output_fields(out_num)%buffer,1) .OR.&
& output_fields(out_num)%imax /= UBOUND(output_fields(out_num)%buffer,1) .OR.&
& output_fields(out_num)%jmin /= LBOUND(output_fields(out_num)%buffer,2) .OR.&
& output_fields(out_num)%jmax /= UBOUND(output_fields(out_num)%buffer,2) .OR.&
& output_fields(out_num)%kmin /= LBOUND(output_fields(out_num)%buffer,3) .OR.&
& output_fields(out_num)%kmax /= UBOUND(output_fields(out_num)%buffer,3) ) THEN
WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),&
& TRIM(output_fields(out_num)%output_name)
error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : '
WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1)
WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1)
WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2)
WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2)
WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3)
WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3)
WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin
WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax
WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin
WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax
WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin
WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax
err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2)
END IF
output_fields(out_num)%imax = 0
output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH
output_fields(out_num)%jmax = 0
output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH
output_fields(out_num)%kmax = 0
output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH
END SUBROUTINE check_bounds_are_exact_static
!
!
!
! Initialize the output file.
!
!
! SUBROUTINE 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)
!
!
! Initialize the output file.
!
! File name.
! How often data is to be written to the file.
! The output frequency unit. (MIN, HOURS, DAYS, etc.)
! Number type/kind the data is to be written out to the file.
! Time axis units.
! Long name for time axis.
! Tile number.
! How often a new file is to be created.
! The new file frequency unit. (MIN, HOURS, DAYS, etc.)
! Time when the file is to start
! How long file is to be used.
! File duration unit. (MIN, HOURS, DAYS, etc.)
SUBROUTINE 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)
CHARACTER(len=*), INTENT(in) :: name, long_name
INTEGER, INTENT(in) :: output_freq, output_units, format, time_units
INTEGER, INTENT(in) :: tile_count
INTEGER, INTENT(in), OPTIONAL :: new_file_freq, new_file_freq_units
INTEGER, INTENT(in), OPTIONAL :: file_duration, file_duration_units
TYPE(time_type), INTENT(in), OPTIONAL :: start_time
INTEGER :: new_file_freq1, new_file_freq_units1
INTEGER :: file_duration1, file_duration_units1
INTEGER :: n
LOGICAL :: same_file_err !< .FALSE. indicates that if the file name had
!! previously been registered, this new file
!! contained differences from the previous.
REAL, DIMENSION(1) :: tdata
CHARACTER(len=128) :: time_units_str
! Check if this file has already been defined
same_file_err=.FALSE. ! To indicate that if this file was previously defined
! no differences in this registration was detected.
DO n=1,num_files
IF ( TRIM(files(n)%name) == TRIM(name) ) THEN
! File is defined, check if all inputs are the same
! Start with the required parameters
IF ( files(n)%output_freq.NE.output_freq .OR.&
& files(n)%output_units.NE.output_units .OR.&
& files(n)%format.NE.format .OR.&
& files(n)%time_units.NE.time_units .OR.&
& TRIM(files(n)%long_name).NE.TRIM(long_name) .OR.&
& files(n)%tile_count.NE.tile_count ) THEN
same_file_err=.TRUE.
END IF
! Now check the OPTIONAL parameters
IF ( PRESENT(new_file_freq) ) THEN
IF ( files(n)%new_file_freq.NE.new_file_freq ) THEN
same_file_err=.TRUE.
END IF
END IF
IF ( PRESENT(new_file_freq_units) ) THEN
IF ( files(n)%new_file_freq_units.NE.new_file_freq_units ) THEN
same_file_err=.TRUE.
END IF
END IF
IF ( PRESENT(start_time) ) THEN
IF ( files(n)%start_time==start_time ) THEN
same_file_err=.TRUE.
END IF
END IF
IF ( PRESENT(file_duration) ) THEN
IF ( files(n)%duration.NE.file_duration) THEN
same_file_err=.TRUE.
END IF
END IF
IF ( PRESENT(file_duration_units) ) THEN
IF ( files(n)%duration_units.NE.file_duration_units ) THEN
same_file_err=.TRUE.
END IF
END IF
! If the same file was defined twice, simply return, else FATAL
IF ( same_file_err ) THEN
! Something in this file is not identical to the previously defined
! file of the same name. FATAL
CALL error_mesg('diag_util_mod::init_file',&
& 'The file "'//TRIM(name)//'" is defined multiple times in&
& the diag_table.', FATAL)
ELSE
! Issue a note that the same file is defined multiple times
CALL error_mesg('diag_util_mod::init_file',&
& 'The file "'//TRIM(name)//'" is defined multiple times in&
& the diag_table.', NOTE)
! Return to the calling function
RETURN
END IF
END IF
END DO
! Get a number for this file
num_files = num_files + 1
IF ( num_files >= max_files ) THEN
!
! max_files exceeded, increase max_files via the max_files variable
! in the namelist diag_manager_nml.
!
CALL error_mesg('diag_util_mod::init_file',&
& ' max_files exceeded, increase max_files via the max_files variable&
& in the namelist diag_manager_nml.', FATAL)
END IF
IF ( PRESENT(new_file_freq) ) THEN
new_file_freq1 = new_file_freq
ELSE
new_file_freq1 = VERY_LARGE_FILE_FREQ
END IF
IF ( PRESENT(new_file_freq_units) ) THEN
new_file_freq_units1 = new_file_freq_units
ELSE IF ( get_calendar_type() == NO_CALENDAR ) THEN
new_file_freq_units1 = DIAG_DAYS
ELSE
new_file_freq_units1 = DIAG_YEARS
END IF
IF ( PRESENT(file_duration) ) THEN
file_duration1 = file_duration
ELSE
file_duration1 = new_file_freq1
END IF
IF ( PRESENT(file_duration_units) ) THEN
file_duration_units1 = file_duration_units
ELSE
file_duration_units1 = new_file_freq_units1
END IF
files(num_files)%tile_count = tile_count
files(num_files)%name = TRIM(name)
files(num_files)%output_freq = output_freq
files(num_files)%output_units = output_units
files(num_files)%format = FORMAT
files(num_files)%time_units = time_units
files(num_files)%long_name = TRIM(long_name)
files(num_files)%num_fields = 0
files(num_files)%local = .FALSE.
files(num_files)%last_flush = base_time
files(num_files)%file_unit = -1
files(num_files)%new_file_freq = new_file_freq1
files(num_files)%new_file_freq_units = new_file_freq_units1
files(num_files)%duration = file_duration1
files(num_files)%duration_units = file_duration_units1
IF ( PRESENT(start_time) ) THEN
files(num_files)%start_time = start_time
ELSE
files(num_files)%start_time = base_time
END IF
files(num_files)%next_open=diag_time_inc(files(num_files)%start_time,new_file_freq1,new_file_freq_units1)
files(num_files)%close_time = diag_time_inc(files(num_files)%start_time,file_duration1, file_duration_units1)
IF ( files(num_files)%close_time>files(num_files)%next_open ) THEN
!
! close time GREATER than next_open time, check file duration,
! file frequency in
!
CALL error_mesg('diag_util_mod::init_file', 'close time GREATER than next_open time, check file duration,&
& file frequency in '//files(num_files)%name, FATAL)
END IF
! add time_axis_id and time_bounds_id here
WRITE(time_units_str, 11) TRIM(time_unit_list(files(num_files)%time_units)), base_year,&
& base_month, base_day, base_hour, base_minute, base_second
11 FORMAT(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
files(num_files)%time_axis_id = diag_axis_init (TRIM(long_name), tdata, time_units_str, 'T',&
& TRIM(long_name) , set_name=TRIM(name) )
!---- register axis for storing time boundaries
files(num_files)%time_bounds_id = diag_axis_init( 'nv',(/1.,2./),'none','N','vertex number',&
& set_name='nv')
END SUBROUTINE init_file
!
!
!
! Synchronize the file's start and close times with the model start and end times.
!
!
! SUBROUTINE sync_file_times(init_time)
!
!
! sync_file_times checks to see if the file start time is less than the
! model's init time (passed in as the only argument). If it is less, then the
! both the file start time and end time are synchronized using the passed in initial time
! and the duration as calculated by the diag_time_inc function. sync_file_times
! will also increase the next_open until it is greater than the init_time.
!
! The file ID
! Initial time use for the synchronization.
! Return error message
SUBROUTINE sync_file_times(file_id, init_time, err_msg)
INTEGER, INTENT(in) :: file_id
TYPE(time_type), INTENT(in) :: init_time
CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg
CHARACTER(len=128) :: msg
IF ( PRESENT(err_msg) ) err_msg = ''
IF ( files(file_id)%start_time < init_time ) THEN
! Sync the start_time of the file with the initial time of the model
files(file_id)%start_time = init_time
! Sync the file's close time also
files(file_id)%close_time = diag_time_inc(files(file_id)%start_time,&
& files(file_id)%duration, files(file_id)%duration_units)
END IF
! Need to increase next_open until it is greate than init_time
DO WHILE ( files(file_id)%next_open <= init_time )
files(file_id)%next_open = diag_time_inc(files(file_id)%next_open,&
& files(file_id)%new_file_freq, files(file_id)%new_file_freq_units, err_msg=msg)
IF ( msg /= '' ) THEN
IF ( fms_error_handler('diag_util_mod::sync_file_times',&
& ' file='//TRIM(files(file_id)%name)//': '//TRIM(msg), err_msg) ) RETURN
END IF
END DO
END SUBROUTINE sync_file_times
!
!
!
! Return the next time data/file is to be written based on the frequency and units.
!
!
! TYPE(time_type) FUNCTION diag_time_inc(time, output_freq, output_units, err_msg)
!
!
! Return the next time data/file is to be written. This value is based on the current time and the frequency and units.
! Function completed successful if the optional err_msg is empty.
!
! Current model time.
! Output frequency number value.
! Output frequency unit.
!
! Function error message. An empty string indicates the next output time was found successfully.
!
TYPE(time_type) FUNCTION diag_time_inc(time, output_freq, output_units, err_msg)
TYPE(time_type), INTENT(in) :: time
INTEGER, INTENT(in):: output_freq, output_units
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
CHARACTER(len=128) :: error_message_local
IF ( PRESENT(err_msg) ) err_msg = ''
error_message_local = ''
! special values for output frequency are -1 for output at end of run
! and 0 for every timestep. Need to check for these here?
! Return zero time increment, hopefully this value is never used
IF ( output_freq == END_OF_RUN .OR. output_freq == EVERY_TIME ) THEN
diag_time_inc = time
RETURN
END IF
! Make sure calendar was not set after initialization
IF ( output_units == DIAG_SECONDS ) THEN
IF ( get_calendar_type() == NO_CALENDAR ) THEN
diag_time_inc = increment_time(time, output_freq, 0, err_msg=error_message_local)
ELSE
diag_time_inc = increment_date(time, 0, 0, 0, 0, 0, output_freq, err_msg=error_message_local)
END IF
ELSE IF ( output_units == DIAG_MINUTES ) THEN
IF ( get_calendar_type() == NO_CALENDAR ) THEN
diag_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_MINUTE), 0, &
&err_msg=error_message_local)
ELSE
diag_time_inc = increment_date(time, 0, 0, 0, 0, output_freq, 0, err_msg=error_message_local)
END IF
ELSE IF ( output_units == DIAG_HOURS ) THEN
IF ( get_calendar_type() == NO_CALENDAR ) THEN
diag_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_HOUR), 0, err_msg=error_message_local)
ELSE
diag_time_inc = increment_date(time, 0, 0, 0, output_freq, 0, 0, err_msg=error_message_local)
END IF
ELSE IF ( output_units == DIAG_DAYS ) THEN
IF (get_calendar_type() == NO_CALENDAR) THEN
diag_time_inc = increment_time(time, 0, output_freq, err_msg=error_message_local)
ELSE
diag_time_inc = increment_date(time, 0, 0, output_freq, 0, 0, 0, err_msg=error_message_local)
END IF
ELSE IF ( output_units == DIAG_MONTHS ) THEN
IF (get_calendar_type() == NO_CALENDAR) THEN
error_message_local = 'output units of months NOT allowed with no calendar'
ELSE
diag_time_inc = increment_date(time, 0, output_freq, 0, 0, 0, 0, err_msg=error_message_local)
END IF
ELSE IF ( output_units == DIAG_YEARS ) THEN
IF ( get_calendar_type() == NO_CALENDAR ) THEN
error_message_local = 'output units of years NOT allowed with no calendar'
ELSE
diag_time_inc = increment_date(time, output_freq, 0, 0, 0, 0, 0, err_msg=error_message_local)
END IF
ELSE
error_message_local = 'illegal output units'
END IF
IF ( error_message_local /= '' ) THEN
IF ( fms_error_handler('diag_time_inc',error_message_local,err_msg) ) RETURN
END IF
END FUNCTION diag_time_inc
!
!
!
!
! Return the file number for file name and tile.
!
!
! INTEGER FUNCTION fild_file(name, time_count)
!
!
! Find the file number for the file name and tile number given. A return value of -1 indicates the file was not found.
!
! File name.
! Tile number.
INTEGER FUNCTION find_file(name, tile_count)
INTEGER, INTENT(in) :: tile_count
CHARACTER(len=*), INTENT(in) :: name
INTEGER :: i
find_file = -1
DO i = 1, num_files
IF( TRIM(files(i)%name) == TRIM(name) .AND. tile_count == files(i)%tile_count ) THEN
find_file = i
RETURN
END IF
END DO
END FUNCTION find_file
!
!
!
!
! Return the field number for the given module name, field name, and tile number.
!
!
! INTEGER FUNCTION find_input_field(module_name, field_name, tile_count)
!
!
! Return the field number for the given module name, field name and tile number. A return value of -1 indicates
! the field was not found.
!
! Module name.
! field name.
! Tile number.
INTEGER FUNCTION find_input_field(module_name, field_name, tile_count)
CHARACTER(len=*), INTENT(in) :: module_name, field_name
INTEGER, INTENT(in) :: tile_count
INTEGER :: i
find_input_field = DIAG_FIELD_NOT_FOUND ! Default return value if not found.
DO i = 1, num_input_fields
IF(tile_count == input_fields(i)%tile_count .AND.&
& TRIM(input_fields(i)%module_name) == TRIM(module_name) .AND.&
& lowercase(TRIM(input_fields(i)%field_name)) == lowercase(TRIM(field_name))) THEN
find_input_field = i
RETURN
END IF
END DO
END FUNCTION find_input_field
!
!
!
! Initialize the input field.
!
!
! SUBROUTINE init_input_field(module_name, field_name, tile_count)
!
! Initialize the input field.
!
!
! Module name.
! Input field name.
! Tile number.
SUBROUTINE init_input_field(module_name, field_name, tile_count)
CHARACTER(len=*), INTENT(in) :: module_name, field_name
INTEGER, INTENT(in) :: tile_count
! Get a number for this input_field if not already set up
IF ( find_input_field(module_name, field_name, tile_count) < 0 ) THEN
num_input_fields = num_input_fields + 1
IF ( num_input_fields > max_input_fields ) THEN
! max_input_fields exceeded, increase it via diag_manager_nml
CALL error_mesg('diag_util_mod::init_input_field',&
& 'max_input_fields exceeded, increase it via diag_manager_nml', FATAL)
END IF
ELSE
! If this is already initialized do not need to do anything
RETURN
END IF
input_fields(num_input_fields)%module_name = TRIM(module_name)
input_fields(num_input_fields)%field_name = TRIM(field_name)
input_fields(num_input_fields)%num_output_fields = 0
! Set flag that this field has not been registered
input_fields(num_input_fields)%register = .FALSE.
input_fields(num_input_fields)%local = .FALSE.
input_fields(num_input_fields)%standard_name = 'none'
input_fields(num_input_fields)%tile_count = tile_count
input_fields(num_input_fields)%numthreads = 1
input_fields(num_input_fields)%active_omp_level = 0
input_fields(num_input_fields)%time = time_zero
END SUBROUTINE init_input_field
!
!
!
! Initialize the output field.
!
!
! SUBROUTINE init_output_field(module_name, field_name, output_name, output_file
! time_method, pack, tile_count, local_coord)
!
!
! Initialize the output field.
!
! Module name.
! Output field name.
! Output name written to file.
! File where field should be written.
!
! Data reduction method. See diag_manager_mod for valid methods.
! Packing method.
! Tile number.
! Region to be written. If missing, then all data to be written.
SUBROUTINE init_output_field(module_name, field_name, output_name, output_file,&
& time_method, pack, tile_count, local_coord)
CHARACTER(len=*), INTENT(in) :: module_name, field_name, output_name, output_file
CHARACTER(len=*), INTENT(in) :: time_method
INTEGER, INTENT(in) :: pack
INTEGER, INTENT(in) :: tile_count
TYPE(coord_type), INTENT(in), OPTIONAL :: local_coord
INTEGER :: out_num, in_num, file_num, file_num_tile1
INTEGER :: num_fields, i, method_selected, l1
INTEGER :: ioerror
REAL :: pow_value
INTEGER :: grv !< Value used to determine if the region defined in the diag_table is for the whole axis, or a sub-axis
CHARACTER(len=128) :: error_msg
CHARACTER(len=50) :: t_method
character(len=256) :: tmp_name
! Value to use to determine if a region is to be output on the full axis, or sub-axis
! get the value to compare to determine if writing full axis data
IF ( region_out_use_alt_value ) THEN
grv = GLO_REG_VAL_ALT
ELSE
grv = GLO_REG_VAL
END IF
! Get a number for this output field
num_output_fields = num_output_fields + 1
IF ( num_output_fields > max_output_fields ) THEN
! max_output_fields = exceeded. Increase via diag_manager_nml
WRITE (UNIT=error_msg,FMT=*) max_output_fields
CALL error_mesg('diag_util_mod::init_output_field', 'max_output_fields = '//TRIM(error_msg)//' exceeded.&
& Increase via diag_manager_nml', FATAL)
END IF
out_num = num_output_fields
! First, find the index to the associated input field
in_num = find_input_field(module_name, field_name, tile_count)
IF ( in_num < 0 ) THEN
IF ( tile_count > 1 ) THEN
WRITE (error_msg,'(A,"/",A,"/",A)') TRIM(module_name),TRIM(field_name),&
& "tile_count="//TRIM(string(tile_count))
ELSE
WRITE (error_msg,'(A,"/",A)') TRIM(module_name),TRIM(field_name)
END IF
! module_name/field_name /[/tile_count=] NOT registered
CALL error_mesg('diag_util_mod::init_output_field',&
& 'module_name/field_name '//TRIM(error_msg)//' NOT registered', FATAL)
END IF
! Add this output field into the list for this input field
input_fields(in_num)%num_output_fields =&
& input_fields(in_num)%num_output_fields + 1
IF ( input_fields(in_num)%num_output_fields > max_out_per_in_field ) THEN
!
! MAX_OUT_PER_IN_FIELD = exceeded for /, increase MAX_OUT_PER_IN_FIELD
! in the diag_manager_nml namelist.
!
WRITE (UNIT=error_msg,FMT=*) MAX_OUT_PER_IN_FIELD
CALL error_mesg('diag_util_mod::init_output_field',&
& 'MAX_OUT_PER_IN_FIELD exceeded for '//TRIM(module_name)//"/"//TRIM(field_name)//&
&', increase MAX_OUT_PER_IN_FIELD in the diag_manager_nml namelist', FATAL)
END IF
input_fields(in_num)%output_fields(input_fields(in_num)%num_output_fields) = out_num
! Also put pointer to input field in this output field
output_fields(out_num)%input_field = in_num
! Next, find the number for the corresponding file
IF ( TRIM(output_file).EQ.'null' ) THEN
file_num = max_files
ELSE
file_num = find_file(output_file, 1)
IF ( file_num < 0 ) THEN
!
! file is NOT found in the diag_table.
!
CALL error_mesg('diag_util_mod::init_output_field', 'file '&
& //TRIM(output_file)//' is NOT found in the diag_table', FATAL)
END IF
IF ( tile_count > 1 ) THEN
file_num_tile1 = file_num
file_num = find_file(output_file, tile_count)
IF(file_num < 0) THEN
CALL init_file(files(file_num_tile1)%name, files(file_num_tile1)%output_freq,&
& files(file_num_tile1)%output_units, files(file_num_tile1)%format,&
& files(file_num_tile1)%time_units, files(file_num_tile1)%long_name,&
& tile_count, files(file_num_tile1)%new_file_freq,&
& files(file_num_tile1)%new_file_freq_units, files(file_num_tile1)%start_time,&
& files(file_num_tile1)%duration, files(file_num_tile1)%duration_units )
file_num = find_file(output_file, tile_count)
IF ( file_num < 0 ) THEN
!
! file is not initialized for tile_count =
!
CALL error_mesg('diag_util_mod::init_output_field', 'file '//TRIM(output_file)//&
& ' is not initialized for tile_count = '//TRIM(string(tile_count)), FATAL)
END IF
END IF
END IF
END IF
! Insert this field into list for this file
files(file_num)%num_fields = files(file_num)%num_fields + 1
IF ( files(file_num)%num_fields > MAX_FIELDS_PER_FILE ) THEN
WRITE (UNIT=error_msg, FMT=*) MAX_FIELDS_PER_FILE
!
! MAX_FIELDS_PER_FILE = exceeded. Increase MAX_FIELDS_PER_FILE in diag_data.F90.
!
CALL error_mesg('diag_util_mod::init_output_field',&
& 'MAX_FIELDS_PER_FILE = '//TRIM(error_msg)//' exceeded. Increase MAX_FIELDS_PER_FILE in diag_data.F90.', FATAL)
END IF
num_fields = files(file_num)%num_fields
files(file_num)%fields(num_fields) = out_num
! Set the file for this output field
output_fields(out_num)%output_file = file_num
! Enter the other data for this output field
output_fields(out_num)%output_name = TRIM(output_name)
output_fields(out_num)%pack = pack
output_fields(out_num)%pow_value = 1
output_fields(out_num)%num_axes = 0
output_fields(out_num)%total_elements = 0
output_fields(out_num)%region_elements = 0
output_fields(out_num)%imax = 0
output_fields(out_num)%jmax = 0
output_fields(out_num)%kmax = 0
output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH
output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH
output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH
! initialize the size of the diurnal axis to 1
output_fields(out_num)%n_diurnal_samples = 1
! Initialize all time method to false
method_selected = 0
output_fields(out_num)%time_average = .FALSE.
output_fields(out_num)%time_rms = .FALSE.
output_fields(out_num)%time_min = .FALSE.
output_fields(out_num)%time_max = .FALSE.
output_fields(out_num)%time_sum = .FALSE.
output_fields(out_num)%time_ops = .FALSE.
output_fields(out_num)%written_once = .FALSE.
t_method = lowercase(time_method)
! cannot time average fields output every time
IF ( files(file_num)%output_freq == EVERY_TIME ) THEN
output_fields(out_num)%time_average = .FALSE.
method_selected = method_selected+1
t_method = 'point'
ELSEIF ( INDEX(t_method,'diurnal') == 1 ) THEN
! get the integer number from the t_method
READ (UNIT=t_method(8:LEN_TRIM(t_method)), FMT=*, IOSTAT=ioerror) output_fields(out_num)%n_diurnal_samples
IF ( ioerror /= 0 ) THEN
!
! could not find integer number of diurnal samples in string ""
!
CALL error_mesg('diag_util_mod::init_output_field',&
& 'could not find integer number of diurnal samples in string "' //TRIM(t_method)//'"', FATAL)
ELSE IF ( output_fields(out_num)%n_diurnal_samples <= 0 ) THEN
!
! The integer value of diurnal samples must be greater than zero.
!
CALL error_mesg('diag_util_mod::init_output_field',&
& 'The integer value of diurnal samples must be greater than zero.', FATAL)
END IF
output_fields(out_num)%time_average = .TRUE.
method_selected = method_selected+1
t_method='mean'
ELSEIF ( INDEX(t_method,'pow') == 1 ) THEN
! Get the integer number from the t_method
READ (UNIT=t_method(4:LEN_TRIM(t_method)), FMT=*, IOSTAT=ioerror) pow_value
IF ( ioerror /= 0 .OR. output_fields(out_num)%pow_value < 1 .OR. FLOOR(pow_value) /= CEILING(pow_value) ) THEN
!
! Invalid power number in time operation "". Must be a positive integer.
!
CALL error_mesg('diag_util_mod::init_output_field',&
& 'Invalid power number in time operation "'//TRIM(t_method)//'". Must be a positive integer', FATAL)
END IF
output_fields(out_num)%pow_value = INT(pow_value)
output_fields(out_num)%time_average = .TRUE.
method_selected = method_selected+1
t_method = 'mean_pow('//t_method(4:LEN_TRIM(t_method))//')'
ELSE
SELECT CASE(TRIM(t_method))
CASE ( '.true.', 'mean', 'average', 'avg' )
output_fields(out_num)%time_average = .TRUE.
method_selected = method_selected+1
t_method = 'mean'
CASE ( 'rms' )
output_fields(out_num)%time_average = .TRUE.
output_fields(out_num)%time_rms = .TRUE.
output_fields(out_num)%pow_value = 2.0
method_selected = method_selected+1
t_method = 'root_mean_square'
CASE ( '.false.', 'none', 'point' )
output_fields(out_num)%time_average = .FALSE.
method_selected = method_selected+1
t_method = 'point'
CASE ( 'maximum', 'max' )
output_fields(out_num)%time_max = .TRUE.
l1 = LEN_TRIM(output_fields(out_num)%output_name)
if (l1 .ge. 3) then
tmp_name = trim(adjustl(output_fields(out_num)%output_name(l1-2:l1)))
IF (lowercase(trim(tmp_name)) /= 'max' ) then
output_fields(out_num)%output_name = TRIM(output_name)//'_max'
endif
endif
method_selected = method_selected+1
t_method = 'max'
CASE ( 'minimum', 'min' )
output_fields(out_num)%time_min = .TRUE.
l1 = LEN_TRIM(output_fields(out_num)%output_name)
if (l1 .ge. 3) then
tmp_name = trim(adjustl(output_fields(out_num)%output_name(l1-2:l1)))
IF (lowercase(trim(tmp_name)) /= 'min' ) then
output_fields(out_num)%output_name = TRIM(output_name)//'_min'
endif
endif
method_selected = method_selected+1
t_method = 'min'
CASE ( 'sum', 'cumsum' )
output_fields(out_num)%time_sum = .TRUE.
l1 = LEN_TRIM(output_fields(out_num)%output_name)
IF ( output_fields(out_num)%output_name(l1-2:l1) /= 'sum' )&
& output_fields(out_num)%output_name = TRIM(output_name)//'_sum'
method_selected = method_selected+1
t_method = 'sum'
END SELECT
END IF
! reconcile logical flags
output_fields(out_num)%time_ops = output_fields(out_num)%time_min.OR.output_fields(out_num)%time_max&
& .OR.output_fields(out_num)%time_average .OR. output_fields(out_num)%time_sum
output_fields(out_num)%phys_window = .FALSE.
! need to initialize grid_type = -1(start, end, l_start_indx,l_end_indx etc...)
IF ( PRESENT(local_coord) ) THEN
input_fields(in_num)%local = .TRUE.
input_fields(in_num)%local_coord = local_coord
IF ( INT(local_coord%xbegin) == grv .AND. INT(local_coord%xend) == grv .AND.&
& INT(local_coord%ybegin) == grv .AND. INT(local_coord%yend) == grv ) THEN
output_fields(out_num)%local_output = .FALSE.
output_fields(out_num)%need_compute = .FALSE.
output_fields(out_num)%reduced_k_range = .TRUE.
ELSE
output_fields(out_num)%local_output = .TRUE.
output_fields(out_num)%need_compute = .FALSE.
output_fields(out_num)%reduced_k_range = .FALSE.
END IF
output_fields(out_num)%output_grid%start(1) = local_coord%xbegin
output_fields(out_num)%output_grid%start(2) = local_coord%ybegin
output_fields(out_num)%output_grid%start(3) = local_coord%zbegin
output_fields(out_num)%output_grid%end(1) = local_coord%xend
output_fields(out_num)%output_grid%end(2) = local_coord%yend
output_fields(out_num)%output_grid%end(3) = local_coord%zend
DO i = 1, 3
output_fields(out_num)%output_grid%l_start_indx(i) = -1
output_fields(out_num)%output_grid%l_end_indx(i) = -1
output_fields(out_num)%output_grid%subaxes(i) = -1
END DO
ELSE
output_fields(out_num)%local_output = .FALSE.
output_fields(out_num)%need_compute = .FALSE.
output_fields(out_num)%reduced_k_range = .FALSE.
END IF
!
! improper time method in diag_table for output field
!
IF ( method_selected /= 1 ) CALL error_mesg('diag_util_mod::init_output_field',&
&'improper time method in diag_table for output field:'//TRIM(output_name),FATAL)
output_fields(out_num)%time_method = TRIM(t_method)
! allocate counters: NOTE that for simplicity we always allocate them, even
! if they are superceeded by 4D "counter" array. This isn't most memory
! efficient, approach, but probably tolerable since they are so small anyway
ALLOCATE(output_fields(out_num)%count_0d(output_fields(out_num)%n_diurnal_samples))
ALLOCATE(output_fields(out_num)%num_elements(output_fields(out_num)%n_diurnal_samples))
output_fields(out_num)%count_0d(:) = 0
output_fields(out_num)%num_elements(:) = 0
output_fields(out_num)%num_attributes = 0
END SUBROUTINE init_output_field
!
!
!
!
! Open file for output.
!
!
! SUBROUTINE opening_file(file, time)
!
!
! Open file for output, and write the meta data. Warning: Assumes all data structures have been fully initialized.
!
! File ID.
! Time for the file time stamp
SUBROUTINE opening_file(file, time)
! WARNING: Assumes that all data structures are fully initialized
INTEGER, INTENT(in) :: file
TYPE(time_type), INTENT(in) :: time
REAL, DIMENSION(2) :: DATA
INTEGER :: j, field_num, input_field_num, num_axes, k
INTEGER :: field_num1
INTEGER :: position
INTEGER :: dir, edges
INTEGER :: ntileMe
INTEGER :: year, month, day, hour, minute, second
INTEGER, ALLOCATABLE :: tile_id(:)
INTEGER, DIMENSION(1) :: time_axis_id, time_bounds_id
! size of this axes array must be at least max num. of
! axes per field + 2; the last two elements are for time
! and time bounds dimensions
INTEGER, DIMENSION(6) :: axes
INTEGER, ALLOCATABLE :: axesc(:) ! indices if compressed axes associated with the field
LOGICAL :: time_ops, aux_present, match_aux_name, req_present, match_req_fields
LOGICAL :: all_scalar_or_1d
CHARACTER(len=7) :: prefix
CHARACTER(len=7) :: avg_name = 'average'
CHARACTER(len=128) :: time_units, timeb_units, avg, error_string, filename, aux_name, req_fields, fieldname
CHARACTER(len=128) :: suffix, base_name
CHARACTER(len=32) :: time_name, timeb_name,time_longname, timeb_longname, cart_name
CHARACTER(len=256) :: fname
CHARACTER(len=24) :: start_date
TYPE(domain1d) :: domain
TYPE(domain2d) :: domain2
TYPE(domainUG) :: domainU
INTEGER :: is, ie, last, ind
aux_present = .FALSE.
match_aux_name = .FALSE.
req_present = .FALSE.
match_req_fields = .FALSE.
! Here is where time_units string must be set up; time since base date
WRITE (time_units, 11) TRIM(time_unit_list(files(file)%time_units)), base_year,&
& base_month, base_day, base_hour, base_minute, base_second
11 FORMAT(A, ' since ', I4.4, '-', I2.2, '-', I2.2, ' ', I2.2, ':', I2.2, ':', I2.2)
base_name = files(file)%name
IF ( files(file)%new_file_freq < VERY_LARGE_FILE_FREQ ) THEN
position = INDEX(files(file)%name, '%')
IF ( position > 0 ) THEN
base_name = base_name(1:position-1)
ELSE
!
! filename does not contain % for time stamp string
!
CALL error_mesg('diag_util_mod::opening_file',&
& 'file name '//TRIM(files(file)%name)//' does not contain % for time stamp string', FATAL)
END IF
suffix = get_time_string(files(file)%name, time)
ELSE
suffix = ' '
END IF
! Add ensemble ID to filename
fname=base_name
call get_instance_filename(fname, base_name)
! Set the filename
filename = TRIM(base_name)//TRIM(suffix)
! prepend the file start date if prepend_date == .TRUE.
IF ( prepend_date ) THEN
call get_date(diag_init_time, year, month, day, hour, minute, second)
write (start_date, '(1I20.4, 2I2.2)') year, month, day
filename = TRIM(adjustl(start_date))//'.'//TRIM(filename)
END IF
! Loop through all fields with this file to output axes
! JWD: This is a klooge; need something more robust
domain2 = NULL_DOMAIN2D
domainU = NULL_DOMAINUG
all_scalar_or_1d = .TRUE.
DO j = 1, files(file)%num_fields
field_num = files(file)%fields(j)
if (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) CYCLE
num_axes = output_fields(field_num)%num_axes
IF ( num_axes > 1 ) THEN
all_scalar_or_1d = .FALSE.
domain2 = get_domain2d ( output_fields(field_num)%axes(1:num_axes) )
domainU = get_domainUG ( output_fields(field_num)%axes(1) )
IF ( domain2 .NE. NULL_DOMAIN2D ) EXIT
ELSEIF (num_axes == 1) THEN
if (domainU .EQ. null_domainUG) then
domainU = get_domainUG ( output_fields(field_num)%axes(num_axes) )
endif
END IF
END DO
IF (.NOT. all_scalar_or_1d) THEN
IF (domainU .NE. null_domainUG .AND. domain2 .NE. null_domain2D) THEN
CALL error_mesg('diag_util_mod::opening_file', &
'Domain2 and DomainU are somehow both set.', &
FATAL)
ELSEIF (domainU .EQ. null_domainUG) THEN
IF (domain2 .EQ. NULL_DOMAIN2D) THEN
CALL return_domain(domain2)
ENDIF
IF (domain2 .EQ. NULL_DOMAIN2D) THEN
!Fix for the corner-case when you have a file that contains
!2D field(s) that is not associated with a domain tile, as
!is usually assumed.
!This is very confusing, but I will try to explain. The
!all_scalar_or_1d flag determines if the file name is associated
!with a domain (i.e. has ".tilex." in the file name). A value
!of .FALSE. for the all_scalar_or_1d flag signals that the
!file name is associated with a domain tile. Normally,
!files that contain at least one two-dimensional field are
!assumed to be associated with a specific domain tile, and
!thus have the value of the all_scalar_or_1d flag set to
!.FALSE. It is possible, however, to have a file that contains
!two-dimensional fields that is not associated with a domain tile
!(i.e., if you make it into this branch.). If that is the
!case, then reset the all_scalar_or_1d flag back to .TRUE.
!Got that?
all_scalar_or_1d = .TRUE.
ELSE
ntileMe = mpp_get_current_ntile(domain2)
ALLOCATE(tile_id(ntileMe))
tile_id = mpp_get_tile_id(domain2)
fname = TRIM(filename)
IF ( mpp_get_ntile_count(domain2) > 1 ) THEN
CALL get_tile_string(filename, TRIM(fname)//'.tile' , tile_id(files(file)%tile_count))
ELSEIF ( tile_id(1) > 1 ) then
CALL get_tile_string(filename, TRIM(fname)//'.tile' , tile_id(1))
ENDIF
DEALLOCATE(tile_id)
ENDIF
ENDIF
ENDIF
IF ( domainU .ne. null_domainUG) then
! ntileMe = mpp_get_UG_current_ntile(domainU)
! ALLOCATE(tile_id(ntileMe))
! tile_id = mpp_get_UG_tile_id(domainU)
! fname = TRIM(filename)
! ntiles = mpp_get_UG_domain_ntiles(domainU)
! my_tile_id = mpp_get_UG_domain_tile_id(domainU)
! CALL get_tile_string(filename, TRIM(fname)//'.tile' , tile_id(files(file)%tile_count))
! DEALLOCATE(tile_id)
fname = TRIM(filename)
CALL get_mosaic_tile_file_ug(fname,filename,domainU)
ENDIF
IF ( _ALLOCATED(files(file)%attributes) ) THEN
CALL diag_output_init(filename, files(file)%format, global_descriptor,&
& files(file)%file_unit, all_scalar_or_1d, domain2, domainU,&
& attributes=files(file)%attributes(1:files(file)%num_attributes))
ELSE
CALL diag_output_init(filename, files(file)%format, global_descriptor,&
& files(file)%file_unit, all_scalar_or_1d, domain2,domainU)
END IF
files(file)%bytes_written = 0
! Does this file contain time_average fields?
time_ops = .FALSE.
DO j = 1, files(file)%num_fields
field_num = files(file)%fields(j)
IF ( output_fields(field_num)%time_ops ) THEN
time_ops = .TRUE.
EXIT
END IF
END DO
! Loop through all fields with this file to output axes
DO j = 1, files(file)%num_fields
field_num = files(file)%fields(j)
input_field_num = output_fields(field_num)%input_field
IF (.NOT.input_fields(input_field_num)%register) THEN
WRITE (error_string,'(A,"/",A)') TRIM(input_fields(input_field_num)%module_name),&
& TRIM(input_fields(input_field_num)%field_name)
IF(mpp_pe() .EQ. mpp_root_pe()) THEN
!
! module/field_name (/)
! NOT registered
!
CALL error_mesg('diag_util_mod::opening_file',&
& 'module/field_name ('//TRIM(error_string)//') NOT registered', WARNING)
END IF
CYCLE
END IF
if (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) CYCLE
! Put the time axis in the axis field
num_axes = output_fields(field_num)%num_axes
axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
! make sure that axis_id are not -1
DO k = 1, num_axes
IF ( axes(k) < 0 ) THEN
WRITE(error_string,'(a)') output_fields(field_num)%output_name
!
! ouptut_name has axis_id = -1
!
CALL error_mesg('diag_util_mod::opening_file','output_name '//TRIM(error_string)//&
& ' has axis_id = -1', FATAL)
END IF
END DO
! check if aux is present in any axes
IF ( .NOT.aux_present ) THEN
DO k = 1, num_axes
aux_name = get_axis_aux(axes(k))
IF ( TRIM(aux_name) /= 'none' ) THEN
aux_present = .TRUE.
EXIT
END IF
END DO
END IF
! check if required fields are present in any axes
IF ( .NOT.req_present ) THEN
DO k = 1, num_axes
req_fields = get_axis_reqfld(axes(k))
IF ( TRIM(req_fields) /= 'none' ) THEN
CALL error_mesg('diag_util_mod::opening_file','required fields found: '//&
&TRIM(req_fields)//' in file '//TRIM(files(file)%name),NOTE)
req_present = .TRUE.
EXIT
END IF
END DO
END IF
axes(num_axes + 1) = files(file)%time_axis_id
CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 1), time_ops)
IF ( time_ops ) THEN
axes(num_axes + 2) = files(file)%time_bounds_id
CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 2))
END IF
! write metadata for axes used in compression-by-gathering, e.g. for unstructured
! grid
DO k = 1, num_axes
IF (axis_is_compressed(axes(k))) THEN
CALL get_compressed_axes_ids(axes(k), axesc) ! returns allocatable array
CALL write_axis_meta_data(files(file)%file_unit, axesc)
DEALLOCATE(axesc)
ENDIF
ENDDO
END DO
! Looking for the first NON-static field in a file
field_num1 = files(file)%fields(1)
DO j = 1, files(file)%num_fields
field_num = files(file)%fields(j)
IF ( output_fields(field_num)%time_ops ) THEN
field_num1 = field_num
EXIT
END IF
END DO
DO j = 1, files(file)%num_fields
field_num = files(file)%fields(j)
input_field_num = output_fields(field_num)%input_field
IF (.NOT.input_fields(input_field_num)%register) CYCLE
IF (output_fields(field_num)%local_output .AND. .NOT. output_fields(field_num)%need_compute) CYCLE
! Make sure that 1 file contains either time_average or instantaneous fields
! cannot have both time_average and instantaneous in 1 file
IF ( .NOT.mix_snapshot_average_fields ) THEN
IF ( (output_fields(field_num)%time_ops.NEQV.output_fields(field_num1)%time_ops) .AND.&
& .NOT.output_fields(field_num1)%static .AND. .NOT.output_fields(field_num)%static) THEN
IF ( mpp_pe() == mpp_root_pe() ) THEN
!
! can NOT have BOTH time average AND instantaneous fields.
! Create a new file or set mix_snapshot_average_fields=.TRUE. in the namelist diag_manager_nml.
!
CALL error_mesg('diag_util_mod::opening_file','file '//&
& TRIM(files(file)%name)//' can NOT have BOTH time average AND instantaneous fields.'//&
& ' Create a new file or set mix_snapshot_average_fields=.TRUE. in the namelist diag_manager_nml.' , FATAL)
END IF
END IF
END IF
! check if any field has the same name as aux_name
IF ( aux_present .AND. .NOT.match_aux_name ) THEN
fieldname = output_fields(field_num)%output_name
IF ( INDEX(aux_name, TRIM(fieldname)) > 0 ) match_aux_name = .TRUE.
END IF
! check if any field has the same name as req_fields
IF ( req_present .AND. .NOT.match_req_fields ) THEN
fieldname = output_fields(field_num)%output_name
is = 1; last = len_trim(req_fields)
DO
ind = index(req_fields(is:last),' ')
IF (ind .eq. 0) ind = last-is+2
ie = is+(ind-2)
if (req_fields(is:ie) .EQ. trim(fieldname)) then
match_req_fields = .TRUE.
!CALL error_mesg('diag_util_mod::opening_file','matched required field: '//TRIM(fieldname),NOTE)
EXIT
END IF
is = is+ind
if (is .GT. last) EXIT
END DO
END IF
! Put the time axis in the axis field
num_axes = output_fields(field_num)%num_axes
axes(1:num_axes) = output_fields(field_num)%axes(1:num_axes)
IF ( .NOT.output_fields(field_num)%static ) THEN
num_axes=num_axes+1
axes(num_axes) = files(file)%time_axis_id
END IF
IF(output_fields(field_num)%time_average) THEN
avg = avg_name
ELSE IF(output_fields(field_num)%time_max) THEN
avg = avg_name
ELSE IF(output_fields(field_num)%time_min) THEN
avg = avg_name
ELSE
avg = " "
END IF
IF ( input_fields(input_field_num)%missing_value_present ) THEN
IF ( LEN_TRIM(input_fields(input_field_num)%interp_method) > 0 ) THEN
output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
& output_fields(field_num)%output_name, axes(1:num_axes),&
& input_fields(input_field_num)%units,&
& input_fields(input_field_num)%long_name,&
& input_fields(input_field_num)%range, output_fields(field_num)%pack,&
& input_fields(input_field_num)%missing_value, avg_name = avg,&
& time_method=output_fields(field_num)%time_method,&
& standard_name = input_fields(input_field_num)%standard_name,&
& interp_method = input_fields(input_field_num)%interp_method,&
& attributes=output_fields(field_num)%attributes,&
& num_attributes=output_fields(field_num)%num_attributes,&
& use_UGdomain=files(file)%use_domainUG)
ELSE
output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
& output_fields(field_num)%output_name, axes(1:num_axes),&
& input_fields(input_field_num)%units,&
& input_fields(input_field_num)%long_name,&
& input_fields(input_field_num)%range, output_fields(field_num)%pack,&
& input_fields(input_field_num)%missing_value, avg_name = avg,&
& time_method=output_fields(field_num)%time_method,&
& standard_name = input_fields(input_field_num)%standard_name,&
& attributes=output_fields(field_num)%attributes,&
& num_attributes=output_fields(field_num)%num_attributes,&
& use_UGdomain=files(file)%use_domainUG)
END IF
! NEED TO TAKE CARE OF TIME AVERAGING INFO TOO BOTH CASES
ELSE
IF ( LEN_TRIM(input_fields(input_field_num)%interp_method) > 0 ) THEN
output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
& output_fields(field_num)%output_name, axes(1:num_axes),&
& input_fields(input_field_num)%units,&
& input_fields(input_field_num)%long_name,&
& input_fields(input_field_num)%range, output_fields(field_num)%pack,&
& avg_name = avg,&
& time_method=output_fields(field_num)%time_method,&
& standard_name = input_fields(input_field_num)%standard_name,&
& interp_method = input_fields(input_field_num)%interp_method,&
& attributes=output_fields(field_num)%attributes,&
& num_attributes=output_fields(field_num)%num_attributes,&
& use_UGdomain=files(file)%use_domainUG)
ELSE
output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
& output_fields(field_num)%output_name, axes(1:num_axes),&
& input_fields(input_field_num)%units,&
& input_fields(input_field_num)%long_name,&
& input_fields(input_field_num)%range, output_fields(field_num)%pack,&
& avg_name = avg,&
& time_method=output_fields(field_num)%time_method,&
& standard_name = input_fields(input_field_num)%standard_name,&
& attributes=output_fields(field_num)%attributes,&
& num_attributes=output_fields(field_num)%num_attributes,&
& use_UGdomain=files(file)%use_domainUG)
END IF
END IF
END DO
! If any of the fields in the file are time averaged, need to output the axes
! Use double precision since time axis is double precision
IF ( time_ops ) THEN
time_axis_id(1) = files(file)%time_axis_id
files(file)%f_avg_start = write_field_meta_data(files(file)%file_unit,&
& avg_name // '_T1', time_axis_id, time_units,&
& "Start time for average period", pack=pack_size)
files(file)%f_avg_end = write_field_meta_data(files(file)%file_unit,&
& avg_name // '_T2', time_axis_id, time_units,&
& "End time for average period", pack=pack_size)
files(file)%f_avg_nitems = write_field_meta_data(files(file)%file_unit,&
& avg_name // '_DT', time_axis_id,&
& TRIM(time_unit_list(files(file)%time_units)),&
& "Length of average period", pack=pack_size)
END IF
IF ( time_ops ) THEN
time_axis_id(1) = files(file)%time_axis_id
time_bounds_id(1) = files(file)%time_bounds_id
CALL get_diag_axis( time_axis_id(1), time_name, time_units, time_longname,&
& cart_name, dir, edges, Domain, domainU, DATA)
CALL get_diag_axis( time_bounds_id(1), timeb_name, timeb_units, timeb_longname,&
& cart_name, dir, edges, Domain, domainU, DATA)
IF ( do_cf_compliance() ) THEN
! CF Compliance requires the unit on the _bnds axis is the same as 'time'
files(file)%f_bounds = write_field_meta_data(files(file)%file_unit,&
& TRIM(time_name)//'_bnds', (/time_bounds_id,time_axis_id/),&
& time_units, TRIM(time_name)//' axis boundaries', pack=pack_size)
ELSE
files(file)%f_bounds = write_field_meta_data(files(file)%file_unit,&
& TRIM(time_name)//'_bnds', (/time_bounds_id,time_axis_id/),&
& TRIM(time_unit_list(files(file)%time_units)),&
& TRIM(time_name)//' axis boundaries', pack=pack_size)
END IF
END IF
! Let lower levels know that all meta data has been sent
CALL done_meta_data(files(file)%file_unit)
IF( aux_present .AND. .NOT.match_aux_name ) THEN
!
! one axis has auxiliary but the corresponding field is NOT
! found in file
!
IF ( mpp_pe() == mpp_root_pe() ) CALL error_mesg('diag_util_mod::opening_file',&
&'one axis has auxiliary but the corresponding field is NOT found in file '//TRIM(files(file)%name), WARNING)
END IF
IF( req_present .AND. .NOT.match_req_fields ) THEN
!
! one axis has required fields but the corresponding field is NOT
! found in file
!
IF ( mpp_pe() == mpp_root_pe() ) CALL error_mesg('diag_util_mod::opening_file',&
&'one axis has required fields ('//trim(req_fields)//') but the '// &
&'corresponding fields are NOT found in file '//TRIM(files(file)%name), FATAL)
END IF
END SUBROUTINE opening_file
!
!
!
!
!
! This function determines a string based on current time.
! This string is used as suffix in output file name
!
!
! CHARACTER(len=128) FUNCTION get_time_string(filename, current_time)
!
!
! This function determines a string based on current time.
! This string is used as suffix in output file name
!
! File name.
! Current model time.
CHARACTER(len=128) FUNCTION get_time_string(filename, current_time)
CHARACTER(len=128), INTENT(in) :: filename
TYPE(time_type), INTENT(in) :: current_time
INTEGER :: yr1, mo1, dy1, hr1, mi1, sc1 ! get from current time
INTEGER :: yr2, dy2, hr2, mi2 ! for computing next_level time unit
INTEGER :: yr1_s, mo1_s, dy1_s, hr1_s, mi1_s, sc1_s ! actual values to write string
INTEGER :: abs_sec, abs_day ! component of current_time
INTEGER :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
INTEGER :: julian_day, i, position, len, first_percent
CHARACTER(len=1) :: width ! width of the field in format write
CHARACTER(len=10) :: format
CHARACTER(len=20) :: yr, mo, dy, hr, mi, sc ! string of current time (output)
CHARACTER(len=128) :: filetail
format = '("_",i*.*)'
CALL get_date(current_time, yr1, mo1, dy1, hr1, mi1, sc1)
len = LEN_TRIM(filename)
first_percent = INDEX(filename, '%')
filetail = filename(first_percent:len)
! compute year string
position = INDEX(filetail, 'yr')
IF ( position > 0 ) THEN
width = filetail(position-1:position-1)
yr1_s = yr1
format(7:9) = width//'.'//width
WRITE(yr, format) yr1_s
yr2 = 0
ELSE
yr = ' '
yr2 = yr1 - 1
END IF
! compute month string
position = INDEX(filetail, 'mo')
IF ( position > 0 ) THEN
width = filetail(position-1:position-1)
mo1_s = yr2*12 + mo1
format(7:9) = width//'.'//width
WRITE(mo, format) mo1_s
ELSE
mo = ' '
END IF
! compute day string
IF ( LEN_TRIM(mo) > 0 ) THEN ! month present
dy1_s = dy1
dy2 = dy1_s - 1
ELSE IF ( LEN_TRIM(yr) >0 ) THEN ! no month, year present
! compute julian day
IF ( mo1 == 1 ) THEN
dy1_s = dy1
ELSE
julian_day = 0
DO i = 1, mo1-1
julian_day = julian_day + days_per_month(i)
END DO
IF ( leap_year(current_time) .AND. mo1 > 2 ) julian_day = julian_day + 1
julian_day = julian_day + dy1
dy1_s = julian_day
END IF
dy2 = dy1_s - 1
ELSE ! no month, no year
CALL get_time(current_time, abs_sec, abs_day)
dy1_s = abs_day
dy2 = dy1_s
END IF
position = INDEX(filetail, 'dy')
IF ( position > 0 ) THEN
width = filetail(position-1:position-1)
FORMAT(7:9) = width//'.'//width
WRITE(dy, FORMAT) dy1_s
ELSE
dy = ' '
END IF
! compute hour string
IF ( LEN_TRIM(dy) > 0 ) THEN
hr1_s = hr1
ELSE
hr1_s = dy2*24 + hr1
END IF
hr2 = hr1_s
position = INDEX(filetail, 'hr')
IF ( position > 0 ) THEN
width = filetail(position-1:position-1)
format(7:9) = width//'.'//width
WRITE(hr, format) hr1_s
ELSE
hr = ' '
END IF
! compute minute string
IF ( LEN_TRIM(hr) > 0 ) THEN
mi1_s = mi1
ELSE
mi1_s = hr2*60 + mi1
END IF
mi2 = mi1_s
position = INDEX(filetail, 'mi')
IF(position>0) THEN
width = filetail(position-1:position-1)
format(7:9) = width//'.'//width
WRITE(mi, format) mi1_s
ELSE
mi = ' '
END IF
! compute second string
IF ( LEN_TRIM(mi) > 0 ) THEN
sc1_s = sc1
ELSE
sc1_s = NINT(mi2*SECONDS_PER_MINUTE) + sc1
END IF
position = INDEX(filetail, 'sc')
IF ( position > 0 ) THEN
width = filetail(position-1:position-1)
format(7:9) = width//'.'//width
WRITE(sc, format) sc1_s
ELSE
sc = ' '
ENDIF
get_time_string = TRIM(yr)//TRIM(mo)//TRIM(dy)//TRIM(hr)//TRIM(mi)//TRIM(sc)
END FUNCTION get_time_string
!
!
!
!
! Return the difference between two times in units.
!
!
! REAL FUNCTION get_date_dif(t2, t1, units)
!
!
! Calculate and return the difference between the two times given in the unit given using the function t2 - t1.
!
! Most recent time.
! Most distant time.
! Unit of return value.
REAL FUNCTION get_date_dif(t2, t1, units)
TYPE(time_type), INTENT(in) :: t2, t1
INTEGER, INTENT(in) :: units
INTEGER :: dif_seconds, dif_days
TYPE(time_type) :: dif_time
! Compute time axis label value
!
! variable t2 is less than in variable t1
!
IF ( t2 < t1 ) CALL error_mesg('diag_util_mod::get_date_dif', &
& 'in variable t2 is less than in variable t1', FATAL)
dif_time = t2 - t1
CALL get_time(dif_time, dif_seconds, dif_days)
IF ( units == DIAG_SECONDS ) THEN
get_date_dif = dif_seconds + SECONDS_PER_DAY * dif_days
ELSE IF ( units == DIAG_MINUTES ) THEN
get_date_dif = 1440 * dif_days + dif_seconds / SECONDS_PER_MINUTE
ELSE IF ( units == DIAG_HOURS ) THEN
get_date_dif = 24 * dif_days + dif_seconds / SECONDS_PER_HOUR
ELSE IF ( units == DIAG_DAYS ) THEN
get_date_dif = dif_days + dif_seconds / SECONDS_PER_DAY
ELSE IF ( units == DIAG_MONTHS ) THEN
!
! months not supported as output units
!
CALL error_mesg('diag_util_mod::get_date_dif', 'months not supported as output units', FATAL)
ELSE IF ( units == DIAG_YEARS ) THEN
!
! years not suppored as output units
!
CALL error_mesg('diag_util_mod::get_date_dif', 'years not supported as output units', FATAL)
ELSE
!
! illegal time units
!
CALL error_mesg('diag_util_mod::diag_date_dif', 'illegal time units', FATAL)
END IF
END FUNCTION get_date_dif
!
!
!
! Write data out to file.
!
!
! SUBROUTINE diag_data_out(file, field, dat, time, fianl_call_in, static_write_in)
!
!
! Write data out to file, and if necessary flush the buffers.
!
! File ID.
! Field ID.
! Data to write out.
! Current model time.
! .TRUE. if this is the last write for file.
! .TRUE. if static fields are to be written to file.
SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in)
INTEGER, INTENT(in) :: file, field
REAL, DIMENSION(:,:,:,:), INTENT(inout) :: dat
TYPE(time_type), INTENT(in) :: time
LOGICAL, OPTIONAL, INTENT(in):: final_call_in, static_write_in
LOGICAL :: final_call, do_write, static_write
INTEGER :: i, num
REAL :: dif, time_data(2, 1, 1, 1), dt_time(1, 1, 1, 1), start_dif, end_dif
do_write = .TRUE.
final_call = .FALSE.
IF ( PRESENT(final_call_in) ) final_call = final_call_in
static_write = .FALSE.
IF ( PRESENT(static_write_in) ) static_write = static_write_in
dif = get_date_dif(time, base_time, files(file)%time_units)
! get file_unit, open new file and close curent file if necessary
IF ( .NOT.static_write .OR. files(file)%file_unit < 0 ) CALL check_and_open(file, time, do_write)
IF ( .NOT.do_write ) RETURN ! no need to write data
CALL diag_field_out(files(file)%file_unit, output_fields(field)%f_type, dat, dif)
! record number of bytes written to this file
files(file)%bytes_written = files(file)%bytes_written +&
& (SIZE(dat,1)*SIZE(dat,2)*SIZE(dat,3))*(8/output_fields(field)%pack)
IF ( .NOT.output_fields(field)%written_once ) output_fields(field)%written_once = .TRUE.
! *** inserted this line because start_dif < 0 for static fields ***
IF ( .NOT.output_fields(field)%static ) THEN
start_dif = get_date_dif(output_fields(field)%last_output, base_time,files(file)%time_units)
IF ( .NOT.mix_snapshot_average_fields ) THEN
end_dif = get_date_dif(output_fields(field)%next_output, base_time, files(file)%time_units)
ELSE
end_dif = dif
END IF
END IF
! Need to write average axes out;
DO i = 1, files(file)%num_fields
num = files(file)%fields(i)
IF ( output_fields(num)%time_ops .AND. &
input_fields(output_fields(num)%input_field)%register) THEN
IF ( num == field ) THEN
! Output the axes if this is first time-averaged field
time_data(1, 1, 1, 1) = start_dif
CALL diag_field_out(files(file)%file_unit, files(file)%f_avg_start, time_data(1:1,:,:,:), dif)
time_data(2, 1, 1, 1) = end_dif
CALL diag_field_out(files(file)%file_unit, files(file)%f_avg_end, time_data(2:2,:,:,:), dif)
! Compute the length of the average
dt_time(1, 1, 1, 1) = end_dif - start_dif
CALL diag_field_out(files(file)%file_unit, files(file)%f_avg_nitems, dt_time(1:1,:,:,:), dif)
! Include boundary variable for CF compliance
CALL diag_field_out(files(file)%file_unit, files(file)%f_bounds, time_data(1:2,:,:,:), dif)
EXIT
END IF
END IF
END DO
! If write time is greater (equal for the last call) than last_flush for this file, flush it
IF ( final_call ) THEN
IF ( time >= files(file)%last_flush ) THEN
CALL diag_flush(files(file)%file_unit)
files(file)%last_flush = time
END IF
ELSE
IF ( time > files(file)%last_flush .AND. (flush_nc_files.OR.debug_diag_manager) ) THEN
CALL diag_flush(files(file)%file_unit)
files(file)%last_flush = time
END IF
END IF
END SUBROUTINE diag_data_out
!
!
!
!
! Checks if it is time to open a new file.
!
!
! SUBROUTINE check_and_open(file, time, do_write)
!
!
! Checks if it is time to open a new file. If yes, it first closes the
! current file, opens a new file and returns file_unit
! previous diag_manager_end is replaced by closing_file and output_setup by opening_file.
!
! File ID.
! Current model time.
! .TRUE. if file is expecting more data to write, .FALSE. otherwise.
SUBROUTINE check_and_open(file, time, do_write)
INTEGER, INTENT(in) :: file
TYPE(time_type), INTENT(in) :: time
LOGICAL, INTENT(out) :: do_write
IF ( time >= files(file)%start_time ) THEN
IF ( files(file)%file_unit < 0 ) THEN ! need to open a new file
CALL opening_file(file, time)
do_write = .TRUE.
ELSE
do_write = .TRUE.
IF ( time > files(file)%close_time .AND. time < files(file)%next_open ) THEN
do_write = .FALSE. ! file still open but receives NO MORE data
ELSE IF ( time > files(file)%next_open ) THEN ! need to close current file and open a new one
CALL write_static(file) ! write all static fields and close this file
CALL opening_file(file, time)
files(file)%start_time = files(file)%next_open
files(file)%close_time =&
& diag_time_inc(files(file)%start_time,files(file)%duration, files(file)%duration_units)
files(file)%next_open =&
& diag_time_inc(files(file)%next_open, files(file)%new_file_freq,&
& files(file)%new_file_freq_units)
IF ( files(file)%close_time > files(file)%next_open ) THEN
!
! has close time GREATER than next_open time,
! check file duration and frequency
!
CALL error_mesg('diag_util_mod::check_and_open',&
& files(file)%name//' has close time GREATER than next_open time, check file duration and frequency',FATAL)
END IF
END IF ! no need to open new file, simply return file_unit
END IF
ELSE
do_write = .FALSE.
END IF
END SUBROUTINE check_and_open
!
!
!
!
! Output all static fields in this file
!
!
! SUBROUTINE write_static(file)
!
!
! Write the static data to the file.
!
! File ID.
SUBROUTINE write_static(file)
INTEGER, INTENT(in) :: file
INTEGER :: j, i, input_num
DO j = 1, files(file)%num_fields
i = files(file)%fields(j)
input_num = output_fields(i)%input_field
! skip fields that were not registered
IF ( .NOT.input_fields(input_num)%register ) CYCLE
IF ( output_fields(i)%local_output .AND. .NOT. output_fields(i)%need_compute) CYCLE
! only output static fields here
IF ( .NOT.output_fields(i)%static ) CYCLE
CALL diag_data_out(file, i, output_fields(i)%buffer, files(file)%last_flush, .TRUE., .TRUE.)
END DO
! Close up this file
IF ( files(file)%file_unit.NE.-1 ) then
! File is stil open. This is to protect when the diag_table has no Fields
! going to this file, and it was never opened (b/c diag_data_out was not
! called)
CALL mpp_close(files(file)%file_unit)
files(file)%file_unit = -1
END IF
END SUBROUTINE write_static
!
!
!
! Checks to see if output_name and output_file are unique in output_fields.
!
!
! SUBROUTINE check_duplicate_output_fields(err_msg)
!
!
! Check to see if output_name and output_file are unique in output_fields. An empty
! err_msg indicates no duplicates found.
!
! Error message. If empty, then no duplicates found.
SUBROUTINE check_duplicate_output_fields(err_msg)
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
INTEGER :: i, j, tmp_file
CHARACTER(len=128) :: tmp_name
CHARACTER(len=256) :: err_msg_local
IF ( PRESENT(err_msg) ) err_msg=''
! Do the checking when more than 1 output_fileds present
IF ( num_output_fields <= 1 ) RETURN
err_msg_local = ''
i_loop: DO i = 1, num_output_fields-1
tmp_name = TRIM(output_fields(i)%output_name)
tmp_file = output_fields(i)%output_file
DO j = i+1, num_output_fields
IF ( (tmp_name == TRIM(output_fields(j)%output_name)) .AND. &
&(tmp_file == output_fields(j)%output_file)) THEN
err_msg_local = ' output_field "'//TRIM(tmp_name)//&
&'" duplicated in file "'//TRIM(files(tmp_file)%name)//'"'
EXIT i_loop
END IF
END DO
END DO i_loop
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler(' ERROR in diag_table',err_msg_local,err_msg) ) RETURN
END IF
END SUBROUTINE check_duplicate_output_fields
!
!
!
! Allocates the atttype in out_field
!
!
! SUBROUTINE attribute_init(out_field, err_msg)
!
!
! Allocates memory in out_field for the attributes. Will FATAL if err_msg is not included
! in the subroutine call.
!
! output field to allocate memory for attribute
! Error message, passed back to calling function
SUBROUTINE attribute_init_field(out_field, err_msg)
TYPE(output_field_type), INTENT(inout) :: out_field
CHARACTER(LEN=*), INTENT(out), OPTIONAL :: err_msg
INTEGER :: istat
! Need to initialize err_msg if present
IF ( PRESENT(err_msg) ) err_msg = ''
! Allocate memory for the attributes
IF ( .NOT._ALLOCATED(out_field%attributes) ) THEN
ALLOCATE(out_field%attributes(max_field_attributes), STAT=istat)
IF ( istat.NE.0 ) THEN
!
! Unable to allocate memory for attribute to module/input_field /
!
IF ( fms_error_handler('diag_util_mod::attribute_init_field',&
& 'Unable to allocate memory for attributes', err_msg) ) THEN
RETURN
END IF
ELSE
! Set equal to 0. It will be increased when attributes added
out_field%num_attributes = 0
END IF
END IF
END SUBROUTINE attribute_init_field
!
!
!
! Prepends the attribute value to an already existing attribute. If the
! attribute isn't yet defined, then creates a new attribute
!
!
! SUBROUTINE prepend_attribute(out_field, attribute, prepend_value)
!
!
! Checks if the attribute already exists in the out_field. If it exists,
! then prepend the prepend_value, otherwise, create the attribute
! with the prepend_value. err_msg indicates no duplicates found.
!
! output field that will get the attribute
! Name of the attribute
! Value to prepend
! Error message, passed back to calling routine
SUBROUTINE prepend_attribute_field(out_field, att_name, prepend_value, err_msg)
TYPE(output_field_type), INTENT(inout) :: out_field
CHARACTER(len=*), INTENT(in) :: att_name, prepend_value
CHARACTER(len=*), INTENT(out) , OPTIONAL :: err_msg
INTEGER :: length, i, this_attribute
CHARACTER(len=512) :: err_msg_local
! Initialize string characters
err_msg_local=''
IF ( PRESENT(err_msg) ) err_msg = ''
! Make sure the attributes for this out field have been initialized
CALL attribute_init_field(out_field, err_msg_local)
IF ( TRIM(err_msg_local) .NE. '' ) THEN
IF ( fms_error_handler('diag_util_mod::prepend_attribute_field', TRIM(err_msg_local), err_msg) ) THEN
RETURN
END IF
END IF
! Find if attribute exists
this_attribute = 0
DO i=1, out_field%num_attributes
IF ( TRIM(out_field%attributes(i)%name) .EQ. TRIM(att_name) ) THEN
this_attribute = i
EXIT
END IF
END DO
IF ( this_attribute > 0 ) THEN
IF ( out_field%attributes(this_attribute)%type .NE. NF90_CHAR ) THEN
!
! Attribute is not a character attribute.
!
IF ( fms_error_handler('diag_util_mod::prepend_attribute_field', &
& 'Attribute "'//TRIM(att_name)//'" is not a character attribute.',&
& err_msg) ) THEN
RETURN
END IF
END IF
ELSE
! Defining a new attribute
! Increase the number of field attributes
this_attribute = out_field%num_attributes + 1
IF ( this_attribute .GT. max_field_attributes ) THEN
!
! Number of attributes exceeds max_field_attributes for attribute .
! Increase diag_manager_nml:max_field_attributes.
!
IF ( fms_error_handler('diag_util_mod::prepend_attribute_field',&
& 'Number of attributes exceeds max_field_attributes for attribute "'&
& //TRIM(att_name)//'". Increase diag_manager_nml:max_field_attributes.',&
& err_msg) ) THEN
RETURN
END IF
ELSE
out_field%num_attributes = this_attribute
! Set name and type
out_field%attributes(this_attribute)%name = att_name
out_field%attributes(this_attribute)%type = NF90_CHAR
! Initialize catt to a blank string, as len_trim doesn't always work on an uninitialized string
out_field%attributes(this_attribute)%catt = ''
END IF
END IF
! Check if string is already included, and return if found
IF ( INDEX(TRIM(out_field%attributes(this_attribute)%catt), TRIM(prepend_value)).EQ.0 ) THEN
! Check if new string length goes beyond the length of catt
length = LEN_TRIM(TRIM(prepend_value)//" "//TRIM(out_field%attributes(this_attribute)%catt))
IF ( length.GT.LEN(out_field%attributes(this_attribute)%catt) ) THEN
!
! Prepend length for attribute is longer than allowed.
!
IF ( fms_error_handler('diag_util_mod::prepend_attribute_field',&
& 'Prepend length for attribute "'//TRIM(att_name)//'" is longer than allowed.',&
& err_msg) ) THEN
RETURN
END IF
END IF
! Set fields
out_field%attributes(this_attribute)%catt =&
& TRIM(prepend_value)//' '//TRIM(out_field%attributes(this_attribute)%catt)
out_field%attributes(this_attribute)%len = length
END IF
END SUBROUTINE prepend_attribute_field
!
!
!
! Allocates the atttype in out_file
!
!
! SUBROUTINE attribute_init(out_file, err_msg)
!
!
! Allocates memory in out_file for the attributes. Will FATAL if err_msg is not included
! in the subroutine call.
!
! output file to allocate memory for attribute
! Error message, passed back to calling function
SUBROUTINE attribute_init_file(out_file, err_msg)
TYPE(file_type), INTENT(inout) :: out_file
CHARACTER(LEN=*), INTENT(out), OPTIONAL :: err_msg
INTEGER :: istat
! Initialize err_msg
IF ( PRESENT(err_msg) ) err_msg = ''
! Allocate memory for the attributes
IF ( .NOT._ALLOCATED(out_file%attributes) ) THEN
ALLOCATE(out_file%attributes(max_field_attributes), STAT=istat)
IF ( istat.NE.0 ) THEN
!
! Unable to allocate memory for file attributes
!
IF ( fms_error_handler('diag_util_mod::attribute_init_file', 'Unable to allocate memory for file attributes', err_msg) ) THEN
RETURN
END IF
ELSE
! Set equal to 0. It will be increased when attributes added
out_file%num_attributes = 0
END IF
END IF
END SUBROUTINE attribute_init_file
!
!
!
! Prepends the attribute value to an already existing attribute. If the
! attribute isn't yet defined, then creates a new attribute
!
!
! SUBROUTINE prepend_attribute(out_file, attribute, prepend_value)
!
!
! Checks if the attribute already exists in the out_file. If it exists,
! then prepend the prepend_value, otherwise, create the attribute
! with the prepend_value. err_msg indicates no duplicates found.
!
! output file that will get the attribute
! Name of the attribute
! Value to prepend
! Error message, passed back to calling routine
SUBROUTINE prepend_attribute_file(out_file, att_name, prepend_value, err_msg)
TYPE(file_type), INTENT(inout) :: out_file
CHARACTER(len=*), INTENT(in) :: att_name, prepend_value
CHARACTER(len=*), INTENT(out) , OPTIONAL :: err_msg
INTEGER :: length, i, this_attribute
CHARACTER(len=512) :: err_msg_local
! Initialize string variables
err_msg_local = ''
IF ( PRESENT(err_msg) ) err_msg = ''
! Make sure the attributes for this out file have been initialized
CALL attribute_init_file(out_file, err_msg_local)
IF ( TRIM(err_msg_local) .NE. '' ) THEN
IF ( fms_error_handler('diag_util_mod::prepend_attribute_file', TRIM(err_msg_local), err_msg) ) THEN
RETURN
END IF
END IF
! Find if attribute exists
this_attribute = 0
DO i=1, out_file%num_attributes
IF ( TRIM(out_file%attributes(i)%name) .EQ. TRIM(att_name) ) THEN
this_attribute = i
EXIT
END IF
END DO
IF ( this_attribute > 0 ) THEN
IF ( out_file%attributes(this_attribute)%type .NE. NF90_CHAR ) THEN
!
! Attribute is not a character attribute.
!
IF ( fms_error_handler('diag_util_mod::prepend_attribute_file',&
& 'Attribute "'//TRIM(att_name)//'" is not a character attribute.',&
& err_msg) ) THEN
RETURN
END IF
END IF
ELSE
! Defining a new attribute
! Increase the number of file attributes
this_attribute = out_file%num_attributes + 1
IF ( this_attribute .GT. max_file_attributes ) THEN
!
! Number of attributes exceeds max_file_attributes for attribute .
! Increase diag_manager_nml:max_file_attributes.
!
IF ( fms_error_handler('diag_util_mod::prepend_attribute_file',&
& 'Number of attributes exceeds max_file_attributes for attribute "'&
&//TRIM(att_name)//'". Increase diag_manager_nml:max_file_attributes.',&
& err_msg) ) THEN
RETURN
END IF
ELSE
out_file%num_attributes = this_attribute
! Set name and type
out_file%attributes(this_attribute)%name = att_name
out_file%attributes(this_attribute)%type = NF90_CHAR
! Initialize catt to a blank string, as len_trim doesn't always work on an uninitialized string
out_file%attributes(this_attribute)%catt = ''
END IF
END IF
! Only add string only if not already defined
IF ( INDEX(TRIM(out_file%attributes(this_attribute)%catt), TRIM(prepend_value)).EQ.0 ) THEN
! Check if new string length goes beyond the length of catt
length = LEN_TRIM(TRIM(prepend_value)//" "//TRIM(out_file%attributes(this_attribute)%catt))
IF ( length.GT.LEN(out_file%attributes(this_attribute)%catt) ) THEN
!
! Prepend length for attribute is longer than allowed.
!
IF ( fms_error_handler('diag_util_mod::prepend_attribute_file',&
& 'Prepend length for attribute "'//TRIM(att_name)//'" is longer than allowed.',&
& err_msg) ) THEN
RETURN
END IF
END IF
! Set files
out_file%attributes(this_attribute)%catt =&
& TRIM(prepend_value)//' '//TRIM(out_file%attributes(this_attribute)%catt)
out_file%attributes(this_attribute)%len = length
END IF
END SUBROUTINE prepend_attribute_file
!
END MODULE diag_util_mod