From 63528d609b7d060a4f07a53f26943029eb0a7f9a Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Mon, 12 Feb 2024 15:33:21 -0500
Subject: [PATCH 001/168] fix: CI updates and bug fixes for CMake build (#1437)
---
.github/workflows/github_cmake_gnu.yml | 18 ++++++++++++++++--
CMakeLists.txt | 7 +++++--
cmake/Findlibyaml.cmake | 4 ++--
3 files changed, 23 insertions(+), 6 deletions(-)
diff --git a/.github/workflows/github_cmake_gnu.yml b/.github/workflows/github_cmake_gnu.yml
index 08fed288cc..b8ee629ab3 100644
--- a/.github/workflows/github_cmake_gnu.yml
+++ b/.github/workflows/github_cmake_gnu.yml
@@ -16,13 +16,27 @@ jobs:
libyaml-flag: [ "", -DWITH_YAML=on ]
io-flag: [ "", -DUSE_DEPRECATED_IO=on ]
container:
- image: noaagfdl/hpc-me.ubuntu-minimal:cmake
+ image: ghcr.io/noaa-gfdl/fms/fms-ci-rocky-gnu:12.3.0
+ credentials:
+ username: ${{ github.actor }}
+ password: ${{ secrets.github_token }}
env:
CMAKE_FLAGS: "${{ matrix.omp-flags }} ${{ matrix.io-flag }} ${{ matrix.libyaml-flag }} -D64BIT=on"
steps:
- name: Checkout code
uses: actions/checkout@v4
- name: Generate makefiles with CMake
- run: cmake $CMAKE_FLAGS .
+ run: cmake $CMAKE_FLAGS -DNetCDF_ROOT=/opt/view -DLIBYAML_ROOT=/opt/view
- name: Build the library
run: make
+ - name: Link with basic executable
+ run: |
+ echo "program test" > test.F90
+ echo " use fms_mod" >> test.F90
+ echo " call fms_init" >> test.F90
+ echo " call fms_end" >> test.F90
+ echo "end program" >> test.F90
+ mpifort -L/opt/view/lib -fopenmp `nf-config --flibs` -Iinclude_r4 -Iinclude_r8 test.F90 libfms_r4.a libfms_r8.a -o test.x
+ touch input.nml
+ - name: Run executable
+ run: ./test.x
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 759e6a1990..4756560ae4 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -345,9 +345,12 @@ foreach(kind ${kinds})
target_link_libraries(${libTgt}_f PRIVATE OpenMP::OpenMP_Fortran)
endif()
- # Check if gnu 10 or higher with mpich
+ # Check if gnu 10 or higher
+ # this should only be needed with mpich, but wasn't able to find a good way to find the MPI flavor consistently
if ( CMAKE_Fortran_COMPILER_VERSION MATCHES "1[0-9]\.[0-9]*\.[0-9]*" AND CMAKE_Fortran_COMPILER_ID MATCHES "GNU")
- if(MPI_C_COMPILER MATCHES ".*mpich.*" )
+ include(CheckFortranCompilerFlag)
+ check_fortran_compiler_flag("-fallow-argument-mismatch" _arg_mismatch_flag)
+ if(_arg_mismatch_flag)
message(STATUS "Adding -fallow-argument-mismatch flag to compile with GCC >=10 and MPICH")
target_compile_options(${libTgt}_f PRIVATE "-fallow-argument-mismatch;-w")
endif()
diff --git a/cmake/Findlibyaml.cmake b/cmake/Findlibyaml.cmake
index ce4b1f6c32..029447c70d 100644
--- a/cmake/Findlibyaml.cmake
+++ b/cmake/Findlibyaml.cmake
@@ -3,8 +3,8 @@
# LIBYAML_INCLUDE_DIR
# LIBYAML_LIBRARIES
-FIND_PATH(LIBYAML_INCLUDE_DIR NAMES yaml.h PATHS $ENV{LIBYAML_ROOT}/include )
-FIND_LIBRARY(LIBYAML_LIBRARIES NAMES yaml PATHS $ENV{LIBYAML_ROOT}/lib )
+FIND_PATH(LIBYAML_INCLUDE_DIR NAMES yaml.h PATHS ${LIBYAML_ROOT}/include $ENV{LIBYAML_ROOT}/include )
+FIND_LIBRARY(LIBYAML_LIBRARIES NAMES yaml PATHS ${LIBYAML_ROOT}/lib $ENV{LIBYAML_ROOT}/lib )
if(NOT LIBYAML_INCLUDE_DIR OR NOT LIBYAML_LIBRARIES)
message(SEND_ERROR "libyaml library/include file not found, set LIBYAML_ROOT")
endif()
From 82fbf0edb02ee154148cbe15640cc3c6274ba7f9 Mon Sep 17 00:00:00 2001
From: Rusty Benson <6594772+bensonr@users.noreply.github.com>
Date: Thu, 22 Feb 2024 10:15:34 -0500
Subject: [PATCH 002/168] feat: make sub-communicators available for broadcasts
and other uses such as MPI parallel I/O (#1457)
---
mpp/include/mpp_domains_define.inc | 26 +++++++++++++++++---------
mpp/include/mpp_domains_util.inc | 19 +++++++++++++++++++
mpp/include/mpp_util.inc | 9 ++++++---
mpp/mpp.F90 | 10 +++++++++-
mpp/mpp_domains.F90 | 17 ++++++++++-------
5 files changed, 61 insertions(+), 20 deletions(-)
diff --git a/mpp/include/mpp_domains_define.inc b/mpp/include/mpp_domains_define.inc
index b606aa3d20..e447544dc3 100644
--- a/mpp/include/mpp_domains_define.inc
+++ b/mpp/include/mpp_domains_define.inc
@@ -644,7 +644,7 @@
integer :: i, j, m, n, xhalosz, yhalosz, memory_xsize, memory_ysize
integer :: whalosz, ehalosz, shalosz, nhalosz
- integer :: ipos, jpos, pos, tile, nlist, cur_tile_id
+ integer :: ipos, jpos, pos, tile, nlist, cur_tile_id, cur_comm_id
integer :: ndivx, ndivy, isg, ieg, jsg, jeg, ishift, jshift, errunit, logunit
integer :: x_offset, y_offset, start_pos, nfold
logical :: from_mosaic, is_complete
@@ -684,20 +684,22 @@
cur_tile_id = 1
if(present(tile_id)) cur_tile_id = tile_id
+ cur_comm_id=0
if( PRESENT(pelist) )then
allocate( pes(0:size(pelist(:))-1) )
pes = pelist
if(from_mosaic) then
allocate( pesall(0:mpp_npes()-1) )
- call mpp_get_current_pelist(pesall)
+ call mpp_get_current_pelist(pesall, commID=cur_comm_id)
else
allocate( pesall(0:size(pes(:))-1) )
pesall = pes
+ call mpp_get_current_pelist(pesall, commID=cur_comm_id)
end if
else
allocate( pes(0:mpp_npes()-1) )
allocate( pesall(0:mpp_npes()-1) )
- call mpp_get_current_pelist(pes)
+ call mpp_get_current_pelist(pes, commID=cur_comm_id)
pesall = pes
end if
@@ -795,13 +797,14 @@
allocate(domain%tile_id_all(1))
domain%tile_id = cur_tile_id
domain%tile_id_all = cur_tile_id
+ domain%tile_comm_id = cur_comm_id
domain%ntiles = 1
domain%max_ntile_pe = 1
domain%ncontacts = 0
domain%rotated_ninety = .FALSE.
allocate( domain%list(0:nlist-1) )
do i = 0, nlist-1
- allocate( domain%list(i)%x(1), domain%list(i)%y(1), domain%list(i)%tile_id(1) )
+ allocate( domain%list(i)%x(1), domain%list(i)%y(1), domain%list(i)%tile_id(1))
end do
end if
@@ -853,6 +856,7 @@
if( ANY(pes == mpp_pe()) ) then
domain%io_layout = layout
domain%tile_root_pe = pes(0)
+ domain%comm_id = cur_comm_id
if( ipos.EQ.NULL_PE .OR. jpos.EQ.NULL_PE ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: pelist must include this PE for '//trim(domain%name) )
if( debug ) then
@@ -1257,9 +1261,8 @@ end subroutine check_message_size
if( nlist .NE. size(pelist(:))) call mpp_error(FATAL, &
'mpp_domains_define.inc: size of pelist is not equal mpp_npes')
pes = pelist
- else
- call mpp_get_current_pelist(pes)
end if
+ call mpp_get_current_pelist(pes, commID=domain%comm_id)
!--- pelist should be monotonic increasing by 1.
do n = 1, nlist-1
if(pes(n) - pes(n-1) .NE. 1) call mpp_error(FATAL, &
@@ -1332,11 +1335,11 @@ end subroutine check_message_size
do n = 0, nlist-1
nt = ntile_per_pe(n)
- allocate(domain%list(n)%x(nt), domain%list(n)%y(nt), domain%list(n)%tile_id(nt) )
+ allocate(domain%list(n)%x(nt), domain%list(n)%y(nt), domain%list(n)%tile_id(nt))
end do
- pe = mpp_pe()
pos = 0
+ pe = mpp_pe()
if( PRESENT(tile_id) ) then
if(size(tile_id(:)) .NE. num_tile) then
call mpp_error(FATAL, "mpp_domains_define.inc: size(tile_id) .NE. num_tile")
@@ -1380,6 +1383,7 @@ end subroutine check_message_size
allocate(tile_count(pes(0):pes(0)+nlist-1))
tile_count = 0 ! tile number on current pe
+ domain%tile_comm_id=0
do n = 1, num_tile
allocate(mask(layout(1,n), layout(2,n)))
allocate(pelist_tile(pe_start(n):pe_end(n)) )
@@ -1387,6 +1391,10 @@ end subroutine check_message_size
do m = pe_start(n), pe_end(n)
pelist_tile(m) = m
end do
+ !--- set the tile communicator
+ if (ANY(pelist_tile == pe)) then
+ call mpp_declare_pelist(pelist_tile, commID=domain%tile_comm_id)
+ endif
mask = .TRUE.
if(present(maskmap)) mask = maskmap(1:layout(1,n), 1:layout(2,n), n)
ndivx = layout(1,n); ndivy = layout(2,n)
@@ -1451,7 +1459,7 @@ end subroutine check_message_size
deallocate(mask, xext, yext, pelist_tile)
end do
- deallocate(pes, tile_count)
+ deallocate(pes, tile_count, tile_id_local)
if(num_contact == 0 .OR. num_tile == 1) return
diff --git a/mpp/include/mpp_domains_util.inc b/mpp/include/mpp_domains_util.inc
index a8210895ed..ab2933e131 100644
--- a/mpp/include/mpp_domains_util.inc
+++ b/mpp/include/mpp_domains_util.inc
@@ -689,6 +689,25 @@ function mpp_get_domain_tile_root_pe(domain)
end function mpp_get_domain_tile_root_pe
+
+function mpp_get_domain_tile_commid(domain)
+ type(domain2d), intent(in) :: domain !> domain you are querying for information
+ integer :: mpp_get_domain_tile_commid !> declaration of the return tile communicator
+
+ mpp_get_domain_tile_commid = domain%tile_comm_id
+
+end function mpp_get_domain_tile_commid
+
+
+function mpp_get_domain_commid(domain)
+ type(domain2d), intent(in) :: domain !> domain you are querying for information
+ integer :: mpp_get_domain_commid !> declaration of the return domain communicator
+
+ mpp_get_domain_commid = domain%comm_id
+
+end function mpp_get_domain_commid
+
+
function mpp_get_io_domain(domain)
type(domain2d), intent(in) :: domain
type(domain2d), pointer :: mpp_get_io_domain
diff --git a/mpp/include/mpp_util.inc b/mpp/include/mpp_util.inc
index e6af1ba157..f8458806e6 100644
--- a/mpp/include/mpp_util.inc
+++ b/mpp/include/mpp_util.inc
@@ -428,15 +428,18 @@ end function rarray_to_char
!!
!! This call implies synchronization across the PEs in the current
!! pelist, of which pelist is a subset.
- subroutine mpp_declare_pelist( pelist, name )
- integer, intent(in) :: pelist(:)
- character(len=*), intent(in), optional :: name
+ subroutine mpp_declare_pelist( pelist, name, commID )
+ integer, intent(in) :: pelist(:) !> pelist you are declaring and storing within FMS
+ character(len=*), intent(in), optional :: name !> unique name for an input pelist
+ integer, intent(out), optional :: commID !> return of current MPI comm group communicator ID
integer :: i
if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_DECLARE_PELIST: You must first call mpp_init.' )
i = get_peset(pelist)
write( peset(i)%name,'(a,i2.2)' ) 'PElist', i !default name
if( PRESENT(name) )peset(i)%name = name
+ if( PRESENT(commID) )commID = peset(i)%id
+
return
end subroutine mpp_declare_pelist
diff --git a/mpp/mpp.F90 b/mpp/mpp.F90
index 7d07e1937c..b045ce6d77 100644
--- a/mpp/mpp.F90
+++ b/mpp/mpp.F90
@@ -196,7 +196,7 @@ module mpp_mod
public :: COMM_TAG_9, COMM_TAG_10, COMM_TAG_11, COMM_TAG_12
public :: COMM_TAG_13, COMM_TAG_14, COMM_TAG_15, COMM_TAG_16
public :: COMM_TAG_17, COMM_TAG_18, COMM_TAG_19, COMM_TAG_20
- public :: MPP_FILL_INT,MPP_FILL_DOUBLE
+ public :: MPP_FILL_INT,MPP_FILL_DOUBLE,MPP_INFO_NULL
public :: mpp_init_test_full_init, mpp_init_test_init_true_only, mpp_init_test_peset_allocated
public :: mpp_init_test_clocks_init, mpp_init_test_datatype_list_init, mpp_init_test_logfile_init
public :: mpp_init_test_read_namelist, mpp_init_test_etc_unit, mpp_init_test_requests_allocated
@@ -1325,6 +1325,14 @@ module mpp_mod
integer, parameter :: mpp_init_test_etc_unit = 6
integer, parameter :: mpp_init_test_requests_allocated = 7
+!> MPP_INFO_NULL acts as an analagous mpp-macro for MPI_INFO_NULL to share with fms2_io NetCDF4
+!! mpi-io. The default value for the no-mpi case comes from Intel MPI and MPICH. OpenMPI sets
+!! a default value of '0'
+#if defined(use_libMPI)
+ integer, parameter :: MPP_INFO_NULL = MPI_INFO_NULL
+#else
+ integer, parameter :: MPP_INFO_NULL = 469762048
+#endif
!***********************************************************************
! variables needed for subroutine read_input_nml (include/mpp_util.inc)
diff --git a/mpp/mpp_domains.F90 b/mpp/mpp_domains.F90
index e46f424e38..cac3cf3c1c 100644
--- a/mpp/mpp_domains.F90
+++ b/mpp/mpp_domains.F90
@@ -158,6 +158,7 @@ module mpp_domains_mod
public :: mpp_get_tile_npes, mpp_get_domain_root_pe, mpp_get_tile_pelist, mpp_get_tile_compute_domains
public :: mpp_get_num_overlap, mpp_get_overlap
public :: mpp_get_io_domain, mpp_get_domain_pe, mpp_get_domain_tile_root_pe
+ public :: mpp_get_domain_tile_commid, mpp_get_domain_commid
public :: mpp_get_domain_name, mpp_get_io_domain_layout
public :: mpp_copy_domain, mpp_set_domain_symmetry
public :: mpp_get_update_pelist, mpp_get_update_size
@@ -305,8 +306,8 @@ module mpp_domains_mod
!> @ingroup mpp_domains_mod
type :: domain2D_spec
private
- type(domain1D_spec), pointer :: x(:) => NULL() !< x-direction domain decomposition
- type(domain1D_spec), pointer :: y(:) => NULL() !< y-direction domain decomposition
+ type(domain1D_spec), pointer :: x(:) => NULL() !< x-direction domain decomposition
+ type(domain1D_spec), pointer :: y(:) => NULL() !< y-direction domain decomposition
integer, pointer :: tile_id(:) => NULL() !< tile id of each tile
integer :: pe !< PE to which this domain is assigned
integer :: pos !< position of this PE within link list
@@ -374,13 +375,15 @@ module mpp_domains_mod
integer :: whalo, ehalo !< halo size in x-direction
integer :: shalo, nhalo !< halo size in y-direction
integer :: ntiles !< number of tiles within mosaic
+ integer :: comm_id !< MPI communicator for the mosaic
+ integer :: tile_comm_id !< MPI communicator for this tile of domain
integer :: max_ntile_pe !< maximum value in the pelist of number of tiles on each pe.
- integer :: ncontacts !< number of contact region within mosaic.
- logical :: rotated_ninety !< indicate if any contact rotate NINETY or MINUS_NINETY
+ integer :: ncontacts !< number of contact region within mosaic.
+ logical :: rotated_ninety !< indicate if any contact rotate NINETY or MINUS_NINETY
logical :: initialized=.FALSE. !< indicate if the overlapping is computed or not.
- integer :: tile_root_pe !< root pe of current tile.
- integer :: io_layout(2) !< io_layout, will be set through mpp_define_io_domain
- !! default = domain layout
+ integer :: tile_root_pe !< root pe of current tile.
+ integer :: io_layout(2) !< io_layout, will be set through mpp_define_io_domain
+ !! default = domain layout
integer, pointer :: pearray(:,:) => NULL() !< pe of each layout position
integer, pointer :: tile_id(:) => NULL() !< tile id of each tile on current processor
integer, pointer :: tile_id_all(:)=> NULL() !< tile id of all the tiles of domain
From 5300c3214be510cbc16752fe9b9eabbb4fd683bb Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Thu, 22 Feb 2024 10:17:27 -0500
Subject: [PATCH 003/168] fix: autotools check for HDF5 floating point
exceptions (#1455)
---
configure.ac | 15 +++++++++++++++
1 file changed, 15 insertions(+)
diff --git a/configure.ac b/configure.ac
index 223733b9f9..cd64493729 100644
--- a/configure.ac
+++ b/configure.ac
@@ -259,6 +259,21 @@ GX_FC_CHECK_MOD([netcdf], [], [], [AC_MSG_ERROR([Can't find the netCDF Fortran m
GX_FORTRAN_SEARCH_LIBS([nf90_create], [netcdff], [use netcdf], [iret = nf90_create('foo.nc', 1, ncid)], [],
[AC_MSG_ERROR([Can't find the netCDF Fortran library. Set LDFLAGS/LIBS])])
+# Check if we get a floating point exception with netcdf
+# this will only get triggered if you have FPE traps enabled via FCFLAGS
+AC_MSG_CHECKING([if HDF5 version causes floating point exceptions with set flags])
+AC_RUN_IFELSE([AC_LANG_PROGRAM([], [[
+ use netcdf
+ integer i, j
+ j = nf90_open("test.nc", NC_WRITE, i)
+]])], [hdf5_fpe_bug=no], [hdf5_fpe_bug=yes])
+AC_MSG_RESULT([$hdf5_fpe_bug])
+if test $hdf5_fpe_bug = yes; then
+ AC_MSG_ERROR([The HDF5 version used to build netcdf is incompatible with the set FCFLAGS. dnl
+NetCDF must be built with a HDF5 version other than 1.14.3 to support floating point exception traps.])
+fi
+
+
# Check if Fortran compiler has the Class, Character array assign bug
GX_FC_CLASS_CHAR_ARRAY_BUG_CHECK()
From 1d3570d6c83ef79f0ce2639cc114fa0076d94ee5 Mon Sep 17 00:00:00 2001
From: Ray Menzel <43218622+menzel-gfdl@users.noreply.github.com>
Date: Thu, 7 Mar 2024 11:16:10 -0500
Subject: [PATCH 004/168] Fix : Make interpolator File Path Buffer Bigger
(#1469)
---
interpolator/include/interpolator.inc | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/interpolator/include/interpolator.inc b/interpolator/include/interpolator.inc
index 96bd7d76ab..7f32260411 100644
--- a/interpolator/include/interpolator.inc
+++ b/interpolator/include/interpolator.inc
@@ -127,7 +127,7 @@ integer , intent(in), optional :: vert_interp(:)
character(len=*), intent(out), optional :: clim_units(:)
logical, intent(out), optional :: single_year_file
-character(len=64) :: src_file
+character(len=128) :: src_file
!++lwh
real(FMS_INTP_KIND_) :: dlat, dlon
!--lwh
From 1bb706cc61f8351f176e4f9b7ccc8ab25ed6999b Mon Sep 17 00:00:00 2001
From: Scitech777 <160655680+Scitech777@users.noreply.github.com>
Date: Thu, 7 Mar 2024 12:33:39 -0500
Subject: [PATCH 005/168] chore: add Molly to the code owners file(#1474)
---
.github/CODEOWNERS | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS
index db81ffb9af..ff4da7503c 100644
--- a/.github/CODEOWNERS
+++ b/.github/CODEOWNERS
@@ -25,7 +25,7 @@
# These owners will be the default owners for all the files in the
# repository. Unless a later match is found, these owners
# will be requested for a review when a PR is opened.
-* @thomas-robinson @bensonr @rem1776
+* @thomas-robinson @bensonr @rem1776 @scitech777
# GNU autotools files
Makefile.am @uramirez8707 @rem1776
From f5d9892025c09b90d5e8b0402a2f5645d72ecad0 Mon Sep 17 00:00:00 2001
From: dkokron
Date: Fri, 29 Mar 2024 11:32:47 -0500
Subject: [PATCH 006/168] feat: add support for collective parallel reads in
fms2_io (#1477)
---
fms2_io/include/netcdf_read_data.inc | 104 +++++++++++++++++++--------
fms2_io/netcdf_io.F90 | 82 +++++++++++++++------
mpp/mpp.F90 | 11 ++-
3 files changed, 145 insertions(+), 52 deletions(-)
diff --git a/fms2_io/include/netcdf_read_data.inc b/fms2_io/include/netcdf_read_data.inc
index 4bfd427970..b69046cc64 100644
--- a/fms2_io/include/netcdf_read_data.inc
+++ b/fms2_io/include/netcdf_read_data.inc
@@ -354,8 +354,12 @@ subroutine netcdf_read_data_2d(fileobj, variable_name, buf, unlim_dim_level, &
endif
c(unlim_dim_index) = unlim_dim_level
endif
- if (fileobj%is_root) then
+ if(fileobj%use_collective) then
varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
+ ! NetCDF does not have the ability to specify collective I/O at
+ ! the file basis so we must activate at the variable level
+ err = nf90_var_par_access(fileobj%ncid, varid, nf90_collective)
+ call check_netcdf_code(err, append_error_msg)
select type(buf)
type is (integer(kind=i4_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
@@ -370,20 +374,38 @@ subroutine netcdf_read_data_2d(fileobj, variable_name, buf, unlim_dim_level, &
end select
call check_netcdf_code(err, append_error_msg)
call unpack_data_2d(fileobj, varid, variable_name, buf)
- endif
- if (bcast) then
- select type(buf)
- type is (integer(kind=i4_kind))
- call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
- type is (integer(kind=i8_kind))
- call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
- type is (real(kind=r4_kind))
- call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
- type is (real(kind=r8_kind))
- call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
- class default
- call error("Unsupported variable type: "//trim(append_error_msg))
- end select
+ else
+ if (fileobj%is_root) then
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
+ select type(buf)
+ type is (integer(kind=i4_kind))
+ err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
+ type is (integer(kind=i8_kind))
+ err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
+ type is (real(kind=r4_kind))
+ err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
+ type is (real(kind=r8_kind))
+ err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
+ class default
+ call error("Unsupported variable type: "//trim(append_error_msg))
+ end select
+ call check_netcdf_code(err, append_error_msg)
+ call unpack_data_2d(fileobj, varid, variable_name, buf)
+ endif
+ if (bcast) then
+ select type(buf)
+ type is (integer(kind=i4_kind))
+ call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
+ type is (integer(kind=i8_kind))
+ call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
+ type is (real(kind=r4_kind))
+ call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
+ type is (real(kind=r8_kind))
+ call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
+ class default
+ call error("Unsupported variable type: "//trim(append_error_msg))
+ end select
+ endif
endif
end subroutine netcdf_read_data_2d
@@ -446,8 +468,12 @@ subroutine netcdf_read_data_3d(fileobj, variable_name, buf, unlim_dim_level, &
endif
c(unlim_dim_index) = unlim_dim_level
endif
- if (fileobj%is_root) then
+ if(fileobj%use_collective) then
varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
+ ! NetCDF does not have the ability to specify collective I/O at
+ ! the file basis so we must activate at the variable level
+ err = nf90_var_par_access(fileobj%ncid, varid, nf90_collective)
+ call check_netcdf_code(err, append_error_msg)
select type(buf)
type is (integer(kind=i4_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
@@ -462,20 +488,38 @@ subroutine netcdf_read_data_3d(fileobj, variable_name, buf, unlim_dim_level, &
end select
call check_netcdf_code(err, append_error_msg)
call unpack_data_3d(fileobj, varid, variable_name, buf)
- endif
- if (bcast) then
- select type(buf)
- type is (integer(kind=i4_kind))
- call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
- type is (integer(kind=i8_kind))
- call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
- type is (real(kind=r4_kind))
- call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
- type is (real(kind=r8_kind))
- call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
- class default
- call error("Unsupported variable type: "//trim(append_error_msg))
- end select
+ else
+ if (fileobj%is_root) then
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
+ select type(buf)
+ type is (integer(kind=i4_kind))
+ err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
+ type is (integer(kind=i8_kind))
+ err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
+ type is (real(kind=r4_kind))
+ err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
+ type is (real(kind=r8_kind))
+ err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
+ class default
+ call error("Unsupported variable type: "//trim(append_error_msg))
+ end select
+ call check_netcdf_code(err, append_error_msg)
+ call unpack_data_3d(fileobj, varid, variable_name, buf)
+ endif
+ if (bcast) then
+ select type(buf)
+ type is (integer(kind=i4_kind))
+ call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
+ type is (integer(kind=i8_kind))
+ call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
+ type is (real(kind=r4_kind))
+ call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
+ type is (real(kind=r8_kind))
+ call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
+ class default
+ call error("Unsupported variable type: "//trim(append_error_msg))
+ end select
+ endif
endif
end subroutine netcdf_read_data_3d
diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90
index b66c6f0526..07959401cc 100644
--- a/fms2_io/netcdf_io.F90
+++ b/fms2_io/netcdf_io.F90
@@ -149,6 +149,11 @@ module netcdf_io_mod
character (len=20) :: time_name
type(dimension_information) :: bc_dimensions ! MPP_COMM_NULL acts as an analagous mpp-macro for MPI_COMM_NULL to share with fms2_io NetCDF4
+!! mpi-io. The default value for the no-mpi case comes from Intel MPI and MPICH. OpenMPI sets
+!! a default value of '2'
+#if defined(use_libMPI)
+ integer, parameter :: MPP_COMM_NULL = MPI_COMM_NULL
+#else
+ integer, parameter :: MPP_COMM_NULL = 67108864
+#endif
+
!***********************************************************************
! variables needed for subroutine read_input_nml (include/mpp_util.inc)
!
From d32804592e05ec117c1495a5e318b2670d2c4575 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Thu, 11 Apr 2024 08:46:20 -0400
Subject: [PATCH 007/168] CI: mom6 tests on PR's (#1440)
---
.github/workflows/github_mom_gnu.yml | 32 ++++++++++++++++++++++++++++
1 file changed, 32 insertions(+)
create mode 100644 .github/workflows/github_mom_gnu.yml
diff --git a/.github/workflows/github_mom_gnu.yml b/.github/workflows/github_mom_gnu.yml
new file mode 100644
index 0000000000..36735b7252
--- /dev/null
+++ b/.github/workflows/github_mom_gnu.yml
@@ -0,0 +1,32 @@
+name: Run MOM6 test suite
+
+# runs on PR's or when manually triggered
+on: [workflow_dispatch, pull_request]
+
+# cancel running jobs if theres a newer push
+concurrency:
+ group: ${{ github.workflow }}-${{ github.ref }}
+ cancel-in-progress: true
+
+jobs:
+ build:
+ runs-on: ubuntu-latest
+ container:
+ image: ghcr.io/noaa-gfdl/fms/fms-ci-rocky-gnu:13.2.0
+ credentials:
+ username: ${{ github.actor }}
+ password: ${{ secrets.github_token }}
+ steps:
+ - name: Checkout MOM6 repository
+ uses: actions/checkout@v4
+ with:
+ repository: 'NOAA-GFDL/MOM6'
+ submodules: recursive
+ - name: Checkout FMS into MOM build
+ uses: actions/checkout@v4
+ with:
+ path: .testing/deps/fms/src
+ - name: Build FMS and MOM test suite
+ run: make -C .testing -j
+ - name: Run MOM tests
+ run: make -C .testing -j test
From 9b05ea106b736be6ab9f47844a944c1027f08084 Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Thu, 18 Apr 2024 09:26:48 -0400
Subject: [PATCH 008/168] chore: updates to codeowners (#1488)
---
.github/CODEOWNERS | 24 ++++++++++--------------
1 file changed, 10 insertions(+), 14 deletions(-)
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS
index ff4da7503c..4421b72854 100644
--- a/.github/CODEOWNERS
+++ b/.github/CODEOWNERS
@@ -25,7 +25,7 @@
# These owners will be the default owners for all the files in the
# repository. Unless a later match is found, these owners
# will be requested for a review when a PR is opened.
-* @thomas-robinson @bensonr @rem1776 @scitech777
+* @thomas-robinson @bensonr @rem1776
# GNU autotools files
Makefile.am @uramirez8707 @rem1776
@@ -34,15 +34,13 @@ Makefile.am @uramirez8707 @rem1776
*.m4 @uramirez8707 @rem1776
# cmake files
-CM* @mlee03 @ngs333
-cmake @mlee03 @ngs333
+CM* @mlee03
+cmake @mlee03
# Files specific to GitHub or GitLab
-/.github/ @GFDL-Eric @rem1776
-/.gitlab/ @GFDL-Eric @rem1776
+/.github/ @rem1776
# Testing files
-/.gitlab-ci.yml @uramirez8707 @mlee03 @bensonr @thomas-robinson @rem1776
/test_fms/ @uramirez8707 @mlee03 @bensonr @thomas-robinson @rem1776
# Specific component directories
@@ -52,18 +50,16 @@ cmake @mlee03 @ngs333
/block_control/ @bensonr
/test_fms/block_control/ @bensonr @rem1776
-/data_override/ @GFDL-Eric
-/test_fms/data_override/ @GFDL-Eric @rem1776
+#/data_override/ Currently no code owner
+/test_fms/data_override/ @rem1776
-/diag_manager @thomas-robinson @ngs333
-/test_fms/diag_manager/ @thomas-robinson @ngs333
-
-/fv3gfs/ @bensonr
+/diag_manager @thomas-robinson
+/test_fms/diag_manager/ @thomas-robinson
/fms/ @thomas-robinson @rem1776
/test_fms/fms/ @thomas-robinson @rem1776
-/fms2/ @uramirez8707 @GFDL-Eric
-/test_fms/fms2/ @uramirez8707 @GFDL-Eric
+/fms2/ @uramirez8707
+/test_fms/fms2/ @uramirez8707
/libFMS/ @thomas-robinson @rem1776
From cb0c48a5194ff2119c93a0e7d71c5d84e8d637aa Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 18 Apr 2024 13:54:54 -0400
Subject: [PATCH 009/168] fix: data_override failures with scalars and add test
case (#1489)
---
data_override/include/data_override.inc | 18 +++--
test_fms/data_override/Makefile.am | 6 +-
.../test_data_override2_scalar.sh | 71 ++++++++++++++++++
.../test_data_override_ongrid.F90 | 75 +++++++++++++++++++
4 files changed, 161 insertions(+), 9 deletions(-)
create mode 100755 test_fms/data_override/test_data_override2_scalar.sh
diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc
index cfec9ef64f..a7385677d8 100644
--- a/data_override/include/data_override.inc
+++ b/data_override/include/data_override.inc
@@ -69,9 +69,9 @@ type data_type
logical :: multifile = .false.
character(len=512) :: prev_file_name !< name of netCDF data file for previous segment
character(len=512) :: next_file_name !< name of netCDF data file for next segment
- type(time_type), dimension(:), pointer :: time_records => NULL()
- type(time_type), dimension(:), pointer :: time_prev_records => NULL()
- type(time_type), dimension(:), pointer :: time_next_records => NULL()
+ type(time_type), dimension(:), allocatable :: time_records
+ type(time_type), dimension(:), allocatable :: time_prev_records
+ type(time_type), dimension(:), allocatable :: time_next_records
end type data_type
!> Private type for holding various data fields for performing data overrides
@@ -900,13 +900,17 @@ subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data_out,time,override,data
!10 do time interp to get data in compute_domain
- first_record = data_table(index1)%time_records(1)
- last_record = data_table(index1)%time_records(dims(4))
-
! if using consecutive files, allow to perform time interpolation between the last record of previous
! file and first record of current file OR between the last record of current file and first record of
! next file hence "bridging" over files.
if_multi2: if (multifile) then
+ dims = get_external_field_size(id_time)
+ if (.not. allocated(data_table(index1)%time_records)) allocate(data_table(index1)%time_records(dims(4)))
+ call get_time_axis(id_time,data_table(index1)%time_records)
+
+ first_record = data_table(index1)%time_records(1)
+ last_record = data_table(index1)%time_records(dims(4))
+
if_time2: if (time.
+#***********************************************************************
+#
+# Copyright (c) 2019-2021 Ed Hartnett, Uriel Ramirez, Seth Underwood
+
+# Set common test settings.
+. ../test-lib.sh
+
+output_dir
+rm -rf data_table data_table.yaml input.nml input_base.nml
+
+if [ ! -z $parser_skip ]; then
+ cat <<_EOF > input.nml
+&data_override_nml
+use_data_table_yaml=.False.
+/
+&test_data_override_ongrid_nml
+ test_case = 3
+/
+_EOF
+ printf '"OCN", "co2", "co2", "./INPUT/scalar.nc", "none" , 1.0' | cat > data_table
+else
+cat <<_EOF > input.nml
+&data_override_nml
+use_data_table_yaml=.True.
+/
+&test_data_override_ongrid_nml
+ test_case = 3
+/
+_EOF
+cat <<_EOF > data_table.yaml
+data_table:
+ - gridname : OCN
+ fieldname_code : co2
+ fieldname_file : co2
+ file_name : INPUT/scalar.nc
+ interpol_method : none
+ factor : 1.0
+_EOF
+fi
+
+[ ! -d "INPUT" ] && mkdir -p "INPUT"
+for KIND in r4 r8
+do
+rm -rf INPUT/*
+test_expect_success "data_override scalar field (${KIND})" '
+ mpirun -n 6 ../test_data_override_ongrid_${KIND}
+'
+
+done
+rm -rf INPUT *.nc # remove any leftover files to reduce size
+
+test_done
\ No newline at end of file
diff --git a/test_fms/data_override/test_data_override_ongrid.F90 b/test_fms/data_override/test_data_override_ongrid.F90
index ac97f03a11..4345bb9f86 100644
--- a/test_fms/data_override/test_data_override_ongrid.F90
+++ b/test_fms/data_override/test_data_override_ongrid.F90
@@ -50,6 +50,7 @@ program test_data_override_ongrid
integer :: io_status
integer, parameter :: ongrid = 1
integer, parameter :: bilinear = 2
+integer, parameter :: scalar = 3
integer :: test_case = ongrid
namelist / test_data_override_ongrid_nml / nhalox, nhaloy, test_case
@@ -83,6 +84,8 @@ program test_data_override_ongrid
call generate_ongrid_input_file ()
case (bilinear)
call generate_bilinear_input_file ()
+case (scalar)
+ call generate_scalar_input_file ()
end select
call mpp_sync()
@@ -96,6 +99,8 @@ program test_data_override_ongrid
call ongrid_test()
case (bilinear)
call bilinear_test()
+case (scalar)
+ call scalar_test()
end select
call mpp_exit
@@ -437,4 +442,74 @@ subroutine bilinear_test()
enddo
deallocate(runoff_decreasing, runoff_increasing)
end subroutine bilinear_test
+
+!> @brief Generates the input for the bilinear data_override test_case
+subroutine generate_scalar_input_file()
+ if (mpp_pe() .eq. mpp_root_pe()) then
+ call create_grid_spec_file ()
+ call create_ocean_mosaic_file()
+ call create_ocean_hgrid_file()
+ call create_scalar_data_file()
+ endif
+ call mpp_sync()
+end subroutine generate_scalar_input_file
+
+subroutine create_scalar_data_file()
+ type(FmsNetcdfFile_t) :: fileobj
+ character(len=10) :: dimnames(1)
+ real(lkind), allocatable, dimension(:) :: co2_in
+ real(lkind), allocatable, dimension(:) :: time_data
+ integer :: i
+
+ allocate(co2_in(10))
+ allocate(time_data(10))
+ do i = 1, 10
+ co2_in(i) = real(i, lkind)
+ enddo
+ time_data = (/1., 2., 3., 5., 6., 7., 8., 9., 10., 11./)
+
+ dimnames(1) = 'time'
+
+ if (open_file(fileobj, 'INPUT/scalar.nc', 'overwrite')) then
+ call register_axis(fileobj, "time", unlimited)
+ call register_field(fileobj, "time", "float", (/"time"/))
+ call register_variable_attribute(fileobj, "time", "cartesian_axis", "T", str_len=1)
+ call register_variable_attribute(fileobj, "time", "calendar", "noleap", str_len=6)
+ call register_variable_attribute(fileobj, "time", "units", "days since 0001-01-01 00:00:00", str_len=30)
+
+ call register_field(fileobj, "co2", "float", dimnames)
+ call write_data(fileobj, "co2", co2_in)
+ call write_data(fileobj, "time", time_data)
+ call close_file(fileobj)
+ else
+ call mpp_error(FATAL, "Error opening the file: 'INPUT/scalar.nc' to write")
+ endif
+ deallocate(co2_in)
+end subroutine create_scalar_data_file
+
+subroutine scalar_test()
+ real(lkind) :: expected_result !< Expected result from data_override
+ type(time_type) :: Time !< Time
+ real(lkind) :: co2 !< Data to be written
+
+ co2 = 999._lkind
+ !< Run it when time=3
+ Time = set_date(1,1,4,0,0,0)
+ call data_override('OCN','co2',co2, Time)
+ !< Because you are getting the data when time=3, and this is an "ongrid" case, the expected result is just
+ !! equal to the data at time=3, which is 3.
+ expected_result = 3._lkind
+ if (co2 .ne. expected_result) call mpp_error(FATAL, "co2 was not overriden to the correct value!")
+
+ !< Run it when time=4
+ co2 = 999._lkind
+ Time = set_date(1,1,5,0,0,0)
+ call data_override('OCN','co2',co2, Time)
+ !< You are getting the data when time=4, the data at time=3 is 3. and at time=5 is 4., so the expected result
+ !! is the average of the 2 (because this is is an "ongrid" case and there is no horizontal interpolation).
+ expected_result = (3._lkind + 4._lkind) / 2._lkind
+ if (co2 .ne. expected_result) call mpp_error(FATAL, "co2 was not overriden to the correct value!")
+
+end subroutine scalar_test
+
end program test_data_override_ongrid
From ac22da2c41b10752d414751e829d39084bfad3e2 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Tue, 30 Apr 2024 09:23:16 -0400
Subject: [PATCH 010/168] CI: update workflow containers and fully migrate to
github container registry (#1453)
---
.github/workflows/Dockerfile.gnu | 68 ----------------------
.github/workflows/github_autotools_gnu.yml | 6 +-
.github/workflows/github_cmake_gnu.yml | 5 +-
.github/workflows/github_coupler_gnu.yml | 2 +-
.github/workflows/spack.env | 17 ------
test_fms/parser/test_output_yaml.F90 | 4 +-
test_fms/test-lib.sh.in | 2 +-
7 files changed, 8 insertions(+), 96 deletions(-)
delete mode 100644 .github/workflows/Dockerfile.gnu
delete mode 100644 .github/workflows/spack.env
diff --git a/.github/workflows/Dockerfile.gnu b/.github/workflows/Dockerfile.gnu
deleted file mode 100644
index 3506c2b9ee..0000000000
--- a/.github/workflows/Dockerfile.gnu
+++ /dev/null
@@ -1,68 +0,0 @@
-#***********************************************************************
-#* 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 .
-#***********************************************************************
-# FMS CI image recipefile for GNU
-# Runs on centos stream (builder has same base from redhat registry)
-#
-# arguments to specify versions to build can be given to docker or changed here (--build-arg name=val)
-FROM spack/rockylinux9:latest as builder
-
-ARG gcc_version=12.3.0
-ARG netcdfc_version=4.9.0
-ARG netcdff_version=4.6.0
-ARG libyaml_version=0.2.5
-ARG mpich_version=4.0.2
-
-COPY spack.env /opt/deps/spack.env
-
-# perl's download kept timing out
-RUN sed -i 's/connect_timeout: 10/connect_timeout: 600/' /opt/spack/etc/spack/defaults/config.yaml && \
- spack install gcc@${gcc_version} && \
- source /opt/spack/share/spack/setup-env.sh && \
- spack load gcc@${gcc_version} && \
- spack compiler find && \
- sed "s/COMPILER/gcc@$gcc_version/" /opt/deps/spack.env > spack.yaml && \
- sed -i "s/NETCDF_C_VERSION/$netcdfc_version/" spack.yaml && \
- sed -i "s/NETCDF_F_VERSION/$netcdff_version/" spack.yaml && \
- sed -i "s/LIBYAML_VERSION/$libyaml_version/" spack.yaml && \
- sed -i "s/MPI_LIB/mpich@$mpich_version/" spack.yaml && \
- spack env activate -d . && \
- spack -e . concretize -f > /opt/deps/deps.log && \
- spack install --fail-fast
-
-# copy built software to base from first image
-FROM rockylinux:9
-
-COPY --from=builder /opt/view/ /opt/view/
-COPY --from=builder /opt/deps/ /opt/deps/
-
-# input files used with --enable-input-tests
-# need to be on the dev boxes if building
-COPY ./fms_test_input /home/unit_tests_input
-
-RUN dnf install -y autoconf make automake m4 libtool pkg-config zip
-
-ENV FC="mpifort"
-ENV CC="mpicc"
-ENV MPICH_FC="/opt/view/bin/gfortran"
-ENV MPICH_CC="/opt/view/bin/gcc"
-ENV FCFLAGS="-I/opt/view/include"
-ENV CFLAGS="-I/opt/view/include"
-ENV LDFLAGS="-L/opt/view/lib"
-ENV LD_LIBRARY_PATH="/opt/view/lib:/opt/view/lib64:/usr/local/lib:/usr/local/lib64"
-ENV PATH="/opt/view/bin:/usr/local/bin:/usr/bin:/usr/local/sbin:/usr/sbin"
diff --git a/.github/workflows/github_autotools_gnu.yml b/.github/workflows/github_autotools_gnu.yml
index 8df7021bb9..7be75bbe68 100644
--- a/.github/workflows/github_autotools_gnu.yml
+++ b/.github/workflows/github_autotools_gnu.yml
@@ -14,17 +14,17 @@ jobs:
runs-on: ubuntu-latest
strategy:
matrix:
- conf-flag: [ --disable-openmp, --disable-setting-flags, --with-mpi=no, --disable-r8-defaults]
+ conf-flag: [ --disable-openmp, --disable-setting-flags, --with-mpi=no, --disable-r8-default]
input-flag: [--with-yaml, --enable-test-input=/home/unit_tests_input]
exclude:
- conf-flag: --with-mpi=no
input-flag: --enable-test-input=/home/unit_tests_input
container:
- image: noaagfdl/fms-ci-rocky-gnu:12.3.0
+ image: ghcr.io/noaa-gfdl/fms/fms-ci-rocky-gnu:13.2.0
env:
TEST_VERBOSE: 1
DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flag }} ${{ matrix.input-flag }} ${{ matrix.io-flag }}"
- SKIP_TESTS: "test_yaml_parser.5" # temporary till fixes are in
+ SKIP_TESTS: "test_horiz_interp2.[23-24]" # TODO (couldn't reproduce outside CI)
steps:
- name: Checkout code
uses: actions/checkout@v4
diff --git a/.github/workflows/github_cmake_gnu.yml b/.github/workflows/github_cmake_gnu.yml
index b8ee629ab3..de71dcbbdf 100644
--- a/.github/workflows/github_cmake_gnu.yml
+++ b/.github/workflows/github_cmake_gnu.yml
@@ -16,10 +16,7 @@ jobs:
libyaml-flag: [ "", -DWITH_YAML=on ]
io-flag: [ "", -DUSE_DEPRECATED_IO=on ]
container:
- image: ghcr.io/noaa-gfdl/fms/fms-ci-rocky-gnu:12.3.0
- credentials:
- username: ${{ github.actor }}
- password: ${{ secrets.github_token }}
+ image: ghcr.io/noaa-gfdl/fms/fms-ci-rocky-gnu:13.2.0
env:
CMAKE_FLAGS: "${{ matrix.omp-flags }} ${{ matrix.io-flag }} ${{ matrix.libyaml-flag }} -D64BIT=on"
steps:
diff --git a/.github/workflows/github_coupler_gnu.yml b/.github/workflows/github_coupler_gnu.yml
index 70cf0db3a5..d42a28f2c6 100644
--- a/.github/workflows/github_coupler_gnu.yml
+++ b/.github/workflows/github_coupler_gnu.yml
@@ -10,7 +10,7 @@ jobs:
coupler-build:
runs-on: ubuntu-latest
container:
- image: ghcr.io/noaa-gfdl/fms/fms-ci-rocky-gnu:12.3.0
+ image: ghcr.io/noaa-gfdl/fms/fms-ci-rocky-gnu:13.2.0
credentials:
username: ${{ github.actor }}
password: ${{ secrets.github_token }}
diff --git a/.github/workflows/spack.env b/.github/workflows/spack.env
deleted file mode 100644
index 69a3bdcbd0..0000000000
--- a/.github/workflows/spack.env
+++ /dev/null
@@ -1,17 +0,0 @@
-# template for spack environment yaml
-# uppercase words get replaced before activating
-spack:
- specs:
- - COMPILER
- - MPI_LIB
- - netcdf-c@NETCDF_C_VERSION ^MPI_LIB
- - netcdf-fortran@NETCDF_F_VERSION
- - libyaml@LIBYAML_VERSION
- concretizer:
- unify: true
- packages:
- all:
- compiler: [ COMPILER ]
- config:
- install_tree: /opt/deps
- view: /opt/view
diff --git a/test_fms/parser/test_output_yaml.F90 b/test_fms/parser/test_output_yaml.F90
index 010ad8b187..6122ff7ab3 100644
--- a/test_fms/parser/test_output_yaml.F90
+++ b/test_fms/parser/test_output_yaml.F90
@@ -203,11 +203,11 @@ program test_output_yaml
call yaml_out_add_level2key( "order 4",k1(1))
call yaml_out_add_level2key( "sides", k2(1))
call yaml_out_add_level2key( "specials", k2(2))
- call write_yaml_from_struct_3 (filename, 1, k1, v1, a2, k2, v2, a3, (/1, 1, 1, 1, 2, 1/), k3, v3, &
+ call write_yaml_from_struct_3 (trim(filename), 1, k1, v1, a2, k2, v2, a3, (/1, 1, 1, 1, 2, 1/), k3, v3, &
& (/ 1, 1, 1 , 1, 0 ,0 ,0 ,0/))
else
!> Write the yaml
- call write_yaml_from_struct_3 (filename, 1, k1, v1, a2, k2, v2, a3, a3each, k3, v3, (/ 3, 0, 0 , 0, 0 ,0 ,0 ,0/))
+ call write_yaml_from_struct_3 (trim(filename), 1, k1, v1, a2, k2, v2, a3, a3each, k3, v3,(/3, 0, 0, 0, 0, 0, 0, 0/))
endif
!> Check yaml output against reference
diff --git a/test_fms/test-lib.sh.in b/test_fms/test-lib.sh.in
index 9be57a630a..93ba65d08e 100644
--- a/test_fms/test-lib.sh.in
+++ b/test_fms/test-lib.sh.in
@@ -261,7 +261,7 @@ match_pattern_list_ () {
break
fi
if test $num -ge $first -a $num -le $last ; then
- return 0
+ test "$tNameArg" = "$tNamePattern" && return 0
fi
fi
done
From e429ebdcfe40da300d6f2483501e9b845f9179b4 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Tue, 30 Apr 2024 09:23:57 -0400
Subject: [PATCH 011/168] chore: Update CONTRIBUTING.md with section for code
reviews (#1495)
---
CONTRIBUTING.md | 27 +++++++++++++++++++++++++++
1 file changed, 27 insertions(+)
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index 1ad061ba1c..d4cb0f35a1 100644
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -94,6 +94,33 @@ long-term, portability, and the scope of the impact on the code base. Therefore,
Modeling Systems does not guarantee that all pull requests will be accepted,
even if the changes pass the initial testing phases, and are otherwise correct.
+## Reviewing Pull Requests
+
+When reviewing a pull request, members of MSD should look for the following:
+
+- Design
+ - Does the code change belong in the FMS library or does it better belong elsewhere such as a component repository or the FMScoupler?
+ - Could existing routines/modules be utilized to reduce redundancy?
+ - Temporary changes/fixes meant to be removed should be avoided whenever possible
+- Functionality
+ - Does this PR do what is intended (and stated)
+ - Are the changes good for both end-users and developers?
+ - Will the code change impact existing end-users needlessly?
+- Complexity
+ - Are the changes easily understood by the reader / reviewer?
+- Testing
+ - Code changes should include a test program or a modification to a test program to ensure the code is covered by the test suite
+- Comments
+ - Inline comments for complex code segments or intricacies to make the purpose of the code reasonably clear
+- Style and Consistency
+ - Code should follow the syle guide in general, but should also be consistent to the file the change is made in
+- Documentation
+ - If a PR changes the behaviour or instructions, accompanying documentation should also change
+- Thoroughness
+ - Reviews should be done line by line, and the surrounding context/file should be taken into account
+
+Comments on pull requests should be courteous and constructive, giving useful feedback and explanations for why changes should be made. See the [code of conduct](CODE_OF_CONDUCT.md) for more information.
+
## Tests
FMS uses TravisCI and gitlab-CI to run build tests for libFMS. Users may create
From 648cbcfb607a71fd22d11d8cca8f9fe860f409b8 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Tue, 30 Apr 2024 09:27:07 -0400
Subject: [PATCH 012/168] fix: autotools hdf5 compiler check (#1493)
---
Makefile.am | 4 ++--
configure.ac | 2 +-
test_fms/monin_obukhov/test_monin_obukhov2.sh | 2 +-
3 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 22fb68f97d..f9a8211f8f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -125,10 +125,10 @@ check-code-coverage: check
.PHONY: check-code-coverage
clean-local:
- -rm -rf .mods coverage-data coverage-report
+ -rm -rf .mods coverage-data coverage-report test.nc
else
clean-local:
- -rm -rf .mods
+ -rm -rf .mods test.nc
endif
install-data-hook:
diff --git a/configure.ac b/configure.ac
index cd64493729..30e94759f6 100644
--- a/configure.ac
+++ b/configure.ac
@@ -265,7 +265,7 @@ AC_MSG_CHECKING([if HDF5 version causes floating point exceptions with set flags
AC_RUN_IFELSE([AC_LANG_PROGRAM([], [[
use netcdf
integer i, j
- j = nf90_open("test.nc", NC_WRITE, i)
+ j = nf90_create("test.nc", NC_WRITE, i)
]])], [hdf5_fpe_bug=no], [hdf5_fpe_bug=yes])
AC_MSG_RESULT([$hdf5_fpe_bug])
if test $hdf5_fpe_bug = yes; then
diff --git a/test_fms/monin_obukhov/test_monin_obukhov2.sh b/test_fms/monin_obukhov/test_monin_obukhov2.sh
index 72a5f9b3fa..c125164c92 100755
--- a/test_fms/monin_obukhov/test_monin_obukhov2.sh
+++ b/test_fms/monin_obukhov/test_monin_obukhov2.sh
@@ -35,7 +35,7 @@ for p in r4 r8
do
cp ${top_srcdir}/test_fms/monin_obukhov/input.${p}.nml input.nml
test_expect_success "test monin_obukhov_mod (${p})" "mpirun -n 1 ./test_monin_obukhov_${p}"
- rm input.nml
+ rm -f input.nml
done
test_done
From a9a61651c3ba285235b0eda2b78cabd1ae01c199 Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Wed, 6 Oct 2021 13:53:24 -0400
Subject: [PATCH 013/168] feat: first attempt at adding the fms_diag_object to
diag manager
---
diag_manager/Makefile.am | 16 +-
diag_manager/diag_data.F90 | 51 ++-
diag_manager/diag_yaml.c | 6 +
diag_manager/diag_yaml.h | 28 ++
diag_manager/fms_diag_object.F90 | 547 +++++++++++++++++++++++++++++++
diag_manager/fms_diag_yaml.F90 | 32 ++
6 files changed, 676 insertions(+), 4 deletions(-)
create mode 100644 diag_manager/diag_yaml.c
create mode 100644 diag_manager/diag_yaml.h
create mode 100644 diag_manager/fms_diag_object.F90
create mode 100644 diag_manager/fms_diag_yaml.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 13ea77d8b7..7ada7b1a51 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -45,6 +45,10 @@ libdiag_manager_la_SOURCES = \
fms_diag_bbox.F90 \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh
+ fms_diag_yaml.F90 \
+ diag_yaml.h \
+ diag_yaml.c \
+ fms_diag_object.F90
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
@@ -53,6 +57,7 @@ diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODE
diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \
diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
+<<<<<<< HEAD
fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
@@ -63,8 +68,9 @@ fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \
- fms_diag_fieldbuff_update_mod.$(FC_MODEXT)
-
+ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT)
+fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
+fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
MODFILES = \
@@ -76,14 +82,18 @@ MODFILES = \
diag_table_mod.$(FC_MODEXT) \
fms_diag_time_reduction_mod.$(FC_MODEXT) \
fms_diag_outfield_mod.$(FC_MODEXT) \
- fms_diag_bbox_mod.$(FC_MODEXT) \
+ fms_diag_bbox_mod.$(FC_MODEXT) \
fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \
fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \
diag_manager_mod.$(FC_MODEXT) \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh
+ fms_diag_yaml_mod.$(FC_MODEXT) \
+ fms_diag_object_mod.$(FC_MODEXT) \
+ diag_manager_mod.$(FC_MODEXT)
nodist_include_HEADERS = $(MODFILES)
+
BUILT_SOURCES = $(MODFILES)
include $(top_srcdir)/mkmods.mk
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index e5d7942946..8e9ab8bd0a 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -56,12 +56,34 @@ MODULE diag_data_mod
! NF90_FILL_REAL has value of 9.9692099683868690e+36.
USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL
use fms2_io_mod
-
+ use iso_c_binding
IMPLICIT NONE
PUBLIC
! Specify storage limits for fixed size tables used for pointers, etc.
+ integer, parameter :: diag_null = -999 !< Integer represening NULL in the diag_object
+ integer, parameter :: diag_not_found = -1
+ integer, parameter :: diag_not_registered = 0
+ integer, parameter :: diag_registered_id = 10
+ !> Supported averaging intervals
+ integer, parameter :: monthly = 30
+ integer, parameter :: daily = 24
+ integer, parameter :: diurnal = 2
+ integer, parameter :: yearly = 12
+ integer, parameter :: no_diag_averaging = 0
+ integer, parameter :: instantaneous = 0
+ integer, parameter :: three_hourly = 3
+ integer, parameter :: six_hourly = 6
+ !integer, parameter :: seasonally = 180
+ !> Supported type/kind of the variable
+ !integer, parameter :: r16=16
+ integer, parameter :: r8 = 8
+ integer, parameter :: r4 = 4
+ integer, parameter :: i8 = -8
+ integer, parameter :: i4 = -4
+ integer, parameter :: string = 19 !< s is the 19th letter of the alphabet
+ integer, parameter :: null_type_int = -999
INTEGER, PARAMETER :: MAX_FIELDS_PER_FILE = 300 !< Maximum number of fields per file.
INTEGER, PARAMETER :: DIAG_OTHER = 0
INTEGER, PARAMETER :: DIAG_OCEAN = 1
@@ -82,6 +104,33 @@ MODULE diag_data_mod
!> @}
+
+ !> @brief The files type matching a C struct containing diag_yaml information
+ !> @ingroup diag_data_mod
+type, bind(c) :: diag_files_type
+ character (kind=c_char) :: fname (20) !< file name
+ character (kind=c_char) :: frequnit (7) !< the frequency unit
+ integer (c_int) :: freq !< the frequency of data
+ character (kind=c_char) :: timeunit(7) !< The unit of time
+ character (kind=c_char) :: unlimdim(8) !< The name of the unlimited dimension
+ character (kind=c_char) :: key(8) !< Storage for the key in the yaml file
+end type diag_files_type
+!> @brief The field type matching the C struct for diag_yaml information
+ !> @ingroup diag_data_mod
+type, bind(c) :: diag_fields_type
+ character (kind=c_char) :: fname (20) !< The field/diagnostic name
+ character (kind=c_char) :: var(20) !< The name of the variable
+ character (kind=c_char) :: files(20) !< The files that the diagnostic will be written to
+ integer (c_int) :: ikind !< The type/kind of the variable
+ character (kind=c_char) :: skind(20) !< The type/kind of the variable
+ character (kind=c_char) :: reduction(20) !< IDK
+ character (kind=c_char) :: all_all(4) !< This has to be "all"
+ character (kind=c_char) :: region(50) !< The region
+ character (kind=c_char) :: regcoord(50) !< Coodinates of the region
+ character (kind=c_char) :: module_location(20) !< The module
+ character (kind=c_char) :: key(8) !< Storage for the key in the yaml file
+end type diag_fields_type
+
!> @brief Contains the coordinates of the local domain to output.
!> @ingroup diag_data_mod
TYPE diag_grid
diff --git a/diag_manager/diag_yaml.c b/diag_manager/diag_yaml.c
new file mode 100644
index 0000000000..3dbb680da3
--- /dev/null
+++ b/diag_manager/diag_yaml.c
@@ -0,0 +1,6 @@
+#include
+#include
+#include
+#include
+#include
+
diff --git a/diag_manager/diag_yaml.h b/diag_manager/diag_yaml.h
new file mode 100644
index 0000000000..fe1c9212ed
--- /dev/null
+++ b/diag_manager/diag_yaml.h
@@ -0,0 +1,28 @@
+#include
+#include
+#include
+#include
+typedef struct diag_files {
+ char name [20];
+ char frequnit [7];
+ int freq;
+ char timeunit [7];
+ char unlimdim [8];
+ char key [8];
+} files;
+
+
+typedef struct diag_fields {
+ char name[20];
+ char var[20];
+ char files[20];
+ int intkind;
+ char skind[20];
+ char reduction[20];
+ char all[4];
+ char region[50];
+ char regcoord[50];
+ char module[20];
+ char key [8];
+} fields;
+
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
new file mode 100644
index 0000000000..41d4756307
--- /dev/null
+++ b/diag_manager/fms_diag_object.F90
@@ -0,0 +1,547 @@
+module fms_diag_object_mod
+!> \author Tom Robinson
+!> \email thomas.robinson@noaa.gov
+!! \brief Contains routines for the diag_objects
+!!
+!! \description The diag_manager passes an object back and forth between the diag routines and the users.
+!! The procedures of this object and the types are all in this module. The fms_dag_object is a type
+!! that contains all of the information of the variable. It is extended by a type that holds the
+!! appropriate buffer for the data for manipulation.
+use diag_data_mod, only: diag_null
+use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int
+use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id
+use fms_diag_yaml_mod, only: is_field_type_null
+use fms_diag_yaml_mod, only: diag_fields_type, diag_files_type, get_diag_table_field
+use diag_axis_mod, only: diag_axis_type
+use mpp_mod, only: fatal, note, warning, mpp_error
+!use diag_util_mod, only: int_to_cs, logical_to_cs
+!USE diag_data_mod, ONLY: fileobjU, fileobj, fnum_for_domain, fileobjND
+
+use fms2_io_mod
+use iso_c_binding
+
+implicit none
+
+interface operator (<)
+ procedure obj_lt_int
+ procedure int_lt_obj
+end interface
+interface operator (<=)
+ procedure obj_le_int
+ procedure int_le_obj
+end interface
+interface operator (>)
+ procedure obj_gt_int
+ procedure int_gt_obj
+end interface
+interface operator (>=)
+ procedure obj_ge_int
+ procedure int_ge_obj
+end interface
+interface operator (==)
+ procedure obj_eq_int
+ procedure int_eq_obj
+end interface
+interface operator (.ne.)
+ procedure obj_ne_int
+ procedure int_ne_obj
+end interface
+
+
+!> \brief Object that holds all variable information
+type fms_diag_object
+ type (diag_fields_type) :: diag_field !< info from diag_table
+ type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table
+ integer, allocatable, private :: diag_id !< unique id for varable
+ class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the
+ !! file objects for this variable
+ character(len=:), allocatable, dimension(:) :: metadata !< metedata for the variable
+ logical, private :: static !< true is this is a static var
+ logical, allocatable, private :: registered !< true when registered
+ integer, allocatable, dimension(:), private :: frequency !< specifies the frequency
+
+ integer, allocatable, private :: vartype !< the type of varaible
+ character(len=:), allocatable, private :: varname !< the name of the variable
+ character(len=:), allocatable, private :: longname !< longname of the variable
+ character(len=:), allocatable, private :: units !< the units
+ character(len=:), allocatable, private :: modname !< the module
+ integer, private :: missing_value !< The missing fill value
+ integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs
+ type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object
+
+ contains
+! procedure :: send_data => fms_send_data !!TODO
+ procedure :: init_ob => diag_obj_init
+ procedure :: diag_id_inq => fms_diag_id_inq
+ procedure :: copy => copy_diag_obj
+ procedure :: register_meta => fms_register_diag_field_obj
+ procedure :: setID => set_diag_id
+ procedure :: is_registered => diag_ob_registered
+ procedure :: set_type => set_vartype
+ procedure :: vartype_inq => what_is_vartype
+
+ procedure :: is_static => diag_obj_is_static
+ procedure :: is_registeredB => diag_obj_is_registered
+ procedure :: get_vartype => diag_obj_get_vartype
+ procedure :: get_varname => diag_obj_get_varname
+
+end type fms_diag_object
+!> \brief Extends the variable object to work with multiple types of data
+type, extends(fms_diag_object) :: fms_diag_object_scalar
+ class(*), allocatable :: vardata
+end type fms_diag_object_scalar
+type, extends(fms_diag_object) :: fms_diag_object_1d
+ class(*), allocatable, dimension(:) :: vardata
+end type fms_diag_object_1d
+type, extends(fms_diag_object) :: fms_diag_object_2d
+ class(*), allocatable, dimension(:,:) :: vardata
+end type fms_diag_object_2d
+type, extends(fms_diag_object) :: fms_diag_object_3d
+ class(*), allocatable, dimension(:,:,:) :: vardata
+end type fms_diag_object_3d
+type, extends(fms_diag_object) :: fms_diag_object_4d
+ class(*), allocatable, dimension(:,:,:,:) :: vardata
+end type fms_diag_object_4d
+type, extends(fms_diag_object) :: fms_diag_object_5d
+ class(*), allocatable, dimension(:,:,:,:,:) :: vardata
+end type fms_diag_object_5d
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+type(fms_diag_object) :: null_ob
+type(fms_diag_object_scalar) :: null_sc
+type(fms_diag_object_1d) :: null_1d
+type(fms_diag_object_2d) :: null_2d
+type(fms_diag_object_3d) :: null_3d
+type(fms_diag_object_4d) :: null_4d
+type(fms_diag_object_5d) :: null_5d
+
+integer,private :: MAX_LEN_VARNAME
+integer,private :: MAX_LEN_META
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+public :: fms_diag_object, fms_diag_object_scalar, fms_diag_object_1d
+public :: fms_diag_object_2d, fms_diag_object_3d, fms_diag_object_4d, fms_diag_object_5d
+public :: copy_diag_obj, fms_diag_id_inq
+public :: operator (>),operator (<),operator (>=),operator (<=),operator (==),operator (.ne.)
+public :: null_sc, null_1d, null_2d, null_3d, null_4d, null_5d
+public :: fms_diag_object_init
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ CONTAINS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+subroutine fms_diag_object_init (mlv,mlm)
+ integer, intent(in) :: mlv !< The maximum length of the varname
+ integer, intent(in) :: mlm !< The maximum length of the metadata
+!> Get info from the namelist
+ MAX_LEN_VARNAME = mlv
+ MAX_LEN_META = mlm
+!> Initialize the null_d variables
+ null_ob%diag_id = DIAG_NULL
+ null_sc%diag_id = DIAG_NULL
+ null_1d%diag_id = DIAG_NULL
+ null_2d%diag_id = DIAG_NULL
+ null_3d%diag_id = DIAG_NULL
+ null_4d%diag_id = DIAG_NULL
+ null_5d%diag_id = DIAG_NULL
+end subroutine fms_diag_object_init
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \Description Sets the diag_id to the not registered value.
+subroutine diag_obj_init(ob)
+ class (fms_diag_object) , intent(inout) :: ob
+ select type (ob)
+ class is (fms_diag_object)
+ ob%diag_id = diag_not_registered !null_ob%diag_id
+ end select
+end subroutine diag_obj_init
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \description Fills in and allocates (when necessary) the values in the diagnostic object
+subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
+ class(fms_diag_object) , intent(inout) :: dobj
+ character(*) , intent(in) :: modname!< The module name
+ character(*) , intent(in) :: varname!< The variable name
+ integer , dimension(:) , intent(in), optional :: axes !< Th character(:),allocatable :: rese axes
+ integer , intent(in), optional :: time !< Time placeholder
+ character(*) , intent(in), optional :: longname!< The variable long name
+ character(*) , intent(in), optional :: units !< Units of the variable
+ integer , intent(in), optional :: missing_value !< A missing value to be used
+ character(*), dimension(:) , intent(in), optional :: metadata
+! class(*), pointer :: vptr
+
+
+!> Fill in information from the register call
+ allocate(character(len=MAX_LEN_VARNAME) :: dobj%varname)
+ dobj%varname = trim(varname)
+ allocate(character(len=len(modname)) :: dobj%modname)
+ dobj%modname = trim(modname)
+!> Grab the information from the diag_table
+ dobj%diag_field = get_diag_table_field(trim(varname))
+ if (is_field_type_null(dobj%diag_field)) then
+ dobj%diag_id = diag_not_found
+ dobj%vartype = diag_null
+ return
+ endif
+!> get the optional arguments if included and the diagnostic is in the diag table
+ if (present(longname)) then
+ allocate(character(len=len(longname)) :: dobj%longname)
+ dobj%longname = trim(longname)
+ endif
+ if (present(units)) then
+ allocate(character(len=len(units)) :: dobj%units)
+ dobj%units = trim(units)
+ endif
+ if (present(metadata)) then
+ allocate(character(len=MAX_LEN_META) :: dobj%metadata(size(metadata)))
+ dobj%metadata = metadata
+ endif
+ if (present(missing_value)) then
+ dobj%missing_value = missing_value
+ else
+ dobj%missing_value = DIAG_NULL
+ endif
+
+! write(6,*)"IKIND for diag_fields(1) is",dobj%diag_fields(1)%ikind
+! write(6,*)"IKIND for "//trim(varname)//" is ",dobj%diag_field%ikind
+end subroutine fms_register_diag_field_obj
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \brief Sets the diag_id. This can only be done if a variable is unregistered
+subroutine set_diag_id(objin , id)
+ class (fms_diag_object) , intent(inout):: objin
+ integer :: id
+ if (allocated(objin%registered)) then
+ if (objin%registered) then
+ call mpp_error("set_diag_id", "The variable"//objin%varname//" is already registered", FATAL)
+ endif
+ else
+ objin%diag_id = id
+ endif
+end subroutine set_diag_id
+!> \brief Find the type of the variable and store it in the object
+subroutine set_vartype(objin , var)
+ class (fms_diag_object) , intent(inout):: objin
+ class(*) :: var
+ select type (var)
+ type is (real(kind=8))
+ objin%vartype = r8
+ type is (real(kind=4))
+ objin%vartype = r4
+ type is (integer(kind=8))
+ objin%vartype = i8
+ type is (integer(kind=4))
+ objin%vartype = i4
+ type is (character(*))
+ objin%vartype = string
+ class default
+ objin%vartype = null_type_int
+ call mpp_error("set_vartype", "The variable"//objin%varname//" is not a supported type "// &
+ " r8, r4, i8, i4, or string.", warning)
+ end select
+end subroutine set_vartype
+!> \brief Prints to the screen what type the diag variable is
+subroutine what_is_vartype(objin)
+ class (fms_diag_object) , intent(inout):: objin
+ if (.not. allocated(objin%vartype)) then
+ call mpp_error("what_is_vartype", "The variable type has not been set prior to this call", warning)
+ return
+ endif
+ select case (objin%vartype)
+ case (r8)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is REAL(kind=8)", NOTE)
+ case (r4)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is REAL(kind=4)", NOTE)
+ case (i8)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is INTEGER(kind=8)", NOTE)
+ case (i4)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is INTEGER(kind=4)", NOTE)
+ case (string)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is CHARACTER(*)", NOTE)
+ case (null_type_int)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " was not set", WARNING)
+ case default
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is not supported by diag_manager", FATAL)
+ end select
+end subroutine what_is_vartype
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!MZ Is this a TODO. Many problems:
+!> \brief Registers the object
+subroutine diag_ob_registered(objin , reg)
+ class (fms_diag_object) , intent(inout):: objin
+ logical , intent(in) :: reg !< If registering, this is true
+ objin%registered = reg
+end subroutine diag_ob_registered
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \brief Copies the calling object into the object that is the argument of the subroutine
+subroutine copy_diag_obj(objin , objout)
+ class (fms_diag_object) , intent(in) :: objin
+ class (fms_diag_object) , intent(inout) , allocatable :: objout !< The destination of the copy
+select type (objout)
+ class is (fms_diag_object)
+
+ if (allocated(objin%registered)) then
+ objout%registered = objin%registered
+ else
+ call mpp_error("copy_diag_obj", "You can only copy objects that have been registered",warning)
+ endif
+! type (diag_fields_type) :: diag_field !< info from diag_table
+! type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table
+
+ objout%diag_id = objin%diag_id
+
+! class (fms_io_obj), allocatable, dimension(:) :: fms_fileobj !< fileobjs
+ if (allocated(objin%metadata)) objout%metadata = objin%metadata
+ objout%static = objin%static
+ if (allocated(objin%frequency)) objout%frequency = objin%frequency
+ if (allocated(objin%varname)) objout%varname = objin%varname
+end select
+end subroutine copy_diag_obj
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \brief Returns the diag_id
+integer function fms_diag_id_inq (dobj) result(diag_id)
+ class(fms_diag_object) , intent(inout) :: dobj
+! character(*) , intent(in) :: varname
+
+ if (.not.allocated(dobj%registered)) then
+ call mpp_error ("fms_what_is_my_id","The diag object was not registered", fatal)
+ endif
+ diag_id = dobj%diag_id
+end function fms_diag_id_inq
+
+!> Function to return a character (string) representation of the most basic
+!> object identity info. Intended for debugging and warning. The format produced is:
+!> [dobj: o.varname(string|?), vartype (string|?), o.registered (T|F|?), diag_id (id|?)].
+!> A questionmark "?" is set in place of the variable that is not yet allocated
+!>TODO: Add diag_id ?
+function fms_diag_obj_as_string_basic(dobj) result(rslt)
+ class(fms_diag_object), allocatable, intent(in) :: dobj
+ character(:), allocatable :: rslt
+ character (len=:), allocatable :: registered, vartype, varname, diag_id
+ if ( .not. allocated (dobj)) then
+ varname = "?"
+ vartype = "?"
+ registered = "?"
+ diag_id = "?"
+ rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]"
+ return
+ end if
+
+! if(allocated (dobj%registered)) then
+! registered = logical_to_cs (dobj%registered)
+! else
+! registered = "?"
+! end if
+
+! if(allocated (dobj%diag_id)) then
+! diag_id = int_to_cs (dobj%diag_id)
+! else
+! diag_id = "?"
+! end if
+
+! if(allocated (dobj%vartype)) then
+! vartype = int_to_cs (dobj%vartype)
+! else
+! registered = "?"
+! end if
+
+ if(allocated (dobj%varname)) then
+ varname = dobj%varname
+ else
+ registered = "?"
+ end if
+
+ rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]"
+
+end function fms_diag_obj_as_string_basic
+
+
+function diag_obj_is_registered (obj) result (rslt)
+ class(fms_diag_object), intent(in) :: obj
+ logical :: rslt
+ rslt = obj%registered
+end function diag_obj_is_registered
+
+function diag_obj_is_static (obj) result (rslt)
+ class(fms_diag_object), intent(in) :: obj
+ logical :: rslt
+ rslt = obj%static
+end function diag_obj_is_static
+
+function diag_obj_get_vartype (obj) result (rslt)
+ class(fms_diag_object), intent(in) :: obj
+ integer :: rslt
+ rslt = obj%vartype
+end function diag_obj_get_vartype
+
+function diag_obj_get_varname(obj) result (rslt)
+ class(fms_diag_object), intent(in) :: obj
+ character(len=len(obj%varname)) :: rslt
+ rslt = obj%varname
+end function diag_obj_get_varname
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Operator Overrides !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \brief override for checking if object ID is greater than an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_gt_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i >= diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (obj%diag_id > i)
+ endif
+end function obj_gt_int
+!> \brief override for checking if integer (ID) is greater than an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_gt_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i <= diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj)) then
+ ll = .true.
+ else
+ ll = (i > obj%diag_id)
+ endif
+end function int_gt_obj
+!> \brief override for checking if object ID is less than an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_lt_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i > diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj)) then
+ ll = .false.
+ else
+ ll = (obj%diag_id < i)
+ endif
+end function obj_lt_int
+!> \brief override for checking if integer (ID) is less than an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_lt_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i >= diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj)) then
+ ll = .true.
+ else
+ ll = (i < obj%diag_id)
+ endif
+end function int_lt_obj
+!> \brief override for checking if object ID is greater than or equal to an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_ge_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i <= diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (obj%diag_id >= i)
+ endif
+end function obj_ge_int
+!> \brief override for checking if integer (ID) is greater than or equal to an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_ge_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i >= diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (i >= obj%diag_id)
+ endif
+end function int_ge_obj
+!> \brief override for checking if object ID is less than or equal to an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_le_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i >= diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (obj%diag_id <= i)
+ endif
+end function obj_le_int
+!> \brief override for checking if integer (ID) is less than or equal to an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_le_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i <= diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (i <= obj%diag_id)
+ endif
+end function int_le_obj
+!> \brief override for checking if object ID is equal to an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_eq_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i == diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (obj%diag_id == i)
+ endif
+end function obj_eq_int
+!> \brief override for checking if integer (ID) is equal to an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_eq_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i == diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (i == obj%diag_id)
+ endif
+end function int_eq_obj
+
+!> \brief override for checking if object ID is not equal to an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_ne_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i == diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj) ) then
+ ll = .true.
+ else
+ ll = (obj%diag_id .ne. i)
+ endif
+end function obj_ne_int
+
+!> \brief override for checking if integer (ID) is not equal to an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_ne_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i == diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj) ) then
+ ll = .true.
+ else
+ ll = (i .ne. obj%diag_id)
+ endif
+end function int_ne_obj
+
+end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
new file mode 100644
index 0000000000..e565f7c9a1
--- /dev/null
+++ b/diag_manager/fms_diag_yaml.F90
@@ -0,0 +1,32 @@
+module fms_diag_yaml_mod
+
+use fms_diag_data_mod, only: diag_files_type, diag_fields_type
+
+contains
+!> \brief Compares two field type variables
+pure logical function is_field_type_null (in1)
+type(diag_fields_type), intent(in) :: in1
+is_field_type_null = (in1%ikind == DIAG_NULL)
+end function is_field_type_null
+
+!!TODO
+!> \brief looks for a diag_field based on it's name.
+!! Returns null if field is not found.
+type(diag_fields_type)function get_diag_table_field (field_name) result (field)
+ character(len=*), intent(IN) :: field_name
+ integer :: i
+! do i = 1,size(diag_fields)
+! if (trim(field_name) == trim(fms_c2f_string(diag_fields(i)%fname))) then
+! field = diag_fields(i)
+!write (6,*) field_name//" Found"
+!
+! return
+! endif
+! enddo
+! field = null_field_type
+
+end function get_diag_table_field
+
+
+
+end module fms_diag_yaml_mod
From 26b92b21a17916978da3174e7c624ded4777217d Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Wed, 6 Oct 2021 14:13:48 -0400
Subject: [PATCH 014/168] feat: Second attempt at adding the fms_diag_object to
diag manager
---
diag_manager/Makefile.am | 1 -
diag_manager/fms_diag_yaml.F90 | 2 +-
2 files changed, 1 insertion(+), 2 deletions(-)
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 7ada7b1a51..7169e66b62 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -57,7 +57,6 @@ diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODE
diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \
diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
-<<<<<<< HEAD
fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index e565f7c9a1..f96c50ac84 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -1,6 +1,6 @@
module fms_diag_yaml_mod
-use fms_diag_data_mod, only: diag_files_type, diag_fields_type
+use diag_data_mod, only: diag_files_type, diag_fields_type
contains
!> \brief Compares two field type variables
From bef210db8bcd224b274aad42555ffb7196ab6398 Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Wed, 6 Oct 2021 14:57:38 -0400
Subject: [PATCH 015/168] feat: Adds diag_object to diag_manager folder and
compiles.
---
diag_manager/diag_axis.F90 | 2 +-
diag_manager/diag_yaml.c | 4 ++--
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90
index 606ebd76f2..deda28faef 100644
--- a/diag_manager/diag_axis.F90
+++ b/diag_manager/diag_axis.F90
@@ -52,7 +52,7 @@ MODULE diag_axis_mod
& get_axis_num, get_diag_axis_domain_name, diag_axis_add_attribute,&
& get_domainUG, axis_compatible_check, axis_is_compressed, &
& get_compressed_axes_ids, get_axis_reqfld, &
- & NORTH, EAST, CENTER
+ & NORTH, EAST, CENTER, diag_axis_type
! Include variable "version" to be written to log file
#include
diff --git a/diag_manager/diag_yaml.c b/diag_manager/diag_yaml.c
index 3dbb680da3..29100fd997 100644
--- a/diag_manager/diag_yaml.c
+++ b/diag_manager/diag_yaml.c
@@ -1,6 +1,6 @@
-#include
+/** #include **/
#include
#include
#include
-#include
+/** #include **/
From 2b5faa6b53ab971ada99ff2b1c27d32a7eb4d4a6 Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Wed, 20 Oct 2021 09:33:40 -0400
Subject: [PATCH 016/168] feat: Adds modern diag namelist variable
---
diag_manager/diag_data.F90 | 1 +
diag_manager/diag_manager.F90 | 8 ++++++--
2 files changed, 7 insertions(+), 2 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 8e9ab8bd0a..62972615f5 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -377,6 +377,7 @@ MODULE diag_data_mod
LOGICAL :: prepend_date = .TRUE. !< Should the history file have the start date prepended to the file name.
!! .TRUE. is only supported if the diag_manager_init
!! routine is called with the optional time_init parameter.
+ LOGICAL :: use_modern_diag = .false. !< Namelist flag to use the modernized diag_manager code
LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io
LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons.
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 9a72598915..b500455195 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -230,8 +230,8 @@ MODULE diag_manager_mod
& diag_log_unit, time_unit_list, pelist_name, max_axes, module_is_initialized, max_num_axis_sets,&
& use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,&
& max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,&
- & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time, diag_data_init,&
- & use_mpp_io, use_refactored_send
+ & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time, diag_data_init, &
+ & use_mpp_io, use_modern_diag
USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
@@ -3794,8 +3794,12 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
& max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
& max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
& oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
+<<<<<<< HEAD
& max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io, field_log_separator,&
& use_refactored_send
+=======
+ & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_mpp_io
+>>>>>>> 98bb81e0 (Adds namelist variable)
! If the module was already initialized do nothing
IF ( module_is_initialized ) RETURN
From 42a0c6b841c53feb1386c018535b02e690bfd1e3 Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Tue, 2 Nov 2021 11:47:40 -0400
Subject: [PATCH 017/168] feat: setup diag_yaml_object and remove object
overrides
---
diag_manager/fms_diag_object.F90 | 219 +++----------------------------
diag_manager/fms_diag_yaml.F90 | 42 +++++-
2 files changed, 56 insertions(+), 205 deletions(-)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 41d4756307..27da92a4cf 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -10,8 +10,9 @@ module fms_diag_object_mod
use diag_data_mod, only: diag_null
use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id
+use diag_data_mod, only: diag_fields_type, diag_files_type
use fms_diag_yaml_mod, only: is_field_type_null
-use fms_diag_yaml_mod, only: diag_fields_type, diag_files_type, get_diag_table_field
+use fms_diag_yaml_mod, only: diag_yaml
use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
!use diag_util_mod, only: int_to_cs, logical_to_cs
@@ -22,32 +23,6 @@ module fms_diag_object_mod
implicit none
-interface operator (<)
- procedure obj_lt_int
- procedure int_lt_obj
-end interface
-interface operator (<=)
- procedure obj_le_int
- procedure int_le_obj
-end interface
-interface operator (>)
- procedure obj_gt_int
- procedure int_gt_obj
-end interface
-interface operator (>=)
- procedure obj_ge_int
- procedure int_ge_obj
-end interface
-interface operator (==)
- procedure obj_eq_int
- procedure int_eq_obj
-end interface
-interface operator (.ne.)
- procedure obj_ne_int
- procedure int_ne_obj
-end interface
-
-
!> \brief Object that holds all variable information
type fms_diag_object
type (diag_fields_type) :: diag_field !< info from diag_table
@@ -72,7 +47,8 @@ module fms_diag_object_mod
contains
! procedure :: send_data => fms_send_data !!TODO
procedure :: init_ob => diag_obj_init
- procedure :: diag_id_inq => fms_diag_id_inq
+ procedure :: get_id => fms_diag_get_id
+ procedure :: id => fms_diag_get_id
procedure :: copy => copy_diag_obj
procedure :: register_meta => fms_register_diag_field_obj
procedure :: setID => set_diag_id
@@ -119,8 +95,7 @@ module fms_diag_object_mod
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
public :: fms_diag_object, fms_diag_object_scalar, fms_diag_object_1d
public :: fms_diag_object_2d, fms_diag_object_3d, fms_diag_object_4d, fms_diag_object_5d
-public :: copy_diag_obj, fms_diag_id_inq
-public :: operator (>),operator (<),operator (>=),operator (<=),operator (==),operator (.ne.)
+public :: copy_diag_obj, fms_diag_get_id
public :: null_sc, null_1d, null_2d, null_3d, null_4d, null_5d
public :: fms_diag_object_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -150,6 +125,7 @@ subroutine diag_obj_init(ob)
select type (ob)
class is (fms_diag_object)
ob%diag_id = diag_not_registered !null_ob%diag_id
+ ob%registered = .false.
end select
end subroutine diag_obj_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -173,7 +149,8 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long
allocate(character(len=len(modname)) :: dobj%modname)
dobj%modname = trim(modname)
!> Grab the information from the diag_table
- dobj%diag_field = get_diag_table_field(trim(varname))
+! dobj%diag_field = get_diag_table_field(trim(varname))
+! dobj%diag_field = diag_yaml%get_diag_field(
if (is_field_type_null(dobj%diag_field)) then
dobj%diag_id = diag_not_found
dobj%vartype = diag_null
@@ -200,6 +177,8 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long
! write(6,*)"IKIND for diag_fields(1) is",dobj%diag_fields(1)%ikind
! write(6,*)"IKIND for "//trim(varname)//" is ",dobj%diag_field%ikind
+!> Set the registered flag to true
+ dobj%registered = .true.
end subroutine fms_register_diag_field_obj
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \brief Sets the diag_id. This can only be done if a variable is unregistered
@@ -300,16 +279,19 @@ subroutine copy_diag_obj(objin , objout)
end select
end subroutine copy_diag_obj
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!> \brief Returns the diag_id
-integer function fms_diag_id_inq (dobj) result(diag_id)
+!> \brief Returns the ID integer for a variable
+integer function fms_diag_get_id (dobj) result(diag_id)
class(fms_diag_object) , intent(inout) :: dobj
! character(*) , intent(in) :: varname
-
- if (.not.allocated(dobj%registered)) then
- call mpp_error ("fms_what_is_my_id","The diag object was not registered", fatal)
+!> Check if the diag_object registration has been done
+ if (allocated(dobj%registered)) then
+ !> Return the diag_id if the variable has been registered
+ diag_id = dobj%diag_id
+ else
+!> If the variable is not regitered, then return the unregistered value
+ diag_id = DIAG_NOT_REGISTERED
endif
- diag_id = dobj%diag_id
-end function fms_diag_id_inq
+end function fms_diag_get_id
!> Function to return a character (string) representation of the most basic
!> object identity info. Intended for debugging and warning. The format produced is:
@@ -382,166 +364,5 @@ function diag_obj_get_varname(obj) result (rslt)
rslt = obj%varname
end function diag_obj_get_varname
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Operator Overrides !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!> \brief override for checking if object ID is greater than an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_gt_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i >= diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (obj%diag_id > i)
- endif
-end function obj_gt_int
-!> \brief override for checking if integer (ID) is greater than an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_gt_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i <= diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj)) then
- ll = .true.
- else
- ll = (i > obj%diag_id)
- endif
-end function int_gt_obj
-!> \brief override for checking if object ID is less than an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_lt_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i > diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj)) then
- ll = .false.
- else
- ll = (obj%diag_id < i)
- endif
-end function obj_lt_int
-!> \brief override for checking if integer (ID) is less than an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_lt_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i >= diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj)) then
- ll = .true.
- else
- ll = (i < obj%diag_id)
- endif
-end function int_lt_obj
-!> \brief override for checking if object ID is greater than or equal to an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_ge_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i <= diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (obj%diag_id >= i)
- endif
-end function obj_ge_int
-!> \brief override for checking if integer (ID) is greater than or equal to an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_ge_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i >= diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (i >= obj%diag_id)
- endif
-end function int_ge_obj
-!> \brief override for checking if object ID is less than or equal to an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_le_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i >= diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (obj%diag_id <= i)
- endif
-end function obj_le_int
-!> \brief override for checking if integer (ID) is less than or equal to an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_le_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i <= diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (i <= obj%diag_id)
- endif
-end function int_le_obj
-!> \brief override for checking if object ID is equal to an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_eq_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i == diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (obj%diag_id == i)
- endif
-end function obj_eq_int
-!> \brief override for checking if integer (ID) is equal to an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_eq_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i == diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (i == obj%diag_id)
- endif
-end function int_eq_obj
-
-!> \brief override for checking if object ID is not equal to an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_ne_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i == diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj) ) then
- ll = .true.
- else
- ll = (obj%diag_id .ne. i)
- endif
-end function obj_ne_int
-
-!> \brief override for checking if integer (ID) is not equal to an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_ne_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i == diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj) ) then
- ll = .true.
- else
- ll = (i .ne. obj%diag_id)
- endif
-end function int_ne_obj
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index f96c50ac84..41c2777435 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -2,19 +2,49 @@ module fms_diag_yaml_mod
use diag_data_mod, only: diag_files_type, diag_fields_type
+integer, parameter :: basedate_size = 7
+
+!> Object that holds the information of the diag_yaml
+type diag_yaml_object
+ character(len=:), allocatable, private :: diag_title !< Experiment name
+ integer, private, dimension (basedate_size) :: diag_basedate !< basedate array
+ type(diag_files_type), allocatable, private, dimension (:) :: diag_files!< History file info
+ type(diag_fields_type), allocatable, private, dimension (:,:) :: diag_fields !< Diag fields info
+ contains
+ procedure :: title => get_title !< Returns the title
+ procedure :: basedate => get_basedate !< Returns the basedate array
+end type diag_yaml_object
+type (diag_yaml_object) :: diag_yaml
+
+public :: get_title, get_basedate
+
contains
+
+!> \brief Returns the basedate as an integer array
+pure function get_basedate (diag_yaml) result (diag_basedate)
+class (diag_yaml_object), intent(in) :: diag_yaml !< The diag_yaml
+integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return
+diag_basedate = diag_yaml%diag_basedate
+end function get_basedate
+!> \brief Returns the title of the diag table as an allocated string
+pure function get_title (diag_yaml) result (diag_title)
+class (diag_yaml_object), intent(in) :: diag_yaml !< The diag_yaml
+character(len=:),allocatable :: diag_title !< Basedate array result to return
+ diag_title = diag_yaml%diag_title
+end function get_title
+
!> \brief Compares two field type variables
pure logical function is_field_type_null (in1)
type(diag_fields_type), intent(in) :: in1
-is_field_type_null = (in1%ikind == DIAG_NULL)
+is_field_type_null = .true.
end function is_field_type_null
!!TODO
!> \brief looks for a diag_field based on it's name.
!! Returns null if field is not found.
-type(diag_fields_type)function get_diag_table_field (field_name) result (field)
- character(len=*), intent(IN) :: field_name
- integer :: i
+!type(diag_fields_type)function get_diag_table_field (field_name) result (field)
+! character(len=*), intent(IN) :: field_name
+! integer :: i
! do i = 1,size(diag_fields)
! if (trim(field_name) == trim(fms_c2f_string(diag_fields(i)%fname))) then
! field = diag_fields(i)
@@ -24,8 +54,8 @@ end function is_field_type_null
! endif
! enddo
! field = null_field_type
-
-end function get_diag_table_field
+!
+!end function get_diag_table_field
From 2b2d70ca12a335d89a0bce21557009d912e98fa5 Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Fri, 22 Oct 2021 14:12:22 -0400
Subject: [PATCH 018/168] feat: Adds all variables to diag object that are
registered.
---
diag_manager/diag_manager.F90 | 1 +
diag_manager/fms_diag_object.F90 | 239 +++++++++++++++++++++++++++++--
2 files changed, 227 insertions(+), 13 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index b500455195..09fda5b444 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -236,6 +236,7 @@ MODULE diag_manager_mod
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
+ USE fms_diag_object_mod, ONLY: fms_diag_object, diag_object_placeholder
USE constants_mod, ONLY: SECONDS_PER_DAY
USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type
USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, &
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 27da92a4cf..5f065d82a4 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -15,37 +15,95 @@ module fms_diag_object_mod
use fms_diag_yaml_mod, only: diag_yaml
use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
+use time_manager_mod, ONLY: time_type
+!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
+!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
+!!! & get_ticks_per_second
+
!use diag_util_mod, only: int_to_cs, logical_to_cs
!USE diag_data_mod, ONLY: fileobjU, fileobj, fnum_for_domain, fileobjND
use fms2_io_mod
+use platform_mod
use iso_c_binding
implicit none
+integer, parameter :: range_dims = 2 !< The range of the variables will be set to 2 when allocated
+
+interface operator (<)
+ procedure obj_lt_int
+ procedure int_lt_obj
+end interface
+interface operator (<=)
+ procedure obj_le_int
+ procedure int_le_obj
+end interface
+interface operator (>)
+ procedure obj_gt_int
+ procedure int_gt_obj
+end interface
+interface operator (>=)
+ procedure obj_ge_int
+ procedure int_ge_obj
+end interface
+!interface operator (==)
+! procedure obj_eq_int
+! procedure int_eq_obj
+!end interface
+interface operator (.ne.)
+ procedure obj_ne_int
+ procedure int_ne_obj
+end interface
+
+
!> \brief Object that holds all variable information
type fms_diag_object
- type (diag_fields_type) :: diag_field !< info from diag_table
- type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table
+ type (diag_fields_type) :: diag_field !< info from diag_table
+ type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table
integer, allocatable, private :: diag_id !< unique id for varable
class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the
!! file objects for this variable
character(len=:), allocatable, dimension(:) :: metadata !< metedata for the variable
- logical, private :: static !< true is this is a static var
- logical, allocatable, private :: registered !< true when registered
- integer, allocatable, dimension(:), private :: frequency !< specifies the frequency
-
+ logical, private :: static !< true is this is a static var
+ logical, allocatable, private :: registered !< true when registered
+ logical, allocatable, private :: mask_variant !< If there is a mask variant
+ logical, allocatable, private :: local !< If the output is local
+ TYPE(time_type), private :: init_time !< The initial time
integer, allocatable, private :: vartype !< the type of varaible
character(len=:), allocatable, private :: varname !< the name of the variable
character(len=:), allocatable, private :: longname !< longname of the variable
+ character(len=:), allocatable, private :: standname !< standard name of the variable
character(len=:), allocatable, private :: units !< the units
character(len=:), allocatable, private :: modname !< the module
- integer, private :: missing_value !< The missing fill value
+ character(len=:), allocatable, private :: realm !< String to set as the value
+ !! to the modeling_realm attribute
+ character(len=:), allocatable, private :: err_msg !< An error message
+ character(len=:), allocatable, private :: interp_method !< The interp method to be used
+ !! when regridding the field in post-processing.
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ integer, allocatable, dimension(:), private :: frequency !< specifies the frequency
+ integer, allocatable, dimension(:), private :: output_units
+ integer, allocatable, private :: t
+ integer, allocatable, private :: tile_count !< The number of tiles
integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs
- type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object
+ integer, allocatable, private :: area, volume !< The Area and Volume
+ integer(kind=I4_KIND), allocatable :: i4missing_value !< The missing i4 fill value
+ integer(kind=I8_KIND), allocatable :: i8missing_value !< The missing i8 fill value
+ real(kind=R4_KIND), allocatable :: r4missing_value !< The missing r4 fill value
+ real(kind=R8_KIND), allocatable :: r8missing_value !< The missing r8 fill value
+ integer(kind=I4_KIND), allocatable,dimension(:) :: i4data_RANGE !< The range of i4 data
+ integer(kind=I8_KIND), allocatable,dimension(:) :: i8data_RANGE !< The range of i8 data
+ real(kind=R4_KIND), allocatable,dimension(:) :: r4data_RANGE !< The range of r4 data
+ real(kind=R8_KIND), allocatable,dimension(:) :: r8data_RANGE !< The range of r8 data
+ type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object
+!! dev variables that need to be removed
+ integer :: missing_value !< this should be removed
contains
! procedure :: send_data => fms_send_data !!TODO
+<<<<<<< HEAD
procedure :: init_ob => diag_obj_init
procedure :: get_id => fms_diag_get_id
procedure :: id => fms_diag_get_id
@@ -55,11 +113,21 @@ module fms_diag_object_mod
procedure :: is_registered => diag_ob_registered
procedure :: set_type => set_vartype
procedure :: vartype_inq => what_is_vartype
+=======
+ procedure,public :: init_ob => diag_obj_init
+ procedure,public :: diag_id_inq => fms_diag_id_inq
+ procedure,public :: copy => copy_diag_obj
+ procedure,public :: register_meta => fms_register_diag_field_obj
+ procedure,public :: setID => set_diag_id
+ procedure,public :: is_registered => diag_ob_registered
+ procedure,public :: set_type => set_vartype
+ procedure,public :: vartype_inq => what_is_vartype
+>>>>>>> 9c9a406d (Adds all variables to diag object that are registered.)
- procedure :: is_static => diag_obj_is_static
- procedure :: is_registeredB => diag_obj_is_registered
- procedure :: get_vartype => diag_obj_get_vartype
- procedure :: get_varname => diag_obj_get_varname
+ procedure,public :: is_static => diag_obj_is_static
+ procedure,public :: is_registeredB => diag_obj_is_registered
+ procedure,public :: get_vartype => diag_obj_get_vartype
+ procedure,public :: get_varname => diag_obj_get_varname
end type fms_diag_object
!> \brief Extends the variable object to work with multiple types of data
@@ -92,10 +160,17 @@ module fms_diag_object_mod
integer,private :: MAX_LEN_VARNAME
integer,private :: MAX_LEN_META
+
+type(fms_diag_object_3d) :: diag_object_placeholder (10)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
public :: fms_diag_object, fms_diag_object_scalar, fms_diag_object_1d
public :: fms_diag_object_2d, fms_diag_object_3d, fms_diag_object_4d, fms_diag_object_5d
+<<<<<<< HEAD
public :: copy_diag_obj, fms_diag_get_id
+=======
+public :: copy_diag_obj, fms_diag_id_inq
+public :: operator (>),operator (<),operator (>=),operator (<=),operator (.ne.)!operator (==),operator (.ne.)
+>>>>>>> 9c9a406d (Adds all variables to diag object that are registered.)
public :: null_sc, null_1d, null_2d, null_3d, null_4d, null_5d
public :: fms_diag_object_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -134,7 +209,7 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long
class(fms_diag_object) , intent(inout) :: dobj
character(*) , intent(in) :: modname!< The module name
character(*) , intent(in) :: varname!< The variable name
- integer , dimension(:) , intent(in), optional :: axes !< Th character(:),allocatable :: rese axes
+ integer , dimension(:) , intent(in), optional :: axes !< The character(:),allocatable :: rese axes
integer , intent(in), optional :: time !< Time placeholder
character(*) , intent(in), optional :: longname!< The variable long name
character(*) , intent(in), optional :: units !< Units of the variable
@@ -364,5 +439,143 @@ function diag_obj_get_varname(obj) result (rslt)
rslt = obj%varname
end function diag_obj_get_varname
+<<<<<<< HEAD
+=======
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Operator Overrides !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \brief override for checking if object ID is greater than an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_gt_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i >= diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (obj%diag_id > i)
+ endif
+end function obj_gt_int
+!> \brief override for checking if integer (ID) is greater than an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_gt_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i <= diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj)) then
+ ll = .true.
+ else
+ ll = (i > obj%diag_id)
+ endif
+end function int_gt_obj
+!> \brief override for checking if object ID is less than an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_lt_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i > diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj)) then
+ ll = .false.
+ else
+ ll = (obj%diag_id < i)
+ endif
+end function obj_lt_int
+!> \brief override for checking if integer (ID) is less than an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_lt_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i >= diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj)) then
+ ll = .true.
+ else
+ ll = (i < obj%diag_id)
+ endif
+end function int_lt_obj
+!> \brief override for checking if object ID is greater than or equal to an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_ge_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i <= diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (obj%diag_id >= i)
+ endif
+end function obj_ge_int
+!> \brief override for checking if integer (ID) is greater than or equal to an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_ge_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i >= diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (i >= obj%diag_id)
+ endif
+end function int_ge_obj
+!> \brief override for checking if object ID is less than or equal to an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_le_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i >= diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (obj%diag_id <= i)
+ endif
+end function obj_le_int
+!> \brief override for checking if integer (ID) is less than or equal to an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_le_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i <= diag_not_registered) then
+ ll = .true.
+ elseif (.not.allocated(obj) ) then
+ ll = .false.
+ else
+ ll = (i <= obj%diag_id)
+ endif
+end function int_le_obj
+
+!> \brief override for checking if object ID is not equal to an integer (IDs)
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function obj_ne_int (obj,i) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i == diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj) ) then
+ ll = .true.
+ else
+ ll = (obj%diag_id .ne. i)
+ endif
+end function obj_ne_int
+
+!> \brief override for checking if integer (ID) is not equal to an object ID
+!> @note unalloacted obj is assumed to equal diag_not_registered
+pure logical function int_ne_obj (i,obj) result(ll)
+ class (fms_diag_object), intent(in), allocatable :: obj
+ integer, intent(in) :: i
+ if (.not.allocated(obj) .and. i == diag_not_registered) then
+ ll = .false.
+ elseif (.not.allocated(obj) ) then
+ ll = .true.
+ else
+ ll = (i .ne. obj%diag_id)
+ endif
+end function int_ne_obj
+>>>>>>> 9c9a406d (Adds all variables to diag object that are registered.)
end module fms_diag_object_mod
From b7c350d0048019eb10ea1573d48c8ab8f8f4bebf Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Fri, 22 Oct 2021 15:12:40 -0400
Subject: [PATCH 019/168] fix: setup register routines in diag_object
---
diag_manager/diag_manager.F90 | 8 ++++
diag_manager/fms_diag_object.F90 | 69 +++++++++++++++++++++++---------
2 files changed, 58 insertions(+), 19 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 09fda5b444..23aee09bce 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -611,6 +611,14 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
END DO
END IF
+
+ if (use_modern_diag) then
+ call diag_object_placeholder(1)%register &
+ (module_name, field_name, axes, init_time, &
+ long_name, units, missing_value, Range, mask_variant, standard_name, &
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm) !(no metadata here)
+ endif
+
END FUNCTION register_diag_field_array
!> @brief Return field index for subsequent call to send_data.
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 5f065d82a4..ed2d3d3220 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -89,18 +89,17 @@ module fms_diag_object_mod
integer, allocatable, private :: tile_count !< The number of tiles
integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs
integer, allocatable, private :: area, volume !< The Area and Volume
- integer(kind=I4_KIND), allocatable :: i4missing_value !< The missing i4 fill value
- integer(kind=I8_KIND), allocatable :: i8missing_value !< The missing i8 fill value
- real(kind=R4_KIND), allocatable :: r4missing_value !< The missing r4 fill value
- real(kind=R8_KIND), allocatable :: r8missing_value !< The missing r8 fill value
+ real, private :: missing_value !< Holds a missing value if none given
+ integer(kind=I4_KIND), allocatable, private :: i4missing_value !< The missing i4 fill value
+ integer(kind=I8_KIND), allocatable, private :: i8missing_value !< The missing i8 fill value
+ real(kind=R4_KIND), allocatable, private :: r4missing_value !< The missing r4 fill value
+ real(kind=R8_KIND), allocatable, private :: r8missing_value !< The missing r8 fill value
integer(kind=I4_KIND), allocatable,dimension(:) :: i4data_RANGE !< The range of i4 data
integer(kind=I8_KIND), allocatable,dimension(:) :: i8data_RANGE !< The range of i8 data
real(kind=R4_KIND), allocatable,dimension(:) :: r4data_RANGE !< The range of r4 data
real(kind=R8_KIND), allocatable,dimension(:) :: r8data_RANGE !< The range of r8 data
type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object
-!! dev variables that need to be removed
- integer :: missing_value !< this should be removed
contains
! procedure :: send_data => fms_send_data !!TODO
<<<<<<< HEAD
@@ -117,7 +116,7 @@ module fms_diag_object_mod
procedure,public :: init_ob => diag_obj_init
procedure,public :: diag_id_inq => fms_diag_id_inq
procedure,public :: copy => copy_diag_obj
- procedure,public :: register_meta => fms_register_diag_field_obj
+ procedure,public :: register => fms_register_diag_field_obj
procedure,public :: setID => set_diag_id
procedure,public :: is_registered => diag_ob_registered
procedure,public :: set_type => set_vartype
@@ -205,18 +204,33 @@ subroutine diag_obj_init(ob)
end subroutine diag_obj_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \description Fills in and allocates (when necessary) the values in the diagnostic object
-subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
+subroutine fms_register_diag_field_obj &
+ !(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
+ (dobj, modname, varname, axes, init_time, &
+ longname, units, missing_value, varRange, mask_variant, standname, &
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm, metadata)
class(fms_diag_object) , intent(inout) :: dobj
- character(*) , intent(in) :: modname!< The module name
- character(*) , intent(in) :: varname!< The variable name
- integer , dimension(:) , intent(in), optional :: axes !< The character(:),allocatable :: rese axes
- integer , intent(in), optional :: time !< Time placeholder
- character(*) , intent(in), optional :: longname!< The variable long name
- character(*) , intent(in), optional :: units !< Units of the variable
- integer , intent(in), optional :: missing_value !< A missing value to be used
- character(*), dimension(:) , intent(in), optional :: metadata
-! class(*), pointer :: vptr
-
+ CHARACTER(len=*), INTENT(in) :: modname !< The module name
+ CHARACTER(len=*), INTENT(in) :: varname !< The variable name
+ INTEGER, INTENT(in) :: axes(:) !< The axes indicies
+ TYPE(time_type), INTENT(in) :: init_time !< Initial time
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standname !< The variables stanard name
+ class(*), OPTIONAL, INTENT(in) :: missing_value
+ class(*), OPTIONAL, INTENT(in) :: varRANGE(2)
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error message to be passed back up
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
+ !! regridding the field in post-processing.
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ INTEGER, OPTIONAL, INTENT(in) :: tile_count !< the number of tiles
+ INTEGER, OPTIONAL, INTENT(in) :: area !< diag_field_id containing the cell area field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id containing the cell volume field
+ CHARACTER(len=*), OPTIONAL, INTENT(in):: realm !< String to set as the value to the modeling_realm attribute
+ character(len=*), optional, intent(in), dimension(:) :: metadata !< metedata for the variable
!> Fill in information from the register call
allocate(character(len=MAX_LEN_VARNAME) :: dobj%varname)
@@ -236,6 +250,10 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long
allocate(character(len=len(longname)) :: dobj%longname)
dobj%longname = trim(longname)
endif
+ if (present(standname)) then
+ allocate(character(len=len(standname)) :: dobj%standname)
+ dobj%standname = trim(standname)
+ endif
if (present(units)) then
allocate(character(len=len(units)) :: dobj%units)
dobj%units = trim(units)
@@ -245,7 +263,20 @@ subroutine fms_register_diag_field_obj (dobj, modname, varname, axes, time, long
dobj%metadata = metadata
endif
if (present(missing_value)) then
- dobj%missing_value = missing_value
+ select type (missing_value)
+ type is (integer(kind=i4_kind))
+ dobj%i4missing_value = missing_value
+ type is (integer(kind=i8_kind))
+ dobj%i4missing_value = missing_value
+ type is (real(kind=r4_kind))
+ dobj%i4missing_value = missing_value
+ type is (real(kind=i8_kind))
+ dobj%i4missing_value = missing_value
+ class default
+ call mpp_error("fms_register_diag_field_obj", &
+ "The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",&
+ FATAL)
+ end select
else
dobj%missing_value = DIAG_NULL
endif
From 252ef7c1a2d3230a3dc8489569bbd66ced3c5fae Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Mon, 25 Oct 2021 09:35:51 -0400
Subject: [PATCH 020/168] fix: typos in filling in missing value for diag
object registration.
---
diag_manager/fms_diag_object.F90 | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index ed2d3d3220..1dadfa9a49 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -267,11 +267,11 @@ subroutine fms_register_diag_field_obj &
type is (integer(kind=i4_kind))
dobj%i4missing_value = missing_value
type is (integer(kind=i8_kind))
- dobj%i4missing_value = missing_value
+ dobj%i8missing_value = missing_value
type is (real(kind=r4_kind))
- dobj%i4missing_value = missing_value
- type is (real(kind=i8_kind))
- dobj%i4missing_value = missing_value
+ dobj%r4missing_value = missing_value
+ type is (real(kind=r8_kind))
+ dobj%r8missing_value = missing_value
class default
call mpp_error("fms_register_diag_field_obj", &
"The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",&
From 525b7e3061c6d822bd3e9f774f06a34bea82da27 Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Wed, 3 Nov 2021 13:05:31 -0400
Subject: [PATCH 021/168] feat: Initial add of fms_diag_yaml_object.F90
---
diag_manager/Makefile.am | 4 +-
diag_manager/fms_diag_yaml_object.F90 | 374 ++++++++++++++++++++++++++
2 files changed, 377 insertions(+), 1 deletion(-)
create mode 100644 diag_manager/fms_diag_yaml_object.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 7169e66b62..12a06fd9e5 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -48,7 +48,8 @@ libdiag_manager_la_SOURCES = \
fms_diag_yaml.F90 \
diag_yaml.h \
diag_yaml.c \
- fms_diag_object.F90
+ fms_diag_object.F90 \
+ fms_diag_yaml_object.F90
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
@@ -87,6 +88,7 @@ MODFILES = \
diag_manager_mod.$(FC_MODEXT) \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh
+ fms_diag_yaml_object_mod.$(FC_MODEXT) \
fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) \
diag_manager_mod.$(FC_MODEXT)
diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90
new file mode 100644
index 0000000000..4bb242d4eb
--- /dev/null
+++ b/diag_manager/fms_diag_yaml_object.F90
@@ -0,0 +1,374 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @defgroup fms_diag_yaml_object_mod fms_diag_yaml_object_mod
+!> @ingroup diag_manager
+!! @brief The diag yaml objects are handled here, with variables the correspond to
+!! entries in the diag yaml file. The actual parsing of the yaml is handled in
+!! @ref fms_diag_yaml_mod.
+!! @author Tom Robinson
+
+!> @file
+!> @brief File for @ref fms_diag_yaml_object_mod
+
+!> @addtogroup fms_diag_yaml_object_mod
+!> @{
+module fms_diag_yaml_object_mod
+
+use fms_mod , only: fms_c2f_string
+use iso_c_binding
+ implicit none
+integer, parameter :: NUM_REGION_ARRAY = 8
+ !> @brief The files type matching a C struct containing diag_yaml information
+ !> @ingroup fms_diag_files_mod
+type, bind(c) :: diag_yaml_files_struct
+ character (kind=c_char) :: file_fname (20) !< file name
+ character (kind=c_char) :: file_frequnit (7) !< the frequency unit
+ integer (c_int) :: file_freq !< the frequency of data
+ character (kind=c_char) :: file_timeunit(7) !< The unit of time
+ character (kind=c_char) :: file_unlimdim(8) !< The name of the unlimited dimension
+ character (kind=c_char) :: file_write (5) !< false if the user doesn’t want the file to be
+ !! created (default is true).
+ character (kind=c_char) :: file_realm (3) !< The modeling realm that the variables come from
+ real (c_float) :: file_region (NUM_REGION_ARRAY) !< Bounds of the regional section to capture
+ integer (c_int) :: file_new_file_freq !< Frequency for closing the existing file
+ character (kind=c_char) :: file_new_file_freq_units (3)!< Time units for creating a new file.
+ !! Required if “new_file_freq” used
+ integer (c_int) :: file_start_time !< Time to start the file for the first time. Requires “new_file_freq”
+ integer (c_int) :: file_duration !< How long the file should receive data after start time
+ !! in “file_duration_units”. This optional field can only
+ !! be used if the start_time field is present. If this field
+ !! is absent, then the file duration will be equal to the
+ !! frequency for creating new files.
+ !! NOTE: The file_duration_units field must also be present if
+ !! this field is present.
+ character (kind=c_char) :: file_duration_units (3)!< The file duration units
+end type diag_yaml_files_struct
+
+type diag_yaml_files_type
+ character (len=:), allocatable :: file_fname !< file name
+ character (len=:), allocatable :: file_frequnit !< the frequency unit
+ integer (c_int) :: file_freq !< the frequency of data
+ character (len=:), allocatable :: file_timeunit !< The unit of time
+ character (len=:), allocatable :: file_unlimdim !< The name of the unlimited dimension
+ logical :: file_write
+ character (len=:), allocatable :: string_file_write !< false if the user doesn’t want the file to be
+ !! created (default is true).
+ character (len=:), allocatable :: file_realm !< The modeling realm that the variables come from
+ real :: file_region (NUM_REGION_ARRAY) !< Bounds of the regional section to capture
+ integer :: file_new_file_freq !< Frequency for closing the existing file
+ character (len=:), allocatable :: file_new_file_freq_units !< Time units for creating a new file.
+ !! Required if “new_file_freq” used
+ integer :: file_start_time !< Time to start the file for the first time. Requires “new_file_freq”
+ integer :: file_duration !< How long the file should receive data after start time
+ !! in “file_duration_units”. This optional field can only
+ !! be used if the start_time field is present. If this field
+ !! is absent, then the file duration will be equal to the
+ !! frequency for creating new files.
+ !! NOTE: The file_duration_units field must also be present if
+ !! this field is present.
+ character (len=:), allocatable :: file_duration_units !< The file duration units
+ character (len=:), dimension(:), allocatable :: file_varlist !< An array of variable names
+ !! within a file
+ character (len=:), dimension(:,:), allocatable :: file_global_meta !< Array of key(dim=1)
+ !! and values(dim=2) to be added as global
+ !! meta data to the file
+
+ contains
+ procedure :: copy_struct => copy_file_struct_to_object
+ procedure :: fname => get_file_fname
+ procedure :: frequnit => get_file_frequnit
+ procedure :: freq => get_file_freq
+ procedure :: timeunit => get_file_timeunit
+ procedure :: unlimdim => get_file_unlimdim
+ procedure :: write_file => get_file_write
+ procedure :: realm => get_file_realm
+ procedure :: region => get_file_region
+ procedure :: new_file_freq => get_file_new_file_freq
+ procedure :: new_file_freq_units => get_file_new_file_freq_units
+ procedure :: start_time => get_file_start_time
+ procedure :: duration => get_file_duration
+ procedure :: duration_units => get_file_duration_units
+ procedure :: varlist => get_file_varlist
+ procedure :: global_meta => get_file_global_meta
+
+end type diag_yaml_files_type
+
+!> @brief The field type matching the C struct for diag_yaml information
+ !> @ingroup fms_diag_files_mod
+type, bind(c) :: diag_yaml_files_var_struct
+ character (kind=c_char) :: var_fname (20) !< The field/diagnostic name
+ character (kind=c_char) :: var_varname(20) !< The name of the variable
+ character (kind=c_char) :: var_reduction(20) !< Reduction to be done on var
+ character (kind=c_char) :: var_module(20) !< The module that th variable is in
+ character (kind=c_char) :: var_skind(8) !< The type/kind of the variable
+ character (kind=c_char) :: var_write(5) !< false if the user doesn’t want the variable to be
+ !! written to the file (default: true).
+ character (kind=c_char) :: var_outname(20) !< Name of the variable as written to the file
+ character (kind=c_char) :: var_longname(100) !< Overwrites the long name of the variable
+ character (kind=c_char) :: var_units(10) !< Overwrites the units
+end type diag_yaml_files_var_struct
+
+type diag_yaml_files_var_type
+ character (len=:), allocatable :: var_fname !< The field/diagnostic name
+ character (len=:), allocatable :: var_varname !< The name of the variable
+ character (len=:), allocatable :: var_reduction !< Reduction to be done on var
+ character (len=:), allocatable :: var_module !< The module that th variable is in
+ character (len=:), allocatable :: var_skind !< The type/kind of the variable
+ character (len=:), allocatable :: string_var_write !< false if the user doesn’t want the variable to be
+ !! written to the file (default: true).
+ logical :: var_write !< false if the user doesn’t want the variable to be
+ !! written to the file (default: true).
+ character (len=:), allocatable :: var_outname !< Name of the variable as written to the file
+ character (len=:), allocatable :: var_longname !< Overwrites the long name of the variable
+ character (len=:), allocatable :: var_units !< Overwrites the units
+ character (len=:), dimension (:), allocatable :: var_attributes !< Attributes to overwrite or
+ !! add from diag_yaml
+ contains
+ procedure :: copy_struct => copy_variable_struct_to_object
+ procedure :: fname => get_var_fname
+ procedure :: varname => get_var_varname
+ procedure :: reduction => get_var_reduction
+ procedure :: module_var => get_var_module
+ procedure :: skind => get_var_skind
+ procedure :: outname => get_var_outname
+ procedure :: longname => get_var_longname
+ procedure :: units => get_var_units
+ procedure :: write_var => get_var_write
+ procedure :: attr => get_var_attributes
+
+end type diag_yaml_files_var_type
+
+contains
+!!!!!!!! YAML FILE ROUTINES !!!!!!!!
+!< \brief Copies the information of the yaml struct to the fortran object holding the info
+subroutine copy_file_struct_to_object(diag_files_obj, diag_files_struct)
+ class(diag_yaml_files_type) :: diag_files_obj !< Fortran-side object with diag_yaml info
+ type(diag_yaml_files_struct) :: diag_files_struct !< The C struct that has the diag_yaml
+ !! info
+ integer :: i !< For looping
+!< Convert the C strings to Fortran strings
+ diag_files_obj%file_fname = fms_c2f_string (diag_files_struct%file_fname)
+ diag_files_obj%file_frequnit = fms_c2f_string (diag_files_struct%file_frequnit)
+ diag_files_obj%file_timeunit = fms_c2f_string (diag_files_struct%file_timeunit)
+ diag_files_obj%file_unlimdim = fms_c2f_string (diag_files_struct%file_unlimdim)
+ diag_files_obj%file_realm = fms_c2f_string (diag_files_struct%file_realm)
+ diag_files_obj%file_new_file_freq_units = fms_c2f_string (diag_files_struct%file_new_file_freq_units)
+ diag_files_obj%file_duration_units = fms_c2f_string (diag_files_struct%file_duration_units)
+!< Set the file_write to be true or false
+ diag_files_obj%string_file_write = fms_c2f_string (diag_files_struct%file_write)
+ diag_files_obj%file_write = .true.
+ if (diag_files_obj%string_file_write(1:1)=="f" .or. &
+ diag_files_obj%string_file_write(1:1)=="F") &
+ diag_files_obj%file_write = .false.
+ deallocate (diag_files_obj%string_file_write)
+!< Store the numbers
+ diag_files_obj%file_freq = diag_files_struct%file_freq
+!$omp simd
+ do i = 1, NUM_REGION_ARRAY
+ diag_files_obj%file_region(i) = diag_files_struct%file_region(i)
+ enddo
+ diag_files_obj%file_new_file_freq = diag_files_struct%file_new_file_freq
+ diag_files_obj%file_start_time = diag_files_struct%file_start_time
+ diag_files_obj%file_duration = diag_files_struct%file_duration
+
+end subroutine copy_file_struct_to_object
+!!!!!!! YAML FILE INQUIRIES !!!!!!!
+!> \brief Inquiry for diag_files_obj%file_fname
+pure function get_file_fname (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_files_obj%file_fname
+end function get_file_fname
+!> \brief Inquiry for diag_files_obj%file_frequnit
+pure function get_file_frequnit (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_files_obj%file_frequnit
+end function get_file_frequnit
+!> \brief Inquiry for diag_files_obj%file_freq
+pure function get_file_freq(diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_files_obj%file_freq
+end function get_file_freq
+!> \brief Inquiry for diag_files_obj%file_timeunit
+pure function get_file_timeunit (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_files_obj%file_timeunit
+end function get_file_timeunit
+!> \brief Inquiry for diag_files_obj%file_unlimdim
+pure function get_file_unlimdim(diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_files_obj%file_unlimdim
+end function get_file_unlimdim
+!> \brief Inquiry for diag_files_obj%file_write
+pure function get_file_write(diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ logical :: res !< What is returned
+ res = diag_files_obj%file_write
+end function get_file_write
+!> \brief Inquiry for diag_files_obj%file_realm
+pure function get_file_realm(diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (*) :: res !< What is returned
+ res = diag_files_obj%file_realm
+end function get_file_realm
+!> \brief Inquiry for diag_files_obj%file_region
+pure function get_file_region (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ real :: res (NUM_REGION_ARRAY) !< What is returned
+ res = diag_files_obj%file_region
+end function get_file_region
+!> \brief Inquiry for diag_files_obj%file_new_file_freq
+pure function get_file_new_file_freq(diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_files_obj%file_new_file_freq
+end function get_file_new_file_freq
+!> \brief Inquiry for diag_files_obj%file_new_file_freq_units
+pure function get_file_new_file_freq_units (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (*) :: res !< What is returned
+ res = diag_files_obj%file_new_file_freq_units
+end function get_file_new_file_freq_units
+!> \brief Inquiry for diag_files_obj%file_start_time
+pure function get_file_start_time (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_files_obj%file_start_time
+end function get_file_start_time
+!> \brief Inquiry for diag_files_obj%file_duration
+pure function get_file_duration (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_files_obj%file_duration
+end function get_file_duration
+!> \brief Inquiry for diag_files_obj%file_duration_units
+pure function get_file_duration_units (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (*) :: res !< What is returned
+ res = diag_files_obj%file_duration_units
+end function get_file_duration_units
+!> \brief Inquiry for diag_files_obj%file_varlist
+pure function get_file_varlist (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (*) :: res(:) !< What is returned
+ res = diag_files_obj%file_varlist
+end function get_file_varlist
+!> \brief Inquiry for diag_files_obj%file_global_meta
+pure function get_file_global_meta (diag_files_obj) result (res)
+ class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (*) :: res(:,:) !< What is returned
+ res = diag_files_obj%file_global_meta
+end function get_file_global_meta
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!! VARIABLES ROUTINES AND FUNCTIONS !!!!!!!
+!< \brief Copies the information of the yaml struct to the fortran object holding the var info
+subroutine copy_variable_struct_to_object(diag_var_obj, diag_var_struct)
+ class(diag_yaml_files_var_type) :: diag_var_obj !< Fortran-side object with diag_yaml var info
+ type(diag_yaml_files_var_struct) :: diag_var_struct !< The C struct that has the diag_yaml
+ !! var info
+!< Convert the C strings to Fortran strings
+ diag_var_obj%var_fname = fms_c2f_string (diag_var_struct%var_fname)
+ diag_var_obj%var_varname = fms_c2f_string (diag_var_struct%var_varname)
+ diag_var_obj%var_reduction = fms_c2f_string (diag_var_struct%var_reduction)
+ diag_var_obj%var_module = fms_c2f_string (diag_var_struct%var_module)
+ diag_var_obj%var_skind = fms_c2f_string (diag_var_struct%var_skind)
+ diag_var_obj%var_outname = fms_c2f_string (diag_var_struct%var_outname)
+ diag_var_obj%var_longname = fms_c2f_string (diag_var_struct%var_longname)
+ diag_var_obj%var_units = fms_c2f_string (diag_var_struct%var_units)
+!< Set the file_write to be true or false
+ diag_var_obj%string_var_write= fms_c2f_string (diag_var_struct%var_write)
+ diag_var_obj%var_write= .true.
+ if (diag_var_obj%string_var_write(1:1)=="f" .or. &
+ diag_var_obj%string_var_write(1:1)=="F") &
+ diag_var_obj%var_write= .false.
+ deallocate (diag_var_obj%string_var_write)
+end subroutine copy_variable_struct_to_object
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!! YAML VAR INQUIRIES !!!!!!!
+!> \brief Inquiry for diag_yaml_files_var_obj%var_fname
+pure function get_var_fname (diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_var_objn%var_fname
+end function get_var_fname
+!> \brief Inquiry for diag_yaml_files_var_obj%var_varname
+pure function get_var_varname (diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_var_obj%var_varname
+end function get_var_varname
+!> \brief Inquiry for diag_yaml_files_var_obj%var_reduction
+pure function get_var_reduction (diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_var_obj%var_reduction
+end function get_var_reduction
+!> \brief Inquiry for diag_yaml_files_var_obj%var_module
+pure function get_var_module (diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_var_obj%var_module
+end function get_var_module
+!> \brief Inquiry for diag_yaml_files_var_obj%var_skind
+pure function get_var_skind (diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_var_obj%var_skind
+end function get_var_skind
+!> \brief Inquiry for diag_yaml_files_var_obj%var_outname
+pure function get_var_outname (diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_var_obj%var_outname
+end function get_var_outname
+!> \brief Inquiry for diag_yaml_files_var_obj%var_longname
+pure function get_var_longname (diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_var_obj%var_longname
+end function get_var_longname
+!> \brief Inquiry for diag_yaml_files_var_obj%var_units
+pure function get_var_units (diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=*) :: res !< What is returned
+ res = diag_var_obj%var_units
+end function get_var_units
+!> \brief Inquiry for diag_yaml_files_var_obj%var_write
+pure function get_var_write (diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ logical :: res !< What is returned
+ res = diag_var_obj%var_write
+end function get_var_write
+!> \brief Inquiry for diag_yaml_files_var_obj%var_attributes
+pure function get_var_attributes(diag_var_obj) result (res)
+ class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=*) :: res (:) !< What is returned
+ res = diag_var_obj%var_attributes
+end function get_var_attributes
+
+end module fms_diag_yaml_object_mod
+!> @}
+! close documentation grouping
+
From b215a38fe1195abb7ef8d9dfc7696f99c3763a55 Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Thu, 11 Nov 2021 08:06:00 -0500
Subject: [PATCH 022/168] fix: compile errors in new diag manager related to
objects
---
diag_manager/fms_diag_object.F90 | 2 +-
diag_manager/fms_diag_yaml_object.F90 | 38 +++++++++++++--------------
2 files changed, 20 insertions(+), 20 deletions(-)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 1dadfa9a49..2990f92951 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -107,7 +107,7 @@ module fms_diag_object_mod
procedure :: get_id => fms_diag_get_id
procedure :: id => fms_diag_get_id
procedure :: copy => copy_diag_obj
- procedure :: register_meta => fms_register_diag_field_obj
+ procedure :: register => fms_register_diag_field_obj
procedure :: setID => set_diag_id
procedure :: is_registered => diag_ob_registered
procedure :: set_type => set_vartype
diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90
index 4bb242d4eb..4ac308758a 100644
--- a/diag_manager/fms_diag_yaml_object.F90
+++ b/diag_manager/fms_diag_yaml_object.F90
@@ -192,13 +192,13 @@ end subroutine copy_file_struct_to_object
!> \brief Inquiry for diag_files_obj%file_fname
pure function get_file_fname (diag_files_obj) result (res)
class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_fname
end function get_file_fname
!> \brief Inquiry for diag_files_obj%file_frequnit
pure function get_file_frequnit (diag_files_obj) result (res)
class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_frequnit
end function get_file_frequnit
!> \brief Inquiry for diag_files_obj%file_freq
@@ -210,13 +210,13 @@ end function get_file_freq
!> \brief Inquiry for diag_files_obj%file_timeunit
pure function get_file_timeunit (diag_files_obj) result (res)
class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_timeunit
end function get_file_timeunit
!> \brief Inquiry for diag_files_obj%file_unlimdim
pure function get_file_unlimdim(diag_files_obj) result (res)
class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_unlimdim
end function get_file_unlimdim
!> \brief Inquiry for diag_files_obj%file_write
@@ -228,7 +228,7 @@ end function get_file_write
!> \brief Inquiry for diag_files_obj%file_realm
pure function get_file_realm(diag_files_obj) result (res)
class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (*) :: res !< What is returned
+ character (:), allocatable :: res !< What is returned
res = diag_files_obj%file_realm
end function get_file_realm
!> \brief Inquiry for diag_files_obj%file_region
@@ -246,7 +246,7 @@ end function get_file_new_file_freq
!> \brief Inquiry for diag_files_obj%file_new_file_freq_units
pure function get_file_new_file_freq_units (diag_files_obj) result (res)
class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (*) :: res !< What is returned
+ character (:), allocatable :: res !< What is returned
res = diag_files_obj%file_new_file_freq_units
end function get_file_new_file_freq_units
!> \brief Inquiry for diag_files_obj%file_start_time
@@ -264,19 +264,19 @@ end function get_file_duration
!> \brief Inquiry for diag_files_obj%file_duration_units
pure function get_file_duration_units (diag_files_obj) result (res)
class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (*) :: res !< What is returned
+ character (:), allocatable :: res !< What is returned
res = diag_files_obj%file_duration_units
end function get_file_duration_units
!> \brief Inquiry for diag_files_obj%file_varlist
pure function get_file_varlist (diag_files_obj) result (res)
class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (*) :: res(:) !< What is returned
+ character (:), allocatable :: res(:) !< What is returned
res = diag_files_obj%file_varlist
end function get_file_varlist
!> \brief Inquiry for diag_files_obj%file_global_meta
pure function get_file_global_meta (diag_files_obj) result (res)
class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (*) :: res(:,:) !< What is returned
+ character (:), allocatable :: res(:,:) !< What is returned
res = diag_files_obj%file_global_meta
end function get_file_global_meta
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -310,49 +310,49 @@ end subroutine copy_variable_struct_to_object
!> \brief Inquiry for diag_yaml_files_var_obj%var_fname
pure function get_var_fname (diag_var_obj) result (res)
class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
- res = diag_var_objn%var_fname
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_var_obj%var_fname
end function get_var_fname
!> \brief Inquiry for diag_yaml_files_var_obj%var_varname
pure function get_var_varname (diag_var_obj) result (res)
class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_varname
end function get_var_varname
!> \brief Inquiry for diag_yaml_files_var_obj%var_reduction
pure function get_var_reduction (diag_var_obj) result (res)
class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_reduction
end function get_var_reduction
!> \brief Inquiry for diag_yaml_files_var_obj%var_module
pure function get_var_module (diag_var_obj) result (res)
class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_module
end function get_var_module
!> \brief Inquiry for diag_yaml_files_var_obj%var_skind
pure function get_var_skind (diag_var_obj) result (res)
class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_skind
end function get_var_skind
!> \brief Inquiry for diag_yaml_files_var_obj%var_outname
pure function get_var_outname (diag_var_obj) result (res)
class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_outname
end function get_var_outname
!> \brief Inquiry for diag_yaml_files_var_obj%var_longname
pure function get_var_longname (diag_var_obj) result (res)
class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_longname
end function get_var_longname
!> \brief Inquiry for diag_yaml_files_var_obj%var_units
pure function get_var_units (diag_var_obj) result (res)
class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=*) :: res !< What is returned
+ character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_units
end function get_var_units
!> \brief Inquiry for diag_yaml_files_var_obj%var_write
@@ -364,7 +364,7 @@ end function get_var_write
!> \brief Inquiry for diag_yaml_files_var_obj%var_attributes
pure function get_var_attributes(diag_var_obj) result (res)
class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=*) :: res (:) !< What is returned
+ character (len=:), allocatable :: res (:) !< What is returned
res = diag_var_obj%var_attributes
end function get_var_attributes
From c907b66af2e03f84b7e62a6cd1c8fe82ee7334f4 Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Mon, 29 Nov 2021 14:39:01 -0500
Subject: [PATCH 023/168] feat: updates getter functions in the diag yaml
objects
---
diag_manager/fms_diag_yaml_object.F90 | 50 +++++++++++++--------------
1 file changed, 25 insertions(+), 25 deletions(-)
diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90
index 4ac308758a..b26a4a3bdc 100644
--- a/diag_manager/fms_diag_yaml_object.F90
+++ b/diag_manager/fms_diag_yaml_object.F90
@@ -91,21 +91,21 @@ module fms_diag_yaml_object_mod
contains
procedure :: copy_struct => copy_file_struct_to_object
- procedure :: fname => get_file_fname
- procedure :: frequnit => get_file_frequnit
- procedure :: freq => get_file_freq
- procedure :: timeunit => get_file_timeunit
- procedure :: unlimdim => get_file_unlimdim
- procedure :: write_file => get_file_write
- procedure :: realm => get_file_realm
- procedure :: region => get_file_region
- procedure :: new_file_freq => get_file_new_file_freq
- procedure :: new_file_freq_units => get_file_new_file_freq_units
- procedure :: start_time => get_file_start_time
- procedure :: duration => get_file_duration
- procedure :: duration_units => get_file_duration_units
- procedure :: varlist => get_file_varlist
- procedure :: global_meta => get_file_global_meta
+ procedure :: get_file_fname
+ procedure :: get_file_frequnit
+ procedure :: get_file_freq
+ procedure :: get_file_timeunit
+ procedure :: get_file_unlimdim
+ procedure :: get_file_write
+ procedure :: get_file_realm
+ procedure :: get_file_region
+ procedure :: get_file_new_file_freq
+ procedure :: get_file_new_file_freq_units
+ procedure :: get_file_start_time
+ procedure :: get_file_duration
+ procedure :: get_file_duration_units
+ procedure :: get_file_varlist
+ procedure :: get_file_global_meta
end type diag_yaml_files_type
@@ -141,16 +141,16 @@ module fms_diag_yaml_object_mod
!! add from diag_yaml
contains
procedure :: copy_struct => copy_variable_struct_to_object
- procedure :: fname => get_var_fname
- procedure :: varname => get_var_varname
- procedure :: reduction => get_var_reduction
- procedure :: module_var => get_var_module
- procedure :: skind => get_var_skind
- procedure :: outname => get_var_outname
- procedure :: longname => get_var_longname
- procedure :: units => get_var_units
- procedure :: write_var => get_var_write
- procedure :: attr => get_var_attributes
+ procedure :: get_var_fname
+ procedure :: get_var_varname
+ procedure :: get_var_reduction
+ procedure :: get_var_module
+ procedure :: get_var_skind
+ procedure :: get_var_outname
+ procedure :: get_var_longname
+ procedure :: get_var_units
+ procedure :: get_var_write
+ procedure :: get_var_attributes
end type diag_yaml_files_var_type
From 0f3db8b1922a1e0e79d34faf4f001fe9c09f3bde Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 28 Dec 2021 14:49:53 -0500
Subject: [PATCH 024/168] feat: add diag_yaml object (#866)
---
CMakeLists.txt | 3 +
diag_manager/Makefile.am | 22 +-
diag_manager/diag_data.F90 | 27 --
diag_manager/diag_manager.F90 | 21 +-
diag_manager/diag_yaml.c | 6 -
diag_manager/diag_yaml.h | 28 ---
diag_manager/fms_diag_object.F90 | 19 +-
diag_manager/fms_diag_yaml.F90 | 347 ++++++++++++++++++++++----
diag_manager/fms_diag_yaml_object.F90 | 308 ++++++++++-------------
9 files changed, 470 insertions(+), 311 deletions(-)
delete mode 100644 diag_manager/diag_yaml.c
delete mode 100644 diag_manager/diag_yaml.h
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 4756560ae4..d8275c0d4a 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -130,6 +130,9 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_elem_weight_procs.F90
diag_manager/fms_diag_fieldbuff_update.F90
diag_manager/fms_diag_bbox.F90
+ diag_manager/fms_diag_object.F90
+ diag_manager/fms_diag_yaml.F90
+ diag_manager/fms_diag_yaml_object.F90
drifters/cloud_interpolator.F90
drifters/drifters.F90
drifters/drifters_comm.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 12a06fd9e5..69d43e7cc5 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -46,8 +46,6 @@ libdiag_manager_la_SOURCES = \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh
fms_diag_yaml.F90 \
- diag_yaml.h \
- diag_yaml.c \
fms_diag_object.F90 \
fms_diag_yaml_object.F90
@@ -56,21 +54,15 @@ diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT)
diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \
- diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT)
+ diag_grid_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
-fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
-fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
-fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
-fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT)
-fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
- fms_diag_outfield_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \
- fms_diag_bbox_mod.$(FC_MODEXT)
+fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
+ fms_diag_yaml_object_mod.$(FC_MODEXT)
+fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) \
+ fms_diag_yaml_object_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
- diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
- fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \
- fms_diag_fieldbuff_update_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT)
-fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
-fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+ diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
+ fms_diag_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
MODFILES = \
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 62972615f5..415ae0804e 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -104,33 +104,6 @@ MODULE diag_data_mod
!> @}
-
- !> @brief The files type matching a C struct containing diag_yaml information
- !> @ingroup diag_data_mod
-type, bind(c) :: diag_files_type
- character (kind=c_char) :: fname (20) !< file name
- character (kind=c_char) :: frequnit (7) !< the frequency unit
- integer (c_int) :: freq !< the frequency of data
- character (kind=c_char) :: timeunit(7) !< The unit of time
- character (kind=c_char) :: unlimdim(8) !< The name of the unlimited dimension
- character (kind=c_char) :: key(8) !< Storage for the key in the yaml file
-end type diag_files_type
-!> @brief The field type matching the C struct for diag_yaml information
- !> @ingroup diag_data_mod
-type, bind(c) :: diag_fields_type
- character (kind=c_char) :: fname (20) !< The field/diagnostic name
- character (kind=c_char) :: var(20) !< The name of the variable
- character (kind=c_char) :: files(20) !< The files that the diagnostic will be written to
- integer (c_int) :: ikind !< The type/kind of the variable
- character (kind=c_char) :: skind(20) !< The type/kind of the variable
- character (kind=c_char) :: reduction(20) !< IDK
- character (kind=c_char) :: all_all(4) !< This has to be "all"
- character (kind=c_char) :: region(50) !< The region
- character (kind=c_char) :: regcoord(50) !< Coodinates of the region
- character (kind=c_char) :: module_location(20) !< The module
- character (kind=c_char) :: key(8) !< Storage for the key in the yaml file
-end type diag_fields_type
-
!> @brief Contains the coordinates of the local domain to output.
!> @ingroup diag_data_mod
TYPE diag_grid
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 23aee09bce..5710267189 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -236,6 +236,9 @@ MODULE diag_manager_mod
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
+#ifdef use_yaml
+ use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end
+#endif
USE fms_diag_object_mod, ONLY: fms_diag_object, diag_object_placeholder
USE constants_mod, ONLY: SECONDS_PER_DAY
USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type
@@ -3706,6 +3709,10 @@ SUBROUTINE diag_manager_end(time)
if (allocated(fileobj)) deallocate(fileobj)
if (allocated(fileobjND)) deallocate(fileobjND)
if (allocated(fnum_for_domain)) deallocate(fnum_for_domain)
+
+#ifdef use_yaml
+ if (use_modern_diag) call diag_yaml_object_end
+#endif
END SUBROUTINE diag_manager_end
!> @brief Replaces diag_manager_end; close just one file: files(file)
@@ -3803,12 +3810,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
& max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
& max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
& oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
-<<<<<<< HEAD
& max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io, field_log_separator,&
- & use_refactored_send
-=======
- & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_mpp_io
->>>>>>> 98bb81e0 (Adds namelist variable)
+ & use_modern_diag
! If the module was already initialized do nothing
IF ( module_is_initialized ) RETURN
@@ -3928,8 +3931,12 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
END IF
END IF
- CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local)
- IF ( mystat /= 0 ) THEN
+#ifdef use_yaml
+ if (use_modern_diag) CALL diag_yaml_object_init()
+#endif
+
+ CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local)
+ IF ( mystat /= 0 ) THEN
IF ( fms_error_handler('diag_manager_mod::diag_manager_init',&
& 'Error parsing diag_table. '//TRIM(err_msg_local), err_msg) ) RETURN
END IF
diff --git a/diag_manager/diag_yaml.c b/diag_manager/diag_yaml.c
deleted file mode 100644
index 29100fd997..0000000000
--- a/diag_manager/diag_yaml.c
+++ /dev/null
@@ -1,6 +0,0 @@
-/** #include **/
-#include
-#include
-#include
-/** #include **/
-
diff --git a/diag_manager/diag_yaml.h b/diag_manager/diag_yaml.h
deleted file mode 100644
index fe1c9212ed..0000000000
--- a/diag_manager/diag_yaml.h
+++ /dev/null
@@ -1,28 +0,0 @@
-#include
-#include
-#include
-#include
-typedef struct diag_files {
- char name [20];
- char frequnit [7];
- int freq;
- char timeunit [7];
- char unlimdim [8];
- char key [8];
-} files;
-
-
-typedef struct diag_fields {
- char name[20];
- char var[20];
- char files[20];
- int intkind;
- char skind[20];
- char reduction[20];
- char all[4];
- char region[50];
- char regcoord[50];
- char module[20];
- char key [8];
-} fields;
-
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 2990f92951..5ded82e22d 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -10,11 +10,9 @@ module fms_diag_object_mod
use diag_data_mod, only: diag_null
use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id
-use diag_data_mod, only: diag_fields_type, diag_files_type
-use fms_diag_yaml_mod, only: is_field_type_null
-use fms_diag_yaml_mod, only: diag_yaml
use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
+use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type
use time_manager_mod, ONLY: time_type
!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
@@ -59,8 +57,8 @@ module fms_diag_object_mod
!> \brief Object that holds all variable information
type fms_diag_object
- type (diag_fields_type) :: diag_field !< info from diag_table
- type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table
+ type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table
+ type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table
integer, allocatable, private :: diag_id !< unique id for varable
class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the
!! file objects for this variable
@@ -238,13 +236,14 @@ subroutine fms_register_diag_field_obj &
allocate(character(len=len(modname)) :: dobj%modname)
dobj%modname = trim(modname)
!> Grab the information from the diag_table
+! TO DO:
! dobj%diag_field = get_diag_table_field(trim(varname))
! dobj%diag_field = diag_yaml%get_diag_field(
- if (is_field_type_null(dobj%diag_field)) then
- dobj%diag_id = diag_not_found
- dobj%vartype = diag_null
- return
- endif
+! if (is_field_type_null(dobj%diag_field)) then
+! dobj%diag_id = diag_not_found
+! dobj%vartype = diag_null
+! return
+! endif
!> get the optional arguments if included and the diagnostic is in the diag table
if (present(longname)) then
allocate(character(len=len(longname)) :: dobj%longname)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 41c2777435..9a423697e0 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -1,62 +1,319 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @defgroup fms_diag_yaml_mod fms_diag_yaml_mod
+!> @ingroup diag_manager
+!! @brief fms_diag_yaml_mod is an integral part of
+!! diag_manager_mod. Its function is to read the diag_table.yaml to fill in
+!! the diag_yaml_object
+
+!> @file
+!> @brief File for @ref diag_yaml_mod
+
+!> @addtogroup fms_diag_yaml_mod
+!> @{
module fms_diag_yaml_mod
+#ifdef use_yaml
+use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type, diag_yaml_files_obj_init, &
+ NUM_SUB_REGION_ARRAY
+use yaml_parser_mod
+use mpp_mod
-use diag_data_mod, only: diag_files_type, diag_fields_type
+implicit none
-integer, parameter :: basedate_size = 7
+private
-!> Object that holds the information of the diag_yaml
-type diag_yaml_object
- character(len=:), allocatable, private :: diag_title !< Experiment name
- integer, private, dimension (basedate_size) :: diag_basedate !< basedate array
- type(diag_files_type), allocatable, private, dimension (:) :: diag_files!< History file info
- type(diag_fields_type), allocatable, private, dimension (:,:) :: diag_fields !< Diag fields info
- contains
- procedure :: title => get_title !< Returns the title
- procedure :: basedate => get_basedate !< Returns the basedate array
-end type diag_yaml_object
-type (diag_yaml_object) :: diag_yaml
+public :: diag_yaml_object_init, diag_yaml_object_end
+!> @}
-public :: get_title, get_basedate
+integer, parameter :: basedate_size = 6
+!> @brief Object that holds the information of the diag_yaml
+!> @ingroup fms_diag_yaml_mod
+type diagYamlObject_type
+ character(len=:), allocatable, private :: diag_title !< Experiment name
+ integer, private, dimension (basedate_size) :: diag_basedate !< basedate array
+ type(diagYamlFiles_type), allocatable, private, dimension (:) :: diag_files!< History file info
+ type(diagYamlFilesVar_type), allocatable, private, dimension (:) :: diag_fields !< Diag fields info
+ contains
+ procedure :: get_title !< Returns the title
+ procedure :: get_basedate !< Returns the basedate array
+end type diagYamlObject_type
+
+type (diagYamlObject_type) :: diag_yaml !< Obj containing the contents of the diag_table.yaml
+
+!> @addtogroup fms_diag_yaml_mod
+!> @{
contains
-!> \brief Returns the basedate as an integer array
+!> @brief get the basedate of a diag_yaml type
+!! @return the basedate as an integer array
pure function get_basedate (diag_yaml) result (diag_basedate)
-class (diag_yaml_object), intent(in) :: diag_yaml !< The diag_yaml
-integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return
-diag_basedate = diag_yaml%diag_basedate
+ class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
+ integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return
+
+ diag_basedate = diag_yaml%diag_basedate
end function get_basedate
-!> \brief Returns the title of the diag table as an allocated string
+
+!> @brief get the title of a diag_yaml type
+!! @return the title of the diag table as an allocated string
pure function get_title (diag_yaml) result (diag_title)
-class (diag_yaml_object), intent(in) :: diag_yaml !< The diag_yaml
-character(len=:),allocatable :: diag_title !< Basedate array result to return
- diag_title = diag_yaml%diag_title
+ class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
+ character(len=:),allocatable :: diag_title !< Basedate array result to return
+
+ diag_title = diag_yaml%diag_title
end function get_title
-!> \brief Compares two field type variables
-pure logical function is_field_type_null (in1)
-type(diag_fields_type), intent(in) :: in1
-is_field_type_null = .true.
-end function is_field_type_null
-
-!!TODO
-!> \brief looks for a diag_field based on it's name.
-!! Returns null if field is not found.
-!type(diag_fields_type)function get_diag_table_field (field_name) result (field)
-! character(len=*), intent(IN) :: field_name
-! integer :: i
-! do i = 1,size(diag_fields)
-! if (trim(field_name) == trim(fms_c2f_string(diag_fields(i)%fname))) then
-! field = diag_fields(i)
-!write (6,*) field_name//" Found"
-!
-! return
-! endif
-! enddo
-! field = null_field_type
-!
-!end function get_diag_table_field
+!> @brief Uses the yaml_parser_mod to read in the diag_table and fill in the
+!! diag_yaml object
+subroutine diag_yaml_object_init
+ integer :: diag_yaml_id !< Id for the diag_table yaml
+ integer :: nfiles !< Number of files in the diag_table yaml
+ integer, allocatable :: diag_file_ids(:) !< Ids of the files in the diag_table yaml
+ integer :: i, j !< For do loops
+ integer :: total_nvars !< The total number of variables in the diag_table yaml
+ integer :: var_count !< The current number of variables added to the diag_yaml obj
+ integer :: nvars !< The number of variables in the current file
+ integer, allocatable :: var_ids(:) !< Ids of the variables in diag_table yaml
+
+ diag_yaml_id = open_and_parse_file("diag_table.yaml")
+
+ call diag_get_value_from_key(diag_yaml_id, 0, "title", diag_yaml%diag_title)
+ call get_value_from_key(diag_yaml_id, 0, "base_date", diag_yaml%diag_basedate)
+
+ nfiles = get_num_blocks(diag_yaml_id, "diag_files")
+ allocate(diag_yaml%diag_files(nfiles))
+ allocate(diag_file_ids(nfiles))
+ call get_block_ids(diag_yaml_id, "diag_files", diag_file_ids)
+
+ total_nvars = get_total_num_vars(diag_yaml_id, diag_file_ids)
+ allocate(diag_yaml%diag_fields(total_nvars))
+
+ var_count = 0
+ nfiles_loop: do i = 1, nfiles
+ call diag_yaml_files_obj_init(diag_yaml%diag_files(i))
+ call fill_in_diag_files(diag_yaml_id, diag_file_ids(i), diag_yaml%diag_files(i))
+
+ nvars = 0
+ nvars = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i))
+ allocate(var_ids(nvars))
+ call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=diag_file_ids(i))
+ nvars_loop: do j = 1, nvars
+ var_count = var_count + 1
+ call fill_in_diag_fields(diag_yaml_id, var_ids(j), diag_yaml%diag_fields(var_count))
+ enddo nvars_loop
+ deallocate(var_ids)
+ enddo nfiles_loop
+
+ deallocate(diag_file_ids)
+end subroutine
+
+!> @brief Destroys the diag_yaml object
+subroutine diag_yaml_object_end()
+ integer :: i !< For do loops
+
+ do i = 1, size(diag_yaml%diag_files, 1)
+ if(allocated(diag_yaml%diag_files(i)%file_global_meta)) deallocate(diag_yaml%diag_files(i)%file_global_meta)
+ if(allocated(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region)) &
+ deallocate(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region)
+ if(allocated(diag_yaml%diag_files(i)%file_sub_region%index_sub_region)) &
+ deallocate(diag_yaml%diag_files(i)%file_sub_region%index_sub_region)
+ enddo
+ if(allocated(diag_yaml%diag_files)) deallocate(diag_yaml%diag_files)
+
+ do i = 1, size(diag_yaml%diag_fields, 1)
+ if(allocated(diag_yaml%diag_fields(i)%var_attributes)) deallocate(diag_yaml%diag_fields(i)%var_attributes)
+ enddo
+ if(allocated(diag_yaml%diag_fields)) deallocate(diag_yaml%diag_fields)
+
+end subroutine diag_yaml_object_end
+
+!> @brief Fills in a diagYamlFiles_type with the contents of a file block in diag_table.yaml
+subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
+ integer, intent(in) :: diag_yaml_id !< Id of the diag_table.yaml
+ integer, intent(in) :: diag_file_id !< Id of the file block to read
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to read the contents into
+
+ integer :: nsubregion !< Flag indicating of there any regions (0 or 1)
+ integer :: sub_region_id(1) !< Id of the sub_region block
+ integer :: natt !< Number of global attributes in the current file
+ integer :: global_att_id(1) !< Id of the global attributes block
+ integer :: nkeys !< Number of key/value global attributes pair
+ integer :: j !< For do loops
+
+ integer, allocatable :: key_ids(:) !< Id of the gloabl atttributes key/value pairs
+
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", fileobj%file_frequnit)
+ call get_value_from_key(diag_yaml_id, diag_file_id, "freq", fileobj%file_freq)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", fileobj%file_unlimdim)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", fileobj%file_timeunit)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "write_file", fileobj%string_file_write, is_optional=.true.)
+ if (fileobj%string_file_write .eq. "false") fileobj%file_write = .false.
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "realm", fileobj%file_realm, is_optional=.true.)
+ call get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", fileobj%file_new_file_freq, is_optional=.true.)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq_units", fileobj%file_new_file_freq_units, &
+ is_optional=.true.)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", fileobj%file_start_time, is_optional=.true.)
+ call get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", fileobj%file_duration, is_optional=.true.)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration_units", fileobj%file_duration_units, &
+ is_optional=.true.)
+
+ nsubregion = 0
+ nsubregion = get_num_blocks(diag_yaml_id, "sub_region", parent_block_id=diag_file_id)
+ if (nsubregion .eq. 1) then
+ call get_block_ids(diag_yaml_id, "sub_region", sub_region_id, parent_block_id=diag_file_id)
+ call diag_get_value_from_key(diag_yaml_id, sub_region_id(1), "grid_type", fileobj%file_sub_region%grid_type)
+ if (trim(fileobj%file_sub_region%grid_type) .eq. "latlon") then
+ allocate(fileobj%file_sub_region%lat_lon_sub_region(8))
+ call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%lat_lon_sub_region)
+ elseif (trim(fileobj%file_sub_region%grid_type) .eq. "index") then
+ allocate(fileobj%file_sub_region%index_sub_region(8))
+ call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%index_sub_region)
+ call get_value_from_key(diag_yaml_id, sub_region_id(1), "tile", fileobj%file_sub_region%tile, is_optional=.true.)
+ if (fileobj%file_sub_region%tile .eq. 0) call mpp_error(FATAL, "The tile number is required when defining a "//&
+ "subregion. Check your subregion entry for "//trim(fileobj%file_fname))
+ endif
+ elseif (nsubregion .ne. 0) then
+ call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//" has multiple region blocks")
+ endif
+
+ natt = 0
+ natt = get_num_blocks(diag_yaml_id, "global_meta", parent_block_id=diag_file_id)
+ if (natt .eq. 1) then
+ call get_block_ids(diag_yaml_id, "global_meta", global_att_id, parent_block_id=diag_file_id)
+ nkeys = get_nkeys(diag_yaml_id, global_att_id(1))
+ allocate(key_ids(nkeys))
+ call get_key_ids(diag_yaml_id, global_att_id(1), key_ids)
+
+ allocate(fileobj%file_global_meta(nkeys, 2))
+ do j = 1, nkeys
+ call get_key_name(diag_yaml_id, key_ids(j), fileobj%file_global_meta(j, 1))
+ call get_key_value(diag_yaml_id, key_ids(j), fileobj%file_global_meta(j, 2))
+ enddo
+ deallocate(key_ids)
+ elseif (natt .ne. 0) then
+ call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//" has multiple global_meta blocks")
+ endif
+
+end subroutine
+
+!> @brief Fills in a diagYamlFilesVar_type with the contents of a variable block in
+!! diag_table.yaml
+subroutine fill_in_diag_fields(diag_file_id, var_id, field)
+ integer, intent(in) :: diag_file_id !< Id of the file block in the yaml file
+ integer, intent(in) :: var_id !< Id of the variable block in the yaml file
+ type(diagYamlFilesVar_type), intent(out) :: field !< diagYamlFilesVar_type obj to read the contents into
+
+
+ integer :: natt !< Number of attributes in variable
+ integer :: var_att_id(1) !< Id of the variable attribute block
+ integer :: nkeys !< Number of key/value pairs of attributes
+ integer :: j !< For do loops
+
+ integer, allocatable :: key_ids(:) !< Id of each attribute key/value pair
+
+ field%var_write = .true.
+ call diag_get_value_from_key(diag_file_id, var_id, "var_name", field%var_varname)
+ call diag_get_value_from_key(diag_file_id, var_id, "reduction", field%var_reduction)
+ call diag_get_value_from_key(diag_file_id, var_id, "module", field%var_module)
+ call diag_get_value_from_key(diag_file_id, var_id, "kind", field%var_skind)
+ call diag_get_value_from_key(diag_file_id, var_id, "write_var", field%string_var_write, is_optional=.true.)
+ if (trim(field%string_var_write) .eq. "false") field%var_write = .false.
+
+ call diag_get_value_from_key(diag_file_id, var_id, "output_name", field%var_outname)
+ call diag_get_value_from_key(diag_file_id, var_id, "long_name", field%var_longname, is_optional=.true.)
+ !! VAR_UNITS !!
+
+ natt = 0
+ natt = get_num_blocks(diag_file_id, "attributes", parent_block_id=var_id)
+ if (natt .eq. 1) then
+ call get_block_ids(diag_file_id, "attributes", var_att_id, parent_block_id=var_id)
+ nkeys = get_nkeys(diag_file_id, var_att_id(1))
+ allocate(key_ids(nkeys))
+ call get_key_ids(diag_file_id, var_att_id(1), key_ids)
+
+ allocate(field%var_attributes(nkeys, 2))
+ do j = 1, nkeys
+ call get_key_name(diag_file_id, key_ids(j), field%var_attributes(j, 1))
+ call get_key_value(diag_file_id, key_ids(j), field%var_attributes(j, 2))
+ enddo
+ deallocate(key_ids)
+ elseif (natt .ne. 0) then
+ call mpp_error(FATAL, "diag_yaml_object_init: variable "//trim(field%var_varname)//" has multiple attribute blocks")
+ endif
+
+end subroutine
+
+!> @brief diag_manager wrapper to get_value_from_key to use for allocatable
+!! string variables
+subroutine diag_get_value_from_key(diag_file_id, par_id, key_name, value_name, is_optional)
+ integer, intent(in) :: diag_file_id!< Id of the file block in the yaml file
+ integer, intent(in) :: par_id !< Id of the parent block in the yaml file
+ character(len=*), intent(in) :: key_name !< Key to look for in the parent block
+ character(len=:), allocatable :: value_name !< Value of the key
+ logical, intent(in), optional :: is_optional !< Flag indicating if the key is optional
+
+ character(len=255) :: buffer !< String buffer to read in to
+
+ buffer = "" !< Needs to be initialized for optional keys that are not present
+ call get_value_from_key(diag_file_id, par_id, trim(key_name), buffer, is_optional= is_optional)
+ allocate(character(len=len_trim(buffer)) :: value_name)
+ value_name = trim(buffer)
+
+end subroutine diag_get_value_from_key
+
+!> @brief gets the lat/lon of the sub region to use in a diag_table yaml
+subroutine get_sub_region(diag_yaml_id, sub_region_id, sub_region)
+ integer, intent(in) :: diag_yaml_id !< Id of the diag_table yaml file
+ integer, intent(in) :: sub_region_id !< Id of the region block to read from
+ class(*),intent(out) :: sub_region (NUM_SUB_REGION_ARRAY) !< Array storing the bounds of the sub region
+
+ call get_value_from_key(diag_yaml_id, sub_region_id, "dim1_begin", sub_region(1), is_optional=.true.)
+ call get_value_from_key(diag_yaml_id, sub_region_id, "dim1_end", sub_region(2), is_optional=.true.)
+ call get_value_from_key(diag_yaml_id, sub_region_id, "dim2_begin", sub_region(3), is_optional=.true.)
+ call get_value_from_key(diag_yaml_id, sub_region_id, "dim2_end", sub_region(4), is_optional=.true.)
+ call get_value_from_key(diag_yaml_id, sub_region_id, "dim3_begin", sub_region(5), is_optional=.true.)
+ call get_value_from_key(diag_yaml_id, sub_region_id, "dim3_end", sub_region(6), is_optional=.true.)
+ call get_value_from_key(diag_yaml_id, sub_region_id, "dim4_begin", sub_region(7), is_optional=.true.)
+ call get_value_from_key(diag_yaml_id, sub_region_id, "dim4_end", sub_region(8), is_optional=.true.)
+
+end subroutine get_sub_region
+
+!> @brief gets the total number of variables in the diag_table yaml file
+!! @return total number of variables
+function get_total_num_vars(diag_yaml_id, diag_file_ids) &
+result(total_nvars)
+
+ integer, intent(in) :: diag_yaml_id !< Id for the diag_table yaml
+ integer, intent(in) :: diag_file_ids(:) !< Ids of the files in the diag_table yaml
+ integer :: total_nvars
+ integer :: i !< For do loop
+ total_nvars = 0
+ do i = 1, size(diag_file_ids,1)
+ total_nvars = total_nvars + get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i))
+ end do
+end function
+#endif
end module fms_diag_yaml_mod
+!> @}
+! close documentation grouping
diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90
index b26a4a3bdc..e406885084 100644
--- a/diag_manager/fms_diag_yaml_object.F90
+++ b/diag_manager/fms_diag_yaml_object.F90
@@ -18,10 +18,10 @@
!***********************************************************************
!> @defgroup fms_diag_yaml_object_mod fms_diag_yaml_object_mod
!> @ingroup diag_manager
-!! @brief The diag yaml objects are handled here, with variables the correspond to
-!! entries in the diag yaml file. The actual parsing of the yaml is handled in
+!! @brief The diag yaml objects are handled here, with variables the correspond to
+!! entries in the diag yaml file. The actual parsing of the yaml is handled in
!! @ref fms_diag_yaml_mod.
-!! @author Tom Robinson
+!! @author Tom Robinson, Uriel Ramirez
!> @file
!> @brief File for @ref fms_diag_yaml_object_mod
@@ -33,64 +33,57 @@ module fms_diag_yaml_object_mod
use fms_mod , only: fms_c2f_string
use iso_c_binding
implicit none
-integer, parameter :: NUM_REGION_ARRAY = 8
- !> @brief The files type matching a C struct containing diag_yaml information
- !> @ingroup fms_diag_files_mod
-type, bind(c) :: diag_yaml_files_struct
- character (kind=c_char) :: file_fname (20) !< file name
- character (kind=c_char) :: file_frequnit (7) !< the frequency unit
- integer (c_int) :: file_freq !< the frequency of data
- character (kind=c_char) :: file_timeunit(7) !< The unit of time
- character (kind=c_char) :: file_unlimdim(8) !< The name of the unlimited dimension
- character (kind=c_char) :: file_write (5) !< false if the user doesn’t want the file to be
- !! created (default is true).
- character (kind=c_char) :: file_realm (3) !< The modeling realm that the variables come from
- real (c_float) :: file_region (NUM_REGION_ARRAY) !< Bounds of the regional section to capture
- integer (c_int) :: file_new_file_freq !< Frequency for closing the existing file
- character (kind=c_char) :: file_new_file_freq_units (3)!< Time units for creating a new file.
- !! Required if “new_file_freq” used
- integer (c_int) :: file_start_time !< Time to start the file for the first time. Requires “new_file_freq”
- integer (c_int) :: file_duration !< How long the file should receive data after start time
- !! in “file_duration_units”. This optional field can only
- !! be used if the start_time field is present. If this field
- !! is absent, then the file duration will be equal to the
- !! frequency for creating new files.
- !! NOTE: The file_duration_units field must also be present if
- !! this field is present.
- character (kind=c_char) :: file_duration_units (3)!< The file duration units
-end type diag_yaml_files_struct
+integer, parameter :: NUM_SUB_REGION_ARRAY = 8
+integer, parameter :: MAX_STR_LEN = 255
+
+!> @brief type to hold the sub region information about a file
+type subRegion_type
+ character (len=:), allocatable :: grid_type !< Flag indicating the type of region,
+ !! acceptable values are "latlon" and "index"
+ real, allocatable :: lat_lon_sub_region (:) !< Array that stores the grid point bounds for the sub region
+ !! to use if grid_type is set to "latlon"
+ !! [dim1_begin, dim1_end, dim2_begin, dim2_end,
+ !! dim3_begin, dim3_end, dim4_begin, dim4_end]
+ integer, allocatable :: index_sub_region (:) !< Array that stores the index bounds for the sub region to
+ !! to use if grid_type is set to "index"
+ !! [dim1_begin, dim1_end, dim2_begin, dim2_end,
+ !! dim3_begin, dim3_end, dim4_begin, dim4_end]
+ integer :: tile !< Tile number of the sub region, required if using the "index" grid type
+
+end type subRegion_type
-type diag_yaml_files_type
+type diagYamlFiles_type
character (len=:), allocatable :: file_fname !< file name
character (len=:), allocatable :: file_frequnit !< the frequency unit
integer (c_int) :: file_freq !< the frequency of data
character (len=:), allocatable :: file_timeunit !< The unit of time
character (len=:), allocatable :: file_unlimdim !< The name of the unlimited dimension
logical :: file_write
- character (len=:), allocatable :: string_file_write !< false if the user doesn’t want the file to be
+ character (len=:), allocatable :: string_file_write !< false if the user doesn’t want the file to be
!! created (default is true).
character (len=:), allocatable :: file_realm !< The modeling realm that the variables come from
- real :: file_region (NUM_REGION_ARRAY) !< Bounds of the regional section to capture
+ type(subRegion_type) :: file_sub_region !< type containing info about the subregion, if any
integer :: file_new_file_freq !< Frequency for closing the existing file
- character (len=:), allocatable :: file_new_file_freq_units !< Time units for creating a new file.
+ character (len=:), allocatable :: file_new_file_freq_units !< Time units for creating a new file.
!! Required if “new_file_freq” used
- integer :: file_start_time !< Time to start the file for the first time. Requires “new_file_freq”
- integer :: file_duration !< How long the file should receive data after start time
- !! in “file_duration_units”. This optional field can only
+ character (len=:), allocatable :: file_start_time !< Time to start the file for the first time. Requires
+ !! “new_file_freq”
+ integer :: file_duration !< How long the file should receive data after start time
+ !! in “file_duration_units”. This optional field can only
!! be used if the start_time field is present. If this field
!! is absent, then the file duration will be equal to the
- !! frequency for creating new files.
+ !! frequency for creating new files.
!! NOTE: The file_duration_units field must also be present if
!! this field is present.
character (len=:), allocatable :: file_duration_units !< The file duration units
- character (len=:), dimension(:), allocatable :: file_varlist !< An array of variable names
+ !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
+ character (len=MAX_STR_LEN), dimension(:), allocatable :: file_varlist !< An array of variable names
!! within a file
- character (len=:), dimension(:,:), allocatable :: file_global_meta !< Array of key(dim=1)
- !! and values(dim=2) to be added as global
+ character (len=MAX_STR_LEN), dimension(:,:), allocatable :: file_global_meta !< Array of key(dim=1)
+ !! and values(dim=2) to be added as global
!! meta data to the file
contains
- procedure :: copy_struct => copy_file_struct_to_object
procedure :: get_file_fname
procedure :: get_file_frequnit
procedure :: get_file_freq
@@ -98,7 +91,7 @@ module fms_diag_yaml_object_mod
procedure :: get_file_unlimdim
procedure :: get_file_write
procedure :: get_file_realm
- procedure :: get_file_region
+ procedure :: get_file_sub_region
procedure :: get_file_new_file_freq
procedure :: get_file_new_file_freq_units
procedure :: get_file_start_time
@@ -107,24 +100,9 @@ module fms_diag_yaml_object_mod
procedure :: get_file_varlist
procedure :: get_file_global_meta
-end type diag_yaml_files_type
+end type diagYamlFiles_type
-!> @brief The field type matching the C struct for diag_yaml information
- !> @ingroup fms_diag_files_mod
-type, bind(c) :: diag_yaml_files_var_struct
- character (kind=c_char) :: var_fname (20) !< The field/diagnostic name
- character (kind=c_char) :: var_varname(20) !< The name of the variable
- character (kind=c_char) :: var_reduction(20) !< Reduction to be done on var
- character (kind=c_char) :: var_module(20) !< The module that th variable is in
- character (kind=c_char) :: var_skind(8) !< The type/kind of the variable
- character (kind=c_char) :: var_write(5) !< false if the user doesn’t want the variable to be
- !! written to the file (default: true).
- character (kind=c_char) :: var_outname(20) !< Name of the variable as written to the file
- character (kind=c_char) :: var_longname(100) !< Overwrites the long name of the variable
- character (kind=c_char) :: var_units(10) !< Overwrites the units
-end type diag_yaml_files_var_struct
-
-type diag_yaml_files_var_type
+type diagYamlFilesVar_type
character (len=:), allocatable :: var_fname !< The field/diagnostic name
character (len=:), allocatable :: var_varname !< The name of the variable
character (len=:), allocatable :: var_reduction !< Reduction to be done on var
@@ -137,10 +115,10 @@ module fms_diag_yaml_object_mod
character (len=:), allocatable :: var_outname !< Name of the variable as written to the file
character (len=:), allocatable :: var_longname !< Overwrites the long name of the variable
character (len=:), allocatable :: var_units !< Overwrites the units
- character (len=:), dimension (:), allocatable :: var_attributes !< Attributes to overwrite or
+ !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
+ character (len=MAX_STR_LEN), dimension (:, :), allocatable :: var_attributes !< Attributes to overwrite or
!! add from diag_yaml
contains
- procedure :: copy_struct => copy_variable_struct_to_object
procedure :: get_var_fname
procedure :: get_var_varname
procedure :: get_var_reduction
@@ -152,130 +130,112 @@ module fms_diag_yaml_object_mod
procedure :: get_var_write
procedure :: get_var_attributes
-end type diag_yaml_files_var_type
+end type diagYamlFilesVar_type
contains
-!!!!!!!! YAML FILE ROUTINES !!!!!!!!
-!< \brief Copies the information of the yaml struct to the fortran object holding the info
-subroutine copy_file_struct_to_object(diag_files_obj, diag_files_struct)
- class(diag_yaml_files_type) :: diag_files_obj !< Fortran-side object with diag_yaml info
- type(diag_yaml_files_struct) :: diag_files_struct !< The C struct that has the diag_yaml
- !! info
- integer :: i !< For looping
-!< Convert the C strings to Fortran strings
- diag_files_obj%file_fname = fms_c2f_string (diag_files_struct%file_fname)
- diag_files_obj%file_frequnit = fms_c2f_string (diag_files_struct%file_frequnit)
- diag_files_obj%file_timeunit = fms_c2f_string (diag_files_struct%file_timeunit)
- diag_files_obj%file_unlimdim = fms_c2f_string (diag_files_struct%file_unlimdim)
- diag_files_obj%file_realm = fms_c2f_string (diag_files_struct%file_realm)
- diag_files_obj%file_new_file_freq_units = fms_c2f_string (diag_files_struct%file_new_file_freq_units)
- diag_files_obj%file_duration_units = fms_c2f_string (diag_files_struct%file_duration_units)
-!< Set the file_write to be true or false
- diag_files_obj%string_file_write = fms_c2f_string (diag_files_struct%file_write)
- diag_files_obj%file_write = .true.
- if (diag_files_obj%string_file_write(1:1)=="f" .or. &
- diag_files_obj%string_file_write(1:1)=="F") &
- diag_files_obj%file_write = .false.
- deallocate (diag_files_obj%string_file_write)
-!< Store the numbers
- diag_files_obj%file_freq = diag_files_struct%file_freq
-!$omp simd
- do i = 1, NUM_REGION_ARRAY
- diag_files_obj%file_region(i) = diag_files_struct%file_region(i)
- enddo
- diag_files_obj%file_new_file_freq = diag_files_struct%file_new_file_freq
- diag_files_obj%file_start_time = diag_files_struct%file_start_time
- diag_files_obj%file_duration = diag_files_struct%file_duration
-
-end subroutine copy_file_struct_to_object
!!!!!!! YAML FILE INQUIRIES !!!!!!!
-!> \brief Inquiry for diag_files_obj%file_fname
+!> @brief Inquiry for diag_files_obj%file_fname
+!! @return file_fname of a diag_yaml_file obj
pure function get_file_fname (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_fname
end function get_file_fname
-!> \brief Inquiry for diag_files_obj%file_frequnit
+!> @brief Inquiry for diag_files_obj%file_frequnit
+!! @return file_frequnit of a diag_yaml_file_obj
pure function get_file_frequnit (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_frequnit
end function get_file_frequnit
-!> \brief Inquiry for diag_files_obj%file_freq
+!> @brief Inquiry for diag_files_obj%file_freq
+!! @return file_freq of a diag_yaml_file_obj
pure function get_file_freq(diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
integer :: res !< What is returned
res = diag_files_obj%file_freq
end function get_file_freq
-!> \brief Inquiry for diag_files_obj%file_timeunit
+!> @brief Inquiry for diag_files_obj%file_timeunit
+!! @return file_timeunit of a diag_yaml_file_obj
pure function get_file_timeunit (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_timeunit
end function get_file_timeunit
-!> \brief Inquiry for diag_files_obj%file_unlimdim
+!> @brief Inquiry for diag_files_obj%file_unlimdim
+!! @return file_unlimdim of a diag_yaml_file_obj
pure function get_file_unlimdim(diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_unlimdim
end function get_file_unlimdim
-!> \brief Inquiry for diag_files_obj%file_write
+!> @brief Inquiry for diag_files_obj%file_write
+!! @return file_write of a diag_yaml_file_obj
pure function get_file_write(diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
logical :: res !< What is returned
res = diag_files_obj%file_write
end function get_file_write
-!> \brief Inquiry for diag_files_obj%file_realm
+!> @brief Inquiry for diag_files_obj%file_realm
+!! @return file_realm of a diag_yaml_file_obj
pure function get_file_realm(diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
character (:), allocatable :: res !< What is returned
res = diag_files_obj%file_realm
end function get_file_realm
-!> \brief Inquiry for diag_files_obj%file_region
-pure function get_file_region (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- real :: res (NUM_REGION_ARRAY) !< What is returned
- res = diag_files_obj%file_region
-end function get_file_region
-!> \brief Inquiry for diag_files_obj%file_new_file_freq
+!> @brief Inquiry for diag_files_obj%file_subregion
+!! @return file_sub_region of a diag_yaml_file_obj
+pure function get_file_sub_region (diag_files_obj) result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ type(subRegion_type) :: res !< What is returned
+ res = diag_files_obj%file_sub_region
+end function get_file_sub_region
+!> @brief Inquiry for diag_files_obj%file_new_file_freq
+!! @return file_new_file_freq of a diag_yaml_file_obj
pure function get_file_new_file_freq(diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
integer :: res !< What is returned
res = diag_files_obj%file_new_file_freq
end function get_file_new_file_freq
-!> \brief Inquiry for diag_files_obj%file_new_file_freq_units
+!> @brief Inquiry for diag_files_obj%file_new_file_freq_units
+!! @return file_new_file_freq_units of a diag_yaml_file_obj
pure function get_file_new_file_freq_units (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
character (:), allocatable :: res !< What is returned
res = diag_files_obj%file_new_file_freq_units
end function get_file_new_file_freq_units
-!> \brief Inquiry for diag_files_obj%file_start_time
+!> @brief Inquiry for diag_files_obj%file_start_time
+!! @return file_start_time of a diag_yaml_file_obj
pure function get_file_start_time (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
- integer :: res !< What is returned
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_start_time
end function get_file_start_time
-!> \brief Inquiry for diag_files_obj%file_duration
+!> @brief Inquiry for diag_files_obj%file_duration
+!! @return file_duration of a diag_yaml_file_obj
pure function get_file_duration (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
integer :: res !< What is returned
res = diag_files_obj%file_duration
end function get_file_duration
-!> \brief Inquiry for diag_files_obj%file_duration_units
+!> @brief Inquiry for diag_files_obj%file_duration_units
+!! @return file_duration_units of a diag_yaml_file_obj
pure function get_file_duration_units (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
character (:), allocatable :: res !< What is returned
res = diag_files_obj%file_duration_units
end function get_file_duration_units
-!> \brief Inquiry for diag_files_obj%file_varlist
+!> @brief Inquiry for diag_files_obj%file_varlist
+!! @return file_varlist of a diag_yaml_file_obj
pure function get_file_varlist (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
character (:), allocatable :: res(:) !< What is returned
res = diag_files_obj%file_varlist
end function get_file_varlist
-!> \brief Inquiry for diag_files_obj%file_global_meta
+!> @brief Inquiry for diag_files_obj%file_global_meta
+!! @return file_global_meta of a diag_yaml_file_obj
pure function get_file_global_meta (diag_files_obj) result (res)
- class (diag_yaml_files_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
character (:), allocatable :: res(:,:) !< What is returned
res = diag_files_obj%file_global_meta
end function get_file_global_meta
@@ -283,91 +243,93 @@ end function get_file_global_meta
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! VARIABLES ROUTINES AND FUNCTIONS !!!!!!!
-!< \brief Copies the information of the yaml struct to the fortran object holding the var info
-subroutine copy_variable_struct_to_object(diag_var_obj, diag_var_struct)
- class(diag_yaml_files_var_type) :: diag_var_obj !< Fortran-side object with diag_yaml var info
- type(diag_yaml_files_var_struct) :: diag_var_struct !< The C struct that has the diag_yaml
- !! var info
-!< Convert the C strings to Fortran strings
- diag_var_obj%var_fname = fms_c2f_string (diag_var_struct%var_fname)
- diag_var_obj%var_varname = fms_c2f_string (diag_var_struct%var_varname)
- diag_var_obj%var_reduction = fms_c2f_string (diag_var_struct%var_reduction)
- diag_var_obj%var_module = fms_c2f_string (diag_var_struct%var_module)
- diag_var_obj%var_skind = fms_c2f_string (diag_var_struct%var_skind)
- diag_var_obj%var_outname = fms_c2f_string (diag_var_struct%var_outname)
- diag_var_obj%var_longname = fms_c2f_string (diag_var_struct%var_longname)
- diag_var_obj%var_units = fms_c2f_string (diag_var_struct%var_units)
-!< Set the file_write to be true or false
- diag_var_obj%string_var_write= fms_c2f_string (diag_var_struct%var_write)
- diag_var_obj%var_write= .true.
- if (diag_var_obj%string_var_write(1:1)=="f" .or. &
- diag_var_obj%string_var_write(1:1)=="F") &
- diag_var_obj%var_write= .false.
- deallocate (diag_var_obj%string_var_write)
-end subroutine copy_variable_struct_to_object
+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!! YAML VAR INQUIRIES !!!!!!!
-!> \brief Inquiry for diag_yaml_files_var_obj%var_fname
+!> @brief Inquiry for diag_yaml_files_var_obj%var_fname
+!! @return var_fname of a diag_yaml_files_var_obj
pure function get_var_fname (diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_fname
end function get_var_fname
-!> \brief Inquiry for diag_yaml_files_var_obj%var_varname
+!> @brief Inquiry for diag_yaml_files_var_obj%var_varname
+!! @return var_varname of a diag_yaml_files_var_obj
pure function get_var_varname (diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_varname
end function get_var_varname
-!> \brief Inquiry for diag_yaml_files_var_obj%var_reduction
+!> @brief Inquiry for diag_yaml_files_var_obj%var_reduction
+!! @return var_reduction of a diag_yaml_files_var_obj
pure function get_var_reduction (diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_reduction
end function get_var_reduction
-!> \brief Inquiry for diag_yaml_files_var_obj%var_module
+!> @brief Inquiry for diag_yaml_files_var_obj%var_module
+!! @return var_module of a diag_yaml_files_var_obj
pure function get_var_module (diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_module
end function get_var_module
-!> \brief Inquiry for diag_yaml_files_var_obj%var_skind
+!> @brief Inquiry for diag_yaml_files_var_obj%var_skind
+!! @return var_skind of a diag_yaml_files_var_obj
pure function get_var_skind (diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_skind
end function get_var_skind
-!> \brief Inquiry for diag_yaml_files_var_obj%var_outname
+!> @brief Inquiry for diag_yaml_files_var_obj%var_outname
+!! @return var_outname of a diag_yaml_files_var_obj
pure function get_var_outname (diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_outname
end function get_var_outname
-!> \brief Inquiry for diag_yaml_files_var_obj%var_longname
+!> @brief Inquiry for diag_yaml_files_var_obj%var_longname
+!! @return var_longname of a diag_yaml_files_var_obj
pure function get_var_longname (diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_longname
end function get_var_longname
-!> \brief Inquiry for diag_yaml_files_var_obj%var_units
+!> @brief Inquiry for diag_yaml_files_var_obj%var_units
+!! @return var_units of a diag_yaml_files_var_obj
pure function get_var_units (diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_units
end function get_var_units
-!> \brief Inquiry for diag_yaml_files_var_obj%var_write
+!> @brief Inquiry for diag_yaml_files_var_obj%var_write
+!! @return var_write of a diag_yaml_files_var_obj
pure function get_var_write (diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
logical :: res !< What is returned
res = diag_var_obj%var_write
end function get_var_write
-!> \brief Inquiry for diag_yaml_files_var_obj%var_attributes
+!> @brief Inquiry for diag_yaml_files_var_obj%var_attributes
+!! @return var_attributes of a diag_yaml_files_var_obj
pure function get_var_attributes(diag_var_obj) result (res)
- class (diag_yaml_files_var_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res (:) !< What is returned
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned
res = diag_var_obj%var_attributes
end function get_var_attributes
+!> @brief Initializes the non string values of a diagYamlFiles_type to its
+!! default values
+subroutine diag_yaml_files_obj_init(obj)
+ type(diagYamlFiles_type), intent(out) :: obj !< diagYamlFiles_type object to initialize
+
+ obj%file_freq = 0
+ obj%file_write = .true.
+ obj%file_duration = 0
+ obj%file_sub_region%lat_lon_sub_region = -999.
+ obj%file_sub_region%index_sub_region = -999
+ obj%file_sub_region%tile = 0
+end subroutine diag_yaml_files_obj_init
+
end module fms_diag_yaml_object_mod
!> @}
! close documentation grouping
From 1edbc322cc1ace38574fea40800c008025289499 Mon Sep 17 00:00:00 2001
From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com>
Date: Tue, 4 Jan 2022 15:55:22 -0500
Subject: [PATCH 025/168] feat: Add the fms_diag_object container. (#867)
---
CMakeLists.txt | 2 +
diag_manager/Makefile.am | 19 +-
diag_manager/diag_manager.F90 | 30 +-
diag_manager/fms_diag_dlinked_list.F90 | 323 ++++++++++++++++++
diag_manager/fms_diag_object.F90 | 36 +-
diag_manager/fms_diag_object_container.F90 | 261 ++++++++++++++
test_fms/diag_manager/Makefile.am | 5 +-
.../diag_manager/test_diag_dlinked_list.F90 | 238 +++++++++++++
test_fms/diag_manager/test_diag_manager2.sh | 4 +-
.../test_diag_object_container.F90 | 237 +++++++++++++
10 files changed, 1127 insertions(+), 28 deletions(-)
create mode 100644 diag_manager/fms_diag_dlinked_list.F90
create mode 100644 diag_manager/fms_diag_object_container.F90
create mode 100644 test_fms/diag_manager/test_diag_dlinked_list.F90
create mode 100644 test_fms/diag_manager/test_diag_object_container.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index d8275c0d4a..28469988f7 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -133,6 +133,8 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_object.F90
diag_manager/fms_diag_yaml.F90
diag_manager/fms_diag_yaml_object.F90
+ diag_manager/fms_diag_dlinked_list.F90
+ diag_manager/fms_diag_object_container.F90
drifters/cloud_interpolator.F90
drifters/drifters.F90
drifters/drifters_comm.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 69d43e7cc5..d9fec6ef63 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -31,8 +31,8 @@ noinst_LTLIBRARIES = libdiag_manager.la
# Each convenience library depends on its source.
libdiag_manager_la_SOURCES = \
- diag_axis.F90 \
diag_data.F90 \
+ diag_axis.F90 \
diag_grid.F90 \
diag_manager.F90 \
diag_output.F90 \
@@ -47,7 +47,9 @@ libdiag_manager_la_SOURCES = \
include/fms_diag_fieldbuff_update.fh
fms_diag_yaml.F90 \
fms_diag_object.F90 \
- fms_diag_yaml_object.F90
+ fms_diag_yaml_object.F90 \
+ fms_diag_object_container.F90 \
+ fms_diag_dlinked_list.F90
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
@@ -57,12 +59,14 @@ diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT
diag_grid_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
- fms_diag_yaml_object_mod.$(FC_MODEXT)
+ fms_diag_yaml_object_mod.$(FC_MODEXT)
fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) \
fms_diag_yaml_object_mod.$(FC_MODEXT)
+fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
- diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
- fms_diag_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+ diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
+ fms_diag_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
+ fms_diag_object_container_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
MODFILES = \
@@ -83,10 +87,11 @@ MODFILES = \
fms_diag_yaml_object_mod.$(FC_MODEXT) \
fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) \
+ fms_diag_dlinked_list_mod.$(FC_MODEXT) \
+ fms_diag_object_container_mod.$(FC_MODEXT) \
diag_manager_mod.$(FC_MODEXT)
- nodist_include_HEADERS = $(MODFILES)
-
+nodist_include_HEADERS = $(MODFILES)
BUILT_SOURCES = $(MODFILES)
include $(top_srcdir)/mkmods.mk
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 5710267189..95f3b8643b 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -236,10 +236,14 @@ MODULE diag_manager_mod
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
+ USE fms_diag_object_mod, ONLY: fms_diag_object
+ use fms_diag_object_container_mod, ONLY: FmsDiagObjectContainer_t
+
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end
#endif
USE fms_diag_object_mod, ONLY: fms_diag_object, diag_object_placeholder
+
USE constants_mod, ONLY: SECONDS_PER_DAY
USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type
USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, &
@@ -276,6 +280,8 @@ MODULE diag_manager_mod
type(time_type) :: Time_end
+ TYPE(FmsDiagObjectContainer_t), ALLOCATABLE :: the_diag_object_container
+
!> @brief Send data over to output fields.
!!
!> send_data is overloaded for fields having zero dimension
@@ -448,6 +454,9 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
LOGICAL :: mask_variant1, verbose1
CHARACTER(len=128) :: msg
TYPE(time_type) :: diag_file_init_time !< The intial time of the diag_file
+ INTEGER :: status_ic !< used to check the status of insert into container.
+ CLASS(fms_diag_object), ALLOCATABLE , TARGET :: diag_obj !< the diag object that is (to be) registered
+ TYPE(fms_diag_object), POINTER :: diag_obj_ptr => NULL() !< a pointer to the registered diag_object
! get stdout unit number
stdout_unit = stdout()
@@ -616,14 +625,24 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
END IF
if (use_modern_diag) then
- call diag_object_placeholder(1)%register &
- (module_name, field_name, axes, init_time, &
- long_name, units, missing_value, Range, mask_variant, standard_name, &
- do_not_log, err_msg, interp_method, tile_count, area, volume, realm) !(no metadata here)
+ !! Create a diag object, initialize it with the registered data, and insert
+ !! it ino the diag_obj_container singleton.
+
+ allocate( diag_obj )
+ call diag_obj%register (module_name, field_name, axes, init_time, &
+ long_name, units, missing_value, Range, mask_variant, standard_name, &
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm) !(no metadata here)
+
+ diag_obj_ptr => diag_obj
+ status_ic = the_diag_object_container%insert(diag_obj_ptr%get_id(), diag_obj_ptr)
+ if(status_ic .ne. 0) then
+ print *, "Insertion ERROR for id ", diag_obj_ptr%get_id()
+ endif
endif
END FUNCTION register_diag_field_array
+
!> @brief Return field index for subsequent call to send_data.
!! @return field index for subsequent call to send_data.
INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, units,&
@@ -3955,6 +3974,9 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
& 'Max Value', FIELD_LOG_SEPARATOR, 'AXES LIST'
END IF
+ !!Create the diag_object container; Its a singleton in the diag_data mod
+ the_diag_object_container = FmsDiagObjectContainer_t()
+
module_is_initialized = .TRUE.
! create axis_id for scalars here
null_axis_id = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none')
diff --git a/diag_manager/fms_diag_dlinked_list.F90 b/diag_manager/fms_diag_dlinked_list.F90
new file mode 100644
index 0000000000..99b4fb09ad
--- /dev/null
+++ b/diag_manager/fms_diag_dlinked_list.F90
@@ -0,0 +1,323 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @defgroup fms_diag_dlinked_list_mod fms_diag_dlinked_list_mod
+!> @ingroup diag_manager
+!> @brief fms_diag_dlinked_list_mod defines a generic doubly linked
+!! list class and an iterator class for traversing the list.
+!!
+!> @author Miguel Zuniga
+!!
+!! fms_diag_dlinked_list_mod defines a generic doubly linked
+!! list class and an iterator class for traversing the list. It is
+!! generic in the sense that the elements or objects it contains are
+!! "class(*)" objects. If additional typecheking or psossibly a
+!! slightly different user interface is desired, consider creating
+!! a wrapper or another class with this one for a memeber element and
+!! procedures that are trivially implemeted by using this class.
+!!
+!! This version is roughly a fortran translation of the C++ doubly linked list
+!! class in the book ``Data Structures And Algorithm Analysis in C++", 3rd Edition,
+!! by Mark Allen Weiss.
+
+!> @file
+!> @brief File for @ref fms_diag_dlinked_list_mod
+!> @addtogroup fms_diag_dlinked_list_mod
+!> @{
+MODULE fms_diag_dlinked_list_mod
+ USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE
+ implicit none
+ !!TODO: COnsider setting the access (public,private) to functions, etc.
+ !> The doubly-linked list node type.
+ type, public:: FmsDlListNode_t
+ private
+ class(*), pointer :: data => null() !< The data pointed to by the node.
+ type(FmsDlListNode_t), pointer :: next => null() !< A pointer to the previous node.
+ type(FmsDlListNode_t), pointer :: prev => null() !< A pointer to the next node.
+ end type FmsDlListNode_t
+
+ !> Linked list iterator
+ type, public :: FmsDllIterator_t
+ private
+ type(FmsDlListNode_t), pointer :: current !< A pointer to the current node.
+ type(FmsDlListNode_t), pointer :: end !< A sentinel (non-data) node.
+ contains
+ procedure :: has_data => literator_has_data !< Function returns true is there is data in the iterator.
+ procedure :: next => literator_next !< Function moves the iterator to the next data element.
+ procedure :: get => literator_data !< Function return a pointer to the current data.
+ procedure :: get_current_node_pointer => get_current_node_ptr !< Return the current node pointer.
+ end type FmsDllIterator_t
+
+ !> The doubly-linked list type. Besides the member functions, see the
+ !! associated iterator class ( FmsDllIterator_t) for traversal, and note that
+ !! the default constructor is overriden with an interface of the same name.
+ type, public :: FmsDlList_t
+ private
+ type(FmsDlListNode_t), pointer :: head !< The sentinal (non-data) head node of the linked list. .
+ type(FmsDlListNode_t), pointer :: tail !< The sentinel (non-data) tail node of the linked list.
+ integer :: the_size !< The number of data elements in the linked list.
+ contains
+ procedure :: push_back => push_at_back
+ procedure :: pop_back => pop_at_back
+ procedure :: remove => remove_node
+ procedure :: get_literator => get_forward_literator
+ procedure :: size => get_size
+ procedure :: is_empty => is_size_zero
+ procedure :: clear => clear_all
+ final :: destructor
+ procedure :: insert => insert_data
+
+ end type FmsDlList_t
+
+ interface FmsDlListNode_t
+ module procedure :: node_constructor
+ end interface FmsDlListNode_t
+
+ interface FmsDlList_t
+ module procedure :: linked_list_constructor
+ end interface FmsDlList_t
+
+ interface FmsDllIterator_t
+ module procedure :: literator_constructor
+ end interface FmsDllIterator_t
+
+contains
+
+ !> @brief Insert data d in a new node to be placed in front of the
+ !! target node t_nd.
+ !! @return Returns an iterator that starts with the newly inserted node.
+ function insert_data( this, t_nd, d ) result(liter)
+ class(FmsDlList_t), intent(in out) :: this ! d
+ !! Insert nd into list so that list section [prev node <--> target node ] looks like
+ !! [prev node <--> new nd <--> target node]. The four pointers pointing to and/or
+ !! from "new nd" need to be set. Therefore :
+ !! a) The new nd's prev needs to be whatever was the targets prev:
+ nd%prev => t_nd%prev
+ !! b) New node nd's next is obviously the target node:
+ nd%next => t_nd
+ !! c) the next of the prev node needs to point to the new node nd:
+ t_nd%prev%next => nd
+ !! d) target node's prev needs to point to the new node :
+ t_nd%prev => nd
+ this%the_size = this%the_size + 1
+ liter = FmsDllIterator_t(nd, this%tail)
+ end function insert_data
+
+ !> @brief Remove Node nd from the linked tree.
+ !! @return Return the iterator that begins with the next node after nd, and ends with
+ !! the list end node. Returns the list iterator if the node cannot be removed.
+ function remove_node( this, nd ) result( litr)
+ class(FmsDlList_t), intent(in out) :: this ! nd%next
+ nd%next%prev => nd%prev
+ deallocate(nd)
+ this%the_size = this%the_size - 1
+ else
+ litr = this%get_literator()
+ endif
+ end function remove_node
+
+
+ !> @brief Remove the tail (last data node) of the list.
+ !! @return Returns an iterator to the remaining list.
+ function pop_at_back (this ) result( liter )
+ class(FmsDlList_t), intent(in out) :: this ! this%tail%prev
+ liter = this%remove( nd )
+ else
+ liter = this%get_literator()
+ endif
+ end function pop_at_back
+
+ !> @brief Push (insert) data at the end of the list
+ !> @return Returns an iterator that starts at the tail of the list.
+ function push_at_back( this, d ) result(litr)
+ class(FmsDlList_t), intent(in out) :: this ! @brief Constructor for the node_type
+ !! @return Returns a nully allocated node.
+ function node_constructor () result (nd)
+ type(FmsDlListNode_t), allocatable :: nd !< The allocated node.
+ allocate(nd)
+ nd%data => null()
+ nd%prev => null()
+ nd%next => null()
+ end function node_constructor
+
+ !> @brief Constructor for the linked list.
+ !! @return Returns a newly allocated linked list instance.
+ function linked_list_constructor () result (ll)
+ type(FmsDlList_t), allocatable :: ll !< The resultant linked list to be reutrned.
+ allocate(ll)
+ allocate(ll%head)
+ allocate(ll%tail)
+ !!print *, 'associated(ll%head) :' , associated(ll%head), &
+ !! ' associated(ll%head) :' , associated(ll%head)
+ ll%head%next => ll%tail
+ ll%tail%prev => ll%head
+ ll%the_size = 0
+ end function linked_list_constructor
+
+ !> @brief The list iterator constructor.
+ !! @return Returns a newly allocated list iterator.
+ function literator_constructor ( fnd, tnd ) result (litr)
+ type (FmsDlListNode_t), pointer :: fnd
+ !< The sentinal (non-data) "first node" of the iterator will be fnd
+ type (FmsDlListNode_t), pointer :: tnd
+ !< The sentinal (non-data) "last node" of the iterator will be tnd.
+ type (FmsDllIterator_t), allocatable :: litr !< The resultant linked list to be reutrned.
+ allocate(litr)
+ litr%current => fnd
+ litr%end => tnd
+ end function literator_constructor
+
+ !> @brief Getter for the size (the number of data elements) of the linked list.
+ !! @return Returns the size of the lined list.
+ function get_size (this) result (sz)
+ class(FmsDlList_t), intent(in out) :: this
+ ! @brief Determines if the size (number of data elements) of the list is zero.
+!! @return Returns true if there are zero (0) data elements in the list; false otherwise.
+ function is_size_zero (this) result (r)
+ class(FmsDlList_t), intent(in out) :: this
+ ! @brief Create and return a new forward iterator for the list.
+ !> @return Returns a forward iterator for the linked list.
+ function get_forward_literator(this) result (litr)
+ class(FmsDlList_t), intent(in) :: this ! @brief Determine if the iterator has data.
+ !> @return Returns true iff the iterator has data.
+ function literator_has_data( this ) result( r )
+ class(FmsDllIterator_t), intent(in) :: this
+ ! @brief Move the iterators current data node pointer to the next data node.
+ !! @return Returns a status of 0 if succesful, -1 otherwise.
+ function literator_next( this ) result( status )
+ class(FmsDllIterator_t), intent(in out ) :: this
+ integer :: status !< The returned status. Failure possible is if iterator does not have data.
+ status = -1
+ if(this%has_data() .eqv. .true.) then
+ this%current => this%current%next
+ status = 0
+ endif
+ end function literator_next
+
+ !> @brief Get the current data object pointed to by the iterator.
+ !! function does not allocate or assign the result if
+ !! the user mistakenly called it without data present.
+ !! @return Returns a pointer to the current data.
+ function literator_data( this ) result( rd )
+ class(FmsDllIterator_t), intent(in) :: this ! null()
+ if (this%has_data() .eqv. .true.) then
+ rd => this%current%data
+ endif
+ end function literator_data
+
+!> @brief Get the current data object pointed to by the iterator.
+ !! function does not allocate or assign the result if
+ !! the user mistakenly called it without data present.
+ !! @return Returns a pointer to the current data.
+ function get_current_node_ptr( this ) result( pn )
+ class(FmsDllIterator_t), intent(in) :: this ! this%current
+ end function get_current_node_ptr
+
+ !> @brief Iterate over all the nodes, remove them and deallocate the client data
+ !! that the node was holding.
+ subroutine clear_all( this )
+ class(FmsDlList_t), intent(inout) :: this ! this%head%next
+ iter = this%remove(nd)
+ pdata => iter%get()
+ if (associated(pdata) .eqv. .false.) then
+ call error_mesg ('doubly_linked_list:clear_all', &
+ 'linked list destructor containes unassociated data pointer', &
+ WARNING)
+ else
+ deallocate(pdata)
+ endif
+ end do
+ end subroutine clear_all
+
+ !> @brief A destructor that deallocates every node and each nodes data element.
+ subroutine destructor(this)
+ type(FmsDlList_t) :: this ! @}
+! close documentation grouping
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 5ded82e22d..6172f93e31 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -4,12 +4,13 @@ module fms_diag_object_mod
!! \brief Contains routines for the diag_objects
!!
!! \description The diag_manager passes an object back and forth between the diag routines and the users.
-!! The procedures of this object and the types are all in this module. The fms_dag_object is a type
+!! The procedures of this object and the types are all in this module. The fms_dag_object is a type
!! that contains all of the information of the variable. It is extended by a type that holds the
!! appropriate buffer for the data for manipulation.
use diag_data_mod, only: diag_null
use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id
+
use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type
@@ -60,7 +61,7 @@ module fms_diag_object_mod
type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table
type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table
integer, allocatable, private :: diag_id !< unique id for varable
- class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the
+ class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the
!! file objects for this variable
character(len=:), allocatable, dimension(:) :: metadata !< metedata for the variable
logical, private :: static !< true is this is a static var
@@ -69,12 +70,12 @@ module fms_diag_object_mod
logical, allocatable, private :: local !< If the output is local
TYPE(time_type), private :: init_time !< The initial time
integer, allocatable, private :: vartype !< the type of varaible
- character(len=:), allocatable, private :: varname !< the name of the variable
- character(len=:), allocatable, private :: longname !< longname of the variable
- character(len=:), allocatable, private :: standname !< standard name of the variable
+ character(len=:), allocatable, private :: varname !< the name of the variable
+ character(len=:), allocatable, private :: longname !< longname of the variable
+ character(len=:), allocatable, private :: standname !< standard name of the variable
character(len=:), allocatable, private :: units !< the units
character(len=:), allocatable, private :: modname !< the module
- character(len=:), allocatable, private :: realm !< String to set as the value
+ character(len=:), allocatable, private :: realm !< String to set as the value
!! to the modeling_realm attribute
character(len=:), allocatable, private :: err_msg !< An error message
character(len=:), allocatable, private :: interp_method !< The interp method to be used
@@ -105,7 +106,7 @@ module fms_diag_object_mod
procedure :: get_id => fms_diag_get_id
procedure :: id => fms_diag_get_id
procedure :: copy => copy_diag_obj
- procedure :: register => fms_register_diag_field_obj
+ procedure :: register => fms_register_diag_field_obj !! Merely initialize fields.
procedure :: setID => set_diag_id
procedure :: is_registered => diag_ob_registered
procedure :: set_type => set_vartype
@@ -201,7 +202,7 @@ subroutine diag_obj_init(ob)
end select
end subroutine diag_obj_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!> \description Fills in and allocates (when necessary) the values in the diagnostic object
+!> \Description Fills in and allocates (when necessary) the values in the diagnostic object
subroutine fms_register_diag_field_obj &
!(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
(dobj, modname, varname, axes, init_time, &
@@ -239,11 +240,14 @@ subroutine fms_register_diag_field_obj &
! TO DO:
! dobj%diag_field = get_diag_table_field(trim(varname))
! dobj%diag_field = diag_yaml%get_diag_field(
+ !! TODO : Discuss design. Is this a premature return that somehow should
+ !! indicate a warning or failure to the calling function and/or the log files?
! if (is_field_type_null(dobj%diag_field)) then
! dobj%diag_id = diag_not_found
! dobj%vartype = diag_null
! return
! endif
+
!> get the optional arguments if included and the diagnostic is in the diag table
if (present(longname)) then
allocate(character(len=len(longname)) :: dobj%longname)
@@ -252,7 +256,7 @@ subroutine fms_register_diag_field_obj &
if (present(standname)) then
allocate(character(len=len(standname)) :: dobj%standname)
dobj%standname = trim(standname)
- endif
+ endif
if (present(units)) then
allocate(character(len=len(units)) :: dobj%units)
dobj%units = trim(units)
@@ -276,7 +280,7 @@ subroutine fms_register_diag_field_obj &
"The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",&
FATAL)
end select
- else
+ else
dobj%missing_value = DIAG_NULL
endif
@@ -284,6 +288,8 @@ subroutine fms_register_diag_field_obj &
! write(6,*)"IKIND for "//trim(varname)//" is ",dobj%diag_field%ikind
!> Set the registered flag to true
dobj%registered = .true.
+ ! save it in the diag object container.
+
end subroutine fms_register_diag_field_obj
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \brief Sets the diag_id. This can only be done if a variable is unregistered
@@ -316,7 +322,7 @@ subroutine set_vartype(objin , var)
class default
objin%vartype = null_type_int
call mpp_error("set_vartype", "The variable"//objin%varname//" is not a supported type "// &
- " r8, r4, i8, i4, or string.", warning)
+ " r8, r4, i8, i4, or string.", warning)
end select
end subroutine set_vartype
!> \brief Prints to the screen what type the diag variable is
@@ -354,7 +360,7 @@ end subroutine what_is_vartype
!!MZ Is this a TODO. Many problems:
!> \brief Registers the object
subroutine diag_ob_registered(objin , reg)
- class (fms_diag_object) , intent(inout):: objin
+ class (fms_diag_object) , intent(inout):: objin
logical , intent(in) :: reg !< If registering, this is true
objin%registered = reg
end subroutine diag_ob_registered
@@ -374,11 +380,11 @@ subroutine copy_diag_obj(objin , objout)
! type (diag_fields_type) :: diag_field !< info from diag_table
! type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table
- objout%diag_id = objin%diag_id
+ objout%diag_id = objin%diag_id
! class (fms_io_obj), allocatable, dimension(:) :: fms_fileobj !< fileobjs
if (allocated(objin%metadata)) objout%metadata = objin%metadata
- objout%static = objin%static
+ objout%static = objin%static
if (allocated(objin%frequency)) objout%frequency = objin%frequency
if (allocated(objin%varname)) objout%varname = objin%varname
end select
@@ -388,7 +394,7 @@ end subroutine copy_diag_obj
integer function fms_diag_get_id (dobj) result(diag_id)
class(fms_diag_object) , intent(inout) :: dobj
! character(*) , intent(in) :: varname
-!> Check if the diag_object registration has been done
+!> Check if the diag_object registration has been done
if (allocated(dobj%registered)) then
!> Return the diag_id if the variable has been registered
diag_id = dobj%diag_id
diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90
new file mode 100644
index 0000000000..3d61abb135
--- /dev/null
+++ b/diag_manager/fms_diag_object_container.F90
@@ -0,0 +1,261 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @defgroup fms_diag_object_container_mod fms_diag_object_container_mod
+!> @ingroup diag_manager
+!> @brief fms_diag_object_container_mod defines a container class and iterator class
+!! for inserting, removing and searching for fms_diag_object instances
+!!
+!> @author Miguel Zuniga
+!!
+!! fms_diag_object_container_mod defines a container for inserting, removing and
+!! searching for fms_diag_object instances. It also defined an iterator for
+!! the data in the container. The value returned by the fms_diag_object function get_id()
+!! is used for search key comparison.
+!!
+!! Most of the functions in class FmsDiagObjectContainer_t are simple wrappers over
+!! those of the underlying fms_doubly_linked_list_mod class. The find/search
+!! are a little more than that, and what FmsDiagObjectContainer_t provides over the
+!! underlying liked list is the search function, type checking, convenience, and a
+!! fixed user interface defined for the intended use.
+!!
+!> @file
+!> @brief File for @ref fms_diag_object_container_mod
+!> @addtogroup fms_diag_object_container_mod
+!> @{
+MODULE fms_diag_object_container_mod
+ use fms_diag_object_mod, only: fms_diag_object
+ USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE
+
+ !! Since this version is based on the FDS linked list:
+ use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t, FmsDlListNode_t
+
+ implicit none
+
+ !> @brief A container of fms_diag_object instances providing insert, remove ,
+ !! find/search, and size public member functions. Iterator is provided by
+ !! the associated iterator class (see dig_obj_iterator class).
+ !!
+ !! This version does not enforce uniqueness of ID keys (I.e. it is not a set).
+ !!
+ type, public:: FmsDiagObjectContainer_t
+ private
+ TYPE (FmsDlList_t), ALLOCATABLE :: the_linked_list !< This version based on the FDS linked_list.
+ contains
+ procedure :: insert => insert_diag_object
+ procedure :: remove => remove_diag_object
+ procedure :: find => find_diag_object
+ procedure :: size => get_num_objects
+ procedure :: iterator => get_iterator
+ final :: destructor
+ end type FmsDiagObjectContainer_t
+
+
+ !> @brief Iterator used to traverse the objects of the container.
+ type, public :: FmsDiagObjIterator_t
+ private
+ type(FmsDllIterator_t) :: liter !< This version based on the FDS linked_list (and its iterator).
+ contains
+ procedure :: has_data => literator_has_data
+ procedure :: next => literator_next
+ procedure :: get => literator_data
+ end type FmsDiagObjIterator_t
+
+ interface FmsDiagObjectContainer_t
+ module procedure :: diag_object_container_constructor
+ end interface FmsDiagObjectContainer_t
+
+ interface FmsDiagObjIterator_t
+ module procedure :: diag_obj_iterator_constructor
+ end interface FmsDiagObjIterator_t
+
+
+contains
+
+ !> @brief Returns an empty iterator if a diag object with this ID was not found.
+ !! If the diag object was found, return an iterator with the current object being
+ !! the found object, ad the last/anchor being the last/anchor of the container.
+ !! Note that this routine can accept an optional iterator as input, which
+ !! is useful for chaining searches, which may be needed if there are key duplicates.
+ !! @return In iterator that starts from the inserted object.
+ function find_diag_object (this, id , iiter) result (riter)
+ class (FmsDiagObjectContainer_t), intent (in out) :: this
+ ! riter%get()
+ if(id == ptdo%get_id() ) then
+ EXIT
+ end if
+ status = riter%next()
+ end do
+ end function find_diag_object
+
+ !> @brief insert diagnostic object obj with given id.
+ !! Objects are inserted at the back / end of the list
+ !! This version of the container also enforces that the
+ !! objects ID is equal the input id.
+ !! @return A status of -1 if there was an error, and 0 otherwise.
+ function insert_diag_object (this, id, obj) result (status)
+ class (FmsDiagObjectContainer_t), intent (in out) :: this
+ integer, intent (in) :: id !< The id of the object to insert.
+ class(fms_diag_object) , intent (in out) :: obj !< The object to insert
+ integer :: status !< The returned status. 0 for success.
+ class(FmsDllIterator_t), allocatable :: tliter !< A temporary iterator.
+
+ status = -1
+ if ( id .ne. obj%get_id() ) then
+ !!TODO: log error
+ endif
+ tliter = this%the_linked_list%push_back( obj )
+ if(tliter%has_data() .eqv. .true. ) then
+ status = 0
+ endif
+ end function
+
+ !> @brief Remove and return the first object in the container with the corresponding id .
+ !! Note that if the client code does not already have a reference to the object being
+ !! removed, then the client may want to to use procedure find before using procedure remove.
+ !! If procedure find is used, consider calling remove with the iterator returned from find.
+ !! @return In iterator starting from the node that was following the removed node.
+ function remove_diag_object (this, id, iiter ) result (riter)
+ class (FmsDiagObjectContainer_t), intent (in out) :: this
+ ! riter%liter%get_current_node_pointer()
+ temp_liter = this%the_linked_list%remove( pn )
+ riter = FmsDiagObjIterator_t(temp_liter)
+ end function
+
+ !> @brief Getter for the number of objects help in the container.
+ !! @return Return the number of objects..
+ function get_num_objects (this ) result (sz)
+ class (FmsDiagObjectContainer_t), intent (in out) :: this
+ !< The instance of the class that this function is bound to.
+ integer :: sz !< The returned result - the number of objects in container.
+ sz = this%the_linked_list%size()
+ end function
+
+
+ !> @brief Return an iterator for the objects in the container.
+ !! @return An iterator for the objects in the container.
+ function get_iterator (this) result (oliter)
+ class (FmsDiagObjectContainer_t), intent (in) :: this
+ ! @brief A consructor for a container's iterator.
+ !! @return An for a container's iterator.
+ function diag_obj_iterator_constructor( iliter ) result (diag_itr)
+ class (FmsDllIterator_t), allocatable :: iliter
+ !< An iterator. Normally the one that the container is based on.
+ class (FmsDiagObjIterator_t), allocatable :: diag_itr !< The returned diag object iterator.
+ allocate(diag_itr)
+ diag_itr%liter = iliter;
+ end function diag_obj_iterator_constructor
+
+ !> @brief The default consructor for the container.
+ !! @return Returns a container.
+ function diag_object_container_constructor () result (doc)
+ type(FmsDiagObjectContainer_t), allocatable :: doc !< The resultant container.
+ allocate(doc)
+ doc%the_linked_list = FmsDlList_t()
+ !! print * , "In DOC constructor"
+ end function diag_object_container_constructor
+
+ !> @brief Determines if there is more data that can be accessed via the iterator.
+ !> @return Returns true iff more data can be accessed via the iterator.
+ function literator_has_data( this ) result( r )
+ class(FmsDiagObjIterator_t), intent(in) :: this
+ ! @brief Move the iterator to the next object.
+ !! @return Returns a status 0 if sucessful, or -1 if failed.
+ function literator_next( this ) result( status )
+ class(FmsDiagObjIterator_t), intent(in out ) :: this
+ ! @brief Get the current data the iterator is pointing to.
+ !! Note the common use case is to call function has_data to decide if
+ !! this function should be called (again).
+ !! @return Returns a pointer to the current data.
+ function literator_data( this ) result( rdo )
+ class(FmsDiagObjIterator_t), intent(in) :: this
+ ! null()
+ gp => this%liter%get()
+ select type(gp)
+ type is (fms_diag_object) !! "type is", not the (polymorphic) "class is"
+ rdo => gp
+ class default
+ CALL error_mesg ('diag_object_container:literator_data', &
+ 'Data to be accessed via iterator is not of expected type.',FATAL)
+ end select
+ end function literator_data
+
+ !> @brief The destructor for the container.
+ subroutine destructor(this)
+ type(FmsDiagObjectContainer_t) :: this
+ ! @}
+! close documentation grouping
+
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index f5e646cd27..90be4d0d05 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -28,12 +28,15 @@ AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager/include -I$(
LDADD = $(top_builddir)/libFMS/libFMS.la
# Build this test program.
-check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_update_buffer
+check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_object_container \
+ test_diag_update_buffer test_diag_dlinked_list
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
test_diag_manager_time_SOURCES = test_diag_manager_time.F90
test_diag_update_buffer_SOURCES= test_diag_update_buffer.F90
+test_diag_object_container_SOURCES = test_diag_object_container.F90
+test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
diff --git a/test_fms/diag_manager/test_diag_dlinked_list.F90 b/test_fms/diag_manager/test_diag_dlinked_list.F90
new file mode 100644
index 0000000000..69fcdd3e90
--- /dev/null
+++ b/test_fms/diag_manager/test_diag_dlinked_list.F90
@@ -0,0 +1,238 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!! fms_diag_dlinked_list_mod defines a generic doubly linked
+!! list class and an associated iterator class for traversing the list. It
+!! is generic in the sense that the elements or objects it contains are
+!! "class(*)" objects. Note the public interface functions and the lack
+!! of a search (or find) function as per the definition of a linked list.
+!! If a search function, additional type cheeking, or possibly a
+!! slightly different user interface is desired, then consider creating
+!! another iterator and another wrapper, or another class with this one for
+!! a member element and procedures that are trivially implemented by using
+!! this class. (See, for example, class FmsDiagObjectContainer_t and its
+!! associated iterator.
+!!
+!! This version is roughly a Fortran translation of the C++ doubly linked list
+!! class in the book ``Data Structures And Algorithm Analysis in C++",
+!! 3rd Edition, by Mark Allen Weiss.
+program test_diag_dlinked_list
+ use mpp_mod, only: mpp_init, mpp_exit, mpp_error, FATAL, WARNING
+ use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated
+ use mpp_io_mod, only: mpp_io_init
+
+ use fms_diag_object_mod, only : fms_diag_object
+ use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t
+
+ implicit none
+
+ !> @brief This class is the type for the data to insert in the linked list.
+ type TestDummy_t
+ integer :: id = 0
+ character(len=20) :: name
+ end type TestDummy_t
+
+ !!
+ type (FmsDlList_t), allocatable :: list !< Instance of the linked list
+ class(FmsDllIterator_t), allocatable :: iter !< An iterator for the list
+ type (TestDummy_t), pointer:: p_td_obj !< A pointer to a test_dummy object
+ class(*), pointer :: p_obj !< A pointer to a class(*) object
+ integer, parameter :: num_objs = 40 !< Total number of objects tested
+ integer :: full_id_sum !< Sum of all the possible object id values
+ integer :: sum !< Temp sum of vaalues of id sets
+ !!
+ integer :: ierr !< An error flag
+ logical :: test_passed !< Flag indicating if the test_passed
+ !! These fields below used to initialize diag object data. TBD
+ integer :: id
+ character(:), allocatable :: mname, mname_pre
+ !!
+
+
+ test_passed = .true. !! will be set to false if there are any issues.
+
+ call mpp_init(mpp_init_test_requests_allocated)
+ call mpp_io_init()
+ call mpp_set_stack_size(145746)
+
+ !! Ids will initially be from 1 to num_objs, so :
+ full_id_sum = (num_objs * (num_objs + 1)) / 2
+
+ !!Create the list
+ list = FmsDlList_t()
+
+ if( list%size() /= 0) then
+ test_passed = .false.
+ call mpp_error(FATAL, "list incorrect size. Expected 0 at start")
+ endif
+ mname_pre = "ATM"
+
+ !! Initialize num_objs objects and insert into list one at a time.
+ !! The loop iterator is same as id - created in order to facilitate
+ !! some tests.
+ do id = 1, num_objs
+ !!Allocate on heap another test dummy object :
+ allocate (p_td_obj)
+ !! And set some of its dummy data :
+ call combine_str_int(mname_pre, id, mname)
+ p_td_obj%id = id
+ p_td_obj%name = mname
+ !! And have the "Char(*) pointer also point to it:
+ p_obj => p_td_obj
+
+ !! Test insertion the common way :
+ iter = list%push_back( p_obj)
+ if(iter%has_data() .eqv. .false. ) then
+ test_passed = .false.
+ call mpp_error(FATAL, "List push_back error.")
+ endif
+
+ enddo
+
+ if( list%size() /= num_objs) then
+ test_passed = .false.
+ call mpp_error(FATAL, "List has incorrect size after inserts.")
+ endif
+
+
+ !! Test iteration over the entire list :
+ sum = 0
+ sum = sum_ids_in_list ( list )
+
+ if( sum /= full_id_sum) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected")
+ endif
+
+ if( list%size() /= num_objs) then
+ test_passed = .false.
+ call mpp_error(FATAL, "The list size is not as expected post inserts.")
+ endif
+
+ !! Test a removal from the back (id should be num_objs)
+ p_obj => find_back_of_list( list)
+ iter = list%pop_back()
+ !! Note the client is resposible for managing memory of anything he explicitly
+ !! removes from the list:
+ deallocate(p_obj)
+ sum = sum_ids_in_list ( list )
+ if( sum /= full_id_sum - num_objs ) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected")
+ endif
+
+ !! Repeat - test removal from the back of list (should be (num_objs -1)).
+ p_obj => find_back_of_list( list)
+ iter = list%pop_back()
+ !! Note the client is resposible for managing memory of anything he explicitly
+ !! removes from the list:
+ deallocate(p_obj)
+ sum = sum_ids_in_list ( list )
+ if( sum /= (full_id_sum - num_objs - (num_objs -1) )) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected")
+ endif
+
+ call list%clear()
+ if( list%size() /= 0) then
+ test_passed = .false.
+ call mpp_error(FATAL, "List is incorrect size after clearing.")
+ endif
+
+ write (6,*) "Finishing diag_dlinked_list tests."
+
+ !! the list has a finalize/destructor which will deallocate data that is still it list.
+ !! equivalent to calling list%clear() as above.
+ deallocate(list)
+
+ call MPI_finalize(ierr)
+
+CONTAINS
+
+
+
+ !> @brief Cast the "class(*) input data to the expected type.
+ function get_typed_data( data_in ) result( rdo )
+ class(*), intent(in), pointer :: data_in !< An input pointer to the class(*) object.
+ class(TestDummy_t), pointer :: rdo !< The resultant pointer to the expected underlying object type.
+ rdo => null()
+
+ select type(data_in)
+ type is (TestDummy_t) !! "type is", not the (polymorphic) "class is"
+ rdo => data_in
+ class default
+ call mpp_error(FATAL, "Data to access is not of expected type.",FATAL)
+ end select
+ end function get_typed_data
+
+ !> Calcualte the sum of the ids.
+ !! Exercises iteration over the list.
+ function sum_ids_in_list (list) result (rsum)
+ type (FmsDlList_t), allocatable :: list !< The linked list instance
+ integer :: rsum !< The resultant sum of ids
+ class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list
+ type (TestDummy_t), pointer:: p_td_obj !< A pointer to a test_dummy object
+ class(*), pointer :: p_obj !< A pointer to a class(*) object
+ integer :: ic_status !< A list insertion status.
+ !!
+ rsum = 0
+ iter = list%get_literator()
+ do while( iter%has_data() .eqv. .true.)
+ p_obj => iter%get()
+ p_td_obj => get_typed_data (p_obj )
+ id = p_td_obj%id
+ rsum = rsum + id
+ ic_status = iter%next()
+ end do
+ end function sum_ids_in_list
+
+ !> Calcualate the sum of the ids. This also is a kind of search function,
+ !! so if the provided wrapper is not used, you have to write your own.
+ !! @return a pointer the object at the end of the list, or null if none
+ function find_back_of_list (list) result (p_rdo)
+ type (FmsDlList_t), allocatable :: list !< The linked list instance
+ class(TestDummy_t), pointer :: p_rdo !< The resultant back of list,
+ class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list
+ class(*), pointer :: p_obj !< A pointer to a class(*) object
+ integer :: ic_status !< A list insertion status.
+ !!
+ p_rdo => null()
+ iter = list%get_literator()
+ do while( iter%has_data() .eqv. .true.)
+ p_obj => iter%get()
+ p_rdo => get_typed_data (p_obj )
+ ic_status = iter%next()
+ end do
+ end function find_back_of_list
+
+ subroutine combine_str_int (str, num, rs)
+ character(:), allocatable, intent (in):: str
+ integer , intent (in) :: num
+ character(:), allocatable, intent (out) :: rs
+ character(len_trim(str) + 8) :: tmp
+
+ write (tmp, "(A4,I4)") str,num
+ tmp = trim(tmp)
+ rs = tmp
+ end subroutine combine_str_int
+
+
+end program test_diag_dlinked_list
+
+
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index a625db4d1e..9e9892a2e9 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -485,6 +485,7 @@ test_expect_success "wildcard filenames (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager_time
'
+
rm -f input.nml diag_table
touch input.nml
@@ -507,4 +508,5 @@ my_test_count=26
test_expect_success "Test the diag update_buffer (test $my_test_count)" '
mpirun -n 1 ../test_diag_update_buffer
'
- test_done
+
+test_done
diff --git a/test_fms/diag_manager/test_diag_object_container.F90 b/test_fms/diag_manager/test_diag_object_container.F90
new file mode 100644
index 0000000000..1d02023ce8
--- /dev/null
+++ b/test_fms/diag_manager/test_diag_object_container.F90
@@ -0,0 +1,237 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This programs tests public member functions of the
+!! FmsDiagObjectContainer_t and FmsDiagObjIterator_t. As these two classes
+!! are largely wrappers to their underlying classes, it is also
+!! testing the underlying container and iterator classes. The container
+!! functions being tested are insert, remove, and size. The use of the iterators
+!! is also being tested.
+program test_diag_obj_container
+ use mpp_mod, only: mpp_init, mpp_exit, mpp_error, FATAL, WARNING
+ use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated
+ use mpp_io_mod, only: mpp_io_init
+
+ use fms_diag_object_mod, only : fms_diag_object
+ use fms_diag_object_container_mod, only : FmsDiagObjectContainer_t, FmsDiagObjIterator_t
+ USE time_manager_mod, ONLY: time_type
+
+ implicit none
+ !!
+ type (FmsDiagObjectContainer_t), allocatable :: container !< Instance of the container
+ class(FmsDiagObjIterator_t), allocatable :: iter !< An iterator for the container
+ type (fms_diag_object), allocatable , target :: obj_vec(:) !< A vector of objects
+ type (fms_diag_object), pointer:: pobj !< A pointer to an object
+ integer, parameter :: num_objs = 10 !< Total number of objects tested
+ integer :: full_id_sum !< Sum of all the possible object id values
+ integer :: sum !< Temp sum of vaalues of id sets
+ !!
+ integer :: ic_status !< A status flag returned from container functions
+ integer :: ierr !< An error flag
+ !!
+ logical :: test_passed !< Flag indicating if the test_passed
+ !! These fields below used to initialize diag object data. TBD
+ integer :: id
+ integer, dimension(2) :: axes
+ TYPE(time_type) :: init_time
+ !!type (diag_fields_type) :: diag_field
+ character(:), allocatable :: mname, vname, mname_pre, vname_pre
+ !!
+
+
+ test_passed = .true. !! will be set to false if there are any issues.
+
+ call mpp_init(mpp_init_test_requests_allocated)
+ call mpp_io_init()
+ call mpp_set_stack_size(145746)
+
+ !! Ids will initially be from 1 to num_objs, so :
+ full_id_sum = (num_objs * (num_objs + 1)) / 2
+
+ !!Create the container
+ container = FmsDiagObjectContainer_t()
+ !!In diag_manager, one module level container may be used instead of a local one like above.
+
+
+ !! Allocate some test objects.
+ !! NOTE: normally objects will be allocated one at a time with a stament like:
+ !! allocate(pobj, source = fms_diag_object(argument list ))
+ !! or via constructor like :
+ !! pobj => fms_diag_object(argument list )
+ !! Once the object ID is set, it should be inserted into the container and then the
+ !! container will be considered the manager of that object and its memory (unless the object is removed).
+ !! Since type fms_diag_obj doesn't have a proper constructor yet, well be lazy by making array of objects
+ !! ( normal fixed size array the thing whose use we are replacing to begin with ) and consider these particular
+ !! objects to not be managed by the container.
+ allocate(obj_vec(num_objs))
+
+ !! Initialize each object and isnert into container one at a time.
+
+ if( container%size() /= 0) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Container incorrect size. Expected 0 at start")
+ endif
+ mname_pre = "ATM"
+ vname_pre = "xvar"
+ do id = 1, num_objs
+ call combine_str_int(mname_pre, id, mname)
+ call combine_str_int(vname_pre, id, vname )
+
+ pobj => obj_vec( id ) !!Note use of pointer to obj.
+ call pobj%setID(id)
+
+ call pobj%register ("test_mod", vname, axes, init_time, "a_long_name")
+
+ !!Insert object into the container.
+ ic_status = container%insert(pobj%get_id(), pobj)
+ if(ic_status .ne. 0)then
+ test_passed = .false.
+ call mpp_error(FATAL, "Container Insertion error.")
+ endif
+ enddo
+
+ if( container%size() /= num_objs) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Container has incorrect size after inserts.")
+ endif
+
+ !!Search the container for a an object of specified key
+ iter = container%find(123)
+ if ( iter%has_data() .eqv. .true. ) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Found in container unexpected object of id=123")
+ endif
+
+ !!Again, search the container for a an object of specified key
+ iter = container%find(4)
+ if (iter%has_data() .neqv. .true. ) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Did not find expected container object of id=4")
+ endif
+
+ !! Iterate over all the objects in the container;
+ sum = 0
+ iter = container%iterator()
+ do while( iter%has_data() .eqv. .true.)
+ pobj => iter%get() !!Note use of pointer and pointer assignment is preferred.
+ id = pobj%get_id( )
+ !! vname = pobj%get_varname() !! print ...
+ sum = sum + id
+ ic_status = iter%next()
+ end do
+
+ if( sum /= full_id_sum) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Id sums via iteration over the container objects is not as expected")
+ endif
+
+ if( container%size() /= num_objs) then
+ test_passed = .false.
+ call mpp_error(FATAL, "The container size is not as expected post inserts.")
+ endif
+
+
+ !! Test a removal ****
+ iter = container%iterator()
+ iter = container%remove( 4, iter )
+ iter = container%find(4)
+ !! Verify the removal , part 1:
+ if ( iter%has_data() .eqv. .true.) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Found object of id = 4 after removing it")
+ endif
+ !! Verify the removal , part 2 :
+ if (container%size() /= (num_objs - 1)) then
+ test_passed = .false.
+ call mpp_error(FATAL,"The_container%size() \= num_obj -1 after a removal ")
+ endif
+
+ !! Verify the removal , part 3 :
+ !! Iterate over all the objects in the container AFTER the removal of id=4 object;
+ sum = 0
+ iter = container%iterator()
+ do while( iter%has_data() .eqv. .true.)
+ pobj => iter%get() !!Note use of pointer and pointer assignment is preferred.
+ id = pobj%get_id( )
+ !! vname = pobj%get_varname() !! print ...
+ sum = sum + id
+ ic_status = iter%next()
+ end do
+ if( sum /= full_id_sum - 4) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Container incorrect id sums post removal of 4")
+ endif
+ !! End test a removal ****
+
+ !! Test find and access object in the container
+ iter = container%find(7)
+ if (iter%has_data() .neqv. .true. ) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Container did not find object of id=7")
+ endif
+ !! Check the find results more :
+ pobj => iter%get()
+ if(pobj%get_id() /= 7) then
+ test_passed = .false.
+ call mpp_error(FATAL," Id of returned object was not 7 ")
+ endif
+ !!TODO further access tests.
+
+
+ !! Manually clear out the container.
+ !! NOTE: In normal use this is NOT PERFORMED since with its finalize function, the container
+ !! deallocates all pointers and data it manages. However, the client needs to take care of
+ !! the diag objects the client has decided that the container should not manage.
+ !! In this wierd test case, all the diag objects were originally from a vector (a container itself!)
+ !! and not allocated on the heap one at a time, so this step is needed before program completion.
+ do id = 1, num_objs
+ iter = container%find(id)
+ if ( iter%has_data() .eqv. .true.) then
+ iter = container%remove( id, iter )
+ endif
+ end do
+
+ if( container%size() /= 0) then
+ test_passed = .false.
+ call mpp_error(FATAL, "Container is incorrect size after clearing.")
+ endif
+
+ write (6,*) "Finishing diag_obj_container tests."
+
+ !! the container has a finalize/destructor which will
+deallocate(container)
+
+call MPI_finalize(ierr)
+
+CONTAINS
+
+subroutine combine_str_int (str, num, rs)
+ character(:), allocatable, intent (in):: str
+ integer , intent (in) :: num
+ character(:), allocatable, intent (out) :: rs
+ character(len_trim(str) + 8) :: tmp
+
+ write (tmp, "(A4,I4)") str,num
+ tmp = trim(tmp)
+ rs = tmp
+end subroutine combine_str_int
+
+end program test_diag_obj_container
+
+
From 2736b35c391254daa6dfcc7c955b2d47bad013cd Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Mon, 10 Jan 2022 09:53:41 -0500
Subject: [PATCH 026/168] fix: Changes fms_diag_object to fmsDiagObject_type
(#879)
---
diag_manager/diag_manager.F90 | 7 +-
diag_manager/fms_diag_object.F90 | 104 ++++++------------
diag_manager/fms_diag_object_container.F90 | 16 +--
.../diag_manager/test_diag_dlinked_list.F90 | 2 +-
.../test_diag_object_container.F90 | 6 +-
5 files changed, 46 insertions(+), 89 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 95f3b8643b..3d909b36da 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -236,13 +236,12 @@ MODULE diag_manager_mod
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
- USE fms_diag_object_mod, ONLY: fms_diag_object
+ USE fms_diag_object_mod, ONLY: fmsDiagObject_type
use fms_diag_object_container_mod, ONLY: FmsDiagObjectContainer_t
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end
#endif
- USE fms_diag_object_mod, ONLY: fms_diag_object, diag_object_placeholder
USE constants_mod, ONLY: SECONDS_PER_DAY
USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type
@@ -455,8 +454,8 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
CHARACTER(len=128) :: msg
TYPE(time_type) :: diag_file_init_time !< The intial time of the diag_file
INTEGER :: status_ic !< used to check the status of insert into container.
- CLASS(fms_diag_object), ALLOCATABLE , TARGET :: diag_obj !< the diag object that is (to be) registered
- TYPE(fms_diag_object), POINTER :: diag_obj_ptr => NULL() !< a pointer to the registered diag_object
+ CLASS(fmsDiagObject_type), ALLOCATABLE , TARGET :: diag_obj !< the diag object that is (to be) registered
+ TYPE(fmsDiagObject_type), POINTER :: diag_obj_ptr => NULL() !< a pointer to the registered diag_object
! get stdout unit number
stdout_unit = stdout()
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 6172f93e31..5e8a35c66d 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -57,7 +57,7 @@ module fms_diag_object_mod
!> \brief Object that holds all variable information
-type fms_diag_object
+type fmsDiagObject_type
type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table
type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table
integer, allocatable, private :: diag_id !< unique id for varable
@@ -98,10 +98,18 @@ module fms_diag_object_mod
real(kind=R4_KIND), allocatable,dimension(:) :: r4data_RANGE !< The range of r4 data
real(kind=R8_KIND), allocatable,dimension(:) :: r8data_RANGE !< The range of r8 data
type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object
+!> \brief Extends the variable object to work with multiple types of data
+ class(*), allocatable :: vardata0
+ class(*), allocatable, dimension(:) :: vardata1
+ class(*), allocatable, dimension(:,:) :: vardata2
+ class(*), allocatable, dimension(:,:,:) :: vardata3
+ class(*), allocatable, dimension(:,:,:,:) :: vardata4
+ class(*), allocatable, dimension(:,:,:,:,:) :: vardata5
+
+
contains
! procedure :: send_data => fms_send_data !!TODO
-<<<<<<< HEAD
procedure :: init_ob => diag_obj_init
procedure :: get_id => fms_diag_get_id
procedure :: id => fms_diag_get_id
@@ -111,65 +119,24 @@ module fms_diag_object_mod
procedure :: is_registered => diag_ob_registered
procedure :: set_type => set_vartype
procedure :: vartype_inq => what_is_vartype
-=======
- procedure,public :: init_ob => diag_obj_init
- procedure,public :: diag_id_inq => fms_diag_id_inq
- procedure,public :: copy => copy_diag_obj
- procedure,public :: register => fms_register_diag_field_obj
- procedure,public :: setID => set_diag_id
- procedure,public :: is_registered => diag_ob_registered
- procedure,public :: set_type => set_vartype
- procedure,public :: vartype_inq => what_is_vartype
->>>>>>> 9c9a406d (Adds all variables to diag object that are registered.)
procedure,public :: is_static => diag_obj_is_static
procedure,public :: is_registeredB => diag_obj_is_registered
procedure,public :: get_vartype => diag_obj_get_vartype
procedure,public :: get_varname => diag_obj_get_varname
-end type fms_diag_object
-!> \brief Extends the variable object to work with multiple types of data
-type, extends(fms_diag_object) :: fms_diag_object_scalar
- class(*), allocatable :: vardata
-end type fms_diag_object_scalar
-type, extends(fms_diag_object) :: fms_diag_object_1d
- class(*), allocatable, dimension(:) :: vardata
-end type fms_diag_object_1d
-type, extends(fms_diag_object) :: fms_diag_object_2d
- class(*), allocatable, dimension(:,:) :: vardata
-end type fms_diag_object_2d
-type, extends(fms_diag_object) :: fms_diag_object_3d
- class(*), allocatable, dimension(:,:,:) :: vardata
-end type fms_diag_object_3d
-type, extends(fms_diag_object) :: fms_diag_object_4d
- class(*), allocatable, dimension(:,:,:,:) :: vardata
-end type fms_diag_object_4d
-type, extends(fms_diag_object) :: fms_diag_object_5d
- class(*), allocatable, dimension(:,:,:,:,:) :: vardata
-end type fms_diag_object_5d
+end type fmsDiagObject_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-type(fms_diag_object) :: null_ob
-type(fms_diag_object_scalar) :: null_sc
-type(fms_diag_object_1d) :: null_1d
-type(fms_diag_object_2d) :: null_2d
-type(fms_diag_object_3d) :: null_3d
-type(fms_diag_object_4d) :: null_4d
-type(fms_diag_object_5d) :: null_5d
+type(fmsDiagObject_type) :: null_ob
integer,private :: MAX_LEN_VARNAME
integer,private :: MAX_LEN_META
-type(fms_diag_object_3d) :: diag_object_placeholder (10)
+!type(fmsDiagObject_type) :: diag_object_placeholder (10)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-public :: fms_diag_object, fms_diag_object_scalar, fms_diag_object_1d
-public :: fms_diag_object_2d, fms_diag_object_3d, fms_diag_object_4d, fms_diag_object_5d
-<<<<<<< HEAD
public :: copy_diag_obj, fms_diag_get_id
-=======
-public :: copy_diag_obj, fms_diag_id_inq
-public :: operator (>),operator (<),operator (>=),operator (<=),operator (.ne.)!operator (==),operator (.ne.)
->>>>>>> 9c9a406d (Adds all variables to diag object that are registered.)
-public :: null_sc, null_1d, null_2d, null_3d, null_4d, null_5d
+public :: fmsDiagObject_type
+public :: null_ob
public :: fms_diag_object_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -184,19 +151,13 @@ subroutine fms_diag_object_init (mlv,mlm)
MAX_LEN_META = mlm
!> Initialize the null_d variables
null_ob%diag_id = DIAG_NULL
- null_sc%diag_id = DIAG_NULL
- null_1d%diag_id = DIAG_NULL
- null_2d%diag_id = DIAG_NULL
- null_3d%diag_id = DIAG_NULL
- null_4d%diag_id = DIAG_NULL
- null_5d%diag_id = DIAG_NULL
end subroutine fms_diag_object_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \Description Sets the diag_id to the not registered value.
subroutine diag_obj_init(ob)
- class (fms_diag_object) , intent(inout) :: ob
+ class (fmsDiagObject_type) , intent(inout) :: ob
select type (ob)
- class is (fms_diag_object)
+ class is (fmsDiagObject_type)
ob%diag_id = diag_not_registered !null_ob%diag_id
ob%registered = .false.
end select
@@ -208,7 +169,7 @@ subroutine fms_register_diag_field_obj &
(dobj, modname, varname, axes, init_time, &
longname, units, missing_value, varRange, mask_variant, standname, &
do_not_log, err_msg, interp_method, tile_count, area, volume, realm, metadata)
- class(fms_diag_object) , intent(inout) :: dobj
+ class(fmsDiagObject_type) , intent(inout) :: dobj
CHARACTER(len=*), INTENT(in) :: modname !< The module name
CHARACTER(len=*), INTENT(in) :: varname !< The variable name
INTEGER, INTENT(in) :: axes(:) !< The axes indicies
@@ -294,7 +255,7 @@ end subroutine fms_register_diag_field_obj
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \brief Sets the diag_id. This can only be done if a variable is unregistered
subroutine set_diag_id(objin , id)
- class (fms_diag_object) , intent(inout):: objin
+ class (fmsDiagObject_type) , intent(inout):: objin
integer :: id
if (allocated(objin%registered)) then
if (objin%registered) then
@@ -306,7 +267,7 @@ subroutine set_diag_id(objin , id)
end subroutine set_diag_id
!> \brief Find the type of the variable and store it in the object
subroutine set_vartype(objin , var)
- class (fms_diag_object) , intent(inout):: objin
+ class (fmsDiagObject_type) , intent(inout):: objin
class(*) :: var
select type (var)
type is (real(kind=8))
@@ -327,7 +288,7 @@ subroutine set_vartype(objin , var)
end subroutine set_vartype
!> \brief Prints to the screen what type the diag variable is
subroutine what_is_vartype(objin)
- class (fms_diag_object) , intent(inout):: objin
+ class (fmsDiagObject_type) , intent(inout):: objin
if (.not. allocated(objin%vartype)) then
call mpp_error("what_is_vartype", "The variable type has not been set prior to this call", warning)
return
@@ -360,17 +321,17 @@ end subroutine what_is_vartype
!!MZ Is this a TODO. Many problems:
!> \brief Registers the object
subroutine diag_ob_registered(objin , reg)
- class (fms_diag_object) , intent(inout):: objin
+ class (fmsDiagObject_type) , intent(inout):: objin
logical , intent(in) :: reg !< If registering, this is true
objin%registered = reg
end subroutine diag_ob_registered
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \brief Copies the calling object into the object that is the argument of the subroutine
subroutine copy_diag_obj(objin , objout)
- class (fms_diag_object) , intent(in) :: objin
- class (fms_diag_object) , intent(inout) , allocatable :: objout !< The destination of the copy
+ class (fmsDiagObject_type) , intent(in) :: objin
+ class (fmsDiagObject_type) , intent(inout) , allocatable :: objout !< The destination of the copy
select type (objout)
- class is (fms_diag_object)
+ class is (fmsDiagObject_type)
if (allocated(objin%registered)) then
objout%registered = objin%registered
@@ -392,7 +353,7 @@ end subroutine copy_diag_obj
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \brief Returns the ID integer for a variable
integer function fms_diag_get_id (dobj) result(diag_id)
- class(fms_diag_object) , intent(inout) :: dobj
+ class(fmsDiagObject_type) , intent(inout) :: dobj
! character(*) , intent(in) :: varname
!> Check if the diag_object registration has been done
if (allocated(dobj%registered)) then
@@ -410,7 +371,7 @@ end function fms_diag_get_id
!> A questionmark "?" is set in place of the variable that is not yet allocated
!>TODO: Add diag_id ?
function fms_diag_obj_as_string_basic(dobj) result(rslt)
- class(fms_diag_object), allocatable, intent(in) :: dobj
+ class(fmsDiagObject_type), allocatable, intent(in) :: dobj
character(:), allocatable :: rslt
character (len=:), allocatable :: registered, vartype, varname, diag_id
if ( .not. allocated (dobj)) then
@@ -452,31 +413,29 @@ end function fms_diag_obj_as_string_basic
function diag_obj_is_registered (obj) result (rslt)
- class(fms_diag_object), intent(in) :: obj
+ class(fmsDiagObject_type), intent(in) :: obj
logical :: rslt
rslt = obj%registered
end function diag_obj_is_registered
function diag_obj_is_static (obj) result (rslt)
- class(fms_diag_object), intent(in) :: obj
+ class(fmsDiagObject_type), intent(in) :: obj
logical :: rslt
rslt = obj%static
end function diag_obj_is_static
function diag_obj_get_vartype (obj) result (rslt)
- class(fms_diag_object), intent(in) :: obj
+ class(fmsDiagObject_type), intent(in) :: obj
integer :: rslt
rslt = obj%vartype
end function diag_obj_get_vartype
function diag_obj_get_varname(obj) result (rslt)
- class(fms_diag_object), intent(in) :: obj
+ class(fmsDiagObject_type), intent(in) :: obj
character(len=len(obj%varname)) :: rslt
rslt = obj%varname
end function diag_obj_get_varname
-<<<<<<< HEAD
-=======
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Operator Overrides !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -612,6 +571,5 @@ pure logical function int_ne_obj (i,obj) result(ll)
ll = (i .ne. obj%diag_id)
endif
end function int_ne_obj
->>>>>>> 9c9a406d (Adds all variables to diag object that are registered.)
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90
index 3d61abb135..b3fdae819c 100644
--- a/diag_manager/fms_diag_object_container.F90
+++ b/diag_manager/fms_diag_object_container.F90
@@ -20,12 +20,12 @@
!> @defgroup fms_diag_object_container_mod fms_diag_object_container_mod
!> @ingroup diag_manager
!> @brief fms_diag_object_container_mod defines a container class and iterator class
-!! for inserting, removing and searching for fms_diag_object instances
+!! for inserting, removing and searching for fmsDiagObject_type instances
!!
!> @author Miguel Zuniga
!!
!! fms_diag_object_container_mod defines a container for inserting, removing and
-!! searching for fms_diag_object instances. It also defined an iterator for
+!! searching for fmsDiagObject_type instances. It also defined an iterator for
!! the data in the container. The value returned by the fms_diag_object function get_id()
!! is used for search key comparison.
!!
@@ -40,7 +40,7 @@
!> @addtogroup fms_diag_object_container_mod
!> @{
MODULE fms_diag_object_container_mod
- use fms_diag_object_mod, only: fms_diag_object
+ use fms_diag_object_mod, only: fmsDiagObject_type
USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE
!! Since this version is based on the FDS linked list:
@@ -48,7 +48,7 @@ MODULE fms_diag_object_container_mod
implicit none
- !> @brief A container of fms_diag_object instances providing insert, remove ,
+ !> @brief A container of fmsDiagObject_type instances providing insert, remove ,
!! find/search, and size public member functions. Iterator is provided by
!! the associated iterator class (see dig_obj_iterator class).
!!
@@ -101,7 +101,7 @@ function find_diag_object (this, id , iiter) result (riter)
class(FmsDiagObjIterator_t), intent (in), optional :: iiter
!< An (optional) iterator over the searchable set.
class(FmsDiagObjIterator_t) , allocatable :: riter !< The resultant iterator to the object.
- class(fms_diag_object), pointer:: ptdo !< A pointer to temporaty diagnostic object
+ class(fmsDiagObject_type), pointer:: ptdo !< A pointer to temporaty diagnostic object
integer :: status !< A status from iterator operations.
!!
if(present (iiter)) then
@@ -126,7 +126,7 @@ end function find_diag_object
function insert_diag_object (this, id, obj) result (status)
class (FmsDiagObjectContainer_t), intent (in out) :: this
integer, intent (in) :: id !< The id of the object to insert.
- class(fms_diag_object) , intent (in out) :: obj !< The object to insert
+ class(fmsDiagObject_type) , intent (in out) :: obj !< The object to insert
integer :: status !< The returned status. 0 for success.
class(FmsDllIterator_t), allocatable :: tliter !< A temporary iterator.
@@ -232,13 +232,13 @@ end function literator_next
function literator_data( this ) result( rdo )
class(FmsDiagObjIterator_t), intent(in) :: this
! null()
gp => this%liter%get()
select type(gp)
- type is (fms_diag_object) !! "type is", not the (polymorphic) "class is"
+ type is (fmsDiagObject_type) !! "type is", not the (polymorphic) "class is"
rdo => gp
class default
CALL error_mesg ('diag_object_container:literator_data', &
diff --git a/test_fms/diag_manager/test_diag_dlinked_list.F90 b/test_fms/diag_manager/test_diag_dlinked_list.F90
index 69fcdd3e90..4dff25a97a 100644
--- a/test_fms/diag_manager/test_diag_dlinked_list.F90
+++ b/test_fms/diag_manager/test_diag_dlinked_list.F90
@@ -37,7 +37,7 @@ program test_diag_dlinked_list
use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated
use mpp_io_mod, only: mpp_io_init
- use fms_diag_object_mod, only : fms_diag_object
+ use fms_diag_object_mod, only : fmsDiagObject_type
use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t
implicit none
diff --git a/test_fms/diag_manager/test_diag_object_container.F90 b/test_fms/diag_manager/test_diag_object_container.F90
index 1d02023ce8..9a5b8e3251 100644
--- a/test_fms/diag_manager/test_diag_object_container.F90
+++ b/test_fms/diag_manager/test_diag_object_container.F90
@@ -28,7 +28,7 @@ program test_diag_obj_container
use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated
use mpp_io_mod, only: mpp_io_init
- use fms_diag_object_mod, only : fms_diag_object
+ use fms_diag_object_mod, only : fmsDiagObject_type
use fms_diag_object_container_mod, only : FmsDiagObjectContainer_t, FmsDiagObjIterator_t
USE time_manager_mod, ONLY: time_type
@@ -36,8 +36,8 @@ program test_diag_obj_container
!!
type (FmsDiagObjectContainer_t), allocatable :: container !< Instance of the container
class(FmsDiagObjIterator_t), allocatable :: iter !< An iterator for the container
- type (fms_diag_object), allocatable , target :: obj_vec(:) !< A vector of objects
- type (fms_diag_object), pointer:: pobj !< A pointer to an object
+ type (fmsDiagObject_type), allocatable , target :: obj_vec(:) !< A vector of objects
+ type (fmsDiagObject_type), pointer:: pobj !< A pointer to an object
integer, parameter :: num_objs = 10 !< Total number of objects tested
integer :: full_id_sum !< Sum of all the possible object id values
integer :: sum !< Temp sum of vaalues of id sets
From 93ef8e8d83a7821241d009e8bf300ea79799cf16 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 12 Jan 2022 11:04:58 -0500
Subject: [PATCH 027/168] test: Dm update diag_yaml_object_init() tests (#883)
---
diag_manager/fms_diag_yaml.F90 | 204 +++++++++++-
diag_manager/fms_diag_yaml_object.F90 | 24 +-
test_fms/diag_manager/Makefile.am | 14 +-
test_fms/diag_manager/check_crashes.sh | 163 +++++++++
.../diagTables/diag_table_yaml_26 | 61 ++++
test_fms/diag_manager/test_diag_yaml.F90 | 311 ++++++++++++++++++
6 files changed, 767 insertions(+), 10 deletions(-)
create mode 100755 test_fms/diag_manager/check_crashes.sh
create mode 100644 test_fms/diag_manager/diagTables/diag_table_yaml_26
create mode 100644 test_fms/diag_manager/test_diag_yaml.F90
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 9a423697e0..6e184bfc58 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -32,6 +32,7 @@ module fms_diag_yaml_mod
#ifdef use_yaml
use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type, diag_yaml_files_obj_init, &
NUM_SUB_REGION_ARRAY
+use diag_data_mod, only: DIAG_NULL
use yaml_parser_mod
use mpp_mod
@@ -40,6 +41,7 @@ module fms_diag_yaml_mod
private
public :: diag_yaml_object_init, diag_yaml_object_end
+public :: diagYamlObject_type, get_diag_yaml_obj, get_title, get_basedate, get_diag_files, get_diag_fields
!> @}
integer, parameter :: basedate_size = 6
@@ -54,6 +56,8 @@ module fms_diag_yaml_mod
contains
procedure :: get_title !< Returns the title
procedure :: get_basedate !< Returns the basedate array
+ procedure :: get_diag_files !< Returns the diag_files array
+ procedure :: get_diag_fields !< Returns the diag_field array
end type diagYamlObject_type
type (diagYamlObject_type) :: diag_yaml !< Obj containing the contents of the diag_table.yaml
@@ -62,9 +66,19 @@ module fms_diag_yaml_mod
!> @{
contains
+!> @brief gets the diag_yaml module variable
+!! @return a copy of the diag_yaml module variable
+function get_diag_yaml_obj() &
+result(res)
+ type (diagYamlObject_type) :: res
+
+ res = diag_yaml
+end function get_diag_yaml_obj
+
!> @brief get the basedate of a diag_yaml type
!! @return the basedate as an integer array
-pure function get_basedate (diag_yaml) result (diag_basedate)
+pure function get_basedate (diag_yaml) &
+result (diag_basedate)
class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return
@@ -73,13 +87,34 @@ end function get_basedate
!> @brief get the title of a diag_yaml type
!! @return the title of the diag table as an allocated string
-pure function get_title (diag_yaml) result (diag_title)
+pure function get_title (diag_yaml) &
+ result (diag_title)
class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
character(len=:),allocatable :: diag_title !< Basedate array result to return
diag_title = diag_yaml%diag_title
end function get_title
+!> @brief get the diag_files of a diag_yaml type
+!! @return the diag_files
+pure function get_diag_files(diag_yaml) &
+result(diag_files)
+ class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
+ type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files!< History file info
+
+ diag_files = diag_yaml%diag_files
+end function get_diag_files
+
+!> @brief get the diag_fields of a diag_yaml type
+!! @return the diag_fields
+pure function get_diag_fields(diag_yaml) &
+result(diag_fields)
+ class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
+ type(diagYamlFilesVar_type), allocatable, dimension (:) :: diag_fields !< Diag fields info
+
+ diag_fields = diag_yaml%diag_fields
+end function get_diag_fields
+
!> @brief Uses the yaml_parser_mod to read in the diag_table and fill in the
!! diag_yaml object
subroutine diag_yaml_object_init
@@ -114,9 +149,16 @@ subroutine diag_yaml_object_init
nvars = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i))
allocate(var_ids(nvars))
call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=diag_file_ids(i))
+ allocate(diag_yaml%diag_files(i)%file_varlist(nvars))
nvars_loop: do j = 1, nvars
var_count = var_count + 1
+ !> Save the filename in the diag_field type
+ diag_yaml%diag_fields(var_count)%var_fname = diag_yaml%diag_files(i)%file_fname
+
call fill_in_diag_fields(diag_yaml_id, var_ids(j), diag_yaml%diag_fields(var_count))
+
+ !> Save the variable name in the diag_file type
+ diag_yaml%diag_files(i)%file_varlist(j) = diag_yaml%diag_fields(var_count)%var_varname
enddo nvars_loop
deallocate(var_ids)
enddo nfiles_loop
@@ -129,6 +171,7 @@ subroutine diag_yaml_object_end()
integer :: i !< For do loops
do i = 1, size(diag_yaml%diag_files, 1)
+ if(allocated(diag_yaml%diag_files(i)%file_varlist)) deallocate(diag_yaml%diag_files(i)%file_varlist)
if(allocated(diag_yaml%diag_files(i)%file_global_meta)) deallocate(diag_yaml%diag_files(i)%file_global_meta)
if(allocated(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region)) &
deallocate(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region)
@@ -162,18 +205,27 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", fileobj%file_frequnit)
call get_value_from_key(diag_yaml_id, diag_file_id, "freq", fileobj%file_freq)
+ call check_file_freq(fileobj)
+
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", fileobj%file_unlimdim)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", fileobj%file_timeunit)
+ call check_file_time_units(fileobj)
+
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "write_file", fileobj%string_file_write, is_optional=.true.)
if (fileobj%string_file_write .eq. "false") fileobj%file_write = .false.
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "realm", fileobj%file_realm, is_optional=.true.)
+ call check_file_realm(fileobj)
+
call get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", fileobj%file_new_file_freq, is_optional=.true.)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq_units", fileobj%file_new_file_freq_units, &
is_optional=.true.)
+ call check_new_file_freq(fileobj)
+
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", fileobj%file_start_time, is_optional=.true.)
call get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", fileobj%file_duration, is_optional=.true.)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration_units", fileobj%file_duration_units, &
- is_optional=.true.)
+ is_optional=.true.)
+ call check_file_duration(fileobj)
nsubregion = 0
nsubregion = get_num_blocks(diag_yaml_id, "sub_region", parent_block_id=diag_file_id)
@@ -182,13 +234,19 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
call diag_get_value_from_key(diag_yaml_id, sub_region_id(1), "grid_type", fileobj%file_sub_region%grid_type)
if (trim(fileobj%file_sub_region%grid_type) .eq. "latlon") then
allocate(fileobj%file_sub_region%lat_lon_sub_region(8))
+ fileobj%file_sub_region%lat_lon_sub_region = DIAG_NULL
call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%lat_lon_sub_region)
elseif (trim(fileobj%file_sub_region%grid_type) .eq. "index") then
allocate(fileobj%file_sub_region%index_sub_region(8))
+ fileobj%file_sub_region%index_sub_region = DIAG_NULL
call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%index_sub_region)
call get_value_from_key(diag_yaml_id, sub_region_id(1), "tile", fileobj%file_sub_region%tile, is_optional=.true.)
if (fileobj%file_sub_region%tile .eq. 0) call mpp_error(FATAL, "The tile number is required when defining a "//&
"subregion. Check your subregion entry for "//trim(fileobj%file_fname))
+ else
+ call mpp_error(FATAL, trim(fileobj%file_sub_region%grid_type)//" is not a valid region type. &
+ &The acceptable values are latlon and index. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
endif
elseif (nsubregion .ne. 0) then
call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//" has multiple region blocks")
@@ -219,8 +277,7 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
subroutine fill_in_diag_fields(diag_file_id, var_id, field)
integer, intent(in) :: diag_file_id !< Id of the file block in the yaml file
integer, intent(in) :: var_id !< Id of the variable block in the yaml file
- type(diagYamlFilesVar_type), intent(out) :: field !< diagYamlFilesVar_type obj to read the contents into
-
+ type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into
integer :: natt !< Number of attributes in variable
integer :: var_att_id(1) !< Id of the variable attribute block
@@ -232,8 +289,12 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field)
field%var_write = .true.
call diag_get_value_from_key(diag_file_id, var_id, "var_name", field%var_varname)
call diag_get_value_from_key(diag_file_id, var_id, "reduction", field%var_reduction)
+ call check_field_reduction(field)
+
call diag_get_value_from_key(diag_file_id, var_id, "module", field%var_module)
call diag_get_value_from_key(diag_file_id, var_id, "kind", field%var_skind)
+ call check_field_kind(field)
+
call diag_get_value_from_key(diag_file_id, var_id, "write_var", field%string_var_write, is_optional=.true.)
if (trim(field%string_var_write) .eq. "false") field%var_write = .false.
@@ -313,6 +374,139 @@ function get_total_num_vars(diag_yaml_id, diag_file_ids) &
end do
end function
+!> @brief This checks if the file frequency in a diag file is valid and crashes if it isn't
+subroutine check_file_freq(fileobj)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+
+ if (fileobj%file_freq < 1 ) &
+ call mpp_error(FATAL, "freq must be greater than 0. &
+ &Check you entry for"//trim(fileobj%file_fname))
+ if(.not. is_valid_time_units(fileobj%file_frequnit)) &
+ call mpp_error(FATAL, trim(fileobj%file_frequnit)//" is not a valid file_frequnit. &
+ &The acceptable values are seconds, minuts, hours, days, months, years. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+end subroutine check_file_freq
+
+!> @brief This checks if the time unit in a diag file is valid and crashes if it isn't
+subroutine check_file_time_units (fileobj)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to checK
+
+ if(.not. is_valid_time_units(fileobj%file_timeunit)) &
+ call mpp_error(FATAL, trim(fileobj%file_timeunit)//" is not a valid time_unit. &
+ &The acceptable values are seconds, minuts, hours, days, months, years. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+end subroutine check_file_time_units
+
+!> @brief This checks if the realm in a diag file is valid and crashes if it isn't
+subroutine check_file_realm(fileobj)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to checK
+
+ select case (TRIM(fileobj%file_realm))
+ case ("ATM", "OCN", "LND", "ICE", "")
+ case default
+ call mpp_error(FATAL, trim(fileobj%file_realm)//" is an invalid realm! &
+ &The acceptable values are ATM, OCN, LND, ICE. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+ end select
+
+end subroutine check_file_realm
+
+!> @brief This checks if the new file frequency in a diag file is valid and crashes if it isn't
+subroutine check_new_file_freq(fileobj)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+
+ if (fileobj%file_new_file_freq > 0) then
+ if (trim(fileobj%file_new_file_freq_units) .eq. "") &
+ call mpp_error(FATAL, "new_file_freq_units is required if using new_file_freq. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+
+ if (.not. is_valid_time_units(fileobj%file_new_file_freq_units)) &
+ call mpp_error(FATAL, trim(fileobj%file_new_file_freq_units)//" is not a valid new_file_freq_units. &
+ &The acceptable values are seconds, minuts, hours, days, months, years. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+ endif
+end subroutine check_new_file_freq
+
+!> @brief This checks if the file duration in a diag file is valid and crashes if it isn't
+subroutine check_file_duration(fileobj)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+
+ if (fileobj%file_duration > 0) then
+ if(trim(fileobj%file_duration_units) .eq. "") &
+ call mpp_error(FATAL, "file_duration_units is required if using file_duration. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+
+ if (.not. is_valid_time_units(fileobj%file_duration_units)) &
+ call mpp_error(FATAL, trim(fileobj%file_duration_units)//" is not a valid file_duration_units. &
+ &The acceptable values are seconds, minuts, hours, days, months, years. &
+ &Check your entry for file:"//trim(fileobj%file_duration_units))
+ endif
+end subroutine check_file_duration
+
+!> @brief This checks if the kind of a diag field is valid and crashes if it isn't
+subroutine check_field_kind(field)
+ type(diagYamlFilesVar_type), intent(in) :: field !< diagYamlFilesVar_type obj to read the contents into
+
+ select case (TRIM(field%var_skind))
+ case ("double", "float")
+ case default
+ call mpp_error(FATAL, trim(field%var_skind)//" is an invalid kind! &
+ &The acceptable values are double and float. &
+ &Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
+ end select
+
+end subroutine check_field_kind
+
+!> @brief This checks if the reduction of a diag field is valid and crashes if it isn't
+subroutine check_field_reduction(field)
+ type(diagYamlFilesVar_type), intent(in) :: field !< diagYamlFilesVar_type obj to read the contents into
+
+ integer :: n_diurnal !< number of diurnal samples
+ integer :: pow_value !< The power value
+ integer :: ioerror !< io error status after reading in the diurnal samples
+
+ n_diurnal = 0
+ pow_value = 0
+ ioerror = 0
+ if (field%var_reduction(1:7) .eq. "diurnal") then
+ READ (UNIT=field%var_reduction(8:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) n_diurnal
+ if (ioerror .ne. 0) &
+ call mpp_error(FATAL, "Error getting the number of diurnal samples from "//trim(field%var_reduction))
+ if (n_diurnal .le. 0) &
+ call mpp_error(FATAL, "Diurnal samples should be greater than 0. &
+ & Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
+ elseif (field%var_reduction(1:3) .eq. "pow") then
+ READ (UNIT=field%var_reduction(4:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) pow_value
+ if (ioerror .ne. 0) &
+ call mpp_error(FATAL, "Error getting the power value from "//trim(field%var_reduction))
+ if (pow_value .le. 0) &
+ call mpp_error(FATAL, "The power value should be greater than 0. &
+ & Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
+ else
+ select case (TRIM(field%var_reduction))
+ case ("none", "average", "min", "max", "rms")
+ case default
+ call mpp_error(FATAL, trim(field%var_reduction)//" is an invalid reduction method! &
+ &The acceptable values are none, average, pow##, diurnal##, min, max, and rms. &
+ &Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
+ end select
+ endif
+end subroutine check_field_reduction
+
+!> @brief This checks if a time unit is valid
+!! @return Flag indicating if the time units are valid
+pure function is_valid_time_units(time_units) &
+result(is_valid)
+ character(len=*), intent(in) :: time_units
+ logical :: is_valid
+
+ select case (TRIM(time_units))
+ case ("seconds", "minutes", "hours", "days", "months", "years")
+ is_valid = .true.
+ case default
+ is_valid = .false.
+ end select
+end function is_valid_time_units
#endif
end module fms_diag_yaml_mod
!> @}
diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90
index e406885084..7cc6db38f3 100644
--- a/diag_manager/fms_diag_yaml_object.F90
+++ b/diag_manager/fms_diag_yaml_object.F90
@@ -99,6 +99,7 @@ module fms_diag_yaml_object_mod
procedure :: get_file_duration_units
procedure :: get_file_varlist
procedure :: get_file_global_meta
+ procedure :: is_global_meta
end type diagYamlFiles_type
@@ -129,7 +130,7 @@ module fms_diag_yaml_object_mod
procedure :: get_var_units
procedure :: get_var_write
procedure :: get_var_attributes
-
+ procedure :: is_var_attributes
end type diagYamlFilesVar_type
contains
@@ -239,6 +240,15 @@ pure function get_file_global_meta (diag_files_obj) result (res)
character (:), allocatable :: res(:,:) !< What is returned
res = diag_files_obj%file_global_meta
end function get_file_global_meta
+!> @brief Inquiry for whether file_global_meta is allocated
+!! @return Flag indicating if file_global_meta is allocated
+function is_global_meta(diag_files_obj) result(res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ logical :: res
+ res = .false.
+ if (allocated(diag_files_obj%file_global_meta)) &
+ res = .true.
+end function
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -316,6 +326,15 @@ pure function get_var_attributes(diag_var_obj) result (res)
character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned
res = diag_var_obj%var_attributes
end function get_var_attributes
+!> @brief Inquiry for whether var_attributes is allocated
+!! @return Flag indicating if var_attributes is allocated
+function is_var_attributes(diag_var_obj) result(res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ logical :: res
+ res = .false.
+ if (allocated(diag_var_obj%var_attributes)) &
+ res = .true.
+end function is_var_attributes
!> @brief Initializes the non string values of a diagYamlFiles_type to its
!! default values
@@ -325,8 +344,7 @@ subroutine diag_yaml_files_obj_init(obj)
obj%file_freq = 0
obj%file_write = .true.
obj%file_duration = 0
- obj%file_sub_region%lat_lon_sub_region = -999.
- obj%file_sub_region%index_sub_region = -999
+ obj%file_new_file_freq = 0
obj%file_sub_region%tile = 0
end subroutine diag_yaml_files_obj_init
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 90be4d0d05..79ecc644de 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -29,12 +29,14 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
# Build this test program.
check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_object_container \
- test_diag_update_buffer test_diag_dlinked_list
+ test_diag_update_buffer test_diag_dlinked_list \
+ test_diag_dlinked_list test_diag_yaml
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
test_diag_manager_time_SOURCES = test_diag_manager_time.F90
test_diag_update_buffer_SOURCES= test_diag_update_buffer.F90
+test_diag_yaml_SOURCES = test_diag_yaml.F90
test_diag_object_container_SOURCES = test_diag_object_container.F90
test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90
@@ -46,6 +48,14 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
TESTS = test_diag_manager2.sh
# Copy over other needed files to the srcdir
-EXTRA_DIST = test_diag_manager2.sh
+EXTRA_DIST = input.nml_base diagTables test_diag_manager2.sh check_crashes.sh
+
+if SKIP_PARSER_TESTS
+skipflag="skip"
+else
+skipflag=""
+endif
+
+TESTS_ENVIRONMENT = parser_skip=${skipflag}
CLEANFILES = input.nml *.nc *.out diag_table *-files/* *.dpi *.spi *.dyn *.spl
diff --git a/test_fms/diag_manager/check_crashes.sh b/test_fms/diag_manager/check_crashes.sh
new file mode 100755
index 0000000000..da68fdf81f
--- /dev/null
+++ b/test_fms/diag_manager/check_crashes.sh
@@ -0,0 +1,163 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# This is part of the GFDL FMS package. This is a shell script to
+# execute tests in the test_fms/data_override directory.
+
+# Set common test settings.
+. ../test_common.sh
+
+printf "&check_crashes_nml \n checking_crashes = .true. \n/" | cat > input.nml
+
+echo "Test 27: Missing tile when using the 'index' grid type"
+touch input.nml
+sed '/tile/d' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since 'tile' was missing and the 'index' grid type was used"
+ exit 3
+fi
+
+echo "Test 28: Missing new_file_freq_units when using new_file_freq_units"
+touch input.nml
+sed '/new_file_freq_units/d' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since 'new_file_freq_units' was missing and new_file_freq was used"
+ exit 3
+fi
+
+echo "Test 29: new_file_freq_units is not valid"
+touch input.nml
+sed 's/new_file_freq_units: hours/new_file_freq_units: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since 'new_file_freq_units' is not valid"
+ exit 3
+fi
+
+echo "Test 30: Missing file_duration_units when using file_duration"
+touch input.nml
+sed '/file_duration_units/d' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since 'file_duration_units' was missing and file_duration was used"
+ exit 3
+fi
+
+echo "Test 31: file_duration_units is not valid"
+touch input.nml
+sed 's/file_duration_units: hours/file_duration_units: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since 'file_duration_units' is not valid"
+ exit 3
+fi
+
+echo "Test 32: freq units is not valid"
+touch input.nml
+sed 's/freq_units: hours/freq_units: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since the freq units is not valid"
+ exit 3
+fi
+
+echo "Test 33: freq is less than 0"
+touch input.nml
+sed 's/freq: 6/freq: -666/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since freq is not valid"
+ exit 3
+fi
+
+echo "Test 34: realm is not valid"
+touch input.nml
+sed 's/realm: ATM/realm: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since realm is not valid"
+ exit 3
+fi
+
+echo "Test 35: kind is not valid"
+touch input.nml
+sed 's/kind: float/kind: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since the kind is not valid"
+ exit 3
+fi
+
+echo "Test 36: reduction is not valid"
+touch input.nml
+sed 's/reduction: average/reduction: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since the reduction method is not valid"
+ exit 3
+fi
+
+echo "Test 37: diurnal samples is less than 0"
+touch input.nml
+sed 's/reduction: average/reduction: diurnal0/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since the number of diurnal samples is less than 0"
+ exit 3
+fi
+
+echo "Test 38: diurnal samples is not an integer"
+touch input.nml
+sed 's/reduction: average/reduction: diurnal99r/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since the number of diurnal samples is not valid"
+ exit 3
+fi
+
+echo "Test 39: power value is less than 0"
+touch input.nml
+sed 's/reduction: average/reduction: pow0/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since the power value is less than"
+ exit 3
+fi
+
+echo "Test 40: power value is not an integer"
+touch input.nml
+sed 's/reduction: average/reduction: pow99r/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since the power value is not valid"
+ exit 3
+fi
+
+echo "Test 41: the sub_region grid_type is not valid"
+touch input.nml
+sed 's/grid_type: latlon/grid_type: ice_cream/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
+run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
+if [ $? -eq 0 ]; then
+ echo "Test should have failed since the sub_region grid_type"
+ exit 3
+fi
diff --git a/test_fms/diag_manager/diagTables/diag_table_yaml_26 b/test_fms/diag_manager/diagTables/diag_table_yaml_26
new file mode 100644
index 0000000000..d82038bd6a
--- /dev/null
+++ b/test_fms/diag_manager/diagTables/diag_table_yaml_26
@@ -0,0 +1,61 @@
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: wild_card_name%4yr%2mo%2dy%2hr
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6
+ new_file_freq_units: hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12
+ file_duration_units: hours
+ write_file: false
+ realm: ATM
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst
+ output_name: sst
+ reduction: average
+ kind: float
+ write_var: false
+ global_meta:
+ - is_a_file: true
+- file_name: normal
+ freq: 24
+ freq_units: days
+ time_units: hours
+ unlimdim: records
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst
+ output_name: sst
+ reduction: average
+ kind: float
+ write_var: true
+ attributes:
+ - do_sst: .true.
+ sub_region:
+ - grid_type: latlon
+ dim1_begin: 64.0
+ dim3_end: 20.0
+- file_name: normal2
+ freq: 24
+ freq_units: days
+ time_units: hours
+ unlimdim: records
+ write_file: true
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sstt
+ output_name: sstt
+ reduction: average
+ kind: float
+ long_name: S S T
+ sub_region:
+ - grid_type: index
+ tile: 1
+ dim2_begin: 10
+ dim2_end: 20
+ dim1_begin: 10
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
new file mode 100644
index 0000000000..d939de7b91
--- /dev/null
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -0,0 +1,311 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This program tests the diag_yaml_object_init and diag_yaml_object_end subroutines
+!! in fms_diag_yaml_mod
+program test_diag_yaml
+
+#ifdef use_yaml
+use FMS_mod, only: fms_init, fms_end
+use fms_diag_yaml_mod
+use fms_diag_yaml_object_mod
+use mpp_mod
+use platform_mod
+
+implicit none
+
+!< @brief Interface used to compare two different values
+interface compare_result
+subroutine compare_result_0d(key_name, res, expected_res)
+ character(len=*), intent(in) :: key_name !< Name of the key to compare
+ class(*), intent(in) :: res !< Value obtained from reading the file
+ class(*), intent(in) :: expected_res !< Value expected
+end subroutine compare_result_0d
+
+subroutine compare_result_1d(key_name, res, expected_res)
+ character(len=*), intent(in) :: key_name !< Name of the key to compare
+ class(*), intent(in) :: res(:) !< Value obtained from reading the file
+ class(*), intent(in) :: expected_res(:) !< Value expected
+end subroutine compare_result_1d
+end interface compare_result
+
+type(diagYamlObject_type) :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init
+type(diagYamlObject_type) :: ans !< expected diagYamlObject
+logical :: checking_crashes = .false.!< Flag indicating that you are checking crashes
+integer :: i !< For do loops
+integer :: io_status !< The status after reading the input.nml
+
+type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< Files from the diag_yaml
+type(diagYamlFilesVar_type), allocatable, dimension(:) :: diag_fields !< Fields from the diag_yaml
+
+namelist / check_crashes_nml / checking_crashes
+
+call fms_init()
+
+read (input_nml_file, check_crashes_nml, iostat=io_status)
+if (io_status > 0) call mpp_error(FATAL,'=>check_crashes: Error reading input.nml')
+
+call diag_yaml_object_init
+
+my_yaml = get_diag_yaml_obj()
+
+if (.not. checking_crashes) then
+ call compare_result("base_date", my_yaml%get_basedate(), (/2, 1, 1, 0, 0 , 0 /))
+ call compare_result("title", my_yaml%get_title(), "test_diag_manager")
+
+ diag_files = my_yaml%get_diag_files()
+ call compare_result("nfiles", size(diag_files), 3)
+ call compare_diag_files(diag_files)
+
+ diag_fields = my_yaml%get_diag_fields()
+ call compare_result("nfields", size(diag_fields), 3)
+ call compare_diag_fields(diag_fields)
+
+endif
+deallocate(diag_files)
+deallocate(diag_fields)
+
+call diag_yaml_object_end
+
+call fms_end()
+
+contains
+
+!> @brief Compares a diagYamlFilesVar_type with the expected result and
+!! crashes if they don't match
+subroutine compare_diag_fields(res)
+ type(diagYamlFilesVar_type), intent(in) :: res(:) !< diag_field info read from yaml file
+ character (len=255), dimension(:, :), allocatable :: var_attributes !< Variable attributes
+
+ call compare_result("var_fname 1", res(1)%get_var_fname(), "wild_card_name%4yr%2mo%2dy%2hr")
+ call compare_result("var_fname 2", res(2)%get_var_fname(), "normal")
+ call compare_result("var_fname 3", res(3)%get_var_fname(), "normal2")
+
+ call compare_result("var_varname 1", res(1)%get_var_varname(), "sst")
+ call compare_result("var_varname 2", res(2)%get_var_varname(), "sst")
+ call compare_result("var_varname 3", res(3)%get_var_varname(), "sstt")
+
+ call compare_result("var_reduction 1", res(1)%get_var_reduction(), "average")
+ call compare_result("var_reduction 2", res(2)%get_var_reduction(), "average")
+ call compare_result("var_reduction 3", res(3)%get_var_reduction(), "average")
+
+ call compare_result("var_module 1", res(1)%get_var_module(), "test_diag_manager_mod")
+ call compare_result("var_module 2", res(2)%get_var_module(), "test_diag_manager_mod")
+ call compare_result("var_module 3", res(3)%get_var_module(), "test_diag_manager_mod")
+
+ call compare_result("var_skind 1", res(1)%get_var_skind(), "float")
+ call compare_result("var_skind 2", res(2)%get_var_skind(), "float")
+ call compare_result("var_skind 3", res(3)%get_var_skind(), "float")
+
+ call compare_result("var_write 1", res(1)%get_var_write(), .false.)
+ call compare_result("var_write 2", res(2)%get_var_write(), .true.)
+ call compare_result("var_write 3", res(3)%get_var_write(), .true.)
+
+ call compare_result("var_outname 1", res(1)%get_var_outname(), "sst")
+ call compare_result("var_outname 2", res(2)%get_var_outname(), "sst")
+ call compare_result("var_outname 3", res(3)%get_var_outname(), "sstt")
+
+ call compare_result("var_longname 1", res(1)%get_var_longname(), "")
+ call compare_result("var_longname 2", res(2)%get_var_longname(), "")
+ call compare_result("var_longname 3", res(3)%get_var_longname(), "S S T")
+
+ if (res(1)%is_var_attributes()) call mpp_error(FATAL, "The variable attributes for the first file was set?")
+
+ var_attributes = res(2)%get_var_attributes()
+ if (.not. allocated(var_attributes)) call mpp_error(FATAL, "The variable attributes for the second file was not set")
+ call compare_result("var attributes key", var_attributes(1,1), "do_sst")
+ call compare_result("var attributes value", var_attributes(1,2), ".true.")
+ deallocate(var_attributes)
+
+ if (res(3)%is_var_attributes()) call mpp_error(FATAL, "The variable attributes for the third file was set?")
+
+end subroutine
+
+!> @brief Compares a diagYamlFiles_type with the expected result and
+!! crashes if they don't match
+subroutine compare_diag_files(res)
+ type(diagYamlFiles_type), intent(in) :: res(:) !< diag_file info read from yaml file
+
+ character (len=255), dimension(:), allocatable :: varlist !< List of variables
+ character (len=255), dimension(:, :), allocatable :: global_meta !< List of global meta
+
+ call compare_result("file_fname 1", res(1)%get_file_fname(), "wild_card_name%4yr%2mo%2dy%2hr")
+ call compare_result("file_fname 2", res(2)%get_file_fname(), "normal")
+ call compare_result("file_fname 3", res(3)%get_file_fname(), "normal2")
+
+ call compare_result("file_freq 1", res(1)%get_file_freq(), 6)
+ call compare_result("file_freq 2", res(2)%get_file_freq(), 24)
+ call compare_result("file_freq 3", res(3)%get_file_freq(), 24)
+
+ call compare_result("file_frequnit 1", res(1)%get_file_frequnit(), "hours")
+ call compare_result("file_frequnit 2", res(2)%get_file_frequnit(), "days")
+ call compare_result("file_frequnit 3", res(3)%get_file_frequnit(), "days")
+
+ call compare_result("file_timeunit 1", res(1)%get_file_timeunit(), "hours")
+ call compare_result("file_timeunit 2", res(2)%get_file_timeunit(), "hours")
+ call compare_result("file_timeunit 3", res(3)%get_file_timeunit(), "hours")
+
+ call compare_result("file_unlimdim 1", res(1)%get_file_unlimdim(), "time")
+ call compare_result("file_unlimdim 2", res(2)%get_file_unlimdim(), "records")
+ call compare_result("file_unlimdim 3", res(3)%get_file_unlimdim(), "records")
+
+ call compare_result("file_realm 1", res(1)%get_file_realm(), "ATM")
+ call compare_result("file_realm 2", res(2)%get_file_realm(), "")
+ call compare_result("file_realm 3", res(3)%get_file_realm(), "")
+
+ call compare_result("file_write 1", res(1)%get_file_write(), .false.)
+ call compare_result("file_write 2", res(2)%get_file_write(), .true.)
+ call compare_result("file_write 3", res(3)%get_file_write(), .true.)
+
+ call compare_result("file_new_file_freq 1", res(1)%get_file_new_file_freq(), 6)
+ call compare_result("file_new_file_freq 2", res(2)%get_file_new_file_freq(), 0)
+ call compare_result("file_new_file_freq 3", res(3)%get_file_new_file_freq(), 0)
+
+ call compare_result("file_new_file_freq_units 1", res(1)%get_file_new_file_freq_units(), "hours")
+ call compare_result("file_new_file_freq_units 2", res(2)%get_file_new_file_freq_units(), "")
+ call compare_result("file_new_file_freq_units 3", res(3)%get_file_new_file_freq_units(), "")
+
+ call compare_result("file_duration 1", res(1)%get_file_duration(), 12)
+ call compare_result("file_duration 2", res(2)%get_file_duration(), 0)
+ call compare_result("file_duration 3", res(3)%get_file_duration(), 0)
+
+ call compare_result("file_duration_units 1", res(1)%get_file_duration_units(), "hours")
+ call compare_result("file_duration_units 2", res(2)%get_file_duration_units(), "")
+ call compare_result("file_duration_units 3", res(3)%get_file_duration_units(), "")
+
+ call compare_result("file_start_time 1", res(1)%get_file_start_time(), "2 1 1 0 0 0")
+ call compare_result("file_start_time 2", res(2)%get_file_start_time(), "")
+ call compare_result("file_start_time 3", res(3)%get_file_start_time(), "")
+
+ varlist = res(1)%get_file_varlist()
+ if (.not. allocated(varlist)) call mpp_error(FATAL, "The varlist for the first file was not set")
+ call compare_result("number_variables 1", size(varlist), 1)
+ call compare_result("varlist 1", varlist(1), "sst")
+ deallocate(varlist)
+
+ varlist = res(2)%get_file_varlist()
+ if (.not. allocated(varlist)) call mpp_error(FATAL, "The varlist for the first file was not set")
+ call compare_result("number_variables 2", size(varlist), 1)
+ call compare_result("varlist 2", varlist(1), "sst")
+ deallocate(varlist)
+
+ varlist = res(3)%get_file_varlist()
+ if (.not. allocated(varlist)) call mpp_error(FATAL, "The varlist for the first file was not set")
+ call compare_result("number_variables 3", size(varlist), 1)
+ call compare_result("varlist 3", varlist(1), "sstt")
+ deallocate(varlist)
+
+ global_meta= res(1)%get_file_global_meta()
+ if (.not. allocated(global_meta)) call mpp_error(FATAL, "The global meta for the first file was not set")
+ call compare_result("attributes key", global_meta(1,1), "is_a_file")
+ call compare_result("attributes value", global_meta(1,2), "true")
+ deallocate(global_meta)
+
+ if (res(2)%is_global_meta()) call mpp_error(FATAL, "The global meta for the second file was set?")
+ if (res(3)%is_global_meta()) call mpp_error(FATAL, "The global meta for the third file was set?")
+
+end subroutine compare_diag_files
+
+#endif
+end program test_diag_yaml
+
+#ifdef use_yaml
+!< @brief Compare a key value with the expected result
+subroutine compare_result_0d(key_name, res, expected_res)
+ use platform_mod
+ use mpp_mod
+ character(len=*), intent(in) :: key_name !< Name of the key to compare
+ class(*), intent(in) :: res !< Value obtained from reading the file
+ class(*), intent(in) :: expected_res !< Value expected
+
+ print *, "Comparing ", trim(key_name)
+ select type(res)
+ type is(character(len=*))
+ select type(expected_res)
+ type is(character(len=*))
+ if(trim(res) .ne. trim(expected_res)) &
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. "//trim(res)//" ne "//&
+ trim(expected_res)//".")
+ end select
+ type is (integer(kind=i4_kind))
+ select type(expected_res)
+ type is(integer(kind=i4_kind))
+ if (res .ne. expected_res) then
+ print *, res, " ne ", expected_res
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result.")
+ endif
+ end select
+ type is (logical)
+ select type(expected_res)
+ type is(logical)
+ if ((res .and. .not. expected_res) .or. (.not. res .and. expected_res)) then
+ print*, res, " ne ", expected_res
+ call mpp_error(FATAL, "Error!:"//trim(key_name)//" is not the expected result")
+ endif
+ end select
+ end select
+
+end subroutine compare_result_0d
+
+!< @brief Compare a 1d key value with the expected result
+subroutine compare_result_1d(key_name, res, expected_res)
+ use platform_mod
+ use mpp_mod
+ character(len=*), intent(in) :: key_name !< Name of the key to compare
+ class(*), intent(in) :: res(:) !< Value obtained from reading the file
+ class(*), intent(in) :: expected_res(:) !< Value expected
+
+ integer :: i
+
+ print *, "Comparing ", trim(key_name)
+
+ select type(res)
+ type is (integer(kind=i4_kind))
+ select type(expected_res)
+ type is (integer(kind=i4_kind))
+ do i = 1, size(res,1)
+ if( res(i) .ne. expected_res(i)) then
+ print *, res, " ne ", expected_res
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. ")
+ endif
+ enddo
+ end select
+ type is (real(kind=r4_kind))
+ select type(expected_res)
+ type is (real(kind=r4_kind))
+ do i = 1, size(res,1)
+ if( res(i) .ne. expected_res(i)) then
+ print *, res, " ne ", expected_res
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. ")
+ endif
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type(expected_res)
+ type is (real(kind=r8_kind))
+ do i = 1, size(res,1)
+ if( res(i) .ne. expected_res(i)) then
+ print *, res, " ne ", expected_res
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. ")
+ endif
+ enddo
+ end select
+ end select
+end subroutine compare_result_1d
+#endif
From b349abf34b10f14a41e36e40cbb55825b78cdffa Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Mon, 7 Feb 2022 13:35:16 -0500
Subject: [PATCH 028/168] feat: add getter functions to fms_diag_object (#885)
---
diag_manager/diag_data.F90 | 1 +
diag_manager/fms_diag_object.F90 | 404 ++++++++++++++++++++++++++++---
2 files changed, 370 insertions(+), 35 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 415ae0804e..04e8c048a8 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -63,6 +63,7 @@ MODULE diag_data_mod
! Specify storage limits for fixed size tables used for pointers, etc.
integer, parameter :: diag_null = -999 !< Integer represening NULL in the diag_object
+ character(len=1), parameter :: diag_null_string = " "
integer, parameter :: diag_not_found = -1
integer, parameter :: diag_not_registered = 0
integer, parameter :: diag_registered_id = 10
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 5e8a35c66d..90d1904fe7 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -7,7 +7,7 @@ module fms_diag_object_mod
!! The procedures of this object and the types are all in this module. The fms_dag_object is a type
!! that contains all of the information of the variable. It is extended by a type that holds the
!! appropriate buffer for the data for manipulation.
-use diag_data_mod, only: diag_null
+use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string
use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id
@@ -63,8 +63,8 @@ module fms_diag_object_mod
integer, allocatable, private :: diag_id !< unique id for varable
class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the
!! file objects for this variable
- character(len=:), allocatable, dimension(:) :: metadata !< metedata for the variable
- logical, private :: static !< true is this is a static var
+ character(len=:), allocatable, dimension(:) :: metadata !< metadata for the variable
+ logical, allocatable, private :: static !< true if this is a static var
logical, allocatable, private :: registered !< true when registered
logical, allocatable, private :: mask_variant !< If there is a mask variant
logical, allocatable, private :: local !< If the output is local
@@ -88,15 +88,8 @@ module fms_diag_object_mod
integer, allocatable, private :: tile_count !< The number of tiles
integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs
integer, allocatable, private :: area, volume !< The Area and Volume
- real, private :: missing_value !< Holds a missing value if none given
- integer(kind=I4_KIND), allocatable, private :: i4missing_value !< The missing i4 fill value
- integer(kind=I8_KIND), allocatable, private :: i8missing_value !< The missing i8 fill value
- real(kind=R4_KIND), allocatable, private :: r4missing_value !< The missing r4 fill value
- real(kind=R8_KIND), allocatable, private :: r8missing_value !< The missing r8 fill value
- integer(kind=I4_KIND), allocatable,dimension(:) :: i4data_RANGE !< The range of i4 data
- integer(kind=I8_KIND), allocatable,dimension(:) :: i8data_RANGE !< The range of i8 data
- real(kind=R4_KIND), allocatable,dimension(:) :: r4data_RANGE !< The range of r4 data
- real(kind=R8_KIND), allocatable,dimension(:) :: r8data_RANGE !< The range of r8 data
+ class(*), allocatable, private :: missing_value !< The missing fill value
+ class(*), allocatable, private :: data_RANGE !< The range of the variable data
type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object
!> \brief Extends the variable object to work with multiple types of data
class(*), allocatable :: vardata0
@@ -116,15 +109,41 @@ module fms_diag_object_mod
procedure :: copy => copy_diag_obj
procedure :: register => fms_register_diag_field_obj !! Merely initialize fields.
procedure :: setID => set_diag_id
- procedure :: is_registered => diag_ob_registered
procedure :: set_type => set_vartype
procedure :: vartype_inq => what_is_vartype
-
- procedure,public :: is_static => diag_obj_is_static
- procedure,public :: is_registeredB => diag_obj_is_registered
- procedure,public :: get_vartype => diag_obj_get_vartype
- procedure,public :: get_varname => diag_obj_get_varname
-
+! Check functions
+ procedure :: is_static => diag_obj_is_static
+ procedure :: is_registered => diag_ob_registered
+ procedure :: is_registeredB => diag_obj_is_registered
+ procedure :: is_mask_variant => get_mask_variant
+ procedure :: is_local => get_local
+! Get functions
+ procedure :: get_diag_id => fms_diag_get_id
+ procedure :: get_metadata
+ procedure :: get_static
+ procedure :: get_registered
+ procedure :: get_mask_variant
+ procedure :: get_local
+ procedure :: get_vartype
+ procedure :: get_varname
+ procedure :: get_longname
+ procedure :: get_standname
+ procedure :: get_units
+ procedure :: get_modname
+ procedure :: get_realm
+ procedure :: get_err_msg
+ procedure :: get_interp_method
+ procedure :: get_frequency
+ procedure :: get_output_units
+ procedure :: get_t
+ procedure :: get_tile_count
+ procedure :: get_axis_ids
+ procedure :: get_area
+ procedure :: get_volume
+ procedure :: get_missing_value
+ procedure :: get_data_RANGE
+!TODO procedure :: get_init_time
+!TODO procedure :: get_axis
end type fmsDiagObject_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagObject_type) :: null_ob
@@ -229,20 +248,28 @@ subroutine fms_register_diag_field_obj &
if (present(missing_value)) then
select type (missing_value)
type is (integer(kind=i4_kind))
- dobj%i4missing_value = missing_value
+ allocate(integer(kind=i4_kind) :: dobj%missing_value)
+ dobj%missing_value = missing_value
type is (integer(kind=i8_kind))
- dobj%i8missing_value = missing_value
+ allocate(integer(kind=i8_kind) :: dobj%missing_value)
+ dobj%missing_value = missing_value
type is (real(kind=r4_kind))
- dobj%r4missing_value = missing_value
+ allocate(integer(kind=r4_kind) :: dobj%missing_value)
+ dobj%missing_value = missing_value
type is (real(kind=r8_kind))
- dobj%r8missing_value = missing_value
+ allocate(integer(kind=r8_kind) :: dobj%missing_value)
+ dobj%missing_value = missing_value
class default
call mpp_error("fms_register_diag_field_obj", &
"The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",&
FATAL)
end select
else
- dobj%missing_value = DIAG_NULL
+ allocate(real :: dobj%missing_value)
+ select type (miss => dobj%missing_value)
+ type is (real)
+ miss = real(CMOR_MISSING_VALUE)
+ end select
endif
! write(6,*)"IKIND for diag_fields(1) is",dobj%diag_fields(1)%ikind
@@ -352,6 +379,7 @@ subroutine copy_diag_obj(objin , objout)
end subroutine copy_diag_obj
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \brief Returns the ID integer for a variable
+!! \return the diag ID
integer function fms_diag_get_id (dobj) result(diag_id)
class(fmsDiagObject_type) , intent(inout) :: dobj
! character(*) , intent(in) :: varname
@@ -424,17 +452,323 @@ function diag_obj_is_static (obj) result (rslt)
rslt = obj%static
end function diag_obj_is_static
-function diag_obj_get_vartype (obj) result (rslt)
- class(fmsDiagObject_type), intent(in) :: obj
- integer :: rslt
- rslt = obj%vartype
-end function diag_obj_get_vartype
-
-function diag_obj_get_varname(obj) result (rslt)
- class(fmsDiagObject_type), intent(in) :: obj
- character(len=len(obj%varname)) :: rslt
- rslt = obj%varname
-end function diag_obj_get_varname
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Get functions
+
+!> @brief Gets metedata
+!! @return copy of metadata string array, or a single space if metadata is not allocated
+function get_metadata (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable, dimension(:) :: rslt
+ if (allocated(obj%metadata)) then
+ allocate(character(len=(len(obj%metadata(1)))) :: rslt (size(obj%metadata)) )
+ rslt = obj%metadata
+ else
+ allocate(character(len=1) :: rslt(1:1))
+ rslt = diag_null_string
+ endif
+end function get_metadata
+!> @brief Gets static
+!! @return copy of variable static
+function get_static (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ logical :: rslt
+ rslt = obj%static
+end function get_static
+!> @brief Gets regisetered
+!! @return copy of registered
+function get_registered (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ logical :: rslt
+ rslt = obj%registered
+end function get_registered
+!> @brief Gets mask variant
+!! @return copy of mask variant
+function get_mask_variant (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ logical :: rslt
+ rslt = obj%mask_variant
+end function get_mask_variant
+!> @brief Gets local
+!! @return copy of local
+function get_local (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ logical :: rslt
+ rslt = obj%local
+end function get_local
+!> @brief Gets initial time
+!! @return copy of the initial time
+!! TODO
+!function get_init_time (obj) &
+!result(rslt)
+! class (fmsDiagObject_type), intent(in) :: obj !< diag object
+! TYPE(time_type) :: rslt
+!
+!end function get_init_time
+!> @brief Gets vartype
+!! @return copy of The integer related to the variable type
+function get_vartype (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ integer :: rslt
+ rslt = obj%vartype
+end function get_vartype
+!> @brief Gets varname
+!! @return copy of the variable name
+function get_varname (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ rslt = obj%varname
+end function get_varname
+!> @brief Gets longname
+!! @return copy of the variable long name or a single string if there is no long name
+function get_longname (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%longname)) then
+ rslt = obj%longname
+ else
+ rslt = diag_null_string
+ endif
+end function get_longname
+!> @brief Gets standname
+!! @return copy of the standard name or an empty string if standname is not allocated
+function get_standname (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%standname)) then
+ rslt = obj%standname
+ else
+ rslt = diag_null_string
+ endif
+end function get_standname
+!> @brief Gets units
+!! @return copy of the units or an empty string if not allocated
+function get_units (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%units)) then
+ rslt = obj%units
+ else
+ rslt = diag_null_string
+ endif
+end function get_units
+!> @brief Gets modname
+!! @return copy of the module name that the variable is in or an empty string if not allocated
+function get_modname (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%modname)) then
+ rslt = obj%modname
+ else
+ rslt = diag_null_string
+ endif
+end function get_modname
+!> @brief Gets realm
+!! @return copy of the variables modeling realm or an empty string if not allocated
+function get_realm (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%realm)) then
+ rslt = obj%realm
+ else
+ rslt = diag_null_string
+ endif
+end function get_realm
+!> @brief Gets err_msg
+!! @return copy of The error message stored in err_msg or an empty string if not allocated
+function get_err_msg (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%err_msg)) then
+ rslt = obj%err_msg
+ else
+ rslt = diag_null_string
+ endif
+end function get_err_msg
+!> @brief Gets interp_method
+!! @return copy of The interpolation method or an empty string if not allocated
+function get_interp_method (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%interp_method)) then
+ rslt = obj%interp_method
+ else
+ rslt = diag_null_string
+ endif
+end function get_interp_method
+!> @brief Gets frequency
+!! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated
+function get_frequency (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ integer, allocatable, dimension (:) :: rslt
+ if (allocated(obj%frequency)) then
+ allocate (rslt(size(obj%frequency)))
+ rslt = obj%frequency
+ else
+ allocate (rslt(1))
+ rslt = DIAG_NULL
+ endif
+end function get_frequency
+!> @brief Gets output_units
+!! @return copy of The units of the output or DIAG_NULL is output_units is not allocated
+function get_output_units (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ integer,allocatable, dimension (:) :: rslt
+ if (allocated(obj%output_units)) then
+ allocate (rslt(size(obj%output_units)))
+ rslt = obj%output_units
+ else
+ allocate (rslt(1))
+ rslt = DIAG_NULL
+ endif
+end function get_output_units
+!> @brief Gets t
+!! @return copy of t
+function get_t (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ integer :: rslt
+ if (allocated(obj%t)) then
+ rslt = obj%t
+ else
+ rslt = -999
+ endif
+end function get_t
+!> @brief Gets tile_count
+!! @return copy of the number of tiles or diag_null if tile_count is not allocated
+function get_tile_count (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ integer :: rslt
+ if (allocated(obj%tile_count)) then
+ rslt = obj%tile_count
+ else
+ rslt = DIAG_NULL
+ endif
+end function get_tile_count
+!> @brief Gets axis_ids
+!! @return copy of The axis IDs array or a diag_null if no axis IDs are set
+function get_axis_ids (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ integer, allocatable, dimension(:) :: rslt
+ if (allocated(obj%axis_ids)) then
+ allocate(rslt(size(obj%axis_ids)))
+ rslt = obj%axis_ids
+ else
+ allocate(rslt(1))
+ rslt = diag_null
+ endif
+end function get_axis_ids
+!> @brief Gets area
+!! @return copy of the area or diag_null if not allocated
+function get_area (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ integer :: rslt
+ if (allocated(obj%area)) then
+ rslt = obj%area
+ else
+ rslt = diag_null
+ endif
+end function get_area
+!> @brief Gets volume
+!! @return copy of the volume or diag_null if volume is not allocated
+function get_volume (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ integer :: rslt
+ if (allocated(obj%volume)) then
+ rslt = obj%volume
+ else
+ rslt = diag_null
+ endif
+end function get_volume
+!> @brief Gets missing_value
+!! @return copy of The missing value
+function get_missing_value (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ class(*),allocatable :: rslt
+ if (allocated(obj%missing_value)) then
+ select type (miss => obj%missing_value)
+ type is (integer(kind=i4_kind))
+ allocate (integer(kind=i4_kind) :: rslt)
+ rslt = miss
+ type is (integer(kind=i8_kind))
+ allocate (integer(kind=i8_kind) :: rslt)
+ rslt = miss
+ type is (real(kind=r4_kind))
+ allocate (integer(kind=i4_kind) :: rslt)
+ rslt = miss
+ type is (real(kind=r8_kind))
+ allocate (integer(kind=i4_kind) :: rslt)
+ rslt = miss
+ class default
+ call mpp_error ("get_missing_value", &
+ "The missing value is not a r8, r4, i8, or i4",&
+ FATAL)
+ end select
+ else
+ call mpp_error ("get_missing_value", &
+ "The missing value is not allocated", FATAL)
+ endif
+end function get_missing_value
+!> @brief Gets data_range
+!! @return copy of the data range
+function get_data_RANGE (obj) &
+result(rslt)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ class(*),allocatable :: rslt
+ if (allocated(obj%data_RANGE)) then
+ select type (r => obj%data_RANGE)
+ type is (integer(kind=i4_kind))
+ allocate (integer(kind=i4_kind) :: rslt)
+ rslt = r
+ type is (integer(kind=i8_kind))
+ allocate (integer(kind=i8_kind) :: rslt)
+ rslt = r
+ type is (real(kind=r4_kind))
+ allocate (integer(kind=i4_kind) :: rslt)
+ rslt = r
+ type is (real(kind=r8_kind))
+ allocate (integer(kind=i4_kind) :: rslt)
+ rslt = r
+ class default
+ call mpp_error ("get_data_RANGE", &
+ "The data_RANGE value is not a r8, r4, i8, or i4",&
+ FATAL)
+ end select
+ else
+ call mpp_error ("get_data_RANGE", &
+ "The data_RANGE value is not allocated", FATAL)
+ endif
+end function get_data_RANGE
+!> @brief Gets axis
+!! @return copy of axis information
+!! TODO
+!function get_axis (obj) &
+!result(rslt)
+! class (fmsDiagObject_type), intent(in) :: obj !< diag object
+! type (diag_axis_type), allocatable, dimension(:) :: rslt
+!
+!end function get_axis
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From f1c8961c7c4adb4310fe7bc2a4de631b84b29a88 Mon Sep 17 00:00:00 2001
From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com>
Date: Mon, 7 Feb 2022 13:37:31 -0500
Subject: [PATCH 029/168] fix: diag_manager container and linked list updates
and add test (#888)
---
diag_manager/diag_manager.F90 | 3 +-
diag_manager/fms_diag_dlinked_list.F90 | 509 +++++++++---------
diag_manager/fms_diag_object_container.F90 | 60 ++-
.../diag_manager/test_diag_dlinked_list.F90 | 123 ++---
.../test_diag_object_container.F90 | 45 +-
5 files changed, 389 insertions(+), 351 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 3d909b36da..b4ba4d5530 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -3974,7 +3974,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
END IF
!!Create the diag_object container; Its a singleton in the diag_data mod
- the_diag_object_container = FmsDiagObjectContainer_t()
+ allocate(the_diag_object_container)
+ call the_diag_object_container%initialize()
module_is_initialized = .TRUE.
! create axis_id for scalars here
diff --git a/diag_manager/fms_diag_dlinked_list.F90 b/diag_manager/fms_diag_dlinked_list.F90
index 99b4fb09ad..850a106b89 100644
--- a/diag_manager/fms_diag_dlinked_list.F90
+++ b/diag_manager/fms_diag_dlinked_list.F90
@@ -41,282 +41,297 @@
!> @addtogroup fms_diag_dlinked_list_mod
!> @{
MODULE fms_diag_dlinked_list_mod
- USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE
- implicit none
- !!TODO: COnsider setting the access (public,private) to functions, etc.
- !> The doubly-linked list node type.
- type, public:: FmsDlListNode_t
- private
- class(*), pointer :: data => null() !< The data pointed to by the node.
- type(FmsDlListNode_t), pointer :: next => null() !< A pointer to the previous node.
- type(FmsDlListNode_t), pointer :: prev => null() !< A pointer to the next node.
- end type FmsDlListNode_t
+ USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE
+ implicit none
+ !> The doubly-linked list node type.
+ type, public:: FmsDlListNode_t
+ private
+ class(*), pointer :: data_ptr => null() !< The data pointed to by the node.
+ type(FmsDlListNode_t), pointer :: next => null() !< A pointer to the previous node.
+ type(FmsDlListNode_t), pointer :: prev => null() !< A pointer to the next node.
+ end type FmsDlListNode_t
- !> Linked list iterator
- type, public :: FmsDllIterator_t
- private
- type(FmsDlListNode_t), pointer :: current !< A pointer to the current node.
- type(FmsDlListNode_t), pointer :: end !< A sentinel (non-data) node.
- contains
- procedure :: has_data => literator_has_data !< Function returns true is there is data in the iterator.
- procedure :: next => literator_next !< Function moves the iterator to the next data element.
- procedure :: get => literator_data !< Function return a pointer to the current data.
- procedure :: get_current_node_pointer => get_current_node_ptr !< Return the current node pointer.
- end type FmsDllIterator_t
+ !> Linked list iterator
+ type, public :: FmsDllIterator_t
+ private
+ type(FmsDlListNode_t), pointer :: current=>null() !< A pointer to the current node.
+ type(FmsDlListNode_t), pointer :: end =>null() !< A sentinel (non-data) node.
+ contains
+ procedure :: has_data => literator_has_data !< Function returns true if there is data in the iterator.
+ procedure :: next => literator_next !< Function moves the iterator to the next data element. Used in
+ !< conjunction with function has_data().
+ procedure :: get => literator_data !< Function return a pointer to the current data. Used in conjunction
+ !< with function has_data().
+ procedure :: get_current_node_pointer => get_current_node_ptr !< Return the current node pointer.
+ end type FmsDllIterator_t
- !> The doubly-linked list type. Besides the member functions, see the
- !! associated iterator class ( FmsDllIterator_t) for traversal, and note that
- !! the default constructor is overriden with an interface of the same name.
- type, public :: FmsDlList_t
- private
- type(FmsDlListNode_t), pointer :: head !< The sentinal (non-data) head node of the linked list. .
- type(FmsDlListNode_t), pointer :: tail !< The sentinel (non-data) tail node of the linked list.
- integer :: the_size !< The number of data elements in the linked list.
- contains
- procedure :: push_back => push_at_back
- procedure :: pop_back => pop_at_back
- procedure :: remove => remove_node
- procedure :: get_literator => get_forward_literator
- procedure :: size => get_size
- procedure :: is_empty => is_size_zero
- procedure :: clear => clear_all
- final :: destructor
- procedure :: insert => insert_data
+ !> The doubly-linked list type. Besides the member functions, see the
+ !! associated iterator class ( FmsDllIterator_t) for traversal, and note that
+ !! the default constructor is overriden with an interface of the same name.
+ type, public :: FmsDlList_t
+ private
+ type(FmsDlListNode_t), pointer :: head=>null() !< The sentinal (non-data) head node of the linked list. .
+ type(FmsDlListNode_t), pointer :: tail=>null() !< The sentinel (non-data) tail node of the linked list.
+ integer :: the_size !< The number of data elements in the linked list.
+ contains
+ procedure :: push_back => push_at_back
+ procedure :: pop_back => pop_at_back
+ procedure :: remove => remove_node
+ procedure :: get_literator => get_forward_literator
+ procedure :: size => get_size
+ procedure :: is_empty => is_size_zero
+ procedure :: clear => clear_all
+ procedure :: initialize => linked_list_initializer
+ final :: destructor
+ procedure :: insert => insert_data
- end type FmsDlList_t
+ end type FmsDlList_t
- interface FmsDlListNode_t
- module procedure :: node_constructor
- end interface FmsDlListNode_t
+ interface FmsDlList_t
+ module procedure :: linked_list_constructor
+ end interface FmsDlList_t
- interface FmsDlList_t
- module procedure :: linked_list_constructor
- end interface FmsDlList_t
-
- interface FmsDllIterator_t
- module procedure :: literator_constructor
- end interface FmsDllIterator_t
+ interface FmsDllIterator_t
+ module procedure :: literator_constructor
+ end interface FmsDllIterator_t
contains
- !> @brief Insert data d in a new node to be placed in front of the
- !! target node t_nd.
- !! @return Returns an iterator that starts with the newly inserted node.
- function insert_data( this, t_nd, d ) result(liter)
- class(FmsDlList_t), intent(in out) :: this ! d
- !! Insert nd into list so that list section [prev node <--> target node ] looks like
- !! [prev node <--> new nd <--> target node]. The four pointers pointing to and/or
- !! from "new nd" need to be set. Therefore :
- !! a) The new nd's prev needs to be whatever was the targets prev:
- nd%prev => t_nd%prev
- !! b) New node nd's next is obviously the target node:
- nd%next => t_nd
- !! c) the next of the prev node needs to point to the new node nd:
- t_nd%prev%next => nd
- !! d) target node's prev needs to point to the new node :
- t_nd%prev => nd
- this%the_size = this%the_size + 1
- liter = FmsDllIterator_t(nd, this%tail)
- end function insert_data
+ !> @brief Insert data d in a new node to be placed in front of the
+ !! target node t_nd.
+ !! @return Returns an iterator that starts with the newly inserted node.
+ function insert_data( this, t_nd, d ) result(liter)
+ class(FmsDlList_t), intent(in out) :: this ! d
+ !! Insert nd into list so that list section [prev node <--> target node ] looks like
+ !! [prev node <--> new nd <--> target node]. The four pointers pointing to and/or
+ !! from "new nd" need to be set. Therefore :
+ !! a) The new nd's prev needs to be whatever was the targets prev:
+ nd%prev => t_nd%prev
+ !! b) New node nd's next is obviously the target node:
+ nd%next => t_nd
+ !! c) the next of the prev node needs to point to the new node nd:
+ t_nd%prev%next => nd
+ !! d) target node's prev needs to point to the new node :
+ t_nd%prev => nd
+ this%the_size = this%the_size + 1
+ liter = FmsDllIterator_t(nd, this%tail)
+ end function insert_data
+
+ !> @brief Remove Node nd from the linked tree.
+ !! @return Return the iterator that begins with the next node after nd, and ends with
+ !! the list end node. Returns the list iterator if the node cannot be removed.
+ function remove_node( this, nd ) result( litr)
+ class(FmsDlList_t), intent(in out) :: this ! nd%next
+ nd%next%prev => nd%prev
+ deallocate(nd)
+ this%the_size = this%the_size - 1
+ else
+ litr = this%get_literator()
+ endif
+ end function remove_node
- !> @brief Remove Node nd from the linked tree.
- !! @return Return the iterator that begins with the next node after nd, and ends with
- !! the list end node. Returns the list iterator if the node cannot be removed.
- function remove_node( this, nd ) result( litr)
- class(FmsDlList_t), intent(in out) :: this ! nd%next
- nd%next%prev => nd%prev
- deallocate(nd)
- this%the_size = this%the_size - 1
- else
- litr = this%get_literator()
- endif
- end function remove_node
+ !> @brief Remove the tail (last data node) of the list.
+ !! @return Returns an iterator to the remaining list.
+ function pop_at_back (this ) result( liter )
+ class(FmsDlList_t), intent(in out) :: this ! this%tail%prev
+ liter = this%remove( nd )
+ else
+ liter = this%get_literator()
+ endif
+ end function pop_at_back
- !> @brief Remove the tail (last data node) of the list.
- !! @return Returns an iterator to the remaining list.
- function pop_at_back (this ) result( liter )
- class(FmsDlList_t), intent(in out) :: this ! this%tail%prev
- liter = this%remove( nd )
- else
- liter = this%get_literator()
- endif
- end function pop_at_back
+ !> @brief Push (insert) data at the end of the list
+ !> @return Returns an iterator that starts at the tail of the list.
+ function push_at_back( this, d ) result(litr)
+ class(FmsDlList_t), intent(in out) :: this ! @brief Push (insert) data at the end of the list
- !> @return Returns an iterator that starts at the tail of the list.
- function push_at_back( this, d ) result(litr)
- class(FmsDlList_t), intent(in out) :: this ! @brief Constructor for the linked list.
+ !! @return Returns a newly allocated linked list instance.
+ !! TODO: This function is not used since (observed on Intel compilers) with
+ !! a finalize keyword on the destructor, when this function returns and ll
+ !! goes out of scope, th allocations in initialized are undome
+ !! whether ot not ll is declared a pointer or allocatable
+ function linked_list_constructor () result (ll)
+ type(FmsDlList_t), pointer :: ll !< The resultant linked list to be reutrned.
+ allocate(ll)
+ call ll%initialize()
+ end function linked_list_constructor
- !> @brief Constructor for the node_type
- !! @return Returns a nully allocated node.
- function node_constructor () result (nd)
- type(FmsDlListNode_t), allocatable :: nd !< The allocated node.
- allocate(nd)
- nd%data => null()
- nd%prev => null()
- nd%next => null()
- end function node_constructor
+ !> @brief Initializer for the linked list.
+ !! @return Returns a newly allocated linked list instance.
+ subroutine linked_list_initializer( this )
+ class(FmsDlList_t), intent(inout) :: this ! this%tail
+ this%tail%prev => this%head
+ this%the_size = 0
+ endif
+ end subroutine linked_list_initializer
- !> @brief Constructor for the linked list.
- !! @return Returns a newly allocated linked list instance.
- function linked_list_constructor () result (ll)
- type(FmsDlList_t), allocatable :: ll !< The resultant linked list to be reutrned.
- allocate(ll)
- allocate(ll%head)
- allocate(ll%tail)
- !!print *, 'associated(ll%head) :' , associated(ll%head), &
- !! ' associated(ll%head) :' , associated(ll%head)
- ll%head%next => ll%tail
- ll%tail%prev => ll%head
- ll%the_size = 0
- end function linked_list_constructor
- !> @brief The list iterator constructor.
- !! @return Returns a newly allocated list iterator.
- function literator_constructor ( fnd, tnd ) result (litr)
- type (FmsDlListNode_t), pointer :: fnd
- !< The sentinal (non-data) "first node" of the iterator will be fnd
- type (FmsDlListNode_t), pointer :: tnd
- !< The sentinal (non-data) "last node" of the iterator will be tnd.
- type (FmsDllIterator_t), allocatable :: litr !< The resultant linked list to be reutrned.
- allocate(litr)
- litr%current => fnd
- litr%end => tnd
- end function literator_constructor
+ !> @brief The list iterator constructor.
+ !! @return Returns a newly allocated list iterator.
+ function literator_constructor ( fnd, tnd ) result (litr)
+ type (FmsDlListNode_t), pointer :: fnd
+ !< The sentinal (non-data) "first node" of the iterator will be fnd
+ type (FmsDlListNode_t), pointer :: tnd
+ !< The sentinal (non-data) "last node" of the iterator will be tnd.
+ type (FmsDllIterator_t), allocatable :: litr !< The resultant linked list to be reutrned.
+ allocate(litr)
+ litr%current => fnd
+ litr%end => tnd
+ end function literator_constructor
- !> @brief Getter for the size (the number of data elements) of the linked list.
- !! @return Returns the size of the lined list.
- function get_size (this) result (sz)
- class(FmsDlList_t), intent(in out) :: this
- ! @brief Getter for the size (the number of data elements) of the linked list.
+ !! @return Returns the size of the lined list.
+ function get_size (this) result (sz)
+ class(FmsDlList_t), intent(in out) :: this
+ ! @brief Determines if the size (number of data elements) of the list is zero.
!! @return Returns true if there are zero (0) data elements in the list; false otherwise.
- function is_size_zero (this) result (r)
- class(FmsDlList_t), intent(in out) :: this
- ! @brief Create and return a new forward iterator for the list.
- !> @return Returns a forward iterator for the linked list.
- function get_forward_literator(this) result (litr)
- class(FmsDlList_t), intent(in) :: this ! @brief Create and return a new forward iterator for the list.
+ !> @return Returns a forward iterator for the linked list.
+ function get_forward_literator(this) result (litr)
+ class(FmsDlList_t), intent(in) :: this ! @brief Determine if the iterator has data.
- !> @return Returns true iff the iterator has data.
- function literator_has_data( this ) result( r )
- class(FmsDllIterator_t), intent(in) :: this
- ! @brief Determine if the iterator has data.
+ !> @return Returns true iff the iterator has data.
+ function literator_has_data( this ) result( r )
+ class(FmsDllIterator_t), intent(in) :: this
+ ! @brief Move the iterators current data node pointer to the next data node.
- !! @return Returns a status of 0 if succesful, -1 otherwise.
- function literator_next( this ) result( status )
- class(FmsDllIterator_t), intent(in out ) :: this
- integer :: status !< The returned status. Failure possible is if iterator does not have data.
- status = -1
- if(this%has_data() .eqv. .true.) then
- this%current => this%current%next
- status = 0
- endif
- end function literator_next
+ !> @brief Move the iterators current data node pointer to the next data node.
+ !! @return Returns a status of 0 if succesful, -1 otherwise.
+ function literator_next( this ) result( status )
+ class(FmsDllIterator_t), intent(in out ) :: this
+ integer :: status !< The returned status. Failure possible is if iterator does not have data.
+ status = -1
+ if(this%has_data() .eqv. .true.) then
+ this%current => this%current%next
+ status = 0
+ endif
+ end function literator_next
- !> @brief Get the current data object pointed to by the iterator.
- !! function does not allocate or assign the result if
- !! the user mistakenly called it without data present.
- !! @return Returns a pointer to the current data.
- function literator_data( this ) result( rd )
- class(FmsDllIterator_t), intent(in) :: this ! null()
- if (this%has_data() .eqv. .true.) then
- rd => this%current%data
- endif
- end function literator_data
+ !> @brief Get the current data object pointed to by the iterator.
+ !! function does not allocate or assign the result if
+ !! the user mistakenly called it without data present.
+ !! @return Returns a pointer to the current data.
+ function literator_data( this ) result( rd )
+ class(FmsDllIterator_t), intent(in) :: this ! null()
+ if (this%has_data() .eqv. .true.) then
+ rd => this%current%data_ptr
+ endif
+ end function literator_data
-!> @brief Get the current data object pointed to by the iterator.
- !! function does not allocate or assign the result if
- !! the user mistakenly called it without data present.
- !! @return Returns a pointer to the current data.
- function get_current_node_ptr( this ) result( pn )
- class(FmsDllIterator_t), intent(in) :: this ! this%current
- end function get_current_node_ptr
+ !> @brief Get the current data object pointed to by the iterator.
+ !! function does not allocate or assign the result if
+ !! the user mistakenly called it without data present.
+ !! @return Returns a pointer to the current data.
+ function get_current_node_ptr( this ) result( pn )
+ class(FmsDllIterator_t), intent(in) :: this ! this%current
+ end function get_current_node_ptr
- !> @brief Iterate over all the nodes, remove them and deallocate the client data
- !! that the node was holding.
- subroutine clear_all( this )
- class(FmsDlList_t), intent(inout) :: this ! this%head%next
- iter = this%remove(nd)
- pdata => iter%get()
- if (associated(pdata) .eqv. .false.) then
- call error_mesg ('doubly_linked_list:clear_all', &
- 'linked list destructor containes unassociated data pointer', &
- WARNING)
- else
- deallocate(pdata)
+ !> @brief Iterate over all the nodes and remove them. Also (by overridable default), it deallocates the
+ !! client data associated with the nodes.
+ subroutine clear_all( this, data_dealloc_flag)
+ class(FmsDlList_t), intent(inout) :: this !null() !< A pointer to the data.
+ logical :: data_dealloc_f !< Set to data_dealloc_flag if present, otherwise its .true.
+ !
+ data_dealloc_f = .true.
+ if( PRESENT(data_dealloc_flag) ) then
+ data_dealloc_f = data_dealloc_flag
endif
- end do
- end subroutine clear_all
+ do while( this% the_size /= 0)
+ nd => this%head%next
+ pdata => nd%data_ptr
+ iter = this%remove(nd)
+ if(data_dealloc_f .eqv. .true.) then
+ if (associated(pdata) .eqv. .false.) then
+ call error_mesg ('fms_diag_dlinked_list', &
+ 'In clear_all; linked node contains node with unassociated data pointer', &
+ WARNING)
+ else
+ deallocate(pdata)
+ endif
+ endif
+ end do
+ end subroutine clear_all
- !> @brief A destructor that deallocates every node and each nodes data element.
- subroutine destructor(this)
+ !> @brief A destructor that deallocates every node and each nodes data element. !Note
+ !! that for the data elements to not be de-allocated, function clear() (or clear_all() )
+ !! with the appropriate arguments must be called.
+ subroutine destructor(this)
type(FmsDlList_t) :: this !null()
+ deallocate(this%tail)
+ this%tail=>null()
+ end subroutine destructor
end module fms_diag_dlinked_list_mod
!> @}
diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90
index b3fdae819c..fe71b7a6ef 100644
--- a/diag_manager/fms_diag_object_container.F90
+++ b/diag_manager/fms_diag_object_container.F90
@@ -56,13 +56,15 @@ MODULE fms_diag_object_container_mod
!!
type, public:: FmsDiagObjectContainer_t
private
- TYPE (FmsDlList_t), ALLOCATABLE :: the_linked_list !< This version based on the FDS linked_list.
+ TYPE (FmsDlList_t), pointer :: the_linked_list => null() !< This version based on the FDS linked_list.
contains
procedure :: insert => insert_diag_object
procedure :: remove => remove_diag_object
procedure :: find => find_diag_object
procedure :: size => get_num_objects
procedure :: iterator => get_iterator
+ procedure :: initialize => container_initializer
+ procedure :: clear => clear_all
final :: destructor
end type FmsDiagObjectContainer_t
@@ -72,15 +74,13 @@ MODULE fms_diag_object_container_mod
private
type(FmsDllIterator_t) :: liter !< This version based on the FDS linked_list (and its iterator).
contains
- procedure :: has_data => literator_has_data
- procedure :: next => literator_next
- procedure :: get => literator_data
+ procedure :: has_data => literator_has_data !< Function returns true if there is data in the iterator.
+ procedure :: next => literator_next !< Function moves the iterator to the next data element. Used in
+ !< conjunction with function has_data().
+ procedure :: get => literator_data !< Function return a pointer to the current data. Used in conjunction
+ !< with function has_data().
end type FmsDiagObjIterator_t
- interface FmsDiagObjectContainer_t
- module procedure :: diag_object_container_constructor
- end interface FmsDiagObjectContainer_t
-
interface FmsDiagObjIterator_t
module procedure :: diag_obj_iterator_constructor
end interface FmsDiagObjIterator_t
@@ -202,10 +202,21 @@ end function diag_obj_iterator_constructor
function diag_object_container_constructor () result (doc)
type(FmsDiagObjectContainer_t), allocatable :: doc !< The resultant container.
allocate(doc)
- doc%the_linked_list = FmsDlList_t()
- !! print * , "In DOC constructor"
+ doc%the_linked_list => null()
+ allocate(doc%the_linked_list)
+ call doc%the_linked_list%initialize
end function diag_object_container_constructor
+ subroutine container_initializer( this )
+ class(FmsDiagObjectContainer_t), intent(inout) :: this
+ if( associated(this%the_linked_list) ) then
+ call error_mesg('fms_diag_object_container:','container is already initialized', WARNING)
+ else
+ allocate(this%the_linked_list)
+ call this%the_linked_list%initialize()
+ endif
+ end subroutine container_initializer
+
!> @brief Determines if there is more data that can be accessed via the iterator.
!> @return Returns true iff more data can be accessed via the iterator.
function literator_has_data( this ) result( r )
@@ -236,22 +247,41 @@ function literator_data( this ) result( rdo )
class(*), pointer :: gp !< A eneric typed object in the container.
rdo => null()
- gp => this%liter%get()
+ gp => this%liter%get()
select type(gp)
type is (fmsDiagObject_type) !! "type is", not the (polymorphic) "class is"
rdo => gp
class default
- CALL error_mesg ('diag_object_container:literator_data', &
- 'Data to be accessed via iterator is not of expected type.',FATAL)
+ call error_mesg ('fms_diag_object_container:', &
+ 'In literator_data, data to be accessed is not of expected type.',FATAL)
end select
end function literator_data
- !> @brief The destructor for the container.
+ !> @brief Iterate over all the nodes and remove them. Also (by overridable default), it deallocates the
+ !! client data associated with the nodes.
+ subroutine clear_all( this, data_dealloc_flag )
+ class(FmsDiagObjectContainer_t), intent(inout) :: this ! @brief A destructor that deallocates every node and each nodes data element. !Note
+ !! that for the data elements to not be de-allocated, function clear() with the
+ !! appropriate arguments must be called.
subroutine destructor(this)
type(FmsDiagObjectContainer_t) :: this
!null()
end subroutine destructor
diff --git a/test_fms/diag_manager/test_diag_dlinked_list.F90 b/test_fms/diag_manager/test_diag_dlinked_list.F90
index 4dff25a97a..355733b6bd 100644
--- a/test_fms/diag_manager/test_diag_dlinked_list.F90
+++ b/test_fms/diag_manager/test_diag_dlinked_list.F90
@@ -33,10 +33,9 @@
!! class in the book ``Data Structures And Algorithm Analysis in C++",
!! 3rd Edition, by Mark Allen Weiss.
program test_diag_dlinked_list
- use mpp_mod, only: mpp_init, mpp_exit, mpp_error, FATAL, WARNING
- use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated
+ use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated
use mpp_io_mod, only: mpp_io_init
-
+ use fms_mod, ONLY: error_mesg, FATAL,NOTE
use fms_diag_object_mod, only : fmsDiagObject_type
use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t
@@ -45,7 +44,7 @@ program test_diag_dlinked_list
!> @brief This class is the type for the data to insert in the linked list.
type TestDummy_t
integer :: id = 0
- character(len=20) :: name
+ real :: weight = 1000
end type TestDummy_t
!!
@@ -61,27 +60,27 @@ program test_diag_dlinked_list
logical :: test_passed !< Flag indicating if the test_passed
!! These fields below used to initialize diag object data. TBD
integer :: id
- character(:), allocatable :: mname, mname_pre
!!
-
- test_passed = .true. !! will be set to false if there are any issues.
-
call mpp_init(mpp_init_test_requests_allocated)
call mpp_io_init()
call mpp_set_stack_size(145746)
+ call error_mesg("test_diag_linked_list", "Starting tests",NOTE)
+
+ test_passed = .true. !! will be set to false if there are any issues.
+
!! Ids will initially be from 1 to num_objs, so :
full_id_sum = (num_objs * (num_objs + 1)) / 2
- !!Create the list
- list = FmsDlList_t()
+ !! Create the list
+ allocate(list)
+ call list%initialize()
if( list%size() /= 0) then
- test_passed = .false.
- call mpp_error(FATAL, "list incorrect size. Expected 0 at start")
+ test_passed = .false.
+ call error_mesg("test_diag_linked_list", "list incorrect size. Expected 0 at start",FATAL)
endif
- mname_pre = "ATM"
!! Initialize num_objs objects and insert into list one at a time.
!! The loop iterator is same as id - created in order to facilitate
@@ -90,9 +89,8 @@ program test_diag_dlinked_list
!!Allocate on heap another test dummy object :
allocate (p_td_obj)
!! And set some of its dummy data :
- call combine_str_int(mname_pre, id, mname)
p_td_obj%id = id
- p_td_obj%name = mname
+ p_td_obj%weight = id + 1000
!! And have the "Char(*) pointer also point to it:
p_obj => p_td_obj
@@ -100,14 +98,14 @@ program test_diag_dlinked_list
iter = list%push_back( p_obj)
if(iter%has_data() .eqv. .false. ) then
test_passed = .false.
- call mpp_error(FATAL, "List push_back error.")
+ call error_mesg("test_diag_dlinked_list", "List push_back error.",FATAL)
endif
enddo
if( list%size() /= num_objs) then
test_passed = .false.
- call mpp_error(FATAL, "List has incorrect size after inserts.")
+ call error_mesg("test_diag_dlinked_list", "List has incorrect size after inserts.",FATAL)
endif
@@ -117,24 +115,27 @@ program test_diag_dlinked_list
if( sum /= full_id_sum) then
test_passed = .false.
- call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected")
+ call error_mesg("test_diag_dlinked_list", &
+ &"Id sums via iteration over the list objects is not as expected",FATAL)
endif
if( list%size() /= num_objs) then
test_passed = .false.
- call mpp_error(FATAL, "The list size is not as expected post inserts.")
+ call error_mesg("test_diag_dlinked_list", &
+ &"The list size is not as expected post inserts.",FATAL)
endif
!! Test a removal from the back (id should be num_objs)
p_obj => find_back_of_list( list)
- iter = list%pop_back()
+ iter = list%pop_back()
!! Note the client is resposible for managing memory of anything he explicitly
!! removes from the list:
deallocate(p_obj)
sum = sum_ids_in_list ( list )
if( sum /= full_id_sum - num_objs ) then
test_passed = .false.
- call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected")
+ call error_mesg("test_diag_dlinked_list", &
+ &"Id sums via iteration over the list objects is not as expected",FATAL)
endif
!! Repeat - test removal from the back of list (should be (num_objs -1)).
@@ -146,93 +147,81 @@ program test_diag_dlinked_list
sum = sum_ids_in_list ( list )
if( sum /= (full_id_sum - num_objs - (num_objs -1) )) then
test_passed = .false.
- call mpp_error(FATAL, "Id sums via iteration over the list objects is not as expected")
+ call error_mesg("test_diag_dlinked_list", &
+ & "Id sums via iteration over the list objects is not as expected",FATAL)
endif
+ !! List.clear() is called by the destructor automatically, but for further testing
+ !! we will use it to renove (and deallocate) the data nodes and associated data
+ !! of the list.
call list%clear()
if( list%size() /= 0) then
test_passed = .false.
- call mpp_error(FATAL, "List is incorrect size after clearing.")
+ call error_mesg("test_diag_dlinked_list", &
+ "List is incorrect size after clearing.",FATAL)
endif
- write (6,*) "Finishing diag_dlinked_list tests."
-
- !! the list has a finalize/destructor which will deallocate data that is still it list.
- !! equivalent to calling list%clear() as above.
+ !! Allocated objects are deallocated automatically, but one can aslo make the call.
deallocate(list)
+ call error_mesg('test_diag_dlinked_list', 'Test has finished',NOTE)
+
call MPI_finalize(ierr)
CONTAINS
-
-
!> @brief Cast the "class(*) input data to the expected type.
- function get_typed_data( data_in ) result( rdo )
- class(*), intent(in), pointer :: data_in !< An input pointer to the class(*) object.
- class(TestDummy_t), pointer :: rdo !< The resultant pointer to the expected underlying object type.
- rdo => null()
-
- select type(data_in)
+ function get_typed_data( pci ) result( pdo )
+ class(*), intent(in), pointer :: pci !< An input pointer to the class(*) data object.
+ class(TestDummy_t), pointer :: pdo !< The resultant pointer to the expected underlying object type.
+ !
+ pdo => null()
+ select type(pci)
type is (TestDummy_t) !! "type is", not the (polymorphic) "class is"
- rdo => data_in
+ pdo => pci
class default
- call mpp_error(FATAL, "Data to access is not of expected type.",FATAL)
+ call error_mesg("test_diag_dlinked_list", &
+ & "Data to access is not of expected type.",FATAL)
end select
end function get_typed_data
!> Calcualte the sum of the ids.
!! Exercises iteration over the list.
- function sum_ids_in_list (list) result (rsum)
- type (FmsDlList_t), allocatable :: list !< The linked list instance
+ function sum_ids_in_list (the_list) result (rsum)
+ type (FmsDlList_t), intent(inout) , allocatable :: the_list !< The linked list instance
integer :: rsum !< The resultant sum of ids
class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list
- type (TestDummy_t), pointer:: p_td_obj !< A pointer to a test_dummy object
- class(*), pointer :: p_obj !< A pointer to a class(*) object
- integer :: ic_status !< A list insertion status.
+ type (TestDummy_t), pointer:: p_td_obj => null() !< A pointer to a test_dummy object
+ class(*), pointer :: p_obj => null() !< A pointer to a class(*) object
+ integer :: ic_status !< A list insertion status.
!!
rsum = 0
- iter = list%get_literator()
+ iter = the_list%get_literator()
do while( iter%has_data() .eqv. .true.)
p_obj => iter%get()
p_td_obj => get_typed_data (p_obj )
- id = p_td_obj%id
- rsum = rsum + id
+ rsum = rsum + p_td_obj%id
ic_status = iter%next()
end do
end function sum_ids_in_list
- !> Calcualate the sum of the ids. This also is a kind of search function,
+ !> Find the past object in list. This also is a kind of search function,
!! so if the provided wrapper is not used, you have to write your own.
!! @return a pointer the object at the end of the list, or null if none
- function find_back_of_list (list) result (p_rdo)
- type (FmsDlList_t), allocatable :: list !< The linked list instance
- class(TestDummy_t), pointer :: p_rdo !< The resultant back of list,
+ function find_back_of_list (the_list) result (pdo)
+ type (FmsDlList_t), intent(inout) , allocatable ::the_list !< The linked list instance
+ class(TestDummy_t), pointer :: pdo !< The resultant back of list,
class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list
- class(*), pointer :: p_obj !< A pointer to a class(*) object
+ class(*), pointer :: p_obj => null() !< A pointer to a class(*) object
integer :: ic_status !< A list insertion status.
!!
- p_rdo => null()
- iter = list%get_literator()
+ pdo=>null()
+ iter = the_list%get_literator()
do while( iter%has_data() .eqv. .true.)
p_obj => iter%get()
- p_rdo => get_typed_data (p_obj )
+ pdo => get_typed_data (p_obj )
ic_status = iter%next()
end do
end function find_back_of_list
- subroutine combine_str_int (str, num, rs)
- character(:), allocatable, intent (in):: str
- integer , intent (in) :: num
- character(:), allocatable, intent (out) :: rs
- character(len_trim(str) + 8) :: tmp
-
- write (tmp, "(A4,I4)") str,num
- tmp = trim(tmp)
- rs = tmp
- end subroutine combine_str_int
-
-
end program test_diag_dlinked_list
-
-
diff --git a/test_fms/diag_manager/test_diag_object_container.F90 b/test_fms/diag_manager/test_diag_object_container.F90
index 9a5b8e3251..e55b3fa30b 100644
--- a/test_fms/diag_manager/test_diag_object_container.F90
+++ b/test_fms/diag_manager/test_diag_object_container.F90
@@ -24,9 +24,9 @@
!! functions being tested are insert, remove, and size. The use of the iterators
!! is also being tested.
program test_diag_obj_container
- use mpp_mod, only: mpp_init, mpp_exit, mpp_error, FATAL, WARNING
- use mpp_mod, only : mpp_set_stack_size, mpp_init_test_requests_allocated
+ use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated
use mpp_io_mod, only: mpp_io_init
+ use fms_mod, ONLY: error_mesg, FATAL,NOTE
use fms_diag_object_mod, only : fmsDiagObject_type
use fms_diag_object_container_mod, only : FmsDiagObjectContainer_t, FmsDiagObjIterator_t
@@ -55,17 +55,20 @@ program test_diag_obj_container
!!
- test_passed = .true. !! will be set to false if there are any issues.
-
call mpp_init(mpp_init_test_requests_allocated)
call mpp_io_init()
call mpp_set_stack_size(145746)
+ call error_mesg('test_diag_object_container', 'Test has started',NOTE)
+
+ test_passed = .true. !! will be set to false if there are any issues.
+
!! Ids will initially be from 1 to num_objs, so :
full_id_sum = (num_objs * (num_objs + 1)) / 2
!!Create the container
- container = FmsDiagObjectContainer_t()
+ allocate(container)
+ call container%initialize()
!!In diag_manager, one module level container may be used instead of a local one like above.
@@ -85,7 +88,7 @@ program test_diag_obj_container
if( container%size() /= 0) then
test_passed = .false.
- call mpp_error(FATAL, "Container incorrect size. Expected 0 at start")
+ call error_mesg('test_diag_object_container', 'Container incorrect size. Expected 0 at start',FATAL)
endif
mname_pre = "ATM"
vname_pre = "xvar"
@@ -102,27 +105,27 @@ program test_diag_obj_container
ic_status = container%insert(pobj%get_id(), pobj)
if(ic_status .ne. 0)then
test_passed = .false.
- call mpp_error(FATAL, "Container Insertion error.")
+ call error_mesg('test_diag_object_container', 'Container Insertion error.',FATAL)
endif
enddo
if( container%size() /= num_objs) then
test_passed = .false.
- call mpp_error(FATAL, "Container has incorrect size after inserts.")
+ call error_mesg('test_diag_object_container', 'Container has incorrect size after inserts.',FATAL)
endif
!!Search the container for a an object of specified key
iter = container%find(123)
if ( iter%has_data() .eqv. .true. ) then
test_passed = .false.
- call mpp_error(FATAL, "Found in container unexpected object of id=123")
+ call error_mesg('test_diag_object_container', 'Found in container unexpected object of id=123',FATAL)
endif
!!Again, search the container for a an object of specified key
iter = container%find(4)
if (iter%has_data() .neqv. .true. ) then
test_passed = .false.
- call mpp_error(FATAL, "Did not find expected container object of id=4")
+ call error_mesg('test_diag_object_container', 'Did not find expected container object of id=4',FATAL)
endif
!! Iterate over all the objects in the container;
@@ -138,12 +141,12 @@ program test_diag_obj_container
if( sum /= full_id_sum) then
test_passed = .false.
- call mpp_error(FATAL, "Id sums via iteration over the container objects is not as expected")
+ call error_mesg('test_diag_object_container', 'Id sums via iteration over the container objects is not as expected',FATAL)
endif
if( container%size() /= num_objs) then
test_passed = .false.
- call mpp_error(FATAL, "The container size is not as expected post inserts.")
+ call error_mesg('test_diag_object_container', 'The container size is not as expected post inserts.',FATAL)
endif
@@ -154,12 +157,12 @@ program test_diag_obj_container
!! Verify the removal , part 1:
if ( iter%has_data() .eqv. .true.) then
test_passed = .false.
- call mpp_error(FATAL, "Found object of id = 4 after removing it")
+ call error_mesg('test_diag_object_container', 'Found object of id = 4 after removing it',FATAL)
endif
!! Verify the removal , part 2 :
if (container%size() /= (num_objs - 1)) then
test_passed = .false.
- call mpp_error(FATAL,"The_container%size() \= num_obj -1 after a removal ")
+ call error_mesg('test_diag_object_container','The_container%size() \= num_obj -1 after a removal ',FATAL)
endif
!! Verify the removal , part 3 :
@@ -175,7 +178,7 @@ program test_diag_obj_container
end do
if( sum /= full_id_sum - 4) then
test_passed = .false.
- call mpp_error(FATAL, "Container incorrect id sums post removal of 4")
+ call error_mesg('test_diag_object_container', 'Container incorrect id sums post removal of 4',FATAL)
endif
!! End test a removal ****
@@ -183,13 +186,13 @@ program test_diag_obj_container
iter = container%find(7)
if (iter%has_data() .neqv. .true. ) then
test_passed = .false.
- call mpp_error(FATAL, "Container did not find object of id=7")
+ call error_mesg('test_diag_object_container', 'Container did not find object of id=7',FATAL)
endif
!! Check the find results more :
pobj => iter%get()
if(pobj%get_id() /= 7) then
test_passed = .false.
- call mpp_error(FATAL," Id of returned object was not 7 ")
+ call error_mesg('test_diag_object_container', 'Id of returned object was not 7 ',FATAL)
endif
!!TODO further access tests.
@@ -209,13 +212,13 @@ program test_diag_obj_container
if( container%size() /= 0) then
test_passed = .false.
- call mpp_error(FATAL, "Container is incorrect size after clearing.")
+ call error_mesg('test_diag_object_container', 'Container is incorrect size after clearing.',FATAL)
endif
- write (6,*) "Finishing diag_obj_container tests."
+ !! And the container has a finalize/destructor which will deallocate the list and data.
+ deallocate(container)
- !! the container has a finalize/destructor which will
-deallocate(container)
+ call error_mesg('test_diag_object_container', 'Test has finished',NOTE)
call MPI_finalize(ierr)
From fd32093dae2d9a1bcf1871863ecd111e2fe9afb8 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 7 Feb 2022 14:27:44 -0500
Subject: [PATCH 030/168] feat: Moves fms_diag_yaml_obj to fms_diag_yaml and
updates test (#887)
---
CMakeLists.txt | 1 -
diag_manager/Makefile.am | 8 +-
diag_manager/fms_diag_object.F90 | 6 +-
diag_manager/fms_diag_yaml.F90 | 360 ++++++++++++++++++++++-
diag_manager/fms_diag_yaml_object.F90 | 354 ----------------------
test_fms/diag_manager/test_diag_yaml.F90 | 10 +-
6 files changed, 366 insertions(+), 373 deletions(-)
delete mode 100644 diag_manager/fms_diag_yaml_object.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 28469988f7..d667f6163a 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -132,7 +132,6 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_bbox.F90
diag_manager/fms_diag_object.F90
diag_manager/fms_diag_yaml.F90
- diag_manager/fms_diag_yaml_object.F90
diag_manager/fms_diag_dlinked_list.F90
diag_manager/fms_diag_object_container.F90
drifters/cloud_interpolator.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index d9fec6ef63..78589bb69b 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -47,7 +47,6 @@ libdiag_manager_la_SOURCES = \
include/fms_diag_fieldbuff_update.fh
fms_diag_yaml.F90 \
fms_diag_object.F90 \
- fms_diag_yaml_object.F90 \
fms_diag_object_container.F90 \
fms_diag_dlinked_list.F90
@@ -58,10 +57,8 @@ diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODE
diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \
diag_grid_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
-fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
- fms_diag_yaml_object_mod.$(FC_MODEXT)
-fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) \
- fms_diag_yaml_object_mod.$(FC_MODEXT)
+fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
+fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
@@ -84,7 +81,6 @@ MODFILES = \
diag_manager_mod.$(FC_MODEXT) \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh
- fms_diag_yaml_object_mod.$(FC_MODEXT) \
fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) \
fms_diag_dlinked_list_mod.$(FC_MODEXT) \
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 90d1904fe7..bb08c464f2 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -13,7 +13,9 @@ module fms_diag_object_mod
use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
-use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type
+#ifdef use_yaml
+use fms_diag_yaml_mod, only: diagYamlFiles_type, diagYamlFilesVar_type
+#endif
use time_manager_mod, ONLY: time_type
!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
@@ -58,8 +60,10 @@ module fms_diag_object_mod
!> \brief Object that holds all variable information
type fmsDiagObject_type
+#ifdef use_yaml
type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table
type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table
+#endif
integer, allocatable, private :: diag_id !< unique id for varable
class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the
!! file objects for this variable
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 6e184bfc58..22d344ec39 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -30,11 +30,10 @@
!> @{
module fms_diag_yaml_mod
#ifdef use_yaml
-use fms_diag_yaml_object_mod, only: diagYamlFiles_type, diagYamlFilesVar_type, diag_yaml_files_obj_init, &
- NUM_SUB_REGION_ARRAY
-use diag_data_mod, only: DIAG_NULL
-use yaml_parser_mod
-use mpp_mod
+use diag_data_mod, only: DIAG_NULL
+use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
+ get_block_ids, get_key_value, get_key_ids, get_key_name
+use mpp_mod, only: mpp_error, FATAL
implicit none
@@ -42,9 +41,116 @@ module fms_diag_yaml_mod
public :: diag_yaml_object_init, diag_yaml_object_end
public :: diagYamlObject_type, get_diag_yaml_obj, get_title, get_basedate, get_diag_files, get_diag_fields
+public :: diagYamlFiles_type, diagYamlFilesVar_type
!> @}
integer, parameter :: basedate_size = 6
+integer, parameter :: NUM_SUB_REGION_ARRAY = 8
+integer, parameter :: MAX_STR_LEN = 255
+
+!> @brief type to hold the sub region information about a file
+type subRegion_type
+ character (len=:), allocatable :: grid_type !< Flag indicating the type of region,
+ !! acceptable values are "latlon" and "index"
+ real, allocatable :: lat_lon_sub_region (:) !< Array that stores the grid point bounds for the sub region
+ !! to use if grid_type is set to "latlon"
+ !! [dim1_begin, dim1_end, dim2_begin, dim2_end,
+ !! dim3_begin, dim3_end, dim4_begin, dim4_end]
+ integer, allocatable :: index_sub_region (:) !< Array that stores the index bounds for the sub region to
+ !! to use if grid_type is set to "index"
+ !! [dim1_begin, dim1_end, dim2_begin, dim2_end,
+ !! dim3_begin, dim3_end, dim4_begin, dim4_end]
+ integer :: tile !< Tile number of the sub region, required if using the "index" grid type
+
+end type subRegion_type
+
+!> @brief type to hold the diag_file information
+type diagYamlFiles_type
+ character (len=:), private, allocatable :: file_fname !< file name
+ character (len=:), private, allocatable :: file_frequnit !< the frequency unit
+ integer, private :: file_freq !< the frequency of data
+ character (len=:), private, allocatable :: file_timeunit !< The unit of time
+ character (len=:), private, allocatable :: file_unlimdim !< The name of the unlimited dimension
+ logical, private :: file_write !< false if the user doesn't want to the file to be created
+ character (len=:), private, allocatable :: string_file_write !< false if the user doesn’t want the file to be
+ !! created (default is true).
+ character (len=:), private, allocatable :: file_realm !< The modeling realm that the variables come from
+ type(subRegion_type), private :: file_sub_region !< type containing info about the subregion, if any
+ integer, private :: file_new_file_freq !< Frequency for closing the existing file
+ character (len=:), private, allocatable :: file_new_file_freq_units !< Time units for creating a new file.
+ !! Required if “new_file_freq” used
+ character (len=:), private, allocatable :: file_start_time !< Time to start the file for the first time. Requires
+ !! “new_file_freq”
+ integer, private :: file_duration !< How long the file should receive data after start time
+ !! in “file_duration_units”. This optional field can only
+ !! be used if the start_time field is present. If this field
+ !! is absent, then the file duration will be equal to the
+ !! frequency for creating new files.
+ !! NOTE: The file_duration_units field must also be present if
+ !! this field is present.
+ character (len=:), private, allocatable :: file_duration_units !< The file duration units
+ !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
+ character (len=MAX_STR_LEN), dimension(:), private, allocatable :: file_varlist !< An array of variable names
+ !! within a file
+ character (len=MAX_STR_LEN), dimension(:,:), private, allocatable :: file_global_meta !< Array of key(dim=1)
+ !! and values(dim=2) to be added as global
+ !! meta data to the file
+
+ contains
+ !> All getter functions (functions named get_x(), for member field named x)
+ !! return copies of the member variables unless explicitly noted.
+ procedure :: get_file_fname
+ procedure :: get_file_frequnit
+ procedure :: get_file_freq
+ procedure :: get_file_timeunit
+ procedure :: get_file_unlimdim
+ procedure :: get_file_write
+ procedure :: get_file_realm
+ procedure :: get_file_sub_region
+ procedure :: get_file_new_file_freq
+ procedure :: get_file_new_file_freq_units
+ procedure :: get_file_start_time
+ procedure :: get_file_duration
+ procedure :: get_file_duration_units
+ procedure :: get_file_varlist
+ procedure :: get_file_global_meta
+ procedure :: is_global_meta
+
+end type diagYamlFiles_type
+
+!> @brief type to hold the info a diag_field
+type diagYamlFilesVar_type
+ character (len=:), private, allocatable :: var_fname !< The field/diagnostic name
+ character (len=:), private, allocatable :: var_varname !< The name of the variable
+ character (len=:), private, allocatable :: var_reduction !< Reduction to be done on var
+ character (len=:), private, allocatable :: var_module !< The module that th variable is in
+ character (len=:), private, allocatable :: var_skind !< The type/kind of the variable
+ character (len=:), private, allocatable :: string_var_write !< false if the user doesn’t want the variable to be
+ !! written to the file (default: true).
+ logical, private :: var_write !< false if the user doesn’t want the variable to be
+ !! written to the file (default: true).
+ character (len=:), private, allocatable :: var_outname !< Name of the variable as written to the file
+ character (len=:), private, allocatable :: var_longname !< Overwrites the long name of the variable
+ character (len=:), private, allocatable :: var_units !< Overwrites the units
+
+ !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
+ character (len=MAX_STR_LEN), dimension (:, :), private, allocatable :: var_attributes !< Attributes to overwrite or
+ !! add from diag_yaml
+ contains
+ !> All getter functions (functions named get_x(), for member field named x)
+ !! return copies of the member variables unless explicitly noted.
+ procedure :: get_var_fname
+ procedure :: get_var_varname
+ procedure :: get_var_reduction
+ procedure :: get_var_module
+ procedure :: get_var_skind
+ procedure :: get_var_outname
+ procedure :: get_var_longname
+ procedure :: get_var_units
+ procedure :: get_var_write
+ procedure :: get_var_attributes
+ procedure :: is_var_attributes
+end type diagYamlFilesVar_type
!> @brief Object that holds the information of the diag_yaml
!> @ingroup fms_diag_yaml_mod
@@ -241,7 +347,7 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
fileobj%file_sub_region%index_sub_region = DIAG_NULL
call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%index_sub_region)
call get_value_from_key(diag_yaml_id, sub_region_id(1), "tile", fileobj%file_sub_region%tile, is_optional=.true.)
- if (fileobj%file_sub_region%tile .eq. 0) call mpp_error(FATAL, "The tile number is required when defining a "//&
+ if (fileobj%file_sub_region%tile .eq. DIAG_NULL) call mpp_error(FATAL, "The tile number is required when defining a "//&
"subregion. Check your subregion entry for "//trim(fileobj%file_fname))
else
call mpp_error(FATAL, trim(fileobj%file_sub_region%grid_type)//" is not a valid region type. &
@@ -507,6 +613,248 @@ pure function is_valid_time_units(time_units) &
is_valid = .false.
end select
end function is_valid_time_units
+
+!!!!!!! YAML FILE INQUIRIES !!!!!!!
+!> @brief Inquiry for diag_files_obj%file_fname
+!! @return file_fname of a diag_yaml_file obj
+pure function get_file_fname (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_files_obj%file_fname
+end function get_file_fname
+!> @brief Inquiry for diag_files_obj%file_frequnit
+!! @return file_frequnit of a diag_yaml_file_obj
+pure function get_file_frequnit (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_files_obj%file_frequnit
+end function get_file_frequnit
+!> @brief Inquiry for diag_files_obj%file_freq
+!! @return file_freq of a diag_yaml_file_obj
+pure function get_file_freq(diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_files_obj%file_freq
+end function get_file_freq
+!> @brief Inquiry for diag_files_obj%file_timeunit
+!! @return file_timeunit of a diag_yaml_file_obj
+pure function get_file_timeunit (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_files_obj%file_timeunit
+end function get_file_timeunit
+!> @brief Inquiry for diag_files_obj%file_unlimdim
+!! @return file_unlimdim of a diag_yaml_file_obj
+pure function get_file_unlimdim(diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_files_obj%file_unlimdim
+end function get_file_unlimdim
+!> @brief Inquiry for diag_files_obj%file_write
+!! @return file_write of a diag_yaml_file_obj
+pure function get_file_write(diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ logical :: res !< What is returned
+ res = diag_files_obj%file_write
+end function get_file_write
+!> @brief Inquiry for diag_files_obj%file_realm
+!! @return file_realm of a diag_yaml_file_obj
+pure function get_file_realm(diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (:), allocatable :: res !< What is returned
+ res = diag_files_obj%file_realm
+end function get_file_realm
+!> @brief Inquiry for diag_files_obj%file_subregion
+!! @return file_sub_region of a diag_yaml_file_obj
+pure function get_file_sub_region (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ type(subRegion_type) :: res !< What is returned
+ res = diag_files_obj%file_sub_region
+end function get_file_sub_region
+!> @brief Inquiry for diag_files_obj%file_new_file_freq
+!! @return file_new_file_freq of a diag_yaml_file_obj
+pure function get_file_new_file_freq(diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_files_obj%file_new_file_freq
+end function get_file_new_file_freq
+!> @brief Inquiry for diag_files_obj%file_new_file_freq_units
+!! @return file_new_file_freq_units of a diag_yaml_file_obj
+pure function get_file_new_file_freq_units (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (:), allocatable :: res !< What is returned
+ res = diag_files_obj%file_new_file_freq_units
+end function get_file_new_file_freq_units
+!> @brief Inquiry for diag_files_obj%file_start_time
+!! @return file_start_time of a diag_yaml_file_obj
+pure function get_file_start_time (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_files_obj%file_start_time
+end function get_file_start_time
+!> @brief Inquiry for diag_files_obj%file_duration
+!! @return file_duration of a diag_yaml_file_obj
+pure function get_file_duration (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_files_obj%file_duration
+end function get_file_duration
+!> @brief Inquiry for diag_files_obj%file_duration_units
+!! @return file_duration_units of a diag_yaml_file_obj
+pure function get_file_duration_units (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (:), allocatable :: res !< What is returned
+ res = diag_files_obj%file_duration_units
+end function get_file_duration_units
+!> @brief Inquiry for diag_files_obj%file_varlist
+!! @return file_varlist of a diag_yaml_file_obj
+pure function get_file_varlist (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (:), allocatable :: res(:) !< What is returned
+ res = diag_files_obj%file_varlist
+end function get_file_varlist
+!> @brief Inquiry for diag_files_obj%file_global_meta
+!! @return file_global_meta of a diag_yaml_file_obj
+pure function get_file_global_meta (diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ character (:), allocatable :: res(:,:) !< What is returned
+ res = diag_files_obj%file_global_meta
+end function get_file_global_meta
+!> @brief Inquiry for whether file_global_meta is allocated
+!! @return Flag indicating if file_global_meta is allocated
+function is_global_meta(diag_files_obj) &
+ result(res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ logical :: res
+ res = .false.
+ if (allocated(diag_files_obj%file_global_meta)) &
+ res = .true.
+end function
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!! VARIABLES ROUTINES AND FUNCTIONS !!!!!!!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!! YAML VAR INQUIRIES !!!!!!!
+!> @brief Inquiry for diag_yaml_files_var_obj%var_fname
+!! @return var_fname of a diag_yaml_files_var_obj
+pure function get_var_fname (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_var_obj%var_fname
+end function get_var_fname
+!> @brief Inquiry for diag_yaml_files_var_obj%var_varname
+!! @return var_varname of a diag_yaml_files_var_obj
+pure function get_var_varname (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_var_obj%var_varname
+end function get_var_varname
+!> @brief Inquiry for diag_yaml_files_var_obj%var_reduction
+!! @return var_reduction of a diag_yaml_files_var_obj
+pure function get_var_reduction (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_var_obj%var_reduction
+end function get_var_reduction
+!> @brief Inquiry for diag_yaml_files_var_obj%var_module
+!! @return var_module of a diag_yaml_files_var_obj
+pure function get_var_module (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_var_obj%var_module
+end function get_var_module
+!> @brief Inquiry for diag_yaml_files_var_obj%var_skind
+!! @return var_skind of a diag_yaml_files_var_obj
+pure function get_var_skind (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_var_obj%var_skind
+end function get_var_skind
+!> @brief Inquiry for diag_yaml_files_var_obj%var_outname
+!! @return var_outname of a diag_yaml_files_var_obj
+pure function get_var_outname (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_var_obj%var_outname
+end function get_var_outname
+!> @brief Inquiry for diag_yaml_files_var_obj%var_longname
+!! @return var_longname of a diag_yaml_files_var_obj
+pure function get_var_longname (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_var_obj%var_longname
+end function get_var_longname
+!> @brief Inquiry for diag_yaml_files_var_obj%var_units
+!! @return var_units of a diag_yaml_files_var_obj
+pure function get_var_units (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=:), allocatable :: res !< What is returned
+ res = diag_var_obj%var_units
+end function get_var_units
+!> @brief Inquiry for diag_yaml_files_var_obj%var_write
+!! @return var_write of a diag_yaml_files_var_obj
+pure function get_var_write (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ logical :: res !< What is returned
+ res = diag_var_obj%var_write
+end function get_var_write
+!> @brief Inquiry for diag_yaml_files_var_obj%var_attributes
+!! @return var_attributes of a diag_yaml_files_var_obj
+pure function get_var_attributes(diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned
+ res = diag_var_obj%var_attributes
+end function get_var_attributes
+!> @brief Inquiry for whether var_attributes is allocated
+!! @return Flag indicating if var_attributes is allocated
+function is_var_attributes(diag_var_obj) &
+result(res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ logical :: res
+ res = .false.
+ if (allocated(diag_var_obj%var_attributes)) &
+ res = .true.
+end function is_var_attributes
+
+!> @brief Initializes the non string values of a diagYamlFiles_type to its
+!! default values
+subroutine diag_yaml_files_obj_init(obj)
+ type(diagYamlFiles_type), intent(out) :: obj !< diagYamlFiles_type object to initialize
+
+ obj%file_freq = DIAG_NULL
+ obj%file_write = .true.
+ obj%file_duration = DIAG_NULL
+ obj%file_new_file_freq = DIAG_NULL
+ obj%file_sub_region%tile = DIAG_NULL
+end subroutine diag_yaml_files_obj_init
+
#endif
end module fms_diag_yaml_mod
!> @}
diff --git a/diag_manager/fms_diag_yaml_object.F90 b/diag_manager/fms_diag_yaml_object.F90
deleted file mode 100644
index 7cc6db38f3..0000000000
--- a/diag_manager/fms_diag_yaml_object.F90
+++ /dev/null
@@ -1,354 +0,0 @@
-!***********************************************************************
-!* 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 .
-!***********************************************************************
-!> @defgroup fms_diag_yaml_object_mod fms_diag_yaml_object_mod
-!> @ingroup diag_manager
-!! @brief The diag yaml objects are handled here, with variables the correspond to
-!! entries in the diag yaml file. The actual parsing of the yaml is handled in
-!! @ref fms_diag_yaml_mod.
-!! @author Tom Robinson, Uriel Ramirez
-
-!> @file
-!> @brief File for @ref fms_diag_yaml_object_mod
-
-!> @addtogroup fms_diag_yaml_object_mod
-!> @{
-module fms_diag_yaml_object_mod
-
-use fms_mod , only: fms_c2f_string
-use iso_c_binding
- implicit none
-integer, parameter :: NUM_SUB_REGION_ARRAY = 8
-integer, parameter :: MAX_STR_LEN = 255
-
-!> @brief type to hold the sub region information about a file
-type subRegion_type
- character (len=:), allocatable :: grid_type !< Flag indicating the type of region,
- !! acceptable values are "latlon" and "index"
- real, allocatable :: lat_lon_sub_region (:) !< Array that stores the grid point bounds for the sub region
- !! to use if grid_type is set to "latlon"
- !! [dim1_begin, dim1_end, dim2_begin, dim2_end,
- !! dim3_begin, dim3_end, dim4_begin, dim4_end]
- integer, allocatable :: index_sub_region (:) !< Array that stores the index bounds for the sub region to
- !! to use if grid_type is set to "index"
- !! [dim1_begin, dim1_end, dim2_begin, dim2_end,
- !! dim3_begin, dim3_end, dim4_begin, dim4_end]
- integer :: tile !< Tile number of the sub region, required if using the "index" grid type
-
-end type subRegion_type
-
-type diagYamlFiles_type
- character (len=:), allocatable :: file_fname !< file name
- character (len=:), allocatable :: file_frequnit !< the frequency unit
- integer (c_int) :: file_freq !< the frequency of data
- character (len=:), allocatable :: file_timeunit !< The unit of time
- character (len=:), allocatable :: file_unlimdim !< The name of the unlimited dimension
- logical :: file_write
- character (len=:), allocatable :: string_file_write !< false if the user doesn’t want the file to be
- !! created (default is true).
- character (len=:), allocatable :: file_realm !< The modeling realm that the variables come from
- type(subRegion_type) :: file_sub_region !< type containing info about the subregion, if any
- integer :: file_new_file_freq !< Frequency for closing the existing file
- character (len=:), allocatable :: file_new_file_freq_units !< Time units for creating a new file.
- !! Required if “new_file_freq” used
- character (len=:), allocatable :: file_start_time !< Time to start the file for the first time. Requires
- !! “new_file_freq”
- integer :: file_duration !< How long the file should receive data after start time
- !! in “file_duration_units”. This optional field can only
- !! be used if the start_time field is present. If this field
- !! is absent, then the file duration will be equal to the
- !! frequency for creating new files.
- !! NOTE: The file_duration_units field must also be present if
- !! this field is present.
- character (len=:), allocatable :: file_duration_units !< The file duration units
- !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
- character (len=MAX_STR_LEN), dimension(:), allocatable :: file_varlist !< An array of variable names
- !! within a file
- character (len=MAX_STR_LEN), dimension(:,:), allocatable :: file_global_meta !< Array of key(dim=1)
- !! and values(dim=2) to be added as global
- !! meta data to the file
-
- contains
- procedure :: get_file_fname
- procedure :: get_file_frequnit
- procedure :: get_file_freq
- procedure :: get_file_timeunit
- procedure :: get_file_unlimdim
- procedure :: get_file_write
- procedure :: get_file_realm
- procedure :: get_file_sub_region
- procedure :: get_file_new_file_freq
- procedure :: get_file_new_file_freq_units
- procedure :: get_file_start_time
- procedure :: get_file_duration
- procedure :: get_file_duration_units
- procedure :: get_file_varlist
- procedure :: get_file_global_meta
- procedure :: is_global_meta
-
-end type diagYamlFiles_type
-
-type diagYamlFilesVar_type
- character (len=:), allocatable :: var_fname !< The field/diagnostic name
- character (len=:), allocatable :: var_varname !< The name of the variable
- character (len=:), allocatable :: var_reduction !< Reduction to be done on var
- character (len=:), allocatable :: var_module !< The module that th variable is in
- character (len=:), allocatable :: var_skind !< The type/kind of the variable
- character (len=:), allocatable :: string_var_write !< false if the user doesn’t want the variable to be
- !! written to the file (default: true).
- logical :: var_write !< false if the user doesn’t want the variable to be
- !! written to the file (default: true).
- character (len=:), allocatable :: var_outname !< Name of the variable as written to the file
- character (len=:), allocatable :: var_longname !< Overwrites the long name of the variable
- character (len=:), allocatable :: var_units !< Overwrites the units
- !< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
- character (len=MAX_STR_LEN), dimension (:, :), allocatable :: var_attributes !< Attributes to overwrite or
- !! add from diag_yaml
- contains
- procedure :: get_var_fname
- procedure :: get_var_varname
- procedure :: get_var_reduction
- procedure :: get_var_module
- procedure :: get_var_skind
- procedure :: get_var_outname
- procedure :: get_var_longname
- procedure :: get_var_units
- procedure :: get_var_write
- procedure :: get_var_attributes
- procedure :: is_var_attributes
-end type diagYamlFilesVar_type
-
-contains
-!!!!!!! YAML FILE INQUIRIES !!!!!!!
-!> @brief Inquiry for diag_files_obj%file_fname
-!! @return file_fname of a diag_yaml_file obj
-pure function get_file_fname (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_files_obj%file_fname
-end function get_file_fname
-!> @brief Inquiry for diag_files_obj%file_frequnit
-!! @return file_frequnit of a diag_yaml_file_obj
-pure function get_file_frequnit (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_files_obj%file_frequnit
-end function get_file_frequnit
-!> @brief Inquiry for diag_files_obj%file_freq
-!! @return file_freq of a diag_yaml_file_obj
-pure function get_file_freq(diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- integer :: res !< What is returned
- res = diag_files_obj%file_freq
-end function get_file_freq
-!> @brief Inquiry for diag_files_obj%file_timeunit
-!! @return file_timeunit of a diag_yaml_file_obj
-pure function get_file_timeunit (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_files_obj%file_timeunit
-end function get_file_timeunit
-!> @brief Inquiry for diag_files_obj%file_unlimdim
-!! @return file_unlimdim of a diag_yaml_file_obj
-pure function get_file_unlimdim(diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_files_obj%file_unlimdim
-end function get_file_unlimdim
-!> @brief Inquiry for diag_files_obj%file_write
-!! @return file_write of a diag_yaml_file_obj
-pure function get_file_write(diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- logical :: res !< What is returned
- res = diag_files_obj%file_write
-end function get_file_write
-!> @brief Inquiry for diag_files_obj%file_realm
-!! @return file_realm of a diag_yaml_file_obj
-pure function get_file_realm(diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (:), allocatable :: res !< What is returned
- res = diag_files_obj%file_realm
-end function get_file_realm
-!> @brief Inquiry for diag_files_obj%file_subregion
-!! @return file_sub_region of a diag_yaml_file_obj
-pure function get_file_sub_region (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- type(subRegion_type) :: res !< What is returned
- res = diag_files_obj%file_sub_region
-end function get_file_sub_region
-!> @brief Inquiry for diag_files_obj%file_new_file_freq
-!! @return file_new_file_freq of a diag_yaml_file_obj
-pure function get_file_new_file_freq(diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- integer :: res !< What is returned
- res = diag_files_obj%file_new_file_freq
-end function get_file_new_file_freq
-!> @brief Inquiry for diag_files_obj%file_new_file_freq_units
-!! @return file_new_file_freq_units of a diag_yaml_file_obj
-pure function get_file_new_file_freq_units (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (:), allocatable :: res !< What is returned
- res = diag_files_obj%file_new_file_freq_units
-end function get_file_new_file_freq_units
-!> @brief Inquiry for diag_files_obj%file_start_time
-!! @return file_start_time of a diag_yaml_file_obj
-pure function get_file_start_time (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_files_obj%file_start_time
-end function get_file_start_time
-!> @brief Inquiry for diag_files_obj%file_duration
-!! @return file_duration of a diag_yaml_file_obj
-pure function get_file_duration (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- integer :: res !< What is returned
- res = diag_files_obj%file_duration
-end function get_file_duration
-!> @brief Inquiry for diag_files_obj%file_duration_units
-!! @return file_duration_units of a diag_yaml_file_obj
-pure function get_file_duration_units (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (:), allocatable :: res !< What is returned
- res = diag_files_obj%file_duration_units
-end function get_file_duration_units
-!> @brief Inquiry for diag_files_obj%file_varlist
-!! @return file_varlist of a diag_yaml_file_obj
-pure function get_file_varlist (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (:), allocatable :: res(:) !< What is returned
- res = diag_files_obj%file_varlist
-end function get_file_varlist
-!> @brief Inquiry for diag_files_obj%file_global_meta
-!! @return file_global_meta of a diag_yaml_file_obj
-pure function get_file_global_meta (diag_files_obj) result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (:), allocatable :: res(:,:) !< What is returned
- res = diag_files_obj%file_global_meta
-end function get_file_global_meta
-!> @brief Inquiry for whether file_global_meta is allocated
-!! @return Flag indicating if file_global_meta is allocated
-function is_global_meta(diag_files_obj) result(res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- logical :: res
- res = .false.
- if (allocated(diag_files_obj%file_global_meta)) &
- res = .true.
-end function
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!! VARIABLES ROUTINES AND FUNCTIONS !!!!!!!
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!! YAML VAR INQUIRIES !!!!!!!
-!> @brief Inquiry for diag_yaml_files_var_obj%var_fname
-!! @return var_fname of a diag_yaml_files_var_obj
-pure function get_var_fname (diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_fname
-end function get_var_fname
-!> @brief Inquiry for diag_yaml_files_var_obj%var_varname
-!! @return var_varname of a diag_yaml_files_var_obj
-pure function get_var_varname (diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_varname
-end function get_var_varname
-!> @brief Inquiry for diag_yaml_files_var_obj%var_reduction
-!! @return var_reduction of a diag_yaml_files_var_obj
-pure function get_var_reduction (diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_reduction
-end function get_var_reduction
-!> @brief Inquiry for diag_yaml_files_var_obj%var_module
-!! @return var_module of a diag_yaml_files_var_obj
-pure function get_var_module (diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_module
-end function get_var_module
-!> @brief Inquiry for diag_yaml_files_var_obj%var_skind
-!! @return var_skind of a diag_yaml_files_var_obj
-pure function get_var_skind (diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_skind
-end function get_var_skind
-!> @brief Inquiry for diag_yaml_files_var_obj%var_outname
-!! @return var_outname of a diag_yaml_files_var_obj
-pure function get_var_outname (diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_outname
-end function get_var_outname
-!> @brief Inquiry for diag_yaml_files_var_obj%var_longname
-!! @return var_longname of a diag_yaml_files_var_obj
-pure function get_var_longname (diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_longname
-end function get_var_longname
-!> @brief Inquiry for diag_yaml_files_var_obj%var_units
-!! @return var_units of a diag_yaml_files_var_obj
-pure function get_var_units (diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_units
-end function get_var_units
-!> @brief Inquiry for diag_yaml_files_var_obj%var_write
-!! @return var_write of a diag_yaml_files_var_obj
-pure function get_var_write (diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- logical :: res !< What is returned
- res = diag_var_obj%var_write
-end function get_var_write
-!> @brief Inquiry for diag_yaml_files_var_obj%var_attributes
-!! @return var_attributes of a diag_yaml_files_var_obj
-pure function get_var_attributes(diag_var_obj) result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned
- res = diag_var_obj%var_attributes
-end function get_var_attributes
-!> @brief Inquiry for whether var_attributes is allocated
-!! @return Flag indicating if var_attributes is allocated
-function is_var_attributes(diag_var_obj) result(res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- logical :: res
- res = .false.
- if (allocated(diag_var_obj%var_attributes)) &
- res = .true.
-end function is_var_attributes
-
-!> @brief Initializes the non string values of a diagYamlFiles_type to its
-!! default values
-subroutine diag_yaml_files_obj_init(obj)
- type(diagYamlFiles_type), intent(out) :: obj !< diagYamlFiles_type object to initialize
-
- obj%file_freq = 0
- obj%file_write = .true.
- obj%file_duration = 0
- obj%file_new_file_freq = 0
- obj%file_sub_region%tile = 0
-end subroutine diag_yaml_files_obj_init
-
-end module fms_diag_yaml_object_mod
-!> @}
-! close documentation grouping
-
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index d939de7b91..95f93513e6 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -24,7 +24,7 @@ program test_diag_yaml
#ifdef use_yaml
use FMS_mod, only: fms_init, fms_end
use fms_diag_yaml_mod
-use fms_diag_yaml_object_mod
+use diag_data_mod, only: DIAG_NULL
use mpp_mod
use platform_mod
@@ -174,16 +174,16 @@ subroutine compare_diag_files(res)
call compare_result("file_write 3", res(3)%get_file_write(), .true.)
call compare_result("file_new_file_freq 1", res(1)%get_file_new_file_freq(), 6)
- call compare_result("file_new_file_freq 2", res(2)%get_file_new_file_freq(), 0)
- call compare_result("file_new_file_freq 3", res(3)%get_file_new_file_freq(), 0)
+ call compare_result("file_new_file_freq 2", res(2)%get_file_new_file_freq(), DIAG_NULL)
+ call compare_result("file_new_file_freq 3", res(3)%get_file_new_file_freq(), DIAG_NULL)
call compare_result("file_new_file_freq_units 1", res(1)%get_file_new_file_freq_units(), "hours")
call compare_result("file_new_file_freq_units 2", res(2)%get_file_new_file_freq_units(), "")
call compare_result("file_new_file_freq_units 3", res(3)%get_file_new_file_freq_units(), "")
call compare_result("file_duration 1", res(1)%get_file_duration(), 12)
- call compare_result("file_duration 2", res(2)%get_file_duration(), 0)
- call compare_result("file_duration 3", res(3)%get_file_duration(), 0)
+ call compare_result("file_duration 2", res(2)%get_file_duration(), DIAG_NULL)
+ call compare_result("file_duration 3", res(3)%get_file_duration(), DIAG_NULL)
call compare_result("file_duration_units 1", res(1)%get_file_duration_units(), "hours")
call compare_result("file_duration_units 2", res(2)%get_file_duration_units(), "")
From 4175073d5b1abe85b4c07b8447dc9df709ad56b2 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 25 Feb 2022 08:30:26 -0500
Subject: [PATCH 031/168] fix: diag_yaml object fix frequency and reading
reductions (#901)
---
diag_manager/fms_diag_yaml.F90 | 8 ++++----
test_fms/diag_manager/diagTables/diag_table_yaml_26 | 2 +-
test_fms/diag_manager/test_diag_yaml.F90 | 2 +-
3 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 22d344ec39..67f0feebdd 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -484,8 +484,8 @@ function get_total_num_vars(diag_yaml_id, diag_file_ids) &
subroutine check_file_freq(fileobj)
type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
- if (fileobj%file_freq < 1 ) &
- call mpp_error(FATAL, "freq must be greater than 0. &
+ if (.not. (fileobj%file_freq >= -1) ) &
+ call mpp_error(FATAL, "freq must be greater than or equal to -1. &
&Check you entry for"//trim(fileobj%file_fname))
if(.not. is_valid_time_units(fileobj%file_frequnit)) &
call mpp_error(FATAL, trim(fileobj%file_frequnit)//" is not a valid file_frequnit. &
@@ -574,14 +574,14 @@ subroutine check_field_reduction(field)
n_diurnal = 0
pow_value = 0
ioerror = 0
- if (field%var_reduction(1:7) .eq. "diurnal") then
+ if (index(field%var_reduction, "diurnal") .ne. 0) then
READ (UNIT=field%var_reduction(8:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) n_diurnal
if (ioerror .ne. 0) &
call mpp_error(FATAL, "Error getting the number of diurnal samples from "//trim(field%var_reduction))
if (n_diurnal .le. 0) &
call mpp_error(FATAL, "Diurnal samples should be greater than 0. &
& Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
- elseif (field%var_reduction(1:3) .eq. "pow") then
+ elseif (index(field%var_reduction, "pow") .ne. 0) then
READ (UNIT=field%var_reduction(4:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) pow_value
if (ioerror .ne. 0) &
call mpp_error(FATAL, "Error getting the power value from "//trim(field%var_reduction))
diff --git a/test_fms/diag_manager/diagTables/diag_table_yaml_26 b/test_fms/diag_manager/diagTables/diag_table_yaml_26
index d82038bd6a..d7c6132ded 100644
--- a/test_fms/diag_manager/diagTables/diag_table_yaml_26
+++ b/test_fms/diag_manager/diagTables/diag_table_yaml_26
@@ -41,7 +41,7 @@ diag_files:
dim1_begin: 64.0
dim3_end: 20.0
- file_name: normal2
- freq: 24
+ freq: -1
freq_units: days
time_units: hours
unlimdim: records
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index 95f93513e6..32ef98cd9d 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -151,7 +151,7 @@ subroutine compare_diag_files(res)
call compare_result("file_freq 1", res(1)%get_file_freq(), 6)
call compare_result("file_freq 2", res(2)%get_file_freq(), 24)
- call compare_result("file_freq 3", res(3)%get_file_freq(), 24)
+ call compare_result("file_freq 3", res(3)%get_file_freq(), -1)
call compare_result("file_frequnit 1", res(1)%get_file_frequnit(), "hours")
call compare_result("file_frequnit 2", res(2)%get_file_frequnit(), "days")
From 80c887b57e54d5cb0801bc020cf308bd07debf0d Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Fri, 25 Feb 2022 08:32:57 -0500
Subject: [PATCH 032/168] feat: add has_* functions for allocatables (#910)
---
diag_manager/fms_diag_object.F90 | 227 +++++++++++++++++++++++++++--
diag_manager/fms_diag_yaml.F90 | 235 +++++++++++++++++++++++++++++++
2 files changed, 450 insertions(+), 12 deletions(-)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index bb08c464f2..9f2f2fb589 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -62,7 +62,7 @@ module fms_diag_object_mod
type fmsDiagObject_type
#ifdef use_yaml
type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table
- type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table
+ type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table
#endif
integer, allocatable, private :: diag_id !< unique id for varable
class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the
@@ -95,17 +95,13 @@ module fms_diag_object_mod
class(*), allocatable, private :: missing_value !< The missing fill value
class(*), allocatable, private :: data_RANGE !< The range of the variable data
type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object
-!> \brief Extends the variable object to work with multiple types of data
- class(*), allocatable :: vardata0
- class(*), allocatable, dimension(:) :: vardata1
- class(*), allocatable, dimension(:,:) :: vardata2
- class(*), allocatable, dimension(:,:,:) :: vardata3
- class(*), allocatable, dimension(:,:,:,:) :: vardata4
- class(*), allocatable, dimension(:,:,:,:,:) :: vardata5
-
-
-
- contains
+ class(*), allocatable :: vardata0 !< Scalar data buffer
+ class(*), allocatable, dimension(:) :: vardata1 !< 1D data buffer
+ class(*), allocatable, dimension(:,:) :: vardata2 !< 2D data buffer
+ class(*), allocatable, dimension(:,:,:) :: vardata3 !< 3D data buffer
+ class(*), allocatable, dimension(:,:,:,:) :: vardata4 !< 4D data buffer
+ class(*), allocatable, dimension(:,:,:,:,:) :: vardata5 !< 5D data buffer
+ contains
! procedure :: send_data => fms_send_data !!TODO
procedure :: init_ob => diag_obj_init
procedure :: get_id => fms_diag_get_id
@@ -121,6 +117,36 @@ module fms_diag_object_mod
procedure :: is_registeredB => diag_obj_is_registered
procedure :: is_mask_variant => get_mask_variant
procedure :: is_local => get_local
+! Is variable allocated check functions
+!TODO procedure :: has_diag_field
+!TODO procedure :: has_diag_file
+ procedure :: has_diag_id
+ procedure :: has_fileob
+ procedure :: has_metadata
+ procedure :: has_static
+ procedure :: has_registered
+ procedure :: has_mask_variant
+ procedure :: has_local
+!TODO procedure :: has_init_time
+ procedure :: has_vartype
+ procedure :: has_varname
+ procedure :: has_longname
+ procedure :: has_standname
+ procedure :: has_units
+ procedure :: has_modname
+ procedure :: has_realm
+ procedure :: has_err_msg
+ procedure :: has_interp_method
+ procedure :: has_frequency
+ procedure :: has_output_units
+ procedure :: has_t
+ procedure :: has_tile_count
+ procedure :: has_axis_ids
+ procedure :: has_area
+ procedure :: has_volume
+ procedure :: has_missing_value
+ procedure :: has_data_RANGE
+ procedure :: has_axis
! Get functions
procedure :: get_diag_id => fms_diag_get_id
procedure :: get_metadata
@@ -910,4 +936,181 @@ pure logical function int_ne_obj (i,obj) result(ll)
endif
end function int_ne_obj
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!! Allocation checks
+!!> @brief Checks if obj%diag_field is allocated
+!!! @return true if obj%diag_field is allocated
+!logical function has_diag_field (obj)
+! class (fmsDiagObject_type), intent(in) :: obj !< diag object
+! has_diag_field = allocated(obj%diag_field)
+!end function has_diag_field
+!!> @brief Checks if obj%diag_file is allocated
+!!! @return true if obj%diag_file is allocated
+!logical function has_diag_file (obj)
+! class (fmsDiagObject_type), intent(in) :: obj !< diag object
+! has_diag_file = allocated(obj%diag_file)
+!end function has_diag_file
+!> @brief Checks if obj%diag_id is allocated
+!! @return true if obj%diag_id is allocated
+logical function has_diag_id (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_diag_id = allocated(obj%diag_id)
+end function has_diag_id
+!> @brief Checks if obj%fileob pointer is associated
+!! @return true if obj%fileob is associated
+logical function has_fileob (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_fileob = associated(obj%fileob)
+end function has_fileob
+!> @brief Checks if obj%metadata is allocated
+!! @return true if obj%metadata is allocated
+logical function has_metadata (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_metadata = allocated(obj%metadata)
+end function has_metadata
+!> @brief Checks if obj%static is allocated
+!! @return true if obj%static is allocated
+logical function has_static (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_static = allocated(obj%static)
+end function has_static
+!> @brief Checks if obj%registered is allocated
+!! @return true if obj%registered is allocated
+logical function has_registered (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_registered = allocated(obj%registered)
+end function has_registered
+!> @brief Checks if obj%mask_variant is allocated
+!! @return true if obj%mask_variant is allocated
+logical function has_mask_variant (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_mask_variant = allocated(obj%mask_variant)
+end function has_mask_variant
+!> @brief Checks if obj%local is allocated
+!! @return true if obj%local is allocated
+logical function has_local (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_local = allocated(obj%local)
+end function has_local
+!!> @brief Checks if obj%init_time is allocated
+!!! @return true if obj%init_time is allocated
+!logical function has_init_time (obj)
+! class (fmsDiagObject_type), intent(in) :: obj !< diag object
+! has_init_time = allocated(obj%init_time)
+!end function has_init_time
+!> @brief Checks if obj%vartype is allocated
+!! @return true if obj%vartype is allocated
+logical function has_vartype (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_vartype = allocated(obj%vartype)
+end function has_vartype
+!> @brief Checks if obj%varname is allocated
+!! @return true if obj%varname is allocated
+logical function has_varname (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_varname = allocated(obj%varname)
+end function has_varname
+!> @brief Checks if obj%longname is allocated
+!! @return true if obj%longname is allocated
+logical function has_longname (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_longname = allocated(obj%longname)
+end function has_longname
+!> @brief Checks if obj%standname is allocated
+!! @return true if obj%standname is allocated
+logical function has_standname (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_standname = allocated(obj%standname)
+end function has_standname
+!> @brief Checks if obj%units is allocated
+!! @return true if obj%units is allocated
+logical function has_units (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_units = allocated(obj%units)
+end function has_units
+!> @brief Checks if obj%modname is allocated
+!! @return true if obj%modname is allocated
+logical function has_modname (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_modname = allocated(obj%modname)
+end function has_modname
+!> @brief Checks if obj%realm is allocated
+!! @return true if obj%realm is allocated
+logical function has_realm (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_realm = allocated(obj%realm)
+end function has_realm
+!> @brief Checks if obj%err_msg is allocated
+!! @return true if obj%err_msg is allocated
+logical function has_err_msg (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_err_msg = allocated(obj%err_msg)
+end function has_err_msg
+!> @brief Checks if obj%interp_method is allocated
+!! @return true if obj%interp_method is allocated
+logical function has_interp_method (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_interp_method = allocated(obj%interp_method)
+end function has_interp_method
+!> @brief Checks if obj%frequency is allocated
+!! @return true if obj%frequency is allocated
+logical function has_frequency (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_frequency = allocated(obj%frequency)
+end function has_frequency
+!> @brief Checks if obj%output_units is allocated
+!! @return true if obj%output_units is allocated
+logical function has_output_units (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_output_units = allocated(obj%output_units)
+end function has_output_units
+!> @brief Checks if obj%t is allocated
+!! @return true if obj%t is allocated
+logical function has_t (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_t = allocated(obj%t)
+end function has_t
+!> @brief Checks if obj%tile_count is allocated
+!! @return true if obj%tile_count is allocated
+logical function has_tile_count (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_tile_count = allocated(obj%tile_count)
+end function has_tile_count
+!> @brief Checks if obj%axis_ids is allocated
+!! @return true if obj%axis_ids is allocated
+logical function has_axis_ids (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_axis_ids = allocated(obj%axis_ids)
+end function has_axis_ids
+!> @brief Checks if obj%area is allocated
+!! @return true if obj%area is allocated
+logical function has_area (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_area = allocated(obj%area)
+end function has_area
+!> @brief Checks if obj%volume is allocated
+!! @return true if obj%volume is allocated
+logical function has_volume (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_volume = allocated(obj%volume)
+end function has_volume
+!> @brief Checks if obj%missing_value is allocated
+!! @return true if obj%missing_value is allocated
+logical function has_missing_value (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_missing_value = allocated(obj%missing_value)
+end function has_missing_value
+!> @brief Checks if obj%data_RANGE is allocated
+!! @return true if obj%data_RANGE is allocated
+logical function has_data_RANGE (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_data_RANGE = allocated(obj%data_RANGE)
+end function has_data_RANGE
+!> @brief Checks if obj%axis is allocated
+!! @return true if obj%axis is allocated
+logical function has_axis (obj)
+ class (fmsDiagObject_type), intent(in) :: obj !< diag object
+ has_axis = allocated(obj%axis)
+end function has_axis
+
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 67f0feebdd..e684759630 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -115,6 +115,24 @@ module fms_diag_yaml_mod
procedure :: get_file_varlist
procedure :: get_file_global_meta
procedure :: is_global_meta
+ !> Has functions to determine if allocatable variables are true. If a variable is not an allocatable
+ !! then is will always return .true.
+ procedure :: has_file_fname
+ procedure :: has_file_frequnit
+ procedure :: has_file_freq
+ procedure :: has_file_timeunit
+ procedure :: has_file_unlimdim
+ procedure :: has_file_write
+ procedure :: has_string_file_write
+ procedure :: has_file_realm
+ procedure :: has_file_sub_region
+ procedure :: has_file_new_file_freq
+ procedure :: has_file_new_file_freq_units
+ procedure :: has_file_start_time
+ procedure :: has_file_duration
+ procedure :: has_file_duration_units
+ procedure :: has_file_varlist
+ procedure :: has_file_global_meta
end type diagYamlFiles_type
@@ -150,6 +168,19 @@ module fms_diag_yaml_mod
procedure :: get_var_write
procedure :: get_var_attributes
procedure :: is_var_attributes
+
+ procedure :: has_var_fname
+ procedure :: has_var_varname
+ procedure :: has_var_reduction
+ procedure :: has_var_module
+ procedure :: has_var_skind
+ procedure :: has_string_var_write
+ procedure :: has_var_write
+ procedure :: has_var_outname
+ procedure :: has_var_longname
+ procedure :: has_var_units
+ procedure :: has_var_attributes
+
end type diagYamlFilesVar_type
!> @brief Object that holds the information of the diag_yaml
@@ -164,6 +195,12 @@ module fms_diag_yaml_mod
procedure :: get_basedate !< Returns the basedate array
procedure :: get_diag_files !< Returns the diag_files array
procedure :: get_diag_fields !< Returns the diag_field array
+
+ procedure :: has_diag_title
+ procedure :: has_diag_basedate
+ procedure :: has_diag_files
+ procedure :: has_diag_fields
+
end type diagYamlObject_type
type (diagYamlObject_type) :: diag_yaml !< Obj containing the contents of the diag_table.yaml
@@ -855,6 +892,204 @@ subroutine diag_yaml_files_obj_init(obj)
obj%file_sub_region%tile = DIAG_NULL
end subroutine diag_yaml_files_obj_init
+!> @brief Checks if obj%file_fname is allocated
+!! @return true if obj%file_fname is allocated
+pure logical function has_file_fname (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_fname = allocated(obj%file_fname)
+end function has_file_fname
+!> @brief Checks if obj%file_frequnit is allocated
+!! @return true if obj%file_frequnit is allocated
+pure logical function has_file_frequnit (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_frequnit = allocated(obj%file_frequnit)
+end function has_file_frequnit
+!> @brief obj%file_freq is on the stack, so the object always has it
+!! @return true if obj%file_freq is allocated
+pure logical function has_file_freq (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_freq = .true.
+end function has_file_freq
+!> @brief Checks if obj%file_timeunit is allocated
+!! @return true if obj%file_timeunit is allocated
+pure logical function has_file_timeunit (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_timeunit = allocated(obj%file_timeunit)
+end function has_file_timeunit
+!> @brief Checks if obj%file_unlimdim is allocated
+!! @return true if obj%file_unlimdim is allocated
+pure logical function has_file_unlimdim (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_unlimdim = allocated(obj%file_unlimdim)
+end function has_file_unlimdim
+!> @brief Checks if obj%file_write is on the stack, so this will always be true
+!! @return true
+pure logical function has_file_write (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_write = .true.
+end function has_file_write
+!> @brief Checks if obj%string_file_write is allocated
+!! @return true if obj%string_file_write is allocated
+pure logical function has_string_file_write (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_string_file_write = allocated(obj%string_file_write)
+end function has_string_file_write
+!> @brief Checks if obj%file_realm is allocated
+!! @return true if obj%file_realm is allocated
+pure logical function has_file_realm (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_realm = allocated(obj%file_realm)
+end function has_file_realm
+!> @brief Checks if obj%file_sub_region is being used and has the sub region variables allocated
+!! @return true if obj%file_sub_region sub region variables are allocated
+pure logical function has_file_sub_region (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ if ( (allocated(obj%file_sub_region%grid_type) .and. allocated(obj%file_sub_region%lat_lon_sub_region)) &
+ .or.(allocated(obj%file_sub_region%grid_type) .and. allocated(obj%file_sub_region%index_sub_region))) &
+ then
+ has_file_sub_region = .true.
+ else
+ has_file_sub_region = .false.
+ endif
+end function has_file_sub_region
+!> @brief obj%file_new_file_freq is defined on the stack, so this will return true
+!! @return true
+pure logical function has_file_new_file_freq (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_new_file_freq = .true.
+end function has_file_new_file_freq
+!> @brief Checks if obj%file_new_file_freq_units is allocated
+!! @return true if obj%file_new_file_freq_units is allocated
+pure logical function has_file_new_file_freq_units (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_new_file_freq_units = allocated(obj%file_new_file_freq_units)
+end function has_file_new_file_freq_units
+!> @brief Checks if obj%file_start_time is allocated
+!! @return true if obj%file_start_time is allocated
+pure logical function has_file_start_time (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_start_time = allocated(obj%file_start_time)
+end function has_file_start_time
+!> @brief obj%file_duration is allocated on th stack, so this is always true
+!! @return true
+pure logical function has_file_duration (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_duration = .true.
+end function has_file_duration
+!> @brief obj%file_duration_units is on the stack, so this will retrun true
+!! @return true
+pure logical function has_file_duration_units (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_duration_units = .true.
+end function has_file_duration_units
+!> @brief Checks if obj%file_varlist is allocated
+!! @return true if obj%file_varlist is allocated
+pure logical function has_file_varlist (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_varlist = allocated(obj%file_varlist)
+end function has_file_varlist
+!> @brief Checks if obj%file_global_meta is allocated
+!! @return true if obj%file_global_meta is allocated
+pure logical function has_file_global_meta (obj)
+ class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+ has_file_global_meta = allocated(obj%file_global_meta)
+end function has_file_global_meta
+
+!> @brief Checks if obj%var_fname is allocated
+!! @return true if obj%var_fname is allocated
+pure logical function has_var_fname (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_fname = allocated(obj%var_fname)
+end function has_var_fname
+!> @brief Checks if obj%var_varname is allocated
+!! @return true if obj%var_varname is allocated
+pure logical function has_var_varname (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_varname = allocated(obj%var_varname)
+end function has_var_varname
+!> @brief Checks if obj%var_reduction is allocated
+!! @return true if obj%var_reduction is allocated
+pure logical function has_var_reduction (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_reduction = allocated(obj%var_reduction)
+end function has_var_reduction
+!> @brief Checks if obj%var_module is allocated
+!! @return true if obj%var_module is allocated
+pure logical function has_var_module (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_module = allocated(obj%var_module)
+end function has_var_module
+!> @brief Checks if obj%var_skind is allocated
+!! @return true if obj%var_skind is allocated
+pure logical function has_var_skind (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_skind = allocated(obj%var_skind)
+end function has_var_skind
+!> @brief Checks if obj%string_var_write is allocated
+!! @return true if obj%string_var_write is allocated
+pure logical function has_string_var_write (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_string_var_write = allocated(obj%string_var_write)
+end function has_string_var_write
+!> @brief obj%var_write is on the stack, so this returns true
+!! @return true
+pure logical function has_var_write (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_write = .true.
+end function has_var_write
+!> @brief Checks if obj%var_outname is allocated
+!! @return true if obj%var_outname is allocated
+pure logical function has_var_outname (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_outname = allocated(obj%var_outname)
+end function has_var_outname
+!> @brief Checks if obj%var_longname is allocated
+!! @return true if obj%var_longname is allocated
+pure logical function has_var_longname (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_longname = allocated(obj%var_longname)
+end function has_var_longname
+!> @brief Checks if obj%var_units is allocated
+!! @return true if obj%var_units is allocated
+pure logical function has_var_units (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_units = allocated(obj%var_units)
+end function has_var_units
+!> @brief Checks if obj%var_attributes is allocated
+!! @return true if obj%var_attributes is allocated
+pure logical function has_var_attributes (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_attributes = allocated(obj%var_attributes)
+end function has_var_attributes
+
+
+
+!> @brief Checks if obj%diag_title is allocated
+!! @return true if obj%diag_title is allocated
+pure logical function has_diag_title (obj)
+ class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
+ has_diag_title = allocated(obj%diag_title)
+end function has_diag_title
+!> @brief obj%diag_basedate is on the stack, so this is always true
+!! @return true
+pure logical function has_diag_basedate (obj)
+ class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
+ has_diag_basedate = .true.
+end function has_diag_basedate
+!> @brief Checks if obj%diag_files is allocated
+!! @return true if obj%diag_files is allocated
+pure logical function has_diag_files (obj)
+ class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
+ has_diag_files = allocated(obj%diag_files)
+end function has_diag_files
+!> @brief Checks if obj%diag_fields is allocated
+!! @return true if obj%diag_fields is allocated
+pure logical function has_diag_fields (obj)
+ class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
+ has_diag_fields = allocated(obj%diag_fields)
+end function has_diag_fields
+
+
#endif
end module fms_diag_yaml_mod
!> @}
From 9ca540ba4141719e62d461982af0d4a143a4f45d Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Fri, 25 Feb 2022 14:34:52 -0500
Subject: [PATCH 033/168] feat: update functions to be pure in diag and yaml
objects (#923)
---
diag_manager/fms_diag_object.F90 | 94 ++++++++++++++++----------------
diag_manager/fms_diag_yaml.F90 | 2 +-
2 files changed, 48 insertions(+), 48 deletions(-)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 9f2f2fb589..9ac1eef07a 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -487,7 +487,7 @@ end function diag_obj_is_static
!> @brief Gets metedata
!! @return copy of metadata string array, or a single space if metadata is not allocated
-function get_metadata (obj) &
+pure function get_metadata (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable, dimension(:) :: rslt
@@ -501,7 +501,7 @@ function get_metadata (obj) &
end function get_metadata
!> @brief Gets static
!! @return copy of variable static
-function get_static (obj) &
+pure function get_static (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
logical :: rslt
@@ -509,7 +509,7 @@ function get_static (obj) &
end function get_static
!> @brief Gets regisetered
!! @return copy of registered
-function get_registered (obj) &
+pure function get_registered (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
logical :: rslt
@@ -517,7 +517,7 @@ function get_registered (obj) &
end function get_registered
!> @brief Gets mask variant
!! @return copy of mask variant
-function get_mask_variant (obj) &
+pure function get_mask_variant (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
logical :: rslt
@@ -525,7 +525,7 @@ function get_mask_variant (obj) &
end function get_mask_variant
!> @brief Gets local
!! @return copy of local
-function get_local (obj) &
+pure function get_local (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
logical :: rslt
@@ -542,7 +542,7 @@ end function get_local
!end function get_init_time
!> @brief Gets vartype
!! @return copy of The integer related to the variable type
-function get_vartype (obj) &
+pure function get_vartype (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
integer :: rslt
@@ -550,7 +550,7 @@ function get_vartype (obj) &
end function get_vartype
!> @brief Gets varname
!! @return copy of the variable name
-function get_varname (obj) &
+pure function get_varname (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable :: rslt
@@ -558,7 +558,7 @@ function get_varname (obj) &
end function get_varname
!> @brief Gets longname
!! @return copy of the variable long name or a single string if there is no long name
-function get_longname (obj) &
+pure function get_longname (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable :: rslt
@@ -570,7 +570,7 @@ function get_longname (obj) &
end function get_longname
!> @brief Gets standname
!! @return copy of the standard name or an empty string if standname is not allocated
-function get_standname (obj) &
+pure function get_standname (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable :: rslt
@@ -582,7 +582,7 @@ function get_standname (obj) &
end function get_standname
!> @brief Gets units
!! @return copy of the units or an empty string if not allocated
-function get_units (obj) &
+pure function get_units (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable :: rslt
@@ -594,7 +594,7 @@ function get_units (obj) &
end function get_units
!> @brief Gets modname
!! @return copy of the module name that the variable is in or an empty string if not allocated
-function get_modname (obj) &
+pure function get_modname (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable :: rslt
@@ -606,7 +606,7 @@ function get_modname (obj) &
end function get_modname
!> @brief Gets realm
!! @return copy of the variables modeling realm or an empty string if not allocated
-function get_realm (obj) &
+pure function get_realm (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable :: rslt
@@ -618,7 +618,7 @@ function get_realm (obj) &
end function get_realm
!> @brief Gets err_msg
!! @return copy of The error message stored in err_msg or an empty string if not allocated
-function get_err_msg (obj) &
+pure function get_err_msg (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable :: rslt
@@ -630,7 +630,7 @@ function get_err_msg (obj) &
end function get_err_msg
!> @brief Gets interp_method
!! @return copy of The interpolation method or an empty string if not allocated
-function get_interp_method (obj) &
+pure function get_interp_method (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable :: rslt
@@ -642,7 +642,7 @@ function get_interp_method (obj) &
end function get_interp_method
!> @brief Gets frequency
!! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated
-function get_frequency (obj) &
+pure function get_frequency (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
integer, allocatable, dimension (:) :: rslt
@@ -656,7 +656,7 @@ function get_frequency (obj) &
end function get_frequency
!> @brief Gets output_units
!! @return copy of The units of the output or DIAG_NULL is output_units is not allocated
-function get_output_units (obj) &
+pure function get_output_units (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
integer,allocatable, dimension (:) :: rslt
@@ -670,7 +670,7 @@ function get_output_units (obj) &
end function get_output_units
!> @brief Gets t
!! @return copy of t
-function get_t (obj) &
+pure function get_t (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
integer :: rslt
@@ -682,7 +682,7 @@ function get_t (obj) &
end function get_t
!> @brief Gets tile_count
!! @return copy of the number of tiles or diag_null if tile_count is not allocated
-function get_tile_count (obj) &
+pure function get_tile_count (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
integer :: rslt
@@ -694,7 +694,7 @@ function get_tile_count (obj) &
end function get_tile_count
!> @brief Gets axis_ids
!! @return copy of The axis IDs array or a diag_null if no axis IDs are set
-function get_axis_ids (obj) &
+pure function get_axis_ids (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
integer, allocatable, dimension(:) :: rslt
@@ -708,7 +708,7 @@ function get_axis_ids (obj) &
end function get_axis_ids
!> @brief Gets area
!! @return copy of the area or diag_null if not allocated
-function get_area (obj) &
+pure function get_area (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
integer :: rslt
@@ -720,7 +720,7 @@ function get_area (obj) &
end function get_area
!> @brief Gets volume
!! @return copy of the volume or diag_null if volume is not allocated
-function get_volume (obj) &
+pure function get_volume (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
integer :: rslt
@@ -952,43 +952,43 @@ end function int_ne_obj
!end function has_diag_file
!> @brief Checks if obj%diag_id is allocated
!! @return true if obj%diag_id is allocated
-logical function has_diag_id (obj)
+pure logical function has_diag_id (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_diag_id = allocated(obj%diag_id)
end function has_diag_id
!> @brief Checks if obj%fileob pointer is associated
!! @return true if obj%fileob is associated
-logical function has_fileob (obj)
+pure logical function has_fileob (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_fileob = associated(obj%fileob)
end function has_fileob
!> @brief Checks if obj%metadata is allocated
!! @return true if obj%metadata is allocated
-logical function has_metadata (obj)
+pure logical function has_metadata (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_metadata = allocated(obj%metadata)
end function has_metadata
!> @brief Checks if obj%static is allocated
!! @return true if obj%static is allocated
-logical function has_static (obj)
+pure logical function has_static (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_static = allocated(obj%static)
end function has_static
!> @brief Checks if obj%registered is allocated
!! @return true if obj%registered is allocated
-logical function has_registered (obj)
+pure logical function has_registered (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_registered = allocated(obj%registered)
end function has_registered
!> @brief Checks if obj%mask_variant is allocated
!! @return true if obj%mask_variant is allocated
-logical function has_mask_variant (obj)
+pure logical function has_mask_variant (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_mask_variant = allocated(obj%mask_variant)
end function has_mask_variant
!> @brief Checks if obj%local is allocated
!! @return true if obj%local is allocated
-logical function has_local (obj)
+pure logical function has_local (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_local = allocated(obj%local)
end function has_local
@@ -1000,115 +1000,115 @@ end function has_local
!end function has_init_time
!> @brief Checks if obj%vartype is allocated
!! @return true if obj%vartype is allocated
-logical function has_vartype (obj)
+pure logical function has_vartype (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_vartype = allocated(obj%vartype)
end function has_vartype
!> @brief Checks if obj%varname is allocated
!! @return true if obj%varname is allocated
-logical function has_varname (obj)
+pure logical function has_varname (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_varname = allocated(obj%varname)
end function has_varname
!> @brief Checks if obj%longname is allocated
!! @return true if obj%longname is allocated
-logical function has_longname (obj)
+pure logical function has_longname (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_longname = allocated(obj%longname)
end function has_longname
!> @brief Checks if obj%standname is allocated
!! @return true if obj%standname is allocated
-logical function has_standname (obj)
+pure logical function has_standname (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_standname = allocated(obj%standname)
end function has_standname
!> @brief Checks if obj%units is allocated
!! @return true if obj%units is allocated
-logical function has_units (obj)
+pure logical function has_units (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_units = allocated(obj%units)
end function has_units
!> @brief Checks if obj%modname is allocated
!! @return true if obj%modname is allocated
-logical function has_modname (obj)
+pure logical function has_modname (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_modname = allocated(obj%modname)
end function has_modname
!> @brief Checks if obj%realm is allocated
!! @return true if obj%realm is allocated
-logical function has_realm (obj)
+pure logical function has_realm (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_realm = allocated(obj%realm)
end function has_realm
!> @brief Checks if obj%err_msg is allocated
!! @return true if obj%err_msg is allocated
-logical function has_err_msg (obj)
+pure logical function has_err_msg (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_err_msg = allocated(obj%err_msg)
end function has_err_msg
!> @brief Checks if obj%interp_method is allocated
!! @return true if obj%interp_method is allocated
-logical function has_interp_method (obj)
+pure logical function has_interp_method (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_interp_method = allocated(obj%interp_method)
end function has_interp_method
!> @brief Checks if obj%frequency is allocated
!! @return true if obj%frequency is allocated
-logical function has_frequency (obj)
+pure logical function has_frequency (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_frequency = allocated(obj%frequency)
end function has_frequency
!> @brief Checks if obj%output_units is allocated
!! @return true if obj%output_units is allocated
-logical function has_output_units (obj)
+pure logical function has_output_units (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_output_units = allocated(obj%output_units)
end function has_output_units
!> @brief Checks if obj%t is allocated
!! @return true if obj%t is allocated
-logical function has_t (obj)
+pure logical function has_t (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_t = allocated(obj%t)
end function has_t
!> @brief Checks if obj%tile_count is allocated
!! @return true if obj%tile_count is allocated
-logical function has_tile_count (obj)
+pure logical function has_tile_count (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_tile_count = allocated(obj%tile_count)
end function has_tile_count
!> @brief Checks if obj%axis_ids is allocated
!! @return true if obj%axis_ids is allocated
-logical function has_axis_ids (obj)
+pure logical function has_axis_ids (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_axis_ids = allocated(obj%axis_ids)
end function has_axis_ids
!> @brief Checks if obj%area is allocated
!! @return true if obj%area is allocated
-logical function has_area (obj)
+pure logical function has_area (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_area = allocated(obj%area)
end function has_area
!> @brief Checks if obj%volume is allocated
!! @return true if obj%volume is allocated
-logical function has_volume (obj)
+pure logical function has_volume (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_volume = allocated(obj%volume)
end function has_volume
!> @brief Checks if obj%missing_value is allocated
!! @return true if obj%missing_value is allocated
-logical function has_missing_value (obj)
+pure logical function has_missing_value (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_missing_value = allocated(obj%missing_value)
end function has_missing_value
!> @brief Checks if obj%data_RANGE is allocated
!! @return true if obj%data_RANGE is allocated
-logical function has_data_RANGE (obj)
+pure logical function has_data_RANGE (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_data_RANGE = allocated(obj%data_RANGE)
end function has_data_RANGE
!> @brief Checks if obj%axis is allocated
!! @return true if obj%axis is allocated
-logical function has_axis (obj)
+pure logical function has_axis (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_axis = allocated(obj%axis)
end function has_axis
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index e684759630..9c3ae48483 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -211,7 +211,7 @@ module fms_diag_yaml_mod
!> @brief gets the diag_yaml module variable
!! @return a copy of the diag_yaml module variable
-function get_diag_yaml_obj() &
+pure function get_diag_yaml_obj() &
result(res)
type (diagYamlObject_type) :: res
From e77c03fe19f96bf2ed2fde196974bb6a2b4f5776 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 14 Mar 2022 13:33:16 -0400
Subject: [PATCH 034/168] feat: modern diag add diag_model_subset behaviour for
ocean models (#927)
---
diag_manager/diag_manager.F90 | 2 +-
diag_manager/fms_diag_yaml.F90 | 58 +++++++--
test_fms/diag_manager/Makefile.am | 3 +-
test_fms/diag_manager/test_diag_manager2.sh | 127 ++++++++++++++++++++
test_fms/diag_manager/test_diag_ocean.F90 | 100 +++++++++++++++
test_fms/diag_manager/test_diag_yaml.F90 | 8 +-
6 files changed, 285 insertions(+), 13 deletions(-)
create mode 100644 test_fms/diag_manager/test_diag_ocean.F90
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index b4ba4d5530..11dc42bd17 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -3950,7 +3950,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
END IF
#ifdef use_yaml
- if (use_modern_diag) CALL diag_yaml_object_init()
+ if (use_modern_diag) CALL diag_yaml_object_init(diag_subset_output)
#endif
CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 9c3ae48483..6f5e758062 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -30,7 +30,7 @@
!> @{
module fms_diag_yaml_mod
#ifdef use_yaml
-use diag_data_mod, only: DIAG_NULL
+use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL
@@ -97,6 +97,7 @@ module fms_diag_yaml_mod
!! meta data to the file
contains
+
!> All getter functions (functions named get_x(), for member field named x)
!! return copies of the member variables unless explicitly noted.
procedure :: get_file_fname
@@ -260,7 +261,12 @@ end function get_diag_fields
!> @brief Uses the yaml_parser_mod to read in the diag_table and fill in the
!! diag_yaml object
-subroutine diag_yaml_object_init
+subroutine diag_yaml_object_init(diag_subset_output)
+ integer, intent(in) :: diag_subset_output !< DIAG_ALL - Current PE is in the one and only pelist
+ !! DIAG_OTHER - Current PE is not in the ocean pelist
+ !! and there are multiple pelists
+ !! DIAG_OCEAN - Current PE is in the ocean pelist
+ !! and there are multiple pelists
integer :: diag_yaml_id !< Id for the diag_table yaml
integer :: nfiles !< Number of files in the diag_table yaml
integer, allocatable :: diag_file_ids(:) !< Ids of the files in the diag_table yaml
@@ -269,6 +275,10 @@ subroutine diag_yaml_object_init
integer :: var_count !< The current number of variables added to the diag_yaml obj
integer :: nvars !< The number of variables in the current file
integer, allocatable :: var_ids(:) !< Ids of the variables in diag_table yaml
+ logical :: is_ocean !< Flag indicating if it is an ocean file
+ logical, allocatable :: ignore(:) !< Flag indicating if the diag_file is going to be ignored
+ integer :: actual_num_files !< The actual number of files that were saved
+ integer :: file_count !! The current number of files added to the diag_yaml obj
diag_yaml_id = open_and_parse_file("diag_table.yaml")
@@ -276,32 +286,62 @@ subroutine diag_yaml_object_init
call get_value_from_key(diag_yaml_id, 0, "base_date", diag_yaml%diag_basedate)
nfiles = get_num_blocks(diag_yaml_id, "diag_files")
- allocate(diag_yaml%diag_files(nfiles))
allocate(diag_file_ids(nfiles))
+ allocate(ignore(nfiles))
+
call get_block_ids(diag_yaml_id, "diag_files", diag_file_ids)
- total_nvars = get_total_num_vars(diag_yaml_id, diag_file_ids)
+ ignore = .false.
+ total_nvars = 0
+ !< If you are on two seperate pelists
+ if(diag_subset_output .ne. DIAG_ALL) then
+ actual_num_files = 0
+ do i = 1, nfiles
+ is_ocean = .false.
+ call get_value_from_key(diag_yaml_id, diag_file_ids(i), "is_ocean", is_ocean, is_optional=.true.)
+ !< If you are on the ocean pelist and the file is not an ocean file, skip the file
+ if (diag_subset_output .eq. DIAG_OCEAN .and. .not. is_ocean) ignore(i) = .true.
+
+ !< If you are not on the ocean pelist and the file is ocean, skip the file
+ if(diag_subset_output .eq. DIAG_OTHER .and. is_ocean) ignore(i) = .true.
+
+ if (.not. ignore(i)) then
+ actual_num_files = actual_num_files + 1
+ !< If ignoring the file, ignore the fields in that file too!
+ total_nvars = total_nvars + get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i))
+ endif
+ enddo
+ else
+ actual_num_files = nfiles
+ total_nvars = get_total_num_vars(diag_yaml_id, diag_file_ids)
+ endif
+
+ allocate(diag_yaml%diag_files(actual_num_files))
allocate(diag_yaml%diag_fields(total_nvars))
var_count = 0
+ file_count = 0
+ !> Loop through the number of nfiles and fill in the diag_yaml obj
nfiles_loop: do i = 1, nfiles
- call diag_yaml_files_obj_init(diag_yaml%diag_files(i))
- call fill_in_diag_files(diag_yaml_id, diag_file_ids(i), diag_yaml%diag_files(i))
+ if(ignore(i)) cycle
+ file_count = file_count + 1
+ call diag_yaml_files_obj_init(diag_yaml%diag_files(file_count))
+ call fill_in_diag_files(diag_yaml_id, diag_file_ids(i), diag_yaml%diag_files(file_count))
nvars = 0
nvars = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i))
allocate(var_ids(nvars))
call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=diag_file_ids(i))
- allocate(diag_yaml%diag_files(i)%file_varlist(nvars))
+ allocate(diag_yaml%diag_files(file_count)%file_varlist(nvars))
nvars_loop: do j = 1, nvars
var_count = var_count + 1
!> Save the filename in the diag_field type
- diag_yaml%diag_fields(var_count)%var_fname = diag_yaml%diag_files(i)%file_fname
+ diag_yaml%diag_fields(var_count)%var_fname = diag_yaml%diag_files(file_count)%file_fname
call fill_in_diag_fields(diag_yaml_id, var_ids(j), diag_yaml%diag_fields(var_count))
!> Save the variable name in the diag_file type
- diag_yaml%diag_files(i)%file_varlist(j) = diag_yaml%diag_fields(var_count)%var_varname
+ diag_yaml%diag_files(file_count)%file_varlist(j) = diag_yaml%diag_fields(var_count)%var_varname
enddo nvars_loop
deallocate(var_ids)
enddo nfiles_loop
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 79ecc644de..ed255c665f 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -30,7 +30,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
# Build this test program.
check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_object_container \
test_diag_update_buffer test_diag_dlinked_list \
- test_diag_dlinked_list test_diag_yaml
+ test_diag_yaml test_diag_ocean
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -39,6 +39,7 @@ test_diag_update_buffer_SOURCES= test_diag_update_buffer.F90
test_diag_yaml_SOURCES = test_diag_yaml.F90
test_diag_object_container_SOURCES = test_diag_object_container.F90
test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90
+test_diag_ocean_SOURCES = test_diag_ocean.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 9e9892a2e9..1ef881ccc1 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -509,4 +509,131 @@ test_expect_success "Test the diag update_buffer (test $my_test_count)" '
mpirun -n 1 ../test_diag_update_buffer
'
+cat <<_EOF > diag_table.yaml
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: wild_card_name%4yr%2mo%2dy%2hr
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6
+ new_file_freq_units: hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12
+ file_duration_units: hours
+ write_file: false
+ realm: ATM
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst
+ output_name: sst
+ reduction: average
+ kind: float
+ write_var: false
+ global_meta:
+ - is_a_file: true
+- file_name: normal
+ freq: 24
+ freq_units: days
+ time_units: hours
+ unlimdim: records
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst
+ output_name: sst
+ reduction: average
+ kind: float
+ write_var: true
+ attributes:
+ - do_sst: .true.
+ sub_region:
+ - grid_type: latlon
+ dim1_begin: 64.0
+ dim3_end: 20.0
+- file_name: normal2
+ freq: -1
+ freq_units: days
+ time_units: hours
+ unlimdim: records
+ write_file: true
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sstt
+ output_name: sstt
+ reduction: average
+ kind: float
+ long_name: S S T
+ sub_region:
+ - grid_type: index
+ tile: 1
+ dim2_begin: 10
+ dim2_end: 20
+ dim1_begin: 10
+_EOF
+cp diag_table.yaml diag_table.yaml_base
+
+test_expect_success "diag_yaml test (test $my_test_count)" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+. $top_srcdir/test_fms/diag_manager/check_crashes.sh
+
+printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml
+cat <<_EOF > diag_table.yaml
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: file1
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst1
+ output_name: sst1
+ reduction: average
+ kind: float
+- file_name: file2
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ is_ocean: True
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst2
+ output_name: sst2
+ reduction: average
+ kind: float
+- file_name: file3
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst3
+ output_name: sst3
+ reduction: average
+ kind: float
+ - module: test_diag_manager_mod
+ var_name: sst4
+ output_name: sst4
+ reduction: average
+ kind: float
+_EOF
+test_expect_success "Test the diag_ocean feature in diag_manager_init (test $my_test_count)" '
+ mpirun -n 2 ../test_diag_ocean
+'
+
+test_expect_success "test_diag_object_container (test $my_test_count)" '
+ mpirun -n 1 ../test_diag_object_container
+'
+test_expect_success "test_diag_dlinked_list (test $my_test_count)" '
+ mpirun -n 1 ../test_diag_dlinked_list
+'
+
test_done
diff --git a/test_fms/diag_manager/test_diag_ocean.F90 b/test_fms/diag_manager/test_diag_ocean.F90
new file mode 100644
index 0000000000..449569dd49
--- /dev/null
+++ b/test_fms/diag_manager/test_diag_ocean.F90
@@ -0,0 +1,100 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This program tests the diag_model_subset feature of diag_mananger_init
+!! It requires two PEs to run and it runs with diag_table_yaml_27
+program test_diag_ocean
+
+#ifdef use_yaml
+use FMS_mod, only: fms_init, fms_end, string
+use fms_diag_yaml_mod
+use diag_manager_mod, only: diag_manager_init
+use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_OTHER
+use mpp_mod
+use platform_mod
+
+implicit none
+
+type(diagYamlObject_type) :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init
+type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< Files from the diag_yaml
+type(diagYamlFilesVar_type), allocatable, dimension(:) :: diag_fields !< Fields from the diag_yaml
+character(len=10), allocatable :: file_names(:) !< The expected names of the files
+character(len=10), allocatable :: var_names(:) !< The expected names of the variables
+integer :: diag_subset !< Diag_subset to be sent to diag_manager_init
+integer :: nfiles !< Expected number of files
+integer :: nvariables !< Expected number of variables
+integer :: i !< For do loops
+
+call fms_init()
+
+if (mpp_npes() .ne. 2) call mpp_error(FATAL, "test_diag_ocean requires two PEs!")
+
+!> PE 0 is not going to include the file with is_ocean = .true.
+if (mpp_pe() .eq. 0) then
+ diag_subset = DIAG_OTHER
+ nfiles = 2
+ allocate(file_names(nfiles))
+ file_names = (/"file1", "file3"/)
+ nvariables = 3
+ allocate(var_names(nvariables))
+ var_names = (/"sst1", "sst3", "sst4"/)
+endif
+
+!> PE 1 is only going to include the file with is_ocean = .true.
+if (mpp_pe() .eq. 1) then
+ diag_subset = DIAG_OCEAN
+ nfiles = 1
+ allocate(file_names(nfiles))
+ file_names = (/"file2"/)
+ nvariables = 1
+ allocate(var_names(nvariables))
+ var_names = (/"sst2"/)
+endif
+
+call diag_manager_init(diag_model_subset=diag_subset)
+
+my_yaml = get_diag_yaml_obj()
+diag_files = my_yaml%get_diag_files()
+if (size(diag_files) .ne. nfiles) call mpp_error(FATAL, "The number of files should be "//string(nfiles))
+
+do i = 1, nfiles
+ if(trim(file_names(i)) .ne. diag_files(i)%get_file_fname()) &
+ call mpp_error(FATAL, "The file_name should of the "//string(i)//" file should be "//&
+ &trim(file_names(i))//" not "//diag_files(i)%get_file_fname())
+end do
+
+diag_fields = my_yaml%get_diag_fields()
+if (size(diag_fields) .ne. nvariables) call mpp_error(FATAL, "The number of variables should be "//string(nvariables))
+
+do i = 1, nvariables
+ if(trim(var_names(i)) .ne. diag_fields(i)%get_var_varname()) &
+ call mpp_error(FATAL, "The var_name should of the "//string(i)//" field should be "//&
+ &trim(var_names(i))//" not "//diag_fields(i)%get_var_varname())
+end do
+
+deallocate(diag_files)
+deallocate(diag_fields)
+deallocate(file_names)
+deallocate(var_names)
+
+call diag_yaml_object_end
+call fms_end()
+
+#endif
+end program test_diag_ocean
\ No newline at end of file
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index 32ef98cd9d..854d0efaf4 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -24,7 +24,7 @@ program test_diag_yaml
#ifdef use_yaml
use FMS_mod, only: fms_init, fms_end
use fms_diag_yaml_mod
-use diag_data_mod, only: DIAG_NULL
+use diag_data_mod, only: DIAG_NULL, DIAG_ALL
use mpp_mod
use platform_mod
@@ -61,7 +61,11 @@ end subroutine compare_result_1d
read (input_nml_file, check_crashes_nml, iostat=io_status)
if (io_status > 0) call mpp_error(FATAL,'=>check_crashes: Error reading input.nml')
-call diag_yaml_object_init
+#ifndef use_yaml
+if (checking_crashes) call mpp_error(FATAL, "It is crashing!")
+call fms_end()
+#else
+call diag_yaml_object_init(DIAG_ALL)
my_yaml = get_diag_yaml_obj()
From 3a0569439c98be13127e210bde091c40e11b25f5 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 14 Mar 2022 14:52:46 -0400
Subject: [PATCH 035/168] feat: rework logic to ignore non-written files (#936)
---
diag_manager/fms_diag_yaml.F90 | 102 ++++++++------------
test_fms/diag_manager/test_diag_manager2.sh | 15 ++-
test_fms/diag_manager/test_diag_yaml.F90 | 12 +--
3 files changed, 54 insertions(+), 75 deletions(-)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 6f5e758062..e17fc4d19b 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -71,9 +71,6 @@ module fms_diag_yaml_mod
integer, private :: file_freq !< the frequency of data
character (len=:), private, allocatable :: file_timeunit !< The unit of time
character (len=:), private, allocatable :: file_unlimdim !< The name of the unlimited dimension
- logical, private :: file_write !< false if the user doesn't want to the file to be created
- character (len=:), private, allocatable :: string_file_write !< false if the user doesn’t want the file to be
- !! created (default is true).
character (len=:), private, allocatable :: file_realm !< The modeling realm that the variables come from
type(subRegion_type), private :: file_sub_region !< type containing info about the subregion, if any
integer, private :: file_new_file_freq !< Frequency for closing the existing file
@@ -105,7 +102,6 @@ module fms_diag_yaml_mod
procedure :: get_file_freq
procedure :: get_file_timeunit
procedure :: get_file_unlimdim
- procedure :: get_file_write
procedure :: get_file_realm
procedure :: get_file_sub_region
procedure :: get_file_new_file_freq
@@ -123,8 +119,6 @@ module fms_diag_yaml_mod
procedure :: has_file_freq
procedure :: has_file_timeunit
procedure :: has_file_unlimdim
- procedure :: has_file_write
- procedure :: has_string_file_write
procedure :: has_file_realm
procedure :: has_file_sub_region
procedure :: has_file_new_file_freq
@@ -144,10 +138,6 @@ module fms_diag_yaml_mod
character (len=:), private, allocatable :: var_reduction !< Reduction to be done on var
character (len=:), private, allocatable :: var_module !< The module that th variable is in
character (len=:), private, allocatable :: var_skind !< The type/kind of the variable
- character (len=:), private, allocatable :: string_var_write !< false if the user doesn’t want the variable to be
- !! written to the file (default: true).
- logical, private :: var_write !< false if the user doesn’t want the variable to be
- !! written to the file (default: true).
character (len=:), private, allocatable :: var_outname !< Name of the variable as written to the file
character (len=:), private, allocatable :: var_longname !< Overwrites the long name of the variable
character (len=:), private, allocatable :: var_units !< Overwrites the units
@@ -166,7 +156,6 @@ module fms_diag_yaml_mod
procedure :: get_var_outname
procedure :: get_var_longname
procedure :: get_var_units
- procedure :: get_var_write
procedure :: get_var_attributes
procedure :: is_var_attributes
@@ -175,8 +164,6 @@ module fms_diag_yaml_mod
procedure :: has_var_reduction
procedure :: has_var_module
procedure :: has_var_skind
- procedure :: has_string_var_write
- procedure :: has_var_write
procedure :: has_var_outname
procedure :: has_var_longname
procedure :: has_var_units
@@ -273,12 +260,15 @@ subroutine diag_yaml_object_init(diag_subset_output)
integer :: i, j !< For do loops
integer :: total_nvars !< The total number of variables in the diag_table yaml
integer :: var_count !< The current number of variables added to the diag_yaml obj
+ integer :: file_var_count !< The current number of variables added in the diag_file
integer :: nvars !< The number of variables in the current file
integer, allocatable :: var_ids(:) !< Ids of the variables in diag_table yaml
logical :: is_ocean !< Flag indicating if it is an ocean file
logical, allocatable :: ignore(:) !< Flag indicating if the diag_file is going to be ignored
integer :: actual_num_files !< The actual number of files that were saved
integer :: file_count !! The current number of files added to the diag_yaml obj
+ logical :: write_file !< Flag indicating if the user wants the file to be written
+ logical :: write_var !< Flag indicating if the user wants the variable to be written
diag_yaml_id = open_and_parse_file("diag_table.yaml")
@@ -295,7 +285,6 @@ subroutine diag_yaml_object_init(diag_subset_output)
total_nvars = 0
!< If you are on two seperate pelists
if(diag_subset_output .ne. DIAG_ALL) then
- actual_num_files = 0
do i = 1, nfiles
is_ocean = .false.
call get_value_from_key(diag_yaml_id, diag_file_ids(i), "is_ocean", is_ocean, is_optional=.true.)
@@ -304,17 +293,22 @@ subroutine diag_yaml_object_init(diag_subset_output)
!< If you are not on the ocean pelist and the file is ocean, skip the file
if(diag_subset_output .eq. DIAG_OTHER .and. is_ocean) ignore(i) = .true.
+ enddo
+ endif
+
+ !< Determine how many files are in the diag_yaml, ignoring those with write_file = False
+ actual_num_files = 0
+ do i = 1, nfiles
+ write_file = .true.
+ call get_value_from_key(diag_yaml_id, diag_file_ids(i), "write_file", write_file, is_optional=.true.)
+ if(.not. write_file) ignore(i) = .true.
- if (.not. ignore(i)) then
+ if (.not. ignore(i)) then
actual_num_files = actual_num_files + 1
!< If ignoring the file, ignore the fields in that file too!
- total_nvars = total_nvars + get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i))
- endif
- enddo
- else
- actual_num_files = nfiles
- total_nvars = get_total_num_vars(diag_yaml_id, diag_file_ids)
- endif
+ total_nvars = total_nvars + get_total_num_vars(diag_yaml_id, diag_file_ids(i))
+ endif
+ enddo
allocate(diag_yaml%diag_files(actual_num_files))
allocate(diag_yaml%diag_fields(total_nvars))
@@ -332,16 +326,23 @@ subroutine diag_yaml_object_init(diag_subset_output)
nvars = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i))
allocate(var_ids(nvars))
call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=diag_file_ids(i))
- allocate(diag_yaml%diag_files(file_count)%file_varlist(nvars))
+ file_var_count = 0
+ allocate(diag_yaml%diag_files(file_count)%file_varlist(get_total_num_vars(diag_yaml_id, diag_file_ids(i))))
nvars_loop: do j = 1, nvars
+ write_var = .true.
+ call get_value_from_key(diag_yaml_id, var_ids(j), "write_var", write_var, is_optional=.true.)
+ if (.not. write_var) cycle
+
var_count = var_count + 1
+ file_var_count = file_var_count + 1
+
!> Save the filename in the diag_field type
diag_yaml%diag_fields(var_count)%var_fname = diag_yaml%diag_files(file_count)%file_fname
call fill_in_diag_fields(diag_yaml_id, var_ids(j), diag_yaml%diag_fields(var_count))
!> Save the variable name in the diag_file type
- diag_yaml%diag_files(file_count)%file_varlist(j) = diag_yaml%diag_fields(var_count)%var_varname
+ diag_yaml%diag_files(file_count)%file_varlist(file_var_count) = diag_yaml%diag_fields(var_count)%var_varname
enddo nvars_loop
deallocate(var_ids)
enddo nfiles_loop
@@ -394,8 +395,6 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", fileobj%file_timeunit)
call check_file_time_units(fileobj)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "write_file", fileobj%string_file_write, is_optional=.true.)
- if (fileobj%string_file_write .eq. "false") fileobj%file_write = .false.
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "realm", fileobj%file_realm, is_optional=.true.)
call check_file_realm(fileobj)
@@ -469,7 +468,6 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field)
integer, allocatable :: key_ids(:) !< Id of each attribute key/value pair
- field%var_write = .true.
call diag_get_value_from_key(diag_file_id, var_id, "var_name", field%var_varname)
call diag_get_value_from_key(diag_file_id, var_id, "reduction", field%var_reduction)
call check_field_reduction(field)
@@ -478,9 +476,6 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field)
call diag_get_value_from_key(diag_file_id, var_id, "kind", field%var_skind)
call check_field_kind(field)
- call diag_get_value_from_key(diag_file_id, var_id, "write_var", field%string_var_write, is_optional=.true.)
- if (trim(field%string_var_write) .eq. "false") field%var_write = .false.
-
call diag_get_value_from_key(diag_file_id, var_id, "output_name", field%var_outname)
call diag_get_value_from_key(diag_file_id, var_id, "long_name", field%var_longname, is_optional=.true.)
!! VAR_UNITS !!
@@ -542,18 +537,28 @@ end subroutine get_sub_region
!> @brief gets the total number of variables in the diag_table yaml file
!! @return total number of variables
-function get_total_num_vars(diag_yaml_id, diag_file_ids) &
+function get_total_num_vars(diag_yaml_id, diag_file_id) &
result(total_nvars)
integer, intent(in) :: diag_yaml_id !< Id for the diag_table yaml
- integer, intent(in) :: diag_file_ids(:) !< Ids of the files in the diag_table yaml
+ integer, intent(in) :: diag_file_id !< Id of the file in the diag_table yaml
integer :: total_nvars
integer :: i !< For do loop
+ integer :: nvars !< Number of variables in a file
+ integer, allocatable :: var_ids(:) !< Id of the variables in the file block of the yaml file
+ logical :: var_write !< Flag indicating if the user wants the variable to be written
+
+ nvars = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_id)
+ allocate(var_ids(nvars))
+ call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=diag_file_id)
+ !< Loop through all the variables in the diag_file block and only count those that don't have write_var=false
total_nvars = 0
- do i = 1, size(diag_file_ids,1)
- total_nvars = total_nvars + get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i))
+ do i = 1, nvars
+ var_write = .true.
+ call get_value_from_key(diag_yaml_id, var_ids(i), "write_var", var_write, is_optional=.true.)
+ if (var_write) total_nvars = total_nvars + 1
end do
end function
@@ -732,14 +737,6 @@ pure function get_file_unlimdim(diag_files_obj) &
character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_unlimdim
end function get_file_unlimdim
-!> @brief Inquiry for diag_files_obj%file_write
-!! @return file_write of a diag_yaml_file_obj
-pure function get_file_write(diag_files_obj) &
-result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- logical :: res !< What is returned
- res = diag_files_obj%file_write
-end function get_file_write
!> @brief Inquiry for diag_files_obj%file_realm
!! @return file_realm of a diag_yaml_file_obj
pure function get_file_realm(diag_files_obj) &
@@ -893,14 +890,6 @@ pure function get_var_units (diag_var_obj) &
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_units
end function get_var_units
-!> @brief Inquiry for diag_yaml_files_var_obj%var_write
-!! @return var_write of a diag_yaml_files_var_obj
-pure function get_var_write (diag_var_obj) &
-result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- logical :: res !< What is returned
- res = diag_var_obj%var_write
-end function get_var_write
!> @brief Inquiry for diag_yaml_files_var_obj%var_attributes
!! @return var_attributes of a diag_yaml_files_var_obj
pure function get_var_attributes(diag_var_obj) &
@@ -926,7 +915,6 @@ subroutine diag_yaml_files_obj_init(obj)
type(diagYamlFiles_type), intent(out) :: obj !< diagYamlFiles_type object to initialize
obj%file_freq = DIAG_NULL
- obj%file_write = .true.
obj%file_duration = DIAG_NULL
obj%file_new_file_freq = DIAG_NULL
obj%file_sub_region%tile = DIAG_NULL
@@ -968,12 +956,6 @@ pure logical function has_file_write (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
has_file_write = .true.
end function has_file_write
-!> @brief Checks if obj%string_file_write is allocated
-!! @return true if obj%string_file_write is allocated
-pure logical function has_string_file_write (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_string_file_write = allocated(obj%string_file_write)
-end function has_string_file_write
!> @brief Checks if obj%file_realm is allocated
!! @return true if obj%file_realm is allocated
pure logical function has_file_realm (obj)
@@ -1065,12 +1047,6 @@ pure logical function has_var_skind (obj)
class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
has_var_skind = allocated(obj%var_skind)
end function has_var_skind
-!> @brief Checks if obj%string_var_write is allocated
-!! @return true if obj%string_var_write is allocated
-pure logical function has_string_var_write (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_string_var_write = allocated(obj%string_var_write)
-end function has_string_var_write
!> @brief obj%var_write is on the stack, so this returns true
!! @return true
pure logical function has_var_write (obj)
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 1ef881ccc1..69fe54556c 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -523,7 +523,6 @@ diag_files:
start_time: 2 1 1 0 0 0
file_duration: 12
file_duration_units: hours
- write_file: false
realm: ATM
varlist:
- module: test_diag_manager_mod
@@ -531,7 +530,6 @@ diag_files:
output_name: sst
reduction: average
kind: float
- write_var: false
global_meta:
- is_a_file: true
- file_name: normal
@@ -565,12 +563,25 @@ diag_files:
reduction: average
kind: float
long_name: S S T
+ - module: test_diag_manager_mod
+ var_name: sstt2
+ output_name: sstt2
+ reduction: average
+ kind: float
+ long_name: S S T
+ write_var: false
sub_region:
- grid_type: index
tile: 1
dim2_begin: 10
dim2_end: 20
dim1_begin: 10
+- file_name: normal3
+ freq: -1
+ freq_units: days
+ time_units: hours
+ unlimdim: records
+ write_file: false
_EOF
cp diag_table.yaml diag_table.yaml_base
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index 854d0efaf4..f38719e737 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -74,11 +74,11 @@ end subroutine compare_result_1d
call compare_result("title", my_yaml%get_title(), "test_diag_manager")
diag_files = my_yaml%get_diag_files()
- call compare_result("nfiles", size(diag_files), 3)
+ call compare_result("nfiles", size(diag_files), 3) !< the fourth file has file_write = false so it doesn't count
call compare_diag_files(diag_files)
diag_fields = my_yaml%get_diag_fields()
- call compare_result("nfields", size(diag_fields), 3)
+ call compare_result("nfields", size(diag_fields), 3) !< the fourth variable has var_write = false so it doesn't count
call compare_diag_fields(diag_fields)
endif
@@ -117,10 +117,6 @@ subroutine compare_diag_fields(res)
call compare_result("var_skind 2", res(2)%get_var_skind(), "float")
call compare_result("var_skind 3", res(3)%get_var_skind(), "float")
- call compare_result("var_write 1", res(1)%get_var_write(), .false.)
- call compare_result("var_write 2", res(2)%get_var_write(), .true.)
- call compare_result("var_write 3", res(3)%get_var_write(), .true.)
-
call compare_result("var_outname 1", res(1)%get_var_outname(), "sst")
call compare_result("var_outname 2", res(2)%get_var_outname(), "sst")
call compare_result("var_outname 3", res(3)%get_var_outname(), "sstt")
@@ -173,10 +169,6 @@ subroutine compare_diag_files(res)
call compare_result("file_realm 2", res(2)%get_file_realm(), "")
call compare_result("file_realm 3", res(3)%get_file_realm(), "")
- call compare_result("file_write 1", res(1)%get_file_write(), .false.)
- call compare_result("file_write 2", res(2)%get_file_write(), .true.)
- call compare_result("file_write 3", res(3)%get_file_write(), .true.)
-
call compare_result("file_new_file_freq 1", res(1)%get_file_new_file_freq(), 6)
call compare_result("file_new_file_freq 2", res(2)%get_file_new_file_freq(), DIAG_NULL)
call compare_result("file_new_file_freq 3", res(3)%get_file_new_file_freq(), DIAG_NULL)
From 63ceb6855ce7b2f35e86e18536fc8183288c147d Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 21 Mar 2022 14:04:47 -0400
Subject: [PATCH 036/168] feat: updates for setting/getting base time variables
and add test (#937)
---
diag_manager/diag_data.F90 | 115 ++++++++++++++++++++++-
diag_manager/diag_manager.F90 | 40 +++-----
diag_manager/diag_table.F90 | 44 ++-------
diag_manager/diag_util.F90 | 24 ++---
diag_manager/fms_diag_yaml.F90 | 3 +-
test_fms/diag_manager/test_diag_yaml.F90 | 23 ++++-
6 files changed, 168 insertions(+), 81 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 04e8c048a8..103bf9749d 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -48,11 +48,12 @@
MODULE diag_data_mod
use platform_mod
- USE time_manager_mod, ONLY: time_type
+ USE time_manager_mod, ONLY: get_calendar_type, NO_CALENDAR, set_date, set_time, month_name, time_type
+ USE constants_mod, ONLY: SECONDS_PER_HOUR, SECONDS_PER_MINUTE
USE mpp_domains_mod, ONLY: domain1d, domain2d, domainUG
- USE fms_mod, ONLY: WARNING, write_version_number
USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type
-
+ USE fms_mod, ONLY: write_version_number
+ use mpp_mod, ONLY: mpp_error, FATAL, WARNING, mpp_pe, mpp_root_pe, stdlog
! NF90_FILL_REAL has value of 9.9692099683868690e+36.
USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL
use fms2_io_mod
@@ -370,8 +371,10 @@ MODULE diag_data_mod
!
TYPE(time_type) :: diag_init_time !< Time diag_manager_init called. If init_time not included in
!! diag_manager_init call, then same as base_time
- TYPE(time_type) :: base_time
- INTEGER :: base_year, base_month, base_day, base_hour, base_minute, base_second
+ TYPE(time_type), private :: base_time !< The base_time read from diag_table
+ logical, private :: base_time_set !< Flag indicating that the base_time is set
+ !! This is to prevent users from calling set_base_time multiple times
+ INTEGER, private :: base_year, base_month, base_day, base_hour, base_minute, base_second
CHARACTER(len = 256):: global_descriptor
!
@@ -405,10 +408,112 @@ SUBROUTINE diag_data_init()
! Write version number out to log file
call write_version_number("DIAG_DATA_MOD", version)
+ module_is_initialized = .true.
+ base_time_set = .false.
+
END SUBROUTINE diag_data_init
+ !> @brief Set the module variable base_time
+ subroutine set_base_time(base_time_int)
+ integer :: base_time_int(6) !< base_time as an array [year month day hour min sec]
+
+ CHARACTER(len=9) :: amonth !< Month name
+ INTEGER :: stdlog_unit !< Fortran file unit number for the stdlog file.
+
+ if (.not. module_is_initialized) call mpp_error(FATAL, "set_base_time: diag_data is not initialized")
+ if (base_time_set) call mpp_error(FATAL, "set_base_time: the base_time is already set!")
+
+ base_year = base_time_int(1)
+ base_month = base_time_int(2)
+ base_day = base_time_int(3)
+ base_hour = base_time_int(4)
+ base_minute = base_time_int(5)
+ base_second = base_time_int(6)
+
+ ! Set up the time type for base time
+ IF ( get_calendar_type() /= NO_CALENDAR ) THEN
+ IF ( base_year==0 .OR. base_month==0 .OR. base_day==0 ) THEN
+ call mpp_error(FATAL, 'diag_data_mod::set_base_time'//&
+ & 'The base_year/month/day can not equal zero')
+ END IF
+ base_time = set_date(base_year, base_month, base_day, base_hour, base_minute, base_second)
+ amonth = month_name(base_month)
+ ELSE
+ ! No calendar - ignore year and month
+ base_time = set_time(NINT(base_hour*SECONDS_PER_HOUR)+NINT(base_minute*SECONDS_PER_MINUTE)+base_second, &
+ & base_day)
+ base_year = 0
+ base_month = 0
+ amonth = 'day'
+ END IF
+ ! get the stdlog unit number
+ stdlog_unit = stdlog()
+
+ IF ( mpp_pe() == mpp_root_pe() ) THEN
+ WRITE (stdlog_unit,'("base date used = ",I4,1X,A,2I3,2(":",I2.2)," gmt")') base_year, TRIM(amonth), base_day, &
+ & base_hour, base_minute, base_second
+ END IF
+ base_time_set = .true.
+
+ end subroutine set_base_time
+
+ !> @brief gets the module variable base_time
+ !> @return the base_time
+ function get_base_time() &
+ result(res)
+ TYPE(time_type) :: res
+ res = base_time
+ end function get_base_time
+
+ !> @brief gets the module variable base_year
+ !> @return the base_year
+ function get_base_year() &
+ result(res)
+ integer :: res
+ res = base_year
+ end function get_base_year
+
+ !> @brief gets the module variable base_month
+ !> @return the base_month
+ function get_base_month() &
+ result(res)
+ integer :: res
+ res = base_month
+ end function get_base_month
+
+ !> @brief gets the module variable base_day
+ !> @return the base_day
+ function get_base_day() &
+ result(res)
+ integer :: res
+ res = base_day
+ end function get_base_day
+
+ !> @brief gets the module variable base_hour
+ !> @return the base_hour
+ function get_base_hour() &
+ result(res)
+ integer :: res
+ res = base_hour
+ end function get_base_hour
+
+ !> @brief gets the module variable base_minute
+ !> @return the base_minute
+ function get_base_minute() &
+ result(res)
+ integer :: res
+ res = base_minute
+ end function get_base_minute
+
+ !> @brief gets the module variable base_second
+ !> @return the base_second
+ function get_base_second() &
+ result(res)
+ integer :: res
+ res = base_second
+ end function get_base_second
END MODULE diag_data_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 11dc42bd17..5cb7189a55 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -223,8 +223,8 @@ MODULE diag_manager_mod
USE diag_data_mod, ONLY: max_files, CMOR_MISSING_VALUE, DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, EVERY_TIME,&
& END_OF_RUN, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, num_files,&
& max_input_fields, max_output_fields, num_output_fields, EMPTY, FILL_VALUE, null_axis_id,&
- & MAX_VALUE, MIN_VALUE, base_time, base_year, base_month, base_day,&
- & base_hour, base_minute, base_second, global_descriptor, coord_type, files, input_fields,&
+ & MAX_VALUE, MIN_VALUE, get_base_time, get_base_year, get_base_month, get_base_day,&
+ & get_base_hour, get_base_minute, get_base_second, global_descriptor, coord_type, files, input_fields,&
& output_fields, Time_zero, append_pelist_name, mix_snapshot_average_fields,&
& first_send_data_call, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
& diag_log_unit, time_unit_list, pelist_name, max_axes, module_is_initialized, max_num_axis_sets,&
@@ -3941,7 +3941,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
diag_init_time = set_date(time_init(1), time_init(2), time_init(3), time_init(4),&
& time_init(5), time_init(6))
ELSE
- diag_init_time = base_time
+ diag_init_time = get_base_time()
IF ( prepend_date .EQV. .TRUE. ) THEN
CALL error_mesg('diag_manager_mod::diag_manager_init',&
& 'prepend_date only supported when diag_manager_init is called with time_init present.', NOTE)
@@ -3952,13 +3952,13 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
#ifdef use_yaml
if (use_modern_diag) CALL diag_yaml_object_init(diag_subset_output)
#endif
-
- CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local)
- IF ( mystat /= 0 ) THEN
+ if (.not. use_modern_diag) then
+ CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local)
+ IF ( mystat /= 0 ) THEN
IF ( fms_error_handler('diag_manager_mod::diag_manager_init',&
& 'Error parsing diag_table. '//TRIM(err_msg_local), err_msg) ) RETURN
- END IF
-
+ END IF
+ endif
!initialize files%bytes_written to zero
files(:)%bytes_written = 0
@@ -3983,18 +3983,6 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
RETURN
END SUBROUTINE diag_manager_init
- !> @brief Return base time for diagnostics.
- !! @return time_type get_base_time
- !! @details Return base time for diagnostics (note: base time must be >= model time).
- TYPE(time_type) FUNCTION get_base_time ()
- !
- ! MODULE has not been initialized
- !
- IF ( .NOT.module_is_initialized ) CALL error_mesg('diag_manager_mod::get_base_time', &
- & 'module has not been initialized', FATAL)
- get_base_time = base_time
- END FUNCTION get_base_time
-
!> @brief Return base date for diagnostics.
!! @details Return date information for diagnostic reference time.
SUBROUTINE get_base_date(year, month, day, hour, minute, second)
@@ -4003,12 +3991,12 @@ SUBROUTINE get_base_date(year, month, day, hour, minute, second)
! module has not been initialized
IF (.NOT.module_is_initialized) CALL error_mesg ('diag_manager_mod::get_base_date', &
& 'module has not been initialized', FATAL)
- year = base_year
- month = base_month
- day = base_day
- hour = base_hour
- minute = base_minute
- second = base_second
+ year = get_base_year()
+ month = get_base_month()
+ day = get_base_day()
+ hour = get_base_hour()
+ minute = get_base_minute()
+ second = get_base_second()
END SUBROUTINE get_base_date
!> @brief Determine whether data is needed for the current model time step.
diff --git a/diag_manager/diag_table.F90 b/diag_manager/diag_table.F90
index 7a23493657..5578bdaa38 100644
--- a/diag_manager/diag_table.F90
+++ b/diag_manager/diag_table.F90
@@ -250,12 +250,10 @@
MODULE diag_table_mod
USE fms2_io_mod, ONLY: ascii_read
- USE fms_mod, ONLY: fms_error_handler, error_mesg, stdlog, mpp_pe, mpp_root_pe, FATAL, WARNING, lowercase
- USE time_manager_mod, ONLY: get_calendar_type, NO_CALENDAR, set_date, set_time, month_name, time_type
- USE constants_mod, ONLY: SECONDS_PER_HOUR, SECONDS_PER_MINUTE
-
- USE diag_data_mod, ONLY: global_descriptor, base_time, base_year, base_month, base_day, base_hour, base_minute, &
- & base_second, DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, coord_type, append_pelist_name, pelist_name
+ USE fms_mod, ONLY: fms_error_handler, error_mesg, mpp_pe, mpp_root_pe, FATAL, WARNING, lowercase
+ USE time_manager_mod, ONLY: set_date, time_type
+ USE diag_data_mod, ONLY: global_descriptor, get_base_time, set_base_time, &
+ & DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, coord_type, append_pelist_name, pelist_name
USE diag_util_mod, ONLY: init_file, check_duplicate_output_fields, init_input_field, init_output_field
IMPLICIT NONE
@@ -325,7 +323,6 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg)
INTEGER, PARAMETER :: DT_LINE_LENGTH = 256
- INTEGER :: stdlog_unit !< Fortran file unit number for the stdlog file.
INTEGER :: record_len !< String length of the diag_table line read in.
INTEGER :: num_lines !< Number of lines in diag_table
INTEGER :: line_num !< Integer representation of the line number.
@@ -337,10 +334,10 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg)
INTEGER, POINTER :: pstat !< pointer that points to istat if preset, otherwise, points to mystat.
CHARACTER(len=5) :: line_number !< String representation of the line number.
- CHARACTER(len=9) :: amonth !< Month name
CHARACTER(len=256) :: record_line !< Current line from the diag_table.
CHARACTER(len=256) :: local_err_msg !< Sting to hold local error messages.
CHARACTER(len=:), DIMENSION(:), ALLOCATABLE :: diag_table
+ integer :: base_time_int(6) !< The base time as read in from the table [year month day hour min sec]
TYPE(file_description_type) :: temp_file
TYPE(field_description_type) :: temp_field
@@ -360,9 +357,6 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg)
diag_subset_output = DIAG_ALL
END IF
- ! get the stdlog unit number
- stdlog_unit = stdlog()
-
call ascii_read('diag_table', diag_table, num_lines=num_lines)
! Read in the global file labeling string
@@ -374,36 +368,14 @@ SUBROUTINE parse_diag_table(diag_subset, istat, err_msg)
END IF
! Read in the base date
- READ (UNIT=diag_table(2), FMT=*, IOSTAT=mystat) base_year, base_month, base_day, base_hour, base_minute, &
- & base_second
+ READ (UNIT=diag_table(2), FMT=*, IOSTAT=mystat) base_time_int
IF ( mystat /= 0 ) THEN
pstat = mystat
IF ( fms_error_handler('diag_manager_init', 'Error reading the base date from the diagnostic table.', &
& err_msg) ) RETURN
END IF
- ! Set up the time type for base time
- IF ( get_calendar_type() /= NO_CALENDAR ) THEN
- IF ( base_year==0 .OR. base_month==0 .OR. base_day==0 ) THEN
- pstat = 101
- IF ( fms_error_handler('diag_table_mod::parse_diag_table', &
- & 'The base_year/month/day can not equal zero', err_msg) ) RETURN
- END IF
- base_time = set_date(base_year, base_month, base_day, base_hour, base_minute, base_second)
- amonth = month_name(base_month)
- ELSE
- ! No calendar - ignore year and month
- base_time = set_time(NINT(base_hour*SECONDS_PER_HOUR)+NINT(base_minute*SECONDS_PER_MINUTE)+base_second, &
- & base_day)
- base_year = 0
- base_month = 0
- amonth = 'day'
- END IF
-
- IF ( mpp_pe() == mpp_root_pe() ) THEN
- WRITE (stdlog_unit,'("base date used = ",I4,1X,A,2I3,2(":",I2.2)," gmt")') base_year, TRIM(amonth), base_day, &
- & base_hour, base_minute, base_second
- END IF
+ call set_base_time(base_time_int)
nfiles=0
nfields=0
@@ -656,7 +628,7 @@ TYPE(file_description_type) FUNCTION parse_file_line(line, istat, err_msg)
parse_file_line%iFile_duration_units = parse_file_line%iNew_file_freq_units
END IF
ELSE
- parse_file_line%start_time = base_time
+ parse_file_line%start_time = get_base_time()
parse_file_line%file_duration = parse_file_line%new_file_freq
parse_file_line%iFile_duration_units = parse_file_line%iNew_file_freq_units
END IF
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index 5591c293a3..b4f6eecb8d 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -42,9 +42,9 @@ MODULE diag_util_mod
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,&
+ & DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, get_base_time,&
+ & time_unit_list, max_files, get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute,&
+ & get_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,&
@@ -1194,7 +1194,7 @@ SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_n
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)%last_flush = get_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
@@ -1208,7 +1208,7 @@ SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_n
IF ( PRESENT(start_time) ) THEN
files(num_files)%start_time = start_time
ELSE
- files(num_files)%start_time = base_time
+ files(num_files)%start_time = get_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)
@@ -1222,8 +1222,8 @@ SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_n
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
+ WRITE(time_units_str, 11) TRIM(time_unit_list(files(num_files)%time_units)), get_base_year(),&
+ & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_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) )
@@ -1738,8 +1738,8 @@ SUBROUTINE opening_file(file, time, filename_time)
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
+ WRITE (time_units, 11) TRIM(time_unit_list(files(file)%time_units)), get_base_year(),&
+ & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_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
@@ -2332,7 +2332,7 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in,
static_write = .FALSE.
IF ( PRESENT(static_write_in) ) static_write = static_write_in
!> dif is the time as a real that is evaluated
- dif = get_date_dif(time, base_time, files(file)%time_units)
+ dif = get_date_dif(time, get_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 ) &
@@ -2367,9 +2367,9 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in,
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)
+ start_dif = get_date_dif(output_fields(field)%last_output, get_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)
+ end_dif = get_date_dif(output_fields(field)%next_output, get_base_time(), files(file)%time_units)
ELSE
end_dif = dif
END IF
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index e17fc4d19b..83f8cfd171 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -30,7 +30,7 @@
!> @{
module fms_diag_yaml_mod
#ifdef use_yaml
-use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER
+use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER, set_base_time
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL
@@ -274,6 +274,7 @@ subroutine diag_yaml_object_init(diag_subset_output)
call diag_get_value_from_key(diag_yaml_id, 0, "title", diag_yaml%diag_title)
call get_value_from_key(diag_yaml_id, 0, "base_date", diag_yaml%diag_basedate)
+ call set_base_time(diag_yaml%diag_basedate)
nfiles = get_num_blocks(diag_yaml_id, "diag_files")
allocate(diag_file_ids(nfiles))
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index f38719e737..87b8904603 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -24,7 +24,9 @@ program test_diag_yaml
#ifdef use_yaml
use FMS_mod, only: fms_init, fms_end
use fms_diag_yaml_mod
-use diag_data_mod, only: DIAG_NULL, DIAG_ALL
+use diag_data_mod, only: DIAG_NULL, DIAG_ALL, get_base_year, get_base_month, get_base_day, get_base_hour, &
+ & get_base_minute, get_base_second, diag_data_init
+use time_manager_mod, only: set_calendar_type, JULIAN
use mpp_mod
use platform_mod
@@ -65,12 +67,17 @@ end subroutine compare_result_1d
if (checking_crashes) call mpp_error(FATAL, "It is crashing!")
call fms_end()
#else
+
+call set_calendar_type(JULIAN)
+call diag_data_init()
call diag_yaml_object_init(DIAG_ALL)
my_yaml = get_diag_yaml_obj()
if (.not. checking_crashes) then
call compare_result("base_date", my_yaml%get_basedate(), (/2, 1, 1, 0, 0 , 0 /))
+ call check_base_time()
+
call compare_result("title", my_yaml%get_title(), "test_diag_manager")
diag_files = my_yaml%get_diag_files()
@@ -218,6 +225,20 @@ subroutine compare_diag_files(res)
end subroutine compare_diag_files
+!> @brief Check if the base_time saved in diag_data is correct
+subroutine check_base_time()
+ integer :: base_time_mod_var(6) !< The base_time obtained from diag_data
+
+ base_time_mod_var(1) = get_base_year()
+ base_time_mod_var(2) = get_base_month()
+ base_time_mod_var(3) = get_base_day()
+ base_time_mod_var(4) = get_base_hour()
+ base_time_mod_var(5) = get_base_minute()
+ base_time_mod_var(6) = get_base_second()
+
+ call compare_result("base_time", base_time_mod_var, (/2, 1, 1, 0, 0 ,0 /))
+end subroutine check_base_time
+
#endif
end program test_diag_yaml
From 13cc7584ab37684f63494ab8330e76ed966322b7 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 21 Mar 2022 14:07:02 -0400
Subject: [PATCH 037/168] feat: add fms_find_unique to string_utils (#938)
From 10acbe77d8d6ead40de9e2147cc750b57fac62cd Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Wed, 23 Mar 2022 14:52:18 -0400
Subject: [PATCH 038/168] chore: Remove use_mpp_io from diag manager (#940)
---
diag_manager/diag_data.F90 | 3 ---
diag_manager/diag_manager.F90 | 28 ++++++++-------------
diag_manager/diag_util.F90 | 2 +-
test_fms/diag_manager/test_diag_manager2.sh | 1 -
4 files changed, 11 insertions(+), 23 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 103bf9749d..c8c7a589ef 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -353,9 +353,6 @@ MODULE diag_data_mod
!! .TRUE. is only supported if the diag_manager_init
!! routine is called with the optional time_init parameter.
LOGICAL :: use_modern_diag = .false. !< Namelist flag to use the modernized diag_manager code
- LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io
- LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons.
-
!
REAL :: FILL_VALUE = NF_FILL_REAL !< Fill value used. Value will be NF90_FILL_REAL if using the
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 5cb7189a55..a13e408db3 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -230,8 +230,8 @@ MODULE diag_manager_mod
& diag_log_unit, time_unit_list, pelist_name, max_axes, module_is_initialized, max_num_axis_sets,&
& use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,&
& max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,&
- & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time, diag_data_init, &
- & use_mpp_io, use_modern_diag
+ & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time,diag_data_init,&
+ & use_modern_diag
USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
@@ -3828,8 +3828,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
& max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
& max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
& oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
- & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io, field_log_separator,&
- & use_modern_diag
+ & max_file_attributes, max_axis_attributes, prepend_date, field_log_separator, use_modern_diag
! If the module was already initialized do nothing
IF ( module_is_initialized ) RETURN
@@ -3918,21 +3917,14 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
DO j = 1, max_input_fields
ALLOCATE(input_fields(j)%output_fields(MAX_OUT_PER_IN_FIELD))
END DO
+!> Allocate files
ALLOCATE(files(max_files))
- if (.not.use_mpp_io) then
- ALLOCATE(fileobjU(max_files))
- ALLOCATE(fileobj(max_files))
- ALLOCATE(fileobjND(max_files))
- ALLOCATE(fnum_for_domain(max_files))
- !> Initialize fnum_for_domain with "dn" which stands for done
- fnum_for_domain(:) = "dn"
- CALL error_mesg('diag_manager_mod::diag_manager_init',&
- & 'diag_manager is using fms2_io', NOTE)
- else
- CALL error_mesg('diag_manager_mod::diag_manager_init',&
- &'MPP_IO is no longer supported. Please remove use_mpp_io from diag_manager_nml namelist',&
- &FATAL)
- endif
+ ALLOCATE(fileobjU(max_files))
+ ALLOCATE(fileobj(max_files))
+ ALLOCATE(fileobjND(max_files))
+ ALLOCATE(fnum_for_domain(max_files))
+ !> Initialize fnum_for_domain with "dn" which stands for done
+ fnum_for_domain(:) = "dn"
ALLOCATE(pelist(mpp_npes()))
CALL mpp_get_current_pelist(pelist, pelist_name)
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index b4f6eecb8d..3a36b07207 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -57,7 +57,7 @@ MODULE diag_util_mod
& get_axis_reqfld, axis_is_compressed, get_compressed_axes_ids
USE diag_output_mod, ONLY: diag_output_init, write_axis_meta_data,&
& write_field_meta_data, done_meta_data, diag_flush
- USE diag_output_mod, ONLY: diag_field_write, diag_write_time !
Date: Thu, 24 Mar 2022 10:50:59 -0400
Subject: [PATCH 039/168] feat: Modern diag register_diag_field set up (#939)
* Add the 'modern' register routines in diag_manager
---
diag_manager/diag_manager.F90 | 193 +++++++++++++++++++++++++---------
1 file changed, 144 insertions(+), 49 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index a13e408db3..b7c3788409 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -231,7 +231,8 @@ MODULE diag_manager_mod
& use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,&
& max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,&
& max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time,diag_data_init,&
- & use_modern_diag
+ & use_modern_diag, diag_null
+
USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
@@ -380,7 +381,6 @@ MODULE diag_manager_mod
!> @addtogroup diag_manager_mod
!> @{
CONTAINS
-
!> @brief Registers a scalar field
!! @return field index for subsequent call to send_data.
INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, &
@@ -392,37 +392,154 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
- CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
- CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute
+ REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ REAL, OPTIONAL, INTENT(in) :: range(2) !< Range to add a variable attribute
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
- ! Fatal error if range is present and its extent is not 2.
- IF ( PRESENT(range) ) THEN
- IF ( SIZE(range) .NE. 2 ) THEN
- ! extent of range should be 2
- CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', FATAL)
- END IF
- END IF
+ if (use_modern_diag) then
+ register_diag_field_scalar = register_diag_field_scalar_modern(module_name, field_name, init_time, &
+ & long_name=long_name, units=units, missing_value=missing_value, var_range=range, standard_name=standard_name, &
+ & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
+ else
+ register_diag_field_scalar = register_diag_field_scalar_old(module_name, field_name, init_time, &
+ & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, &
+ & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
+ endif
+ end function register_diag_field_scalar
+
+ !> @brief Registers an array field
+ !> @return field index for subsequent call to send_data.
+ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_time, &
+ & long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
+ & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
+ CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
+ CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
+ INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis
+ TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
+ REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ REAL, OPTIONAL, INTENT(in) :: range(2) !< Range to add a variable attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
+ LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
+ !! regridding the field in post-processing.
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number
+ INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+
+ if (use_modern_diag) then
+ register_diag_field_array = register_diag_field_array_modern(module_name, field_name, axes, init_time, &
+ & long_name=long_name, units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
+ & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
+ & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
+ else
+ register_diag_field_array = register_diag_field_array_old(module_name, field_name, axes, init_time, &
+ & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
+ & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
+ & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
+ endif
+end function register_diag_field_array
+
+ !> @brief Registers a scalar field
+ !! @return field index for subsequent call to send_data.
+ INTEGER FUNCTION register_diag_field_scalar_modern(module_name, field_name, init_time, &
+ & long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,&
+ & area, volume, realm)
+ CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
+ CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
+ TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
+ REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ REAL, OPTIONAL, INTENT(in) :: var_range(2) !< Range to add a variable attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
+ INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+
+ ! TODO: Check if the diag_field is in the yaml, if it is not return diag_null. If it is fill in the diag_obj
+ register_diag_field_scalar_modern = diag_null
+
+ end function register_diag_field_scalar_modern
+
+ !> @brief Registers an array field
+ !> @return field index for subsequent call to send_data.
+ INTEGER FUNCTION register_diag_field_array_modern(module_name, field_name, axes, init_time, &
+ & long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,&
+ & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
+ CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
+ CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
+ INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis
+ TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
+ REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ REAL, OPTIONAL, INTENT(in) :: var_range(2) !< Range to add a variable attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
+ LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
+ !! regridding the field in post-processing.
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number
+ INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+
+ ! TODO: Check if the diag_field is in the yaml, if it is not return diag_null. If it is fill in the diag_obj
+ register_diag_field_array_modern = diag_null
+ end function register_diag_field_array_modern
+
+ !> @brief Registers a scalar field
+ !! @return field index for subsequent call to send_data.
+ INTEGER FUNCTION register_diag_field_scalar_old(module_name, field_name, init_time, &
+ & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
+ & area, volume, realm)
+ CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
+ CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
+ TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
+ REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ REAL, OPTIONAL, INTENT(in) :: range(2) !< Range to add a variable attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
+ INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+
+ IF ( PRESENT(err_msg) ) err_msg = ''
IF ( PRESENT(init_time) ) THEN
- register_diag_field_scalar = register_diag_field_array(module_name, field_name,&
+ register_diag_field_scalar_old = register_diag_field_array(module_name, field_name,&
& (/null_axis_id/), init_time,long_name, units, missing_value, range, &
& standard_name=standard_name, do_not_log=do_not_log, err_msg=err_msg,&
& area=area, volume=volume, realm=realm)
ELSE
- register_diag_field_scalar = register_static_field(module_name, field_name,&
+ register_diag_field_scalar_old = register_static_field(module_name, field_name,&
& (/null_axis_id/),long_name, units, missing_value, range,&
& standard_name=standard_name, do_not_log=do_not_log, realm=realm)
END IF
- END FUNCTION register_diag_field_scalar
+ END FUNCTION register_diag_field_scalar_old
- !> @brief Registers an array field
- !> @return field index for subsequent call to send_data.
- INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_time, &
+INTEGER FUNCTION register_diag_field_array_old(module_name, field_name, axes, init_time, &
& long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
& do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
@@ -431,8 +548,8 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
- CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
- CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute
+ REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ REAL, OPTIONAL, INTENT(in) :: range(2) !< Range to add a variable attribute
LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information
@@ -452,10 +569,6 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
INTEGER :: stdout_unit
LOGICAL :: mask_variant1, verbose1
CHARACTER(len=128) :: msg
- TYPE(time_type) :: diag_file_init_time !< The intial time of the diag_file
- INTEGER :: status_ic !< used to check the status of insert into container.
- CLASS(fmsDiagObject_type), ALLOCATABLE , TARGET :: diag_obj !< the diag object that is (to be) registered
- TYPE(fmsDiagObject_type), POINTER :: diag_obj_ptr => NULL() !< a pointer to the registered diag_object
! get stdout unit number
stdout_unit = stdout()
@@ -483,7 +596,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
END IF
! Call register static, then set static back to false
- register_diag_field_array = register_static_field(module_name, field_name, axes,&
+ register_diag_field_array_old = register_static_field(module_name, field_name, axes,&
& long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,&
& DYNAMIC=.TRUE., do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, realm=realm)
@@ -498,7 +611,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
&' registered AFTER first send_data call, TOO LATE', WARNING)
END IF
- IF ( register_diag_field_array < 0 ) THEN
+ IF ( register_diag_field_array_old < 0 ) THEN
!
! module/output_field / NOT found in diag_table
!
@@ -509,8 +622,8 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
& WARNING)
END IF
ELSE
- input_fields(register_diag_field_array)%static = .FALSE.
- field = register_diag_field_array
+ input_fields(register_diag_field_array_old)%static = .FALSE.
+ field = register_diag_field_array_old
! Verify that area and volume do not point to the same variable
@@ -520,7 +633,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
err_msg = 'diag_manager_mod::register_diag_field: module/output_field '&
&//TRIM(module_name)//'/'// TRIM(field_name)//' AREA and VOLUME CANNOT be the same variable.&
& Contact the developers.'
- register_diag_field_array = -1
+ register_diag_field_array_old = -1
RETURN
ELSE
CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '&
@@ -538,7 +651,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
err_msg = 'diag_manager_mod::register_diag_field: module/output_field '&
&//TRIM(module_name)//'/'// TRIM(field_name)//' AREA measures field NOT found in diag_table.&
& Contact the model liaison.'
- register_diag_field_array = -1
+ register_diag_field_array_old = -1
RETURN
ELSE
CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '&
@@ -554,7 +667,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
err_msg = 'diag_manager_mod::register_diag_field: module/output_field '&
&//TRIM(module_name)//'/'// TRIM(field_name)//' VOLUME measures field NOT found in diag_table.&
& Contact the model liaison.'
- register_diag_field_array = -1
+ register_diag_field_array_old = -1
RETURN
ELSE
CALL error_mesg ('diag_manager_mod::register_diag_field', 'module/output_field '&
@@ -623,25 +736,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
END DO
END IF
- if (use_modern_diag) then
- !! Create a diag object, initialize it with the registered data, and insert
- !! it ino the diag_obj_container singleton.
-
- allocate( diag_obj )
- call diag_obj%register (module_name, field_name, axes, init_time, &
- long_name, units, missing_value, Range, mask_variant, standard_name, &
- do_not_log, err_msg, interp_method, tile_count, area, volume, realm) !(no metadata here)
-
- diag_obj_ptr => diag_obj
- status_ic = the_diag_object_container%insert(diag_obj_ptr%get_id(), diag_obj_ptr)
- if(status_ic .ne. 0) then
- print *, "Insertion ERROR for id ", diag_obj_ptr%get_id()
- endif
- endif
-
- END FUNCTION register_diag_field_array
-
-
+ END FUNCTION register_diag_field_array_old
!> @brief Return field index for subsequent call to send_data.
!! @return field index for subsequent call to send_data.
INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, units,&
From ca08c7776ff6b888650204fc3dacfa728d4b57d6 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 29 Mar 2022 15:01:45 -0400
Subject: [PATCH 040/168] feat: modern diag init updates to get number of
unique fields and error out without flag (#944)
---
diag_manager/diag_manager.F90 | 26 +++++++----
diag_manager/fms_diag_yaml.F90 | 55 ++++++++++++++++++++++++
test_fms/diag_manager/test_diag_yaml.F90 | 2 +
3 files changed, 74 insertions(+), 9 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index b7c3788409..9abd7a60ee 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -238,10 +238,9 @@ MODULE diag_manager_mod
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
USE fms_diag_object_mod, ONLY: fmsDiagObject_type
- use fms_diag_object_container_mod, ONLY: FmsDiagObjectContainer_t
#ifdef use_yaml
- use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end
+ use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields
#endif
USE constants_mod, ONLY: SECONDS_PER_DAY
@@ -280,7 +279,8 @@ MODULE diag_manager_mod
type(time_type) :: Time_end
- TYPE(FmsDiagObjectContainer_t), ALLOCATABLE :: the_diag_object_container
+ TYPE(fmsDiagObject_type), ALLOCATABLE :: diag_objs(:) !< Array of diag objects, one for each registered variable
+ integer :: registered_variables !< Number of registered variables
!> @brief Send data over to output fields.
!!
@@ -3824,7 +3824,10 @@ SUBROUTINE diag_manager_end(time)
if (allocated(fnum_for_domain)) deallocate(fnum_for_domain)
#ifdef use_yaml
- if (use_modern_diag) call diag_yaml_object_end
+ if (use_modern_diag) then
+ call diag_yaml_object_end
+ if (allocated(diag_objs)) deallocate(diag_objs)
+ endif
#endif
END SUBROUTINE diag_manager_end
@@ -4037,8 +4040,17 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
END IF
#ifdef use_yaml
- if (use_modern_diag) CALL diag_yaml_object_init(diag_subset_output)
+ if (use_modern_diag) then
+ CALL diag_yaml_object_init(diag_subset_output)
+ allocate(diag_objs(get_num_unique_fields()))
+ registered_variables = 0
+ endif
+#else
+ if (use_modern_diag) &
+ call error_mesg("diag_manager_mod::diag_manager_init", &
+ & "You need to compile with -Duse_yaml if diag_manager_nml::use_modern_diag=.true.", FATAL)
#endif
+
if (.not. use_modern_diag) then
CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local)
IF ( mystat /= 0 ) THEN
@@ -4060,10 +4072,6 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
& 'Max Value', FIELD_LOG_SEPARATOR, 'AXES LIST'
END IF
- !!Create the diag_object container; Its a singleton in the diag_data mod
- allocate(the_diag_object_container)
- call the_diag_object_container%initialize()
-
module_is_initialized = .TRUE.
! create axis_id for scalars here
null_axis_id = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none')
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 83f8cfd171..6e3362f91c 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -34,6 +34,8 @@ module fms_diag_yaml_mod
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL
+use, intrinsic :: iso_c_binding, only : c_ptr, c_null_char
+use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique
implicit none
@@ -42,12 +44,28 @@ module fms_diag_yaml_mod
public :: diag_yaml_object_init, diag_yaml_object_end
public :: diagYamlObject_type, get_diag_yaml_obj, get_title, get_basedate, get_diag_files, get_diag_fields
public :: diagYamlFiles_type, diagYamlFilesVar_type
+public :: get_num_unique_fields
+
!> @}
integer, parameter :: basedate_size = 6
integer, parameter :: NUM_SUB_REGION_ARRAY = 8
integer, parameter :: MAX_STR_LEN = 255
+!> @brief type to hold an array of sorted diag_fiels
+type varList_type
+ character(len=255), allocatable :: var_name(:) !< Array of diag_field
+ type(c_ptr), allocatable :: var_pointer(:) !< Array of pointers
+ integer, allocatable :: diag_field_indices(:) !< Index of the field in the diag_field array
+end type
+
+!> @brief type to hold an array of sorted diag_files
+type fileList_type
+ character(len=255), allocatable :: file_name(:) !< Array of diag_field
+ type(c_ptr), allocatable :: file_pointer(:) !< Array of pointers
+ integer, allocatable :: diag_file_indices(:) !< Index of the file in the diag_file array
+end type
+
!> @brief type to hold the sub region information about a file
type subRegion_type
character (len=:), allocatable :: grid_type !< Flag indicating the type of region,
@@ -192,6 +210,8 @@ module fms_diag_yaml_mod
end type diagYamlObject_type
type (diagYamlObject_type) :: diag_yaml !< Obj containing the contents of the diag_table.yaml
+type (varList_type), save :: variable_list !< List of all the variables in the diag_table.yaml
+type (fileList_type), save :: file_list !< List of all files in the diag_table.yaml
!> @addtogroup fms_diag_yaml_mod
!> @{
@@ -313,6 +333,10 @@ subroutine diag_yaml_object_init(diag_subset_output)
allocate(diag_yaml%diag_files(actual_num_files))
allocate(diag_yaml%diag_fields(total_nvars))
+ allocate(variable_list%var_name(total_nvars))
+ allocate(variable_list%diag_field_indices(total_nvars))
+ allocate(file_list%file_name(actual_num_files))
+ allocate(file_list%diag_file_indices(actual_num_files))
var_count = 0
file_count = 0
@@ -323,6 +347,10 @@ subroutine diag_yaml_object_init(diag_subset_output)
call diag_yaml_files_obj_init(diag_yaml%diag_files(file_count))
call fill_in_diag_files(diag_yaml_id, diag_file_ids(i), diag_yaml%diag_files(file_count))
+ !> Save the file name in the file_list
+ file_list%file_name(file_count) = trim(diag_yaml%diag_files(file_count)%file_fname)//c_null_char
+ file_list%diag_file_indices(file_count) = file_count
+
nvars = 0
nvars = get_num_blocks(diag_yaml_id, "varlist", parent_block_id=diag_file_ids(i))
allocate(var_ids(nvars))
@@ -344,10 +372,21 @@ subroutine diag_yaml_object_init(diag_subset_output)
!> Save the variable name in the diag_file type
diag_yaml%diag_files(file_count)%file_varlist(file_var_count) = diag_yaml%diag_fields(var_count)%var_varname
+
+ !> Save the variable name in the variable_list
+ variable_list%var_name(var_count) = trim(diag_yaml%diag_fields(var_count)%var_varname)//c_null_char
+ variable_list%diag_field_indices(var_count) = var_count
enddo nvars_loop
deallocate(var_ids)
enddo nfiles_loop
+ !> Sort the file list in alphabetical order
+ file_list%file_pointer = fms_array_to_pointer(file_list%file_name)
+ call fms_sort_this(file_list%file_pointer, actual_num_files, file_list%diag_file_indices)
+
+ variable_list%var_pointer = fms_array_to_pointer(variable_list%var_name)
+ call fms_sort_this(variable_list%var_pointer, total_nvars, variable_list%diag_field_indices)
+
deallocate(diag_file_ids)
end subroutine
@@ -370,6 +409,14 @@ subroutine diag_yaml_object_end()
enddo
if(allocated(diag_yaml%diag_fields)) deallocate(diag_yaml%diag_fields)
+ if(allocated(file_list%file_pointer)) deallocate(file_list%file_pointer)
+ if(allocated(file_list%file_name)) deallocate(file_list%file_name)
+ if(allocated(file_list%diag_file_indices)) deallocate(file_list%diag_file_indices)
+
+ if(allocated(variable_list%var_pointer)) deallocate(variable_list%var_pointer)
+ if(allocated(variable_list%var_name)) deallocate(variable_list%var_name)
+ if(allocated(variable_list%diag_field_indices)) deallocate(variable_list%diag_field_indices)
+
end subroutine diag_yaml_object_end
!> @brief Fills in a diagYamlFiles_type with the contents of a file block in diag_table.yaml
@@ -1106,6 +1153,14 @@ pure logical function has_diag_fields (obj)
has_diag_fields = allocated(obj%diag_fields)
end function has_diag_fields
+!> @brief Determine the number of unique diag_fields in the diag_yaml_object
+!! @return The number of unique diag_fields
+function get_num_unique_fields() &
+ result(nfields)
+ integer :: nfields
+ nfields = fms_find_unique(variable_list%var_pointer, size(variable_list%var_pointer))
+
+end function get_num_unique_fields
#endif
end module fms_diag_yaml_mod
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index 87b8904603..de4a71d88c 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -88,6 +88,8 @@ end subroutine compare_result_1d
call compare_result("nfields", size(diag_fields), 3) !< the fourth variable has var_write = false so it doesn't count
call compare_diag_fields(diag_fields)
+ !< Check that get_num_unique_fields is getting the correct number of unique fields
+ call compare_result("number of unique fields", get_num_unique_fields(), 2)
endif
deallocate(diag_files)
deallocate(diag_fields)
From 4dc1dd8747baf4cbf058cea3c5940a9269162d71 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 30 Mar 2022 12:59:15 -0400
Subject: [PATCH 041/168] Yaml updates (#942)
* remove the realm key
* Changed output_name to an optional field
---
diag_manager/fms_diag_yaml.F90 | 36 +-----------------------
test_fms/diag_manager/test_diag_yaml.F90 | 4 ---
2 files changed, 1 insertion(+), 39 deletions(-)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 6e3362f91c..340b004914 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -89,7 +89,6 @@ module fms_diag_yaml_mod
integer, private :: file_freq !< the frequency of data
character (len=:), private, allocatable :: file_timeunit !< The unit of time
character (len=:), private, allocatable :: file_unlimdim !< The name of the unlimited dimension
- character (len=:), private, allocatable :: file_realm !< The modeling realm that the variables come from
type(subRegion_type), private :: file_sub_region !< type containing info about the subregion, if any
integer, private :: file_new_file_freq !< Frequency for closing the existing file
character (len=:), private, allocatable :: file_new_file_freq_units !< Time units for creating a new file.
@@ -120,7 +119,6 @@ module fms_diag_yaml_mod
procedure :: get_file_freq
procedure :: get_file_timeunit
procedure :: get_file_unlimdim
- procedure :: get_file_realm
procedure :: get_file_sub_region
procedure :: get_file_new_file_freq
procedure :: get_file_new_file_freq_units
@@ -137,7 +135,6 @@ module fms_diag_yaml_mod
procedure :: has_file_freq
procedure :: has_file_timeunit
procedure :: has_file_unlimdim
- procedure :: has_file_realm
procedure :: has_file_sub_region
procedure :: has_file_new_file_freq
procedure :: has_file_new_file_freq_units
@@ -443,9 +440,6 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", fileobj%file_timeunit)
call check_file_time_units(fileobj)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "realm", fileobj%file_realm, is_optional=.true.)
- call check_file_realm(fileobj)
-
call get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", fileobj%file_new_file_freq, is_optional=.true.)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq_units", fileobj%file_new_file_freq_units, &
is_optional=.true.)
@@ -524,7 +518,7 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field)
call diag_get_value_from_key(diag_file_id, var_id, "kind", field%var_skind)
call check_field_kind(field)
- call diag_get_value_from_key(diag_file_id, var_id, "output_name", field%var_outname)
+ call diag_get_value_from_key(diag_file_id, var_id, "output_name", field%var_outname, is_optional=.true.)
call diag_get_value_from_key(diag_file_id, var_id, "long_name", field%var_longname, is_optional=.true.)
!! VAR_UNITS !!
@@ -633,20 +627,6 @@ subroutine check_file_time_units (fileobj)
&Check your entry for file:"//trim(fileobj%file_fname))
end subroutine check_file_time_units
-!> @brief This checks if the realm in a diag file is valid and crashes if it isn't
-subroutine check_file_realm(fileobj)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to checK
-
- select case (TRIM(fileobj%file_realm))
- case ("ATM", "OCN", "LND", "ICE", "")
- case default
- call mpp_error(FATAL, trim(fileobj%file_realm)//" is an invalid realm! &
- &The acceptable values are ATM, OCN, LND, ICE. &
- &Check your entry for file:"//trim(fileobj%file_fname))
- end select
-
-end subroutine check_file_realm
-
!> @brief This checks if the new file frequency in a diag file is valid and crashes if it isn't
subroutine check_new_file_freq(fileobj)
type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
@@ -785,14 +765,6 @@ pure function get_file_unlimdim(diag_files_obj) &
character (len=:), allocatable :: res !< What is returned
res = diag_files_obj%file_unlimdim
end function get_file_unlimdim
-!> @brief Inquiry for diag_files_obj%file_realm
-!! @return file_realm of a diag_yaml_file_obj
-pure function get_file_realm(diag_files_obj) &
-result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (:), allocatable :: res !< What is returned
- res = diag_files_obj%file_realm
-end function get_file_realm
!> @brief Inquiry for diag_files_obj%file_subregion
!! @return file_sub_region of a diag_yaml_file_obj
pure function get_file_sub_region (diag_files_obj) &
@@ -1004,12 +976,6 @@ pure logical function has_file_write (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
has_file_write = .true.
end function has_file_write
-!> @brief Checks if obj%file_realm is allocated
-!! @return true if obj%file_realm is allocated
-pure logical function has_file_realm (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_realm = allocated(obj%file_realm)
-end function has_file_realm
!> @brief Checks if obj%file_sub_region is being used and has the sub region variables allocated
!! @return true if obj%file_sub_region sub region variables are allocated
pure logical function has_file_sub_region (obj)
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index de4a71d88c..efa06f6182 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -174,10 +174,6 @@ subroutine compare_diag_files(res)
call compare_result("file_unlimdim 2", res(2)%get_file_unlimdim(), "records")
call compare_result("file_unlimdim 3", res(3)%get_file_unlimdim(), "records")
- call compare_result("file_realm 1", res(1)%get_file_realm(), "ATM")
- call compare_result("file_realm 2", res(2)%get_file_realm(), "")
- call compare_result("file_realm 3", res(3)%get_file_realm(), "")
-
call compare_result("file_new_file_freq 1", res(1)%get_file_new_file_freq(), 6)
call compare_result("file_new_file_freq 2", res(2)%get_file_new_file_freq(), DIAG_NULL)
call compare_result("file_new_file_freq 3", res(3)%get_file_new_file_freq(), DIAG_NULL)
From 41e7a0fc35f477d9bdc30e24b11d0524ce74a781 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 1 Apr 2022 13:27:06 -0400
Subject: [PATCH 042/168] fix: modern diag removes realm variables and cleans
up white space (#947)
---
test_fms/diag_manager/check_crashes.sh | 206 +++++++-------------
test_fms/diag_manager/test_diag_manager2.sh | 1 -
2 files changed, 71 insertions(+), 136 deletions(-)
diff --git a/test_fms/diag_manager/check_crashes.sh b/test_fms/diag_manager/check_crashes.sh
index da68fdf81f..9ec803ebec 100755
--- a/test_fms/diag_manager/check_crashes.sh
+++ b/test_fms/diag_manager/check_crashes.sh
@@ -26,138 +26,74 @@
. ../test_common.sh
printf "&check_crashes_nml \n checking_crashes = .true. \n/" | cat > input.nml
-
-echo "Test 27: Missing tile when using the 'index' grid type"
-touch input.nml
-sed '/tile/d' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since 'tile' was missing and the 'index' grid type was used"
- exit 3
-fi
-
-echo "Test 28: Missing new_file_freq_units when using new_file_freq_units"
-touch input.nml
-sed '/new_file_freq_units/d' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since 'new_file_freq_units' was missing and new_file_freq was used"
- exit 3
-fi
-
-echo "Test 29: new_file_freq_units is not valid"
-touch input.nml
-sed 's/new_file_freq_units: hours/new_file_freq_units: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since 'new_file_freq_units' is not valid"
- exit 3
-fi
-
-echo "Test 30: Missing file_duration_units when using file_duration"
-touch input.nml
-sed '/file_duration_units/d' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since 'file_duration_units' was missing and file_duration was used"
- exit 3
-fi
-
-echo "Test 31: file_duration_units is not valid"
-touch input.nml
-sed 's/file_duration_units: hours/file_duration_units: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since 'file_duration_units' is not valid"
- exit 3
-fi
-
-echo "Test 32: freq units is not valid"
-touch input.nml
-sed 's/freq_units: hours/freq_units: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since the freq units is not valid"
- exit 3
-fi
-
-echo "Test 33: freq is less than 0"
-touch input.nml
-sed 's/freq: 6/freq: -666/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since freq is not valid"
- exit 3
-fi
-
-echo "Test 34: realm is not valid"
-touch input.nml
-sed 's/realm: ATM/realm: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since realm is not valid"
- exit 3
-fi
-
-echo "Test 35: kind is not valid"
-touch input.nml
-sed 's/kind: float/kind: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since the kind is not valid"
- exit 3
-fi
-
-echo "Test 36: reduction is not valid"
-touch input.nml
-sed 's/reduction: average/reduction: mullions/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since the reduction method is not valid"
- exit 3
-fi
-
-echo "Test 37: diurnal samples is less than 0"
-touch input.nml
-sed 's/reduction: average/reduction: diurnal0/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since the number of diurnal samples is less than 0"
- exit 3
-fi
-
-echo "Test 38: diurnal samples is not an integer"
-touch input.nml
-sed 's/reduction: average/reduction: diurnal99r/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since the number of diurnal samples is not valid"
- exit 3
-fi
-
-echo "Test 39: power value is less than 0"
-touch input.nml
-sed 's/reduction: average/reduction: pow0/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since the power value is less than"
- exit 3
-fi
-
-echo "Test 40: power value is not an integer"
-touch input.nml
-sed 's/reduction: average/reduction: pow99r/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since the power value is not valid"
- exit 3
-fi
-
-echo "Test 41: the sub_region grid_type is not valid"
-touch input.nml
-sed 's/grid_type: latlon/grid_type: ice_cream/g' $top_srcdir/test_fms/diag_manager/diagTables/diag_table_yaml_26 > diag_table.yaml
-run_test test_diag_yaml 1 $parser_skip && echo "It worked?"
-if [ $? -eq 0 ]; then
- echo "Test should have failed since the sub_region grid_type"
- exit 3
-fi
+sed '/tile/d' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "Missing tile when using the 'index' grid type" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed '/new_file_freq_units/d' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "Missing new_file_freq_units when using new_file_freq_units" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/new_file_freq_units: hours/new_file_freq_units: mullions/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "new_file_freq_units is not valid" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed '/file_duration_units/d' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "Missing file_duration_units when using file_duration" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/file_duration_units: hours/file_duration_units: mullions/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "file_duration_units is not valid" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/freq_units: hours/freq_units: mullions/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "freq units is not valid" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/freq: 6/freq: -666/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "freq is less than -1" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/kind: float/kind: mullions/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "kind is not valid" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/reduction: average/reduction: mullions/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "reduction is not valid" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/reduction: average/reduction: diurnal0/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "diurnal samples is less than 0" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/reduction: average/reduction: diurnal99r/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "diurnal samples is not an integer" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/reduction: average/reduction: pow0/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "power value is less than 0" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/reduction: average/reduction: pow99r/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "power value is not an integer" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+sed 's/grid_type: latlon/grid_type: ice_cream/g' diag_table.yaml_base > diag_table.yaml
+test_expect_failure "the sub_region grid_type is not valid" '
+ mpirun -n 1 ../test_diag_yaml
+'
+
+test_done
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 9a2f329c60..e1e9e80592 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -522,7 +522,6 @@ diag_files:
start_time: 2 1 1 0 0 0
file_duration: 12
file_duration_units: hours
- realm: ATM
varlist:
- module: test_diag_manager_mod
var_name: sst
From c795b7247d3f3a0ca17bbe941c6d242a700e66f3 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 14 Apr 2022 12:24:41 -0400
Subject: [PATCH 043/168] feat: update and add helper routines for
register_diag_field (#950)
---
diag_manager/diag_manager.F90 | 43 ++++++++++++---
diag_manager/fms_diag_yaml.F90 | 69 +++++++++++++++++++++++-
test_fms/diag_manager/test_diag_yaml.F90 | 45 +++++++++++++++-
3 files changed, 148 insertions(+), 9 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 9abd7a60ee..5742a6cb15 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -232,7 +232,7 @@ MODULE diag_manager_mod
& max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,&
& max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time,diag_data_init,&
& use_modern_diag, diag_null
-
+
USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
@@ -240,7 +240,7 @@ MODULE diag_manager_mod
USE fms_diag_object_mod, ONLY: fmsDiagObject_type
#ifdef use_yaml
- use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields
+ use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field
#endif
USE constants_mod, ONLY: SECONDS_PER_DAY
@@ -470,8 +470,23 @@ INTEGER FUNCTION register_diag_field_scalar_modern(module_name, field_name, init
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
- ! TODO: Check if the diag_field is in the yaml, if it is not return diag_null. If it is fill in the diag_obj
- register_diag_field_scalar_modern = diag_null
+#ifdef use_yaml
+ integer, allocatable :: diag_file_indices(:) !< indices where the field was found
+
+ diag_file_indices = find_diag_field(field_name)
+ if (diag_file_indices(1) .eq. diag_null) then
+ !< The field was not found in the table, so return diag_null
+ register_diag_field_scalar_modern = diag_null
+ deallocate(diag_file_indices)
+ return
+ endif
+
+ registered_variables = registered_variables + 1
+ register_diag_field_scalar_modern = registered_variables
+
+ !< TO DO: Fill in the diag_obj
+ deallocate(diag_file_indices)
+#endif
end function register_diag_field_scalar_modern
@@ -502,8 +517,24 @@ INTEGER FUNCTION register_diag_field_array_modern(module_name, field_name, axes,
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
- ! TODO: Check if the diag_field is in the yaml, if it is not return diag_null. If it is fill in the diag_obj
- register_diag_field_array_modern = diag_null
+#ifdef use_yaml
+ integer, allocatable :: diag_file_indices(:) !< indices where the field was found
+
+ diag_file_indices = find_diag_field(field_name)
+ if (diag_file_indices(1) .eq. diag_null) then
+ !< The field was not found in the table, so return diag_null
+ register_diag_field_array_modern = diag_null
+ deallocate(diag_file_indices)
+ return
+ endif
+
+ registered_variables = registered_variables + 1
+ register_diag_field_array_modern = registered_variables
+
+ !< TO DO: Fill in the diag_obj
+ deallocate(diag_file_indices)
+#endif
+
end function register_diag_field_array_modern
!> @brief Registers a scalar field
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 340b004914..f6ca5d5f77 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -44,7 +44,7 @@ module fms_diag_yaml_mod
public :: diag_yaml_object_init, diag_yaml_object_end
public :: diagYamlObject_type, get_diag_yaml_obj, get_title, get_basedate, get_diag_files, get_diag_fields
public :: diagYamlFiles_type, diagYamlFilesVar_type
-public :: get_num_unique_fields
+public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_entries
!> @}
@@ -1128,6 +1128,73 @@ function get_num_unique_fields() &
end function get_num_unique_fields
+!> @brief Determines if a diag_field is in the diag_yaml_object
+!! @return Indices of the locations where the field was found
+function find_diag_field(diag_field_name) &
+result(indices)
+
+ character(len=*), intent(in) :: diag_field_name !< diag_field name to search for
+
+ integer, allocatable :: indices(:)
+
+ indices = fms_find_my_string(variable_list%var_pointer, size(variable_list%var_pointer), &
+ & diag_field_name//c_null_char)
+end function find_diag_field
+
+!> @brief Gets the diag_field entries corresponding to the indices of the sorted variable_list
+!! @return Array of diag_fields
+function get_diag_fields_entries(indices) &
+ result(diag_field)
+
+ integer, intent(in) :: indices(:) !< Indices of the field in the sorted variable_list array
+ type(diagYamlFilesVar_type), dimension (:), allocatable :: diag_field
+
+ integer :: i !< For do loops
+ integer :: field_id !< Indices of the field in the diag_yaml array
+
+ allocate(diag_field(size(indices)))
+
+ do i = 1, size(indices)
+ field_id = variable_list%diag_field_indices(indices(i))
+ diag_field(i) = diag_yaml%diag_fields(field_id)
+ end do
+
+end function get_diag_fields_entries
+
+!> @brief Gets the diag_files entries corresponding to the indices of the sorted variable_list
+!! @return Array of diag_files
+function get_diag_files_entries(indices) &
+ result(diag_file)
+
+ integer, intent(in) :: indices(:) !< Indices of the field in the sorted variable_list
+ type(diagYamlFiles_type), dimension (:), allocatable :: diag_file
+
+ integer :: i !< For do loops
+ integer :: field_id !< Indices of the field in the diag_yaml array
+ integer :: file_id !< Indices of the file in the diag_yaml array
+ character(len=120) :: filename !< Filename of the field
+ integer, allocatable :: file_indices(:) !< Indices of the file in the sorted variable_list
+
+ allocate(diag_file(size(indices)))
+
+ do i = 1, size(indices)
+ field_id = variable_list%diag_field_indices(indices(i))
+ filename = diag_yaml%diag_fields(field_id)%var_fname
+
+ file_indices = fms_find_my_string(file_list%file_pointer, size(file_list%file_pointer), &
+ & trim(filename)//c_null_char)
+
+ if (size(file_indices) .ne. 1) &
+ & call mpp_error(FATAL, "get_diag_files_entries: Error getting the correct number of file indices!")
+
+ if (file_indices(1) .eq. diag_null) &
+ & call mpp_error(FATAL, "get_diag_files_entries: Error finding the filename in the diag_files")
+
+ file_id = file_list%diag_file_indices(file_indices(1))
+ diag_file(i) = diag_yaml%diag_files(file_id)
+ end do
+
+end function get_diag_files_entries
#endif
end module fms_diag_yaml_mod
!> @}
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index efa06f6182..9b6d417046 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -52,6 +52,7 @@ end subroutine compare_result_1d
logical :: checking_crashes = .false.!< Flag indicating that you are checking crashes
integer :: i !< For do loops
integer :: io_status !< The status after reading the input.nml
+integer, allocatable :: indices(:) !< Array of indices
type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< Files from the diag_yaml
type(diagYamlFilesVar_type), allocatable, dimension(:) :: diag_fields !< Fields from the diag_yaml
@@ -90,9 +91,49 @@ end subroutine compare_result_1d
!< Check that get_num_unique_fields is getting the correct number of unique fields
call compare_result("number of unique fields", get_num_unique_fields(), 2)
+
+ deallocate(diag_files)
+ deallocate(diag_fields)
+
+ indices = find_diag_field("sst")
+ print *, "sst was found in ", indices
+ if (size(indices) .ne. 2) &
+ call mpp_error(FATAL, 'sst was supposed to be found twice!')
+ if (indices(1) .ne. 2 .and. indices(2) .ne. 1) &
+ call mpp_error(FATAL, 'sst was supposed to be found in indices 1 and 2')
+
+ diag_fields = get_diag_fields_entries(indices)
+ call compare_result("sst - nfields", size(diag_fields), 2)
+ call compare_result("sst - fieldname", diag_fields(1)%get_var_varname(), "sst")
+ call compare_result("sst - fieldname", diag_fields(2)%get_var_varname(), "sst")
+ deallocate(diag_fields)
+
+ diag_files = get_diag_files_entries(indices)
+ call compare_result("sst - nfiles", size(diag_files), 2)
+ call compare_result("sst - filename", diag_files(1)%get_file_fname(), "normal")
+ call compare_result("sst - filename", diag_files(2)%get_file_fname(), "wild_card_name%4yr%2mo%2dy%2hr")
+ deallocate(diag_files)
+ deallocate(indices)
+
+ indices = find_diag_field("sstt")
+ print *, "sstt was found in ", indices
+ if (size(indices) .ne. 1) &
+ call mpp_error(FATAL, 'sstt was supposed to be found twice!')
+ if (indices(1) .ne. 3) &
+ call mpp_error(FATAL, 'sstt was supposed to be found in indices 1 and 2')
+ deallocate(indices)
+
+ indices = find_diag_field("sstt2") !< This is in diag_table but it has write_var = false
+ print *, "sstt2 was found in ", indices
+ if (indices(1) .ne. -999) &
+ call mpp_error(FATAL, "sstt2 is not in the diag_table!")
+
+ indices = find_diag_field("tamales")
+ print *, "tamales was found in ", indices
+ if (indices(1) .ne. -999) &
+ call mpp_error(FATAL, "tamales is not in the diag_table!")
+
endif
-deallocate(diag_files)
-deallocate(diag_fields)
call diag_yaml_object_end
From 16f115349a83616454117df0418b7a76bc360637 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 14 Apr 2022 12:26:42 -0400
Subject: [PATCH 044/168] feat: Update supported types in diag_manager (#955)
---
diag_manager/fms_diag_yaml.F90 | 4 ++--
test_fms/diag_manager/test_diag_manager2.sh | 16 ++++++++--------
test_fms/diag_manager/test_diag_yaml.F90 | 6 +++---
3 files changed, 13 insertions(+), 13 deletions(-)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index f6ca5d5f77..11072f3ad5 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -664,10 +664,10 @@ subroutine check_field_kind(field)
type(diagYamlFilesVar_type), intent(in) :: field !< diagYamlFilesVar_type obj to read the contents into
select case (TRIM(field%var_skind))
- case ("double", "float")
+ case ("r4", "r8", "i4", "i8")
case default
call mpp_error(FATAL, trim(field%var_skind)//" is an invalid kind! &
- &The acceptable values are double and float. &
+ &The acceptable values are r4, r8, i4, i8. &
&Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
end select
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index e1e9e80592..7091cc5b02 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -527,7 +527,7 @@ diag_files:
var_name: sst
output_name: sst
reduction: average
- kind: float
+ kind: r4
global_meta:
- is_a_file: true
- file_name: normal
@@ -540,7 +540,7 @@ diag_files:
var_name: sst
output_name: sst
reduction: average
- kind: float
+ kind: r4
write_var: true
attributes:
- do_sst: .true.
@@ -559,13 +559,13 @@ diag_files:
var_name: sstt
output_name: sstt
reduction: average
- kind: float
+ kind: r4
long_name: S S T
- module: test_diag_manager_mod
var_name: sstt2
output_name: sstt2
reduction: average
- kind: float
+ kind: r4
long_name: S S T
write_var: false
sub_region:
@@ -604,7 +604,7 @@ diag_files:
var_name: sst1
output_name: sst1
reduction: average
- kind: float
+ kind: r4
- file_name: file2
freq: 6
freq_units: hours
@@ -616,7 +616,7 @@ diag_files:
var_name: sst2
output_name: sst2
reduction: average
- kind: float
+ kind: r4
- file_name: file3
freq: 6
freq_units: hours
@@ -627,12 +627,12 @@ diag_files:
var_name: sst3
output_name: sst3
reduction: average
- kind: float
+ kind: r4
- module: test_diag_manager_mod
var_name: sst4
output_name: sst4
reduction: average
- kind: float
+ kind: r4
_EOF
test_expect_success "Test the diag_ocean feature in diag_manager_init (test $my_test_count)" '
mpirun -n 2 ../test_diag_ocean
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index 9b6d417046..845991b900 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -163,9 +163,9 @@ subroutine compare_diag_fields(res)
call compare_result("var_module 2", res(2)%get_var_module(), "test_diag_manager_mod")
call compare_result("var_module 3", res(3)%get_var_module(), "test_diag_manager_mod")
- call compare_result("var_skind 1", res(1)%get_var_skind(), "float")
- call compare_result("var_skind 2", res(2)%get_var_skind(), "float")
- call compare_result("var_skind 3", res(3)%get_var_skind(), "float")
+ call compare_result("var_skind 1", res(1)%get_var_skind(), "r4")
+ call compare_result("var_skind 2", res(2)%get_var_skind(), "r4")
+ call compare_result("var_skind 3", res(3)%get_var_skind(), "r4")
call compare_result("var_outname 1", res(1)%get_var_outname(), "sst")
call compare_result("var_outname 2", res(2)%get_var_outname(), "sst")
From d184fe8c573ffca8571590fcf02ebc26b23a6c74 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 11 May 2022 14:27:38 -0400
Subject: [PATCH 045/168] feat: add diag axis obj (#966)
---
CMakeLists.txt | 1 +
diag_manager/Makefile.am | 5 +-
diag_manager/fms_diag_axis_object.F90 | 280 ++++++++++++++++++++++++++
3 files changed, 285 insertions(+), 1 deletion(-)
create mode 100644 diag_manager/fms_diag_axis_object.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index d667f6163a..6567c91e83 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -132,6 +132,7 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_bbox.F90
diag_manager/fms_diag_object.F90
diag_manager/fms_diag_yaml.F90
+ diag_manager/fms_diag_axis_object.F90
diag_manager/fms_diag_dlinked_list.F90
diag_manager/fms_diag_object_container.F90
drifters/cloud_interpolator.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 78589bb69b..29df3baa21 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -47,6 +47,7 @@ libdiag_manager_la_SOURCES = \
include/fms_diag_fieldbuff_update.fh
fms_diag_yaml.F90 \
fms_diag_object.F90 \
+ fms_diag_axis_object.F90 \
fms_diag_object_container.F90 \
fms_diag_dlinked_list.F90
@@ -60,10 +61,11 @@ diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEX
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT)
+fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
- fms_diag_object_container_mod.$(FC_MODEXT)
+ fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
MODFILES = \
@@ -83,6 +85,7 @@ MODFILES = \
include/fms_diag_fieldbuff_update.fh
fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) \
+ fms_diag_axis_object_mod.$(FC_MODEXT) \
fms_diag_dlinked_list_mod.$(FC_MODEXT) \
fms_diag_object_container_mod.$(FC_MODEXT) \
diag_manager_mod.$(FC_MODEXT)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
new file mode 100644
index 0000000000..615551d801
--- /dev/null
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -0,0 +1,280 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @defgroup fms_diag_axis_object_mod fms_diag_axis_object_mod
+!> @ingroup diag_manager
+!! @brief fms_diag_axis_object_mod stores the diag axis object, a diag domain
+!! object, and a subaxis object.
+
+!> @file
+!> @brief File for @ref diag_axis_object_mod
+
+!> @addtogroup fms_diag_axis_object_mod
+!> @{
+module fms_diag_axis_object_mod
+ use mpp_domains_mod, only: domain1d, domain2d, domainUG, mpp_get_compute_domain, CENTER, &
+ & mpp_get_compute_domain
+ use platform_mod, only: r8_kind, r4_kind
+ use diag_data_mod, only: diag_atttype
+ use mpp_mod, only: FATAL, mpp_error
+ implicit none
+
+ PRIVATE
+
+ public :: diagAxis_t, diag_axis_init, set_subaxis
+ !> @}
+
+ !> @brief Type to hold the domain info for an axis
+ !! This type was created to avoid having to send in "Domain", "Domain2", "DomainUG" as arguments into subroutines
+ !! and instead only 1 class(diagDomain_t) argument can be send
+ !> @ingroup diag_axis_object_mod
+ type diagDomain_t
+ contains
+ procedure :: set => set_axis_domain
+ procedure :: length => get_length
+ end type diagDomain_t
+
+ !> @brief Type to hold the 1d domain
+ type, extends(diagDomain_t) :: diagDomain1d_t
+ type(domain1d) :: Domain !< 1d Domain of the axis
+ end type
+
+ !> @brief Type to hold the 2d domain
+ type, extends(diagDomain_t) :: diagDomain2d_t
+ type(domain2d) :: Domain2 !< 2d Domain of an "X" or "Y" axis
+ end type
+
+ !> @brief Type to hold the unstructured domain
+ type, extends(diagDomain_t) :: diagDomainUg_t
+ type(domainUG) :: DomainUG !< Domain of "U" axis
+ end type
+
+ !> @brief Type to hold the subaxis
+ !> @ingroup diag_axis_object_mod
+ TYPE subaxis_t
+ CHARACTER(len=:), ALLOCATABLE :: subaxis_name !< Name of the subaxis
+ INTEGER :: starting_index !< Starting index of the subaxis relative to the parent axis
+ INTEGER :: ending_index !< Ending index of the subaxis relative to the parent axis
+ class(*) , ALLOCATABLE :: bounds !< Bounds of the subaxis (lat/lon or indices)
+ contains
+ procedure :: exists => check_if_subaxis_exists
+ END TYPE subaxis_t
+
+ !> @brief Type to hold the diagnostic axis description.
+ !> @ingroup diag_axis_object_mod
+ TYPE diagAxis_t
+ CHARACTER(len=:), ALLOCATABLE, private :: axis_name !< Name of the axis
+ CHARACTER(len=:), ALLOCATABLE, private :: units !< Units of the axis
+ CHARACTER(len=:), ALLOCATABLE, private :: long_name !< Long_name attribute of the axis
+ CHARACTER(len=1) , private :: cart_name !< Cartesian name "X", "Y", "Z", "T", "U", "N"
+ CLASS(*), ALLOCATABLE, private :: axis_data(:) !< Data of the axis
+ !< TO DO this can be a dlinked to avoid having limits
+ type(subaxis_t) , private :: subaxis(3) !< Array of subaxis
+ integer , private :: nsubaxis !< Number of subaxis
+ class(diagDomain_t),ALLOCATABLE, private :: axis_domain !< Domain
+ INTEGER , private :: length !< Global axis length
+ INTEGER , private :: direction !< Direction of the axis 0, 1, -1
+ INTEGER , private :: edges !< Axis ID for the previously defined "edges axis"
+ CHARACTER(len=128) , private :: aux !< Auxiliary name, can only be geolon_t
+ !! or geolat_t
+ CHARACTER(len=128) , private :: req !< Required field names.
+ INTEGER , private :: tile_count !< The number of tiles
+ TYPE(diag_atttype),allocatable , private :: attributes(:) !< Array to hold user definable attributes
+ INTEGER , private :: num_attributes !< Number of defined attibutes
+ INTEGER , private :: domain_position !< The position in the doman (NORTH or EAST or CENTER)
+
+ contains
+
+ PROCEDURE :: register => diag_axis_init
+ PROCEDURE :: axis_length => get_axis_length
+ PROCEDURE :: set_subaxis
+
+ ! TO DO:
+ ! PROCEDURE :: write_axis_metadata
+ ! PROCEDURE :: write_axis_data
+ ! PROCEDURE :: get_fileobj_type_needed (use the domain to figure out what fms2 fileobj to use)
+ ! Get/has/is subroutines as needed
+ END TYPE diagAxis_t
+
+ !> @addtogroup fms_diag_yaml_mod
+ !> @{
+ contains
+
+ !!!!!!!!!!!!!!!!! DIAG AXIS PROCEDURES !!!!!!!!!!!!!!!!!
+ !> @brief Initialize the axis
+ subroutine diag_axis_init(obj, axis_name, axis_data, units, cart_name, long_name, direction,&
+ & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position )
+ class(diagAxis_t), INTENT(out) :: obj !< Diag_axis obj
+ CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
+ class(*), INTENT(in) :: axis_data(:) !< Array of coordinate values
+ CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
+ CHARACTER(len=1), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", "U", "N")
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name !< Name of the parent axis, if it is a subaxis
+ INTEGER, INTENT(in), OPTIONAL :: direction !< Indicates the direction of the axis
+ INTEGER, INTENT(in), OPTIONAL :: edges !< Axis ID for the previously defined "edges axis"
+ TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1D domain
+ TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2D domain
+ TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: aux !< Auxiliary name, can only be geolon_t
+ !! or geolat_t
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: req !< Required field names.
+ INTEGER, INTENT(in), OPTIONAL :: tile_count !< Number of tiles
+ INTEGER, INTENT(in), OPTIONAL :: domain_position !< Domain position, "NORTH" or "EAST"
+
+ obj%axis_name = trim(axis_name)
+ obj%units = trim(units)
+ obj%cart_name = trim(cart_name) !< TO DO Check for valid cart_names
+ if (present(long_name)) obj%long_name = trim(long_name)
+
+ select type (axis_data)
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: obj%axis_data(size(axis_data)))
+ obj%axis_data = axis_data
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: obj%axis_data(size(axis_data)))
+ obj%axis_data = axis_data
+ class default
+ call mpp_error(FATAL, "The axis_data in your diag_axis_init call is not a supported type. &
+ & Currently only r4 and r8 data is supported.")
+ end select
+
+ !< TO DO check the presence of multiple Domains
+ if (present(Domain)) then
+ allocate(diagDomain1d_t :: obj%axis_domain)
+ call obj%axis_domain%set(Domain=Domain)
+ else if (present(Domain2)) then
+ allocate(diagDomain2d_t :: obj%axis_domain)
+ call obj%axis_domain%set(Domain2=Domain2)
+ else if (present(DomainU)) then
+ allocate(diagDomainUg_t :: obj%axis_domain)
+ call obj%axis_domain%set(DomainU=DomainU)
+ endif
+
+ obj%tile_count = 1
+ if (present(tile_count)) obj%tile_count = tile_count
+
+ !< TO DO Check for valid domain_position
+ obj%domain_position = CENTER
+ if (present(domain_position)) obj%domain_position = domain_position
+
+ obj%length = size(axis_data)
+
+ !< TO DO Check for valid direction
+ obj%direction = 0
+ if (present(direction)) obj%direction = direction
+
+ !< TO DO Check if id is valid and with the same parameters
+ obj%edges = 0
+ if (present(edges)) obj%edges = edges
+
+ if (present(aux)) obj%aux = trim(aux)
+ if (present(req)) obj%req = trim(req)
+
+ obj%nsubaxis = 0
+ end subroutine diag_axis_init
+
+ !> @brief Get the length of the axis
+ !> @return axis length
+ function get_axis_length(obj) &
+ result (axis_length)
+ class(diagAxis_t), intent(inout) :: obj !< diag_axis obj
+ integer :: axis_length
+
+ !< If the axis is domain decomposed axis_length will be set to the length for the current PE:
+ if (allocated(obj%axis_domain)) then
+ axis_length = obj%axis_domain%length(obj%cart_name, obj%domain_position, obj%length)
+ else
+ axis_length = obj%length
+ endif
+
+ end function
+
+ !> @brief Set the subaxis of the axis obj
+ subroutine set_subaxis(obj, bounds)
+ class(diagAxis_t), INTENT(INOUT) :: obj !< diag_axis obj
+ class(*), INTENT(INOUT) :: bounds(:) !< bound of the subaxis
+
+ integer :: i !< For do loops
+
+ !< Check if the subaxis for this bouds already exists
+ do i = 1, obj%nsubaxis
+ if (obj%subaxis(i)%exists(bounds)) return
+ enddo
+
+ !< TO DO: everything
+ obj%nsubaxis = obj%nsubaxis + 1
+ end subroutine
+
+ !!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!!
+ !> @brief Check if a subaxis was already defined
+ !> @return Flag indicating if a subaxis is already defined
+ function check_if_subaxis_exists(obj,bounds) &
+ result(exists)
+ class(subaxis_t), INTENT(INOUT) :: obj !< diag_axis obj
+ class(*), INTENT(IN) :: bounds(:) !< bounds of the subaxis
+ logical :: exists
+
+ !< TO DO: compare bounds
+ exists = .false.
+ end function
+
+ !> @brief Get the length of a 2D domain
+ !> @return Length of the 2D domain
+ function get_length(obj, cart_axis, domain_position, global_length) &
+ result (length)
+ class(diagDomain_t), INTENT(INOUT) :: obj !< diag_axis obj
+ character(len=*), INTENT(IN) :: cart_axis !< cart_axis of the axis
+ integer, INTENT(IN) :: domain_position !< Domain position (CENTER, NORTH, EAST)
+ integer, INTENT(IN) :: global_length !< global_length of the axis
+
+ integer :: length
+
+ select type (obj)
+ type is(diagDomain2d_t)
+ if (trim(cart_axis) == "X") call mpp_get_compute_domain(obj%Domain2, xsize=length, position=domain_position)
+ if (trim(cart_axis) == "Y") call mpp_get_compute_domain(obj%Domain2, ysize=length, position=domain_position)
+ class default
+ !< If domain is 1D or UG, just set it to the global length
+ length = global_length
+ end select
+ end function
+
+ !!!!!!!!!!!!!!!!! FMS_DOMAIN PROCEDURES !!!!!!!!!!!!!!!!!
+
+ !> @brief Set the axis domain
+ subroutine set_axis_domain(obj, Domain, Domain2, DomainU)
+ class(diagDomain_t) :: obj !< fms_domain obj
+ TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1d domain
+ TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2d domain
+ TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain
+
+ select type(obj)
+ type is (diagDomain1d_t)
+ obj%Domain = Domain
+ type is (diagDomain2d_t)
+ obj%Domain2 = Domain2
+ type is (diagDomainUg_t)
+ obj%DomainUG = DomainU
+ end select
+ end subroutine set_axis_domain
+
+end module fms_diag_axis_object_mod
+!> @}
+! close documentation grouping
From b704b46b910d8470709fa23caf3757fb426c6e79 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 16 May 2022 13:34:47 -0400
Subject: [PATCH 046/168] feat: modern diag add number of diurnal sample and
power level to the yaml (#977)
---
diag_manager/fms_diag_yaml.F90 | 44 +++++++++++++++++++++++++++++++---
1 file changed, 41 insertions(+), 3 deletions(-)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 11072f3ad5..1a6cd9f39a 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -156,6 +156,10 @@ module fms_diag_yaml_mod
character (len=:), private, allocatable :: var_outname !< Name of the variable as written to the file
character (len=:), private, allocatable :: var_longname !< Overwrites the long name of the variable
character (len=:), private, allocatable :: var_units !< Overwrites the units
+ integer , private :: n_diurnal !< Number of diurnal samples
+ !! 0 if var_reduction is not "diurnalXX"
+ integer , private :: pow_value !< The power value
+ !! 0 if pow_value is not "powXX"
!< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
character (len=MAX_STR_LEN), dimension (:, :), private, allocatable :: var_attributes !< Attributes to overwrite or
@@ -172,6 +176,8 @@ module fms_diag_yaml_mod
procedure :: get_var_longname
procedure :: get_var_units
procedure :: get_var_attributes
+ procedure :: get_n_diurnal
+ procedure :: get_pow_value
procedure :: is_var_attributes
procedure :: has_var_fname
@@ -183,6 +189,8 @@ module fms_diag_yaml_mod
procedure :: has_var_longname
procedure :: has_var_units
procedure :: has_var_attributes
+ procedure :: has_n_diurnal
+ procedure :: has_pow_value
end type diagYamlFilesVar_type
@@ -674,8 +682,9 @@ subroutine check_field_kind(field)
end subroutine check_field_kind
!> @brief This checks if the reduction of a diag field is valid and crashes if it isn't
+!! If the reduction method is diurnalXX or powXX, it gets the number of diurnal sample and the power value
subroutine check_field_reduction(field)
- type(diagYamlFilesVar_type), intent(in) :: field !< diagYamlFilesVar_type obj to read the contents into
+ type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into
integer :: n_diurnal !< number of diurnal samples
integer :: pow_value !< The power value
@@ -707,6 +716,9 @@ subroutine check_field_reduction(field)
&Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
end select
endif
+
+ field%n_diurnal = n_diurnal
+ field%pow_value = pow_value
end subroutine check_field_reduction
!> @brief This checks if a time unit is valid
@@ -918,6 +930,22 @@ pure function get_var_attributes(diag_var_obj) &
character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned
res = diag_var_obj%var_attributes
end function get_var_attributes
+!> @brief Inquiry for diag_yaml_files_var_obj%n_diurnal
+!! @return the number of diurnal samples of a diag_yaml_files_var_obj
+pure function get_n_diurnal(diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_var_obj%n_diurnal
+end function get_n_diurnal
+!> @brief Inquiry for diag_yaml_files_var_obj%pow_value
+!! @return the pow_value of a diag_yaml_files_var_obj
+pure function get_pow_value(diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_var_obj%pow_value
+end function get_pow_value
!> @brief Inquiry for whether var_attributes is allocated
!! @return Flag indicating if var_attributes is allocated
function is_var_attributes(diag_var_obj) &
@@ -1091,8 +1119,18 @@ pure logical function has_var_attributes (obj)
class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
has_var_attributes = allocated(obj%var_attributes)
end function has_var_attributes
-
-
+!> @brief Checks if obj%n_diurnal is set
+!! @return true if obj%n_diurnal is set
+pure logical function has_n_diurnal(obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to inquire
+ has_n_diurnal = (obj%n_diurnal .ne. 0)
+end function has_n_diurnal
+!> @brief Checks if obj%pow_value is set
+!! @return true if obj%pow_value is set
+pure logical function has_pow_value(obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to inquire
+ has_pow_value = (obj%pow_value .ne. 0)
+end function has_pow_value
!> @brief Checks if obj%diag_title is allocated
!! @return true if obj%diag_title is allocated
From d1c45757e3f747361301e3fcc4c1588c99cc20c5 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 23 May 2022 09:37:31 -0400
Subject: [PATCH 047/168] feat: modern diag subregional yaml update (#973)
---
diag_manager/diag_data.F90 | 3 +
diag_manager/fms_diag_yaml.F90 | 109 ++++++++++----------
test_fms/diag_manager/test_diag_manager2.sh | 13 ++-
3 files changed, 66 insertions(+), 59 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index c8c7a589ef..d8f533b67c 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -103,6 +103,9 @@ MODULE diag_data_mod
!! diag_table to indicate to use the full axis instead of a sub-axis
REAL, PARAMETER :: CMOR_MISSING_VALUE = 1.0e20 !< CMOR standard missing value
INTEGER, PARAMETER :: DIAG_FIELD_NOT_FOUND = -1 !< Return value for a diag_field that isn't found in the diag_table
+ INTEGER, PARAMETER :: latlon_gridtype = 1
+ INTEGER, PARAMETER :: index_gridtype = 2
+ INTEGER, PARAMETER :: null_gridtype = DIAG_NULL
!> @}
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 1a6cd9f39a..bbb534198c 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -30,12 +30,14 @@
!> @{
module fms_diag_yaml_mod
#ifdef use_yaml
-use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER, set_base_time
+use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER, set_base_time, latlon_gridtype, &
+ index_gridtype, null_gridtype
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL
use, intrinsic :: iso_c_binding, only : c_ptr, c_null_char
use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique
+use platform_mod, only: r4_kind, i4_kind
implicit none
@@ -68,17 +70,13 @@ module fms_diag_yaml_mod
!> @brief type to hold the sub region information about a file
type subRegion_type
- character (len=:), allocatable :: grid_type !< Flag indicating the type of region,
- !! acceptable values are "latlon" and "index"
- real, allocatable :: lat_lon_sub_region (:) !< Array that stores the grid point bounds for the sub region
- !! to use if grid_type is set to "latlon"
- !! [dim1_begin, dim1_end, dim2_begin, dim2_end,
- !! dim3_begin, dim3_end, dim4_begin, dim4_end]
- integer, allocatable :: index_sub_region (:) !< Array that stores the index bounds for the sub region to
- !! to use if grid_type is set to "index"
- !! [dim1_begin, dim1_end, dim2_begin, dim2_end,
- !! dim3_begin, dim3_end, dim4_begin, dim4_end]
- integer :: tile !< Tile number of the sub region, required if using the "index" grid type
+ INTEGER :: grid_type !< Flag indicating the type of region,
+ !! acceptable values are latlon_gridtype, index_gridtype,
+ !! null_gridtype
+ class(*), allocatable :: corners(:,:)!< (x, y) coordinates of the four corner of the region
+ integer :: zbounds(2) !< indices of the z axis limits (zbegin, zend)
+ integer :: tile !< Tile number of the sub region
+ !! required if using the "index" grid type
end type subRegion_type
@@ -224,11 +222,11 @@ module fms_diag_yaml_mod
!> @brief gets the diag_yaml module variable
!! @return a copy of the diag_yaml module variable
-pure function get_diag_yaml_obj() &
+function get_diag_yaml_obj() &
result(res)
type (diagYamlObject_type) :: res
- res = diag_yaml
+ res= diag_yaml
end function get_diag_yaml_obj
!> @brief get the basedate of a diag_yaml type
@@ -253,7 +251,7 @@ end function get_title
!> @brief get the diag_files of a diag_yaml type
!! @return the diag_files
-pure function get_diag_files(diag_yaml) &
+function get_diag_files(diag_yaml) &
result(diag_files)
class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files!< History file info
@@ -402,10 +400,8 @@ subroutine diag_yaml_object_end()
do i = 1, size(diag_yaml%diag_files, 1)
if(allocated(diag_yaml%diag_files(i)%file_varlist)) deallocate(diag_yaml%diag_files(i)%file_varlist)
if(allocated(diag_yaml%diag_files(i)%file_global_meta)) deallocate(diag_yaml%diag_files(i)%file_global_meta)
- if(allocated(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region)) &
- deallocate(diag_yaml%diag_files(i)%file_sub_region%lat_lon_sub_region)
- if(allocated(diag_yaml%diag_files(i)%file_sub_region%index_sub_region)) &
- deallocate(diag_yaml%diag_files(i)%file_sub_region%index_sub_region)
+ if(allocated(diag_yaml%diag_files(i)%file_sub_region%corners)) &
+ deallocate(diag_yaml%diag_files(i)%file_sub_region%corners)
enddo
if(allocated(diag_yaml%diag_files)) deallocate(diag_yaml%diag_files)
@@ -438,6 +434,7 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
integer :: j !< For do loops
integer, allocatable :: key_ids(:) !< Id of the gloabl atttributes key/value pairs
+ character(len=:), ALLOCATABLE :: grid_type !< grid_type as it is read in from the yaml
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", fileobj%file_frequnit)
@@ -463,24 +460,11 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
nsubregion = get_num_blocks(diag_yaml_id, "sub_region", parent_block_id=diag_file_id)
if (nsubregion .eq. 1) then
call get_block_ids(diag_yaml_id, "sub_region", sub_region_id, parent_block_id=diag_file_id)
- call diag_get_value_from_key(diag_yaml_id, sub_region_id(1), "grid_type", fileobj%file_sub_region%grid_type)
- if (trim(fileobj%file_sub_region%grid_type) .eq. "latlon") then
- allocate(fileobj%file_sub_region%lat_lon_sub_region(8))
- fileobj%file_sub_region%lat_lon_sub_region = DIAG_NULL
- call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%lat_lon_sub_region)
- elseif (trim(fileobj%file_sub_region%grid_type) .eq. "index") then
- allocate(fileobj%file_sub_region%index_sub_region(8))
- fileobj%file_sub_region%index_sub_region = DIAG_NULL
- call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region%index_sub_region)
- call get_value_from_key(diag_yaml_id, sub_region_id(1), "tile", fileobj%file_sub_region%tile, is_optional=.true.)
- if (fileobj%file_sub_region%tile .eq. DIAG_NULL) call mpp_error(FATAL, "The tile number is required when defining a "//&
- "subregion. Check your subregion entry for "//trim(fileobj%file_fname))
- else
- call mpp_error(FATAL, trim(fileobj%file_sub_region%grid_type)//" is not a valid region type. &
- &The acceptable values are latlon and index. &
- &Check your entry for file:"//trim(fileobj%file_fname))
- endif
- elseif (nsubregion .ne. 0) then
+ call diag_get_value_from_key(diag_yaml_id, sub_region_id(1), "grid_type", grid_type)
+ call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region, grid_type, fileobj%file_fname)
+ elseif (nsubregion .eq. 0) then
+ fileobj%file_sub_region%grid_type = null_gridtype
+ else
call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//" has multiple region blocks")
endif
@@ -569,19 +553,38 @@ subroutine diag_get_value_from_key(diag_file_id, par_id, key_name, value_name, i
end subroutine diag_get_value_from_key
!> @brief gets the lat/lon of the sub region to use in a diag_table yaml
-subroutine get_sub_region(diag_yaml_id, sub_region_id, sub_region)
- integer, intent(in) :: diag_yaml_id !< Id of the diag_table yaml file
- integer, intent(in) :: sub_region_id !< Id of the region block to read from
- class(*),intent(out) :: sub_region (NUM_SUB_REGION_ARRAY) !< Array storing the bounds of the sub region
-
- call get_value_from_key(diag_yaml_id, sub_region_id, "dim1_begin", sub_region(1), is_optional=.true.)
- call get_value_from_key(diag_yaml_id, sub_region_id, "dim1_end", sub_region(2), is_optional=.true.)
- call get_value_from_key(diag_yaml_id, sub_region_id, "dim2_begin", sub_region(3), is_optional=.true.)
- call get_value_from_key(diag_yaml_id, sub_region_id, "dim2_end", sub_region(4), is_optional=.true.)
- call get_value_from_key(diag_yaml_id, sub_region_id, "dim3_begin", sub_region(5), is_optional=.true.)
- call get_value_from_key(diag_yaml_id, sub_region_id, "dim3_end", sub_region(6), is_optional=.true.)
- call get_value_from_key(diag_yaml_id, sub_region_id, "dim4_begin", sub_region(7), is_optional=.true.)
- call get_value_from_key(diag_yaml_id, sub_region_id, "dim4_end", sub_region(8), is_optional=.true.)
+subroutine get_sub_region(diag_yaml_id, sub_region_id, sub_region, grid_type, fname)
+ integer, intent(in) :: diag_yaml_id !< Id of the diag_table yaml file
+ integer, intent(in) :: sub_region_id !< Id of the region block to read from
+ type(subRegion_type),intent(inout) :: sub_region !< Type that stores the sub_region
+ character(len=*), intent(in) :: grid_type !< The grid_type as it is read from the file
+ character(len=*), intent(in) :: fname !< filename of the subregion (for error messages)
+
+ select case (trim(grid_type))
+ case ("latlon")
+ sub_region%grid_type = latlon_gridtype
+ allocate(real(kind=r4_kind) :: sub_region%corners(4,2))
+ case ("index")
+ sub_region%grid_type = index_gridtype
+ allocate(integer(kind=i4_kind) :: sub_region%corners(4,2))
+
+ call get_value_from_key(diag_yaml_id, sub_region_id, "tile", sub_region%tile, is_optional=.true.)
+ if (sub_region%tile .eq. DIAG_NULL) call mpp_error(FATAL, &
+ "The tile number is required when defining a "//&
+ "subregion. Check your subregion entry for "//trim(fname))
+ case default
+ call mpp_error(FATAL, trim(grid_type)//" is not a valid region type. &
+ &The acceptable values are latlon and index. &
+ &Check your entry for file:"//trim(fname))
+ end select
+
+ call get_value_from_key(diag_yaml_id, sub_region_id, "corner1", sub_region%corners(1,:))
+ call get_value_from_key(diag_yaml_id, sub_region_id, "corner2", sub_region%corners(2,:))
+ call get_value_from_key(diag_yaml_id, sub_region_id, "corner3", sub_region%corners(3,:))
+ call get_value_from_key(diag_yaml_id, sub_region_id, "corner4", sub_region%corners(4,:))
+
+ sub_region%zbounds = DIAG_NULL
+ call get_value_from_key(diag_yaml_id, sub_region_id, "zbounds", sub_region%zbounds, is_optional=.true.)
end subroutine get_sub_region
@@ -779,7 +782,7 @@ pure function get_file_unlimdim(diag_files_obj) &
end function get_file_unlimdim
!> @brief Inquiry for diag_files_obj%file_subregion
!! @return file_sub_region of a diag_yaml_file_obj
-pure function get_file_sub_region (diag_files_obj) &
+function get_file_sub_region (diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
type(subRegion_type) :: res !< What is returned
@@ -1008,9 +1011,7 @@ end function has_file_write
!! @return true if obj%file_sub_region sub region variables are allocated
pure logical function has_file_sub_region (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- if ( (allocated(obj%file_sub_region%grid_type) .and. allocated(obj%file_sub_region%lat_lon_sub_region)) &
- .or.(allocated(obj%file_sub_region%grid_type) .and. allocated(obj%file_sub_region%index_sub_region))) &
- then
+ if ( obj%file_sub_region%grid_type .eq. latlon_gridtype .or. obj%file_sub_region%grid_type .eq. index_gridtype) then
has_file_sub_region = .true.
else
has_file_sub_region = .false.
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 7091cc5b02..b3319d269d 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -546,8 +546,10 @@ diag_files:
- do_sst: .true.
sub_region:
- grid_type: latlon
- dim1_begin: 64.0
- dim3_end: 20.0
+ corner1: -80, 0
+ corner2: -80, 75
+ corner3: -60, 0
+ corner4: -60, 75
- file_name: normal2
freq: -1
freq_units: days
@@ -571,9 +573,10 @@ diag_files:
sub_region:
- grid_type: index
tile: 1
- dim2_begin: 10
- dim2_end: 20
- dim1_begin: 10
+ corner1: 10, 15
+ corner2: 20, 15
+ corner3: 10, 25
+ corner4: 20, 25
- file_name: normal3
freq: -1
freq_units: days
From e3cc26096a243cb2e9faf688809bb216ce634398 Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Wed, 1 Jun 2022 12:23:43 -0400
Subject: [PATCH 048/168] feat: add diag file object (#943)
---
CMakeLists.txt | 1 +
diag_manager/Makefile.am | 12 +-
diag_manager/diag_manager.F90 | 4 +-
diag_manager/fms_diag_file_object.F90 | 403 ++++++++++++++++++++++++++
diag_manager/fms_diag_object.F90 | 41 +--
diag_manager/fms_diag_yaml.F90 | 28 +-
6 files changed, 455 insertions(+), 34 deletions(-)
create mode 100644 diag_manager/fms_diag_file_object.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 6567c91e83..b6f6b95e4f 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -132,6 +132,7 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_bbox.F90
diag_manager/fms_diag_object.F90
diag_manager/fms_diag_yaml.F90
+ diag_manager/fms_diag_file_object.F90
diag_manager/fms_diag_axis_object.F90
diag_manager/fms_diag_dlinked_list.F90
diag_manager/fms_diag_object_container.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 29df3baa21..30ada40f19 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -42,9 +42,10 @@ libdiag_manager_la_SOURCES = \
fms_diag_outfield.F90 \
fms_diag_elem_weight_procs.F90 \
fms_diag_fieldbuff_update.F90 \
- fms_diag_bbox.F90 \
+ fms_diag_bbox.F90 \
include/fms_diag_fieldbuff_update.inc \
- include/fms_diag_fieldbuff_update.fh
+ include/fms_diag_fieldbuff_update.fh \
+ fms_diag_file_object.F90 \
fms_diag_yaml.F90 \
fms_diag_object.F90 \
fms_diag_axis_object.F90 \
@@ -59,12 +60,14 @@ diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT
diag_grid_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
-fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT)
fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
- fms_diag_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
+ fms_diag_object_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) \
+ fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
@@ -84,6 +87,7 @@ MODFILES = \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh
fms_diag_yaml_mod.$(FC_MODEXT) \
+ fms_diag_file_object_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) \
fms_diag_axis_object_mod.$(FC_MODEXT) \
fms_diag_dlinked_list_mod.$(FC_MODEXT) \
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 5742a6cb15..5f5e2d9472 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -238,9 +238,10 @@ MODULE diag_manager_mod
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
USE fms_diag_object_mod, ONLY: fmsDiagObject_type
-
+ USE fms_diag_file_object_mod, only: fms_diag_files_object_initialized
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field
+ use fms_diag_file_object_mod, only: fms_diag_files_object_init
#endif
USE constants_mod, ONLY: SECONDS_PER_DAY
@@ -4075,6 +4076,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
CALL diag_yaml_object_init(diag_subset_output)
allocate(diag_objs(get_num_unique_fields()))
registered_variables = 0
+ fms_diag_files_object_initialized = fms_diag_files_object_init ()
endif
#else
if (use_modern_diag) &
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
new file mode 100644
index 0000000000..45d6b45c45
--- /dev/null
+++ b/diag_manager/fms_diag_file_object.F90
@@ -0,0 +1,403 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @defgroup fms_diag_output_yaml_mod fms_diag_output_yaml_mod
+!> @ingroup diag_manager
+!! @brief fms_diag_file_object_mod handles the file objects data, functions, and subroutines.
+!! @author Tom Robinson
+!! @description The fmsDiagFile_type contains the information for each history file to be written. It has
+!! a pointer to the information from the diag yaml, additional metadata that comes from the model, and a
+!! list of the variables and their variable IDs that are in the file.
+module fms_diag_file_object_mod
+!use mpp_mod, only: mpp_error, FATAL
+use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t
+use diag_data_mod, only: DIAG_NULL
+#ifdef use_yaml
+use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type
+#endif
+
+implicit none
+private
+
+public :: fmsDiagFile_type, FMS_diag_files, fms_diag_files_object_init, fms_diag_files_object_initialized
+
+logical :: fms_diag_files_object_initialized = .false.
+
+integer, parameter :: var_string_len = 25
+
+type :: fmsDiagFile_type
+ private
+ integer :: id !< The number associated with this file in the larger array of files
+ class(FmsNetcdfFile_t), allocatable :: fileobj !< fms2_io file object for this history file
+ character(len=1) :: file_domain_type !< (I don't think we will need this)
+#ifdef use_yaml
+ type(diagYamlFiles_type), pointer :: diag_yaml_file => null() !< Pointer to the diag_yaml_file data
+#endif
+ character(len=:) , dimension(:), allocatable :: file_metadata_from_model !< File metadata that comes from
+ !! the model.
+ integer, dimension(:), allocatable :: var_ids !< Variable IDs corresponding to file_varlist
+ integer, dimension(:), private, allocatable :: var_index !< An array of the variable indicies in the
+ !! diag_object. This should be the same size as
+ !! `file_varlist`
+ logical, dimension(:), private, allocatable :: var_reg !< Array corresponding to `file_varlist`, .true.
+ !! if the variable has been registered and
+ !! `file_var_index` has been set for the variable
+
+ contains
+
+ procedure, public :: has_file_metadata_from_model
+ procedure, public :: has_fileobj
+#ifdef use_yaml
+ procedure, public :: has_diag_yaml_file
+#endif
+ procedure, public :: has_var_ids
+ procedure, public :: get_id
+! TODO procedure, public :: get_fileobj ! TODO
+ procedure, public :: get_file_domain_type
+! TODO procedure, public :: get_diag_yaml_file ! TODO
+ procedure, public :: get_file_metadata_from_model
+ procedure, public :: get_var_ids
+! The following fuctions come will use the yaml inquiry functions
+#ifdef use_yaml
+ procedure, public :: get_file_fname
+ procedure, public :: get_file_frequnit
+ procedure, public :: get_file_freq
+ procedure, public :: get_file_timeunit
+ procedure, public :: get_file_unlimdim
+!! TODO get functions for sub region stuff
+! procedure, public :: get_file_sub_region
+ procedure, public :: get_file_new_file_freq
+ procedure, public :: get_file_new_file_freq_units
+ procedure, public :: get_file_start_time
+ procedure, public :: get_file_duration
+ procedure, public :: get_file_duration_units
+ procedure, public :: get_file_varlist
+ procedure, public :: get_file_global_meta
+ procedure, public :: has_file_fname
+ procedure, public :: has_file_frequnit
+ procedure, public :: has_file_freq
+ procedure, public :: has_file_timeunit
+ procedure, public :: has_file_unlimdim
+ procedure, public :: has_file_sub_region
+ procedure, public :: has_file_new_file_freq
+ procedure, public :: has_file_new_file_freq_units
+ procedure, public :: has_file_start_time
+ procedure, public :: has_file_duration
+ procedure, public :: has_file_duration_units
+ procedure, public :: has_file_varlist
+ procedure, public :: has_file_global_meta
+#endif
+
+end type fmsDiagFile_type
+
+type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_files !< The array of diag files
+
+contains
+
+!< @brief Allocates the number of files and sets an ID based for each file
+!! @return true if there are files allocated in the YAML object
+logical function fms_diag_files_object_init ()
+#ifdef use_yaml
+ integer :: nFiles !< Number of files in the diag yaml
+ integer :: i !< Looping iterator
+ if (diag_yaml%has_diag_files()) then
+ nFiles = diag_yaml%size_diag_files()
+ allocate (FMS_diag_files(nFiles))
+ set_ids_loop: do i= 1,nFiles
+ FMS_diag_files(i)%diag_yaml_file => diag_yaml%diag_files(i)
+ FMS_diag_files(i)%id = i
+ allocate(FMS_diag_files(i)%var_ids(diag_yaml%diag_files(i)%size_file_varlist()))
+ allocate(FMS_diag_files(i)%var_index(diag_yaml%diag_files(i)%size_file_varlist()))
+ allocate(FMS_diag_files(i)%var_reg(diag_yaml%diag_files(i)%size_file_varlist()))
+ !! Initialize the integer arrays
+ FMS_diag_files(i)%var_ids = DIAG_NULL
+ FMS_diag_files(i)%var_reg = .FALSE.
+ FMS_diag_files(i)%var_index = DIAG_NULL
+ enddo set_ids_loop
+ fms_diag_files_object_init = .true.
+ else
+ fms_diag_files_object_init = .false.
+! mpp_error("fms_diag_files_object_init: The diag_table.yaml file has not been correctly parsed.",&
+! FATAL)
+ endif
+#else
+ fms_diag_files_object_init = .false.
+#endif
+end function fms_diag_files_object_init
+!> \brief Logical function to determine if the variable file_metadata_from_model has been allocated or associated
+!! \return .True. if file_metadata_from_model exists .False. if file_metadata_from_model has not been set
+pure logical function has_file_metadata_from_model (obj)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ has_file_metadata_from_model = allocated(obj%file_metadata_from_model)
+end function has_file_metadata_from_model
+!> \brief Logical function to determine if the variable fileobj has been allocated or associated
+!! \return .True. if fileobj exists .False. if fileobj has not been set
+pure logical function has_fileobj (obj)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ has_fileobj = allocated(obj%fileobj)
+end function has_fileobj
+#ifdef use_yaml
+!> \brief Logical function to determine if the variable diag_yaml_file has been allocated or associated
+!! \return .True. if diag_yaml_file exists .False. if diag_yaml has not been set
+pure logical function has_diag_yaml_file (obj)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ has_diag_yaml_file = associated(obj%diag_yaml_file)
+end function has_diag_yaml_file
+#endif
+!> \brief Logical function to determine if the variable var_ids has been allocated or associated
+!! \return .True. if var_ids exists .False. if var_ids has not been set
+pure logical function has_var_ids (obj)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ has_var_ids = allocated(obj%var_ids)
+end function has_var_ids
+!> \brief Returns a copy of the value of id
+!! \return A copy of id
+pure function get_id (obj) result (res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ integer :: res
+ res = obj%id
+end function get_id
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! TODO
+!> \brief Returns a copy of the value of fileobj
+!! \return A copy of fileobj
+!pure function get_fileobj (obj) result (res)
+! class(fmsDiagFile_type), intent(in) :: obj !< The file object
+! class(FmsNetcdfFile_t) :: res
+! res = obj%fileobj
+!end function get_fileobj
+!> \brief Returns a copy of the value of file_domain_type
+!! \return A copy of file_domain_type
+pure function get_file_domain_type (obj) result (res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character(1) :: res
+ res = obj%file_domain_type
+end function get_file_domain_type
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! TODO
+!!> \brief Returns a copy of the value of diag_yaml_file
+!!! \return A copy of diag_yaml_file
+!#ifdef use_yaml
+!pure function get_diag_yaml_file (obj) result (res)
+! class(fmsDiagFile_type), intent(in) :: obj !< The file object
+! type(diagYamlFiles_type) :: res
+! res = obj%diag_yaml_file
+!end function get_diag_yaml_file
+!#endif
+!> \brief Returns a copy of the value of file_metadata_from_model
+!! \return A copy of file_metadata_from_model
+pure function get_file_metadata_from_model (obj) result (res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character(len=:), dimension(:), allocatable :: res
+ res = obj%file_metadata_from_model
+end function get_file_metadata_from_model
+!> \brief Returns a copy of the value of var_ids
+!! \return A copy of var_ids
+pure function get_var_ids (obj) result (res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ integer, dimension(:), allocatable :: res
+ allocate(res(size(obj%var_ids)))
+ res = obj%var_ids
+end function get_var_ids
+!!!!!!!!! Functions from diag_yaml_file
+#ifdef use_yaml
+!> \brief Returns a copy of file_fname from the yaml object
+!! \return Copy of file_fname
+pure function get_file_fname (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character (len=:), allocatable :: res
+ res = obj%diag_yaml_file%get_file_fname()
+end function get_file_fname
+!> \brief Returns a copy of file_frequnit from the yaml object
+!! \return Copy of file_frequnit
+pure function get_file_frequnit (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character (len=:), allocatable :: res
+ res = obj%diag_yaml_file%get_file_frequnit()
+end function get_file_frequnit
+!> \brief Returns a copy of file_freq from the yaml object
+!! \return Copy of file_freq
+pure function get_file_freq (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ integer :: res
+ res = obj%diag_yaml_file%get_file_freq()
+end function get_file_freq
+!> \brief Returns a copy of file_timeunit from the yaml object
+!! \return Copy of file_timeunit
+pure function get_file_timeunit (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character (len=:), allocatable :: res
+ res = obj%diag_yaml_file%get_file_timeunit()
+end function get_file_timeunit
+!> \brief Returns a copy of file_unlimdim from the yaml object
+!! \return Copy of file_unlimdim
+pure function get_file_unlimdim (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character (len=:), allocatable :: res
+ res = obj%diag_yaml_file%get_file_unlimdim()
+end function get_file_unlimdim
+!! TODO - get functions for sub region stuff
+!> \brief Returns a copy of file_sub_region from the yaml object
+!! \return Copy of file_sub_region
+!pure function get_file_sub_region (obj) result(res)
+! class(fmsDiagFile_type), intent(in) :: obj !< The file object
+! integer :: res
+! res = obj%diag_yaml_file%get_file_sub_region()
+!end function get_file_sub_region
+!> \brief Returns a copy of file_new_file_freq from the yaml object
+!! \return Copy of file_new_file_freq
+pure function get_file_new_file_freq (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ integer :: res
+ res = obj%diag_yaml_file%get_file_new_file_freq()
+end function get_file_new_file_freq
+!> \brief Returns a copy of file_new_file_freq_units from the yaml object
+!! \return Copy of file_new_file_freq_units
+pure function get_file_new_file_freq_units (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character (len=:), allocatable :: res
+ res = obj%diag_yaml_file%get_file_new_file_freq_units()
+end function get_file_new_file_freq_units
+!> \brief Returns a copy of file_start_time from the yaml object
+!! \return Copy of file_start_time
+pure function get_file_start_time (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character (len=:), allocatable :: res
+ res = obj%diag_yaml_file%get_file_start_time()
+end function get_file_start_time
+!> \brief Returns a copy of file_duration from the yaml object
+!! \return Copy of file_duration
+pure function get_file_duration (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ integer :: res
+ res = obj%diag_yaml_file%get_file_duration()
+end function get_file_duration
+!> \brief Returns a copy of file_duration_units from the yaml object
+!! \return Copy of file_duration_units
+pure function get_file_duration_units (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character (len=:), allocatable :: res
+ res = obj%diag_yaml_file%get_file_duration_units()
+end function get_file_duration_units
+!> \brief Returns a copy of file_varlist from the yaml object
+!! \return Copy of file_varlist
+pure function get_file_varlist (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character (len=:), allocatable, dimension(:) :: res
+ res = obj%diag_yaml_file%get_file_varlist()
+end function get_file_varlist
+!> \brief Returns a copy of file_global_meta from the yaml object
+!! \return Copy of file_global_meta
+pure function get_file_global_meta (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ character (len=:), allocatable, dimension(:,:) :: res
+ res = obj%diag_yaml_file%get_file_global_meta()
+end function get_file_global_meta
+!> \brief Checks if file_fname is allocated in the yaml object
+!! \return true if file_fname is allocated
+pure function has_file_fname (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_fname()
+end function has_file_fname
+!> \brief Checks if file_frequnit is allocated in the yaml object
+!! \return true if file_frequnit is allocated
+pure function has_file_frequnit (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_frequnit()
+end function has_file_frequnit
+!> \brief Checks if file_freq is allocated in the yaml object
+!! \return true if file_freq is allocated
+pure function has_file_freq (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_freq()
+end function has_file_freq
+!> \brief Checks if file_timeunit is allocated in the yaml object
+!! \return true if file_timeunit is allocated
+pure function has_file_timeunit (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_timeunit()
+end function has_file_timeunit
+!> \brief Checks if file_unlimdim is allocated in the yaml object
+!! \return true if file_unlimdim is allocated
+pure function has_file_unlimdim (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_unlimdim()
+end function has_file_unlimdim
+!> \brief Checks if file_sub_region is allocated in the yaml object
+!! \return true if file_sub_region is allocated
+pure function has_file_sub_region (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_sub_region()
+end function has_file_sub_region
+!> \brief Checks if file_new_file_freq is allocated in the yaml object
+!! \return true if file_new_file_freq is allocated
+pure function has_file_new_file_freq (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_new_file_freq()
+end function has_file_new_file_freq
+!> \brief Checks if file_new_file_freq_units is allocated in the yaml object
+!! \return true if file_new_file_freq_units is allocated
+pure function has_file_new_file_freq_units (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_new_file_freq_units()
+end function has_file_new_file_freq_units
+!> \brief Checks if file_start_time is allocated in the yaml object
+!! \return true if file_start_time is allocated
+pure function has_file_start_time (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_start_time()
+end function has_file_start_time
+!> \brief Checks if file_duration is allocated in the yaml object
+!! \return true if file_duration is allocated
+pure function has_file_duration (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_duration()
+end function has_file_duration
+!> \brief Checks if file_duration_units is allocated in the yaml object
+!! \return true if file_duration_units is allocated
+pure function has_file_duration_units (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_duration_units()
+end function has_file_duration_units
+!> \brief Checks if file_varlist is allocated in the yaml object
+!! \return true if file_varlist is allocated
+pure function has_file_varlist (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_varlist()
+end function has_file_varlist
+!> \brief Checks if file_global_meta is allocated in the yaml object
+!! \return true if file_global_meta is allocated
+pure function has_file_global_meta (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ logical :: res
+ res = obj%diag_yaml_file%has_file_global_meta()
+end function has_file_global_meta
+#endif
+end module fms_diag_file_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 9ac1eef07a..7c814411a2 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -14,17 +14,14 @@ module fms_diag_object_mod
use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
#ifdef use_yaml
-use fms_diag_yaml_mod, only: diagYamlFiles_type, diagYamlFilesVar_type
+use fms_diag_yaml_mod, only: diagYamlFilesVar_type
+use fms_diag_file_object_mod, only: fmsDiagFile_type
#endif
use time_manager_mod, ONLY: time_type
!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
!!! & get_ticks_per_second
-!use diag_util_mod, only: int_to_cs, logical_to_cs
-!USE diag_data_mod, ONLY: fileobjU, fileobj, fnum_for_domain, fileobjND
-
-use fms2_io_mod
use platform_mod
use iso_c_binding
@@ -61,12 +58,11 @@ module fms_diag_object_mod
!> \brief Object that holds all variable information
type fmsDiagObject_type
#ifdef use_yaml
- type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table
- type (diagYamlFiles_type), allocatable, dimension(:) :: diag_file !< info from diag_table
+ type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable
+ type (fmsDiagFile_type), pointer, dimension(:) :: diag_files !< Array pointing to files that contain
+ !! the objects variable
#endif
integer, allocatable, private :: diag_id !< unique id for varable
- class(FmsNetcdfFile_t), dimension (:), pointer :: fileob => NULL() !< A pointer to all of the
- !! file objects for this variable
character(len=:), allocatable, dimension(:) :: metadata !< metadata for the variable
logical, allocatable, private :: static !< true if this is a static var
logical, allocatable, private :: registered !< true when registered
@@ -119,9 +115,10 @@ module fms_diag_object_mod
procedure :: is_local => get_local
! Is variable allocated check functions
!TODO procedure :: has_diag_field
-!TODO procedure :: has_diag_file
procedure :: has_diag_id
- procedure :: has_fileob
+#ifdef use_yaml
+ procedure :: has_diag_files
+#endif
procedure :: has_metadata
procedure :: has_static
procedure :: has_registered
@@ -395,12 +392,8 @@ subroutine copy_diag_obj(objin , objout)
else
call mpp_error("copy_diag_obj", "You can only copy objects that have been registered",warning)
endif
-! type (diag_fields_type) :: diag_field !< info from diag_table
-! type (diag_files_type),allocatable, dimension(:) :: diag_file !< info from diag_table
-
objout%diag_id = objin%diag_id
-! class (fms_io_obj), allocatable, dimension(:) :: fms_fileobj !< fileobjs
if (allocated(objin%metadata)) objout%metadata = objin%metadata
objout%static = objin%static
if (allocated(objin%frequency)) objout%frequency = objin%frequency
@@ -944,24 +937,20 @@ end function int_ne_obj
! class (fmsDiagObject_type), intent(in) :: obj !< diag object
! has_diag_field = allocated(obj%diag_field)
!end function has_diag_field
-!!> @brief Checks if obj%diag_file is allocated
-!!! @return true if obj%diag_file is allocated
-!logical function has_diag_file (obj)
-! class (fmsDiagObject_type), intent(in) :: obj !< diag object
-! has_diag_file = allocated(obj%diag_file)
-!end function has_diag_file
!> @brief Checks if obj%diag_id is allocated
!! @return true if obj%diag_id is allocated
pure logical function has_diag_id (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_diag_id = allocated(obj%diag_id)
end function has_diag_id
-!> @brief Checks if obj%fileob pointer is associated
-!! @return true if obj%fileob is associated
-pure logical function has_fileob (obj)
+#ifdef use_yaml
+!> @brief Checks if obj%diag_files pointer is associated
+!! @return true if obj%diag_files is associated
+pure logical function has_diag_files (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_fileob = associated(obj%fileob)
-end function has_fileob
+ has_diag_files = associated(obj%diag_files)
+end function has_diag_files
+#endif
!> @brief Checks if obj%metadata is allocated
!! @return true if obj%metadata is allocated
pure logical function has_metadata (obj)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index bbb534198c..53511a26fd 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -43,17 +43,18 @@ module fms_diag_yaml_mod
private
+public :: diag_yaml
public :: diag_yaml_object_init, diag_yaml_object_end
public :: diagYamlObject_type, get_diag_yaml_obj, get_title, get_basedate, get_diag_files, get_diag_fields
public :: diagYamlFiles_type, diagYamlFilesVar_type
public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_entries
-
!> @}
integer, parameter :: basedate_size = 6
integer, parameter :: NUM_SUB_REGION_ARRAY = 8
integer, parameter :: MAX_STR_LEN = 255
+
!> @brief type to hold an array of sorted diag_fiels
type varList_type
character(len=255), allocatable :: var_name(:) !< Array of diag_field
@@ -112,6 +113,7 @@ module fms_diag_yaml_mod
!> All getter functions (functions named get_x(), for member field named x)
!! return copies of the member variables unless explicitly noted.
+ procedure :: size_file_varlist
procedure :: get_file_fname
procedure :: get_file_frequnit
procedure :: get_file_freq
@@ -197,9 +199,11 @@ module fms_diag_yaml_mod
type diagYamlObject_type
character(len=:), allocatable, private :: diag_title !< Experiment name
integer, private, dimension (basedate_size) :: diag_basedate !< basedate array
- type(diagYamlFiles_type), allocatable, private, dimension (:) :: diag_files!< History file info
+ type(diagYamlFiles_type), allocatable, public, dimension (:) :: diag_files!< History file info
type(diagYamlFilesVar_type), allocatable, private, dimension (:) :: diag_fields !< Diag fields info
contains
+ procedure :: size_diag_files
+
procedure :: get_title !< Returns the title
procedure :: get_basedate !< Returns the basedate array
procedure :: get_diag_files !< Returns the diag_files array
@@ -212,7 +216,7 @@ module fms_diag_yaml_mod
end type diagYamlObject_type
-type (diagYamlObject_type) :: diag_yaml !< Obj containing the contents of the diag_table.yaml
+type (diagYamlObject_type), target :: diag_yaml !< Obj containing the contents of the diag_table.yaml
type (varList_type), save :: variable_list !< List of all the variables in the diag_table.yaml
type (fileList_type), save :: file_list !< List of all files in the diag_table.yaml
@@ -239,6 +243,17 @@ pure function get_basedate (diag_yaml) &
diag_basedate = diag_yaml%diag_basedate
end function get_basedate
+!> @brief Find the number of files listed in the diag yaml
+!! @return the number of files in the diag yaml
+pure integer function size_diag_files(diag_yaml)
+ class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
+ if (diag_yaml%has_diag_files()) then
+ size_diag_files = size(diag_yaml%diag_files)
+ else
+ size_diag_files = 0
+ endif
+end function size_diag_files
+
!> @brief get the title of a diag_yaml type
!! @return the title of the diag table as an allocated string
pure function get_title (diag_yaml) &
@@ -740,6 +755,13 @@ pure function is_valid_time_units(time_units) &
end function is_valid_time_units
!!!!!!! YAML FILE INQUIRIES !!!!!!!
+!> @brief Finds the number of variables in the file_varlist
+!! @return the size of the diag_files_obj%file_varlist array
+integer pure function size_file_varlist (diag_files_obj)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ size_file_varlist = size(diag_files_obj%file_varlist)
+end function size_file_varlist
+
!> @brief Inquiry for diag_files_obj%file_fname
!! @return file_fname of a diag_yaml_file obj
pure function get_file_fname (diag_files_obj) &
From 443ad0e69482987b47a39f0aa57bb5e1cdcac24b Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 1 Jun 2022 12:50:53 -0400
Subject: [PATCH 049/168] feat: Diag_axis_init set up (#978)
---
diag_manager/Makefile.am | 2 +-
diag_manager/diag_axis.F90 | 9 +-
diag_manager/diag_manager.F90 | 5 +-
diag_manager/fms_diag_axis_object.F90 | 135 ++++++++++++--
test_fms/diag_manager/Makefile.am | 3 +-
test_fms/diag_manager/test_diag_manager2.sh | 69 ++++++++
test_fms/diag_manager/test_modern_diag.F90 | 187 ++++++++++++++++++++
7 files changed, 393 insertions(+), 17 deletions(-)
create mode 100644 test_fms/diag_manager/test_modern_diag.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 30ada40f19..cd5408d069 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -54,7 +54,7 @@ libdiag_manager_la_SOURCES = \
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
-diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
+diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT)
diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT)
diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \
diag_grid_mod.$(FC_MODEXT)
diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90
index deda28faef..9efcccba34 100644
--- a/diag_manager/diag_axis.F90
+++ b/diag_manager/diag_axis.F90
@@ -39,7 +39,8 @@ MODULE diag_axis_mod
& fms_error_handler, FATAL, NOTE
USE diag_data_mod, ONLY: diag_axis_type, max_subaxes, max_axes,&
& max_num_axis_sets, max_axis_attributes, debug_diag_manager,&
- & first_send_data_call, diag_atttype
+ & first_send_data_call, diag_atttype, use_modern_diag
+ USE fms_diag_axis_object_mod, ONLY: fms_diag_axis_init
USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR
IMPLICIT NONE
@@ -134,6 +135,12 @@ INTEGER FUNCTION diag_axis_init(name, array_data, units, cart_name, long_name, d
CALL write_version_number("DIAG_AXIS_MOD", version)
ENDIF
+ if (use_modern_diag) then
+ diag_axis_init = fms_diag_axis_init(name, DATA, units, cart_name, long_name=long_name, direction=direction,&
+ & set_name=set_name, edges=edges, Domain=Domain, Domain2=Domain2, DomainU=DomainU, aux=aux, req=req, &
+ & tile_count=tile_count, domain_position=domain_position )
+ return
+ endif
IF ( PRESENT(tile_count)) THEN
tile = tile_count
ELSE
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 5f5e2d9472..5bc455ee56 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -241,6 +241,7 @@ MODULE diag_manager_mod
USE fms_diag_file_object_mod, only: fms_diag_files_object_initialized
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field
+ use fms_diag_axis_object_mod, only: fms_diag_axis_object_end, fms_diag_axis_object_init
use fms_diag_file_object_mod, only: fms_diag_files_object_init
#endif
@@ -3858,6 +3859,7 @@ SUBROUTINE diag_manager_end(time)
#ifdef use_yaml
if (use_modern_diag) then
call diag_yaml_object_end
+ call fms_diag_axis_object_end()
if (allocated(diag_objs)) deallocate(diag_objs)
endif
#endif
@@ -4074,6 +4076,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
#ifdef use_yaml
if (use_modern_diag) then
CALL diag_yaml_object_init(diag_subset_output)
+ CALL fms_diag_axis_object_init()
allocate(diag_objs(get_num_unique_fields()))
registered_variables = 0
fms_diag_files_object_initialized = fms_diag_files_object_init ()
@@ -4107,7 +4110,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
module_is_initialized = .TRUE.
! create axis_id for scalars here
- null_axis_id = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none')
+ if(.not. use_modern_diag) null_axis_id = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none')
RETURN
END SUBROUTINE diag_manager_init
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 615551d801..8b3ffef3f9 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -29,15 +29,16 @@
!> @{
module fms_diag_axis_object_mod
use mpp_domains_mod, only: domain1d, domain2d, domainUG, mpp_get_compute_domain, CENTER, &
- & mpp_get_compute_domain
+ & mpp_get_compute_domain, NORTH, EAST
use platform_mod, only: r8_kind, r4_kind
- use diag_data_mod, only: diag_atttype
- use mpp_mod, only: FATAL, mpp_error
+ use diag_data_mod, only: diag_atttype, max_axes
+ use mpp_mod, only: FATAL, mpp_error, uppercase
implicit none
PRIVATE
- public :: diagAxis_t, diag_axis_init, set_subaxis
+ public :: diagAxis_t, set_subaxis, fms_diag_axis_init, fms_diag_axis_object_init, fms_diag_axis_object_end
+ public :: axis_obj
!> @}
!> @brief Type to hold the domain info for an axis
@@ -97,11 +98,11 @@ module fms_diag_axis_object_mod
INTEGER , private :: tile_count !< The number of tiles
TYPE(diag_atttype),allocatable , private :: attributes(:) !< Array to hold user definable attributes
INTEGER , private :: num_attributes !< Number of defined attibutes
- INTEGER , private :: domain_position !< The position in the doman (NORTH or EAST or CENTER)
+ INTEGER , private :: domain_position !< The position in the doman (NORTH, EAST or CENTER)
contains
- PROCEDURE :: register => diag_axis_init
+ PROCEDURE :: register => register_diag_axis_obj
PROCEDURE :: axis_length => get_axis_length
PROCEDURE :: set_subaxis
@@ -112,13 +113,17 @@ module fms_diag_axis_object_mod
! Get/has/is subroutines as needed
END TYPE diagAxis_t
+ integer :: number_of_axis !< Number of axis that has been registered
+ type(diagAxis_t), ALLOCATABLE, TARGET :: axis_obj(:) !< Diag_axis objects
+ logical :: module_is_initialized !< Flag indicating if the module is initialized
+
!> @addtogroup fms_diag_yaml_mod
!> @{
contains
!!!!!!!!!!!!!!!!! DIAG AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Initialize the axis
- subroutine diag_axis_init(obj, axis_name, axis_data, units, cart_name, long_name, direction,&
+ subroutine register_diag_axis_obj(obj, axis_name, axis_data, units, cart_name, long_name, direction,&
& set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position )
class(diagAxis_t), INTENT(out) :: obj !< Diag_axis obj
CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
@@ -140,7 +145,9 @@ subroutine diag_axis_init(obj, axis_name, axis_data, units, cart_name, long_name
obj%axis_name = trim(axis_name)
obj%units = trim(units)
- obj%cart_name = trim(cart_name) !< TO DO Check for valid cart_names
+ obj%cart_name = uppercase(cart_name)
+ call check_if_valid_cart_name(obj%cart_name)
+
if (present(long_name)) obj%long_name = trim(long_name)
select type (axis_data)
@@ -155,11 +162,16 @@ subroutine diag_axis_init(obj, axis_name, axis_data, units, cart_name, long_name
& Currently only r4 and r8 data is supported.")
end select
- !< TO DO check the presence of multiple Domains
if (present(Domain)) then
+ if (present(Domain2) .or. present(DomainU)) call mpp_error(FATAL, &
+ "The presence of Domain with any other domain type is prohibited. "//&
+ "Check you diag_axis_init call for axis_name:"//trim(axis_name))
allocate(diagDomain1d_t :: obj%axis_domain)
call obj%axis_domain%set(Domain=Domain)
else if (present(Domain2)) then
+ if (present(DomainU)) call mpp_error(FATAL, &
+ "The presence of Domain2 with any other domain type is prohibited. "//&
+ "Check you diag_axis_init call for axis_name:"//trim(axis_name))
allocate(diagDomain2d_t :: obj%axis_domain)
call obj%axis_domain%set(Domain2=Domain2)
else if (present(DomainU)) then
@@ -170,25 +182,25 @@ subroutine diag_axis_init(obj, axis_name, axis_data, units, cart_name, long_name
obj%tile_count = 1
if (present(tile_count)) obj%tile_count = tile_count
- !< TO DO Check for valid domain_position
obj%domain_position = CENTER
if (present(domain_position)) obj%domain_position = domain_position
+ call check_if_valid_domain_position(obj%domain_position)
obj%length = size(axis_data)
- !< TO DO Check for valid direction
obj%direction = 0
if (present(direction)) obj%direction = direction
+ call check_if_valid_direction(obj%direction)
- !< TO DO Check if id is valid and with the same parameters
obj%edges = 0
if (present(edges)) obj%edges = edges
+ call check_if_valid_edges(obj%edges)
if (present(aux)) obj%aux = trim(aux)
if (present(req)) obj%req = trim(req)
obj%nsubaxis = 0
- end subroutine diag_axis_init
+ end subroutine register_diag_axis_obj
!> @brief Get the length of the axis
!> @return axis length
@@ -275,6 +287,103 @@ subroutine set_axis_domain(obj, Domain, Domain2, DomainU)
end select
end subroutine set_axis_domain
+ subroutine fms_diag_axis_object_init()
+
+ if (module_is_initialized) return
+
+ number_of_axis = 0
+ allocate(axis_obj(max_axes))
+
+ module_is_initialized = .true.
+ end subroutine fms_diag_axis_object_init
+
+ subroutine fms_diag_axis_object_end()
+ deallocate(axis_obj)
+
+ module_is_initialized = .false.
+ end subroutine fms_diag_axis_object_end
+
+ !> @brief Wrapper for the register_diag_axis subroutine. This is needed to keep the diag_axis_init
+ !! interface the same
+ !> @return Axis id
+ FUNCTION fms_diag_axis_init(axis_name, axis_data, units, cart_name, long_name, direction,&
+ & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position ) &
+ & result(id)
+
+ CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
+ REAL, INTENT(in) :: axis_data(:) !< Array of coordinate values
+ CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
+ CHARACTER(len=1), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", "U", "N")
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name !< Name of the parent axis, if it is a subaxis
+ INTEGER, INTENT(in), OPTIONAL :: direction !< Indicates the direction of the axis
+ INTEGER, INTENT(in), OPTIONAL :: edges !< Axis ID for the previously defined "edges axis"
+ TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1D domain
+ TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2D domain
+ TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: aux !< Auxiliary name, can only be geolon_t
+ !! or geolat_t
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: req !< Required field names.
+ INTEGER, INTENT(in), OPTIONAL :: tile_count !< Number of tiles
+ INTEGER, INTENT(in), OPTIONAL :: domain_position !< Domain position, "NORTH" or "EAST"
+ integer :: id
+
+ number_of_axis = number_of_axis + 1
+
+ if (number_of_axis > max_axes) call mpp_error(FATAL, &
+ &"diag_axis_init: max_axes exceeded, increase via diag_manager_nml")
+
+ call axis_obj(number_of_axis)%register(axis_name, axis_data, units, cart_name, long_name=long_name, &
+ & direction=direction, set_name=set_name, edges=edges, Domain=Domain, Domain2=Domain2, DomainU=DomainU, aux=aux, &
+ & req=req, tile_count=tile_count, domain_position=domain_position)
+
+ id = number_of_axis
+ end function
+
+ !> @brief Check if a cart_name is valid and crashes if it isn't
+ subroutine check_if_valid_cart_name(cart_name)
+ character(len=*), intent(in) :: cart_name
+
+ select case (cart_name)
+ case ("X", "Y", "Z", "T", "U", "N")
+ case default
+ call mpp_error(FATAL, "diag_axit_init: Invalid cart_name: "//cart_name//&
+ "The acceptable values are X, Y, Z, T, U, N.")
+ end select
+ end subroutine check_if_valid_cart_name
+
+ !> @brief Check if a domain_position is valid and crashes if it isn't
+ subroutine check_if_valid_domain_position(domain_position)
+ integer, INTENT(IN) :: domain_position
+
+ select case (domain_position)
+ case (CENTER, NORTH, EAST)
+ case default
+ call mpp_error(FATAL, "diag_axit_init: Invalid domain_positon. "&
+ "The acceptable values are NORTH, EAST, CENTER")
+ end select
+ end subroutine check_if_valid_domain_position
+
+ !> @brief Check if a direction is valid and crashes if it isn't
+ subroutine check_if_valid_direction(direction)
+ integer, INTENT(IN) :: direction
+
+ select case(direction)
+ case(-1, 0, 1)
+ case default
+ call mpp_error(FATAL, "diag_axit_init: Invalid direction. "&
+ "The acceptable values are-1 0 1")
+ end select
+ end subroutine check_if_valid_direction
+
+ !> @brief Check if the edges id is valid and crashes if it isn't
+ subroutine check_if_valid_edges(edges)
+ integer, INTENT(IN) :: edges
+
+ if (edges < 0 .or. edges > number_of_axis) &
+ call mpp_error(FATAL, "diag_axit_init: The edge axis has not been defined. "&
+ "Call diag_axis_init for the edge axis first")
+ end subroutine check_if_valid_edges
end module fms_diag_axis_object_mod
!> @}
! close documentation grouping
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index ed255c665f..d2262129d4 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -30,7 +30,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
# Build this test program.
check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_object_container \
test_diag_update_buffer test_diag_dlinked_list \
- test_diag_yaml test_diag_ocean
+ test_diag_yaml test_diag_ocean test_modern_diag
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -40,6 +40,7 @@ test_diag_yaml_SOURCES = test_diag_yaml.F90
test_diag_object_container_SOURCES = test_diag_object_container.F90
test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90
test_diag_ocean_SOURCES = test_diag_ocean.F90
+test_modern_diag_SOURCES = test_modern_diag.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index b3319d269d..40cff2c612 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -648,4 +648,73 @@ test_expect_success "test_diag_dlinked_list (test $my_test_count)" '
mpirun -n 1 ../test_diag_dlinked_list
'
+printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml
+cat <<_EOF > diag_table.yaml
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+
+diag_files:
+- file_name: file1
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ output_name: potato
+ reduction: average
+ kind: r4
+- file_name: file2
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: atm_mod
+ var_name: var3
+ reduction: average
+ kind: r4
+ - module: atm_mod
+ var_name: var4
+ output_name: i_on_a_sphere
+ reduction: average
+ kind: r8
+ - module: atm_mod
+ var_name: var6
+ reduction: average
+ kind: r8
+- file_name: file3
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: lnd_mod
+ var_name: var5
+ reduction: average
+ kind: r4
+ - module: lnd_mod
+ var_name: var7
+ reduction: average
+ kind: r4
+- file_name: file4
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: lnd_mod
+ var_name: var6
+ reduction: average
+ kind: r4
+_EOF
+
+test_expect_success "Test the modern diag manager end to end (test $my_test_count)" '
+ mpirun -n 6 ../test_modern_diag
+'
test_done
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
new file mode 100644
index 0000000000..79f4c58ca2
--- /dev/null
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -0,0 +1,187 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This programs tests the modern diag_manager
+
+program test_modern_diag
+#ifdef use_yaml
+use mpp_domains_mod, only: domain2d, mpp_domains_set_stack_size, mpp_define_domains, mpp_define_io_domain, &
+ mpp_define_mosaic, domainug, mpp_get_compute_domains, mpp_define_unstruct_domain, &
+ mpp_get_compute_domain, mpp_get_data_domain, mpp_get_UG_domain_grid_index, &
+ mpp_get_UG_compute_domain
+use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field
+use fms_mod, only: fms_init, fms_end
+use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast
+use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time
+
+implicit none
+
+type(time_type) :: Time !< Time of the simulation
+integer, dimension(2) :: layout !< Layout to use when setting up the domain
+integer, dimension(2) :: io_layout !< io layout to use when setting up the io domain
+integer :: nx !< Number of x points
+integer :: ny !< Number of y points
+integer :: nz !< Number of z points
+integer :: ug_dim_size !< Number of points in the UG
+type(domain2d) :: Domain !< 2D domain
+type(domain2d) :: Domain_cube_sph !< cube sphere domain
+type(domainug) :: land_domain !< Unstructured domain
+real, dimension(:), allocatable:: x !< X axis data
+real, dimension(:), allocatable:: y !< Y axis_data
+real, dimension(:), allocatable:: z !< Z axis_data
+integer, dimension(:), allocatable:: ug_dim_data !< UG axis_data
+integer :: i !< For do loops
+integer :: id_x !< axis id for the x dimension
+integer :: id_x3 !< axis id for the x dimension in the cube sphere domain
+integer :: id_y !< axis id for the y dimension
+integer :: id_y3 !< axis id for the y dimension in the cube sphere domain
+integer :: id_UG !< axis id for the unstructured dimension
+integer :: id_z !< axis id for the z dimention
+integer :: id_var1 !< diag_field id for var in lon/lat grid
+integer :: id_var2 !< diag_field id for var in lat/lon grid
+integer :: id_var3 !< diag_field id for var in cube sphere grid
+integer :: id_var4 !< diag_field id for 3d var in cube sphere grid
+integer :: id_var5 !< diag_field id for var in UG grid
+integer :: id_var6 !< diag_field id for var that is not domain decomposed
+integer :: id_var7 !< Scalar var
+
+call fms_init
+call set_calendar_type(JULIAN)
+call diag_manager_init
+
+nx = 96
+ny = 96
+nz = 5
+layout = (/1, mpp_npes()/)
+io_layout = (/1, 1/)
+
+!> Set up a normal (lat/lon) 2D domain, a cube sphere, and UG domain
+call set_up_2D_domain(domain, layout, nx, ny, io_layout)
+call set_up_cube_sph_domain(Domain_cube_sph, nx, ny, io_layout)
+call create_land_domain(Domain_cube_sph, nx, ny, 6, land_domain, npes_group=1)
+call mpp_get_UG_compute_domain(land_domain, size=ug_dim_size)
+
+! Set up the data
+allocate(x(nx), y(ny), z(nz))
+do i=1,nx
+ x(i) = i
+enddo
+do i=1,ny
+ y(i) = i
+enddo
+do i=1,nz
+ z(i) = i
+enddo
+
+allocate(ug_dim_data(ug_dim_size))
+call mpp_get_UG_domain_grid_index(land_domain, ug_dim_data)
+ug_dim_data = ug_dim_data - 1
+
+! Set up the intial time
+Time = set_date(2,1,1,0,0,0)
+
+! Register the diags axis
+id_x = diag_axis_init('x', x, 'point_E', 'x', long_name='point_E', Domain2=Domain)
+id_y = diag_axis_init('y', y, 'point_N', 'y', long_name='point_N', Domain2=Domain)
+
+id_x3 = diag_axis_init('x3', x, 'point_E', 'x', Domain2=Domain_cube_sph)
+id_y3 = diag_axis_init('y3', y, 'point_E', 'y', Domain2=Domain_cube_sph)
+
+id_ug = diag_axis_init("grid_index", real(ug_dim_data), "none", "U", long_name="grid indices", &
+ set_name="land", DomainU=land_domain, aux="geolon_t geolat_t")
+
+id_z = diag_axis_init('z', z, 'point_Z', 'z', long_name='point_Z')
+
+if (id_x .ne. 1) call mpp_error(FATAL, "The x axis does not have the expected id")
+if (id_y .ne. 2) call mpp_error(FATAL, "The y axis does not have the expected id")
+if (id_x3 .ne. 3) call mpp_error(FATAL, "The x3 axis does not have the expected id")
+if (id_y3 .ne. 4) call mpp_error(FATAL, "The y3 axis does not have the expected id")
+if (id_ug .ne. 5) call mpp_error(FATAL, "The ug axis does not have the expected id")
+if (id_z .ne. 6) call mpp_error(FATAL, "The z axis does not have the expected id")
+
+! Register the variables
+id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x, id_y/), Time, 'Var in a lon/lat domain', 'mullions')
+id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_y, id_x/), Time, &
+ 'Var in a lon/lat domain with flipped dimensions', 'mullions')
+id_var3 = register_diag_field ('atm_mod', 'var3', (/id_x3, id_y3/), Time, 'Var in a cube sphere domain', 'mullions')
+id_var4 = register_diag_field ('atm_mod', 'var4', (/id_x3, id_y3, id_z/), Time, &
+ '3D var in a cube sphere domain', 'mullions')
+id_var5 = register_diag_field ('lnd_mod', 'var5', (/id_ug/), Time, 'Var in a UG domain', 'mullions')
+id_var6 = register_diag_field ('lnd_mod', 'var6', (/id_z/), Time, 'Var not domain decomposed', 'mullions')
+id_var7 = register_diag_field ('lnd_mod', 'var7', Time, 'Some scalar var', 'mullions')
+
+if (id_var1 .ne. 1) call mpp_error(FATAL, "var1 does not have the expected id")
+if (id_var2 .ne. 2) call mpp_error(FATAL, "var2 does not have the expected id")
+if (id_var3 .ne. 3) call mpp_error(FATAL, "var3 does not have the expected id")
+if (id_var4 .ne. 4) call mpp_error(FATAL, "var4 does not have the expected id")
+if (id_var5 .ne. 5) call mpp_error(FATAL, "var5 does not have the expected id")
+if (id_var6 .ne. 6) call mpp_error(FATAL, "var6 does not have the expected id")
+if (id_var7 .ne. 7) call mpp_error(FATAL, "var7 does not have the expected id")
+
+call diag_manager_end(Time)
+call fms_end
+
+contains
+
+include "../fms2_io/create_atmosphere_domain.inc"
+include "../fms2_io/create_land_domain.inc"
+
+subroutine set_up_2D_domain(Domain, layout, nx, ny, io_layout)
+ type(domain2d), intent(out) :: Domain !< 2D domain
+ integer, intent(in) :: layout(:) !< Layout to use when setting up the domain
+ integer, intent(in) :: nx !< Number of x points
+ integer, intent(in) :: ny !< Number of y points
+ integer, intent(in) :: io_layout(:) !< Io layout to use when setting up the io_domain
+
+ call mpp_domains_set_stack_size(17280000)
+ call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain')
+ call mpp_define_io_domain(Domain, io_layout)
+end subroutine set_up_2D_domain
+
+subroutine set_up_cube_sph_domain(Domain_cube_sph, nx, ny, io_layout)
+ type(domain2d), intent(out) :: Domain_cube_sph !< 2D domain
+ integer, intent(in) :: nx !< Number of x points
+ integer, intent(in) :: ny !< Number of y points
+ integer, intent(in) :: io_layout(:) !< Io layout to use when setting up the io_domain
+
+ integer :: i !< For do loops
+ integer :: npes !< Number of pes
+ integer, parameter :: ntiles=6 !< Number of tiles
+ integer, dimension(4,ntiles) :: global_indices !< The global indices of each tile
+ integer, dimension(2,ntiles) :: layout !< The layout of each tile
+ integer, dimension(ntiles) :: pe_start !< The starting PE of each tile
+ integer, dimension(ntiles) :: pe_end !< The ending PE of eeach tile
+
+ npes = mpp_npes()
+
+ !< Create the domain
+ do i = 1,ntiles
+ global_indices(:, i) = (/1, ny, 1, ny/)
+ layout(:, i) = (/1, npes/ntiles/)
+ pe_start(i) = (i-1)*(npes/ntiles)
+ pe_end(i) = i*(npes/ntiles) - 1
+ end do
+
+ call create_atmosphere_domain((/nx, nx, nx, nx, nx, nx/), &
+ (/ny, ny, ny, ny, ny, ny/), &
+ global_indices, layout, pe_start, pe_end, &
+ io_layout, Domain_cube_sph)
+end subroutine set_up_cube_sph_domain
+#endif
+end program test_modern_diag
From 0b90ed2edec024c2b34da2189cbcdc4684615888 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 3 Jun 2022 08:27:36 -0400
Subject: [PATCH 050/168] feat: modern diag add io routines for diag_axis
object (#982)
---
diag_manager/diag_data.F90 | 5 +
diag_manager/fms_diag_axis_object.F90 | 144 ++++++++++++++++++++++++--
diag_manager/fms_diag_object.F90 | 11 ++
3 files changed, 154 insertions(+), 6 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index d8f533b67c..e3790b796e 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -97,6 +97,11 @@ MODULE diag_data_mod
INTEGER, PARAMETER :: DIAG_SECONDS = 1, DIAG_MINUTES = 2, DIAG_HOURS = 3
INTEGER, PARAMETER :: DIAG_DAYS = 4, DIAG_MONTHS = 5, DIAG_YEARS = 6
INTEGER, PARAMETER :: MAX_SUBAXES = 10
+ INTEGER, PARAMETER :: NO_DOMAIN = 1 !< Use the FmsNetcdfFile_t fileobj
+ INTEGER, PARAMETER :: TWO_D_DOMAIN = 2 !< Use the FmsNetcdfDomainFile_t fileobj
+ INTEGER, PARAMETER :: UG_DOMAIN = 3 !< Use the FmsNetcdfUnstructuredDomainFile_t fileobj
+ INTEGER, PARAMETER :: DIRECTION_UP = 1 !< The axis points up if positive
+ INTEGER, PARAMETER :: DIRECTION_DOWN = -1 !< The axis points down if positive
INTEGER, PARAMETER :: GLO_REG_VAL = -999 !< Value used in the region specification of the diag_table
!! to indicate to use the full axis instead of a sub-axis
INTEGER, PARAMETER :: GLO_REG_VAL_ALT = -1 !< Alternate value used in the region specification of the
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 8b3ffef3f9..adfc009466 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -31,14 +31,17 @@ module fms_diag_axis_object_mod
use mpp_domains_mod, only: domain1d, domain2d, domainUG, mpp_get_compute_domain, CENTER, &
& mpp_get_compute_domain, NORTH, EAST
use platform_mod, only: r8_kind, r4_kind
- use diag_data_mod, only: diag_atttype, max_axes
+ use diag_data_mod, only: diag_atttype, max_axes, NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, &
+ direction_down, direction_up
use mpp_mod, only: FATAL, mpp_error, uppercase
+ use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, &
+ & register_axis, register_field, register_variable_attribute, write_data
implicit none
PRIVATE
- public :: diagAxis_t, set_subaxis, fms_diag_axis_init, fms_diag_axis_object_init, fms_diag_axis_object_end
- public :: axis_obj
+ public :: diagAxis_t, set_subaxis, fms_diag_axis_init, fms_diag_axis_object_init, fms_diag_axis_object_end, &
+ & get_domain_and_domain_type, axis_obj
!> @}
!> @brief Type to hold the domain info for an axis
@@ -85,10 +88,13 @@ module fms_diag_axis_object_mod
CHARACTER(len=:), ALLOCATABLE, private :: long_name !< Long_name attribute of the axis
CHARACTER(len=1) , private :: cart_name !< Cartesian name "X", "Y", "Z", "T", "U", "N"
CLASS(*), ALLOCATABLE, private :: axis_data(:) !< Data of the axis
+ CHARACTER(len=:), ALLOCATABLE, private :: type_of_data !< The type of the axis_data ("float" or "double")
!< TO DO this can be a dlinked to avoid having limits
type(subaxis_t) , private :: subaxis(3) !< Array of subaxis
integer , private :: nsubaxis !< Number of subaxis
class(diagDomain_t),ALLOCATABLE, private :: axis_domain !< Domain
+ INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN", "TWO_D_DOMAIN",
+ !! or "UG_DOMAIN")
INTEGER , private :: length !< Global axis length
INTEGER , private :: direction !< Direction of the axis 0, 1, -1
INTEGER , private :: edges !< Axis ID for the previously defined "edges axis"
@@ -105,11 +111,10 @@ module fms_diag_axis_object_mod
PROCEDURE :: register => register_diag_axis_obj
PROCEDURE :: axis_length => get_axis_length
PROCEDURE :: set_subaxis
+ PROCEDURE :: write_axis_metadata
+ PROCEDURE :: write_axis_data
! TO DO:
- ! PROCEDURE :: write_axis_metadata
- ! PROCEDURE :: write_axis_data
- ! PROCEDURE :: get_fileobj_type_needed (use the domain to figure out what fms2 fileobj to use)
! Get/has/is subroutines as needed
END TYPE diagAxis_t
@@ -154,14 +159,17 @@ subroutine register_diag_axis_obj(obj, axis_name, axis_data, units, cart_name, l
type is (real(kind=r8_kind))
allocate(real(kind=r8_kind) :: obj%axis_data(size(axis_data)))
obj%axis_data = axis_data
+ obj%type_of_data = "double" !< This is what fms2_io expects in the register_field call
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: obj%axis_data(size(axis_data)))
obj%axis_data = axis_data
+ obj%type_of_data = "float" !< This is what fms2_io expects in the register_field call
class default
call mpp_error(FATAL, "The axis_data in your diag_axis_init call is not a supported type. &
& Currently only r4 and r8 data is supported.")
end select
+ obj%type_of_domain = NO_DOMAIN
if (present(Domain)) then
if (present(Domain2) .or. present(DomainU)) call mpp_error(FATAL, &
"The presence of Domain with any other domain type is prohibited. "//&
@@ -174,9 +182,11 @@ subroutine register_diag_axis_obj(obj, axis_name, axis_data, units, cart_name, l
"Check you diag_axis_init call for axis_name:"//trim(axis_name))
allocate(diagDomain2d_t :: obj%axis_domain)
call obj%axis_domain%set(Domain2=Domain2)
+ obj%type_of_domain = TWO_D_DOMAIN
else if (present(DomainU)) then
allocate(diagDomainUg_t :: obj%axis_domain)
call obj%axis_domain%set(DomainU=DomainU)
+ obj%type_of_domain = UG_DOMAIN
endif
obj%tile_count = 1
@@ -202,6 +212,96 @@ subroutine register_diag_axis_obj(obj, axis_name, axis_data, units, cart_name, l
obj%nsubaxis = 0
end subroutine register_diag_axis_obj
+ !> @brief Write the axis meta data to an open fileobj
+ subroutine write_axis_metadata(obj, fileobj, sub_axis_id)
+ class(diagAxis_t), target, INTENT(IN) :: obj !< diag_axis obj
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
+ integer, OPTIONAL, INTENT(IN) :: sub_axis_id !< ID of the sub_axis, if it exists
+
+ character(len=:), ALLOCATABLE :: axis_edges_name !< Name of the edges, if it exist
+ character(len=:), pointer :: axis_name !< Name of the axis
+ integer :: axis_length !< Size of the axis
+
+ if (present(sub_axis_id)) then
+ axis_name => obj%subaxis(sub_axis_id)%subaxis_name
+ axis_length = obj%subaxis(sub_axis_id)%ending_index - obj%subaxis(sub_axis_id)%starting_index + 1
+ else
+ axis_name => obj%axis_name
+ axis_length = obj%length
+ endif
+
+ !< Add the axis as a dimension in the netcdf file based on the type of axis_domain and the fileobj type
+ select type (fileobj)
+ type is (FmsNetcdfFile_t)
+ !< Here the axis is not domain decomposed (i.e z_axis)
+ call register_axis(fileobj, axis_name, axis_length)
+ type is (FmsNetcdfDomainFile_t)
+ select case (obj%type_of_domain)
+ case (NO_DOMAIN)
+ !< Here the fileobj is domain decomposed, but the axis is not
+ !! Domain decomposed fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
+ call register_axis(fileobj, axis_name, axis_length)
+ case (TWO_D_DOMAIN)
+ !< Here the axis is domain decomposed
+ call register_axis(fileobj, axis_name, obj%cart_name, domain_position=obj%domain_position)
+ end select
+ type is (FmsNetcdfUnstructuredDomainFile_t)
+ select case (obj%type_of_domain)
+ case (NO_DOMAIN)
+ !< Here the fileobj is in the unstructured domain, but the axis is not
+ !< Unstructured domain fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
+ call register_axis(fileobj, axis_name, axis_length)
+ case (UG_DOMAIN)
+ !< Here the axis is in a unstructured domain
+ call register_axis(fileobj, axis_name)
+ end select
+ end select
+
+ !< Add the axis as a variable and write its metada
+ call register_field(fileobj, axis_name, obj%type_of_data, (/axis_name/))
+ call register_variable_attribute(fileobj, axis_name, "longname", obj%long_name, &
+ str_len=len_trim(obj%long_name))
+
+ if (obj%cart_name .NE. "N") &
+ call register_variable_attribute(fileobj, axis_name, "axis", obj%cart_name, str_len=1)
+
+ if (trim(obj%units) .NE. "none") &
+ call register_variable_attribute(fileobj, axis_name, "units", obj%units, str_len=len_trim(obj%units))
+
+ select case (obj%direction)
+ case (direction_up)
+ call register_variable_attribute(fileobj, axis_name, "positive", "up", str_len=2)
+ case (direction_down)
+ call register_variable_attribute(fileobj, axis_name, "positive", "down", str_len=4)
+ end select
+
+ if (obj%edges > 0) then
+ axis_edges_name = axis_obj(obj%edges)%axis_name
+ call register_variable_attribute(fileobj, axis_name, "edges", axis_edges_name, &
+ str_len=len_trim(axis_edges_name))
+ endif
+
+ end subroutine write_axis_metadata
+
+ !> @brief Write the axis data to an open fileobj
+ subroutine write_axis_data(obj, fileobj, sub_axis_id)
+ class(diagAxis_t), INTENT(IN) :: obj !< diag_axis obj
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
+ integer, OPTIONAL, INTENT(IN) :: sub_axis_id !< ID of the sub_axis, if it exists
+
+ integer :: i !< Starting index of a sub_axis
+ integer :: j !< Ending index of a sub_axis
+
+ if (present(sub_axis_id)) then
+ i = obj%subaxis(sub_axis_id)%starting_index
+ j = obj%subaxis(sub_axis_id)%ending_index
+
+ call write_data(fileobj, obj%subaxis(sub_axis_id)%subaxis_name, obj%axis_data(i:j))
+ else
+ call write_data(fileobj, obj%axis_name, obj%axis_data)
+ endif
+ end subroutine write_axis_data
+
!> @brief Get the length of the axis
!> @return axis length
function get_axis_length(obj) &
@@ -384,6 +484,38 @@ subroutine check_if_valid_edges(edges)
call mpp_error(FATAL, "diag_axit_init: The edge axis has not been defined. "&
"Call diag_axis_init for the edge axis first")
end subroutine check_if_valid_edges
+
+ !> @brief Loop through a variable's axis_id to determine and return the domain type and domain to use
+ subroutine get_domain_and_domain_type(axis_id, domain_type, domain, var_name)
+ integer, INTENT(IN) :: axis_id(:) !< Array of axis ids
+ integer, INTENT(OUT) :: domain_type !< fileobj_type to use
+ CLASS(diagDomain_t), POINTER, INTENT(OUT) :: domain !< Domain
+ character(len=*), INTENT(IN) :: var_name !< Name of the variable (for error messages)
+
+ integer :: i !< For do loops
+ integer :: j !< axis_id(i) (for less typing)
+
+ domain_type = NO_DOMAIN
+ domain => null()
+
+ do i = 1, size(axis_id)
+ j = axis_id(i)
+ !< Check that all the axis are in the same domain
+ if (domain_type .ne. axis_obj(j)%type_of_domain) then
+ !< If they are different domains, one of them can be NO_DOMAIN
+ !! i.e a variable can have axis that are domain decomposed (x,y) and an axis that isn't (z)
+ if (domain_type .eq. NO_DOMAIN .or. axis_obj(j)%type_of_domain .eq. NO_DOMAIN ) then
+ !< Update the domain_type and domain, if needed
+ if (axis_obj(j)%type_of_domain .eq. TWO_D_DOMAIN .or. axis_obj(j)%type_of_domain .eq. UG_DOMAIN) then
+ domain_type = axis_obj(j)%type_of_domain
+ domain => axis_obj(j)%axis_domain
+ endif
+ else
+ call mpp_error(FATAL, "The variable:"//trim(var_name)//" has axis that are not in the same domain")
+ endif
+ endif
+ enddo
+ end subroutine get_domain_and_domain_type
end module fms_diag_axis_object_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 7c814411a2..df9fc037c9 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -255,6 +255,17 @@ subroutine fms_register_diag_field_obj &
! return
! endif
+!> TO DO: Add all the info from the diag_axis obj
+!! axes will need to be changed to optional, so this subroutine can be used for both scalar and array fields
+!! the domain_type and domain will be need to added to the dobj
+! if (present(axes))
+! dobj%axes => axes ! or something
+! call get_domain_and_domain_type(dobj%axes, dobj%domain_type, dobj%domain, dobj%varname)
+ !! Send all the axes_info to the diag_files
+! else
+! dobj%domain_type = NO_DOMAIN
+! endif
+
!> get the optional arguments if included and the diagnostic is in the diag table
if (present(longname)) then
allocate(character(len=len(longname)) :: dobj%longname)
From 6a25b29b7ce190e53bcd8e9d70cc39d63b33c2e8 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 15 Jun 2022 14:19:48 -0400
Subject: [PATCH 051/168] feat: finish register diag field routines (#984)
---
diag_manager/diag_data.F90 | 1 +
diag_manager/diag_manager.F90 | 32 ++-
diag_manager/fms_diag_axis_object.F90 | 19 +-
diag_manager/fms_diag_file_object.F90 | 100 +++++++-
diag_manager/fms_diag_object.F90 | 269 ++++++++++----------
diag_manager/fms_diag_yaml.F90 | 29 ++-
test_fms/diag_manager/Makefile.am | 1 -
test_fms/diag_manager/test_diag_manager2.sh | 3 -
test_fms/diag_manager/test_diag_yaml.F90 | 10 +-
9 files changed, 280 insertions(+), 184 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index e3790b796e..0793e82984 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -100,6 +100,7 @@ MODULE diag_data_mod
INTEGER, PARAMETER :: NO_DOMAIN = 1 !< Use the FmsNetcdfFile_t fileobj
INTEGER, PARAMETER :: TWO_D_DOMAIN = 2 !< Use the FmsNetcdfDomainFile_t fileobj
INTEGER, PARAMETER :: UG_DOMAIN = 3 !< Use the FmsNetcdfUnstructuredDomainFile_t fileobj
+ INTEGER, PARAMETER :: SUB_REGIONAL = 4 !< This is a file with a sub_region use the FmsNetcdfFile_t fileobj
INTEGER, PARAMETER :: DIRECTION_UP = 1 !< The axis points up if positive
INTEGER, PARAMETER :: DIRECTION_DOWN = -1 !< The axis points down if positive
INTEGER, PARAMETER :: GLO_REG_VAL = -999 !< Value used in the region specification of the diag_table
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 5bc455ee56..14c088847c 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -473,21 +473,25 @@ INTEGER FUNCTION register_diag_field_scalar_modern(module_name, field_name, init
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
#ifdef use_yaml
- integer, allocatable :: diag_file_indices(:) !< indices where the field was found
+ integer, allocatable :: diag_field_indices(:) !< indices where the field was found
- diag_file_indices = find_diag_field(field_name)
- if (diag_file_indices(1) .eq. diag_null) then
+ diag_field_indices = find_diag_field(field_name)
+ if (diag_field_indices(1) .eq. diag_null) then
!< The field was not found in the table, so return diag_null
register_diag_field_scalar_modern = diag_null
- deallocate(diag_file_indices)
+ deallocate(diag_field_indices)
return
endif
registered_variables = registered_variables + 1
register_diag_field_scalar_modern = registered_variables
- !< TO DO: Fill in the diag_obj
- deallocate(diag_file_indices)
+ call diag_objs(registered_variables)%setID(registered_variables)
+ call diag_objs(registered_variables)%register(module_name, field_name, init_time, diag_field_indices, &
+ & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
+ & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
+ & area=area, volume=volume, realm=realm)
+ deallocate(diag_field_indices)
#endif
end function register_diag_field_scalar_modern
@@ -520,21 +524,25 @@ INTEGER FUNCTION register_diag_field_array_modern(module_name, field_name, axes,
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
#ifdef use_yaml
- integer, allocatable :: diag_file_indices(:) !< indices where the field was found
+ integer, allocatable :: diag_field_indices(:) !< indices of diag_field yaml where the field was found
- diag_file_indices = find_diag_field(field_name)
- if (diag_file_indices(1) .eq. diag_null) then
+ diag_field_indices = find_diag_field(field_name)
+ if (diag_field_indices(1) .eq. diag_null) then
!< The field was not found in the table, so return diag_null
register_diag_field_array_modern = diag_null
- deallocate(diag_file_indices)
+ deallocate(diag_field_indices)
return
endif
registered_variables = registered_variables + 1
register_diag_field_array_modern = registered_variables
- !< TO DO: Fill in the diag_obj
- deallocate(diag_file_indices)
+ call diag_objs(registered_variables)%setID(registered_variables)
+ call diag_objs(registered_variables)%register(module_name, field_name, init_time, diag_field_indices, axes, &
+ & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
+ & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
+ & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
+ deallocate(diag_field_indices)
#endif
end function register_diag_field_array_modern
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index adfc009466..6c27786e85 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -41,7 +41,7 @@ module fms_diag_axis_object_mod
PRIVATE
public :: diagAxis_t, set_subaxis, fms_diag_axis_init, fms_diag_axis_object_init, fms_diag_axis_object_end, &
- & get_domain_and_domain_type, axis_obj
+ & get_domain_and_domain_type, axis_obj, diagDomain_t, sub_axis_objs
!> @}
!> @brief Type to hold the domain info for an axis
@@ -76,6 +76,7 @@ module fms_diag_axis_object_mod
INTEGER :: starting_index !< Starting index of the subaxis relative to the parent axis
INTEGER :: ending_index !< Ending index of the subaxis relative to the parent axis
class(*) , ALLOCATABLE :: bounds !< Bounds of the subaxis (lat/lon or indices)
+ INTEGER :: parent_axis_id !< Id of the parent_axis
contains
procedure :: exists => check_if_subaxis_exists
END TYPE subaxis_t
@@ -121,6 +122,8 @@ module fms_diag_axis_object_mod
integer :: number_of_axis !< Number of axis that has been registered
type(diagAxis_t), ALLOCATABLE, TARGET :: axis_obj(:) !< Diag_axis objects
logical :: module_is_initialized !< Flag indicating if the module is initialized
+ integer :: nsubaxis_objs !< Number of sub_axis that has been registered
+ type(subaxis_t), ALLOCATABLE, Target :: sub_axis_objs(:) !< Registered sub_axis objects
!> @addtogroup fms_diag_yaml_mod
!> @{
@@ -319,10 +322,14 @@ function get_axis_length(obj) &
end function
!> @brief Set the subaxis of the axis obj
- subroutine set_subaxis(obj, bounds)
- class(diagAxis_t), INTENT(INOUT) :: obj !< diag_axis obj
+ !> @return A sub_axis id corresponding to the indices of the sub_axes in the sub_axes_objs array
+ function set_subaxis(obj, bounds) &
+ result(sub_axes_id)
+ class(diagAxis_t), INTENT(INOUT) :: obj !< diag_axis obj
class(*), INTENT(INOUT) :: bounds(:) !< bound of the subaxis
+ integer :: sub_axes_id
+
integer :: i !< For do loops
!< Check if the subaxis for this bouds already exists
@@ -332,7 +339,11 @@ subroutine set_subaxis(obj, bounds)
!< TO DO: everything
obj%nsubaxis = obj%nsubaxis + 1
- end subroutine
+
+ nsubaxis_objs = nsubaxis_objs + 1
+ sub_axes_id = nsubaxis_objs
+ !< TO DO: set the parent_axis_id
+ end function
!!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Check if a subaxis was already defined
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 45d6b45c45..d16f3055fc 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -26,11 +26,12 @@
module fms_diag_file_object_mod
!use mpp_mod, only: mpp_error, FATAL
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t
-use diag_data_mod, only: DIAG_NULL
+use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type
#endif
-
+use fms_diag_axis_object_mod, only: diagDomain_t
+use mpp_mod, only: mpp_error, FATAL
implicit none
private
@@ -44,10 +45,13 @@ module fms_diag_file_object_mod
private
integer :: id !< The number associated with this file in the larger array of files
class(FmsNetcdfFile_t), allocatable :: fileobj !< fms2_io file object for this history file
- character(len=1) :: file_domain_type !< (I don't think we will need this)
#ifdef use_yaml
type(diagYamlFiles_type), pointer :: diag_yaml_file => null() !< Pointer to the diag_yaml_file data
#endif
+ integer :: type_of_domain !< The type of domain to use to open the file
+ !! NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, SUB_REGIONAL
+ class(diagDomain_t), pointer :: domain !< The domain to use,
+ !! null if NO_DOMAIN or SUB_REGIONAL
character(len=:) , dimension(:), allocatable :: file_metadata_from_model !< File metadata that comes from
!! the model.
integer, dimension(:), allocatable :: var_ids !< Variable IDs corresponding to file_varlist
@@ -57,18 +61,21 @@ module fms_diag_file_object_mod
logical, dimension(:), private, allocatable :: var_reg !< Array corresponding to `file_varlist`, .true.
!! if the variable has been registered and
!! `file_var_index` has been set for the variable
+ integer, dimension(:), allocatable :: axis_ids !< Array of axis ids in the file
+ integer, dimension(:), allocatable :: sub_axis_ids !< Array of axis ids in the file
+ integer :: number_of_axis !< Number of axis in the file
contains
-
procedure, public :: has_file_metadata_from_model
procedure, public :: has_fileobj
#ifdef use_yaml
procedure, public :: has_diag_yaml_file
+ procedure, public :: set_file_domain
+ procedure, public :: add_axes
#endif
procedure, public :: has_var_ids
procedure, public :: get_id
! TODO procedure, public :: get_fileobj ! TODO
- procedure, public :: get_file_domain_type
! TODO procedure, public :: get_diag_yaml_file ! TODO
procedure, public :: get_file_metadata_from_model
procedure, public :: get_var_ids
@@ -128,6 +135,23 @@ logical function fms_diag_files_object_init ()
FMS_diag_files(i)%var_ids = DIAG_NULL
FMS_diag_files(i)%var_reg = .FALSE.
FMS_diag_files(i)%var_index = DIAG_NULL
+
+ !> These will be set in a set_file_domain
+ FMS_diag_files(i)%type_of_domain = NO_DOMAIN
+ FMS_diag_files(i)%domain => null()
+
+ !> This will be set in a add_axes
+ allocate(FMS_diag_files(i)%axis_ids(max_axes))
+
+ !> If the file has a sub_regional, define it as one and allocate the sub_axis_ids array.
+ !! This will be set in a add_axes
+ if (FMS_diag_files(i)%has_file_sub_region()) then
+ FMS_diag_files(i)%type_of_domain = SUB_REGIONAL
+ allocate(FMS_diag_files(i)%sub_axis_ids(max_axes))
+ FMS_diag_files(i)%sub_axis_ids = diag_null
+ endif
+
+ FMS_diag_files(i)%number_of_axis = 0
enddo set_ids_loop
fms_diag_files_object_init = .true.
else
@@ -181,13 +205,6 @@ end function get_id
! class(FmsNetcdfFile_t) :: res
! res = obj%fileobj
!end function get_fileobj
-!> \brief Returns a copy of the value of file_domain_type
-!! \return A copy of file_domain_type
-pure function get_file_domain_type (obj) result (res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
- character(1) :: res
- res = obj%file_domain_type
-end function get_file_domain_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! TODO
!!> \brief Returns a copy of the value of diag_yaml_file
@@ -399,5 +416,64 @@ pure function has_file_global_meta (obj) result(res)
logical :: res
res = obj%diag_yaml_file%has_file_global_meta()
end function has_file_global_meta
+
+!> @brief Set the domain and the type_of_domain for a file
+!> @details This subroutine is going to be called once by every variable in the file
+!! in register_diag_field. It will update the domain and the type_of_domain if needed and verify that
+!! all the variables are in the same domain
+subroutine set_file_domain(obj, domain, type_of_domain)
+ class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+ integer, INTENT(in) :: type_of_domain !< fileobj_type to use
+ CLASS(diagDomain_t), INTENT(in), target :: domain !< Domain
+
+ !! If this a sub_regional, don't do anything here
+ if (obj%type_of_domain .eq. SUB_REGIONAL) return
+
+ if (type_of_domain .ne. obj%type_of_domain) then
+ !! If the current type_of_domain in the file obj is not the same as the variable calling this subroutine
+
+ if (type_of_domain .eq. NO_DOMAIN .or. obj%type_of_domain .eq. NO_DOMAIN) then
+ !! If they are not the same then one of them can be NO_DOMAIN
+ !! (i.e a file can have variables that are not domain decomposed and variables that are)
+
+ if (type_of_domain .ne. NO_DOMAIN) then
+ !! Update the file's type_of_domain and domain if needed
+ obj%type_of_domain = type_of_domain
+ obj%domain => domain
+ endif
+
+ else
+ !! If they are not the same and of them is not NO_DOMAIN, then crash because the variables don't have the
+ !! same domain (i.e a file has a variable is that in a 2D domain and one that is in a UG domain)
+
+ call mpp_error(FATAL, "The file: "//obj%get_file_fname()//" has variables that are not in the same domain")
+ endif
+ endif
+
+end subroutine set_file_domain
+
+!> @brief Loops through a variable's axis_ids and adds them to the FMSDiagFile object if they don't exist
+subroutine add_axes(obj, axis_ids)
+ class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+ integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
+
+ integer :: i, j !< For do loops
+
+ do i = 1, size(axis_ids)
+ do j = 1, obj%number_of_axis
+ !> Check if the axis already exists, if it does leave this do loop
+ if (axis_ids(i) .eq. obj%axis_ids(j)) exit
+ enddo
+
+ !> If the axis does not exist add it to the list
+ obj%number_of_axis = obj%number_of_axis + 1
+ obj%axis_ids(obj%number_of_axis) = axis_ids(i)
+
+ !> If this is a sub_regional file, set up the sub_axes
+ !> TO DO:
+ !!
+ enddo
+
+end subroutine add_axes
#endif
end module fms_diag_file_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index df9fc037c9..58287bf767 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -8,15 +8,16 @@ module fms_diag_object_mod
!! that contains all of the information of the variable. It is extended by a type that holds the
!! appropriate buffer for the data for manipulation.
use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string
-use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int
+use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id
use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
#ifdef use_yaml
-use fms_diag_yaml_mod, only: diagYamlFilesVar_type
-use fms_diag_file_object_mod, only: fmsDiagFile_type
+use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id
+use fms_diag_file_object_mod, only: fmsDiagFile_type, FMS_diag_files
#endif
+use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type
use time_manager_mod, ONLY: time_type
!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
@@ -59,14 +60,15 @@ module fms_diag_object_mod
type fmsDiagObject_type
#ifdef use_yaml
type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable
- type (fmsDiagFile_type), pointer, dimension(:) :: diag_files !< Array pointing to files that contain
- !! the objects variable
+ integer, allocatable, dimension(:) :: file_ids !< Ids of the FMS_diag_files the variable
+ !! belongs to
#endif
integer, allocatable, private :: diag_id !< unique id for varable
character(len=:), allocatable, dimension(:) :: metadata !< metadata for the variable
logical, allocatable, private :: static !< true if this is a static var
logical, allocatable, private :: registered !< true when registered
logical, allocatable, private :: mask_variant !< If there is a mask variant
+ logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field
logical, allocatable, private :: local !< If the output is local
TYPE(time_type), private :: init_time !< The initial time
integer, allocatable, private :: vartype !< the type of varaible
@@ -77,7 +79,6 @@ module fms_diag_object_mod
character(len=:), allocatable, private :: modname !< the module
character(len=:), allocatable, private :: realm !< String to set as the value
!! to the modeling_realm attribute
- character(len=:), allocatable, private :: err_msg !< An error message
character(len=:), allocatable, private :: interp_method !< The interp method to be used
!! when regridding the field in post-processing.
!! Valid options are "conserve_order1",
@@ -86,11 +87,13 @@ module fms_diag_object_mod
integer, allocatable, dimension(:), private :: output_units
integer, allocatable, private :: t
integer, allocatable, private :: tile_count !< The number of tiles
- integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs
+ integer, pointer, dimension(:), private :: axis_ids !< variable axis IDs
+ class(diagDomain_t), pointer, private :: domain !< Domain
+ INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN",
+ !! "TWO_D_DOMAIN", or "UG_DOMAIN")
integer, allocatable, private :: area, volume !< The Area and Volume
class(*), allocatable, private :: missing_value !< The missing fill value
- class(*), allocatable, private :: data_RANGE !< The range of the variable data
- type (diag_axis_type), allocatable, dimension(:) :: axis !< The axis object
+ class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data
class(*), allocatable :: vardata0 !< Scalar data buffer
class(*), allocatable, dimension(:) :: vardata1 !< 1D data buffer
class(*), allocatable, dimension(:,:) :: vardata2 !< 2D data buffer
@@ -116,9 +119,6 @@ module fms_diag_object_mod
! Is variable allocated check functions
!TODO procedure :: has_diag_field
procedure :: has_diag_id
-#ifdef use_yaml
- procedure :: has_diag_files
-#endif
procedure :: has_metadata
procedure :: has_static
procedure :: has_registered
@@ -132,18 +132,15 @@ module fms_diag_object_mod
procedure :: has_units
procedure :: has_modname
procedure :: has_realm
- procedure :: has_err_msg
procedure :: has_interp_method
procedure :: has_frequency
procedure :: has_output_units
procedure :: has_t
procedure :: has_tile_count
- procedure :: has_axis_ids
procedure :: has_area
procedure :: has_volume
procedure :: has_missing_value
procedure :: has_data_RANGE
- procedure :: has_axis
! Get functions
procedure :: get_diag_id => fms_diag_get_id
procedure :: get_metadata
@@ -158,13 +155,11 @@ module fms_diag_object_mod
procedure :: get_units
procedure :: get_modname
procedure :: get_realm
- procedure :: get_err_msg
procedure :: get_interp_method
procedure :: get_frequency
procedure :: get_output_units
procedure :: get_t
procedure :: get_tile_count
- procedure :: get_axis_ids
procedure :: get_area
procedure :: get_volume
procedure :: get_missing_value
@@ -212,73 +207,75 @@ end subroutine diag_obj_init
!> \Description Fills in and allocates (when necessary) the values in the diagnostic object
subroutine fms_register_diag_field_obj &
!(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
- (dobj, modname, varname, axes, init_time, &
+ (dobj, modname, varname, init_time, diag_field_indices, axes, &
longname, units, missing_value, varRange, mask_variant, standname, &
do_not_log, err_msg, interp_method, tile_count, area, volume, realm, metadata)
- class(fmsDiagObject_type) , intent(inout) :: dobj
- CHARACTER(len=*), INTENT(in) :: modname !< The module name
- CHARACTER(len=*), INTENT(in) :: varname !< The variable name
- INTEGER, INTENT(in) :: axes(:) !< The axes indicies
- TYPE(time_type), INTENT(in) :: init_time !< Initial time
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: standname !< The variables stanard name
- class(*), OPTIONAL, INTENT(in) :: missing_value
- class(*), OPTIONAL, INTENT(in) :: varRANGE(2)
- LOGICAL, OPTIONAL, INTENT(in) :: mask_variant
- LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged
- CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error message to be passed back up
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
- !! regridding the field in post-processing.
- !! Valid options are "conserve_order1",
- !! "conserve_order2", and "none".
- INTEGER, OPTIONAL, INTENT(in) :: tile_count !< the number of tiles
- INTEGER, OPTIONAL, INTENT(in) :: area !< diag_field_id containing the cell area field
- INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id containing the cell volume field
- CHARACTER(len=*), OPTIONAL, INTENT(in):: realm !< String to set as the value to the modeling_realm attribute
- character(len=*), optional, intent(in), dimension(:) :: metadata !< metedata for the variable
+ class(fmsDiagObject_type), INTENT(inout) :: dobj !< Diaj_obj to fill
+ CHARACTER(len=*), INTENT(in) :: modname !< The module name
+ CHARACTER(len=*), INTENT(in) :: varname !< The variable name
+ TYPE(time_type), INTENT(in) :: init_time !< Initial time !< TO DO
+ integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
+ !! in the yaml object
+ INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standname !< The variables stanard name
+ class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a attribute
+ class(*), OPTIONAL, INTENT(in) :: varRANGE(2) !< Range to add as a attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Error message to be passed back up
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
+ !! regridding the field in post-processing.
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ INTEGER, OPTIONAL, INTENT(in) :: tile_count !< the number of tiles
+ INTEGER, OPTIONAL, INTENT(in) :: area !< diag_field_id of the cell area field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
+ !! modeling_realm attribute
+ character(len=*), optional, INTENT(in) :: metadata(:) !< metedata for the variable
+
+ integer :: i !< For do loops
+ integer :: j !< dobj%file_ids(i) (for less typing :)
+
+#ifdef use_yaml
!> Fill in information from the register call
- allocate(character(len=MAX_LEN_VARNAME) :: dobj%varname)
dobj%varname = trim(varname)
- allocate(character(len=len(modname)) :: dobj%modname)
dobj%modname = trim(modname)
-!> Grab the information from the diag_table
-! TO DO:
-! dobj%diag_field = get_diag_table_field(trim(varname))
-! dobj%diag_field = diag_yaml%get_diag_field(
- !! TODO : Discuss design. Is this a premature return that somehow should
- !! indicate a warning or failure to the calling function and/or the log files?
-! if (is_field_type_null(dobj%diag_field)) then
-! dobj%diag_id = diag_not_found
-! dobj%vartype = diag_null
-! return
-! endif
-!> TO DO: Add all the info from the diag_axis obj
-!! axes will need to be changed to optional, so this subroutine can be used for both scalar and array fields
-!! the domain_type and domain will be need to added to the dobj
-! if (present(axes))
-! dobj%axes => axes ! or something
-! call get_domain_and_domain_type(dobj%axes, dobj%domain_type, dobj%domain, dobj%varname)
- !! Send all the axes_info to the diag_files
-! else
-! dobj%domain_type = NO_DOMAIN
-! endif
+!> Fill in diag_field and find the ids of the files that this variable is in
+ dobj%diag_field = get_diag_fields_entries(diag_field_indices)
+ dobj%file_ids = get_diag_files_id(diag_field_indices)
-!> get the optional arguments if included and the diagnostic is in the diag table
- if (present(longname)) then
- allocate(character(len=len(longname)) :: dobj%longname)
- dobj%longname = trim(longname)
- endif
- if (present(standname)) then
- allocate(character(len=len(standname)) :: dobj%standname)
- dobj%standname = trim(standname)
+ if (present(axes)) then
+ dobj%axis_ids => axes
+ call get_domain_and_domain_type(dobj%axis_ids, dobj%type_of_domain, dobj%domain, dobj%varname)
+ do i = 1, size(dobj%file_ids)
+ j = dobj%file_ids(i)
+ call FMS_diag_files(j)%set_file_domain(dobj%domain, dobj%type_of_domain)
+ call FMS_diag_files(j)%add_axes(axes)
+ enddo
+ !> TO DO:
+ !! Mark the field as registered in the diag_files
+ else
+ !> The variable is a scalar
+ dobj%type_of_domain = NO_DOMAIN
+ dobj%domain => null()
endif
- if (present(units)) then
- allocate(character(len=len(units)) :: dobj%units)
- dobj%units = trim(units)
+
+!> get the optional arguments if included and the diagnostic is in the diag table
+ if (present(longname)) dobj%longname = trim(longname)
+ if (present(standname)) dobj%standname = trim(standname)
+ if (present(units)) dobj%units = trim(units)
+ if (present(realm)) dobj%realm = trim(realm)
+ if (present(interp_method)) dobj%interp_method = trim(interp_method)
+ if (present(tile_count)) then
+ allocate(dobj%tile_count)
+ dobj%tile_count = tile_count
endif
+
if (present(metadata)) then
allocate(character(len=MAX_LEN_META) :: dobj%metadata(size(metadata)))
dobj%metadata = metadata
@@ -310,12 +307,63 @@ subroutine fms_register_diag_field_obj &
end select
endif
-! write(6,*)"IKIND for diag_fields(1) is",dobj%diag_fields(1)%ikind
-! write(6,*)"IKIND for "//trim(varname)//" is ",dobj%diag_field%ikind
-!> Set the registered flag to true
- dobj%registered = .true.
- ! save it in the diag object container.
+ if (present(varRANGE)) then
+ select type (varRANGE)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: dobj%data_RANGE(2))
+ dobj%data_RANGE = varRANGE
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: dobj%data_RANGE(2))
+ dobj%data_RANGE = varRANGE
+ type is (real(kind=r4_kind))
+ allocate(integer(kind=r4_kind) :: dobj%data_RANGE(2))
+ dobj%data_RANGE = varRANGE
+ type is (real(kind=r8_kind))
+ allocate(integer(kind=r8_kind) :: dobj%data_RANGE(2))
+ dobj%data_RANGE = varRANGE
+ class default
+ call mpp_error("fms_register_diag_field_obj", &
+ "The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",&
+ FATAL)
+ end select
+ else
+ allocate(real :: dobj%data_RANGE(2))
+ select type (varRANGE => dobj%data_RANGE)
+ type is (real)
+ varRANGE = real(CMOR_MISSING_VALUE)
+ end select
+ endif
+
+ if (present(area)) then
+ if (area < 0) call mpp_error("fms_register_diag_field_obj", &
+ "The area id passed with field_name"//trim(varname)//" has not been registered."&
+ "Check that there is a register_diag_field call for the AREA measure and that is in the"&
+ "diag_table.yaml", FATAL)
+ allocate(dobj%area)
+ dobj%area = area
+ endif
+
+ if (present(volume)) then
+ if (volume < 0) call mpp_error("fms_register_diag_field_obj", &
+ "The volume id passed with field_name"//trim(varname)//" has not been registered."&
+ "Check that there is a register_diag_field call for the VOLUME measure and that is in the"&
+ "diag_table.yaml", FATAL)
+ allocate(dobj%volume)
+ dobj%volume = volume
+ endif
+ if (present(mask_variant)) then
+ allocate(dobj%mask_variant)
+ dobj%mask_variant = mask_variant
+ endif
+
+ if (present(do_not_log)) then
+ allocate(dobj%do_not_log)
+ dobj%do_not_log = do_not_log
+ endif
+
+ dobj%registered = .true.
+#endif
end subroutine fms_register_diag_field_obj
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \brief Sets the diag_id. This can only be done if a variable is unregistered
@@ -620,18 +668,6 @@ pure function get_realm (obj) &
rslt = diag_null_string
endif
end function get_realm
-!> @brief Gets err_msg
-!! @return copy of The error message stored in err_msg or an empty string if not allocated
-pure function get_err_msg (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
- if (allocated(obj%err_msg)) then
- rslt = obj%err_msg
- else
- rslt = diag_null_string
- endif
-end function get_err_msg
!> @brief Gets interp_method
!! @return copy of The interpolation method or an empty string if not allocated
pure function get_interp_method (obj) &
@@ -696,20 +732,6 @@ pure function get_tile_count (obj) &
rslt = DIAG_NULL
endif
end function get_tile_count
-!> @brief Gets axis_ids
-!! @return copy of The axis IDs array or a diag_null if no axis IDs are set
-pure function get_axis_ids (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- integer, allocatable, dimension(:) :: rslt
- if (allocated(obj%axis_ids)) then
- allocate(rslt(size(obj%axis_ids)))
- rslt = obj%axis_ids
- else
- allocate(rslt(1))
- rslt = diag_null
- endif
-end function get_axis_ids
!> @brief Gets area
!! @return copy of the area or diag_null if not allocated
pure function get_area (obj) &
@@ -769,20 +791,20 @@ end function get_missing_value
function get_data_RANGE (obj) &
result(rslt)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
- class(*),allocatable :: rslt
+ class(*),allocatable :: rslt(:)
if (allocated(obj%data_RANGE)) then
select type (r => obj%data_RANGE)
type is (integer(kind=i4_kind))
- allocate (integer(kind=i4_kind) :: rslt)
+ allocate (integer(kind=i4_kind) :: rslt(2))
rslt = r
type is (integer(kind=i8_kind))
- allocate (integer(kind=i8_kind) :: rslt)
+ allocate (integer(kind=i8_kind) :: rslt(2))
rslt = r
type is (real(kind=r4_kind))
- allocate (integer(kind=i4_kind) :: rslt)
+ allocate (integer(kind=i4_kind) :: rslt(2))
rslt = r
type is (real(kind=r8_kind))
- allocate (integer(kind=i4_kind) :: rslt)
+ allocate (integer(kind=i4_kind) :: rslt(2))
rslt = r
class default
call mpp_error ("get_data_RANGE", &
@@ -954,14 +976,6 @@ pure logical function has_diag_id (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_diag_id = allocated(obj%diag_id)
end function has_diag_id
-#ifdef use_yaml
-!> @brief Checks if obj%diag_files pointer is associated
-!! @return true if obj%diag_files is associated
-pure logical function has_diag_files (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_diag_files = associated(obj%diag_files)
-end function has_diag_files
-#endif
!> @brief Checks if obj%metadata is allocated
!! @return true if obj%metadata is allocated
pure logical function has_metadata (obj)
@@ -1040,12 +1054,6 @@ pure logical function has_realm (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_realm = allocated(obj%realm)
end function has_realm
-!> @brief Checks if obj%err_msg is allocated
-!! @return true if obj%err_msg is allocated
-pure logical function has_err_msg (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_err_msg = allocated(obj%err_msg)
-end function has_err_msg
!> @brief Checks if obj%interp_method is allocated
!! @return true if obj%interp_method is allocated
pure logical function has_interp_method (obj)
@@ -1076,12 +1084,6 @@ pure logical function has_tile_count (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_tile_count = allocated(obj%tile_count)
end function has_tile_count
-!> @brief Checks if obj%axis_ids is allocated
-!! @return true if obj%axis_ids is allocated
-pure logical function has_axis_ids (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_axis_ids = allocated(obj%axis_ids)
-end function has_axis_ids
!> @brief Checks if obj%area is allocated
!! @return true if obj%area is allocated
pure logical function has_area (obj)
@@ -1106,11 +1108,4 @@ pure logical function has_data_RANGE (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_data_RANGE = allocated(obj%data_RANGE)
end function has_data_RANGE
-!> @brief Checks if obj%axis is allocated
-!! @return true if obj%axis is allocated
-pure logical function has_axis (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_axis = allocated(obj%axis)
-end function has_axis
-
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 53511a26fd..bfe713579d 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -47,7 +47,7 @@ module fms_diag_yaml_mod
public :: diag_yaml_object_init, diag_yaml_object_end
public :: diagYamlObject_type, get_diag_yaml_obj, get_title, get_basedate, get_diag_files, get_diag_fields
public :: diagYamlFiles_type, diagYamlFilesVar_type
-public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_entries
+public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_id
!> @}
integer, parameter :: basedate_size = 6
@@ -1222,40 +1222,41 @@ function get_diag_fields_entries(indices) &
end function get_diag_fields_entries
-!> @brief Gets the diag_files entries corresponding to the indices of the sorted variable_list
-!! @return Array of diag_files
-function get_diag_files_entries(indices) &
- result(diag_file)
+!> @brief Finds the indices of the diag_yaml%diag_files(:) corresponding to fields in variable_list(indices)
+!! @return indices of the diag_yaml%diag_files(:)
+function get_diag_files_id(indices) &
+ result(file_id)
integer, intent(in) :: indices(:) !< Indices of the field in the sorted variable_list
- type(diagYamlFiles_type), dimension (:), allocatable :: diag_file
+ integer, allocatable :: file_id(:)
+ integer :: field_id !< Indices of the field in the diag_yaml field array
integer :: i !< For do loops
- integer :: field_id !< Indices of the field in the diag_yaml array
- integer :: file_id !< Indices of the file in the diag_yaml array
character(len=120) :: filename !< Filename of the field
integer, allocatable :: file_indices(:) !< Indices of the file in the sorted variable_list
- allocate(diag_file(size(indices)))
+ allocate(file_id(size(indices)))
do i = 1, size(indices)
field_id = variable_list%diag_field_indices(indices(i))
+ !< Get the filename of the field
filename = diag_yaml%diag_fields(field_id)%var_fname
+ !< File indice of that file in the array of list of sorted files
file_indices = fms_find_my_string(file_list%file_pointer, size(file_list%file_pointer), &
& trim(filename)//c_null_char)
if (size(file_indices) .ne. 1) &
- & call mpp_error(FATAL, "get_diag_files_entries: Error getting the correct number of file indices!")
+ & call mpp_error(FATAL, "get_diag_files_id: Error getting the correct number of file indices!")
if (file_indices(1) .eq. diag_null) &
- & call mpp_error(FATAL, "get_diag_files_entries: Error finding the filename in the diag_files")
+ & call mpp_error(FATAL, "get_diag_files_id: Error finding the filename in the diag_files yaml")
- file_id = file_list%diag_file_indices(file_indices(1))
- diag_file(i) = diag_yaml%diag_files(file_id)
+ !< Get the index of the file in the diag_yaml file
+ file_id(i) = file_list%diag_file_indices(file_indices(1))
end do
-end function get_diag_files_entries
+end function get_diag_files_id
#endif
end module fms_diag_yaml_mod
!> @}
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index d2262129d4..94dbc18774 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -37,7 +37,6 @@ test_diag_manager_SOURCES = test_diag_manager.F90
test_diag_manager_time_SOURCES = test_diag_manager_time.F90
test_diag_update_buffer_SOURCES= test_diag_update_buffer.F90
test_diag_yaml_SOURCES = test_diag_yaml.F90
-test_diag_object_container_SOURCES = test_diag_object_container.F90
test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90
test_diag_ocean_SOURCES = test_diag_ocean.F90
test_modern_diag_SOURCES = test_modern_diag.F90
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 40cff2c612..f6c4b0e43d 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -641,9 +641,6 @@ test_expect_success "Test the diag_ocean feature in diag_manager_init (test $my_
mpirun -n 2 ../test_diag_ocean
'
-test_expect_success "test_diag_object_container (test $my_test_count)" '
- mpirun -n 1 ../test_diag_object_container
-'
test_expect_success "test_diag_dlinked_list (test $my_test_count)" '
mpirun -n 1 ../test_diag_dlinked_list
'
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index 845991b900..dbbabe2b76 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -56,6 +56,10 @@ end subroutine compare_result_1d
type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< Files from the diag_yaml
type(diagYamlFilesVar_type), allocatable, dimension(:) :: diag_fields !< Fields from the diag_yaml
+type(diagYamlObject_type) :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init
+type(diagYamlObject_type) :: ans !< expected diagYamlObject
+integer, ALLOCATABLE :: diag_files_ids(:) !< Ids of the diag_files
+#endif
namelist / check_crashes_nml / checking_crashes
@@ -108,7 +112,11 @@ end subroutine compare_result_1d
call compare_result("sst - fieldname", diag_fields(2)%get_var_varname(), "sst")
deallocate(diag_fields)
- diag_files = get_diag_files_entries(indices)
+ diag_files_ids = get_diag_files_id(indices)
+ allocate(diag_files(size(diag_files_ids)))
+
+ diag_files(1) = my_yaml%diag_files(diag_files_ids(1))
+ diag_files(2) = my_yaml%diag_files(diag_files_ids(2))
call compare_result("sst - nfiles", size(diag_files), 2)
call compare_result("sst - filename", diag_files(1)%get_file_fname(), "normal")
call compare_result("sst - filename", diag_files(2)%get_file_fname(), "wild_card_name%4yr%2mo%2dy%2hr")
From 07ea894b548184c7fc4425c4ad6cc5f61f2c1ca5 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 29 Jun 2022 13:19:24 -0400
Subject: [PATCH 052/168] feat: modern diag allow for variables with the same
name, but different module (#988)
---
diag_manager/diag_manager.F90 | 4 ++--
diag_manager/fms_diag_yaml.F90 | 10 ++++++----
test_fms/diag_manager/test_diag_manager2.sh | 2 +-
test_fms/diag_manager/test_diag_yaml.F90 | 8 ++++----
test_fms/diag_manager/test_modern_diag.F90 | 7 +++++--
5 files changed, 18 insertions(+), 13 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 14c088847c..ffeef6f181 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -475,7 +475,7 @@ INTEGER FUNCTION register_diag_field_scalar_modern(module_name, field_name, init
#ifdef use_yaml
integer, allocatable :: diag_field_indices(:) !< indices where the field was found
- diag_field_indices = find_diag_field(field_name)
+ diag_field_indices = find_diag_field(field_name, module_name)
if (diag_field_indices(1) .eq. diag_null) then
!< The field was not found in the table, so return diag_null
register_diag_field_scalar_modern = diag_null
@@ -526,7 +526,7 @@ INTEGER FUNCTION register_diag_field_array_modern(module_name, field_name, axes,
#ifdef use_yaml
integer, allocatable :: diag_field_indices(:) !< indices of diag_field yaml where the field was found
- diag_field_indices = find_diag_field(field_name)
+ diag_field_indices = find_diag_field(field_name, module_name)
if (diag_field_indices(1) .eq. diag_null) then
!< The field was not found in the table, so return diag_null
register_diag_field_array_modern = diag_null
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index bfe713579d..33019b0b9c 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -391,8 +391,9 @@ subroutine diag_yaml_object_init(diag_subset_output)
!> Save the variable name in the diag_file type
diag_yaml%diag_files(file_count)%file_varlist(file_var_count) = diag_yaml%diag_fields(var_count)%var_varname
- !> Save the variable name in the variable_list
- variable_list%var_name(var_count) = trim(diag_yaml%diag_fields(var_count)%var_varname)//c_null_char
+ !> Save the variable name and the module name in the variable_list
+ variable_list%var_name(var_count) = trim(diag_yaml%diag_fields(var_count)%var_varname)//&
+ ":"//trim(diag_yaml%diag_fields(var_count)%var_module)//c_null_char
variable_list%diag_field_indices(var_count) = var_count
enddo nvars_loop
deallocate(var_ids)
@@ -1191,15 +1192,16 @@ end function get_num_unique_fields
!> @brief Determines if a diag_field is in the diag_yaml_object
!! @return Indices of the locations where the field was found
-function find_diag_field(diag_field_name) &
+function find_diag_field(diag_field_name, module_name) &
result(indices)
character(len=*), intent(in) :: diag_field_name !< diag_field name to search for
+ character(len=*), intent(in) :: module_name !< Name of the module, the variable is in
integer, allocatable :: indices(:)
indices = fms_find_my_string(variable_list%var_pointer, size(variable_list%var_pointer), &
- & diag_field_name//c_null_char)
+ & trim(diag_field_name)//":"//trim(module_name)//c_null_char)
end function find_diag_field
!> @brief Gets the diag_field entries corresponding to the indices of the sorted variable_list
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index f6c4b0e43d..d45fb84766 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -706,7 +706,7 @@ diag_files:
unlimdim: time
varlist:
- module: lnd_mod
- var_name: var6
+ var_name: var1
reduction: average
kind: r4
_EOF
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index dbbabe2b76..0ec2740a94 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -99,7 +99,7 @@ end subroutine compare_result_1d
deallocate(diag_files)
deallocate(diag_fields)
- indices = find_diag_field("sst")
+ indices = find_diag_field("sst", "test_diag_manager_mod")
print *, "sst was found in ", indices
if (size(indices) .ne. 2) &
call mpp_error(FATAL, 'sst was supposed to be found twice!')
@@ -123,7 +123,7 @@ end subroutine compare_result_1d
deallocate(diag_files)
deallocate(indices)
- indices = find_diag_field("sstt")
+ indices = find_diag_field("sstt", "test_diag_manager_mod")
print *, "sstt was found in ", indices
if (size(indices) .ne. 1) &
call mpp_error(FATAL, 'sstt was supposed to be found twice!')
@@ -131,12 +131,12 @@ end subroutine compare_result_1d
call mpp_error(FATAL, 'sstt was supposed to be found in indices 1 and 2')
deallocate(indices)
- indices = find_diag_field("sstt2") !< This is in diag_table but it has write_var = false
+ indices = find_diag_field("sstt2", "test_diag_manager_mod") !< This is in diag_table but it has write_var = false
print *, "sstt2 was found in ", indices
if (indices(1) .ne. -999) &
call mpp_error(FATAL, "sstt2 is not in the diag_table!")
- indices = find_diag_field("tamales")
+ indices = find_diag_field("tamales", "test_diag_manager_mod")
print *, "tamales was found in ", indices
if (indices(1) .ne. -999) &
call mpp_error(FATAL, "tamales is not in the diag_table!")
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index 79f4c58ca2..ec0e9636d9 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -123,8 +123,11 @@ program test_modern_diag
id_var4 = register_diag_field ('atm_mod', 'var4', (/id_x3, id_y3, id_z/), Time, &
'3D var in a cube sphere domain', 'mullions')
id_var5 = register_diag_field ('lnd_mod', 'var5', (/id_ug/), Time, 'Var in a UG domain', 'mullions')
-id_var6 = register_diag_field ('lnd_mod', 'var6', (/id_z/), Time, 'Var not domain decomposed', 'mullions')
-id_var7 = register_diag_field ('lnd_mod', 'var7', Time, 'Some scalar var', 'mullions')
+id_var6 = register_diag_field ('atm_mod', 'var6', (/id_z/), Time, 'Var not domain decomposed', 'mullions')
+
+!< This has the same name as var1, but it should have a different id because the module is different
+!! so it should have its own diag_obj
+id_var7 = register_diag_field ('lnd_mod', 'var1', Time, 'Some scalar var', 'mullions')
if (id_var1 .ne. 1) call mpp_error(FATAL, "var1 does not have the expected id")
if (id_var2 .ne. 2) call mpp_error(FATAL, "var2 does not have the expected id")
From dbfc95c74ba17878dea26443c0aeecbc0c3436f5 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 29 Jun 2022 14:24:06 -0400
Subject: [PATCH 053/168] feat: add a modern version of add_diag_axis_attribute
(#990)
---
diag_manager/diag_axis.F90 | 35 ++++++++++++----
diag_manager/diag_data.F90 | 37 ++++++++++++++++
diag_manager/fms_diag_axis_object.F90 | 49 +++++++++++++++++++---
diag_manager/fms_diag_object.F90 | 2 +-
test_fms/diag_manager/test_modern_diag.F90 | 8 +++-
5 files changed, 117 insertions(+), 14 deletions(-)
diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90
index 9efcccba34..5063b6aa94 100644
--- a/diag_manager/diag_axis.F90
+++ b/diag_manager/diag_axis.F90
@@ -40,8 +40,10 @@ MODULE diag_axis_mod
USE diag_data_mod, ONLY: diag_axis_type, max_subaxes, max_axes,&
& max_num_axis_sets, max_axis_attributes, debug_diag_manager,&
& first_send_data_call, diag_atttype, use_modern_diag
- USE fms_diag_axis_object_mod, ONLY: fms_diag_axis_init
+ USE fms_diag_axis_object_mod, ONLY: fms_diag_axis_init, fms_diag_axis_add_attribute
+#ifdef use_netCDF
USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR
+#endif
IMPLICIT NONE
@@ -1047,7 +1049,11 @@ SUBROUTINE diag_axis_add_attribute_scalar_r(diag_axis_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name
REAL, INTENT(in) :: att_value
- CALL diag_axis_add_attribute_r1d(diag_axis_id, att_name, (/ att_value /))
+ if (use_modern_diag) then
+ call fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /))
+ else
+ CALL diag_axis_add_attribute_r1d(diag_axis_id, att_name, (/ att_value /))
+ endif
END SUBROUTINE diag_axis_add_attribute_scalar_r
SUBROUTINE diag_axis_add_attribute_scalar_i(diag_axis_id, att_name, att_value)
@@ -1055,7 +1061,11 @@ SUBROUTINE diag_axis_add_attribute_scalar_i(diag_axis_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name
INTEGER, INTENT(in) :: att_value
- CALL diag_axis_add_attribute_i1d(diag_axis_id, att_name, (/ att_value /))
+ if (use_modern_diag) then
+ call fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /))
+ else
+ CALL diag_axis_add_attribute_i1d(diag_axis_id, att_name, (/ att_value /))
+ endif
END SUBROUTINE diag_axis_add_attribute_scalar_i
SUBROUTINE diag_axis_add_attribute_scalar_c(diag_axis_id, att_name, att_value)
@@ -1063,7 +1073,11 @@ SUBROUTINE diag_axis_add_attribute_scalar_c(diag_axis_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name
CHARACTER(len=*), INTENT(in) :: att_value
- CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_CHAR, cval=att_value)
+ if (use_modern_diag) then
+ call fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /))
+ else
+ CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_CHAR, cval=att_value)
+ endif
END SUBROUTINE diag_axis_add_attribute_scalar_c
SUBROUTINE diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value)
@@ -1071,15 +1085,22 @@ SUBROUTINE diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name
REAL, DIMENSION(:), INTENT(in) :: att_value
- CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_FLOAT, rval=att_value)
+ if (use_modern_diag) then
+ call fms_diag_axis_add_attribute(diag_axis_id, att_name, att_value)
+ else
+ CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_FLOAT, rval=att_value)
+ endif
END SUBROUTINE diag_axis_add_attribute_r1d
SUBROUTINE diag_axis_add_attribute_i1d(diag_axis_id, att_name, att_value)
INTEGER, INTENT(in) :: diag_axis_id
CHARACTER(len=*), INTENT(in) :: att_name
INTEGER, DIMENSION(:), INTENT(in) :: att_value
-
- CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_INT, ival=att_value)
+ if (use_modern_diag) then
+ call fms_diag_axis_add_attribute(diag_axis_id, att_name, att_value)
+ else
+ CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_INT, ival=att_value)
+ endif
END SUBROUTINE diag_axis_add_attribute_i1d
!> @brief Allocates memory in out_file for the attributes. Will FATAL if err_msg is not included
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 0793e82984..b149dce2a4 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -313,6 +313,15 @@ MODULE diag_data_mod
CHARACTER(len=128) :: tile_name='N/A'
END TYPE diag_global_att_type
+ !> @brief Type to hold the attributes of the field/axis/file
+ !> @ingroup diag_data_mod
+ type fmsDiagAttribute_type
+ class(*), allocatable :: att_value(:) !< Value of the attribute
+ character(len=:), allocatable :: att_name !< Name of the attribute
+
+ contains
+ procedure :: add => fms_add_attribute
+ end type fmsDiagAttribute_type
! Include variable "version" to be written to log file.
#include
@@ -520,6 +529,34 @@ function get_base_second() &
integer :: res
res = base_second
end function get_base_second
+
+ subroutine fms_add_attribute(obj, att_name, att_value)
+ class(fmsDiagAttribute_type), intent(inout) :: obj !< Diag attribute type
+ character(len=*), intent(in) :: att_name !< Name of the attribute
+ class(*), intent(in) :: att_value(:) !< The attribute value to add
+
+ integer :: natt !< the size of att_value
+
+ natt = size(att_value)
+ obj%att_name = att_name
+ select type (att_value)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: obj%att_value(natt))
+ obj%att_value = att_value
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: obj%att_value(natt))
+ obj%att_value = att_value
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: obj%att_value(natt))
+ obj%att_value = att_value
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: obj%att_value(natt))
+ obj%att_value = att_value
+ type is (character(len=*))
+ allocate(character(len=len(att_value)) :: obj%att_value(natt))
+ obj%att_value = att_value
+ end select
+ end subroutine fms_add_attribute
END MODULE diag_data_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 6c27786e85..676b925204 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -30,9 +30,9 @@
module fms_diag_axis_object_mod
use mpp_domains_mod, only: domain1d, domain2d, domainUG, mpp_get_compute_domain, CENTER, &
& mpp_get_compute_domain, NORTH, EAST
- use platform_mod, only: r8_kind, r4_kind
+ use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind
use diag_data_mod, only: diag_atttype, max_axes, NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, &
- direction_down, direction_up
+ direction_down, direction_up, fmsDiagAttribute_type, max_axis_attributes
use mpp_mod, only: FATAL, mpp_error, uppercase
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, &
& register_axis, register_field, register_variable_attribute, write_data
@@ -41,7 +41,7 @@ module fms_diag_axis_object_mod
PRIVATE
public :: diagAxis_t, set_subaxis, fms_diag_axis_init, fms_diag_axis_object_init, fms_diag_axis_object_end, &
- & get_domain_and_domain_type, axis_obj, diagDomain_t, sub_axis_objs
+ & get_domain_and_domain_type, axis_obj, diagDomain_t, sub_axis_objs, fms_diag_axis_add_attribute
!> @}
!> @brief Type to hold the domain info for an axis
@@ -103,12 +103,13 @@ module fms_diag_axis_object_mod
!! or geolat_t
CHARACTER(len=128) , private :: req !< Required field names.
INTEGER , private :: tile_count !< The number of tiles
- TYPE(diag_atttype),allocatable , private :: attributes(:) !< Array to hold user definable attributes
+ TYPE(fmsDiagAttribute_type),allocatable , private :: attributes(:) !< Array to hold user definable attributes
INTEGER , private :: num_attributes !< Number of defined attibutes
INTEGER , private :: domain_position !< The position in the doman (NORTH, EAST or CENTER)
contains
+ PROCEDURE :: add_axis_attribute
PROCEDURE :: register => register_diag_axis_obj
PROCEDURE :: axis_length => get_axis_length
PROCEDURE :: set_subaxis
@@ -213,8 +214,26 @@ subroutine register_diag_axis_obj(obj, axis_name, axis_data, units, cart_name, l
if (present(req)) obj%req = trim(req)
obj%nsubaxis = 0
+ obj%num_attributes = 0
end subroutine register_diag_axis_obj
+ !> @brief Add an attribute to an axis
+ subroutine add_axis_attribute(obj, att_name, att_value)
+ class(diagAxis_t),INTENT(INOUT) :: obj !< diag_axis obj
+ character(len=*), intent(in) :: att_name !< Name of the attribute
+ class(*), intent(in) :: att_value(:) !< The attribute value to add
+
+ integer :: j !< obj%num_attributes (for less typing)
+
+ if (.not. allocated(obj%attributes)) &
+ allocate(obj%attributes(max_axis_attributes))
+
+ obj%num_attributes = obj%num_attributes + 1
+
+ j = obj%num_attributes
+ call obj%attributes(j)%add(att_name, att_value)
+ end subroutine add_axis_attribute
+
!> @brief Write the axis meta data to an open fileobj
subroutine write_axis_metadata(obj, fileobj, sub_axis_id)
class(diagAxis_t), target, INTENT(IN) :: obj !< diag_axis obj
@@ -223,7 +242,8 @@ subroutine write_axis_metadata(obj, fileobj, sub_axis_id)
character(len=:), ALLOCATABLE :: axis_edges_name !< Name of the edges, if it exist
character(len=:), pointer :: axis_name !< Name of the axis
- integer :: axis_length !< Size of the axis
+ integer :: axis_length !< Size of the axis
+ integer :: i !< For do loops
if (present(sub_axis_id)) then
axis_name => obj%subaxis(sub_axis_id)%subaxis_name
@@ -284,6 +304,13 @@ subroutine write_axis_metadata(obj, fileobj, sub_axis_id)
str_len=len_trim(axis_edges_name))
endif
+ if(allocated(obj%attributes)) then
+ do i = 1, size(obj%attributes)
+ call register_variable_attribute(fileobj, axis_name, obj%attributes(i)%att_name, &
+ & obj%attributes(i)%att_value)
+ enddo
+ endif
+
end subroutine write_axis_metadata
!> @brief Write the axis data to an open fileobj
@@ -451,6 +478,18 @@ FUNCTION fms_diag_axis_init(axis_name, axis_data, units, cart_name, long_name, d
id = number_of_axis
end function
+ !> @brief Add an attribute to an axis
+ subroutine fms_diag_axis_add_attribute(axis_id, att_name, att_value)
+ integer, intent(in) :: axis_id !< Id of the axis to add the attribute to
+ character(len=*), intent(in) :: att_name !< Name of the attribute
+ class(*), intent(in) :: att_value(:) !< The attribute value to add
+
+ if (axis_id < 0 .and. axis_id > number_of_axis) &
+ call mpp_error(FATAL, "diag_axis_add_attribute: The axis_id is not valid")
+
+ call axis_obj(axis_id)%add_axis_attribute(att_name, att_value)
+ end subroutine fms_diag_axis_add_attribute
+
!> @brief Check if a cart_name is valid and crashes if it isn't
subroutine check_if_valid_cart_name(cart_name)
character(len=*), intent(in) :: cart_name
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 58287bf767..e3b82129c6 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -544,7 +544,7 @@ pure function get_metadata (obj) &
class (fmsDiagObject_type), intent(in) :: obj !< diag object
character(len=:), allocatable, dimension(:) :: rslt
if (allocated(obj%metadata)) then
- allocate(character(len=(len(obj%metadata(1)))) :: rslt (size(obj%metadata)) )
+ allocate(character(len=(len(obj%metadata))) :: rslt (size(obj%metadata)) )
rslt = obj%metadata
else
allocate(character(len=1) :: rslt(1:1))
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index ec0e9636d9..13e4c0b6f2 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -25,7 +25,8 @@ program test_modern_diag
mpp_define_mosaic, domainug, mpp_get_compute_domains, mpp_define_unstruct_domain, &
mpp_get_compute_domain, mpp_get_data_domain, mpp_get_UG_domain_grid_index, &
mpp_get_UG_compute_domain
-use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field
+use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
+ diag_axis_add_attribute
use fms_mod, only: fms_init, fms_end
use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast
use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time
@@ -107,6 +108,11 @@ program test_modern_diag
set_name="land", DomainU=land_domain, aux="geolon_t geolat_t")
id_z = diag_axis_init('z', z, 'point_Z', 'z', long_name='point_Z')
+call diag_axis_add_attribute (id_z, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)')
+call diag_axis_add_attribute (id_z, 'integer', 10)
+call diag_axis_add_attribute (id_z, '1d integer', (/10, 10/))
+call diag_axis_add_attribute (id_z, 'real', 10.)
+call diag_axis_add_attribute (id_x, '1d real', (/10./))
if (id_x .ne. 1) call mpp_error(FATAL, "The x axis does not have the expected id")
if (id_y .ne. 2) call mpp_error(FATAL, "The y axis does not have the expected id")
From dd004c566d917da1d5fb0db8ce87011e7ad00d9e Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 5 Jul 2022 13:51:42 -0400
Subject: [PATCH 054/168] feat: modern diag implement register_static_field and
move diag_objs array (#995)
---
diag_manager/diag_manager.F90 | 178 +++++++++++-----------------
diag_manager/fms_diag_object.F90 | 194 ++++++++++++++++++++++++++++++-
2 files changed, 256 insertions(+), 116 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index ffeef6f181..b84a3abf7d 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -237,7 +237,8 @@ MODULE diag_manager_mod
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
- USE fms_diag_object_mod, ONLY: fmsDiagObject_type
+ USE fms_diag_object_mod, ONLY: fmsDiagObject_type, fms_diag_object_init, fms_register_diag_field_array, &
+ & fms_register_diag_field_scalar, fms_diag_object_end, fms_register_static_field
USE fms_diag_file_object_mod, only: fms_diag_files_object_initialized
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field
@@ -281,9 +282,6 @@ MODULE diag_manager_mod
type(time_type) :: Time_end
- TYPE(fmsDiagObject_type), ALLOCATABLE :: diag_objs(:) !< Array of diag objects, one for each registered variable
- integer :: registered_variables !< Number of registered variables
-
!> @brief Send data over to output fields.
!!
!> send_data is overloaded for fields having zero dimension
@@ -403,7 +401,7 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
if (use_modern_diag) then
- register_diag_field_scalar = register_diag_field_scalar_modern(module_name, field_name, init_time, &
+ register_diag_field_scalar = fms_register_diag_field_scalar(module_name, field_name, init_time, &
& long_name=long_name, units=units, missing_value=missing_value, var_range=range, standard_name=standard_name, &
& do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
else
@@ -441,7 +439,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
if (use_modern_diag) then
- register_diag_field_array = register_diag_field_array_modern(module_name, field_name, axes, init_time, &
+ register_diag_field_array = fms_register_diag_field_array(module_name, field_name, axes, init_time, &
& long_name=long_name, units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
& standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
& interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
@@ -453,99 +451,53 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
endif
end function register_diag_field_array
- !> @brief Registers a scalar field
+ !> @brief Return field index for subsequent call to send_data.
!! @return field index for subsequent call to send_data.
- INTEGER FUNCTION register_diag_field_scalar_modern(module_name, field_name, init_time, &
- & long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,&
- & area, volume, realm)
- CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
- CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
- TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
- REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
- REAL, OPTIONAL, INTENT(in) :: var_range(2) !< Range to add a variable attribute
- LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
- CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
- INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
- INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
-
-#ifdef use_yaml
- integer, allocatable :: diag_field_indices(:) !< indices where the field was found
-
- diag_field_indices = find_diag_field(field_name, module_name)
- if (diag_field_indices(1) .eq. diag_null) then
- !< The field was not found in the table, so return diag_null
- register_diag_field_scalar_modern = diag_null
- deallocate(diag_field_indices)
- return
- endif
-
- registered_variables = registered_variables + 1
- register_diag_field_scalar_modern = registered_variables
-
- call diag_objs(registered_variables)%setID(registered_variables)
- call diag_objs(registered_variables)%register(module_name, field_name, init_time, diag_field_indices, &
- & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
- & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
- & area=area, volume=volume, realm=realm)
- deallocate(diag_field_indices)
-#endif
-
- end function register_diag_field_scalar_modern
+ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, units,&
+ & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
+ & tile_count, area, volume, realm)
+ CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on
+ CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
+ INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute
+ real, OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
+ real, DIMENSION(2), OPTIONAL, INTENT(in) :: range !< Range to be added as a attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has
+ !! a mask variant
+ LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
+ !! regridding the field in post-processing
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ INTEGER, OPTIONAL, INTENT(in) :: tile_count !! Number of tiles
+ INTEGER, OPTIONAL, INTENT(in) :: area !< Field ID for the area field associated
+ !! with this field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated
+ !! with this field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
+ !! modeling_realm attribute
- !> @brief Registers an array field
- !> @return field index for subsequent call to send_data.
- INTEGER FUNCTION register_diag_field_array_modern(module_name, field_name, axes, init_time, &
- & long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,&
- & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
- CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
- CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
- INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis
- TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
- REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
- REAL, OPTIONAL, INTENT(in) :: var_range(2) !< Range to add a variable attribute
- LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
- LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information
- LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
- CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
- !! regridding the field in post-processing.
- !! Valid options are "conserve_order1",
- !! "conserve_order2", and "none".
- INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number
- INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
- INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+ ! Fatal error if the module has not been initialized.
+ IF ( .NOT.module_is_initialized ) THEN
+ ! diag_manager has NOT been initialized
+ CALL error_mesg ('diag_manager_mod::register_static_field', 'diag_manager has NOT been initialized', FATAL)
+ END IF
-#ifdef use_yaml
- integer, allocatable :: diag_field_indices(:) !< indices of diag_field yaml where the field was found
-
- diag_field_indices = find_diag_field(field_name, module_name)
- if (diag_field_indices(1) .eq. diag_null) then
- !< The field was not found in the table, so return diag_null
- register_diag_field_array_modern = diag_null
- deallocate(diag_field_indices)
- return
+ if (use_modern_diag) then
+ register_static_field = fms_register_static_field(module_name, field_name, axes, &
+ & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
+ & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,&
+ & tile_count=tile_count, area=area, volume=volume, realm=realm)
+ else
+ register_static_field = register_static_field_old(module_name, field_name, axes, &
+ & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
+ & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,&
+ & tile_count=tile_count, area=area, volume=volume, realm=realm)
endif
-
- registered_variables = registered_variables + 1
- register_diag_field_array_modern = registered_variables
-
- call diag_objs(registered_variables)%setID(registered_variables)
- call diag_objs(registered_variables)%register(module_name, field_name, init_time, diag_field_indices, axes, &
- & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
- & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
- & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
- deallocate(diag_field_indices)
-#endif
-
- end function register_diag_field_array_modern
+END FUNCTION register_static_field
!> @brief Registers a scalar field
!! @return field index for subsequent call to send_data.
@@ -780,7 +732,7 @@ INTEGER FUNCTION register_diag_field_array_old(module_name, field_name, axes, in
END FUNCTION register_diag_field_array_old
!> @brief Return field index for subsequent call to send_data.
!! @return field index for subsequent call to send_data.
- INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, units,&
+ INTEGER FUNCTION register_static_field_old(module_name, field_name, axes, long_name, units,&
& missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
& tile_count, area, volume, realm)
CHARACTER(len=*), INTENT(in) :: module_name, field_name
@@ -813,7 +765,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
! Fatal error if the module has not been initialized.
IF ( .NOT.module_is_initialized ) THEN
! diag_manager has NOT been initialized
- CALL error_mesg ('diag_manager_mod::register_static_field', 'diag_manager has NOT been initialized', FATAL)
+ CALL error_mesg ('diag_manager_mod::register_static_field_old', 'diag_manager has NOT been initialized', FATAL)
END IF
! Check if OPTIONAL parameters were passed in.
@@ -873,10 +825,10 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
& DYNAMIC=dynamic1)
END IF
- register_static_field = find_input_field(module_name, field_name, 1)
- field = register_static_field
+ register_static_field_old = find_input_field(module_name, field_name, 1)
+ field = register_static_field_old
! Negative index returned if this field was not found in the diag_table.
- IF ( register_static_field < 0 ) RETURN
+ IF ( register_static_field_old < 0 ) RETURN
! Check that the axes are compatible with each other
domain_type = axis_compatible_check(axes,field_name)
@@ -893,7 +845,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
END IF
CALL init_input_field(module_name, field_name, tile)
- register_static_field = find_input_field(module_name, field_name, tile)
+ register_static_field_old = find_input_field(module_name, field_name, tile)
DO j = 1, input_fields(field)%num_output_fields
out_num = input_fields(field)%output_fields(j)
file_num = output_fields(out_num)%output_file
@@ -906,7 +858,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
& files(file_num)%name,output_fields(out_num)%time_method, output_fields(out_num)%pack, tile)
END IF
END DO
- field = register_static_field
+ field = register_static_field_old
END IF
! Store information for this input field into input field table
@@ -927,7 +879,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
! Verify that area and volume do not point to the same variable
IF ( PRESENT(volume).AND.PRESENT(area) ) THEN
IF ( area.EQ.volume ) THEN
- CALL error_mesg ('diag_manager_mod::register_static_field', 'module/output_field '&
+ CALL error_mesg ('diag_manager_mod::register_static_field_old', 'module/output_field '&
&//TRIM(module_name)//'/'// TRIM(field_name)//' AREA and VOLUME CANNOT be the same variable.&
& Contact the developers.',&
& FATAL)
@@ -937,7 +889,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
! Check for the existence of the area/volume field(s)
IF ( PRESENT(area) ) THEN
IF ( area < 0 ) THEN
- CALL error_mesg ('diag_manager_mod::register_static_field', 'module/output_field '&
+ CALL error_mesg ('diag_manager_mod::register_static_field_old', 'module/output_field '&
&//TRIM(module_name)//'/'// TRIM(field_name)//' AREA measures field NOT found in diag_table.&
& Contact the model liaison.n',&
& FATAL)
@@ -945,7 +897,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
END IF
IF ( PRESENT(volume) ) THEN
IF ( volume < 0 ) THEN
- CALL error_mesg ('diag_manager_mod::register_static_field', 'module/output_field '&
+ CALL error_mesg ('diag_manager_mod::register_static_field_old', 'module/output_field '&
&//TRIM(module_name)//'/'// TRIM(field_name)//' VOLUME measures field NOT found in diag_table&
& Contact the model liaison.',&
& FATAL)
@@ -1065,7 +1017,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
file_num = output_fields(out_num)%output_file
if (domain_type .eq. DIAG_AXIS_2DDOMAIN) then
if (files(file_num)%use_domainUG) then
- call error_mesg("diag_manager_mod::register_static_field", &
+ call error_mesg("diag_manager_mod::register_static_field_old", &
"Diagnostics living on a structured grid" &
//" and an unstructured grid cannot exist" &
//" in the same file (" &
@@ -1076,7 +1028,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
endif
elseif (domain_type .eq. DIAG_AXIS_UGDOMAIN) then
if (files(file_num)%use_domain2D) then
- call error_mesg("diag_manager_mod::register_static_field", &
+ call error_mesg("diag_manager_mod::register_static_field_old", &
"Diagnostics living on a structured grid" &
//" and an unstructured grid cannot exist" &
//" in the same file (" &
@@ -1176,7 +1128,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
! minimum on static fields. Setting the time operation to 'NONE'
! for this field.
!
- CALL error_mesg ('diag_manager_mod::register_static_field',&
+ CALL error_mesg ('diag_manager_mod::register_static_field_old',&
& 'module/field '//TRIM(msg)//' is STATIC. Cannot perform time operations&
& average, maximum, or minimum on static fields. Setting the time operation&
& to "NONE" for this field.', WARNING)
@@ -1223,7 +1175,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
! Set the cell_measures attribute in the out file
CALL init_field_cell_measures(output_fields(out_num), area=area, volume=volume, err_msg=msg)
IF ( LEN_TRIM(msg).GT.0 ) THEN
- CALL error_mesg ('diag_manager_mod::register_static_field',&
+ CALL error_mesg ('diag_manager_mod::register_static_field_old',&
& TRIM(msg)//' for module/field '//TRIM(module_name)//'/'//TRIM(field_name),&
& FATAL)
END IF
@@ -1256,7 +1208,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
END IF
END DO
END IF
- END FUNCTION register_static_field
+ END FUNCTION register_static_field_old
!> @brief Return the diagnostic field ID of a given variable.
!! @return get_diag_field_id will return the ID returned during the register_diag_field call.
@@ -3868,7 +3820,7 @@ SUBROUTINE diag_manager_end(time)
if (use_modern_diag) then
call diag_yaml_object_end
call fms_diag_axis_object_end()
- if (allocated(diag_objs)) deallocate(diag_objs)
+ call fms_diag_object_end()
endif
#endif
END SUBROUTINE diag_manager_end
@@ -4085,8 +4037,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
if (use_modern_diag) then
CALL diag_yaml_object_init(diag_subset_output)
CALL fms_diag_axis_object_init()
- allocate(diag_objs(get_num_unique_fields()))
- registered_variables = 0
+ CALL fms_diag_object_init(255, 255) !< TO DO: MAX_LEN_VARNAME and MAX_LEN_META are supposed to be read from
+ !! the namelist and sent to fms_diag_object
fms_diag_files_object_initialized = fms_diag_files_object_init ()
endif
#else
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index e3b82129c6..d1475f0e56 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -14,7 +14,8 @@ module fms_diag_object_mod
use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
#ifdef use_yaml
-use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id
+use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, &
+ & find_diag_field, get_num_unique_fields
use fms_diag_file_object_mod, only: fmsDiagFile_type, FMS_diag_files
#endif
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type
@@ -172,6 +173,11 @@ module fms_diag_object_mod
integer,private :: MAX_LEN_VARNAME
integer,private :: MAX_LEN_META
+logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized
+
+TYPE(fmsDiagObject_type), private, ALLOCATABLE, target :: diag_objs(:) !< Array of diag objects
+ !! one for each registered variable
+integer, private :: registered_variables !< Number of registered variables
!type(fmsDiagObject_type) :: diag_object_placeholder (10)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -179,20 +185,43 @@ module fms_diag_object_mod
public :: fmsDiagObject_type
public :: null_ob
public :: fms_diag_object_init
+public :: fms_diag_object_end
+public :: fms_register_diag_field_array
+public :: fms_register_diag_field_scalar
+public :: fms_register_static_field
+public :: get_diag_obj_from_id
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> @brief Initiliazes the array of diag_objs based on the number of unique diag_fields in the diag_table
subroutine fms_diag_object_init (mlv,mlm)
integer, intent(in) :: mlv !< The maximum length of the varname
integer, intent(in) :: mlm !< The maximum length of the metadata
+
+ if (module_is_initialized) return
+
!> Get info from the namelist
MAX_LEN_VARNAME = mlv
MAX_LEN_META = mlm
!> Initialize the null_d variables
null_ob%diag_id = DIAG_NULL
+#ifdef use_yaml
+ allocate(diag_objs(get_num_unique_fields()))
+ registered_variables = 0
+#endif
+ module_is_initialized = .true.
end subroutine fms_diag_object_init
+
+!> @brief Deallocates the array of diag_objs
+subroutine fms_diag_object_end ()
+ if (.not. module_is_initialized) return
+
+ if (allocated(diag_objs)) deallocate(diag_objs)
+
+ module_is_initialized = .false.
+end subroutine fms_diag_object_end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \Description Sets the diag_id to the not registered value.
subroutine diag_obj_init(ob)
@@ -207,16 +236,16 @@ end subroutine diag_obj_init
!> \Description Fills in and allocates (when necessary) the values in the diagnostic object
subroutine fms_register_diag_field_obj &
!(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
- (dobj, modname, varname, init_time, diag_field_indices, axes, &
+ (dobj, modname, varname, diag_field_indices, axes, init_time, &
longname, units, missing_value, varRange, mask_variant, standname, &
do_not_log, err_msg, interp_method, tile_count, area, volume, realm, metadata)
class(fmsDiagObject_type), INTENT(inout) :: dobj !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: modname !< The module name
CHARACTER(len=*), INTENT(in) :: varname !< The variable name
- TYPE(time_type), INTENT(in) :: init_time !< Initial time !< TO DO
integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
!! in the yaml object
+ TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Initial time !< TO DO
INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies
CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables
@@ -1108,4 +1137,163 @@ pure logical function has_data_RANGE (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
has_data_RANGE = allocated(obj%data_RANGE)
end function has_data_RANGE
+
+ !> @brief Registers a scalar field
+ !! @return field index for subsequent call to send_data.
+ INTEGER FUNCTION fms_register_diag_field_scalar(module_name, field_name, init_time, &
+ & long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,&
+ & area, volume, realm)
+ CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
+ CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
+ TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
+ INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+
+#ifdef use_yaml
+ integer, allocatable :: diag_field_indices(:) !< indices where the field was found
+
+ diag_field_indices = find_diag_field(field_name, module_name)
+ if (diag_field_indices(1) .eq. diag_null) then
+ !< The field was not found in the table, so return diag_null
+ fms_register_diag_field_scalar = diag_null
+ deallocate(diag_field_indices)
+ return
+ endif
+
+ registered_variables = registered_variables + 1
+ fms_register_diag_field_scalar = registered_variables
+
+ call diag_objs(registered_variables)%setID(registered_variables)
+ call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, &
+ & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
+ & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
+ & area=area, volume=volume, realm=realm)
+ deallocate(diag_field_indices)
+#endif
+
+ end function fms_register_diag_field_scalar
+
+ !> @brief Registers an array field
+ !> @return field index for subsequent call to send_data.
+ INTEGER FUNCTION fms_register_diag_field_array(module_name, field_name, axes, init_time, &
+ & long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,&
+ & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
+ CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
+ CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
+ INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis
+ TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
+ LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
+ !! regridding the field in post-processing.
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number
+ INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+
+#ifdef use_yaml
+ integer, allocatable :: diag_field_indices(:) !< indices of diag_field yaml where the field was found
+
+ diag_field_indices = find_diag_field(field_name, module_name)
+ if (diag_field_indices(1) .eq. diag_null) then
+ !< The field was not found in the table, so return diag_null
+ fms_register_diag_field_array = diag_null
+ deallocate(diag_field_indices)
+ return
+ endif
+
+ registered_variables = registered_variables + 1
+ fms_register_diag_field_array = registered_variables
+
+ call diag_objs(registered_variables)%setID(registered_variables)
+ call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, &
+ & axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
+ & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
+ & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
+ deallocate(diag_field_indices)
+#endif
+
+end function fms_register_diag_field_array
+
+!> @brief Return field index for subsequent call to send_data.
+!! @return field index for subsequent call to send_data.
+INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_name, units,&
+ & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
+ & tile_count, area, volume, realm)
+ CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on
+ CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
+ INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute
+ real, OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
+ real, DIMENSION(2), OPTIONAL, INTENT(in) :: range !< Range to be added as a attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has
+ !! a mask variant
+ LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
+ !! regridding the field in post-processing
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ INTEGER, OPTIONAL, INTENT(in) :: tile_count !! Number of tiles
+ INTEGER, OPTIONAL, INTENT(in) :: area !< Field ID for the area field associated
+ !! with this field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated
+ !! with this field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
+ !! modeling_realm attribute
+
+#ifdef use_yaml
+ integer, allocatable :: diag_field_indices(:) !< indices where the field was foun
+
+ diag_field_indices = find_diag_field(field_name, module_name)
+ if (diag_field_indices(1) .eq. diag_null) then
+ !< The field was not found in the table, so return diag_null
+ fms_register_static_field = diag_null
+ deallocate(diag_field_indices)
+ return
+ endif
+
+ registered_variables = registered_variables + 1
+ fms_register_static_field = registered_variables
+
+ call diag_objs(registered_variables)%setID(registered_variables)
+ allocate(diag_objs(registered_variables)%static)
+ diag_objs(registered_variables)%static = .true.
+ call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, axes=axes, &
+ & longname=long_name, units=units, missing_value=missing_value, varrange=range, &
+ & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm)
+ deallocate(diag_field_indices)
+#endif
+end function fms_register_static_field
+
+!> @brief Get a pointer to the diag_object from the id.
+!> @return A pointer to the diag_object or a null pointer if the id is not valid
+FUNCTION get_diag_obj_from_id ( id ) result (obj_ptr)
+ integer :: id !< Id of the diag_obj to get
+ class(fmsDiagObject_type), pointer :: obj_ptr
+
+ obj_ptr => null()
+ IF (id >= 1 .and. id <= registered_variables) THEN
+ obj_ptr => diag_objs(id)
+ END IF
+END FUNCTION get_diag_obj_from_id
end module fms_diag_object_mod
From 7cb32494b2b4107d4405cefe78c34cac96c5c9c7 Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Tue, 26 Jul 2022 07:23:22 -0400
Subject: [PATCH 055/168] fix: class(*) updates needed for compatibility of
dmUpdate with 2022.03 (#1011)
---
diag_manager/fms_diag_axis_object.F90 | 2 +-
diag_manager/fms_diag_object.F90 | 4 ++--
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 676b925204..04a26938d4 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -449,7 +449,7 @@ FUNCTION fms_diag_axis_init(axis_name, axis_data, units, cart_name, long_name, d
& result(id)
CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
- REAL, INTENT(in) :: axis_data(:) !< Array of coordinate values
+ CLASS(*), INTENT(in) :: axis_data(:) !< Array of coordinate values
CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
CHARACTER(len=1), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", "U", "N")
CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis.
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index d1475f0e56..7848b06a5d 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -1243,8 +1243,8 @@ INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_n
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute
- real, OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
- real, DIMENSION(2), OPTIONAL, INTENT(in) :: range !< Range to be added as a attribute
+ class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
+ class(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range !< Range to be added as a attribute
LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has
!! a mask variant
LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic
From 6364debd3d7f035afd8761c89ff2568357617e9c Mon Sep 17 00:00:00 2001
From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com>
Date: Tue, 26 Jul 2022 13:05:38 -0400
Subject: [PATCH 056/168] fix: Compiling dmUpdate post merge of 2022.03-beta1
(#979)
---
diag_manager/fms_diag_object.F90 | 4 ++--
test_fms/diag_manager/test_diag_manager2.sh | 12 +++++++++++-
2 files changed, 13 insertions(+), 3 deletions(-)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 7848b06a5d..e2734e4b11 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -1243,8 +1243,8 @@ INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_n
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute
- class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
- class(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range !< Range to be added as a attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to be added as a attribute
LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has
!! a mask variant
LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index d45fb84766..b1451e2492 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -458,7 +458,6 @@ setup_test
test_expect_success "Unstructured grid (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager
'
-
my_test_count=24
# test_diag_manager_time
cat <<_EOF > diag_table
@@ -499,6 +498,11 @@ test_diag_manager
"test_diag_manager_mod", "sst", "sst", "test_diurnal", "all", "diurnal3", "none", 2
"test_diag_manager_mod", "ice", "ice", "test_diurnal", "all", "diurnal3", "none", 2
_EOF
+<<<<<<< HEAD
+=======
+
+my_test_count=25
+>>>>>>> 0088145b (Compiling dmUpdate post merge of 2022.03-beta1 (#979))
test_expect_success "diurnal test (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager_time
'
@@ -586,6 +590,7 @@ diag_files:
_EOF
cp diag_table.yaml diag_table.yaml_base
+my_test_count=26
test_expect_success "diag_yaml test (test $my_test_count)" '
mpirun -n 1 ../test_diag_yaml
'
@@ -637,10 +642,13 @@ diag_files:
reduction: average
kind: r4
_EOF
+
+my_test_count=41
test_expect_success "Test the diag_ocean feature in diag_manager_init (test $my_test_count)" '
mpirun -n 2 ../test_diag_ocean
'
+my_test_count=42
test_expect_success "test_diag_dlinked_list (test $my_test_count)" '
mpirun -n 1 ../test_diag_dlinked_list
'
@@ -711,7 +719,9 @@ diag_files:
kind: r4
_EOF
+my_test_count=43
test_expect_success "Test the modern diag manager end to end (test $my_test_count)" '
mpirun -n 6 ../test_modern_diag
'
+
test_done
From 511188975b079c14c25b69e86c3f6e1df912e41d Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Fri, 5 Aug 2022 04:47:14 -0400
Subject: [PATCH 057/168] docs: modern diag uml design update (#1015)
---
diag_manager/docs_uml/Untitled Diagram.drawio | 141 +++++++++
.../docs_uml/classDiagramDiagObjects.drawio | 277 ++++++++++++++++++
diag_manager/docs_uml/diag_manager_end.drawio | 175 +++++++++++
.../docs_uml/diag_manager_init.drawio | 1 +
4 files changed, 594 insertions(+)
create mode 100644 diag_manager/docs_uml/Untitled Diagram.drawio
create mode 100644 diag_manager/docs_uml/classDiagramDiagObjects.drawio
create mode 100644 diag_manager/docs_uml/diag_manager_end.drawio
create mode 100644 diag_manager/docs_uml/diag_manager_init.drawio
diff --git a/diag_manager/docs_uml/Untitled Diagram.drawio b/diag_manager/docs_uml/Untitled Diagram.drawio
new file mode 100644
index 0000000000..a4e56faf62
--- /dev/null
+++ b/diag_manager/docs_uml/Untitled Diagram.drawio
@@ -0,0 +1,141 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/diag_manager/docs_uml/classDiagramDiagObjects.drawio b/diag_manager/docs_uml/classDiagramDiagObjects.drawio
new file mode 100644
index 0000000000..7d9233fcd7
--- /dev/null
+++ b/diag_manager/docs_uml/classDiagramDiagObjects.drawio
@@ -0,0 +1,277 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/diag_manager/docs_uml/diag_manager_end.drawio b/diag_manager/docs_uml/diag_manager_end.drawio
new file mode 100644
index 0000000000..7ccb47c159
--- /dev/null
+++ b/diag_manager/docs_uml/diag_manager_end.drawio
@@ -0,0 +1,175 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/diag_manager/docs_uml/diag_manager_init.drawio b/diag_manager/docs_uml/diag_manager_init.drawio
new file mode 100644
index 0000000000..dc8b20961a
--- /dev/null
+++ b/diag_manager/docs_uml/diag_manager_init.drawio
@@ -0,0 +1 @@
+UzV2zq1wL0osyPDNT0nNUTV2VTV2LsrPL4GwciucU3NyVI0MMlNUjV1UjYwMgFjVyA2HrCFY1qAgsSg1rwSLBiADYTaQg2Y1AA==
\ No newline at end of file
From 06efc242f9b0ba9900f9d2ff45192747cae39760 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 8 Aug 2022 12:17:40 -0400
Subject: [PATCH 058/168] feat: modern diag add time info to diag file obj
(#1002)
---
diag_manager/Makefile.am | 3 +-
diag_manager/fms_diag_file_object.F90 | 92 +++++++++----
diag_manager/fms_diag_object.F90 | 3 +-
diag_manager/fms_diag_yaml.F90 | 161 +++++++++++++----------
test_fms/diag_manager/test_diag_yaml.F90 | 38 ++++--
5 files changed, 192 insertions(+), 105 deletions(-)
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index cd5408d069..dc0fc141ca 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -60,7 +60,8 @@ diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT
diag_grid_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
-fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
+ diag_util_mod.$(FC_MODEXT)
fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT)
fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index d16f3055fc..0b20799679 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -24,9 +24,10 @@
!! a pointer to the information from the diag yaml, additional metadata that comes from the model, and a
!! list of the variables and their variable IDs that are in the file.
module fms_diag_file_object_mod
-!use mpp_mod, only: mpp_error, FATAL
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t
-use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL
+use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time
+use diag_util_mod, only: diag_time_inc
+use time_manager_mod, only: time_type, operator(/=), operator(==)
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type
#endif
@@ -44,6 +45,13 @@ module fms_diag_file_object_mod
type :: fmsDiagFile_type
private
integer :: id !< The number associated with this file in the larger array of files
+ TYPE(time_type) :: start_time !< The start time for the file
+ TYPE(time_type) :: last_output !< Time of the last time output was writen
+ TYPE(time_type) :: next_output !< Time of the next write
+ TYPE(time_type) :: next_next_output !< Time of the next next write
+
+ !< This will be used when using the new_file_freq keys in the diag_table.yaml
+ TYPE(time_type) :: next_open !< The next time to open the file
class(FmsNetcdfFile_t), allocatable :: fileobj !< fms2_io file object for this history file
#ifdef use_yaml
type(diagYamlFiles_type), pointer :: diag_yaml_file => null() !< Pointer to the diag_yaml_file data
@@ -72,6 +80,7 @@ module fms_diag_file_object_mod
procedure, public :: has_diag_yaml_file
procedure, public :: set_file_domain
procedure, public :: add_axes
+ procedure, public :: add_start_time
#endif
procedure, public :: has_var_ids
procedure, public :: get_id
@@ -122,36 +131,47 @@ logical function fms_diag_files_object_init ()
#ifdef use_yaml
integer :: nFiles !< Number of files in the diag yaml
integer :: i !< Looping iterator
+ type(fmsDiagFile_type), pointer :: obj !< FMS_diag_files(i) (for less typing)
if (diag_yaml%has_diag_files()) then
nFiles = diag_yaml%size_diag_files()
allocate (FMS_diag_files(nFiles))
set_ids_loop: do i= 1,nFiles
- FMS_diag_files(i)%diag_yaml_file => diag_yaml%diag_files(i)
- FMS_diag_files(i)%id = i
- allocate(FMS_diag_files(i)%var_ids(diag_yaml%diag_files(i)%size_file_varlist()))
- allocate(FMS_diag_files(i)%var_index(diag_yaml%diag_files(i)%size_file_varlist()))
- allocate(FMS_diag_files(i)%var_reg(diag_yaml%diag_files(i)%size_file_varlist()))
+ obj => FMS_diag_files(i)
+ obj%diag_yaml_file => diag_yaml%diag_files(i)
+ obj%id = i
+ allocate(obj%var_ids(diag_yaml%diag_files(i)%size_file_varlist()))
+ allocate(obj%var_index(diag_yaml%diag_files(i)%size_file_varlist()))
+ allocate(obj%var_reg(diag_yaml%diag_files(i)%size_file_varlist()))
!! Initialize the integer arrays
- FMS_diag_files(i)%var_ids = DIAG_NULL
- FMS_diag_files(i)%var_reg = .FALSE.
- FMS_diag_files(i)%var_index = DIAG_NULL
+ obj%var_ids = DIAG_NULL
+ obj%var_reg = .FALSE.
+ obj%var_index = DIAG_NULL
!> These will be set in a set_file_domain
- FMS_diag_files(i)%type_of_domain = NO_DOMAIN
- FMS_diag_files(i)%domain => null()
+ obj%type_of_domain = NO_DOMAIN
+ obj%domain => null()
!> This will be set in a add_axes
- allocate(FMS_diag_files(i)%axis_ids(max_axes))
+ allocate(obj%axis_ids(max_axes))
!> If the file has a sub_regional, define it as one and allocate the sub_axis_ids array.
!! This will be set in a add_axes
- if (FMS_diag_files(i)%has_file_sub_region()) then
- FMS_diag_files(i)%type_of_domain = SUB_REGIONAL
- allocate(FMS_diag_files(i)%sub_axis_ids(max_axes))
- FMS_diag_files(i)%sub_axis_ids = diag_null
+ if (obj%has_file_sub_region()) then
+ obj%type_of_domain = SUB_REGIONAL
+ allocate(obj%sub_axis_ids(max_axes))
+ obj%sub_axis_ids = diag_null
endif
- FMS_diag_files(i)%number_of_axis = 0
+ obj%number_of_axis = 0
+
+ !> Set the start_time of the file to the base_time and set up the *_output variables
+ obj%start_time = get_base_time()
+ obj%last_output = get_base_time()
+ obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit())
+ obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
+ obj%next_open = get_base_time()
+
+ nullify(obj)
enddo set_ids_loop
fms_diag_files_object_init = .true.
else
@@ -244,7 +264,7 @@ end function get_file_fname
!! \return Copy of file_frequnit
pure function get_file_frequnit (obj) result(res)
class(fmsDiagFile_type), intent(in) :: obj !< The file object
- character (len=:), allocatable :: res
+ integer :: res
res = obj%diag_yaml_file%get_file_frequnit()
end function get_file_frequnit
!> \brief Returns a copy of file_freq from the yaml object
@@ -258,7 +278,7 @@ end function get_file_freq
!! \return Copy of file_timeunit
pure function get_file_timeunit (obj) result(res)
class(fmsDiagFile_type), intent(in) :: obj !< The file object
- character (len=:), allocatable :: res
+ integer :: res
res = obj%diag_yaml_file%get_file_timeunit()
end function get_file_timeunit
!> \brief Returns a copy of file_unlimdim from the yaml object
@@ -287,7 +307,7 @@ end function get_file_new_file_freq
!! \return Copy of file_new_file_freq_units
pure function get_file_new_file_freq_units (obj) result(res)
class(fmsDiagFile_type), intent(in) :: obj !< The file object
- character (len=:), allocatable :: res
+ integer :: res
res = obj%diag_yaml_file%get_file_new_file_freq_units()
end function get_file_new_file_freq_units
!> \brief Returns a copy of file_start_time from the yaml object
@@ -308,7 +328,7 @@ end function get_file_duration
!! \return Copy of file_duration_units
pure function get_file_duration_units (obj) result(res)
class(fmsDiagFile_type), intent(in) :: obj !< The file object
- character (len=:), allocatable :: res
+ integer :: res
res = obj%diag_yaml_file%get_file_duration_units()
end function get_file_duration_units
!> \brief Returns a copy of file_varlist from the yaml object
@@ -475,5 +495,33 @@ subroutine add_axes(obj, axis_ids)
enddo
end subroutine add_axes
+
+!> @brief adds the start time to the fileobj
+!! @note This should be called from the register field calls. It can be called multiple times (one for each variable)
+!! So it needs to make sure that the start_time is the same for each variable. The initial value is the base_time
+subroutine add_start_time(obj, start_time)
+ class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+ TYPE(time_type), intent(in) :: start_time !< Start time to add to the fileobj
+
+ !< If the start_time sent in is equal to the base_time return because
+ !! obj%start_time was already set to the base_time
+ if (start_time .eq. get_base_time()) return
+
+ if (obj%start_time .ne. get_base_time()) then
+ !> If the obj%start_time is not equal to the base_time from the diag_table
+ !! obj%start_time was already updated so make sure it is the same or error out
+ if (obj%start_time .ne. start_time)&
+ call mpp_error(FATAL, "The variables associated with the file:"//obj%get_file_fname()//" have"&
+ &" different start_time")
+ else
+ !> If the obj%start_time is equal to the base_time,
+ !! simply update it with the start_time and set up the *_output variables
+ obj%start_time = start_time
+ obj%last_output = start_time
+ obj%next_output = diag_time_inc(start_time, obj%get_file_freq(), obj%get_file_frequnit())
+ obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
+ endif
+
+end subroutine
#endif
end module fms_diag_file_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index e2734e4b11..0f31e2d83e 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -245,7 +245,7 @@ subroutine fms_register_diag_field_obj &
CHARACTER(len=*), INTENT(in) :: varname !< The variable name
integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
!! in the yaml object
- TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Initial time !< TO DO
+ TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Initial time
INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies
CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables
@@ -285,6 +285,7 @@ subroutine fms_register_diag_field_obj &
j = dobj%file_ids(i)
call FMS_diag_files(j)%set_file_domain(dobj%domain, dobj%type_of_domain)
call FMS_diag_files(j)%add_axes(axes)
+ if (present(init_time)) call FMS_diag_files(j)%add_start_time(init_time)
enddo
!> TO DO:
!! Mark the field as registered in the diag_files
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 33019b0b9c..e436e1a2a5 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -31,7 +31,8 @@
module fms_diag_yaml_mod
#ifdef use_yaml
use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER, set_base_time, latlon_gridtype, &
- index_gridtype, null_gridtype
+ index_gridtype, null_gridtype, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, &
+ DIAG_MONTHS, DIAG_YEARS
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL
@@ -84,14 +85,18 @@ module fms_diag_yaml_mod
!> @brief type to hold the diag_file information
type diagYamlFiles_type
character (len=:), private, allocatable :: file_fname !< file name
- character (len=:), private, allocatable :: file_frequnit !< the frequency unit
+ integer, private :: file_frequnit !< the frequency unit (DIAG_SECONDS, DIAG_MINUTES, &
+ !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
integer, private :: file_freq !< the frequency of data
- character (len=:), private, allocatable :: file_timeunit !< The unit of time
+ integer, private :: file_timeunit !< The unit of time (DIAG_SECONDS, DIAG_MINUTES, &
+ !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
character (len=:), private, allocatable :: file_unlimdim !< The name of the unlimited dimension
type(subRegion_type), private :: file_sub_region !< type containing info about the subregion, if any
integer, private :: file_new_file_freq !< Frequency for closing the existing file
- character (len=:), private, allocatable :: file_new_file_freq_units !< Time units for creating a new file.
+ integer, private :: file_new_file_freq_units !< Time units for creating a new file.
!! Required if “new_file_freq” used
+ !! (DIAG_SECONDS, DIAG_MINUTES, &
+ !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
character (len=:), private, allocatable :: file_start_time !< Time to start the file for the first time. Requires
!! “new_file_freq”
integer, private :: file_duration !< How long the file should receive data after start time
@@ -101,7 +106,9 @@ module fms_diag_yaml_mod
!! frequency for creating new files.
!! NOTE: The file_duration_units field must also be present if
!! this field is present.
- character (len=:), private, allocatable :: file_duration_units !< The file duration units
+ integer, private :: file_duration_units !< The file duration units
+ !! (DIAG_SECONDS, DIAG_MINUTES, &
+ !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
!< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
character (len=MAX_STR_LEN), dimension(:), private, allocatable :: file_varlist !< An array of variable names
!! within a file
@@ -451,26 +458,30 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
integer, allocatable :: key_ids(:) !< Id of the gloabl atttributes key/value pairs
character(len=:), ALLOCATABLE :: grid_type !< grid_type as it is read in from the yaml
+ character(len=:), ALLOCATABLE :: buffer !< buffer to store any *_units as it is read from the yaml
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", fileobj%file_frequnit)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", buffer)
call get_value_from_key(diag_yaml_id, diag_file_id, "freq", fileobj%file_freq)
- call check_file_freq(fileobj)
+ call set_file_freq(fileobj, buffer)
+ deallocate(buffer)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", fileobj%file_unlimdim)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", fileobj%file_timeunit)
- call check_file_time_units(fileobj)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", buffer)
+ call set_file_time_units(fileobj, buffer)
+ deallocate(buffer)
call get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", fileobj%file_new_file_freq, is_optional=.true.)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq_units", fileobj%file_new_file_freq_units, &
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq_units", buffer, &
is_optional=.true.)
- call check_new_file_freq(fileobj)
+ call set_new_file_freq(fileobj, buffer)
+ deallocate(buffer)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", fileobj%file_start_time, is_optional=.true.)
call get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", fileobj%file_duration, is_optional=.true.)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration_units", fileobj%file_duration_units, &
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration_units", buffer, &
is_optional=.true.)
- call check_file_duration(fileobj)
+ call set_file_duration(fileobj, buffer)
nsubregion = 0
nsubregion = get_num_blocks(diag_yaml_id, "sub_region", parent_block_id=diag_file_id)
@@ -631,60 +642,57 @@ function get_total_num_vars(diag_yaml_id, diag_file_id) &
end do
end function
-!> @brief This checks if the file frequency in a diag file is valid and crashes if it isn't
-subroutine check_file_freq(fileobj)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+!> @brief This checks if the file frequency and file frequency units in a diag file are valid and
+!! sets the integer equivalent
+subroutine set_file_freq(fileobj, file_frequnit)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+ character(len=*), intent(in) :: file_frequnit !< File_freq_units as it is read from the diag_table
if (.not. (fileobj%file_freq >= -1) ) &
call mpp_error(FATAL, "freq must be greater than or equal to -1. &
&Check you entry for"//trim(fileobj%file_fname))
- if(.not. is_valid_time_units(fileobj%file_frequnit)) &
- call mpp_error(FATAL, trim(fileobj%file_frequnit)//" is not a valid file_frequnit. &
- &The acceptable values are seconds, minuts, hours, days, months, years. &
- &Check your entry for file:"//trim(fileobj%file_fname))
-end subroutine check_file_freq
-
-!> @brief This checks if the time unit in a diag file is valid and crashes if it isn't
-subroutine check_file_time_units (fileobj)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to checK
-
- if(.not. is_valid_time_units(fileobj%file_timeunit)) &
- call mpp_error(FATAL, trim(fileobj%file_timeunit)//" is not a valid time_unit. &
- &The acceptable values are seconds, minuts, hours, days, months, years. &
- &Check your entry for file:"//trim(fileobj%file_fname))
-end subroutine check_file_time_units
-
-!> @brief This checks if the new file frequency in a diag file is valid and crashes if it isn't
-subroutine check_new_file_freq(fileobj)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+ fileobj%file_frequnit = set_valid_time_units(file_frequnit, "frequnit for file:"//trim(fileobj%file_fname))
+end subroutine set_file_freq
+
+!> @brief This checks if the time unit in a diag file is valid and sets the integer equivalent
+subroutine set_file_time_units (fileobj, file_timeunit)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to checK
+ character(len=*), intent(in) :: file_timeunit !< file_timeunit as it is read from the diag_table
+
+ fileobj%file_timeunit = set_valid_time_units(file_timeunit, "timeunit for file:"//trim(fileobj%file_fname))
+end subroutine set_file_time_units
+!> @brief This checks if the new file frequency and the new file frequency units in a diag file are valid
+!! and sets the integer equivalent
+subroutine set_new_file_freq(fileobj, file_new_file_freq_units)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+ character(len=*), intent(in) :: file_new_file_freq_units !< new file freq units as it is read from
+ !! the diag_table
if (fileobj%file_new_file_freq > 0) then
- if (trim(fileobj%file_new_file_freq_units) .eq. "") &
+ if (trim(file_new_file_freq_units) .eq. "") &
call mpp_error(FATAL, "new_file_freq_units is required if using new_file_freq. &
&Check your entry for file:"//trim(fileobj%file_fname))
- if (.not. is_valid_time_units(fileobj%file_new_file_freq_units)) &
- call mpp_error(FATAL, trim(fileobj%file_new_file_freq_units)//" is not a valid new_file_freq_units. &
- &The acceptable values are seconds, minuts, hours, days, months, years. &
- &Check your entry for file:"//trim(fileobj%file_fname))
+ fileobj%file_new_file_freq_units = set_valid_time_units(file_new_file_freq_units, &
+ "new_file_freq_units for file:"//trim(fileobj%file_fname))
endif
-end subroutine check_new_file_freq
+end subroutine set_new_file_freq
-!> @brief This checks if the file duration in a diag file is valid and crashes if it isn't
-subroutine check_file_duration(fileobj)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+!> @brief This checks if the file duration and the file duration units in a diag file are valid
+!! and sets the integer equivalent
+subroutine set_file_duration(fileobj, file_duration_units)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+ character(len=*), intent(in) :: file_duration_units !< file_duration as it is read from the diag_table
if (fileobj%file_duration > 0) then
- if(trim(fileobj%file_duration_units) .eq. "") &
+ if(trim(file_duration_units) .eq. "") &
call mpp_error(FATAL, "file_duration_units is required if using file_duration. &
&Check your entry for file:"//trim(fileobj%file_fname))
- if (.not. is_valid_time_units(fileobj%file_duration_units)) &
- call mpp_error(FATAL, trim(fileobj%file_duration_units)//" is not a valid file_duration_units. &
- &The acceptable values are seconds, minuts, hours, days, months, years. &
- &Check your entry for file:"//trim(fileobj%file_duration_units))
+ fileobj%file_duration_units = set_valid_time_units(file_duration_units, &
+ "file_duration_units for file:"//trim(fileobj%file_fname))
endif
-end subroutine check_file_duration
+end subroutine set_file_duration
!> @brief This checks if the kind of a diag field is valid and crashes if it isn't
subroutine check_field_kind(field)
@@ -740,20 +748,35 @@ subroutine check_field_reduction(field)
field%pow_value = pow_value
end subroutine check_field_reduction
-!> @brief This checks if a time unit is valid
-!! @return Flag indicating if the time units are valid
-pure function is_valid_time_units(time_units) &
-result(is_valid)
- character(len=*), intent(in) :: time_units
- logical :: is_valid
+!> @brief This checks if a time unit is valid and if it is, it assigns the integer equivalent
+!! @return The integer equivalent to the time units
+function set_valid_time_units(time_units, error_msg) &
+result(time_units_int)
+
+ character(len=*), intent(in) :: time_units !< The time_units as a string
+ character(len=*), intent(in) :: error_msg !< Error message to append
+
+ integer :: time_units_int !< The integer equivalent of the time_units
select case (TRIM(time_units))
- case ("seconds", "minutes", "hours", "days", "months", "years")
- is_valid = .true.
+ case ("seconds")
+ time_units_int = DIAG_SECONDS
+ case ("minutes")
+ time_units_int = DIAG_MINUTES
+ case ("hours")
+ time_units_int = DIAG_HOURS
+ case ("days")
+ time_units_int = DIAG_DAYS
+ case ("months")
+ time_units_int = DIAG_MONTHS
+ case ("years")
+ time_units_int = DIAG_YEARS
case default
- is_valid = .false.
+ time_units_int =DIAG_NULL
+ call mpp_error(FATAL, trim(error_msg)//" is not valid. Acceptable values are "&
+ "seconds, minutes, hours, days, months, years")
end select
-end function is_valid_time_units
+end function set_valid_time_units
!!!!!!! YAML FILE INQUIRIES !!!!!!!
!> @brief Finds the number of variables in the file_varlist
@@ -776,7 +799,7 @@ end function get_file_fname
pure function get_file_frequnit (diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
+ integer :: res !< What is returned
res = diag_files_obj%file_frequnit
end function get_file_frequnit
!> @brief Inquiry for diag_files_obj%file_freq
@@ -792,7 +815,7 @@ end function get_file_freq
pure function get_file_timeunit (diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
+ integer :: res !< What is returned
res = diag_files_obj%file_timeunit
end function get_file_timeunit
!> @brief Inquiry for diag_files_obj%file_unlimdim
@@ -824,7 +847,7 @@ end function get_file_new_file_freq
pure function get_file_new_file_freq_units (diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (:), allocatable :: res !< What is returned
+ integer :: res !< What is returned
res = diag_files_obj%file_new_file_freq_units
end function get_file_new_file_freq_units
!> @brief Inquiry for diag_files_obj%file_start_time
@@ -848,7 +871,7 @@ end function get_file_duration
pure function get_file_duration_units (diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- character (:), allocatable :: res !< What is returned
+ integer :: res !< What is returned
res = diag_files_obj%file_duration_units
end function get_file_duration_units
!> @brief Inquiry for diag_files_obj%file_varlist
@@ -990,7 +1013,9 @@ subroutine diag_yaml_files_obj_init(obj)
obj%file_freq = DIAG_NULL
obj%file_duration = DIAG_NULL
+ obj%file_duration_units = DIAG_NULL
obj%file_new_file_freq = DIAG_NULL
+ obj%file_new_file_freq_units = DIAG_NULL
obj%file_sub_region%tile = DIAG_NULL
end subroutine diag_yaml_files_obj_init
@@ -1004,7 +1029,7 @@ end function has_file_fname
!! @return true if obj%file_frequnit is allocated
pure logical function has_file_frequnit (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_frequnit = allocated(obj%file_frequnit)
+ has_file_frequnit = obj%file_frequnit .NE. DIAG_NULL
end function has_file_frequnit
!> @brief obj%file_freq is on the stack, so the object always has it
!! @return true if obj%file_freq is allocated
@@ -1016,7 +1041,7 @@ end function has_file_freq
!! @return true if obj%file_timeunit is allocated
pure logical function has_file_timeunit (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_timeunit = allocated(obj%file_timeunit)
+ has_file_timeunit = obj%file_timeunit .ne. diag_null
end function has_file_timeunit
!> @brief Checks if obj%file_unlimdim is allocated
!! @return true if obj%file_unlimdim is allocated
@@ -1050,7 +1075,7 @@ end function has_file_new_file_freq
!! @return true if obj%file_new_file_freq_units is allocated
pure logical function has_file_new_file_freq_units (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_new_file_freq_units = allocated(obj%file_new_file_freq_units)
+ has_file_new_file_freq_units = obj%file_new_file_freq_units .ne. diag_null
end function has_file_new_file_freq_units
!> @brief Checks if obj%file_start_time is allocated
!! @return true if obj%file_start_time is allocated
@@ -1068,7 +1093,7 @@ end function has_file_duration
!! @return true
pure logical function has_file_duration_units (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_duration_units = .true.
+ has_file_duration_units = obj%file_duration_units .ne. diag_null
end function has_file_duration_units
!> @brief Checks if obj%file_varlist is allocated
!! @return true if obj%file_varlist is allocated
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index 0ec2740a94..ad157cc321 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -25,7 +25,7 @@ program test_diag_yaml
use FMS_mod, only: fms_init, fms_end
use fms_diag_yaml_mod
use diag_data_mod, only: DIAG_NULL, DIAG_ALL, get_base_year, get_base_month, get_base_day, get_base_hour, &
- & get_base_minute, get_base_second, diag_data_init
+ & get_base_minute, get_base_second, diag_data_init, DIAG_HOURS, DIAG_NULL, DIAG_DAYS
use time_manager_mod, only: set_calendar_type, JULIAN
use mpp_mod
use platform_mod
@@ -211,13 +211,13 @@ subroutine compare_diag_files(res)
call compare_result("file_freq 2", res(2)%get_file_freq(), 24)
call compare_result("file_freq 3", res(3)%get_file_freq(), -1)
- call compare_result("file_frequnit 1", res(1)%get_file_frequnit(), "hours")
- call compare_result("file_frequnit 2", res(2)%get_file_frequnit(), "days")
- call compare_result("file_frequnit 3", res(3)%get_file_frequnit(), "days")
+ call compare_result("file_frequnit 1", res(1)%get_file_frequnit(), DIAG_HOURS)
+ call compare_result("file_frequnit 2", res(2)%get_file_frequnit(), DIAG_DAYS)
+ call compare_result("file_frequnit 3", res(3)%get_file_frequnit(), DIAG_DAYS)
- call compare_result("file_timeunit 1", res(1)%get_file_timeunit(), "hours")
- call compare_result("file_timeunit 2", res(2)%get_file_timeunit(), "hours")
- call compare_result("file_timeunit 3", res(3)%get_file_timeunit(), "hours")
+ call compare_result("file_timeunit 1", res(1)%get_file_timeunit(), DIAG_HOURS)
+ call compare_result("file_timeunit 2", res(2)%get_file_timeunit(), DIAG_HOURS)
+ call compare_result("file_timeunit 3", res(3)%get_file_timeunit(), DIAG_HOURS)
call compare_result("file_unlimdim 1", res(1)%get_file_unlimdim(), "time")
call compare_result("file_unlimdim 2", res(2)%get_file_unlimdim(), "records")
@@ -227,17 +227,17 @@ subroutine compare_diag_files(res)
call compare_result("file_new_file_freq 2", res(2)%get_file_new_file_freq(), DIAG_NULL)
call compare_result("file_new_file_freq 3", res(3)%get_file_new_file_freq(), DIAG_NULL)
- call compare_result("file_new_file_freq_units 1", res(1)%get_file_new_file_freq_units(), "hours")
- call compare_result("file_new_file_freq_units 2", res(2)%get_file_new_file_freq_units(), "")
- call compare_result("file_new_file_freq_units 3", res(3)%get_file_new_file_freq_units(), "")
+ call compare_result("file_new_file_freq_units 1", res(1)%get_file_new_file_freq_units(), DIAG_HOURS)
+ call compare_result("file_new_file_freq_units 2", res(2)%get_file_new_file_freq_units(), DIAG_NULL)
+ call compare_result("file_new_file_freq_units 3", res(3)%get_file_new_file_freq_units(), DIAG_NULL)
call compare_result("file_duration 1", res(1)%get_file_duration(), 12)
call compare_result("file_duration 2", res(2)%get_file_duration(), DIAG_NULL)
call compare_result("file_duration 3", res(3)%get_file_duration(), DIAG_NULL)
- call compare_result("file_duration_units 1", res(1)%get_file_duration_units(), "hours")
- call compare_result("file_duration_units 2", res(2)%get_file_duration_units(), "")
- call compare_result("file_duration_units 3", res(3)%get_file_duration_units(), "")
+ call compare_result("file_duration_units 1", res(1)%get_file_duration_units(), DIAG_HOURS)
+ call compare_result("file_duration_units 2", res(2)%get_file_duration_units(), DIAG_NULL)
+ call compare_result("file_duration_units 3", res(3)%get_file_duration_units(), DIAG_NULL)
call compare_result("file_start_time 1", res(1)%get_file_start_time(), "2 1 1 0 0 0")
call compare_result("file_start_time 2", res(2)%get_file_start_time(), "")
@@ -306,6 +306,8 @@ subroutine compare_result_0d(key_name, res, expected_res)
if(trim(res) .ne. trim(expected_res)) &
call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. "//trim(res)//" ne "//&
trim(expected_res)//".")
+ class default
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type")
end select
type is (integer(kind=i4_kind))
select type(expected_res)
@@ -314,6 +316,8 @@ subroutine compare_result_0d(key_name, res, expected_res)
print *, res, " ne ", expected_res
call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result.")
endif
+ class default
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type")
end select
type is (logical)
select type(expected_res)
@@ -322,6 +326,8 @@ subroutine compare_result_0d(key_name, res, expected_res)
print*, res, " ne ", expected_res
call mpp_error(FATAL, "Error!:"//trim(key_name)//" is not the expected result")
endif
+ class default
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type")
end select
end select
@@ -349,6 +355,8 @@ subroutine compare_result_1d(key_name, res, expected_res)
call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. ")
endif
enddo
+ class default
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type")
end select
type is (real(kind=r4_kind))
select type(expected_res)
@@ -359,6 +367,8 @@ subroutine compare_result_1d(key_name, res, expected_res)
call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. ")
endif
enddo
+ class default
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type")
end select
type is (real(kind=r8_kind))
select type(expected_res)
@@ -369,6 +379,8 @@ subroutine compare_result_1d(key_name, res, expected_res)
call mpp_error(FATAL, "Error!: "//trim(key_name)//" is not the expected result. ")
endif
enddo
+ class default
+ call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type")
end select
end select
end subroutine compare_result_1d
From 87a5bee1b7c49dc90304b544c472c6320a7caf18 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 8 Aug 2022 12:22:39 -0400
Subject: [PATCH 059/168] feat: modern diag add field attributes and implement
old getter routines (#998)
---
diag_manager/diag_axis.F90 | 40 ++++++---
diag_manager/diag_manager.F90 | 40 +++++++--
diag_manager/fms_diag_axis_object.F90 | 23 +++++-
diag_manager/fms_diag_file_object.F90 | 4 +-
diag_manager/fms_diag_object.F90 | 96 ++++++++++++++++------
test_fms/diag_manager/test_modern_diag.F90 | 8 +-
6 files changed, 161 insertions(+), 50 deletions(-)
diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90
index 5063b6aa94..e574b8eef3 100644
--- a/diag_manager/diag_axis.F90
+++ b/diag_manager/diag_axis.F90
@@ -39,8 +39,9 @@ MODULE diag_axis_mod
& fms_error_handler, FATAL, NOTE
USE diag_data_mod, ONLY: diag_axis_type, max_subaxes, max_axes,&
& max_num_axis_sets, max_axis_attributes, debug_diag_manager,&
- & first_send_data_call, diag_atttype, use_modern_diag
- USE fms_diag_axis_object_mod, ONLY: fms_diag_axis_init, fms_diag_axis_add_attribute
+ & first_send_data_call, diag_atttype, use_modern_diag, TWO_D_DOMAIN
+ USE fms_diag_axis_object_mod, ONLY: fms_diag_axis_init, fms_diag_axis_add_attribute, &
+ & diagDomain_t, DIAGDOMAIN2D_T, get_domain_and_domain_type, fms_get_axis_length
#ifdef use_netCDF
USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR
#endif
@@ -608,14 +609,18 @@ INTEGER FUNCTION get_axis_length(id)
INTEGER, INTENT(in) :: id !< Axis ID
INTEGER :: length
- CALL valid_id_check(id, 'get_axis_length')
- IF ( Axes(id)%Domain .NE. null_domain1d ) THEN
- CALL mpp_get_compute_domain(Axes(id)%Domain,size=length)
- !---one extra point is needed for some case. ( like symmetry domain )
- get_axis_length = length + Axes(id)%shift
- ELSE
- get_axis_length = Axes(id)%length
- END IF
+ if (use_modern_diag) then
+ get_axis_length = fms_get_axis_length(id)
+ else
+ CALL valid_id_check(id, 'get_axis_length')
+ IF ( Axes(id)%Domain .NE. null_domain1d ) THEN
+ CALL mpp_get_compute_domain(Axes(id)%Domain,size=length)
+ !---one extra point is needed for some case. ( like symmetry domain )
+ get_axis_length = length + Axes(id)%shift
+ ELSE
+ get_axis_length = Axes(id)%length
+ END IF
+ endif
END FUNCTION get_axis_length
!> @brief Return the auxiliary name for the axis.
@@ -693,11 +698,26 @@ TYPE(domain2d) FUNCTION get_domain2d(ids)
INTEGER :: i, id, flag
+ INTEGER :: type_of_domain !< The type of domain
+ CLASS(diagDomain_t), POINTER :: domain !< Diag Domain pointer
+
IF ( SIZE(ids(:)) < 1 ) THEN
! input argument has incorrect size.
CALL error_mesg('diag_axis_mod::get_domain2d', 'input argument has incorrect size', FATAL)
END IF
get_domain2d = null_domain2d
+
+ if (use_modern_diag) then
+ call get_domain_and_domain_type(ids, type_of_domain, domain, "get_domain2d")
+ if (type_of_domain .ne. TWO_D_DOMAIN) &
+ call error_mesg('diag_axis_mod::get_domain2d', 'The axis do not correspond to a 2d Domain', FATAL)
+ select type(domain)
+ type is (diagDomain2d_t)
+ get_domain2d = domain%domain2
+ end select
+ return
+ endif
+
flag = 0
DO i = 1, SIZE(ids(:))
id = ids(i)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index b84a3abf7d..ac0e15425d 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -238,7 +238,8 @@ MODULE diag_manager_mod
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
USE fms_diag_object_mod, ONLY: fmsDiagObject_type, fms_diag_object_init, fms_register_diag_field_array, &
- & fms_register_diag_field_scalar, fms_diag_object_end, fms_register_static_field
+ & fms_register_diag_field_scalar, fms_diag_object_end, fms_register_static_field, fms_diag_field_add_attribute, &
+ & fms_get_diag_field_id
USE fms_diag_file_object_mod, only: fms_diag_files_object_initialized
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field
@@ -1218,9 +1219,16 @@ INTEGER FUNCTION get_diag_field_id(module_name, field_name)
CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
+ integer :: i !< For do loops
+
+ get_diag_field_id = DIAG_FIELD_NOT_FOUND
+ if (use_modern_diag) then
+ get_diag_field_id = fms_get_diag_field_id(module_name, field_name)
+ else
! find_input_field will return DIAG_FIELD_NOT_FOUND if the field is not
! included in the diag_table
get_diag_field_id = find_input_field(module_name, field_name, tile_count=1)
+ endif
END FUNCTION get_diag_field_id
!> @brief Finds the corresponding related output field and file for a given input field
@@ -4336,7 +4344,11 @@ SUBROUTINE diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name
REAL, INTENT(in) :: att_value !< new attribute value
- CALL diag_field_add_attribute_r1d(diag_field_id, att_name, (/ att_value /))
+ if (use_modern_diag) then
+ call fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
+ else
+ CALL diag_field_add_attribute_r1d(diag_field_id, att_name, (/ att_value /))
+ endif
END SUBROUTINE diag_field_add_attribute_scalar_r
!> @brief Add a scalar integer attribute to the diag field corresponding to a given id
@@ -4345,7 +4357,11 @@ SUBROUTINE diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name
INTEGER, INTENT(in) :: att_value !< new attribute value
- CALL diag_field_add_attribute_i1d(diag_field_id, att_name, (/ att_value /))
+ if (use_modern_diag) then
+ call fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
+ else
+ CALL diag_field_add_attribute_i1d(diag_field_id, att_name, (/ att_value /))
+ endif
END SUBROUTINE diag_field_add_attribute_scalar_i
!> @brief Add a scalar character attribute to the diag field corresponding to a given id
@@ -4354,7 +4370,11 @@ SUBROUTINE diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name
CHARACTER(len=*), INTENT(in) :: att_value !< new attribute value
- CALL diag_field_attribute_init(diag_field_id, att_name, NF90_CHAR, cval=att_value)
+ if (use_modern_diag) then
+ call fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
+ else
+ CALL diag_field_attribute_init(diag_field_id, att_name, NF90_CHAR, cval=att_value)
+ endif
END SUBROUTINE diag_field_add_attribute_scalar_c
!> @brief Add a real 1D array attribute to the diag field corresponding to a given id
@@ -4363,7 +4383,11 @@ SUBROUTINE diag_field_add_attribute_r1d(diag_field_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name
REAL, DIMENSION(:), INTENT(in) :: att_value !< new attribute value
- CALL diag_field_attribute_init(diag_field_id, att_name, NF90_FLOAT, rval=att_value)
+ if (use_modern_diag) then
+ call fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
+ else
+ CALL diag_field_attribute_init(diag_field_id, att_name, NF90_FLOAT, rval=att_value)
+ endif
END SUBROUTINE diag_field_add_attribute_r1d
!> @brief Add an integer 1D array attribute to the diag field corresponding to a given id
@@ -4372,7 +4396,11 @@ SUBROUTINE diag_field_add_attribute_i1d(diag_field_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name
INTEGER, DIMENSION(:), INTENT(in) :: att_value !< new attribute value
- CALL diag_field_attribute_init(diag_field_id, att_name, NF90_INT, ival=att_value)
+ if (use_modern_diag) then
+ call fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
+ else
+ CALL diag_field_attribute_init(diag_field_id, att_name, NF90_INT, ival=att_value)
+ endif
END SUBROUTINE diag_field_add_attribute_i1d
!> @brief Add the cell_measures attribute to a diag out field
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 04a26938d4..35483fbd54 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -41,7 +41,8 @@ module fms_diag_axis_object_mod
PRIVATE
public :: diagAxis_t, set_subaxis, fms_diag_axis_init, fms_diag_axis_object_init, fms_diag_axis_object_end, &
- & get_domain_and_domain_type, axis_obj, diagDomain_t, sub_axis_objs, fms_diag_axis_add_attribute
+ & get_domain_and_domain_type, axis_obj, diagDomain_t, sub_axis_objs, fms_diag_axis_add_attribute, &
+ & DIAGDOMAIN2D_T, fms_get_axis_length
!> @}
!> @brief Type to hold the domain info for an axis
@@ -556,9 +557,10 @@ subroutine get_domain_and_domain_type(axis_id, domain_type, domain, var_name)
!! i.e a variable can have axis that are domain decomposed (x,y) and an axis that isn't (z)
if (domain_type .eq. NO_DOMAIN .or. axis_obj(j)%type_of_domain .eq. NO_DOMAIN ) then
!< Update the domain_type and domain, if needed
- if (axis_obj(j)%type_of_domain .eq. TWO_D_DOMAIN .or. axis_obj(j)%type_of_domain .eq. UG_DOMAIN) then
- domain_type = axis_obj(j)%type_of_domain
- domain => axis_obj(j)%axis_domain
+ if ((axis_obj(j)%type_of_domain .eq. TWO_D_DOMAIN .and. size(axis_id) > 2) &
+ & .or. axis_obj(j)%type_of_domain .eq. UG_DOMAIN) then
+ domain_type = axis_obj(j)%type_of_domain
+ domain => axis_obj(j)%axis_domain
endif
else
call mpp_error(FATAL, "The variable:"//trim(var_name)//" has axis that are not in the same domain")
@@ -566,6 +568,19 @@ subroutine get_domain_and_domain_type(axis_id, domain_type, domain, var_name)
endif
enddo
end subroutine get_domain_and_domain_type
+
+ !> @brief Gets the length of the axis based on the axis_id
+ !> @return Axis_length
+ function fms_get_axis_length(axis_id)&
+ result(axis_length)
+ INTEGER, INTENT(in) :: axis_id !< Axis ID of the axis to the length of
+ integer :: axis_length
+
+ if (axis_id < 0 .and. axis_id > number_of_axis) &
+ call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid")
+
+ axis_length = axis_obj(axis_id)%axis_length()
+ end function fms_get_axis_length
end module fms_diag_axis_object_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 0b20799679..a0ba7d1bff 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -481,8 +481,8 @@ subroutine add_axes(obj, axis_ids)
do i = 1, size(axis_ids)
do j = 1, obj%number_of_axis
- !> Check if the axis already exists, if it does leave this do loop
- if (axis_ids(i) .eq. obj%axis_ids(j)) exit
+ !> Check if the axis already exists, return
+ if (axis_ids(i) .eq. obj%axis_ids(j)) return
enddo
!> If the axis does not exist add it to the list
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 0f31e2d83e..fbbe5a2c0c 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -9,7 +9,9 @@ module fms_diag_object_mod
!! appropriate buffer for the data for manipulation.
use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string
use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN
-use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id
+use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type
+use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
+ &DIAG_FIELD_NOT_FOUND
use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
@@ -65,7 +67,8 @@ module fms_diag_object_mod
!! belongs to
#endif
integer, allocatable, private :: diag_id !< unique id for varable
- character(len=:), allocatable, dimension(:) :: metadata !< metadata for the variable
+ type(fmsDiagAttribute_type), allocatable :: attributes(:) !< attributes for the variable
+ integer, private :: num_attributes !< Number of attributes currently added
logical, allocatable, private :: static !< true if this is a static var
logical, allocatable, private :: registered !< true when registered
logical, allocatable, private :: mask_variant !< If there is a mask variant
@@ -120,7 +123,7 @@ module fms_diag_object_mod
! Is variable allocated check functions
!TODO procedure :: has_diag_field
procedure :: has_diag_id
- procedure :: has_metadata
+ procedure :: has_attributes
procedure :: has_static
procedure :: has_registered
procedure :: has_mask_variant
@@ -144,7 +147,7 @@ module fms_diag_object_mod
procedure :: has_data_RANGE
! Get functions
procedure :: get_diag_id => fms_diag_get_id
- procedure :: get_metadata
+ procedure :: get_attributes
procedure :: get_static
procedure :: get_registered
procedure :: get_mask_variant
@@ -189,7 +192,9 @@ module fms_diag_object_mod
public :: fms_register_diag_field_array
public :: fms_register_diag_field_scalar
public :: fms_register_static_field
+public :: fms_diag_field_add_attribute
public :: get_diag_obj_from_id
+public :: fms_get_diag_field_id
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
CONTAINS
@@ -238,7 +243,7 @@ subroutine fms_register_diag_field_obj &
!(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
(dobj, modname, varname, diag_field_indices, axes, init_time, &
longname, units, missing_value, varRange, mask_variant, standname, &
- do_not_log, err_msg, interp_method, tile_count, area, volume, realm, metadata)
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
class(fmsDiagObject_type), INTENT(inout) :: dobj !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: modname !< The module name
@@ -264,7 +269,6 @@ subroutine fms_register_diag_field_obj &
INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
!! modeling_realm attribute
- character(len=*), optional, INTENT(in) :: metadata(:) !< metedata for the variable
integer :: i !< For do loops
integer :: j !< dobj%file_ids(i) (for less typing :)
@@ -306,10 +310,6 @@ subroutine fms_register_diag_field_obj &
dobj%tile_count = tile_count
endif
- if (present(metadata)) then
- allocate(character(len=MAX_LEN_META) :: dobj%metadata(size(metadata)))
- dobj%metadata = metadata
- endif
if (present(missing_value)) then
select type (missing_value)
type is (integer(kind=i4_kind))
@@ -392,6 +392,10 @@ subroutine fms_register_diag_field_obj &
dobj%do_not_log = do_not_log
endif
+ !< Allocate space for any additional variable attributes
+ !< These will be fill out when calling `diag_field_add_attribute`
+ allocate(dobj%attributes(max_field_attributes))
+ dobj%num_attributes = 0
dobj%registered = .true.
#endif
end subroutine fms_register_diag_field_obj
@@ -483,7 +487,7 @@ subroutine copy_diag_obj(objin , objout)
endif
objout%diag_id = objin%diag_id
- if (allocated(objin%metadata)) objout%metadata = objin%metadata
+ if (allocated(objin%attributes)) objout%attributes = objin%attributes
objout%static = objin%static
if (allocated(objin%frequency)) objout%frequency = objin%frequency
if (allocated(objin%varname)) objout%varname = objin%varname
@@ -567,20 +571,16 @@ end function diag_obj_is_static
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Get functions
-!> @brief Gets metedata
-!! @return copy of metadata string array, or a single space if metadata is not allocated
-pure function get_metadata (obj) &
+!> @brief Gets attributes
+!! @return A pointer to the attributes of the diag_obj, null pointer if there are no attributes
+function get_attributes (obj) &
result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- character(len=:), allocatable, dimension(:) :: rslt
- if (allocated(obj%metadata)) then
- allocate(character(len=(len(obj%metadata))) :: rslt (size(obj%metadata)) )
- rslt = obj%metadata
- else
- allocate(character(len=1) :: rslt(1:1))
- rslt = diag_null_string
- endif
-end function get_metadata
+ class (fmsDiagObject_type), target, intent(in) :: obj !< diag object
+ type(fmsDiagAttribute_type), pointer :: rslt(:)
+
+ rslt => null()
+ if (obj%num_attributes > 0 ) rslt => obj%attributes
+end function get_attributes
!> @brief Gets static
!! @return copy of variable static
pure function get_static (obj) &
@@ -1008,10 +1008,10 @@ pure logical function has_diag_id (obj)
end function has_diag_id
!> @brief Checks if obj%metadata is allocated
!! @return true if obj%metadata is allocated
-pure logical function has_metadata (obj)
+pure logical function has_attributes (obj)
class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_metadata = allocated(obj%metadata)
-end function has_metadata
+ has_attributes = obj%num_attributes > 0
+end function has_attributes
!> @brief Checks if obj%static is allocated
!! @return true if obj%static is allocated
pure logical function has_static (obj)
@@ -1297,4 +1297,46 @@ FUNCTION get_diag_obj_from_id ( id ) result (obj_ptr)
obj_ptr => diag_objs(id)
END IF
END FUNCTION get_diag_obj_from_id
+
+!> @brief Add a attribute to the diag_obj using the diag_field_id
+subroutine fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
+ integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to
+ character(len=*), intent(in) :: att_name !< Name of the attribute
+ class(*), intent(in) :: att_value(:) !< The attribute value to add
+
+ type(fmsDiagObject_type), pointer :: obj
+
+ obj => get_diag_obj_from_id ( diag_field_id )
+ if (.not. associated(obj)) return
+
+ obj%num_attributes = obj%num_attributes + 1
+ if (obj%num_attributes > max_field_attributes) &
+ call mpp_error(FATAL, "diag_field_add_attribute: Number of attributes exceeds max_field_attributes for field:"&
+ //trim(obj%varname)//". Increase diag_manager_nml:max_field_attributes.")
+
+ call obj%attributes(obj%num_attributes)%add(att_name, att_value)
+ nullify(obj)
+end subroutine fms_diag_field_add_attribute
+
+!> @brief Determines the diag_obj id corresponding to a module name and field_name
+!> @return diag_obj id
+PURE FUNCTION fms_get_diag_field_id(module_name, field_name) &
+ result(diag_field_id)
+
+ CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
+ CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
+
+ integer :: diag_field_id
+ integer :: i !< For do loops
+
+ diag_field_id = DIAG_FIELD_NOT_FOUND
+ do i = 1, registered_variables
+ if (diag_objs(i)%get_varname() .eq. trim(field_name) .and. &
+ diag_objs(i)%get_modname() .eq. trim(module_name)) then
+ diag_field_id = i
+ return
+ endif
+ enddo
+end function fms_get_diag_field_id
+
end module fms_diag_object_mod
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index 13e4c0b6f2..57e5b55745 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -26,7 +26,7 @@ program test_modern_diag
mpp_get_compute_domain, mpp_get_data_domain, mpp_get_UG_domain_grid_index, &
mpp_get_UG_compute_domain
use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
- diag_axis_add_attribute
+ diag_axis_add_attribute, diag_field_add_attribute
use fms_mod, only: fms_init, fms_end
use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast
use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time
@@ -143,6 +143,12 @@ program test_modern_diag
if (id_var6 .ne. 6) call mpp_error(FATAL, "var6 does not have the expected id")
if (id_var7 .ne. 7) call mpp_error(FATAL, "var7 does not have the expected id")
+call diag_field_add_attribute (id_var1, "some string", "this is a string")
+call diag_field_add_attribute (id_var1, "integer", 10)
+call diag_field_add_attribute (id_var1, "1d integer", (/10, 10/))
+call diag_field_add_attribute (id_var1, "real", 10.)
+call diag_field_add_attribute (id_var2, '1d real', (/10./))
+
call diag_manager_end(Time)
call fms_end
From e0a2cd4ce365c0f684f83fe29d2f082049478af9 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 15 Aug 2022 14:37:04 -0400
Subject: [PATCH 060/168] feat: Modern diag_manager use integer parameters
instead of strings (#1016)
---
diag_manager/diag_data.F90 | 9 +-
diag_manager/fms_diag_yaml.F90 | 175 +++++++++++++----------
test_fms/diag_manager/test_diag_yaml.F90 | 15 +-
3 files changed, 117 insertions(+), 82 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index b149dce2a4..d54468aec3 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -112,7 +112,14 @@ MODULE diag_data_mod
INTEGER, PARAMETER :: latlon_gridtype = 1
INTEGER, PARAMETER :: index_gridtype = 2
INTEGER, PARAMETER :: null_gridtype = DIAG_NULL
-
+ INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method
+ INTEGER, PARAMETER :: time_average = 1 !< The reduction method is avera
+ INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms
+ INTEGER, PARAMETER :: time_max = 3 !< The reduction method is max
+ INTEGER, PARAMETER :: time_min = 4 !< The reduction method is min
+ INTEGER, PARAMETER :: time_sum = 5 !< The reudction method is sum
+ INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal
+ INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power
!> @}
!> @brief Contains the coordinates of the local domain to output.
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index e436e1a2a5..2262fffb64 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -32,7 +32,8 @@ module fms_diag_yaml_mod
#ifdef use_yaml
use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER, set_base_time, latlon_gridtype, &
index_gridtype, null_gridtype, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, &
- DIAG_MONTHS, DIAG_YEARS
+ DIAG_MONTHS, DIAG_YEARS, time_average, time_rms, time_max, time_min, time_sum, &
+ time_diurnal, time_power, time_none, r8, i8, r4, i4
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL
@@ -137,19 +138,19 @@ module fms_diag_yaml_mod
procedure :: is_global_meta
!> Has functions to determine if allocatable variables are true. If a variable is not an allocatable
!! then is will always return .true.
- procedure :: has_file_fname
- procedure :: has_file_frequnit
- procedure :: has_file_freq
- procedure :: has_file_timeunit
- procedure :: has_file_unlimdim
- procedure :: has_file_sub_region
- procedure :: has_file_new_file_freq
- procedure :: has_file_new_file_freq_units
- procedure :: has_file_start_time
- procedure :: has_file_duration
- procedure :: has_file_duration_units
- procedure :: has_file_varlist
- procedure :: has_file_global_meta
+ procedure :: has_file_fname
+ procedure :: has_file_frequnit
+ procedure :: has_file_freq
+ procedure :: has_file_timeunit
+ procedure :: has_file_unlimdim
+ procedure :: has_file_sub_region
+ procedure :: has_file_new_file_freq
+ procedure :: has_file_new_file_freq_units
+ procedure :: has_file_start_time
+ procedure :: has_file_duration
+ procedure :: has_file_duration_units
+ procedure :: has_file_varlist
+ procedure :: has_file_global_meta
end type diagYamlFiles_type
@@ -157,9 +158,11 @@ module fms_diag_yaml_mod
type diagYamlFilesVar_type
character (len=:), private, allocatable :: var_fname !< The field/diagnostic name
character (len=:), private, allocatable :: var_varname !< The name of the variable
- character (len=:), private, allocatable :: var_reduction !< Reduction to be done on var
+ integer , private, allocatable :: var_reduction !< Reduction to be done on var
+ !! time_average, time_rms, time_max,
+ !! time_min, time_sum, time_diurnal, time_power
character (len=:), private, allocatable :: var_module !< The module that th variable is in
- character (len=:), private, allocatable :: var_skind !< The type/kind of the variable
+ integer , private, allocatable :: var_kind !< The type/kind of the variable
character (len=:), private, allocatable :: var_outname !< Name of the variable as written to the file
character (len=:), private, allocatable :: var_longname !< Overwrites the long name of the variable
character (len=:), private, allocatable :: var_units !< Overwrites the units
@@ -178,7 +181,7 @@ module fms_diag_yaml_mod
procedure :: get_var_varname
procedure :: get_var_reduction
procedure :: get_var_module
- procedure :: get_var_skind
+ procedure :: get_var_kind
procedure :: get_var_outname
procedure :: get_var_longname
procedure :: get_var_units
@@ -187,15 +190,15 @@ module fms_diag_yaml_mod
procedure :: get_pow_value
procedure :: is_var_attributes
- procedure :: has_var_fname
- procedure :: has_var_varname
- procedure :: has_var_reduction
- procedure :: has_var_module
- procedure :: has_var_skind
- procedure :: has_var_outname
- procedure :: has_var_longname
- procedure :: has_var_units
- procedure :: has_var_attributes
+ procedure :: has_var_fname
+ procedure :: has_var_varname
+ procedure :: has_var_reduction
+ procedure :: has_var_module
+ procedure :: has_var_kind
+ procedure :: has_var_outname
+ procedure :: has_var_longname
+ procedure :: has_var_units
+ procedure :: has_var_attributes
procedure :: has_n_diurnal
procedure :: has_pow_value
@@ -216,10 +219,10 @@ module fms_diag_yaml_mod
procedure :: get_diag_files !< Returns the diag_files array
procedure :: get_diag_fields !< Returns the diag_field array
- procedure :: has_diag_title
- procedure :: has_diag_basedate
+ procedure :: has_diag_title
+ procedure :: has_diag_basedate
procedure :: has_diag_files
- procedure :: has_diag_fields
+ procedure :: has_diag_fields
end type diagYamlObject_type
@@ -528,14 +531,16 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field)
integer :: j !< For do loops
integer, allocatable :: key_ids(:) !< Id of each attribute key/value pair
+ character(len=:), ALLOCATABLE :: buffer !< buffer to store the reduction method as it is read from the yaml
call diag_get_value_from_key(diag_file_id, var_id, "var_name", field%var_varname)
- call diag_get_value_from_key(diag_file_id, var_id, "reduction", field%var_reduction)
- call check_field_reduction(field)
+ call diag_get_value_from_key(diag_file_id, var_id, "reduction", buffer)
+ call set_field_reduction(field, buffer)
call diag_get_value_from_key(diag_file_id, var_id, "module", field%var_module)
- call diag_get_value_from_key(diag_file_id, var_id, "kind", field%var_skind)
- call check_field_kind(field)
+ deallocate(buffer)
+ call diag_get_value_from_key(diag_file_id, var_id, "kind", buffer)
+ call set_field_kind(field, buffer)
call diag_get_value_from_key(diag_file_id, var_id, "output_name", field%var_outname, is_optional=.true.)
call diag_get_value_from_key(diag_file_id, var_id, "long_name", field%var_longname, is_optional=.true.)
@@ -694,24 +699,33 @@ subroutine set_file_duration(fileobj, file_duration_units)
endif
end subroutine set_file_duration
-!> @brief This checks if the kind of a diag field is valid and crashes if it isn't
-subroutine check_field_kind(field)
- type(diagYamlFilesVar_type), intent(in) :: field !< diagYamlFilesVar_type obj to read the contents into
-
- select case (TRIM(field%var_skind))
- case ("r4", "r8", "i4", "i8")
+!> @brief This checks if the kind of a diag field is valid and sets it
+subroutine set_field_kind(field, skind)
+ type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into
+ character(len=*), intent(in) :: skind !< The variable kind as read from diag_yaml
+
+ select case (TRIM(skind))
+ case ("r4")
+ field%var_kind = r4
+ case ("r8")
+ field%var_kind = r8
+ case ("i4")
+ field%var_kind = i4
+ case ("i8")
+ field%var_kind = i8
case default
- call mpp_error(FATAL, trim(field%var_skind)//" is an invalid kind! &
+ call mpp_error(FATAL, trim(skind)//" is an invalid kind! &
&The acceptable values are r4, r8, i4, i8. &
&Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
end select
-end subroutine check_field_kind
+end subroutine set_field_kind
-!> @brief This checks if the reduction of a diag field is valid and crashes if it isn't
+!> @brief This checks if the reduction of a diag field is valid and sets it
!! If the reduction method is diurnalXX or powXX, it gets the number of diurnal sample and the power value
-subroutine check_field_reduction(field)
- type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into
+subroutine set_field_reduction(field, reduction_method)
+ type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into
+ character(len=*) , intent(in) :: reduction_method!< reduction method as read from the yaml
integer :: n_diurnal !< number of diurnal samples
integer :: pow_value !< The power value
@@ -720,25 +734,38 @@ subroutine check_field_reduction(field)
n_diurnal = 0
pow_value = 0
ioerror = 0
- if (index(field%var_reduction, "diurnal") .ne. 0) then
- READ (UNIT=field%var_reduction(8:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) n_diurnal
+ if (index(reduction_method, "diurnal") .ne. 0) then
+ READ (UNIT=reduction_method(8:LEN_TRIM(reduction_method)), FMT=*, IOSTAT=ioerror) n_diurnal
if (ioerror .ne. 0) &
- call mpp_error(FATAL, "Error getting the number of diurnal samples from "//trim(field%var_reduction))
+ call mpp_error(FATAL, "Error getting the number of diurnal samples from "//trim(reduction_method))
if (n_diurnal .le. 0) &
call mpp_error(FATAL, "Diurnal samples should be greater than 0. &
& Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
- elseif (index(field%var_reduction, "pow") .ne. 0) then
- READ (UNIT=field%var_reduction(4:LEN_TRIM(field%var_reduction)), FMT=*, IOSTAT=ioerror) pow_value
+ field%var_reduction = time_diurnal
+ elseif (index(reduction_method, "pow") .ne. 0) then
+ READ (UNIT=reduction_method(4:LEN_TRIM(reduction_method)), FMT=*, IOSTAT=ioerror) pow_value
if (ioerror .ne. 0) &
- call mpp_error(FATAL, "Error getting the power value from "//trim(field%var_reduction))
+ call mpp_error(FATAL, "Error getting the power value from "//trim(reduction_method))
if (pow_value .le. 0) &
call mpp_error(FATAL, "The power value should be greater than 0. &
& Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
+ field%var_reduction = time_power
else
- select case (TRIM(field%var_reduction))
- case ("none", "average", "min", "max", "rms")
+ select case (reduction_method)
+ case ("none")
+ field%var_reduction = time_none
+ case ("average")
+ field%var_reduction = time_average
+ case ("min")
+ field%var_reduction = time_min
+ case ("max")
+ field%var_reduction = time_max
+ case ("rms")
+ field%var_reduction = time_rms
+ case ("sum")
+ field%var_reduction = time_sum
case default
- call mpp_error(FATAL, trim(field%var_reduction)//" is an invalid reduction method! &
+ call mpp_error(FATAL, trim(reduction_method)//" is an invalid reduction method! &
&The acceptable values are none, average, pow##, diurnal##, min, max, and rms. &
&Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
end select
@@ -746,7 +773,7 @@ subroutine check_field_reduction(field)
field%n_diurnal = n_diurnal
field%pow_value = pow_value
-end subroutine check_field_reduction
+end subroutine set_field_reduction
!> @brief This checks if a time unit is valid and if it is, it assigns the integer equivalent
!! @return The integer equivalent to the time units
@@ -928,7 +955,7 @@ end function get_var_varname
pure function get_var_reduction (diag_var_obj) &
result (res)
class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
+ integer, allocatable :: res !< What is returned
res = diag_var_obj%var_reduction
end function get_var_reduction
!> @brief Inquiry for diag_yaml_files_var_obj%var_module
@@ -939,14 +966,14 @@ pure function get_var_module (diag_var_obj) &
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_module
end function get_var_module
-!> @brief Inquiry for diag_yaml_files_var_obj%var_skind
-!! @return var_skind of a diag_yaml_files_var_obj
-pure function get_var_skind (diag_var_obj) &
+!> @brief Inquiry for diag_yaml_files_var_obj%var_kind
+!! @return var_kind of a diag_yaml_files_var_obj
+pure function get_var_kind (diag_var_obj) &
result (res)
class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
- character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_skind
-end function get_var_skind
+ integer, allocatable :: res !< What is returned
+ res = diag_var_obj%var_kind
+end function get_var_kind
!> @brief Inquiry for diag_yaml_files_var_obj%var_outname
!! @return var_outname of a diag_yaml_files_var_obj
pure function get_var_outname (diag_var_obj) &
@@ -1050,7 +1077,7 @@ pure logical function has_file_unlimdim (obj)
has_file_unlimdim = allocated(obj%file_unlimdim)
end function has_file_unlimdim
!> @brief Checks if obj%file_write is on the stack, so this will always be true
-!! @return true
+!! @return true
pure logical function has_file_write (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
has_file_write = .true.
@@ -1066,7 +1093,7 @@ pure logical function has_file_sub_region (obj)
endif
end function has_file_sub_region
!> @brief obj%file_new_file_freq is defined on the stack, so this will return true
-!! @return true
+!! @return true
pure logical function has_file_new_file_freq (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
has_file_new_file_freq = .true.
@@ -1084,13 +1111,13 @@ pure logical function has_file_start_time (obj)
has_file_start_time = allocated(obj%file_start_time)
end function has_file_start_time
!> @brief obj%file_duration is allocated on th stack, so this is always true
-!! @return true
+!! @return true
pure logical function has_file_duration (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
has_file_duration = .true.
end function has_file_duration
!> @brief obj%file_duration_units is on the stack, so this will retrun true
-!! @return true
+!! @return true
pure logical function has_file_duration_units (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
has_file_duration_units = obj%file_duration_units .ne. diag_null
@@ -1132,14 +1159,14 @@ pure logical function has_var_module (obj)
class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
has_var_module = allocated(obj%var_module)
end function has_var_module
-!> @brief Checks if obj%var_skind is allocated
-!! @return true if obj%var_skind is allocated
-pure logical function has_var_skind (obj)
+!> @brief Checks if obj%var_kind is allocated
+!! @return true if obj%var_kind is allocated
+pure logical function has_var_kind (obj)
class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_skind = allocated(obj%var_skind)
-end function has_var_skind
+ has_var_kind = allocated(obj%var_kind)
+end function has_var_kind
!> @brief obj%var_write is on the stack, so this returns true
-!! @return true
+!! @return true
pure logical function has_var_write (obj)
class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
has_var_write = .true.
@@ -1186,13 +1213,13 @@ end function has_pow_value
pure logical function has_diag_title (obj)
class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
has_diag_title = allocated(obj%diag_title)
-end function has_diag_title
+end function has_diag_title
!> @brief obj%diag_basedate is on the stack, so this is always true
!! @return true
pure logical function has_diag_basedate (obj)
class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
has_diag_basedate = .true.
-end function has_diag_basedate
+end function has_diag_basedate
!> @brief Checks if obj%diag_files is allocated
!! @return true if obj%diag_files is allocated
pure logical function has_diag_files (obj)
@@ -1204,7 +1231,7 @@ end function has_diag_files
pure logical function has_diag_fields (obj)
class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
has_diag_fields = allocated(obj%diag_fields)
-end function has_diag_fields
+end function has_diag_fields
!> @brief Determine the number of unique diag_fields in the diag_yaml_object
!! @return The number of unique diag_fields
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index ad157cc321..bd26afcb1e 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -25,7 +25,8 @@ program test_diag_yaml
use FMS_mod, only: fms_init, fms_end
use fms_diag_yaml_mod
use diag_data_mod, only: DIAG_NULL, DIAG_ALL, get_base_year, get_base_month, get_base_day, get_base_hour, &
- & get_base_minute, get_base_second, diag_data_init, DIAG_HOURS, DIAG_NULL, DIAG_DAYS
+ & get_base_minute, get_base_second, diag_data_init, DIAG_HOURS, DIAG_NULL, DIAG_DAYS, &
+ & time_average, r4
use time_manager_mod, only: set_calendar_type, JULIAN
use mpp_mod
use platform_mod
@@ -163,17 +164,17 @@ subroutine compare_diag_fields(res)
call compare_result("var_varname 2", res(2)%get_var_varname(), "sst")
call compare_result("var_varname 3", res(3)%get_var_varname(), "sstt")
- call compare_result("var_reduction 1", res(1)%get_var_reduction(), "average")
- call compare_result("var_reduction 2", res(2)%get_var_reduction(), "average")
- call compare_result("var_reduction 3", res(3)%get_var_reduction(), "average")
+ call compare_result("var_reduction 1", res(1)%get_var_reduction(), time_average)
+ call compare_result("var_reduction 2", res(2)%get_var_reduction(), time_average)
+ call compare_result("var_reduction 3", res(3)%get_var_reduction(), time_average)
call compare_result("var_module 1", res(1)%get_var_module(), "test_diag_manager_mod")
call compare_result("var_module 2", res(2)%get_var_module(), "test_diag_manager_mod")
call compare_result("var_module 3", res(3)%get_var_module(), "test_diag_manager_mod")
- call compare_result("var_skind 1", res(1)%get_var_skind(), "r4")
- call compare_result("var_skind 2", res(2)%get_var_skind(), "r4")
- call compare_result("var_skind 3", res(3)%get_var_skind(), "r4")
+ call compare_result("var_kind 1", res(1)%get_var_kind(), r4)
+ call compare_result("var_kind 2", res(2)%get_var_kind(), r4)
+ call compare_result("var_kind 3", res(3)%get_var_kind(), r4)
call compare_result("var_outname 1", res(1)%get_var_outname(), "sst")
call compare_result("var_outname 2", res(2)%get_var_outname(), "sst")
From f01730fb2e4f2deaaef0806bf15b8c023fd16216 Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Mon, 15 Aug 2022 15:23:42 -0400
Subject: [PATCH 061/168] feat: redesign objects and add diag field object
(#1017)
---
CMakeLists.txt | 1 +
diag_manager/Makefile.am | 8 +-
diag_manager/diag_manager.F90 | 36 +-
diag_manager/fms_diag_field_object.F90 | 912 ++++++++++++++
diag_manager/fms_diag_file_object.F90 | 140 ++-
diag_manager/fms_diag_object.F90 | 1322 +++-----------------
diag_manager/fms_diag_object_container.F90 | 19 +-
diag_manager/fms_diag_yaml.F90 | 12 +-
8 files changed, 1214 insertions(+), 1236 deletions(-)
create mode 100644 diag_manager/fms_diag_field_object.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index b6f6b95e4f..20104a36bf 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -133,6 +133,7 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_object.F90
diag_manager/fms_diag_yaml.F90
diag_manager/fms_diag_file_object.F90
+ diag_manager/fms_diag_field_object.F90
diag_manager/fms_diag_axis_object.F90
diag_manager/fms_diag_dlinked_list.F90
diag_manager/fms_diag_object_container.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index dc0fc141ca..caf2dc773e 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -46,6 +46,7 @@ libdiag_manager_la_SOURCES = \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh \
fms_diag_file_object.F90 \
+ fms_diag_field_object.F90 \
fms_diag_yaml.F90 \
fms_diag_object.F90 \
fms_diag_axis_object.F90 \
@@ -60,9 +61,11 @@ diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT
diag_grid_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
-fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
+fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
diag_util_mod.$(FC_MODEXT)
-fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
+ diag_util_mod.$(FC_MODEXT)
+fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT)
fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
@@ -89,6 +92,7 @@ MODFILES = \
include/fms_diag_fieldbuff_update.fh
fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_file_object_mod.$(FC_MODEXT) \
+ fms_diag_field_object_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) \
fms_diag_axis_object_mod.$(FC_MODEXT) \
fms_diag_dlinked_list_mod.$(FC_MODEXT) \
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index ac0e15425d..7c8f79dcf2 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -237,15 +237,11 @@ MODULE diag_manager_mod
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
- USE fms_diag_object_mod, ONLY: fmsDiagObject_type, fms_diag_object_init, fms_register_diag_field_array, &
- & fms_register_diag_field_scalar, fms_diag_object_end, fms_register_static_field, fms_diag_field_add_attribute, &
- & fms_get_diag_field_id
- USE fms_diag_file_object_mod, only: fms_diag_files_object_initialized
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field
use fms_diag_axis_object_mod, only: fms_diag_axis_object_end, fms_diag_axis_object_init
- use fms_diag_file_object_mod, only: fms_diag_files_object_init
#endif
+ use fms_diag_object_mod, only:fms_diag_object
USE constants_mod, ONLY: SECONDS_PER_DAY
USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type
@@ -402,8 +398,9 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
if (use_modern_diag) then
- register_diag_field_scalar = fms_register_diag_field_scalar(module_name, field_name, init_time, &
- & long_name=long_name, units=units, missing_value=missing_value, var_range=range, standard_name=standard_name, &
+ register_diag_field_scalar = fms_diag_object%fms_register_diag_field_scalar( &
+ & module_name, field_name, init_time, long_name=long_name, units=units, &
+ & missing_value=missing_value, var_range=range, standard_name=standard_name, &
& do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
else
register_diag_field_scalar = register_diag_field_scalar_old(module_name, field_name, init_time, &
@@ -440,8 +437,9 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
if (use_modern_diag) then
- register_diag_field_array = fms_register_diag_field_array(module_name, field_name, axes, init_time, &
- & long_name=long_name, units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
+ register_diag_field_array = fms_diag_object%fms_register_diag_field_array( &
+ & module_name, field_name, axes, init_time, long_name=long_name, &
+ & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
& standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
& interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
else
@@ -488,7 +486,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
END IF
if (use_modern_diag) then
- register_static_field = fms_register_static_field(module_name, field_name, axes, &
+ register_static_field = fms_diag_object%fms_register_static_field(module_name, field_name, axes, &
& long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
& standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,&
& tile_count=tile_count, area=area, volume=volume, realm=realm)
@@ -1223,7 +1221,7 @@ INTEGER FUNCTION get_diag_field_id(module_name, field_name)
get_diag_field_id = DIAG_FIELD_NOT_FOUND
if (use_modern_diag) then
- get_diag_field_id = fms_get_diag_field_id(module_name, field_name)
+ get_diag_field_id = fms_diag_object%fms_get_diag_field_id_from_name(module_name, field_name)
else
! find_input_field will return DIAG_FIELD_NOT_FOUND if the field is not
! included in the diag_table
@@ -3828,7 +3826,7 @@ SUBROUTINE diag_manager_end(time)
if (use_modern_diag) then
call diag_yaml_object_end
call fms_diag_axis_object_end()
- call fms_diag_object_end()
+ call fms_diag_object%diag_end()
endif
#endif
END SUBROUTINE diag_manager_end
@@ -4045,9 +4043,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
if (use_modern_diag) then
CALL diag_yaml_object_init(diag_subset_output)
CALL fms_diag_axis_object_init()
- CALL fms_diag_object_init(255, 255) !< TO DO: MAX_LEN_VARNAME and MAX_LEN_META are supposed to be read from
- !! the namelist and sent to fms_diag_object
- fms_diag_files_object_initialized = fms_diag_files_object_init ()
+ CALL fms_diag_object%init(diag_subset_output)
endif
#else
if (use_modern_diag) &
@@ -4345,7 +4341,7 @@ SUBROUTINE diag_field_add_attribute_scalar_r(diag_field_id, att_name, att_value)
REAL, INTENT(in) :: att_value !< new attribute value
if (use_modern_diag) then
- call fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
+ call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
else
CALL diag_field_add_attribute_r1d(diag_field_id, att_name, (/ att_value /))
endif
@@ -4358,7 +4354,7 @@ SUBROUTINE diag_field_add_attribute_scalar_i(diag_field_id, att_name, att_value)
INTEGER, INTENT(in) :: att_value !< new attribute value
if (use_modern_diag) then
- call fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
+ call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
else
CALL diag_field_add_attribute_i1d(diag_field_id, att_name, (/ att_value /))
endif
@@ -4371,7 +4367,7 @@ SUBROUTINE diag_field_add_attribute_scalar_c(diag_field_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_value !< new attribute value
if (use_modern_diag) then
- call fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
+ call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, (/att_value /))
else
CALL diag_field_attribute_init(diag_field_id, att_name, NF90_CHAR, cval=att_value)
endif
@@ -4384,7 +4380,7 @@ SUBROUTINE diag_field_add_attribute_r1d(diag_field_id, att_name, att_value)
REAL, DIMENSION(:), INTENT(in) :: att_value !< new attribute value
if (use_modern_diag) then
- call fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
+ call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
else
CALL diag_field_attribute_init(diag_field_id, att_name, NF90_FLOAT, rval=att_value)
endif
@@ -4397,7 +4393,7 @@ SUBROUTINE diag_field_add_attribute_i1d(diag_field_id, att_name, att_value)
INTEGER, DIMENSION(:), INTENT(in) :: att_value !< new attribute value
if (use_modern_diag) then
- call fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
+ call fms_diag_object%fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
else
CALL diag_field_attribute_init(diag_field_id, att_name, NF90_INT, ival=att_value)
endif
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
new file mode 100644
index 0000000000..559bd4e423
--- /dev/null
+++ b/diag_manager/fms_diag_field_object.F90
@@ -0,0 +1,912 @@
+module fms_diag_field_object_mod
+!> \author Tom Robinson
+!> \email thomas.robinson@noaa.gov
+!! \brief Contains routines for the diag_objects
+!!
+!! \description The diag_manager passes an object back and forth between the diag routines and the users.
+!! The procedures of this object and the types are all in this module. The fms_dag_object is a type
+!! that contains all of the information of the variable. It is extended by a type that holds the
+!! appropriate buffer for the data for manipulation.
+#ifdef use_yaml
+use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string
+use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN
+use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type
+use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
+ &DIAG_FIELD_NOT_FOUND
+
+use diag_axis_mod, only: diag_axis_type
+use mpp_mod, only: fatal, note, warning, mpp_error
+use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, &
+ & find_diag_field, get_num_unique_fields
+use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type
+use time_manager_mod, ONLY: time_type
+!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
+!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
+!!! & get_ticks_per_second
+
+use platform_mod
+use iso_c_binding
+
+implicit none
+
+!> \brief Object that holds all variable information
+type fmsDiagField_type
+ type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable
+ integer, allocatable, dimension(:) :: file_ids !< Ids of the FMS_diag_files the variable
+ !! belongs to
+ integer, allocatable, private :: diag_id !< unique id for varable
+ type(fmsDiagAttribute_type), allocatable :: attributes(:) !< attributes for the variable
+ integer, private :: num_attributes !< Number of attributes currently added
+ logical, allocatable, private :: static !< true if this is a static var
+ logical, allocatable, private :: registered !< true when registered
+ logical, allocatable, private :: mask_variant !< If there is a mask variant
+ logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field
+ logical, allocatable, private :: local !< If the output is local
+ TYPE(time_type), private :: init_time !< The initial time
+ integer, allocatable, private :: vartype !< the type of varaible
+ character(len=:), allocatable, private :: varname !< the name of the variable
+ character(len=:), allocatable, private :: longname !< longname of the variable
+ character(len=:), allocatable, private :: standname !< standard name of the variable
+ character(len=:), allocatable, private :: units !< the units
+ character(len=:), allocatable, private :: modname !< the module
+ character(len=:), allocatable, private :: realm !< String to set as the value
+ !! to the modeling_realm attribute
+ character(len=:), allocatable, private :: interp_method !< The interp method to be used
+ !! when regridding the field in post-processing.
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ integer, allocatable, dimension(:), private :: frequency !< specifies the frequency
+ integer, allocatable, private :: tile_count !< The number of tiles
+ integer, allocatable, dimension(:), private :: axis_ids !< variable axis IDs
+ class(diagDomain_t), pointer, private :: domain !< Domain
+ INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN",
+ !! "TWO_D_DOMAIN", or "UG_DOMAIN")
+ integer, allocatable, private :: area, volume !< The Area and Volume
+ class(*), allocatable, private :: missing_value !< The missing fill value
+ class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data
+ contains
+! procedure :: send_data => fms_send_data !!TODO
+! Get ID functions
+ procedure :: get_id => fms_diag_get_id
+ procedure :: id_from_name => diag_field_id_from_name
+ procedure :: copy => copy_diag_obj
+ procedure :: register => fms_register_diag_field_obj !! Merely initialize fields.
+ procedure :: setID => set_diag_id
+ procedure :: set_type => set_vartype
+ procedure :: add_attribute => diag_field_add_attribute
+ procedure :: vartype_inq => what_is_vartype
+! Check functions
+ procedure :: is_static => diag_obj_is_static
+ procedure :: is_registered => get_registered
+ procedure :: is_registeredB => diag_obj_is_registered
+ procedure :: is_mask_variant => get_mask_variant
+ procedure :: is_local => get_local
+! Is variable allocated check functions
+!TODO procedure :: has_diag_field
+ procedure :: has_diag_id
+ procedure :: has_attributes
+ procedure :: has_static
+ procedure :: has_registered
+ procedure :: has_mask_variant
+ procedure :: has_local
+!TODO procedure :: has_init_time
+ procedure :: has_vartype
+ procedure :: has_varname
+ procedure :: has_longname
+ procedure :: has_standname
+ procedure :: has_units
+ procedure :: has_modname
+ procedure :: has_realm
+ procedure :: has_interp_method
+ procedure :: has_frequency
+ procedure :: has_tile_count
+ procedure :: has_area
+ procedure :: has_volume
+ procedure :: has_missing_value
+ procedure :: has_data_RANGE
+! Get functions
+ procedure :: get_attributes
+ procedure :: get_static
+ procedure :: get_registered
+ procedure :: get_mask_variant
+ procedure :: get_local
+ procedure :: get_vartype
+ procedure :: get_varname
+ procedure :: get_longname
+ procedure :: get_standname
+ procedure :: get_units
+ procedure :: get_modname
+ procedure :: get_realm
+ procedure :: get_interp_method
+ procedure :: get_frequency
+ procedure :: get_tile_count
+ procedure :: get_area
+ procedure :: get_volume
+ procedure :: get_missing_value
+ procedure :: get_data_RANGE
+!TODO procedure :: get_init_time
+!TODO procedure :: get_axis
+end type fmsDiagField_type
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+type(fmsDiagField_type) :: null_ob
+
+logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized
+integer, private :: registered_variables !< Number of registered variables
+
+!type(fmsDiagField_type) :: diag_object_placeholder (10)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+public :: fmsDiagField_type
+public :: fms_diag_fields_object_init
+public :: null_ob
+public :: copy_diag_obj, fms_diag_get_id
+public :: fms_diag_field_object_end
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ CONTAINS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!> @brief Deallocates the array of diag_objs
+subroutine fms_diag_field_object_end (ob)
+ class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object
+ if (allocated(ob)) deallocate(ob)
+ module_is_initialized = .false.
+end subroutine fms_diag_field_object_end
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \Description Allocates the diad field object array.
+!! Sets the diag_id to the not registered value.
+!! Initializes the number of registered variables to be 0
+logical function fms_diag_fields_object_init(ob)
+ class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object
+ integer :: i !< For looping
+ allocate(ob(get_num_unique_fields()))
+ registered_variables = 0
+ do i = 1,size(ob)
+ ob(i)%diag_id = diag_not_registered !null_ob%diag_id
+ ob(i)%registered = .false.
+ enddo
+ module_is_initialized = .true.
+ fms_diag_fields_object_init = .true.
+end function fms_diag_fields_object_init
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \Description Fills in and allocates (when necessary) the values in the diagnostic object
+subroutine fms_register_diag_field_obj &
+ !(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
+ (dobj, modname, varname, diag_field_indices, axes, init_time, &
+ longname, units, missing_value, varRange, mask_variant, standname, &
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
+
+ class(fmsDiagField_type), INTENT(inout) :: dobj !< Diaj_obj to fill
+ CHARACTER(len=*), INTENT(in) :: modname !< The module name
+ CHARACTER(len=*), INTENT(in) :: varname !< The variable name
+ integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
+ !! in the yaml object
+ TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Initial time
+ INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: standname !< The variables stanard name
+ class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a attribute
+ class(*), OPTIONAL, INTENT(in) :: varRANGE(2) !< Range to add as a attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Error message to be passed back up
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
+ !! regridding the field in post-processing.
+ !! Valid options are "conserve_order1",
+ !! "conserve_order2", and "none".
+ INTEGER, OPTIONAL, INTENT(in) :: tile_count !< the number of tiles
+ INTEGER, OPTIONAL, INTENT(in) :: area !< diag_field_id of the cell area field
+ INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
+ !! modeling_realm attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: static !< Set to true if it is a static field
+
+ integer :: i !< For do loops
+ integer :: j !< dobj%file_ids(i) (for less typing :)
+
+!> Fill in information from the register call
+ dobj%varname = trim(varname)
+ dobj%modname = trim(modname)
+!> Add axis and domain information
+ if (present(axes)) then
+ dobj%axis_ids = axes
+ call get_domain_and_domain_type(dobj%axis_ids, dobj%type_of_domain, dobj%domain, dobj%varname)
+ else
+ !> The variable is a scalar
+ dobj%type_of_domain = NO_DOMAIN
+ dobj%domain => null()
+ endif
+
+!> get the optional arguments if included and the diagnostic is in the diag table
+ if (present(longname)) dobj%longname = trim(longname)
+ if (present(standname)) dobj%standname = trim(standname)
+ if (present(units)) dobj%units = trim(units)
+ if (present(realm)) dobj%realm = trim(realm)
+ if (present(interp_method)) dobj%interp_method = trim(interp_method)
+ if (present(tile_count)) then
+ allocate(dobj%tile_count)
+ dobj%tile_count = tile_count
+ endif
+ if (present(static)) then
+ dobj%static = static
+ else
+ dobj%static = .false.
+ endif
+
+ if (present(missing_value)) then
+ select type (missing_value)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: dobj%missing_value)
+ dobj%missing_value = missing_value
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: dobj%missing_value)
+ dobj%missing_value = missing_value
+ type is (real(kind=r4_kind))
+ allocate(integer(kind=r4_kind) :: dobj%missing_value)
+ dobj%missing_value = missing_value
+ type is (real(kind=r8_kind))
+ allocate(integer(kind=r8_kind) :: dobj%missing_value)
+ dobj%missing_value = missing_value
+ class default
+ call mpp_error("fms_register_diag_field_obj", &
+ "The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",&
+ FATAL)
+ end select
+ else
+ allocate(real :: dobj%missing_value)
+ select type (miss => dobj%missing_value)
+ type is (real)
+ miss = real(CMOR_MISSING_VALUE)
+ end select
+ endif
+
+ if (present(varRANGE)) then
+ select type (varRANGE)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: dobj%data_RANGE(2))
+ dobj%data_RANGE = varRANGE
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: dobj%data_RANGE(2))
+ dobj%data_RANGE = varRANGE
+ type is (real(kind=r4_kind))
+ allocate(integer(kind=r4_kind) :: dobj%data_RANGE(2))
+ dobj%data_RANGE = varRANGE
+ type is (real(kind=r8_kind))
+ allocate(integer(kind=r8_kind) :: dobj%data_RANGE(2))
+ dobj%data_RANGE = varRANGE
+ class default
+ call mpp_error("fms_register_diag_field_obj", &
+ "The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",&
+ FATAL)
+ end select
+ else
+ allocate(real :: dobj%data_RANGE(2))
+ select type (varRANGE => dobj%data_RANGE)
+ type is (real)
+ varRANGE = real(CMOR_MISSING_VALUE)
+ end select
+ endif
+
+ if (present(area)) then
+ if (area < 0) call mpp_error("fms_register_diag_field_obj", &
+ "The area id passed with field_name"//trim(varname)//" has not been registered."&
+ "Check that there is a register_diag_field call for the AREA measure and that is in the"&
+ "diag_table.yaml", FATAL)
+ allocate(dobj%area)
+ dobj%area = area
+ endif
+
+ if (present(volume)) then
+ if (volume < 0) call mpp_error("fms_register_diag_field_obj", &
+ "The volume id passed with field_name"//trim(varname)//" has not been registered."&
+ "Check that there is a register_diag_field call for the VOLUME measure and that is in the"&
+ "diag_table.yaml", FATAL)
+ allocate(dobj%volume)
+ dobj%volume = volume
+ endif
+
+ if (present(mask_variant)) then
+ allocate(dobj%mask_variant)
+ dobj%mask_variant = mask_variant
+ endif
+
+ if (present(do_not_log)) then
+ allocate(dobj%do_not_log)
+ dobj%do_not_log = do_not_log
+ endif
+
+ !< Allocate space for any additional variable attributes
+ !< These will be fill out when calling `diag_field_add_attribute`
+ allocate(dobj%attributes(max_field_attributes))
+ dobj%num_attributes = 0
+ dobj%registered = .true.
+end subroutine fms_register_diag_field_obj
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \brief Sets the diag_id. This can only be done if a variable is unregistered
+subroutine set_diag_id(objin , id)
+ class (fmsDiagField_type) , intent(inout):: objin
+ integer :: id
+ if (allocated(objin%registered)) then
+ if (objin%registered) then
+ call mpp_error("set_diag_id", "The variable"//objin%varname//" is already registered", FATAL)
+ endif
+ else
+ objin%diag_id = id
+ endif
+end subroutine set_diag_id
+!> \brief Find the type of the variable and store it in the object
+subroutine set_vartype(objin , var)
+ class (fmsDiagField_type) , intent(inout):: objin
+ class(*) :: var
+ select type (var)
+ type is (real(kind=8))
+ objin%vartype = r8
+ type is (real(kind=4))
+ objin%vartype = r4
+ type is (integer(kind=8))
+ objin%vartype = i8
+ type is (integer(kind=4))
+ objin%vartype = i4
+ type is (character(*))
+ objin%vartype = string
+ class default
+ objin%vartype = null_type_int
+ call mpp_error("set_vartype", "The variable"//objin%varname//" is not a supported type "// &
+ " r8, r4, i8, i4, or string.", warning)
+ end select
+end subroutine set_vartype
+!> \brief Prints to the screen what type the diag variable is
+subroutine what_is_vartype(objin)
+ class (fmsDiagField_type) , intent(inout):: objin
+ if (.not. allocated(objin%vartype)) then
+ call mpp_error("what_is_vartype", "The variable type has not been set prior to this call", warning)
+ return
+ endif
+ select case (objin%vartype)
+ case (r8)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is REAL(kind=8)", NOTE)
+ case (r4)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is REAL(kind=4)", NOTE)
+ case (i8)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is INTEGER(kind=8)", NOTE)
+ case (i4)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is INTEGER(kind=4)", NOTE)
+ case (string)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is CHARACTER(*)", NOTE)
+ case (null_type_int)
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " was not set", WARNING)
+ case default
+ call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ " is not supported by diag_manager", FATAL)
+ end select
+end subroutine what_is_vartype
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \brief Copies the calling object into the object that is the argument of the subroutine
+subroutine copy_diag_obj(objin , objout)
+ class (fmsDiagField_type) , intent(in) :: objin
+ class (fmsDiagField_type) , intent(inout) , allocatable :: objout !< The destination of the copy
+select type (objout)
+ class is (fmsDiagField_type)
+
+ if (allocated(objin%registered)) then
+ objout%registered = objin%registered
+ else
+ call mpp_error("copy_diag_obj", "You can only copy objects that have been registered",warning)
+ endif
+ objout%diag_id = objin%diag_id
+
+ if (allocated(objin%attributes)) objout%attributes = objin%attributes
+ objout%static = objin%static
+ if (allocated(objin%frequency)) objout%frequency = objin%frequency
+ if (allocated(objin%varname)) objout%varname = objin%varname
+end select
+end subroutine copy_diag_obj
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!> \brief Returns the ID integer for a variable
+!! \return the diag ID
+pure integer function fms_diag_get_id (dobj) result(diag_id)
+ class(fmsDiagField_type) , intent(in) :: dobj
+!> Check if the diag_object registration has been done
+ if (allocated(dobj%registered)) then
+ !> Return the diag_id if the variable has been registered
+ diag_id = dobj%diag_id
+ else
+!> If the variable is not regitered, then return the unregistered value
+ diag_id = DIAG_NOT_REGISTERED
+ endif
+end function fms_diag_get_id
+
+!> Function to return a character (string) representation of the most basic
+!> object identity info. Intended for debugging and warning. The format produced is:
+!> [dobj: o.varname(string|?), vartype (string|?), o.registered (T|F|?), diag_id (id|?)].
+!> A questionmark "?" is set in place of the variable that is not yet allocated
+!>TODO: Add diag_id ?
+function fms_diag_obj_as_string_basic(dobj) result(rslt)
+ class(fmsDiagField_type), allocatable, intent(in) :: dobj
+ character(:), allocatable :: rslt
+ character (len=:), allocatable :: registered, vartype, varname, diag_id
+ if ( .not. allocated (dobj)) then
+ varname = "?"
+ vartype = "?"
+ registered = "?"
+ diag_id = "?"
+ rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]"
+ return
+ end if
+
+! if(allocated (dobj%registered)) then
+! registered = logical_to_cs (dobj%registered)
+! else
+! registered = "?"
+! end if
+
+! if(allocated (dobj%diag_id)) then
+! diag_id = int_to_cs (dobj%diag_id)
+! else
+! diag_id = "?"
+! end if
+
+! if(allocated (dobj%vartype)) then
+! vartype = int_to_cs (dobj%vartype)
+! else
+! registered = "?"
+! end if
+
+ if(allocated (dobj%varname)) then
+ varname = dobj%varname
+ else
+ registered = "?"
+ end if
+
+ rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]"
+
+end function fms_diag_obj_as_string_basic
+
+
+function diag_obj_is_registered (obj) result (rslt)
+ class(fmsDiagField_type), intent(in) :: obj
+ logical :: rslt
+ rslt = obj%registered
+end function diag_obj_is_registered
+
+function diag_obj_is_static (obj) result (rslt)
+ class(fmsDiagField_type), intent(in) :: obj
+ logical :: rslt
+ rslt = obj%static
+end function diag_obj_is_static
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Get functions
+
+!> @brief Gets attributes
+!! @return A pointer to the attributes of the diag_obj, null pointer if there are no attributes
+function get_attributes (obj) &
+result(rslt)
+ class (fmsDiagField_type), target, intent(in) :: obj !< diag object
+ type(fmsDiagAttribute_type), pointer :: rslt(:)
+
+ rslt => null()
+ if (obj%num_attributes > 0 ) rslt => obj%attributes
+end function get_attributes
+!> @brief Gets static
+!! @return copy of variable static
+pure function get_static (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ logical :: rslt
+ rslt = obj%static
+end function get_static
+!> @brief Gets regisetered
+!! @return copy of registered
+pure function get_registered (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ logical :: rslt
+ rslt = obj%registered
+end function get_registered
+!> @brief Gets mask variant
+!! @return copy of mask variant
+pure function get_mask_variant (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ logical :: rslt
+ rslt = obj%mask_variant
+end function get_mask_variant
+!> @brief Gets local
+!! @return copy of local
+pure function get_local (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ logical :: rslt
+ rslt = obj%local
+end function get_local
+!> @brief Gets initial time
+!! @return copy of the initial time
+!! TODO
+!function get_init_time (obj) &
+!result(rslt)
+! class (fmsDiagField_type), intent(in) :: obj !< diag object
+! TYPE(time_type) :: rslt
+!
+!end function get_init_time
+!> @brief Gets vartype
+!! @return copy of The integer related to the variable type
+pure function get_vartype (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ integer :: rslt
+ rslt = obj%vartype
+end function get_vartype
+!> @brief Gets varname
+!! @return copy of the variable name
+pure function get_varname (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ rslt = obj%varname
+end function get_varname
+!> @brief Gets longname
+!! @return copy of the variable long name or a single string if there is no long name
+pure function get_longname (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%longname)) then
+ rslt = obj%longname
+ else
+ rslt = diag_null_string
+ endif
+end function get_longname
+!> @brief Gets standname
+!! @return copy of the standard name or an empty string if standname is not allocated
+pure function get_standname (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%standname)) then
+ rslt = obj%standname
+ else
+ rslt = diag_null_string
+ endif
+end function get_standname
+!> @brief Gets units
+!! @return copy of the units or an empty string if not allocated
+pure function get_units (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%units)) then
+ rslt = obj%units
+ else
+ rslt = diag_null_string
+ endif
+end function get_units
+!> @brief Gets modname
+!! @return copy of the module name that the variable is in or an empty string if not allocated
+pure function get_modname (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%modname)) then
+ rslt = obj%modname
+ else
+ rslt = diag_null_string
+ endif
+end function get_modname
+!> @brief Gets realm
+!! @return copy of the variables modeling realm or an empty string if not allocated
+pure function get_realm (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%realm)) then
+ rslt = obj%realm
+ else
+ rslt = diag_null_string
+ endif
+end function get_realm
+!> @brief Gets interp_method
+!! @return copy of The interpolation method or an empty string if not allocated
+pure function get_interp_method (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ character(len=:), allocatable :: rslt
+ if (allocated(obj%interp_method)) then
+ rslt = obj%interp_method
+ else
+ rslt = diag_null_string
+ endif
+end function get_interp_method
+!> @brief Gets frequency
+!! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated
+pure function get_frequency (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ integer, allocatable, dimension (:) :: rslt
+ if (allocated(obj%frequency)) then
+ allocate (rslt(size(obj%frequency)))
+ rslt = obj%frequency
+ else
+ allocate (rslt(1))
+ rslt = DIAG_NULL
+ endif
+end function get_frequency
+!> @brief Gets tile_count
+!! @return copy of the number of tiles or diag_null if tile_count is not allocated
+pure function get_tile_count (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ integer :: rslt
+ if (allocated(obj%tile_count)) then
+ rslt = obj%tile_count
+ else
+ rslt = DIAG_NULL
+ endif
+end function get_tile_count
+!> @brief Gets area
+!! @return copy of the area or diag_null if not allocated
+pure function get_area (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ integer :: rslt
+ if (allocated(obj%area)) then
+ rslt = obj%area
+ else
+ rslt = diag_null
+ endif
+end function get_area
+!> @brief Gets volume
+!! @return copy of the volume or diag_null if volume is not allocated
+pure function get_volume (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ integer :: rslt
+ if (allocated(obj%volume)) then
+ rslt = obj%volume
+ else
+ rslt = diag_null
+ endif
+end function get_volume
+!> @brief Gets missing_value
+!! @return copy of The missing value
+function get_missing_value (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class(*),allocatable :: rslt
+ if (allocated(obj%missing_value)) then
+ select type (miss => obj%missing_value)
+ type is (integer(kind=i4_kind))
+ allocate (integer(kind=i4_kind) :: rslt)
+ rslt = miss
+ type is (integer(kind=i8_kind))
+ allocate (integer(kind=i8_kind) :: rslt)
+ rslt = miss
+ type is (real(kind=r4_kind))
+ allocate (integer(kind=i4_kind) :: rslt)
+ rslt = miss
+ type is (real(kind=r8_kind))
+ allocate (integer(kind=i4_kind) :: rslt)
+ rslt = miss
+ class default
+ call mpp_error ("get_missing_value", &
+ "The missing value is not a r8, r4, i8, or i4",&
+ FATAL)
+ end select
+ else
+ call mpp_error ("get_missing_value", &
+ "The missing value is not allocated", FATAL)
+ endif
+end function get_missing_value
+!> @brief Gets data_range
+!! @return copy of the data range
+function get_data_RANGE (obj) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class(*),allocatable :: rslt(:)
+ if (allocated(obj%data_RANGE)) then
+ select type (r => obj%data_RANGE)
+ type is (integer(kind=i4_kind))
+ allocate (integer(kind=i4_kind) :: rslt(2))
+ rslt = r
+ type is (integer(kind=i8_kind))
+ allocate (integer(kind=i8_kind) :: rslt(2))
+ rslt = r
+ type is (real(kind=r4_kind))
+ allocate (integer(kind=i4_kind) :: rslt(2))
+ rslt = r
+ type is (real(kind=r8_kind))
+ allocate (integer(kind=i4_kind) :: rslt(2))
+ rslt = r
+ class default
+ call mpp_error ("get_data_RANGE", &
+ "The data_RANGE value is not a r8, r4, i8, or i4",&
+ FATAL)
+ end select
+ else
+ call mpp_error ("get_data_RANGE", &
+ "The data_RANGE value is not allocated", FATAL)
+ endif
+end function get_data_RANGE
+!> @brief Gets axis
+!! @return copy of axis information
+!! TODO
+!function get_axis (obj) &
+!result(rslt)
+! class (fmsDiagField_type), intent(in) :: obj !< diag object
+! type (diag_axis_type), allocatable, dimension(:) :: rslt
+!
+!end function get_axis
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!! Allocation checks
+!!> @brief Checks if obj%diag_field is allocated
+!!! @return true if obj%diag_field is allocated
+!logical function has_diag_field (obj)
+! class (fmsDiagField_type), intent(in) :: obj !< diag object
+! has_diag_field = allocated(obj%diag_field)
+!end function has_diag_field
+!> @brief Checks if obj%diag_id is allocated
+!! @return true if obj%diag_id is allocated
+pure logical function has_diag_id (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_diag_id = allocated(obj%diag_id)
+end function has_diag_id
+!> @brief Checks if obj%metadata is allocated
+!! @return true if obj%metadata is allocated
+pure logical function has_attributes (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_attributes = obj%num_attributes > 0
+end function has_attributes
+!> @brief Checks if obj%static is allocated
+!! @return true if obj%static is allocated
+pure logical function has_static (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_static = allocated(obj%static)
+end function has_static
+!> @brief Checks if obj%registered is allocated
+!! @return true if obj%registered is allocated
+pure logical function has_registered (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_registered = allocated(obj%registered)
+end function has_registered
+!> @brief Checks if obj%mask_variant is allocated
+!! @return true if obj%mask_variant is allocated
+pure logical function has_mask_variant (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_mask_variant = allocated(obj%mask_variant)
+end function has_mask_variant
+!> @brief Checks if obj%local is allocated
+!! @return true if obj%local is allocated
+pure logical function has_local (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_local = allocated(obj%local)
+end function has_local
+!!> @brief Checks if obj%init_time is allocated
+!!! @return true if obj%init_time is allocated
+!logical function has_init_time (obj)
+! class (fmsDiagField_type), intent(in) :: obj !< diag object
+! has_init_time = allocated(obj%init_time)
+!end function has_init_time
+!> @brief Checks if obj%vartype is allocated
+!! @return true if obj%vartype is allocated
+pure logical function has_vartype (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_vartype = allocated(obj%vartype)
+end function has_vartype
+!> @brief Checks if obj%varname is allocated
+!! @return true if obj%varname is allocated
+pure logical function has_varname (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_varname = allocated(obj%varname)
+end function has_varname
+!> @brief Checks if obj%longname is allocated
+!! @return true if obj%longname is allocated
+pure logical function has_longname (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_longname = allocated(obj%longname)
+end function has_longname
+!> @brief Checks if obj%standname is allocated
+!! @return true if obj%standname is allocated
+pure logical function has_standname (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_standname = allocated(obj%standname)
+end function has_standname
+!> @brief Checks if obj%units is allocated
+!! @return true if obj%units is allocated
+pure logical function has_units (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_units = allocated(obj%units)
+end function has_units
+!> @brief Checks if obj%modname is allocated
+!! @return true if obj%modname is allocated
+pure logical function has_modname (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_modname = allocated(obj%modname)
+end function has_modname
+!> @brief Checks if obj%realm is allocated
+!! @return true if obj%realm is allocated
+pure logical function has_realm (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_realm = allocated(obj%realm)
+end function has_realm
+!> @brief Checks if obj%interp_method is allocated
+!! @return true if obj%interp_method is allocated
+pure logical function has_interp_method (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_interp_method = allocated(obj%interp_method)
+end function has_interp_method
+!> @brief Checks if obj%frequency is allocated
+!! @return true if obj%frequency is allocated
+pure logical function has_frequency (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_frequency = allocated(obj%frequency)
+end function has_frequency
+!> @brief Checks if obj%tile_count is allocated
+!! @return true if obj%tile_count is allocated
+pure logical function has_tile_count (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_tile_count = allocated(obj%tile_count)
+end function has_tile_count
+!> @brief Checks if obj%area is allocated
+!! @return true if obj%area is allocated
+pure logical function has_area (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_area = allocated(obj%area)
+end function has_area
+!> @brief Checks if obj%volume is allocated
+!! @return true if obj%volume is allocated
+pure logical function has_volume (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_volume = allocated(obj%volume)
+end function has_volume
+!> @brief Checks if obj%missing_value is allocated
+!! @return true if obj%missing_value is allocated
+pure logical function has_missing_value (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_missing_value = allocated(obj%missing_value)
+end function has_missing_value
+!> @brief Checks if obj%data_RANGE is allocated
+!! @return true if obj%data_RANGE is allocated
+pure logical function has_data_RANGE (obj)
+ class (fmsDiagField_type), intent(in) :: obj !< diag object
+ has_data_RANGE = allocated(obj%data_RANGE)
+end function has_data_RANGE
+
+!> @brief Add a attribute to the diag_obj using the diag_field_id
+subroutine diag_field_add_attribute(obj, att_name, att_value)
+ class (fmsDiagField_type), intent (inout) :: obj !< The field object
+ character(len=*), intent(in) :: att_name !< Name of the attribute
+ class(*), intent(in) :: att_value(:) !< The attribute value to add
+
+ obj%num_attributes = obj%num_attributes + 1
+ if (obj%num_attributes > max_field_attributes) &
+ call mpp_error(FATAL, "diag_field_add_attribute: Number of attributes exceeds max_field_attributes for field:"&
+ //trim(obj%varname)//". Increase diag_manager_nml:max_field_attributes.")
+
+ call obj%attributes(obj%num_attributes)%add(att_name, att_value)
+end subroutine diag_field_add_attribute
+
+!> @brief Determines the diag_obj id corresponding to a module name and field_name
+!> @return diag_obj id
+PURE FUNCTION diag_field_id_from_name(diag_objs, module_name, field_name) &
+ result(diag_field_id)
+ CLASS(fmsDiagField_type), INTENT(in) :: diag_objs !< The field object
+ CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
+ CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
+
+ integer :: diag_field_id
+
+ diag_field_id = DIAG_FIELD_NOT_FOUND
+ if (diag_objs%get_varname() .eq. trim(field_name) .and. &
+ diag_objs%get_modname() .eq. trim(module_name)) then
+ diag_field_id = diag_objs%get_id()
+ endif
+end function diag_field_id_from_name
+#endif
+end module fms_diag_field_object_mod
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index a0ba7d1bff..3f11a7174b 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -24,19 +24,19 @@
!! a pointer to the information from the diag yaml, additional metadata that comes from the model, and a
!! list of the variables and their variable IDs that are in the file.
module fms_diag_file_object_mod
+#ifdef use_yaml
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t
-use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time
+use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED
use diag_util_mod, only: diag_time_inc
use time_manager_mod, only: time_type, operator(/=), operator(==)
-#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type
-#endif
-use fms_diag_axis_object_mod, only: diagDomain_t
+use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type
use mpp_mod, only: mpp_error, FATAL
implicit none
private
-public :: fmsDiagFile_type, FMS_diag_files, fms_diag_files_object_init, fms_diag_files_object_initialized
+public :: fmsDiagFileContainer_type
+public :: fmsDiagFile_type, fms_diag_files_object_init, fms_diag_files_object_initialized
logical :: fms_diag_files_object_initialized = .false.
@@ -53,43 +53,38 @@ module fms_diag_file_object_mod
!< This will be used when using the new_file_freq keys in the diag_table.yaml
TYPE(time_type) :: next_open !< The next time to open the file
class(FmsNetcdfFile_t), allocatable :: fileobj !< fms2_io file object for this history file
-#ifdef use_yaml
type(diagYamlFiles_type), pointer :: diag_yaml_file => null() !< Pointer to the diag_yaml_file data
-#endif
integer :: type_of_domain !< The type of domain to use to open the file
!! NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, SUB_REGIONAL
class(diagDomain_t), pointer :: domain !< The domain to use,
!! null if NO_DOMAIN or SUB_REGIONAL
character(len=:) , dimension(:), allocatable :: file_metadata_from_model !< File metadata that comes from
!! the model.
- integer, dimension(:), allocatable :: var_ids !< Variable IDs corresponding to file_varlist
- integer, dimension(:), private, allocatable :: var_index !< An array of the variable indicies in the
- !! diag_object. This should be the same size as
- !! `file_varlist`
- logical, dimension(:), private, allocatable :: var_reg !< Array corresponding to `file_varlist`, .true.
+ integer, dimension(:), allocatable :: field_ids !< Variable IDs corresponding to file_varlist
+ logical, dimension(:), private, allocatable :: field_registered !< Array corresponding to `field_ids`, .true.
!! if the variable has been registered and
- !! `file_var_index` has been set for the variable
+ !! `field_id` has been set for the variable
+ integer, allocatable :: num_registered_fields !< The number of fields registered
+ !! to the file
integer, dimension(:), allocatable :: axis_ids !< Array of axis ids in the file
- integer, dimension(:), allocatable :: sub_axis_ids !< Array of axis ids in the file
integer :: number_of_axis !< Number of axis in the file
contains
+ procedure, public :: add_field_id
procedure, public :: has_file_metadata_from_model
procedure, public :: has_fileobj
-#ifdef use_yaml
procedure, public :: has_diag_yaml_file
+ procedure, public :: set_domain_from_axis
procedure, public :: set_file_domain
procedure, public :: add_axes
procedure, public :: add_start_time
-#endif
- procedure, public :: has_var_ids
+ procedure, public :: has_field_ids
procedure, public :: get_id
! TODO procedure, public :: get_fileobj ! TODO
! TODO procedure, public :: get_diag_yaml_file ! TODO
procedure, public :: get_file_metadata_from_model
- procedure, public :: get_var_ids
+ procedure, public :: get_field_ids
! The following fuctions come will use the yaml inquiry functions
-#ifdef use_yaml
procedure, public :: get_file_fname
procedure, public :: get_file_frequnit
procedure, public :: get_file_freq
@@ -117,35 +112,56 @@ module fms_diag_file_object_mod
procedure, public :: has_file_duration_units
procedure, public :: has_file_varlist
procedure, public :: has_file_global_meta
-#endif
end type fmsDiagFile_type
+type, extends (fmsDiagFile_type) :: subRegionalFile_type
+ integer, dimension(:), allocatable :: sub_axis_ids !< Array of axis ids in the file
+end type subRegionalFile_type
-type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_files !< The array of diag files
+!> \brief A container for fmsDiagFile_type. This is used to create the array of files
+type fmsDiagFileContainer_type
+ class (fmsDiagFile_type),allocatable :: FMS_diag_file !< The individual file object
+end type fmsDiagFileContainer_type
+!type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_file !< The array of diag files
+!class(fmsDiagFileContainer_type),dimension (:), allocatable, target :: FMS_diag_file
contains
!< @brief Allocates the number of files and sets an ID based for each file
!! @return true if there are files allocated in the YAML object
-logical function fms_diag_files_object_init ()
-#ifdef use_yaml
+logical function fms_diag_files_object_init (files_array)
+ class(fmsDiagFileContainer_type), allocatable, target, intent(inout) :: files_array (:) !< array of diag files
+ class(fmsDiagFile_type), pointer :: obj => null() !< Pointer for each member of the array
integer :: nFiles !< Number of files in the diag yaml
integer :: i !< Looping iterator
- type(fmsDiagFile_type), pointer :: obj !< FMS_diag_files(i) (for less typing)
if (diag_yaml%has_diag_files()) then
nFiles = diag_yaml%size_diag_files()
- allocate (FMS_diag_files(nFiles))
+ allocate (files_array(nFiles))
set_ids_loop: do i= 1,nFiles
- obj => FMS_diag_files(i)
+ !> If the file has a sub_regional, define it as one and allocate the sub_axis_ids array.
+ !! This will be set in a add_axes
+ if (diag_yaml%diag_files(i)%has_file_sub_region()) then
+ allocate(subRegionalFile_type :: files_array(i)%FMS_diag_file)
+ obj => files_array(i)%FMS_diag_file
+ obj%type_of_domain = SUB_REGIONAL
+ select type (obj)
+ type is (subRegionalFile_type)
+ allocate(obj%sub_axis_ids(max_axes))
+ obj%sub_axis_ids = diag_null
+ end select
+ else
+ allocate(FmsDiagFile_type::files_array(i)%FMS_diag_file)
+ obj => files_array(i)%FMS_diag_file
+ endif
+ !!
obj%diag_yaml_file => diag_yaml%diag_files(i)
obj%id = i
- allocate(obj%var_ids(diag_yaml%diag_files(i)%size_file_varlist()))
- allocate(obj%var_index(diag_yaml%diag_files(i)%size_file_varlist()))
- allocate(obj%var_reg(diag_yaml%diag_files(i)%size_file_varlist()))
+ allocate(obj%field_ids(diag_yaml%diag_files(i)%size_file_varlist()))
+ allocate(obj%field_registered(diag_yaml%diag_files(i)%size_file_varlist()))
!! Initialize the integer arrays
- obj%var_ids = DIAG_NULL
- obj%var_reg = .FALSE.
- obj%var_index = DIAG_NULL
+ obj%field_ids = DIAG_NOT_REGISTERED
+ obj%field_registered = .FALSE.
+ obj%num_registered_fields = 0
!> These will be set in a set_file_domain
obj%type_of_domain = NO_DOMAIN
@@ -153,15 +169,6 @@ logical function fms_diag_files_object_init ()
!> This will be set in a add_axes
allocate(obj%axis_ids(max_axes))
-
- !> If the file has a sub_regional, define it as one and allocate the sub_axis_ids array.
- !! This will be set in a add_axes
- if (obj%has_file_sub_region()) then
- obj%type_of_domain = SUB_REGIONAL
- allocate(obj%sub_axis_ids(max_axes))
- obj%sub_axis_ids = diag_null
- endif
-
obj%number_of_axis = 0
!> Set the start_time of the file to the base_time and set up the *_output variables
@@ -179,10 +186,21 @@ logical function fms_diag_files_object_init ()
! mpp_error("fms_diag_files_object_init: The diag_table.yaml file has not been correctly parsed.",&
! FATAL)
endif
-#else
- fms_diag_files_object_init = .false.
-#endif
end function fms_diag_files_object_init
+!> \brief Adds a field ID to the file
+subroutine add_field_id (obj, new_field_id)
+ class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+ integer, intent(in) :: new_field_id !< The field ID to be added to field_ids
+ obj%num_registered_fields = obj%num_registered_fields + 1
+ if (obj%num_registered_fields .le. size(obj%field_ids)) then
+ obj%field_ids( obj%num_registered_fields ) = new_field_id
+ obj%field_registered( obj%num_registered_fields ) = .true.
+ else
+ call mpp_error(FATAL, "The file: "//obj%get_file_fname()//" has already been assigned its maximum "//&
+ "number of fields.")
+ endif
+end subroutine add_field_id
+
!> \brief Logical function to determine if the variable file_metadata_from_model has been allocated or associated
!! \return .True. if file_metadata_from_model exists .False. if file_metadata_from_model has not been set
pure logical function has_file_metadata_from_model (obj)
@@ -195,20 +213,18 @@ pure logical function has_fileobj (obj)
class(fmsDiagFile_type), intent(in) :: obj !< The file object
has_fileobj = allocated(obj%fileobj)
end function has_fileobj
-#ifdef use_yaml
!> \brief Logical function to determine if the variable diag_yaml_file has been allocated or associated
!! \return .True. if diag_yaml_file exists .False. if diag_yaml has not been set
pure logical function has_diag_yaml_file (obj)
class(fmsDiagFile_type), intent(in) :: obj !< The file object
has_diag_yaml_file = associated(obj%diag_yaml_file)
end function has_diag_yaml_file
-#endif
-!> \brief Logical function to determine if the variable var_ids has been allocated or associated
-!! \return .True. if var_ids exists .False. if var_ids has not been set
-pure logical function has_var_ids (obj)
+!> \brief Logical function to determine if the variable field_ids has been allocated or associated
+!! \return .True. if field_ids exists .False. if field_ids has not been set
+pure logical function has_field_ids (obj)
class(fmsDiagFile_type), intent(in) :: obj !< The file object
- has_var_ids = allocated(obj%var_ids)
-end function has_var_ids
+ has_field_ids = allocated(obj%field_ids)
+end function has_field_ids
!> \brief Returns a copy of the value of id
!! \return A copy of id
pure function get_id (obj) result (res)
@@ -229,13 +245,11 @@ end function get_id
!! TODO
!!> \brief Returns a copy of the value of diag_yaml_file
!!! \return A copy of diag_yaml_file
-!#ifdef use_yaml
!pure function get_diag_yaml_file (obj) result (res)
! class(fmsDiagFile_type), intent(in) :: obj !< The file object
! type(diagYamlFiles_type) :: res
! res = obj%diag_yaml_file
!end function get_diag_yaml_file
-!#endif
!> \brief Returns a copy of the value of file_metadata_from_model
!! \return A copy of file_metadata_from_model
pure function get_file_metadata_from_model (obj) result (res)
@@ -243,16 +257,15 @@ pure function get_file_metadata_from_model (obj) result (res)
character(len=:), dimension(:), allocatable :: res
res = obj%file_metadata_from_model
end function get_file_metadata_from_model
-!> \brief Returns a copy of the value of var_ids
-!! \return A copy of var_ids
-pure function get_var_ids (obj) result (res)
+!> \brief Returns a copy of the value of field_ids
+!! \return A copy of field_ids
+pure function get_field_ids (obj) result (res)
class(fmsDiagFile_type), intent(in) :: obj !< The file object
integer, dimension(:), allocatable :: res
- allocate(res(size(obj%var_ids)))
- res = obj%var_ids
-end function get_var_ids
+ allocate(res(size(obj%field_ids)))
+ res = obj%field_ids
+end function get_field_ids
!!!!!!!!! Functions from diag_yaml_file
-#ifdef use_yaml
!> \brief Returns a copy of file_fname from the yaml object
!! \return Copy of file_fname
pure function get_file_fname (obj) result(res)
@@ -436,7 +449,12 @@ pure function has_file_global_meta (obj) result(res)
logical :: res
res = obj%diag_yaml_file%has_file_global_meta()
end function has_file_global_meta
-
+!> @brief Sets the domain and type of domain from the axis IDs
+subroutine set_domain_from_axis(obj, axes)
+ class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+ integer, intent(in) :: axes (:)
+ call get_domain_and_domain_type(axes, obj%type_of_domain, obj%domain, obj%get_file_fname())
+end subroutine set_domain_from_axis
!> @brief Set the domain and the type_of_domain for a file
!> @details This subroutine is going to be called once by every variable in the file
!! in register_diag_field. It will update the domain and the type_of_domain if needed and verify that
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index fbbe5a2c0c..f746c029d6 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -1,251 +1,119 @@
+!***********************************************************************
+!* 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 fms_diag_object_mod
-!> \author Tom Robinson
-!> \email thomas.robinson@noaa.gov
-!! \brief Contains routines for the diag_objects
-!!
-!! \description The diag_manager passes an object back and forth between the diag routines and the users.
-!! The procedures of this object and the types are all in this module. The fms_dag_object is a type
-!! that contains all of the information of the variable. It is extended by a type that holds the
-!! appropriate buffer for the data for manipulation.
-use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string
-use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN
-use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type
-use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
- &DIAG_FIELD_NOT_FOUND
-
-use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
+use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
+ &DIAG_FIELD_NOT_FOUND, diag_not_registered
+ USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
+ & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
+ & get_ticks_per_second
#ifdef use_yaml
-use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, &
- & find_diag_field, get_num_unique_fields
-use fms_diag_file_object_mod, only: fmsDiagFile_type, FMS_diag_files
+use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init
+use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init
+use fms_diag_yaml_mod, only: diag_yaml_object_init, find_diag_field, get_diag_files_id
+use fms_diag_axis_object_mod, only: fms_diag_axis_object_init
#endif
-use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type
-use time_manager_mod, ONLY: time_type
-!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
-!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
-!!! & get_ticks_per_second
-
-use platform_mod
-use iso_c_binding
-
implicit none
+private
-integer, parameter :: range_dims = 2 !< The range of the variables will be set to 2 when allocated
-
-interface operator (<)
- procedure obj_lt_int
- procedure int_lt_obj
-end interface
-interface operator (<=)
- procedure obj_le_int
- procedure int_le_obj
-end interface
-interface operator (>)
- procedure obj_gt_int
- procedure int_gt_obj
-end interface
-interface operator (>=)
- procedure obj_ge_int
- procedure int_ge_obj
-end interface
-!interface operator (==)
-! procedure obj_eq_int
-! procedure int_eq_obj
-!end interface
-interface operator (.ne.)
- procedure obj_ne_int
- procedure int_ne_obj
-end interface
-
-
-!> \brief Object that holds all variable information
type fmsDiagObject_type
+!TODO add container arrays
#ifdef use_yaml
- type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable
- integer, allocatable, dimension(:) :: file_ids !< Ids of the FMS_diag_files the variable
- !! belongs to
+private
+!TODO: Remove FMS prefix from variables in this type
+ class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files
+ class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields
+ integer, private :: registered_variables !< Number of registered variables
+ logical, private :: initialized=.false. !< True if the fmsDiagObject is initialized
+ logical, private :: files_initialized=.false. !< True if the fmsDiagObject is initialized
+ logical, private :: fields_initialized=.false. !< True if the fmsDiagObject is initialized
+ logical, private :: buffers_initialized=.false. !< True if the fmsDiagObject is initialized
+ logical, private :: axes_initialized=.false. !< True if the fmsDiagObject is initialized
#endif
- integer, allocatable, private :: diag_id !< unique id for varable
- type(fmsDiagAttribute_type), allocatable :: attributes(:) !< attributes for the variable
- integer, private :: num_attributes !< Number of attributes currently added
- logical, allocatable, private :: static !< true if this is a static var
- logical, allocatable, private :: registered !< true when registered
- logical, allocatable, private :: mask_variant !< If there is a mask variant
- logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field
- logical, allocatable, private :: local !< If the output is local
- TYPE(time_type), private :: init_time !< The initial time
- integer, allocatable, private :: vartype !< the type of varaible
- character(len=:), allocatable, private :: varname !< the name of the variable
- character(len=:), allocatable, private :: longname !< longname of the variable
- character(len=:), allocatable, private :: standname !< standard name of the variable
- character(len=:), allocatable, private :: units !< the units
- character(len=:), allocatable, private :: modname !< the module
- character(len=:), allocatable, private :: realm !< String to set as the value
- !! to the modeling_realm attribute
- character(len=:), allocatable, private :: interp_method !< The interp method to be used
- !! when regridding the field in post-processing.
- !! Valid options are "conserve_order1",
- !! "conserve_order2", and "none".
- integer, allocatable, dimension(:), private :: frequency !< specifies the frequency
- integer, allocatable, dimension(:), private :: output_units
- integer, allocatable, private :: t
- integer, allocatable, private :: tile_count !< The number of tiles
- integer, pointer, dimension(:), private :: axis_ids !< variable axis IDs
- class(diagDomain_t), pointer, private :: domain !< Domain
- INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN",
- !! "TWO_D_DOMAIN", or "UG_DOMAIN")
- integer, allocatable, private :: area, volume !< The Area and Volume
- class(*), allocatable, private :: missing_value !< The missing fill value
- class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data
- class(*), allocatable :: vardata0 !< Scalar data buffer
- class(*), allocatable, dimension(:) :: vardata1 !< 1D data buffer
- class(*), allocatable, dimension(:,:) :: vardata2 !< 2D data buffer
- class(*), allocatable, dimension(:,:,:) :: vardata3 !< 3D data buffer
- class(*), allocatable, dimension(:,:,:,:) :: vardata4 !< 4D data buffer
- class(*), allocatable, dimension(:,:,:,:,:) :: vardata5 !< 5D data buffer
- contains
-! procedure :: send_data => fms_send_data !!TODO
- procedure :: init_ob => diag_obj_init
- procedure :: get_id => fms_diag_get_id
- procedure :: id => fms_diag_get_id
- procedure :: copy => copy_diag_obj
- procedure :: register => fms_register_diag_field_obj !! Merely initialize fields.
- procedure :: setID => set_diag_id
- procedure :: set_type => set_vartype
- procedure :: vartype_inq => what_is_vartype
-! Check functions
- procedure :: is_static => diag_obj_is_static
- procedure :: is_registered => diag_ob_registered
- procedure :: is_registeredB => diag_obj_is_registered
- procedure :: is_mask_variant => get_mask_variant
- procedure :: is_local => get_local
-! Is variable allocated check functions
-!TODO procedure :: has_diag_field
- procedure :: has_diag_id
- procedure :: has_attributes
- procedure :: has_static
- procedure :: has_registered
- procedure :: has_mask_variant
- procedure :: has_local
-!TODO procedure :: has_init_time
- procedure :: has_vartype
- procedure :: has_varname
- procedure :: has_longname
- procedure :: has_standname
- procedure :: has_units
- procedure :: has_modname
- procedure :: has_realm
- procedure :: has_interp_method
- procedure :: has_frequency
- procedure :: has_output_units
- procedure :: has_t
- procedure :: has_tile_count
- procedure :: has_area
- procedure :: has_volume
- procedure :: has_missing_value
- procedure :: has_data_RANGE
-! Get functions
- procedure :: get_diag_id => fms_diag_get_id
- procedure :: get_attributes
- procedure :: get_static
- procedure :: get_registered
- procedure :: get_mask_variant
- procedure :: get_local
- procedure :: get_vartype
- procedure :: get_varname
- procedure :: get_longname
- procedure :: get_standname
- procedure :: get_units
- procedure :: get_modname
- procedure :: get_realm
- procedure :: get_interp_method
- procedure :: get_frequency
- procedure :: get_output_units
- procedure :: get_t
- procedure :: get_tile_count
- procedure :: get_area
- procedure :: get_volume
- procedure :: get_missing_value
- procedure :: get_data_RANGE
-!TODO procedure :: get_init_time
-!TODO procedure :: get_axis
+ contains
+ procedure :: init => fms_diag_object_init
+ procedure :: fms_register_diag_field_scalar
+ procedure :: fms_register_diag_field_array
+ procedure :: fms_register_static_field
+ procedure :: register => fms_register_diag_field_obj !! Merely initialize fields.
+ procedure :: fms_diag_field_add_attribute
+ procedure :: fms_get_diag_field_id_from_name
+ procedure :: diag_end => fms_diag_object_end
end type fmsDiagObject_type
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-type(fmsDiagObject_type) :: null_ob
-
-integer,private :: MAX_LEN_VARNAME
-integer,private :: MAX_LEN_META
-logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized
-TYPE(fmsDiagObject_type), private, ALLOCATABLE, target :: diag_objs(:) !< Array of diag objects
- !! one for each registered variable
+type (fmsDiagObject_type), target :: fms_diag_object
integer, private :: registered_variables !< Number of registered variables
-
-!type(fmsDiagObject_type) :: diag_object_placeholder (10)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-public :: copy_diag_obj, fms_diag_get_id
-public :: fmsDiagObject_type
-public :: null_ob
-public :: fms_diag_object_init
-public :: fms_diag_object_end
-public :: fms_register_diag_field_array
+public :: fms_register_diag_field_obj
public :: fms_register_diag_field_scalar
+public :: fms_register_diag_field_array
public :: fms_register_static_field
public :: fms_diag_field_add_attribute
-public :: get_diag_obj_from_id
-public :: fms_get_diag_field_id
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- CONTAINS
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!> @brief Initiliazes the array of diag_objs based on the number of unique diag_fields in the diag_table
-subroutine fms_diag_object_init (mlv,mlm)
- integer, intent(in) :: mlv !< The maximum length of the varname
- integer, intent(in) :: mlm !< The maximum length of the metadata
+public :: fms_get_diag_field_id_from_name
+public :: fms_diag_object
+public :: fmsDiagObject_type
- if (module_is_initialized) return
+contains
-!> Get info from the namelist
- MAX_LEN_VARNAME = mlv
- MAX_LEN_META = mlm
-!> Initialize the null_d variables
- null_ob%diag_id = DIAG_NULL
+!> @brief Initiliazes the fms_diag_object.
+!! Reads the diag_table.yaml and fills in the yaml object
+!! Allocates the diag manager object arrays for files, fields, and buffers
+!! Initializes variables
+subroutine fms_diag_object_init (obj,diag_subset_output)
+ class(fmsDiagObject_type) :: obj !< Diag mediator/controller object
+ integer :: diag_subset_output !< Subset of the diag output?
#ifdef use_yaml
- allocate(diag_objs(get_num_unique_fields()))
+ if (obj%initialized) return
+
+!TODO: allocate the file, field, and buffer containers
+! allocate(diag_objs(get_num_unique_fields()))
+ CALL diag_yaml_object_init(diag_subset_output)
+ CALL fms_diag_axis_object_init()
+ obj%files_initialized = fms_diag_files_object_init(obj%FMS_diag_files)
+ obj%fields_initialized = fms_diag_fields_object_init (obj%FMS_diag_fields)
registered_variables = 0
+ obj%initialized = .true.
+#else
+ call mpp_error("fms_diag_object_init",&
+ "You must compile with -Duse_yaml to use the option use_modern_diag", FATAL)
#endif
- module_is_initialized = .true.
end subroutine fms_diag_object_init
-
-!> @brief Deallocates the array of diag_objs
-subroutine fms_diag_object_end ()
- if (.not. module_is_initialized) return
-
- if (allocated(diag_objs)) deallocate(diag_objs)
-
- module_is_initialized = .false.
+!> \description Loops through all files and does one final write.
+!! Closes all files
+!! Deallocates all buffers, fields, and files
+!! Uninitializes the fms_diag_object
+subroutine fms_diag_object_end (obj)
+ class(fmsDiagObject_type) :: obj
+#ifdef use_yaml
+ !TODO: loop through files and force write
+ !TODO: Close all files
+ !TODO: Deallocate diag object arrays and clean up all memory
+ obj%initialized = .false.
+#endif
end subroutine fms_diag_object_end
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!> \Description Sets the diag_id to the not registered value.
-subroutine diag_obj_init(ob)
- class (fmsDiagObject_type) , intent(inout) :: ob
- select type (ob)
- class is (fmsDiagObject_type)
- ob%diag_id = diag_not_registered !null_ob%diag_id
- ob%registered = .false.
- end select
-end subroutine diag_obj_init
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \Description Fills in and allocates (when necessary) the values in the diagnostic object
subroutine fms_register_diag_field_obj &
- !(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
- (dobj, modname, varname, diag_field_indices, axes, init_time, &
+ !(field_obj, modname, varname, axes, time, longname, units, missing_value, metadata)
+ (fms_diag_object, modname, varname, diag_field_indices, axes, init_time, &
longname, units, missing_value, varRange, mask_variant, standname, &
do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
- class(fmsDiagObject_type), INTENT(inout) :: dobj !< Diaj_obj to fill
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: modname !< The module name
CHARACTER(len=*), INTENT(in) :: varname !< The variable name
integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
@@ -269,881 +137,61 @@ subroutine fms_register_diag_field_obj &
INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
!! modeling_realm attribute
-
- integer :: i !< For do loops
- integer :: j !< dobj%file_ids(i) (for less typing :)
-
#ifdef use_yaml
-!> Fill in information from the register call
- dobj%varname = trim(varname)
- dobj%modname = trim(modname)
-
-!> Fill in diag_field and find the ids of the files that this variable is in
- dobj%diag_field = get_diag_fields_entries(diag_field_indices)
- dobj%file_ids = get_diag_files_id(diag_field_indices)
- if (present(axes)) then
- dobj%axis_ids => axes
- call get_domain_and_domain_type(dobj%axis_ids, dobj%type_of_domain, dobj%domain, dobj%varname)
- do i = 1, size(dobj%file_ids)
- j = dobj%file_ids(i)
- call FMS_diag_files(j)%set_file_domain(dobj%domain, dobj%type_of_domain)
- call FMS_diag_files(j)%add_axes(axes)
- if (present(init_time)) call FMS_diag_files(j)%add_start_time(init_time)
+ class (fmsDiagFile_type), pointer :: fileptr => null()
+ class (fmsDiagField_type), pointer :: fieldptr => null()
+ integer, allocatable :: file_ids(:) !< The file IDs for this variable
+ integer :: i !< For do loops
+ integer :: j !< fms_diag_object%FMS_diag_fields%file_ids(i) (for less typing :)
+
+!> Use pointers for convenience
+ fieldptr => fms_diag_object%FMS_diag_fields(registered_variables)
+!> Register the data for the field
+ call fieldptr%register(modname, varname, diag_field_indices, &
+ axes, init_time, longname, units, missing_value, varRange, mask_variant, standname, &
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
+!> Get the file IDs from the field indicies from the yaml
+ file_ids = get_diag_files_id(diag_field_indices)
+!> Add the axis information, initial time, and field IDs to the files
+ if (present(axes) .and. present(init_time)) then
+ do i = 1, size(file_ids)
+ fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file
+ call fileptr%add_field_id(fieldptr%get_id())
+ call fileptr%set_domain_from_axis(axes)
+ call fileptr%add_axes(axes)
+ call fileptr%add_start_time(init_time)
+ enddo
+ elseif (present(axes)) then !only axes present
+ do i = 1, size(file_ids)
+ fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file
+ call fileptr%add_field_id(fieldptr%get_id())
+ call fileptr%set_domain_from_axis(axes)
+ call fileptr%add_axes(axes)
+ enddo
+ elseif (present(init_time)) then !only inti time present
+ do i = 1, size(file_ids)
+ fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file
+ call fileptr%add_field_id(fieldptr%get_id())
+ call fileptr%add_start_time(init_time)
+ enddo
+ else !no axis or init time present
+ do i = 1, size(file_ids)
+ fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file
+ call fileptr%add_field_id(fieldptr%get_id())
enddo
- !> TO DO:
- !! Mark the field as registered in the diag_files
- else
- !> The variable is a scalar
- dobj%type_of_domain = NO_DOMAIN
- dobj%domain => null()
- endif
-
-!> get the optional arguments if included and the diagnostic is in the diag table
- if (present(longname)) dobj%longname = trim(longname)
- if (present(standname)) dobj%standname = trim(standname)
- if (present(units)) dobj%units = trim(units)
- if (present(realm)) dobj%realm = trim(realm)
- if (present(interp_method)) dobj%interp_method = trim(interp_method)
- if (present(tile_count)) then
- allocate(dobj%tile_count)
- dobj%tile_count = tile_count
- endif
-
- if (present(missing_value)) then
- select type (missing_value)
- type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: dobj%missing_value)
- dobj%missing_value = missing_value
- type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: dobj%missing_value)
- dobj%missing_value = missing_value
- type is (real(kind=r4_kind))
- allocate(integer(kind=r4_kind) :: dobj%missing_value)
- dobj%missing_value = missing_value
- type is (real(kind=r8_kind))
- allocate(integer(kind=r8_kind) :: dobj%missing_value)
- dobj%missing_value = missing_value
- class default
- call mpp_error("fms_register_diag_field_obj", &
- "The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",&
- FATAL)
- end select
- else
- allocate(real :: dobj%missing_value)
- select type (miss => dobj%missing_value)
- type is (real)
- miss = real(CMOR_MISSING_VALUE)
- end select
- endif
-
- if (present(varRANGE)) then
- select type (varRANGE)
- type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: dobj%data_RANGE(2))
- dobj%data_RANGE = varRANGE
- type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: dobj%data_RANGE(2))
- dobj%data_RANGE = varRANGE
- type is (real(kind=r4_kind))
- allocate(integer(kind=r4_kind) :: dobj%data_RANGE(2))
- dobj%data_RANGE = varRANGE
- type is (real(kind=r8_kind))
- allocate(integer(kind=r8_kind) :: dobj%data_RANGE(2))
- dobj%data_RANGE = varRANGE
- class default
- call mpp_error("fms_register_diag_field_obj", &
- "The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",&
- FATAL)
- end select
- else
- allocate(real :: dobj%data_RANGE(2))
- select type (varRANGE => dobj%data_RANGE)
- type is (real)
- varRANGE = real(CMOR_MISSING_VALUE)
- end select
- endif
-
- if (present(area)) then
- if (area < 0) call mpp_error("fms_register_diag_field_obj", &
- "The area id passed with field_name"//trim(varname)//" has not been registered."&
- "Check that there is a register_diag_field call for the AREA measure and that is in the"&
- "diag_table.yaml", FATAL)
- allocate(dobj%area)
- dobj%area = area
- endif
-
- if (present(volume)) then
- if (volume < 0) call mpp_error("fms_register_diag_field_obj", &
- "The volume id passed with field_name"//trim(varname)//" has not been registered."&
- "Check that there is a register_diag_field call for the VOLUME measure and that is in the"&
- "diag_table.yaml", FATAL)
- allocate(dobj%volume)
- dobj%volume = volume
- endif
-
- if (present(mask_variant)) then
- allocate(dobj%mask_variant)
- dobj%mask_variant = mask_variant
- endif
-
- if (present(do_not_log)) then
- allocate(dobj%do_not_log)
- dobj%do_not_log = do_not_log
endif
-
- !< Allocate space for any additional variable attributes
- !< These will be fill out when calling `diag_field_add_attribute`
- allocate(dobj%attributes(max_field_attributes))
- dobj%num_attributes = 0
- dobj%registered = .true.
+ nullify (fileptr)
+ nullify (fieldptr)
#endif
end subroutine fms_register_diag_field_obj
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!> \brief Sets the diag_id. This can only be done if a variable is unregistered
-subroutine set_diag_id(objin , id)
- class (fmsDiagObject_type) , intent(inout):: objin
- integer :: id
- if (allocated(objin%registered)) then
- if (objin%registered) then
- call mpp_error("set_diag_id", "The variable"//objin%varname//" is already registered", FATAL)
- endif
- else
- objin%diag_id = id
- endif
-end subroutine set_diag_id
-!> \brief Find the type of the variable and store it in the object
-subroutine set_vartype(objin , var)
- class (fmsDiagObject_type) , intent(inout):: objin
- class(*) :: var
- select type (var)
- type is (real(kind=8))
- objin%vartype = r8
- type is (real(kind=4))
- objin%vartype = r4
- type is (integer(kind=8))
- objin%vartype = i8
- type is (integer(kind=4))
- objin%vartype = i4
- type is (character(*))
- objin%vartype = string
- class default
- objin%vartype = null_type_int
- call mpp_error("set_vartype", "The variable"//objin%varname//" is not a supported type "// &
- " r8, r4, i8, i4, or string.", warning)
- end select
-end subroutine set_vartype
-!> \brief Prints to the screen what type the diag variable is
-subroutine what_is_vartype(objin)
- class (fmsDiagObject_type) , intent(inout):: objin
- if (.not. allocated(objin%vartype)) then
- call mpp_error("what_is_vartype", "The variable type has not been set prior to this call", warning)
- return
- endif
- select case (objin%vartype)
- case (r8)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
- " is REAL(kind=8)", NOTE)
- case (r4)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
- " is REAL(kind=4)", NOTE)
- case (i8)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
- " is INTEGER(kind=8)", NOTE)
- case (i4)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
- " is INTEGER(kind=4)", NOTE)
- case (string)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
- " is CHARACTER(*)", NOTE)
- case (null_type_int)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
- " was not set", WARNING)
- case default
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
- " is not supported by diag_manager", FATAL)
- end select
-end subroutine what_is_vartype
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!MZ Is this a TODO. Many problems:
-!> \brief Registers the object
-subroutine diag_ob_registered(objin , reg)
- class (fmsDiagObject_type) , intent(inout):: objin
- logical , intent(in) :: reg !< If registering, this is true
- objin%registered = reg
-end subroutine diag_ob_registered
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!> \brief Copies the calling object into the object that is the argument of the subroutine
-subroutine copy_diag_obj(objin , objout)
- class (fmsDiagObject_type) , intent(in) :: objin
- class (fmsDiagObject_type) , intent(inout) , allocatable :: objout !< The destination of the copy
-select type (objout)
- class is (fmsDiagObject_type)
-
- if (allocated(objin%registered)) then
- objout%registered = objin%registered
- else
- call mpp_error("copy_diag_obj", "You can only copy objects that have been registered",warning)
- endif
- objout%diag_id = objin%diag_id
-
- if (allocated(objin%attributes)) objout%attributes = objin%attributes
- objout%static = objin%static
- if (allocated(objin%frequency)) objout%frequency = objin%frequency
- if (allocated(objin%varname)) objout%varname = objin%varname
-end select
-end subroutine copy_diag_obj
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!> \brief Returns the ID integer for a variable
-!! \return the diag ID
-integer function fms_diag_get_id (dobj) result(diag_id)
- class(fmsDiagObject_type) , intent(inout) :: dobj
-! character(*) , intent(in) :: varname
-!> Check if the diag_object registration has been done
- if (allocated(dobj%registered)) then
- !> Return the diag_id if the variable has been registered
- diag_id = dobj%diag_id
- else
-!> If the variable is not regitered, then return the unregistered value
- diag_id = DIAG_NOT_REGISTERED
- endif
-end function fms_diag_get_id
-
-!> Function to return a character (string) representation of the most basic
-!> object identity info. Intended for debugging and warning. The format produced is:
-!> [dobj: o.varname(string|?), vartype (string|?), o.registered (T|F|?), diag_id (id|?)].
-!> A questionmark "?" is set in place of the variable that is not yet allocated
-!>TODO: Add diag_id ?
-function fms_diag_obj_as_string_basic(dobj) result(rslt)
- class(fmsDiagObject_type), allocatable, intent(in) :: dobj
- character(:), allocatable :: rslt
- character (len=:), allocatable :: registered, vartype, varname, diag_id
- if ( .not. allocated (dobj)) then
- varname = "?"
- vartype = "?"
- registered = "?"
- diag_id = "?"
- rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]"
- return
- end if
-
-! if(allocated (dobj%registered)) then
-! registered = logical_to_cs (dobj%registered)
-! else
-! registered = "?"
-! end if
-
-! if(allocated (dobj%diag_id)) then
-! diag_id = int_to_cs (dobj%diag_id)
-! else
-! diag_id = "?"
-! end if
-
-! if(allocated (dobj%vartype)) then
-! vartype = int_to_cs (dobj%vartype)
-! else
-! registered = "?"
-! end if
-
- if(allocated (dobj%varname)) then
- varname = dobj%varname
- else
- registered = "?"
- end if
-
- rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]"
-
-end function fms_diag_obj_as_string_basic
-
-
-function diag_obj_is_registered (obj) result (rslt)
- class(fmsDiagObject_type), intent(in) :: obj
- logical :: rslt
- rslt = obj%registered
-end function diag_obj_is_registered
-
-function diag_obj_is_static (obj) result (rslt)
- class(fmsDiagObject_type), intent(in) :: obj
- logical :: rslt
- rslt = obj%static
-end function diag_obj_is_static
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Get functions
-
-!> @brief Gets attributes
-!! @return A pointer to the attributes of the diag_obj, null pointer if there are no attributes
-function get_attributes (obj) &
-result(rslt)
- class (fmsDiagObject_type), target, intent(in) :: obj !< diag object
- type(fmsDiagAttribute_type), pointer :: rslt(:)
-
- rslt => null()
- if (obj%num_attributes > 0 ) rslt => obj%attributes
-end function get_attributes
-!> @brief Gets static
-!! @return copy of variable static
-pure function get_static (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- logical :: rslt
- rslt = obj%static
-end function get_static
-!> @brief Gets regisetered
-!! @return copy of registered
-pure function get_registered (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- logical :: rslt
- rslt = obj%registered
-end function get_registered
-!> @brief Gets mask variant
-!! @return copy of mask variant
-pure function get_mask_variant (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- logical :: rslt
- rslt = obj%mask_variant
-end function get_mask_variant
-!> @brief Gets local
-!! @return copy of local
-pure function get_local (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- logical :: rslt
- rslt = obj%local
-end function get_local
-!> @brief Gets initial time
-!! @return copy of the initial time
-!! TODO
-!function get_init_time (obj) &
-!result(rslt)
-! class (fmsDiagObject_type), intent(in) :: obj !< diag object
-! TYPE(time_type) :: rslt
-!
-!end function get_init_time
-!> @brief Gets vartype
-!! @return copy of The integer related to the variable type
-pure function get_vartype (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- integer :: rslt
- rslt = obj%vartype
-end function get_vartype
-!> @brief Gets varname
-!! @return copy of the variable name
-pure function get_varname (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
- rslt = obj%varname
-end function get_varname
-!> @brief Gets longname
-!! @return copy of the variable long name or a single string if there is no long name
-pure function get_longname (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
- if (allocated(obj%longname)) then
- rslt = obj%longname
- else
- rslt = diag_null_string
- endif
-end function get_longname
-!> @brief Gets standname
-!! @return copy of the standard name or an empty string if standname is not allocated
-pure function get_standname (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
- if (allocated(obj%standname)) then
- rslt = obj%standname
- else
- rslt = diag_null_string
- endif
-end function get_standname
-!> @brief Gets units
-!! @return copy of the units or an empty string if not allocated
-pure function get_units (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
- if (allocated(obj%units)) then
- rslt = obj%units
- else
- rslt = diag_null_string
- endif
-end function get_units
-!> @brief Gets modname
-!! @return copy of the module name that the variable is in or an empty string if not allocated
-pure function get_modname (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
- if (allocated(obj%modname)) then
- rslt = obj%modname
- else
- rslt = diag_null_string
- endif
-end function get_modname
-!> @brief Gets realm
-!! @return copy of the variables modeling realm or an empty string if not allocated
-pure function get_realm (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
- if (allocated(obj%realm)) then
- rslt = obj%realm
- else
- rslt = diag_null_string
- endif
-end function get_realm
-!> @brief Gets interp_method
-!! @return copy of The interpolation method or an empty string if not allocated
-pure function get_interp_method (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
- if (allocated(obj%interp_method)) then
- rslt = obj%interp_method
- else
- rslt = diag_null_string
- endif
-end function get_interp_method
-!> @brief Gets frequency
-!! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated
-pure function get_frequency (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- integer, allocatable, dimension (:) :: rslt
- if (allocated(obj%frequency)) then
- allocate (rslt(size(obj%frequency)))
- rslt = obj%frequency
- else
- allocate (rslt(1))
- rslt = DIAG_NULL
- endif
-end function get_frequency
-!> @brief Gets output_units
-!! @return copy of The units of the output or DIAG_NULL is output_units is not allocated
-pure function get_output_units (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- integer,allocatable, dimension (:) :: rslt
- if (allocated(obj%output_units)) then
- allocate (rslt(size(obj%output_units)))
- rslt = obj%output_units
- else
- allocate (rslt(1))
- rslt = DIAG_NULL
- endif
-end function get_output_units
-!> @brief Gets t
-!! @return copy of t
-pure function get_t (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- integer :: rslt
- if (allocated(obj%t)) then
- rslt = obj%t
- else
- rslt = -999
- endif
-end function get_t
-!> @brief Gets tile_count
-!! @return copy of the number of tiles or diag_null if tile_count is not allocated
-pure function get_tile_count (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- integer :: rslt
- if (allocated(obj%tile_count)) then
- rslt = obj%tile_count
- else
- rslt = DIAG_NULL
- endif
-end function get_tile_count
-!> @brief Gets area
-!! @return copy of the area or diag_null if not allocated
-pure function get_area (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- integer :: rslt
- if (allocated(obj%area)) then
- rslt = obj%area
- else
- rslt = diag_null
- endif
-end function get_area
-!> @brief Gets volume
-!! @return copy of the volume or diag_null if volume is not allocated
-pure function get_volume (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- integer :: rslt
- if (allocated(obj%volume)) then
- rslt = obj%volume
- else
- rslt = diag_null
- endif
-end function get_volume
-!> @brief Gets missing_value
-!! @return copy of The missing value
-function get_missing_value (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- class(*),allocatable :: rslt
- if (allocated(obj%missing_value)) then
- select type (miss => obj%missing_value)
- type is (integer(kind=i4_kind))
- allocate (integer(kind=i4_kind) :: rslt)
- rslt = miss
- type is (integer(kind=i8_kind))
- allocate (integer(kind=i8_kind) :: rslt)
- rslt = miss
- type is (real(kind=r4_kind))
- allocate (integer(kind=i4_kind) :: rslt)
- rslt = miss
- type is (real(kind=r8_kind))
- allocate (integer(kind=i4_kind) :: rslt)
- rslt = miss
- class default
- call mpp_error ("get_missing_value", &
- "The missing value is not a r8, r4, i8, or i4",&
- FATAL)
- end select
- else
- call mpp_error ("get_missing_value", &
- "The missing value is not allocated", FATAL)
- endif
-end function get_missing_value
-!> @brief Gets data_range
-!! @return copy of the data range
-function get_data_RANGE (obj) &
-result(rslt)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- class(*),allocatable :: rslt(:)
- if (allocated(obj%data_RANGE)) then
- select type (r => obj%data_RANGE)
- type is (integer(kind=i4_kind))
- allocate (integer(kind=i4_kind) :: rslt(2))
- rslt = r
- type is (integer(kind=i8_kind))
- allocate (integer(kind=i8_kind) :: rslt(2))
- rslt = r
- type is (real(kind=r4_kind))
- allocate (integer(kind=i4_kind) :: rslt(2))
- rslt = r
- type is (real(kind=r8_kind))
- allocate (integer(kind=i4_kind) :: rslt(2))
- rslt = r
- class default
- call mpp_error ("get_data_RANGE", &
- "The data_RANGE value is not a r8, r4, i8, or i4",&
- FATAL)
- end select
- else
- call mpp_error ("get_data_RANGE", &
- "The data_RANGE value is not allocated", FATAL)
- endif
-end function get_data_RANGE
-!> @brief Gets axis
-!! @return copy of axis information
-!! TODO
-!function get_axis (obj) &
-!result(rslt)
-! class (fmsDiagObject_type), intent(in) :: obj !< diag object
-! type (diag_axis_type), allocatable, dimension(:) :: rslt
-!
-!end function get_axis
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Operator Overrides !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!> \brief override for checking if object ID is greater than an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_gt_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i >= diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (obj%diag_id > i)
- endif
-end function obj_gt_int
-!> \brief override for checking if integer (ID) is greater than an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_gt_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i <= diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj)) then
- ll = .true.
- else
- ll = (i > obj%diag_id)
- endif
-end function int_gt_obj
-!> \brief override for checking if object ID is less than an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_lt_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i > diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj)) then
- ll = .false.
- else
- ll = (obj%diag_id < i)
- endif
-end function obj_lt_int
-!> \brief override for checking if integer (ID) is less than an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_lt_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i >= diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj)) then
- ll = .true.
- else
- ll = (i < obj%diag_id)
- endif
-end function int_lt_obj
-!> \brief override for checking if object ID is greater than or equal to an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_ge_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i <= diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (obj%diag_id >= i)
- endif
-end function obj_ge_int
-!> \brief override for checking if integer (ID) is greater than or equal to an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_ge_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i >= diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (i >= obj%diag_id)
- endif
-end function int_ge_obj
-!> \brief override for checking if object ID is less than or equal to an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_le_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i >= diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (obj%diag_id <= i)
- endif
-end function obj_le_int
-!> \brief override for checking if integer (ID) is less than or equal to an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_le_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i <= diag_not_registered) then
- ll = .true.
- elseif (.not.allocated(obj) ) then
- ll = .false.
- else
- ll = (i <= obj%diag_id)
- endif
-end function int_le_obj
-
-!> \brief override for checking if object ID is not equal to an integer (IDs)
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function obj_ne_int (obj,i) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i == diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj) ) then
- ll = .true.
- else
- ll = (obj%diag_id .ne. i)
- endif
-end function obj_ne_int
-
-!> \brief override for checking if integer (ID) is not equal to an object ID
-!> @note unalloacted obj is assumed to equal diag_not_registered
-pure logical function int_ne_obj (i,obj) result(ll)
- class (fms_diag_object), intent(in), allocatable :: obj
- integer, intent(in) :: i
- if (.not.allocated(obj) .and. i == diag_not_registered) then
- ll = .false.
- elseif (.not.allocated(obj) ) then
- ll = .true.
- else
- ll = (i .ne. obj%diag_id)
- endif
-end function int_ne_obj
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!! Allocation checks
-!!> @brief Checks if obj%diag_field is allocated
-!!! @return true if obj%diag_field is allocated
-!logical function has_diag_field (obj)
-! class (fmsDiagObject_type), intent(in) :: obj !< diag object
-! has_diag_field = allocated(obj%diag_field)
-!end function has_diag_field
-!> @brief Checks if obj%diag_id is allocated
-!! @return true if obj%diag_id is allocated
-pure logical function has_diag_id (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_diag_id = allocated(obj%diag_id)
-end function has_diag_id
-!> @brief Checks if obj%metadata is allocated
-!! @return true if obj%metadata is allocated
-pure logical function has_attributes (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_attributes = obj%num_attributes > 0
-end function has_attributes
-!> @brief Checks if obj%static is allocated
-!! @return true if obj%static is allocated
-pure logical function has_static (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_static = allocated(obj%static)
-end function has_static
-!> @brief Checks if obj%registered is allocated
-!! @return true if obj%registered is allocated
-pure logical function has_registered (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_registered = allocated(obj%registered)
-end function has_registered
-!> @brief Checks if obj%mask_variant is allocated
-!! @return true if obj%mask_variant is allocated
-pure logical function has_mask_variant (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_mask_variant = allocated(obj%mask_variant)
-end function has_mask_variant
-!> @brief Checks if obj%local is allocated
-!! @return true if obj%local is allocated
-pure logical function has_local (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_local = allocated(obj%local)
-end function has_local
-!!> @brief Checks if obj%init_time is allocated
-!!! @return true if obj%init_time is allocated
-!logical function has_init_time (obj)
-! class (fmsDiagObject_type), intent(in) :: obj !< diag object
-! has_init_time = allocated(obj%init_time)
-!end function has_init_time
-!> @brief Checks if obj%vartype is allocated
-!! @return true if obj%vartype is allocated
-pure logical function has_vartype (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_vartype = allocated(obj%vartype)
-end function has_vartype
-!> @brief Checks if obj%varname is allocated
-!! @return true if obj%varname is allocated
-pure logical function has_varname (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_varname = allocated(obj%varname)
-end function has_varname
-!> @brief Checks if obj%longname is allocated
-!! @return true if obj%longname is allocated
-pure logical function has_longname (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_longname = allocated(obj%longname)
-end function has_longname
-!> @brief Checks if obj%standname is allocated
-!! @return true if obj%standname is allocated
-pure logical function has_standname (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_standname = allocated(obj%standname)
-end function has_standname
-!> @brief Checks if obj%units is allocated
-!! @return true if obj%units is allocated
-pure logical function has_units (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_units = allocated(obj%units)
-end function has_units
-!> @brief Checks if obj%modname is allocated
-!! @return true if obj%modname is allocated
-pure logical function has_modname (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_modname = allocated(obj%modname)
-end function has_modname
-!> @brief Checks if obj%realm is allocated
-!! @return true if obj%realm is allocated
-pure logical function has_realm (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_realm = allocated(obj%realm)
-end function has_realm
-!> @brief Checks if obj%interp_method is allocated
-!! @return true if obj%interp_method is allocated
-pure logical function has_interp_method (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_interp_method = allocated(obj%interp_method)
-end function has_interp_method
-!> @brief Checks if obj%frequency is allocated
-!! @return true if obj%frequency is allocated
-pure logical function has_frequency (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_frequency = allocated(obj%frequency)
-end function has_frequency
-!> @brief Checks if obj%output_units is allocated
-!! @return true if obj%output_units is allocated
-pure logical function has_output_units (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_output_units = allocated(obj%output_units)
-end function has_output_units
-!> @brief Checks if obj%t is allocated
-!! @return true if obj%t is allocated
-pure logical function has_t (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_t = allocated(obj%t)
-end function has_t
-!> @brief Checks if obj%tile_count is allocated
-!! @return true if obj%tile_count is allocated
-pure logical function has_tile_count (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_tile_count = allocated(obj%tile_count)
-end function has_tile_count
-!> @brief Checks if obj%area is allocated
-!! @return true if obj%area is allocated
-pure logical function has_area (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_area = allocated(obj%area)
-end function has_area
-!> @brief Checks if obj%volume is allocated
-!! @return true if obj%volume is allocated
-pure logical function has_volume (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_volume = allocated(obj%volume)
-end function has_volume
-!> @brief Checks if obj%missing_value is allocated
-!! @return true if obj%missing_value is allocated
-pure logical function has_missing_value (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_missing_value = allocated(obj%missing_value)
-end function has_missing_value
-!> @brief Checks if obj%data_RANGE is allocated
-!! @return true if obj%data_RANGE is allocated
-pure logical function has_data_RANGE (obj)
- class (fmsDiagObject_type), intent(in) :: obj !< diag object
- has_data_RANGE = allocated(obj%data_RANGE)
-end function has_data_RANGE
!> @brief Registers a scalar field
!! @return field index for subsequent call to send_data.
- INTEGER FUNCTION fms_register_diag_field_scalar(module_name, field_name, init_time, &
+INTEGER FUNCTION fms_register_diag_field_scalar(fms_diag_object,module_name, field_name, init_time, &
& long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,&
& area, volume, realm)
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
@@ -1172,21 +220,24 @@ INTEGER FUNCTION fms_register_diag_field_scalar(module_name, field_name, init_ti
registered_variables = registered_variables + 1
fms_register_diag_field_scalar = registered_variables
- call diag_objs(registered_variables)%setID(registered_variables)
- call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, &
+ call fms_diag_object%FMS_diag_fields(registered_variables)%setID(registered_variables)
+ call fms_diag_object%FMS_diag_fields(registered_variables)%register(&
+ & module_name, field_name, diag_field_indices, init_time=init_time, &
& longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
& area=area, volume=volume, realm=realm)
deallocate(diag_field_indices)
+#else
+fms_register_diag_field_scalar = diag_not_registered
#endif
-
- end function fms_register_diag_field_scalar
+end function fms_register_diag_field_scalar
!> @brief Registers an array field
!> @return field index for subsequent call to send_data.
- INTEGER FUNCTION fms_register_diag_field_array(module_name, field_name, axes, init_time, &
+INTEGER FUNCTION fms_register_diag_field_array(fms_diag_object, module_name, field_name, axes, init_time, &
& long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,&
& do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis
@@ -1223,21 +274,24 @@ INTEGER FUNCTION fms_register_diag_field_array(module_name, field_name, axes, in
registered_variables = registered_variables + 1
fms_register_diag_field_array = registered_variables
- call diag_objs(registered_variables)%setID(registered_variables)
- call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, init_time=init_time, &
+ call fms_diag_object%FMS_diag_fields(registered_variables)%setID (registered_variables)
+ call fms_diag_object%FMS_diag_fields(registered_variables)%register( &
+ & module_name, field_name, diag_field_indices, init_time=init_time, &
& axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
& interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
deallocate(diag_field_indices)
+#else
+fms_register_diag_field_array = diag_not_registered
#endif
-
end function fms_register_diag_field_array
!> @brief Return field index for subsequent call to send_data.
!! @return field index for subsequent call to send_data.
-INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_name, units,&
+INTEGER FUNCTION fms_register_static_field(fms_diag_object, module_name, field_name, axes, long_name, units,&
& missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
& tile_count, area, volume, realm)
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field
@@ -1276,67 +330,53 @@ INTEGER FUNCTION fms_register_static_field(module_name, field_name, axes, long_n
registered_variables = registered_variables + 1
fms_register_static_field = registered_variables
- call diag_objs(registered_variables)%setID(registered_variables)
- allocate(diag_objs(registered_variables)%static)
- diag_objs(registered_variables)%static = .true.
- call diag_objs(registered_variables)%register(module_name, field_name, diag_field_indices, axes=axes, &
+ call fms_diag_object%FMS_diag_fields(registered_variables)%setID(registered_variables)
+! Include static as optional variable to register here
+ call fms_diag_object%FMS_diag_fields(registered_variables)%register( &
+ & module_name, field_name, diag_field_indices, axes=axes, &
& longname=long_name, units=units, missing_value=missing_value, varrange=range, &
- & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm)
+ & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm, &
+ & static=.true.)
deallocate(diag_field_indices)
+#else
+fms_register_static_field = diag_not_registered
#endif
end function fms_register_static_field
-!> @brief Get a pointer to the diag_object from the id.
-!> @return A pointer to the diag_object or a null pointer if the id is not valid
-FUNCTION get_diag_obj_from_id ( id ) result (obj_ptr)
- integer :: id !< Id of the diag_obj to get
- class(fmsDiagObject_type), pointer :: obj_ptr
-
- obj_ptr => null()
- IF (id >= 1 .and. id <= registered_variables) THEN
- obj_ptr => diag_objs(id)
- END IF
-END FUNCTION get_diag_obj_from_id
-
!> @brief Add a attribute to the diag_obj using the diag_field_id
-subroutine fms_diag_field_add_attribute(diag_field_id, att_name, att_value)
+subroutine fms_diag_field_add_attribute(fms_diag_object, diag_field_id, att_name, att_value)
+ class(fmsDiagObject_type), intent (inout) :: fms_diag_object !< The diag object
integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
-
- type(fmsDiagObject_type), pointer :: obj
-
- obj => get_diag_obj_from_id ( diag_field_id )
- if (.not. associated(obj)) return
-
- obj%num_attributes = obj%num_attributes + 1
- if (obj%num_attributes > max_field_attributes) &
- call mpp_error(FATAL, "diag_field_add_attribute: Number of attributes exceeds max_field_attributes for field:"&
- //trim(obj%varname)//". Increase diag_manager_nml:max_field_attributes.")
-
- call obj%attributes(obj%num_attributes)%add(att_name, att_value)
- nullify(obj)
+#ifdef use_yaml
+!TODO: Value for diag not found
+ if ( diag_field_id .LE. 0 ) THEN
+ RETURN
+ else
+ if (fms_diag_object%FMS_diag_fields(diag_field_id)%is_registered() ) &
+ call fms_diag_object%FMS_diag_fields(diag_field_id)%add_attribute(att_name, att_value)
+ endif
+#endif
end subroutine fms_diag_field_add_attribute
-
-!> @brief Determines the diag_obj id corresponding to a module name and field_name
-!> @return diag_obj id
-PURE FUNCTION fms_get_diag_field_id(module_name, field_name) &
+!> \brief Gets the diag field ID from the module name and field name.
+!> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered
+PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, field_name) &
result(diag_field_id)
-
+ class(fmsDiagObject_type), intent (in) :: fms_diag_object !< The diag object
CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
-
integer :: diag_field_id
- integer :: i !< For do loops
-
+ integer :: i !< For looping
+!> Initialize to not found
diag_field_id = DIAG_FIELD_NOT_FOUND
- do i = 1, registered_variables
- if (diag_objs(i)%get_varname() .eq. trim(field_name) .and. &
- diag_objs(i)%get_modname() .eq. trim(module_name)) then
- diag_field_id = i
- return
- endif
+#ifdef use_yaml
+!> Loop through fields to find it.
+ if (registered_variables < 1) return
+ do i=1,registered_variables
+ diag_field_id = fms_diag_object%FMS_diag_fields(i)%id_from_name(module_name, field_name)
+ if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return
enddo
-end function fms_get_diag_field_id
-
+#endif
+END FUNCTION fms_get_diag_field_id_from_name
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90
index fe71b7a6ef..66d1c20121 100644
--- a/diag_manager/fms_diag_object_container.F90
+++ b/diag_manager/fms_diag_object_container.F90
@@ -20,12 +20,12 @@
!> @defgroup fms_diag_object_container_mod fms_diag_object_container_mod
!> @ingroup diag_manager
!> @brief fms_diag_object_container_mod defines a container class and iterator class
-!! for inserting, removing and searching for fmsDiagObject_type instances
+!! for inserting, removing and searching for fmsDiagField_type instances
!!
!> @author Miguel Zuniga
!!
!! fms_diag_object_container_mod defines a container for inserting, removing and
-!! searching for fmsDiagObject_type instances. It also defined an iterator for
+!! searching for fmsDiagField_type instances. It also defined an iterator for
!! the data in the container. The value returned by the fms_diag_object function get_id()
!! is used for search key comparison.
!!
@@ -40,7 +40,8 @@
!> @addtogroup fms_diag_object_container_mod
!> @{
MODULE fms_diag_object_container_mod
- use fms_diag_object_mod, only: fmsDiagObject_type
+#ifdef use_yaml
+ use fms_diag_field_object_mod, only: fmsDiagField_type
USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE
!! Since this version is based on the FDS linked list:
@@ -48,7 +49,7 @@ MODULE fms_diag_object_container_mod
implicit none
- !> @brief A container of fmsDiagObject_type instances providing insert, remove ,
+ !> @brief A container of fmsDiagField_type instances providing insert, remove ,
!! find/search, and size public member functions. Iterator is provided by
!! the associated iterator class (see dig_obj_iterator class).
!!
@@ -101,7 +102,7 @@ function find_diag_object (this, id , iiter) result (riter)
class(FmsDiagObjIterator_t), intent (in), optional :: iiter
!< An (optional) iterator over the searchable set.
class(FmsDiagObjIterator_t) , allocatable :: riter !< The resultant iterator to the object.
- class(fmsDiagObject_type), pointer:: ptdo !< A pointer to temporaty diagnostic object
+ class(fmsDiagField_type), pointer:: ptdo !< A pointer to temporaty diagnostic object
integer :: status !< A status from iterator operations.
!!
if(present (iiter)) then
@@ -126,7 +127,7 @@ end function find_diag_object
function insert_diag_object (this, id, obj) result (status)
class (FmsDiagObjectContainer_t), intent (in out) :: this
integer, intent (in) :: id !< The id of the object to insert.
- class(fmsDiagObject_type) , intent (in out) :: obj !< The object to insert
+ class(fmsDiagField_type) , intent (in out) :: obj !< The object to insert
integer :: status !< The returned status. 0 for success.
class(FmsDllIterator_t), allocatable :: tliter !< A temporary iterator.
@@ -243,13 +244,13 @@ end function literator_next
function literator_data( this ) result( rdo )
class(FmsDiagObjIterator_t), intent(in) :: this
! null()
gp => this%liter%get()
select type(gp)
- type is (fmsDiagObject_type) !! "type is", not the (polymorphic) "class is"
+ type is (fmsDiagField_type) !! "type is", not the (polymorphic) "class is"
rdo => gp
class default
call error_mesg ('fms_diag_object_container:', &
@@ -284,7 +285,7 @@ subroutine destructor(this)
this%the_linked_list =>null()
end subroutine destructor
-
+#endif
end module fms_diag_object_container_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 2262fffb64..cad5fe118a 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -114,9 +114,9 @@ module fms_diag_yaml_mod
character (len=MAX_STR_LEN), dimension(:), private, allocatable :: file_varlist !< An array of variable names
!! within a file
character (len=MAX_STR_LEN), dimension(:,:), private, allocatable :: file_global_meta !< Array of key(dim=1)
- !! and values(dim=2) to be added as global
- !! meta data to the file
-
+ !! and values(dim=2) to be
+ !! added as global meta data to
+ !! the file
contains
!> All getter functions (functions named get_x(), for member field named x)
@@ -230,6 +230,9 @@ module fms_diag_yaml_mod
type (varList_type), save :: variable_list !< List of all the variables in the diag_table.yaml
type (fileList_type), save :: file_list !< List of all files in the diag_table.yaml
+logical, private :: diag_yaml_module_initialized = .false.
+
+
!> @addtogroup fms_diag_yaml_mod
!> @{
contains
@@ -318,6 +321,8 @@ subroutine diag_yaml_object_init(diag_subset_output)
logical :: write_file !< Flag indicating if the user wants the file to be written
logical :: write_var !< Flag indicating if the user wants the variable to be written
+ if (diag_yaml_module_initialized) return
+
diag_yaml_id = open_and_parse_file("diag_table.yaml")
call diag_get_value_from_key(diag_yaml_id, 0, "title", diag_yaml%diag_title)
@@ -417,6 +422,7 @@ subroutine diag_yaml_object_init(diag_subset_output)
call fms_sort_this(variable_list%var_pointer, total_nvars, variable_list%diag_field_indices)
deallocate(diag_file_ids)
+ diag_yaml_module_initialized = .true.
end subroutine
!> @brief Destroys the diag_yaml object
From 419e5d3f82acfd78d3380247b29807d9535829d4 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Tue, 16 Aug 2022 13:57:14 -0400
Subject: [PATCH 062/168] fix: modern diag make type bound procedures private
except when through the type (#1022)
---
diag_manager/fms_diag_axis_object.F90 | 2 +-
diag_manager/fms_diag_dlinked_list.F90 | 3 +++
diag_manager/fms_diag_field_object.F90 | 3 ++-
diag_manager/fms_diag_object.F90 | 6 ------
diag_manager/fms_diag_object_container.F90 | 2 ++
diag_manager/fms_diag_yaml.F90 | 2 +-
6 files changed, 9 insertions(+), 9 deletions(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 35483fbd54..b3e04647df 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -40,7 +40,7 @@ module fms_diag_axis_object_mod
PRIVATE
- public :: diagAxis_t, set_subaxis, fms_diag_axis_init, fms_diag_axis_object_init, fms_diag_axis_object_end, &
+ public :: diagAxis_t, fms_diag_axis_init, fms_diag_axis_object_init, fms_diag_axis_object_end, &
& get_domain_and_domain_type, axis_obj, diagDomain_t, sub_axis_objs, fms_diag_axis_add_attribute, &
& DIAGDOMAIN2D_T, fms_get_axis_length
!> @}
diff --git a/diag_manager/fms_diag_dlinked_list.F90 b/diag_manager/fms_diag_dlinked_list.F90
index 850a106b89..c220ef62e2 100644
--- a/diag_manager/fms_diag_dlinked_list.F90
+++ b/diag_manager/fms_diag_dlinked_list.F90
@@ -43,6 +43,9 @@
MODULE fms_diag_dlinked_list_mod
USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE
implicit none
+
+ private
+
!> The doubly-linked list node type.
type, public:: FmsDlListNode_t
private
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 559bd4e423..0f92cee901 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -29,6 +29,8 @@ module fms_diag_field_object_mod
implicit none
+private
+
!> \brief Object that holds all variable information
type fmsDiagField_type
type (diagYamlFilesVar_type), allocatable, dimension(:) :: diag_field !< info from diag_table for this variable
@@ -138,7 +140,6 @@ module fms_diag_field_object_mod
public :: fmsDiagField_type
public :: fms_diag_fields_object_init
public :: null_ob
-public :: copy_diag_obj, fms_diag_get_id
public :: fms_diag_field_object_end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index f746c029d6..8776b2c6cf 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -59,12 +59,6 @@ module fms_diag_object_mod
type (fmsDiagObject_type), target :: fms_diag_object
integer, private :: registered_variables !< Number of registered variables
-public :: fms_register_diag_field_obj
-public :: fms_register_diag_field_scalar
-public :: fms_register_diag_field_array
-public :: fms_register_static_field
-public :: fms_diag_field_add_attribute
-public :: fms_get_diag_field_id_from_name
public :: fms_diag_object
public :: fmsDiagObject_type
diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90
index 66d1c20121..cb582eb523 100644
--- a/diag_manager/fms_diag_object_container.F90
+++ b/diag_manager/fms_diag_object_container.F90
@@ -49,6 +49,8 @@ MODULE fms_diag_object_container_mod
implicit none
+ private
+
!> @brief A container of fmsDiagField_type instances providing insert, remove ,
!! find/search, and size public member functions. Iterator is provided by
!! the associated iterator class (see dig_obj_iterator class).
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index cad5fe118a..631a6cf82c 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -47,7 +47,7 @@ module fms_diag_yaml_mod
public :: diag_yaml
public :: diag_yaml_object_init, diag_yaml_object_end
-public :: diagYamlObject_type, get_diag_yaml_obj, get_title, get_basedate, get_diag_files, get_diag_fields
+public :: diagYamlObject_type, get_diag_yaml_obj
public :: diagYamlFiles_type, diagYamlFilesVar_type
public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_id
!> @}
From 48a1c163bab5647bef3bfe3c97fcf992a2246ea1 Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Tue, 16 Aug 2022 13:58:37 -0400
Subject: [PATCH 063/168] docs: modern diag add class uml diagrams (#1018)
---
.../fms_diag_object_relationships.drawio | 277 ++++++++++++++++++
1 file changed, 277 insertions(+)
create mode 100644 diag_manager/docs_uml/fms_diag_object_relationships.drawio
diff --git a/diag_manager/docs_uml/fms_diag_object_relationships.drawio b/diag_manager/docs_uml/fms_diag_object_relationships.drawio
new file mode 100644
index 0000000000..c431fb9f9d
--- /dev/null
+++ b/diag_manager/docs_uml/fms_diag_object_relationships.drawio
@@ -0,0 +1,277 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
From 3eb9b807253520c956ef130950ee494353a99338 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 16 Aug 2022 15:12:35 -0400
Subject: [PATCH 064/168] chore: clean up the diag registers (#1023)
---
diag_manager/fms_diag_field_object.F90 | 85 ++++++++---------
diag_manager/fms_diag_object.F90 | 122 ++++++++++---------------
2 files changed, 82 insertions(+), 125 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 0f92cee901..132c8048cf 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -44,7 +44,6 @@ module fms_diag_field_object_mod
logical, allocatable, private :: mask_variant !< If there is a mask variant
logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field
logical, allocatable, private :: local !< If the output is local
- TYPE(time_type), private :: init_time !< The initial time
integer, allocatable, private :: vartype !< the type of varaible
character(len=:), allocatable, private :: varname !< the name of the variable
character(len=:), allocatable, private :: longname !< longname of the variable
@@ -91,7 +90,6 @@ module fms_diag_field_object_mod
procedure :: has_registered
procedure :: has_mask_variant
procedure :: has_local
-!TODO procedure :: has_init_time
procedure :: has_vartype
procedure :: has_varname
procedure :: has_longname
@@ -126,14 +124,12 @@ module fms_diag_field_object_mod
procedure :: get_volume
procedure :: get_missing_value
procedure :: get_data_RANGE
-!TODO procedure :: get_init_time
-!TODO procedure :: get_axis
+ procedure :: get_axis_id
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagField_type) :: null_ob
logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized
-integer, private :: registered_variables !< Number of registered variables
!type(fmsDiagField_type) :: diag_object_placeholder (10)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -161,7 +157,6 @@ logical function fms_diag_fields_object_init(ob)
class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object
integer :: i !< For looping
allocate(ob(get_num_unique_fields()))
- registered_variables = 0
do i = 1,size(ob)
ob(i)%diag_id = diag_not_registered !null_ob%diag_id
ob(i)%registered = .false.
@@ -173,7 +168,7 @@ end function fms_diag_fields_object_init
!> \Description Fills in and allocates (when necessary) the values in the diagnostic object
subroutine fms_register_diag_field_obj &
!(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
- (dobj, modname, varname, diag_field_indices, axes, init_time, &
+ (dobj, modname, varname, diag_field_indices, axes, &
longname, units, missing_value, varRange, mask_variant, standname, &
do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
@@ -182,7 +177,6 @@ subroutine fms_register_diag_field_obj &
CHARACTER(len=*), INTENT(in) :: varname !< The variable name
integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
!! in the yaml object
- TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Initial time
INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies
CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables
@@ -209,6 +203,10 @@ subroutine fms_register_diag_field_obj &
!> Fill in information from the register call
dobj%varname = trim(varname)
dobj%modname = trim(modname)
+
+!> Add the yaml info to the diag_object
+ dobj%diag_field = get_diag_fields_entries(diag_field_indices)
+
!> Add axis and domain information
if (present(axes)) then
dobj%axis_ids = axes
@@ -501,7 +499,7 @@ end function get_attributes
pure function get_static (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- logical :: rslt
+ logical :: rslt
rslt = obj%static
end function get_static
!> @brief Gets regisetered
@@ -509,7 +507,7 @@ end function get_static
pure function get_registered (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- logical :: rslt
+ logical :: rslt
rslt = obj%registered
end function get_registered
!> @brief Gets mask variant
@@ -517,7 +515,7 @@ end function get_registered
pure function get_mask_variant (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- logical :: rslt
+ logical :: rslt
rslt = obj%mask_variant
end function get_mask_variant
!> @brief Gets local
@@ -525,24 +523,15 @@ end function get_mask_variant
pure function get_local (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- logical :: rslt
+ logical :: rslt
rslt = obj%local
end function get_local
-!> @brief Gets initial time
-!! @return copy of the initial time
-!! TODO
-!function get_init_time (obj) &
-!result(rslt)
-! class (fmsDiagField_type), intent(in) :: obj !< diag object
-! TYPE(time_type) :: rslt
-!
-!end function get_init_time
-!> @brief Gets vartype
+!> @brief Gets vartype
!! @return copy of The integer related to the variable type
pure function get_vartype (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- integer :: rslt
+ integer :: rslt
rslt = obj%vartype
end function get_vartype
!> @brief Gets varname
@@ -550,7 +539,7 @@ end function get_vartype
pure function get_varname (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
+ character(len=:), allocatable :: rslt
rslt = obj%varname
end function get_varname
!> @brief Gets longname
@@ -558,7 +547,7 @@ end function get_varname
pure function get_longname (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
+ character(len=:), allocatable :: rslt
if (allocated(obj%longname)) then
rslt = obj%longname
else
@@ -570,7 +559,7 @@ end function get_longname
pure function get_standname (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
+ character(len=:), allocatable :: rslt
if (allocated(obj%standname)) then
rslt = obj%standname
else
@@ -582,7 +571,7 @@ end function get_standname
pure function get_units (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
+ character(len=:), allocatable :: rslt
if (allocated(obj%units)) then
rslt = obj%units
else
@@ -594,7 +583,7 @@ end function get_units
pure function get_modname (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
+ character(len=:), allocatable :: rslt
if (allocated(obj%modname)) then
rslt = obj%modname
else
@@ -606,7 +595,7 @@ end function get_modname
pure function get_realm (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
+ character(len=:), allocatable :: rslt
if (allocated(obj%realm)) then
rslt = obj%realm
else
@@ -618,7 +607,7 @@ end function get_realm
pure function get_interp_method (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- character(len=:), allocatable :: rslt
+ character(len=:), allocatable :: rslt
if (allocated(obj%interp_method)) then
rslt = obj%interp_method
else
@@ -630,7 +619,7 @@ end function get_interp_method
pure function get_frequency (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- integer, allocatable, dimension (:) :: rslt
+ integer, allocatable, dimension (:) :: rslt
if (allocated(obj%frequency)) then
allocate (rslt(size(obj%frequency)))
rslt = obj%frequency
@@ -644,7 +633,7 @@ end function get_frequency
pure function get_tile_count (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- integer :: rslt
+ integer :: rslt
if (allocated(obj%tile_count)) then
rslt = obj%tile_count
else
@@ -656,7 +645,7 @@ end function get_tile_count
pure function get_area (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- integer :: rslt
+ integer :: rslt
if (allocated(obj%area)) then
rslt = obj%area
else
@@ -710,7 +699,7 @@ end function get_missing_value
function get_data_RANGE (obj) &
result(rslt)
class (fmsDiagField_type), intent(in) :: obj !< diag object
- class(*),allocatable :: rslt(:)
+ class(*),allocatable :: rslt(:)
if (allocated(obj%data_RANGE)) then
select type (r => obj%data_RANGE)
type is (integer(kind=i4_kind))
@@ -735,15 +724,19 @@ function get_data_RANGE (obj) &
"The data_RANGE value is not allocated", FATAL)
endif
end function get_data_RANGE
-!> @brief Gets axis
-!! @return copy of axis information
-!! TODO
-!function get_axis (obj) &
-!result(rslt)
-! class (fmsDiagField_type), intent(in) :: obj !< diag object
-! type (diag_axis_type), allocatable, dimension(:) :: rslt
-!
-!end function get_axis
+!> @brief Gets axis_ids
+!! @return pointer to the axis ids
+function get_axis_id (obj) &
+result(rslt)
+ class (fmsDiagField_type), target, intent(in) :: obj !< diag object
+ integer, pointer, dimension(:) :: rslt !< field's axis_ids
+
+ if(allocated(obj%axis_ids)) then
+ rslt => obj%axis_ids
+ else
+ rslt => null()
+ endif
+end function get_axis_id
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!! Allocation checks
!!> @brief Checks if obj%diag_field is allocated
@@ -788,12 +781,6 @@ pure logical function has_local (obj)
class (fmsDiagField_type), intent(in) :: obj !< diag object
has_local = allocated(obj%local)
end function has_local
-!!> @brief Checks if obj%init_time is allocated
-!!! @return true if obj%init_time is allocated
-!logical function has_init_time (obj)
-! class (fmsDiagField_type), intent(in) :: obj !< diag object
-! has_init_time = allocated(obj%init_time)
-!end function has_init_time
!> @brief Checks if obj%vartype is allocated
!! @return true if obj%vartype is allocated
pure logical function has_vartype (obj)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 8776b2c6cf..c250ef887a 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -36,7 +36,7 @@ module fms_diag_object_mod
!TODO add container arrays
#ifdef use_yaml
private
-!TODO: Remove FMS prefix from variables in this type
+!TODO: Remove FMS prefix from variables in this type
class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files
class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields
integer, private :: registered_variables !< Number of registered variables
@@ -58,7 +58,6 @@ module fms_diag_object_mod
end type fmsDiagObject_type
type (fmsDiagObject_type), target :: fms_diag_object
-integer, private :: registered_variables !< Number of registered variables
public :: fms_diag_object
public :: fmsDiagObject_type
@@ -80,8 +79,8 @@ subroutine fms_diag_object_init (obj,diag_subset_output)
CALL fms_diag_axis_object_init()
obj%files_initialized = fms_diag_files_object_init(obj%FMS_diag_files)
obj%fields_initialized = fms_diag_fields_object_init (obj%FMS_diag_fields)
- registered_variables = 0
- obj%initialized = .true.
+ obj%registered_variables = 0
+ obj%initialized = .true.
#else
call mpp_error("fms_diag_object_init",&
"You must compile with -Duse_yaml to use the option use_modern_diag", FATAL)
@@ -100,18 +99,18 @@ subroutine fms_diag_object_end (obj)
obj%initialized = .false.
#endif
end subroutine fms_diag_object_end
-!> \Description Fills in and allocates (when necessary) the values in the diagnostic object
-subroutine fms_register_diag_field_obj &
- !(field_obj, modname, varname, axes, time, longname, units, missing_value, metadata)
- (fms_diag_object, modname, varname, diag_field_indices, axes, init_time, &
+
+!> @brief Registers a field.
+!! @description This to avoid having duplicate code in each of the _scalar, _array and _static register calls
+!! @return field index for subsequent call to send_data.
+integer function fms_register_diag_field_obj &
+ (fms_diag_object, modname, varname, axes, init_time, &
longname, units, missing_value, varRange, mask_variant, standname, &
- do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: modname !< The module name
CHARACTER(len=*), INTENT(in) :: varname !< The variable name
- integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
- !! in the yaml object
TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Initial time
INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies
CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
@@ -131,20 +130,35 @@ subroutine fms_register_diag_field_obj &
INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id of the cell volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
!! modeling_realm attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: static !< True if the variable is static
#ifdef use_yaml
- class (fmsDiagFile_type), pointer :: fileptr => null()
- class (fmsDiagField_type), pointer :: fieldptr => null()
+ class (fmsDiagFile_type), pointer :: fileptr => null() !< Pointer to the diag_file
+ class (fmsDiagField_type), pointer :: fieldptr => null() !< Pointer to the diag_field
integer, allocatable :: file_ids(:) !< The file IDs for this variable
integer :: i !< For do loops
- integer :: j !< fms_diag_object%FMS_diag_fields%file_ids(i) (for less typing :)
-
+ integer, allocatable :: diag_field_indices(:) !< indices where the field was found in the yaml
+
+ diag_field_indices = find_diag_field(varname, modname)
+ if (diag_field_indices(1) .eq. diag_null) then
+ !< The field was not found in the table, so return diag_null
+ fms_register_diag_field_obj = diag_null
+ deallocate(diag_field_indices)
+ return
+ endif
+
+ fms_diag_object%registered_variables = fms_diag_object%registered_variables + 1
+ fms_register_diag_field_obj = fms_diag_object%registered_variables
+
+ call fms_diag_object%FMS_diag_fields(fms_diag_object%registered_variables)%&
+ &setID(fms_diag_object%registered_variables)
+
!> Use pointers for convenience
- fieldptr => fms_diag_object%FMS_diag_fields(registered_variables)
+ fieldptr => fms_diag_object%FMS_diag_fields(fms_diag_object%registered_variables)
!> Register the data for the field
call fieldptr%register(modname, varname, diag_field_indices, &
- axes, init_time, longname, units, missing_value, varRange, mask_variant, standname, &
- do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
+ axes, longname, units, missing_value, varRange, mask_variant, standname, &
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
!> Get the file IDs from the field indicies from the yaml
file_ids = get_diag_files_id(diag_field_indices)
!> Add the axis information, initial time, and field IDs to the files
@@ -177,8 +191,9 @@ subroutine fms_register_diag_field_obj &
endif
nullify (fileptr)
nullify (fieldptr)
+ deallocate(diag_field_indices)
#endif
-end subroutine fms_register_diag_field_obj
+end function fms_register_diag_field_obj
!> @brief Registers a scalar field
!! @return field index for subsequent call to send_data.
@@ -201,27 +216,12 @@ INTEGER FUNCTION fms_register_diag_field_scalar(fms_diag_object,module_name, fie
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
#ifdef use_yaml
- integer, allocatable :: diag_field_indices(:) !< indices where the field was found
-
- diag_field_indices = find_diag_field(field_name, module_name)
- if (diag_field_indices(1) .eq. diag_null) then
- !< The field was not found in the table, so return diag_null
- fms_register_diag_field_scalar = diag_null
- deallocate(diag_field_indices)
- return
- endif
-
- registered_variables = registered_variables + 1
- fms_register_diag_field_scalar = registered_variables
-
- call fms_diag_object%FMS_diag_fields(registered_variables)%setID(registered_variables)
- call fms_diag_object%FMS_diag_fields(registered_variables)%register(&
- & module_name, field_name, diag_field_indices, init_time=init_time, &
+ fms_register_diag_field_scalar = fms_diag_object%register(&
+ & module_name, field_name, init_time=init_time, &
& longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
& area=area, volume=volume, realm=realm)
- deallocate(diag_field_indices)
-#else
+#else
fms_register_diag_field_scalar = diag_not_registered
#endif
end function fms_register_diag_field_scalar
@@ -255,26 +255,11 @@ INTEGER FUNCTION fms_register_diag_field_array(fms_diag_object, module_name, fie
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
#ifdef use_yaml
- integer, allocatable :: diag_field_indices(:) !< indices of diag_field yaml where the field was found
-
- diag_field_indices = find_diag_field(field_name, module_name)
- if (diag_field_indices(1) .eq. diag_null) then
- !< The field was not found in the table, so return diag_null
- fms_register_diag_field_array = diag_null
- deallocate(diag_field_indices)
- return
- endif
-
- registered_variables = registered_variables + 1
- fms_register_diag_field_array = registered_variables
-
- call fms_diag_object%FMS_diag_fields(registered_variables)%setID (registered_variables)
- call fms_diag_object%FMS_diag_fields(registered_variables)%register( &
- & module_name, field_name, diag_field_indices, init_time=init_time, &
+ fms_register_diag_field_array = fms_diag_object%register( &
+ & module_name, field_name, init_time=init_time, &
& axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
& interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
- deallocate(diag_field_indices)
#else
fms_register_diag_field_array = diag_not_registered
#endif
@@ -311,27 +296,12 @@ INTEGER FUNCTION fms_register_static_field(fms_diag_object, module_name, field_n
!! modeling_realm attribute
#ifdef use_yaml
- integer, allocatable :: diag_field_indices(:) !< indices where the field was foun
-
- diag_field_indices = find_diag_field(field_name, module_name)
- if (diag_field_indices(1) .eq. diag_null) then
- !< The field was not found in the table, so return diag_null
- fms_register_static_field = diag_null
- deallocate(diag_field_indices)
- return
- endif
-
- registered_variables = registered_variables + 1
- fms_register_static_field = registered_variables
-
- call fms_diag_object%FMS_diag_fields(registered_variables)%setID(registered_variables)
! Include static as optional variable to register here
- call fms_diag_object%FMS_diag_fields(registered_variables)%register( &
- & module_name, field_name, diag_field_indices, axes=axes, &
+ fms_register_static_field = fms_diag_object%register( &
+ & module_name, field_name, axes=axes, &
& longname=long_name, units=units, missing_value=missing_value, varrange=range, &
& standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm, &
& static=.true.)
- deallocate(diag_field_indices)
#else
fms_register_static_field = diag_not_registered
#endif
@@ -345,8 +315,8 @@ subroutine fms_diag_field_add_attribute(fms_diag_object, diag_field_id, att_name
class(*), intent(in) :: att_value(:) !< The attribute value to add
#ifdef use_yaml
!TODO: Value for diag not found
- if ( diag_field_id .LE. 0 ) THEN
- RETURN
+ if ( diag_field_id .LE. 0 ) THEN
+ RETURN
else
if (fms_diag_object%FMS_diag_fields(diag_field_id)%is_registered() ) &
call fms_diag_object%FMS_diag_fields(diag_field_id)%add_attribute(att_name, att_value)
@@ -362,12 +332,12 @@ PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, fiel
CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
integer :: diag_field_id
integer :: i !< For looping
-!> Initialize to not found
+!> Initialize to not found
diag_field_id = DIAG_FIELD_NOT_FOUND
#ifdef use_yaml
!> Loop through fields to find it.
- if (registered_variables < 1) return
- do i=1,registered_variables
+ if (fms_diag_object%registered_variables < 1) return
+ do i=1,fms_diag_object%registered_variables
diag_field_id = fms_diag_object%FMS_diag_fields(i)%id_from_name(module_name, field_name)
if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return
enddo
From 70d3c527832177ea5e9fbecd51a4bcc63ad8ee95 Mon Sep 17 00:00:00 2001
From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com>
Date: Tue, 23 Aug 2022 07:37:03 -0400
Subject: [PATCH 065/168] style: Modifying several classes to use the "this" in
type bound procedures. (#1025)
---
diag_manager/diag_data.F90 | 27 +-
diag_manager/fms_diag_axis_object.F90 | 194 ++++-----
diag_manager/fms_diag_field_object.F90 | 531 ++++++++++++++-----------
diag_manager/fms_diag_file_object.F90 | 298 ++++++++------
diag_manager/fms_diag_object.F90 | 70 ++--
5 files changed, 602 insertions(+), 518 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index d54468aec3..bb41a98cdd 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -325,7 +325,6 @@ MODULE diag_data_mod
type fmsDiagAttribute_type
class(*), allocatable :: att_value(:) !< Value of the attribute
character(len=:), allocatable :: att_name !< Name of the attribute
-
contains
procedure :: add => fms_add_attribute
end type fmsDiagAttribute_type
@@ -537,31 +536,31 @@ function get_base_second() &
res = base_second
end function get_base_second
- subroutine fms_add_attribute(obj, att_name, att_value)
- class(fmsDiagAttribute_type), intent(inout) :: obj !< Diag attribute type
+ subroutine fms_add_attribute(this, att_name, att_value)
+ class(fmsDiagAttribute_type), intent(inout) :: this !< Diag attribute type
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
integer :: natt !< the size of att_value
natt = size(att_value)
- obj%att_name = att_name
+ this%att_name = att_name
select type (att_value)
type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: obj%att_value(natt))
- obj%att_value = att_value
+ allocate(integer(kind=i4_kind) :: this%att_value(natt))
+ this%att_value = att_value
type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: obj%att_value(natt))
- obj%att_value = att_value
+ allocate(integer(kind=i8_kind) :: this%att_value(natt))
+ this%att_value = att_value
type is (real(kind=r4_kind))
- allocate(real(kind=r4_kind) :: obj%att_value(natt))
- obj%att_value = att_value
+ allocate(real(kind=r4_kind) :: this%att_value(natt))
+ this%att_value = att_value
type is (real(kind=r8_kind))
- allocate(real(kind=r8_kind) :: obj%att_value(natt))
- obj%att_value = att_value
+ allocate(real(kind=r8_kind) :: this%att_value(natt))
+ this%att_value = att_value
type is (character(len=*))
- allocate(character(len=len(att_value)) :: obj%att_value(natt))
- obj%att_value = att_value
+ allocate(character(len=len(att_value)) :: this%att_value(natt))
+ this%att_value = att_value
end select
end subroutine fms_add_attribute
END MODULE diag_data_mod
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index b3e04647df..085d01008a 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -133,9 +133,9 @@ module fms_diag_axis_object_mod
!!!!!!!!!!!!!!!!! DIAG AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Initialize the axis
- subroutine register_diag_axis_obj(obj, axis_name, axis_data, units, cart_name, long_name, direction,&
+ subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name, long_name, direction,&
& set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position )
- class(diagAxis_t), INTENT(out) :: obj !< Diag_axis obj
+ class(diagAxis_t), INTENT(out) :: this !< Diag_axis obj
CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
class(*), INTENT(in) :: axis_data(:) !< Array of coordinate values
CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
@@ -153,91 +153,91 @@ subroutine register_diag_axis_obj(obj, axis_name, axis_data, units, cart_name, l
INTEGER, INTENT(in), OPTIONAL :: tile_count !< Number of tiles
INTEGER, INTENT(in), OPTIONAL :: domain_position !< Domain position, "NORTH" or "EAST"
- obj%axis_name = trim(axis_name)
- obj%units = trim(units)
- obj%cart_name = uppercase(cart_name)
- call check_if_valid_cart_name(obj%cart_name)
+ this%axis_name = trim(axis_name)
+ this%units = trim(units)
+ this%cart_name = uppercase(cart_name)
+ call check_if_valid_cart_name(this%cart_name)
- if (present(long_name)) obj%long_name = trim(long_name)
+ if (present(long_name)) this%long_name = trim(long_name)
select type (axis_data)
type is (real(kind=r8_kind))
- allocate(real(kind=r8_kind) :: obj%axis_data(size(axis_data)))
- obj%axis_data = axis_data
- obj%type_of_data = "double" !< This is what fms2_io expects in the register_field call
+ allocate(real(kind=r8_kind) :: this%axis_data(size(axis_data)))
+ this%axis_data = axis_data
+ this%type_of_data = "double" !< This is what fms2_io expects in the register_field call
type is (real(kind=r4_kind))
- allocate(real(kind=r4_kind) :: obj%axis_data(size(axis_data)))
- obj%axis_data = axis_data
- obj%type_of_data = "float" !< This is what fms2_io expects in the register_field call
+ allocate(real(kind=r4_kind) :: this%axis_data(size(axis_data)))
+ this%axis_data = axis_data
+ this%type_of_data = "float" !< This is what fms2_io expects in the register_field call
class default
call mpp_error(FATAL, "The axis_data in your diag_axis_init call is not a supported type. &
& Currently only r4 and r8 data is supported.")
end select
- obj%type_of_domain = NO_DOMAIN
+ this%type_of_domain = NO_DOMAIN
if (present(Domain)) then
if (present(Domain2) .or. present(DomainU)) call mpp_error(FATAL, &
"The presence of Domain with any other domain type is prohibited. "//&
"Check you diag_axis_init call for axis_name:"//trim(axis_name))
- allocate(diagDomain1d_t :: obj%axis_domain)
- call obj%axis_domain%set(Domain=Domain)
+ allocate(diagDomain1d_t :: this%axis_domain)
+ call this%axis_domain%set(Domain=Domain)
else if (present(Domain2)) then
if (present(DomainU)) call mpp_error(FATAL, &
"The presence of Domain2 with any other domain type is prohibited. "//&
"Check you diag_axis_init call for axis_name:"//trim(axis_name))
- allocate(diagDomain2d_t :: obj%axis_domain)
- call obj%axis_domain%set(Domain2=Domain2)
- obj%type_of_domain = TWO_D_DOMAIN
+ allocate(diagDomain2d_t :: this%axis_domain)
+ call this%axis_domain%set(Domain2=Domain2)
+ this%type_of_domain = TWO_D_DOMAIN
else if (present(DomainU)) then
- allocate(diagDomainUg_t :: obj%axis_domain)
- call obj%axis_domain%set(DomainU=DomainU)
- obj%type_of_domain = UG_DOMAIN
+ allocate(diagDomainUg_t :: this%axis_domain)
+ call this%axis_domain%set(DomainU=DomainU)
+ this%type_of_domain = UG_DOMAIN
endif
- obj%tile_count = 1
- if (present(tile_count)) obj%tile_count = tile_count
+ this%tile_count = 1
+ if (present(tile_count)) this%tile_count = tile_count
- obj%domain_position = CENTER
- if (present(domain_position)) obj%domain_position = domain_position
- call check_if_valid_domain_position(obj%domain_position)
+ this%domain_position = CENTER
+ if (present(domain_position)) this%domain_position = domain_position
+ call check_if_valid_domain_position(this%domain_position)
- obj%length = size(axis_data)
+ this%length = size(axis_data)
- obj%direction = 0
- if (present(direction)) obj%direction = direction
- call check_if_valid_direction(obj%direction)
+ this%direction = 0
+ if (present(direction)) this%direction = direction
+ call check_if_valid_direction(this%direction)
- obj%edges = 0
- if (present(edges)) obj%edges = edges
- call check_if_valid_edges(obj%edges)
+ this%edges = 0
+ if (present(edges)) this%edges = edges
+ call check_if_valid_edges(this%edges)
- if (present(aux)) obj%aux = trim(aux)
- if (present(req)) obj%req = trim(req)
+ if (present(aux)) this%aux = trim(aux)
+ if (present(req)) this%req = trim(req)
- obj%nsubaxis = 0
- obj%num_attributes = 0
+ this%nsubaxis = 0
+ this%num_attributes = 0
end subroutine register_diag_axis_obj
!> @brief Add an attribute to an axis
- subroutine add_axis_attribute(obj, att_name, att_value)
- class(diagAxis_t),INTENT(INOUT) :: obj !< diag_axis obj
+ subroutine add_axis_attribute(this, att_name, att_value)
+ class(diagAxis_t),INTENT(INOUT) :: this !< diag_axis obj
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
integer :: j !< obj%num_attributes (for less typing)
- if (.not. allocated(obj%attributes)) &
- allocate(obj%attributes(max_axis_attributes))
+ if (.not. allocated(this%attributes)) &
+ allocate(this%attributes(max_axis_attributes))
- obj%num_attributes = obj%num_attributes + 1
+ this%num_attributes = this%num_attributes + 1
- j = obj%num_attributes
- call obj%attributes(j)%add(att_name, att_value)
+ j = this%num_attributes
+ call this%attributes(j)%add(att_name, att_value)
end subroutine add_axis_attribute
!> @brief Write the axis meta data to an open fileobj
- subroutine write_axis_metadata(obj, fileobj, sub_axis_id)
- class(diagAxis_t), target, INTENT(IN) :: obj !< diag_axis obj
+ subroutine write_axis_metadata(this, fileobj, sub_axis_id)
+ class(diagAxis_t), target, INTENT(IN) :: this !< diag_axis obj
class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
integer, OPTIONAL, INTENT(IN) :: sub_axis_id !< ID of the sub_axis, if it exists
@@ -247,11 +247,11 @@ subroutine write_axis_metadata(obj, fileobj, sub_axis_id)
integer :: i !< For do loops
if (present(sub_axis_id)) then
- axis_name => obj%subaxis(sub_axis_id)%subaxis_name
- axis_length = obj%subaxis(sub_axis_id)%ending_index - obj%subaxis(sub_axis_id)%starting_index + 1
+ axis_name => this%subaxis(sub_axis_id)%subaxis_name
+ axis_length = this%subaxis(sub_axis_id)%ending_index - this%subaxis(sub_axis_id)%starting_index + 1
else
- axis_name => obj%axis_name
- axis_length = obj%length
+ axis_name => this%axis_name
+ axis_length = this%length
endif
!< Add the axis as a dimension in the netcdf file based on the type of axis_domain and the fileobj type
@@ -260,17 +260,17 @@ subroutine write_axis_metadata(obj, fileobj, sub_axis_id)
!< Here the axis is not domain decomposed (i.e z_axis)
call register_axis(fileobj, axis_name, axis_length)
type is (FmsNetcdfDomainFile_t)
- select case (obj%type_of_domain)
+ select case (this%type_of_domain)
case (NO_DOMAIN)
!< Here the fileobj is domain decomposed, but the axis is not
!! Domain decomposed fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
call register_axis(fileobj, axis_name, axis_length)
case (TWO_D_DOMAIN)
!< Here the axis is domain decomposed
- call register_axis(fileobj, axis_name, obj%cart_name, domain_position=obj%domain_position)
+ call register_axis(fileobj, axis_name, this%cart_name, domain_position=this%domain_position)
end select
type is (FmsNetcdfUnstructuredDomainFile_t)
- select case (obj%type_of_domain)
+ select case (this%type_of_domain)
case (NO_DOMAIN)
!< Here the fileobj is in the unstructured domain, but the axis is not
!< Unstructured domain fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
@@ -282,41 +282,41 @@ subroutine write_axis_metadata(obj, fileobj, sub_axis_id)
end select
!< Add the axis as a variable and write its metada
- call register_field(fileobj, axis_name, obj%type_of_data, (/axis_name/))
- call register_variable_attribute(fileobj, axis_name, "longname", obj%long_name, &
- str_len=len_trim(obj%long_name))
+ call register_field(fileobj, axis_name, this%type_of_data, (/axis_name/))
+ call register_variable_attribute(fileobj, axis_name, "longname", this%long_name, &
+ str_len=len_trim(this%long_name))
- if (obj%cart_name .NE. "N") &
- call register_variable_attribute(fileobj, axis_name, "axis", obj%cart_name, str_len=1)
+ if (this%cart_name .NE. "N") &
+ call register_variable_attribute(fileobj, axis_name, "axis", this%cart_name, str_len=1)
- if (trim(obj%units) .NE. "none") &
- call register_variable_attribute(fileobj, axis_name, "units", obj%units, str_len=len_trim(obj%units))
+ if (trim(this%units) .NE. "none") &
+ call register_variable_attribute(fileobj, axis_name, "units", this%units, str_len=len_trim(this%units))
- select case (obj%direction)
+ select case (this%direction)
case (direction_up)
call register_variable_attribute(fileobj, axis_name, "positive", "up", str_len=2)
case (direction_down)
call register_variable_attribute(fileobj, axis_name, "positive", "down", str_len=4)
end select
- if (obj%edges > 0) then
- axis_edges_name = axis_obj(obj%edges)%axis_name
+ if (this%edges > 0) then
+ axis_edges_name = axis_obj(this%edges)%axis_name
call register_variable_attribute(fileobj, axis_name, "edges", axis_edges_name, &
str_len=len_trim(axis_edges_name))
endif
- if(allocated(obj%attributes)) then
- do i = 1, size(obj%attributes)
- call register_variable_attribute(fileobj, axis_name, obj%attributes(i)%att_name, &
- & obj%attributes(i)%att_value)
+ if(allocated(this%attributes)) then
+ do i = 1, size(this%attributes)
+ call register_variable_attribute(fileobj, axis_name, this%attributes(i)%att_name, &
+ & this%attributes(i)%att_value)
enddo
endif
end subroutine write_axis_metadata
!> @brief Write the axis data to an open fileobj
- subroutine write_axis_data(obj, fileobj, sub_axis_id)
- class(diagAxis_t), INTENT(IN) :: obj !< diag_axis obj
+ subroutine write_axis_data(this, fileobj, sub_axis_id)
+ class(diagAxis_t), INTENT(IN) :: this !< diag_axis obj
class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
integer, OPTIONAL, INTENT(IN) :: sub_axis_id !< ID of the sub_axis, if it exists
@@ -324,36 +324,36 @@ subroutine write_axis_data(obj, fileobj, sub_axis_id)
integer :: j !< Ending index of a sub_axis
if (present(sub_axis_id)) then
- i = obj%subaxis(sub_axis_id)%starting_index
- j = obj%subaxis(sub_axis_id)%ending_index
+ i = this%subaxis(sub_axis_id)%starting_index
+ j = this%subaxis(sub_axis_id)%ending_index
- call write_data(fileobj, obj%subaxis(sub_axis_id)%subaxis_name, obj%axis_data(i:j))
+ call write_data(fileobj, this%subaxis(sub_axis_id)%subaxis_name, this%axis_data(i:j))
else
- call write_data(fileobj, obj%axis_name, obj%axis_data)
+ call write_data(fileobj, this%axis_name, this%axis_data)
endif
end subroutine write_axis_data
!> @brief Get the length of the axis
!> @return axis length
- function get_axis_length(obj) &
+ function get_axis_length(this) &
result (axis_length)
- class(diagAxis_t), intent(inout) :: obj !< diag_axis obj
+ class(diagAxis_t), intent(inout) :: this !< diag_axis obj
integer :: axis_length
!< If the axis is domain decomposed axis_length will be set to the length for the current PE:
- if (allocated(obj%axis_domain)) then
- axis_length = obj%axis_domain%length(obj%cart_name, obj%domain_position, obj%length)
+ if (allocated(this%axis_domain)) then
+ axis_length = this%axis_domain%length(this%cart_name, this%domain_position, this%length)
else
- axis_length = obj%length
+ axis_length = this%length
endif
end function
!> @brief Set the subaxis of the axis obj
!> @return A sub_axis id corresponding to the indices of the sub_axes in the sub_axes_objs array
- function set_subaxis(obj, bounds) &
+ function set_subaxis(this, bounds) &
result(sub_axes_id)
- class(diagAxis_t), INTENT(INOUT) :: obj !< diag_axis obj
+ class(diagAxis_t), INTENT(INOUT) :: this !< diag_axis obj
class(*), INTENT(INOUT) :: bounds(:) !< bound of the subaxis
integer :: sub_axes_id
@@ -361,12 +361,12 @@ function set_subaxis(obj, bounds) &
integer :: i !< For do loops
!< Check if the subaxis for this bouds already exists
- do i = 1, obj%nsubaxis
- if (obj%subaxis(i)%exists(bounds)) return
+ do i = 1, this%nsubaxis
+ if (this%subaxis(i)%exists(bounds)) return
enddo
!< TO DO: everything
- obj%nsubaxis = obj%nsubaxis + 1
+ this%nsubaxis = this%nsubaxis + 1
nsubaxis_objs = nsubaxis_objs + 1
sub_axes_id = nsubaxis_objs
@@ -376,9 +376,9 @@ function set_subaxis(obj, bounds) &
!!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Check if a subaxis was already defined
!> @return Flag indicating if a subaxis is already defined
- function check_if_subaxis_exists(obj,bounds) &
+ function check_if_subaxis_exists(this, bounds) &
result(exists)
- class(subaxis_t), INTENT(INOUT) :: obj !< diag_axis obj
+ class(subaxis_t), INTENT(INOUT) :: this !< diag_axis obj
class(*), INTENT(IN) :: bounds(:) !< bounds of the subaxis
logical :: exists
@@ -388,19 +388,19 @@ function check_if_subaxis_exists(obj,bounds) &
!> @brief Get the length of a 2D domain
!> @return Length of the 2D domain
- function get_length(obj, cart_axis, domain_position, global_length) &
+ function get_length(this, cart_axis, domain_position, global_length) &
result (length)
- class(diagDomain_t), INTENT(INOUT) :: obj !< diag_axis obj
+ class(diagDomain_t), INTENT(INOUT) :: this !< diag_axis obj
character(len=*), INTENT(IN) :: cart_axis !< cart_axis of the axis
integer, INTENT(IN) :: domain_position !< Domain position (CENTER, NORTH, EAST)
integer, INTENT(IN) :: global_length !< global_length of the axis
integer :: length
- select type (obj)
+ select type (this)
type is(diagDomain2d_t)
- if (trim(cart_axis) == "X") call mpp_get_compute_domain(obj%Domain2, xsize=length, position=domain_position)
- if (trim(cart_axis) == "Y") call mpp_get_compute_domain(obj%Domain2, ysize=length, position=domain_position)
+ if (trim(cart_axis) == "X") call mpp_get_compute_domain(this%Domain2, xsize=length, position=domain_position)
+ if (trim(cart_axis) == "Y") call mpp_get_compute_domain(this%Domain2, ysize=length, position=domain_position)
class default
!< If domain is 1D or UG, just set it to the global length
length = global_length
@@ -410,19 +410,19 @@ function get_length(obj, cart_axis, domain_position, global_length) &
!!!!!!!!!!!!!!!!! FMS_DOMAIN PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Set the axis domain
- subroutine set_axis_domain(obj, Domain, Domain2, DomainU)
- class(diagDomain_t) :: obj !< fms_domain obj
+ subroutine set_axis_domain(this, Domain, Domain2, DomainU)
+ class(diagDomain_t) :: this !< fms_domain obj
TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1d domain
TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2d domain
TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain
- select type(obj)
+ select type(this)
type is (diagDomain1d_t)
- obj%Domain = Domain
+ this%Domain = Domain
type is (diagDomain2d_t)
- obj%Domain2 = Domain2
+ this%Domain2 = Domain2
type is (diagDomainUg_t)
- obj%DomainUG = DomainU
+ this%DomainUG = DomainU
end select
end subroutine set_axis_domain
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 132c8048cf..c69b9caadd 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -168,11 +168,11 @@ end function fms_diag_fields_object_init
!> \Description Fills in and allocates (when necessary) the values in the diagnostic object
subroutine fms_register_diag_field_obj &
!(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
- (dobj, modname, varname, diag_field_indices, axes, &
+ (this, modname, varname, diag_field_indices, axes, &
longname, units, missing_value, varRange, mask_variant, standname, &
do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
- class(fmsDiagField_type), INTENT(inout) :: dobj !< Diaj_obj to fill
+ class(fmsDiagField_type), INTENT(inout) :: this !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: modname !< The module name
CHARACTER(len=*), INTENT(in) :: varname !< The variable name
integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
@@ -198,63 +198,63 @@ subroutine fms_register_diag_field_obj &
LOGICAL, OPTIONAL, INTENT(in) :: static !< Set to true if it is a static field
integer :: i !< For do loops
- integer :: j !< dobj%file_ids(i) (for less typing :)
+ integer :: j !< this%file_ids(i) (for less typing :)
!> Fill in information from the register call
- dobj%varname = trim(varname)
- dobj%modname = trim(modname)
+ this%varname = trim(varname)
+ this%modname = trim(modname)
!> Add the yaml info to the diag_object
- dobj%diag_field = get_diag_fields_entries(diag_field_indices)
+ this%diag_field = get_diag_fields_entries(diag_field_indices)
!> Add axis and domain information
if (present(axes)) then
- dobj%axis_ids = axes
- call get_domain_and_domain_type(dobj%axis_ids, dobj%type_of_domain, dobj%domain, dobj%varname)
+ this%axis_ids = axes
+ call get_domain_and_domain_type(this%axis_ids, this%type_of_domain, this%domain, this%varname)
else
!> The variable is a scalar
- dobj%type_of_domain = NO_DOMAIN
- dobj%domain => null()
+ this%type_of_domain = NO_DOMAIN
+ this%domain => null()
endif
!> get the optional arguments if included and the diagnostic is in the diag table
- if (present(longname)) dobj%longname = trim(longname)
- if (present(standname)) dobj%standname = trim(standname)
- if (present(units)) dobj%units = trim(units)
- if (present(realm)) dobj%realm = trim(realm)
- if (present(interp_method)) dobj%interp_method = trim(interp_method)
+ if (present(longname)) this%longname = trim(longname)
+ if (present(standname)) this%standname = trim(standname)
+ if (present(units)) this%units = trim(units)
+ if (present(realm)) this%realm = trim(realm)
+ if (present(interp_method)) this%interp_method = trim(interp_method)
if (present(tile_count)) then
- allocate(dobj%tile_count)
- dobj%tile_count = tile_count
+ allocate(this%tile_count)
+ this%tile_count = tile_count
endif
if (present(static)) then
- dobj%static = static
+ this%static = static
else
- dobj%static = .false.
+ this%static = .false.
endif
if (present(missing_value)) then
select type (missing_value)
type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: dobj%missing_value)
- dobj%missing_value = missing_value
+ allocate(integer(kind=i4_kind) :: this%missing_value)
+ this%missing_value = missing_value
type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: dobj%missing_value)
- dobj%missing_value = missing_value
+ allocate(integer(kind=i8_kind) :: this%missing_value)
+ this%missing_value = missing_value
type is (real(kind=r4_kind))
- allocate(integer(kind=r4_kind) :: dobj%missing_value)
- dobj%missing_value = missing_value
+ allocate(integer(kind=r4_kind) :: this%missing_value)
+ this%missing_value = missing_value
type is (real(kind=r8_kind))
- allocate(integer(kind=r8_kind) :: dobj%missing_value)
- dobj%missing_value = missing_value
+ allocate(integer(kind=r8_kind) :: this%missing_value)
+ this%missing_value = missing_value
class default
call mpp_error("fms_register_diag_field_obj", &
"The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",&
FATAL)
end select
else
- allocate(real :: dobj%missing_value)
- select type (miss => dobj%missing_value)
+ allocate(real :: this%missing_value)
+ select type (miss => this%missing_value)
type is (real)
miss = real(CMOR_MISSING_VALUE)
end select
@@ -263,25 +263,25 @@ subroutine fms_register_diag_field_obj &
if (present(varRANGE)) then
select type (varRANGE)
type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: dobj%data_RANGE(2))
- dobj%data_RANGE = varRANGE
+ allocate(integer(kind=i4_kind) :: this%data_RANGE(2))
+ this%data_RANGE = varRANGE
type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: dobj%data_RANGE(2))
- dobj%data_RANGE = varRANGE
+ allocate(integer(kind=i8_kind) :: this%data_RANGE(2))
+ this%data_RANGE = varRANGE
type is (real(kind=r4_kind))
- allocate(integer(kind=r4_kind) :: dobj%data_RANGE(2))
- dobj%data_RANGE = varRANGE
+ allocate(integer(kind=r4_kind) :: this%data_RANGE(2))
+ this%data_RANGE = varRANGE
type is (real(kind=r8_kind))
- allocate(integer(kind=r8_kind) :: dobj%data_RANGE(2))
- dobj%data_RANGE = varRANGE
+ allocate(integer(kind=r8_kind) :: this%data_RANGE(2))
+ this%data_RANGE = varRANGE
class default
call mpp_error("fms_register_diag_field_obj", &
"The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",&
FATAL)
end select
else
- allocate(real :: dobj%data_RANGE(2))
- select type (varRANGE => dobj%data_RANGE)
+ allocate(real :: this%data_RANGE(2))
+ select type (varRANGE => this%data_RANGE)
type is (real)
varRANGE = real(CMOR_MISSING_VALUE)
end select
@@ -292,8 +292,8 @@ subroutine fms_register_diag_field_obj &
"The area id passed with field_name"//trim(varname)//" has not been registered."&
"Check that there is a register_diag_field call for the AREA measure and that is in the"&
"diag_table.yaml", FATAL)
- allocate(dobj%area)
- dobj%area = area
+ allocate(this%area)
+ this%area = area
endif
if (present(volume)) then
@@ -301,39 +301,41 @@ subroutine fms_register_diag_field_obj &
"The volume id passed with field_name"//trim(varname)//" has not been registered."&
"Check that there is a register_diag_field call for the VOLUME measure and that is in the"&
"diag_table.yaml", FATAL)
- allocate(dobj%volume)
- dobj%volume = volume
+ allocate(this%volume)
+ this%volume = volume
endif
if (present(mask_variant)) then
- allocate(dobj%mask_variant)
- dobj%mask_variant = mask_variant
+ allocate(this%mask_variant)
+ this%mask_variant = mask_variant
endif
if (present(do_not_log)) then
- allocate(dobj%do_not_log)
- dobj%do_not_log = do_not_log
+ allocate(this%do_not_log)
+ this%do_not_log = do_not_log
endif
!< Allocate space for any additional variable attributes
!< These will be fill out when calling `diag_field_add_attribute`
- allocate(dobj%attributes(max_field_attributes))
- dobj%num_attributes = 0
- dobj%registered = .true.
+ allocate(this%attributes(max_field_attributes))
+ this%num_attributes = 0
+ this%registered = .true.
end subroutine fms_register_diag_field_obj
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
!> \brief Sets the diag_id. This can only be done if a variable is unregistered
-subroutine set_diag_id(objin , id)
- class (fmsDiagField_type) , intent(inout):: objin
+subroutine set_diag_id(this , id)
+ class (fmsDiagField_type) , intent(inout):: this
integer :: id
- if (allocated(objin%registered)) then
- if (objin%registered) then
- call mpp_error("set_diag_id", "The variable"//objin%varname//" is already registered", FATAL)
+ if (allocated(this%registered)) then
+ if (this%registered) then
+ call mpp_error("set_diag_id", "The variable"//this%varname//" is already registered", FATAL)
endif
else
- objin%diag_id = id
+ this%diag_id = id
endif
end subroutine set_diag_id
+
!> \brief Find the type of the variable and store it in the object
subroutine set_vartype(objin , var)
class (fmsDiagField_type) , intent(inout):: objin
@@ -355,67 +357,70 @@ subroutine set_vartype(objin , var)
" r8, r4, i8, i4, or string.", warning)
end select
end subroutine set_vartype
+
!> \brief Prints to the screen what type the diag variable is
-subroutine what_is_vartype(objin)
- class (fmsDiagField_type) , intent(inout):: objin
- if (.not. allocated(objin%vartype)) then
+subroutine what_is_vartype(this)
+ class (fmsDiagField_type) , intent(inout):: this
+ if (.not. allocated(this%vartype)) then
call mpp_error("what_is_vartype", "The variable type has not been set prior to this call", warning)
return
endif
- select case (objin%vartype)
+ select case (this%vartype)
case (r8)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
" is REAL(kind=8)", NOTE)
case (r4)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
" is REAL(kind=4)", NOTE)
case (i8)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
" is INTEGER(kind=8)", NOTE)
case (i4)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
" is INTEGER(kind=4)", NOTE)
case (string)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
" is CHARACTER(*)", NOTE)
case (null_type_int)
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
" was not set", WARNING)
case default
- call mpp_error("what_is_vartype", "The variable type of "//trim(objin%varname)//&
+ call mpp_error("what_is_vartype", "The variable type of "//trim(this%varname)//&
" is not supported by diag_manager", FATAL)
end select
end subroutine what_is_vartype
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
!> \brief Copies the calling object into the object that is the argument of the subroutine
-subroutine copy_diag_obj(objin , objout)
- class (fmsDiagField_type) , intent(in) :: objin
+subroutine copy_diag_obj(this , objout)
+ class (fmsDiagField_type) , intent(in) :: this
class (fmsDiagField_type) , intent(inout) , allocatable :: objout !< The destination of the copy
select type (objout)
class is (fmsDiagField_type)
- if (allocated(objin%registered)) then
- objout%registered = objin%registered
+ if (allocated(this%registered)) then
+ objout%registered = this%registered
else
call mpp_error("copy_diag_obj", "You can only copy objects that have been registered",warning)
endif
- objout%diag_id = objin%diag_id
+ objout%diag_id = this%diag_id
- if (allocated(objin%attributes)) objout%attributes = objin%attributes
- objout%static = objin%static
- if (allocated(objin%frequency)) objout%frequency = objin%frequency
- if (allocated(objin%varname)) objout%varname = objin%varname
+ if (allocated(this%attributes)) objout%attributes = this%attributes
+ objout%static = this%static
+ if (allocated(this%frequency)) objout%frequency = this%frequency
+ if (allocated(this%varname)) objout%varname = this%varname
end select
end subroutine copy_diag_obj
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
!> \brief Returns the ID integer for a variable
!! \return the diag ID
-pure integer function fms_diag_get_id (dobj) result(diag_id)
- class(fmsDiagField_type) , intent(in) :: dobj
+pure integer function fms_diag_get_id (this) result(diag_id)
+ class(fmsDiagField_type) , intent(in) :: this
!> Check if the diag_object registration has been done
- if (allocated(dobj%registered)) then
+ if (allocated(this%registered)) then
!> Return the diag_id if the variable has been registered
- diag_id = dobj%diag_id
+ diag_id = this%diag_id
else
!> If the variable is not regitered, then return the unregistered value
diag_id = DIAG_NOT_REGISTERED
@@ -424,14 +429,14 @@ end function fms_diag_get_id
!> Function to return a character (string) representation of the most basic
!> object identity info. Intended for debugging and warning. The format produced is:
-!> [dobj: o.varname(string|?), vartype (string|?), o.registered (T|F|?), diag_id (id|?)].
+!> [this: o.varname(string|?), vartype (string|?), o.registered (T|F|?), diag_id (id|?)].
!> A questionmark "?" is set in place of the variable that is not yet allocated
!>TODO: Add diag_id ?
-function fms_diag_obj_as_string_basic(dobj) result(rslt)
- class(fmsDiagField_type), allocatable, intent(in) :: dobj
+function fms_diag_obj_as_string_basic(this) result(rslt)
+ class(fmsDiagField_type), allocatable, intent(in) :: this
character(:), allocatable :: rslt
character (len=:), allocatable :: registered, vartype, varname, diag_id
- if ( .not. allocated (dobj)) then
+ if ( .not. allocated (this)) then
varname = "?"
vartype = "?"
registered = "?"
@@ -440,26 +445,26 @@ function fms_diag_obj_as_string_basic(dobj) result(rslt)
return
end if
-! if(allocated (dobj%registered)) then
-! registered = logical_to_cs (dobj%registered)
+! if(allocated (this%registered)) then
+! registered = logical_to_cs (this%registered)
! else
! registered = "?"
! end if
-! if(allocated (dobj%diag_id)) then
-! diag_id = int_to_cs (dobj%diag_id)
+! if(allocated (this%diag_id)) then
+! diag_id = int_to_cs (this%diag_id)
! else
! diag_id = "?"
! end if
-! if(allocated (dobj%vartype)) then
-! vartype = int_to_cs (dobj%vartype)
+! if(allocated (this%vartype)) then
+! vartype = int_to_cs (this%vartype)
! else
! registered = "?"
! end if
- if(allocated (dobj%varname)) then
- varname = dobj%varname
+ if(allocated (this%varname)) then
+ varname = this%varname
else
registered = "?"
end if
@@ -469,16 +474,16 @@ function fms_diag_obj_as_string_basic(dobj) result(rslt)
end function fms_diag_obj_as_string_basic
-function diag_obj_is_registered (obj) result (rslt)
- class(fmsDiagField_type), intent(in) :: obj
+function diag_obj_is_registered (this) result (rslt)
+ class(fmsDiagField_type), intent(in) :: this
logical :: rslt
- rslt = obj%registered
+ rslt = this%registered
end function diag_obj_is_registered
-function diag_obj_is_static (obj) result (rslt)
- class(fmsDiagField_type), intent(in) :: obj
+function diag_obj_is_static (this) result (rslt)
+ class(fmsDiagField_type), intent(in) :: this
logical :: rslt
- rslt = obj%static
+ rslt = this%static
end function diag_obj_is_static
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -486,192 +491,209 @@ end function diag_obj_is_static
!> @brief Gets attributes
!! @return A pointer to the attributes of the diag_obj, null pointer if there are no attributes
-function get_attributes (obj) &
+function get_attributes (this) &
result(rslt)
- class (fmsDiagField_type), target, intent(in) :: obj !< diag object
+ class (fmsDiagField_type), target, intent(in) :: this !< diag object
type(fmsDiagAttribute_type), pointer :: rslt(:)
rslt => null()
- if (obj%num_attributes > 0 ) rslt => obj%attributes
+ if (this%num_attributes > 0 ) rslt => this%attributes
end function get_attributes
+
!> @brief Gets static
!! @return copy of variable static
-pure function get_static (obj) &
+pure function get_static (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
logical :: rslt
- rslt = obj%static
+ rslt = this%static
end function get_static
+
!> @brief Gets regisetered
!! @return copy of registered
-pure function get_registered (obj) &
+pure function get_registered (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
logical :: rslt
- rslt = obj%registered
+ rslt = this%registered
end function get_registered
+
!> @brief Gets mask variant
!! @return copy of mask variant
-pure function get_mask_variant (obj) &
+pure function get_mask_variant (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
logical :: rslt
- rslt = obj%mask_variant
+ rslt = this%mask_variant
end function get_mask_variant
+
!> @brief Gets local
!! @return copy of local
-pure function get_local (obj) &
+pure function get_local (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
logical :: rslt
- rslt = obj%local
+ rslt = this%local
end function get_local
+
!> @brief Gets vartype
!! @return copy of The integer related to the variable type
-pure function get_vartype (obj) &
+pure function get_vartype (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
integer :: rslt
- rslt = obj%vartype
+ rslt = this%vartype
end function get_vartype
+
!> @brief Gets varname
!! @return copy of the variable name
-pure function get_varname (obj) &
+pure function get_varname (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
character(len=:), allocatable :: rslt
- rslt = obj%varname
+ rslt = this%varname
end function get_varname
+
!> @brief Gets longname
!! @return copy of the variable long name or a single string if there is no long name
-pure function get_longname (obj) &
+pure function get_longname (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
character(len=:), allocatable :: rslt
- if (allocated(obj%longname)) then
- rslt = obj%longname
+ if (allocated(this%longname)) then
+ rslt = this%longname
else
rslt = diag_null_string
endif
end function get_longname
+
!> @brief Gets standname
!! @return copy of the standard name or an empty string if standname is not allocated
-pure function get_standname (obj) &
+pure function get_standname (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
character(len=:), allocatable :: rslt
- if (allocated(obj%standname)) then
- rslt = obj%standname
+ if (allocated(this%standname)) then
+ rslt = this%standname
else
rslt = diag_null_string
endif
end function get_standname
+
!> @brief Gets units
!! @return copy of the units or an empty string if not allocated
-pure function get_units (obj) &
+pure function get_units (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
character(len=:), allocatable :: rslt
- if (allocated(obj%units)) then
- rslt = obj%units
+ if (allocated(this%units)) then
+ rslt = this%units
else
rslt = diag_null_string
endif
end function get_units
+
!> @brief Gets modname
!! @return copy of the module name that the variable is in or an empty string if not allocated
-pure function get_modname (obj) &
+pure function get_modname (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
character(len=:), allocatable :: rslt
- if (allocated(obj%modname)) then
- rslt = obj%modname
+ if (allocated(this%modname)) then
+ rslt = this%modname
else
rslt = diag_null_string
endif
end function get_modname
+
!> @brief Gets realm
!! @return copy of the variables modeling realm or an empty string if not allocated
-pure function get_realm (obj) &
+pure function get_realm (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
character(len=:), allocatable :: rslt
- if (allocated(obj%realm)) then
- rslt = obj%realm
+ if (allocated(this%realm)) then
+ rslt = this%realm
else
rslt = diag_null_string
endif
end function get_realm
+
!> @brief Gets interp_method
!! @return copy of The interpolation method or an empty string if not allocated
-pure function get_interp_method (obj) &
+pure function get_interp_method (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
character(len=:), allocatable :: rslt
- if (allocated(obj%interp_method)) then
- rslt = obj%interp_method
+ if (allocated(this%interp_method)) then
+ rslt = this%interp_method
else
rslt = diag_null_string
endif
end function get_interp_method
+
!> @brief Gets frequency
!! @return copy of the frequency or DIAG_NULL if obj%frequency is not allocated
-pure function get_frequency (obj) &
+pure function get_frequency (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
integer, allocatable, dimension (:) :: rslt
- if (allocated(obj%frequency)) then
- allocate (rslt(size(obj%frequency)))
- rslt = obj%frequency
+ if (allocated(this%frequency)) then
+ allocate (rslt(size(this%frequency)))
+ rslt = this%frequency
else
allocate (rslt(1))
rslt = DIAG_NULL
endif
end function get_frequency
+
!> @brief Gets tile_count
!! @return copy of the number of tiles or diag_null if tile_count is not allocated
-pure function get_tile_count (obj) &
+pure function get_tile_count (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
integer :: rslt
- if (allocated(obj%tile_count)) then
- rslt = obj%tile_count
+ if (allocated(this%tile_count)) then
+ rslt = this%tile_count
else
rslt = DIAG_NULL
endif
end function get_tile_count
+
!> @brief Gets area
!! @return copy of the area or diag_null if not allocated
-pure function get_area (obj) &
+pure function get_area (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
integer :: rslt
- if (allocated(obj%area)) then
- rslt = obj%area
+ if (allocated(this%area)) then
+ rslt = this%area
else
rslt = diag_null
endif
end function get_area
+
!> @brief Gets volume
!! @return copy of the volume or diag_null if volume is not allocated
-pure function get_volume (obj) &
+pure function get_volume (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
integer :: rslt
- if (allocated(obj%volume)) then
- rslt = obj%volume
+ if (allocated(this%volume)) then
+ rslt = this%volume
else
rslt = diag_null
endif
end function get_volume
+
!> @brief Gets missing_value
!! @return copy of The missing value
-function get_missing_value (obj) &
+function get_missing_value (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
class(*),allocatable :: rslt
- if (allocated(obj%missing_value)) then
- select type (miss => obj%missing_value)
+ if (allocated(this%missing_value)) then
+ select type (miss => this%missing_value)
type is (integer(kind=i4_kind))
allocate (integer(kind=i4_kind) :: rslt)
rslt = miss
@@ -694,14 +716,15 @@ function get_missing_value (obj) &
"The missing value is not allocated", FATAL)
endif
end function get_missing_value
+
!> @brief Gets data_range
!! @return copy of the data range
-function get_data_RANGE (obj) &
+function get_data_RANGE (this) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
+ class (fmsDiagField_type), intent(in) :: this !< diag object
class(*),allocatable :: rslt(:)
- if (allocated(obj%data_RANGE)) then
- select type (r => obj%data_RANGE)
+ if (allocated(this%data_RANGE)) then
+ select type (r => this%data_RANGE)
type is (integer(kind=i4_kind))
allocate (integer(kind=i4_kind) :: rslt(2))
rslt = r
@@ -724,21 +747,24 @@ function get_data_RANGE (obj) &
"The data_RANGE value is not allocated", FATAL)
endif
end function get_data_RANGE
+
!> @brief Gets axis_ids
!! @return pointer to the axis ids
-function get_axis_id (obj) &
+function get_axis_id (this) &
result(rslt)
- class (fmsDiagField_type), target, intent(in) :: obj !< diag object
+ class (fmsDiagField_type), target, intent(in) :: this !< diag object
integer, pointer, dimension(:) :: rslt !< field's axis_ids
- if(allocated(obj%axis_ids)) then
- rslt => obj%axis_ids
+ if(allocated(this%axis_ids)) then
+ rslt => this%axis_ids
else
rslt => null()
endif
end function get_axis_id
+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!! Allocation checks
+
!!> @brief Checks if obj%diag_field is allocated
!!! @return true if obj%diag_field is allocated
!logical function has_diag_field (obj)
@@ -747,153 +773,172 @@ end function get_axis_id
!end function has_diag_field
!> @brief Checks if obj%diag_id is allocated
!! @return true if obj%diag_id is allocated
-pure logical function has_diag_id (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_diag_id = allocated(obj%diag_id)
+pure logical function has_diag_id (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_diag_id = allocated(this%diag_id)
end function has_diag_id
+
!> @brief Checks if obj%metadata is allocated
!! @return true if obj%metadata is allocated
-pure logical function has_attributes (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_attributes = obj%num_attributes > 0
+pure logical function has_attributes (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_attributes = this%num_attributes > 0
end function has_attributes
+
!> @brief Checks if obj%static is allocated
!! @return true if obj%static is allocated
-pure logical function has_static (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_static = allocated(obj%static)
+pure logical function has_static (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_static = allocated(this%static)
end function has_static
+
!> @brief Checks if obj%registered is allocated
!! @return true if obj%registered is allocated
-pure logical function has_registered (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_registered = allocated(obj%registered)
+pure logical function has_registered (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_registered = allocated(this%registered)
end function has_registered
+
!> @brief Checks if obj%mask_variant is allocated
!! @return true if obj%mask_variant is allocated
-pure logical function has_mask_variant (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_mask_variant = allocated(obj%mask_variant)
+pure logical function has_mask_variant (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_mask_variant = allocated(this%mask_variant)
end function has_mask_variant
+
!> @brief Checks if obj%local is allocated
!! @return true if obj%local is allocated
-pure logical function has_local (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_local = allocated(obj%local)
+pure logical function has_local (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_local = allocated(this%local)
end function has_local
+
!> @brief Checks if obj%vartype is allocated
!! @return true if obj%vartype is allocated
-pure logical function has_vartype (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_vartype = allocated(obj%vartype)
+pure logical function has_vartype (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_vartype = allocated(this%vartype)
end function has_vartype
+
!> @brief Checks if obj%varname is allocated
!! @return true if obj%varname is allocated
-pure logical function has_varname (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_varname = allocated(obj%varname)
+pure logical function has_varname (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_varname = allocated(this%varname)
end function has_varname
+
!> @brief Checks if obj%longname is allocated
!! @return true if obj%longname is allocated
-pure logical function has_longname (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_longname = allocated(obj%longname)
+pure logical function has_longname (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_longname = allocated(this%longname)
end function has_longname
+
!> @brief Checks if obj%standname is allocated
!! @return true if obj%standname is allocated
-pure logical function has_standname (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_standname = allocated(obj%standname)
+pure logical function has_standname (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_standname = allocated(this%standname)
end function has_standname
+
!> @brief Checks if obj%units is allocated
!! @return true if obj%units is allocated
-pure logical function has_units (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_units = allocated(obj%units)
+pure logical function has_units (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_units = allocated(this%units)
end function has_units
+
!> @brief Checks if obj%modname is allocated
!! @return true if obj%modname is allocated
-pure logical function has_modname (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_modname = allocated(obj%modname)
+pure logical function has_modname (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_modname = allocated(this%modname)
end function has_modname
+
!> @brief Checks if obj%realm is allocated
!! @return true if obj%realm is allocated
-pure logical function has_realm (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_realm = allocated(obj%realm)
+pure logical function has_realm (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_realm = allocated(this%realm)
end function has_realm
+
!> @brief Checks if obj%interp_method is allocated
!! @return true if obj%interp_method is allocated
-pure logical function has_interp_method (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_interp_method = allocated(obj%interp_method)
+pure logical function has_interp_method (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_interp_method = allocated(this%interp_method)
end function has_interp_method
+
!> @brief Checks if obj%frequency is allocated
!! @return true if obj%frequency is allocated
-pure logical function has_frequency (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_frequency = allocated(obj%frequency)
+pure logical function has_frequency (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_frequency = allocated(this%frequency)
end function has_frequency
+
!> @brief Checks if obj%tile_count is allocated
!! @return true if obj%tile_count is allocated
-pure logical function has_tile_count (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_tile_count = allocated(obj%tile_count)
+pure logical function has_tile_count (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_tile_count = allocated(this%tile_count)
end function has_tile_count
+
!> @brief Checks if obj%area is allocated
!! @return true if obj%area is allocated
-pure logical function has_area (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_area = allocated(obj%area)
+pure logical function has_area (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_area = allocated(this%area)
end function has_area
+
!> @brief Checks if obj%volume is allocated
!! @return true if obj%volume is allocated
-pure logical function has_volume (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_volume = allocated(obj%volume)
+pure logical function has_volume (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_volume = allocated(this%volume)
end function has_volume
+
!> @brief Checks if obj%missing_value is allocated
!! @return true if obj%missing_value is allocated
-pure logical function has_missing_value (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_missing_value = allocated(obj%missing_value)
+pure logical function has_missing_value (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_missing_value = allocated(this%missing_value)
end function has_missing_value
+
!> @brief Checks if obj%data_RANGE is allocated
!! @return true if obj%data_RANGE is allocated
-pure logical function has_data_RANGE (obj)
- class (fmsDiagField_type), intent(in) :: obj !< diag object
- has_data_RANGE = allocated(obj%data_RANGE)
+pure logical function has_data_RANGE (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_data_RANGE = allocated(this%data_RANGE)
end function has_data_RANGE
!> @brief Add a attribute to the diag_obj using the diag_field_id
-subroutine diag_field_add_attribute(obj, att_name, att_value)
- class (fmsDiagField_type), intent (inout) :: obj !< The field object
+subroutine diag_field_add_attribute(this, att_name, att_value)
+ class (fmsDiagField_type), intent (inout) :: this !< The field object
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
- obj%num_attributes = obj%num_attributes + 1
- if (obj%num_attributes > max_field_attributes) &
+ this%num_attributes = this%num_attributes + 1
+ if (this%num_attributes > max_field_attributes) &
call mpp_error(FATAL, "diag_field_add_attribute: Number of attributes exceeds max_field_attributes for field:"&
- //trim(obj%varname)//". Increase diag_manager_nml:max_field_attributes.")
+ //trim(this%varname)//". Increase diag_manager_nml:max_field_attributes.")
- call obj%attributes(obj%num_attributes)%add(att_name, att_value)
+ call this%attributes(this%num_attributes)%add(att_name, att_value)
end subroutine diag_field_add_attribute
!> @brief Determines the diag_obj id corresponding to a module name and field_name
!> @return diag_obj id
-PURE FUNCTION diag_field_id_from_name(diag_objs, module_name, field_name) &
+PURE FUNCTION diag_field_id_from_name(this, module_name, field_name) &
result(diag_field_id)
- CLASS(fmsDiagField_type), INTENT(in) :: diag_objs !< The field object
+ CLASS(fmsDiagField_type), INTENT(in) :: this !< The field object
CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
integer :: diag_field_id
diag_field_id = DIAG_FIELD_NOT_FOUND
- if (diag_objs%get_varname() .eq. trim(field_name) .and. &
- diag_objs%get_modname() .eq. trim(module_name)) then
- diag_field_id = diag_objs%get_id()
+ if (this%get_varname() .eq. trim(field_name) .and. &
+ this%get_modname() .eq. trim(module_name)) then
+ diag_field_id = this%get_id()
endif
end function diag_field_id_from_name
#endif
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 3f11a7174b..e3b33c2ee3 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -114,6 +114,7 @@ module fms_diag_file_object_mod
procedure, public :: has_file_global_meta
end type fmsDiagFile_type
+
type, extends (fmsDiagFile_type) :: subRegionalFile_type
integer, dimension(:), allocatable :: sub_axis_ids !< Array of axis ids in the file
end type subRegionalFile_type
@@ -125,6 +126,7 @@ module fms_diag_file_object_mod
!type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_file !< The array of diag files
!class(fmsDiagFileContainer_type),dimension (:), allocatable, target :: FMS_diag_file
+
contains
!< @brief Allocates the number of files and sets an ID based for each file
@@ -187,51 +189,57 @@ logical function fms_diag_files_object_init (files_array)
! FATAL)
endif
end function fms_diag_files_object_init
+
!> \brief Adds a field ID to the file
-subroutine add_field_id (obj, new_field_id)
- class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+subroutine add_field_id (this, new_field_id)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
integer, intent(in) :: new_field_id !< The field ID to be added to field_ids
- obj%num_registered_fields = obj%num_registered_fields + 1
- if (obj%num_registered_fields .le. size(obj%field_ids)) then
- obj%field_ids( obj%num_registered_fields ) = new_field_id
- obj%field_registered( obj%num_registered_fields ) = .true.
+ this%num_registered_fields = this%num_registered_fields + 1
+ if (this%num_registered_fields .le. size(this%field_ids)) then
+ this%field_ids( this%num_registered_fields ) = new_field_id
+ this%field_registered( this%num_registered_fields ) = .true.
else
- call mpp_error(FATAL, "The file: "//obj%get_file_fname()//" has already been assigned its maximum "//&
+ call mpp_error(FATAL, "The file: "//this%get_file_fname()//" has already been assigned its maximum "//&
"number of fields.")
endif
end subroutine add_field_id
!> \brief Logical function to determine if the variable file_metadata_from_model has been allocated or associated
!! \return .True. if file_metadata_from_model exists .False. if file_metadata_from_model has not been set
-pure logical function has_file_metadata_from_model (obj)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
- has_file_metadata_from_model = allocated(obj%file_metadata_from_model)
+pure logical function has_file_metadata_from_model (this)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
+ has_file_metadata_from_model = allocated(this%file_metadata_from_model)
end function has_file_metadata_from_model
+
!> \brief Logical function to determine if the variable fileobj has been allocated or associated
!! \return .True. if fileobj exists .False. if fileobj has not been set
-pure logical function has_fileobj (obj)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
- has_fileobj = allocated(obj%fileobj)
+pure logical function has_fileobj (this)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
+ has_fileobj = allocated(this%fileobj)
end function has_fileobj
+
!> \brief Logical function to determine if the variable diag_yaml_file has been allocated or associated
!! \return .True. if diag_yaml_file exists .False. if diag_yaml has not been set
-pure logical function has_diag_yaml_file (obj)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
- has_diag_yaml_file = associated(obj%diag_yaml_file)
+pure logical function has_diag_yaml_file (this)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
+ has_diag_yaml_file = associated(this%diag_yaml_file)
end function has_diag_yaml_file
+
!> \brief Logical function to determine if the variable field_ids has been allocated or associated
!! \return .True. if field_ids exists .False. if field_ids has not been set
-pure logical function has_field_ids (obj)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
- has_field_ids = allocated(obj%field_ids)
+pure logical function has_field_ids (this)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
+ has_field_ids = allocated(this%field_ids)
end function has_field_ids
+
!> \brief Returns a copy of the value of id
!! \return A copy of id
-pure function get_id (obj) result (res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_id (this) result (res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
integer :: res
- res = obj%id
+ res = this%id
end function get_id
+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! TODO
!> \brief Returns a copy of the value of fileobj
@@ -250,57 +258,65 @@ end function get_id
! type(diagYamlFiles_type) :: res
! res = obj%diag_yaml_file
!end function get_diag_yaml_file
+
!> \brief Returns a copy of the value of file_metadata_from_model
!! \return A copy of file_metadata_from_model
-pure function get_file_metadata_from_model (obj) result (res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_metadata_from_model (this) result (res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
character(len=:), dimension(:), allocatable :: res
- res = obj%file_metadata_from_model
+ res = this%file_metadata_from_model
end function get_file_metadata_from_model
+
!> \brief Returns a copy of the value of field_ids
!! \return A copy of field_ids
-pure function get_field_ids (obj) result (res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_field_ids (this) result (res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
integer, dimension(:), allocatable :: res
- allocate(res(size(obj%field_ids)))
- res = obj%field_ids
+ allocate(res(size(this%field_ids)))
+ res = this%field_ids
end function get_field_ids
+
!!!!!!!!! Functions from diag_yaml_file
!> \brief Returns a copy of file_fname from the yaml object
!! \return Copy of file_fname
-pure function get_file_fname (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_fname (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
character (len=:), allocatable :: res
- res = obj%diag_yaml_file%get_file_fname()
+ res = this%diag_yaml_file%get_file_fname()
end function get_file_fname
+
!> \brief Returns a copy of file_frequnit from the yaml object
!! \return Copy of file_frequnit
-pure function get_file_frequnit (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_frequnit (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
integer :: res
- res = obj%diag_yaml_file%get_file_frequnit()
+ res = this%diag_yaml_file%get_file_frequnit()
end function get_file_frequnit
+
!> \brief Returns a copy of file_freq from the yaml object
!! \return Copy of file_freq
-pure function get_file_freq (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_freq (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
integer :: res
- res = obj%diag_yaml_file%get_file_freq()
+ res = this%diag_yaml_file%get_file_freq()
end function get_file_freq
+
!> \brief Returns a copy of file_timeunit from the yaml object
!! \return Copy of file_timeunit
-pure function get_file_timeunit (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_timeunit (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
integer :: res
- res = obj%diag_yaml_file%get_file_timeunit()
+ res = this%diag_yaml_file%get_file_timeunit()
end function get_file_timeunit
+
!> \brief Returns a copy of file_unlimdim from the yaml object
!! \return Copy of file_unlimdim
-pure function get_file_unlimdim (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_unlimdim (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
character (len=:), allocatable :: res
- res = obj%diag_yaml_file%get_file_unlimdim()
+ res = this%diag_yaml_file%get_file_unlimdim()
end function get_file_unlimdim
+
!! TODO - get functions for sub region stuff
!> \brief Returns a copy of file_sub_region from the yaml object
!! \return Copy of file_sub_region
@@ -309,203 +325,225 @@ end function get_file_unlimdim
! integer :: res
! res = obj%diag_yaml_file%get_file_sub_region()
!end function get_file_sub_region
+
!> \brief Returns a copy of file_new_file_freq from the yaml object
!! \return Copy of file_new_file_freq
-pure function get_file_new_file_freq (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_new_file_freq (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
integer :: res
- res = obj%diag_yaml_file%get_file_new_file_freq()
+ res = this%diag_yaml_file%get_file_new_file_freq()
end function get_file_new_file_freq
+
!> \brief Returns a copy of file_new_file_freq_units from the yaml object
!! \return Copy of file_new_file_freq_units
-pure function get_file_new_file_freq_units (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_new_file_freq_units (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
integer :: res
- res = obj%diag_yaml_file%get_file_new_file_freq_units()
+ res = this%diag_yaml_file%get_file_new_file_freq_units()
end function get_file_new_file_freq_units
+
!> \brief Returns a copy of file_start_time from the yaml object
!! \return Copy of file_start_time
-pure function get_file_start_time (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_start_time (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
character (len=:), allocatable :: res
- res = obj%diag_yaml_file%get_file_start_time()
+ res = this%diag_yaml_file%get_file_start_time()
end function get_file_start_time
+
!> \brief Returns a copy of file_duration from the yaml object
!! \return Copy of file_duration
-pure function get_file_duration (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_duration (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
integer :: res
- res = obj%diag_yaml_file%get_file_duration()
+ res = this%diag_yaml_file%get_file_duration()
end function get_file_duration
+
!> \brief Returns a copy of file_duration_units from the yaml object
!! \return Copy of file_duration_units
-pure function get_file_duration_units (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_duration_units (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
integer :: res
- res = obj%diag_yaml_file%get_file_duration_units()
+ res = this%diag_yaml_file%get_file_duration_units()
end function get_file_duration_units
+
!> \brief Returns a copy of file_varlist from the yaml object
!! \return Copy of file_varlist
-pure function get_file_varlist (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_varlist (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
character (len=:), allocatable, dimension(:) :: res
- res = obj%diag_yaml_file%get_file_varlist()
+ res = this%diag_yaml_file%get_file_varlist()
end function get_file_varlist
+
!> \brief Returns a copy of file_global_meta from the yaml object
!! \return Copy of file_global_meta
-pure function get_file_global_meta (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function get_file_global_meta (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
character (len=:), allocatable, dimension(:,:) :: res
- res = obj%diag_yaml_file%get_file_global_meta()
+ res = this%diag_yaml_file%get_file_global_meta()
end function get_file_global_meta
+
!> \brief Checks if file_fname is allocated in the yaml object
!! \return true if file_fname is allocated
-pure function has_file_fname (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_fname (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_fname()
+ res = this%diag_yaml_file%has_file_fname()
end function has_file_fname
+
!> \brief Checks if file_frequnit is allocated in the yaml object
!! \return true if file_frequnit is allocated
-pure function has_file_frequnit (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_frequnit (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_frequnit()
+ res = this%diag_yaml_file%has_file_frequnit()
end function has_file_frequnit
+
!> \brief Checks if file_freq is allocated in the yaml object
!! \return true if file_freq is allocated
-pure function has_file_freq (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_freq (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_freq()
+ res = this%diag_yaml_file%has_file_freq()
end function has_file_freq
+
!> \brief Checks if file_timeunit is allocated in the yaml object
!! \return true if file_timeunit is allocated
-pure function has_file_timeunit (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_timeunit (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_timeunit()
+ res = this%diag_yaml_file%has_file_timeunit()
end function has_file_timeunit
+
!> \brief Checks if file_unlimdim is allocated in the yaml object
!! \return true if file_unlimdim is allocated
-pure function has_file_unlimdim (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_unlimdim (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_unlimdim()
+ res = this%diag_yaml_file%has_file_unlimdim()
end function has_file_unlimdim
+
!> \brief Checks if file_sub_region is allocated in the yaml object
!! \return true if file_sub_region is allocated
-pure function has_file_sub_region (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_sub_region (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_sub_region()
+ res = this%diag_yaml_file%has_file_sub_region()
end function has_file_sub_region
+
!> \brief Checks if file_new_file_freq is allocated in the yaml object
!! \return true if file_new_file_freq is allocated
-pure function has_file_new_file_freq (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_new_file_freq (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_new_file_freq()
+ res = this%diag_yaml_file%has_file_new_file_freq()
end function has_file_new_file_freq
+
!> \brief Checks if file_new_file_freq_units is allocated in the yaml object
!! \return true if file_new_file_freq_units is allocated
-pure function has_file_new_file_freq_units (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_new_file_freq_units (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_new_file_freq_units()
+ res = this%diag_yaml_file%has_file_new_file_freq_units()
end function has_file_new_file_freq_units
+
!> \brief Checks if file_start_time is allocated in the yaml object
!! \return true if file_start_time is allocated
-pure function has_file_start_time (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_start_time (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_start_time()
+ res = this%diag_yaml_file%has_file_start_time()
end function has_file_start_time
+
!> \brief Checks if file_duration is allocated in the yaml object
!! \return true if file_duration is allocated
-pure function has_file_duration (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_duration (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_duration()
+ res = this%diag_yaml_file%has_file_duration()
end function has_file_duration
+
!> \brief Checks if file_duration_units is allocated in the yaml object
!! \return true if file_duration_units is allocated
-pure function has_file_duration_units (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_duration_units (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_duration_units()
+ res = this%diag_yaml_file%has_file_duration_units()
end function has_file_duration_units
+
!> \brief Checks if file_varlist is allocated in the yaml object
!! \return true if file_varlist is allocated
-pure function has_file_varlist (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_varlist (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_varlist()
+ res = this%diag_yaml_file%has_file_varlist()
end function has_file_varlist
+
!> \brief Checks if file_global_meta is allocated in the yaml object
!! \return true if file_global_meta is allocated
-pure function has_file_global_meta (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
+pure function has_file_global_meta (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
logical :: res
- res = obj%diag_yaml_file%has_file_global_meta()
+ res = this%diag_yaml_file%has_file_global_meta()
end function has_file_global_meta
+
!> @brief Sets the domain and type of domain from the axis IDs
-subroutine set_domain_from_axis(obj, axes)
- class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+subroutine set_domain_from_axis(this, axes)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
integer, intent(in) :: axes (:)
- call get_domain_and_domain_type(axes, obj%type_of_domain, obj%domain, obj%get_file_fname())
+ call get_domain_and_domain_type(axes, this%type_of_domain, this%domain, this%get_file_fname())
end subroutine set_domain_from_axis
+
!> @brief Set the domain and the type_of_domain for a file
!> @details This subroutine is going to be called once by every variable in the file
!! in register_diag_field. It will update the domain and the type_of_domain if needed and verify that
!! all the variables are in the same domain
-subroutine set_file_domain(obj, domain, type_of_domain)
- class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+subroutine set_file_domain(this, domain, type_of_domain)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
integer, INTENT(in) :: type_of_domain !< fileobj_type to use
CLASS(diagDomain_t), INTENT(in), target :: domain !< Domain
!! If this a sub_regional, don't do anything here
- if (obj%type_of_domain .eq. SUB_REGIONAL) return
+ if (this%type_of_domain .eq. SUB_REGIONAL) return
- if (type_of_domain .ne. obj%type_of_domain) then
+ if (type_of_domain .ne. this%type_of_domain) then
!! If the current type_of_domain in the file obj is not the same as the variable calling this subroutine
- if (type_of_domain .eq. NO_DOMAIN .or. obj%type_of_domain .eq. NO_DOMAIN) then
+ if (type_of_domain .eq. NO_DOMAIN .or. this%type_of_domain .eq. NO_DOMAIN) then
!! If they are not the same then one of them can be NO_DOMAIN
!! (i.e a file can have variables that are not domain decomposed and variables that are)
if (type_of_domain .ne. NO_DOMAIN) then
!! Update the file's type_of_domain and domain if needed
- obj%type_of_domain = type_of_domain
- obj%domain => domain
+ this%type_of_domain = type_of_domain
+ this%domain => domain
endif
else
!! If they are not the same and of them is not NO_DOMAIN, then crash because the variables don't have the
!! same domain (i.e a file has a variable is that in a 2D domain and one that is in a UG domain)
- call mpp_error(FATAL, "The file: "//obj%get_file_fname()//" has variables that are not in the same domain")
+ call mpp_error(FATAL, "The file: "//this%get_file_fname()//" has variables that are not in the same domain")
endif
endif
end subroutine set_file_domain
!> @brief Loops through a variable's axis_ids and adds them to the FMSDiagFile object if they don't exist
-subroutine add_axes(obj, axis_ids)
- class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+subroutine add_axes(this, axis_ids)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
integer :: i, j !< For do loops
do i = 1, size(axis_ids)
- do j = 1, obj%number_of_axis
+ do j = 1, this%number_of_axis
!> Check if the axis already exists, return
- if (axis_ids(i) .eq. obj%axis_ids(j)) return
+ if (axis_ids(i) .eq. this%axis_ids(j)) return
enddo
!> If the axis does not exist add it to the list
- obj%number_of_axis = obj%number_of_axis + 1
- obj%axis_ids(obj%number_of_axis) = axis_ids(i)
+ this%number_of_axis = this%number_of_axis + 1
+ this%axis_ids(this%number_of_axis) = axis_ids(i)
!> If this is a sub_regional file, set up the sub_axes
!> TO DO:
@@ -517,27 +555,27 @@ end subroutine add_axes
!> @brief adds the start time to the fileobj
!! @note This should be called from the register field calls. It can be called multiple times (one for each variable)
!! So it needs to make sure that the start_time is the same for each variable. The initial value is the base_time
-subroutine add_start_time(obj, start_time)
- class(fmsDiagFile_type), intent(inout) :: obj !< The file object
+subroutine add_start_time(this, start_time)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
TYPE(time_type), intent(in) :: start_time !< Start time to add to the fileobj
!< If the start_time sent in is equal to the base_time return because
!! obj%start_time was already set to the base_time
if (start_time .eq. get_base_time()) return
- if (obj%start_time .ne. get_base_time()) then
+ if (this%start_time .ne. get_base_time()) then
!> If the obj%start_time is not equal to the base_time from the diag_table
!! obj%start_time was already updated so make sure it is the same or error out
- if (obj%start_time .ne. start_time)&
- call mpp_error(FATAL, "The variables associated with the file:"//obj%get_file_fname()//" have"&
+ if (this%start_time .ne. start_time)&
+ call mpp_error(FATAL, "The variables associated with the file:"//this%get_file_fname()//" have"&
&" different start_time")
else
!> If the obj%start_time is equal to the base_time,
!! simply update it with the start_time and set up the *_output variables
- obj%start_time = start_time
- obj%last_output = start_time
- obj%next_output = diag_time_inc(start_time, obj%get_file_freq(), obj%get_file_frequnit())
- obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
+ this%start_time = start_time
+ this%last_output = start_time
+ this%next_output = diag_time_inc(start_time, this%get_file_freq(), this%get_file_frequnit())
+ this%next_next_output = diag_time_inc(this%next_output, this%get_file_freq(), this%get_file_frequnit())
endif
end subroutine
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index c250ef887a..fb05cbccd6 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -67,36 +67,37 @@ module fms_diag_object_mod
!! Reads the diag_table.yaml and fills in the yaml object
!! Allocates the diag manager object arrays for files, fields, and buffers
!! Initializes variables
-subroutine fms_diag_object_init (obj,diag_subset_output)
- class(fmsDiagObject_type) :: obj !< Diag mediator/controller object
+subroutine fms_diag_object_init (this,diag_subset_output)
+ class(fmsDiagObject_type) :: this !< Diag mediator/controller object
integer :: diag_subset_output !< Subset of the diag output?
#ifdef use_yaml
- if (obj%initialized) return
+ if (this%initialized) return
!TODO: allocate the file, field, and buffer containers
! allocate(diag_objs(get_num_unique_fields()))
CALL diag_yaml_object_init(diag_subset_output)
CALL fms_diag_axis_object_init()
- obj%files_initialized = fms_diag_files_object_init(obj%FMS_diag_files)
- obj%fields_initialized = fms_diag_fields_object_init (obj%FMS_diag_fields)
- obj%registered_variables = 0
- obj%initialized = .true.
+ this%files_initialized = fms_diag_files_object_init(this%FMS_diag_files)
+ this%fields_initialized = fms_diag_fields_object_init (this%FMS_diag_fields)
+ this%registered_variables = 0
+ this%initialized = .true.
#else
call mpp_error("fms_diag_object_init",&
"You must compile with -Duse_yaml to use the option use_modern_diag", FATAL)
#endif
end subroutine fms_diag_object_init
+
!> \description Loops through all files and does one final write.
!! Closes all files
!! Deallocates all buffers, fields, and files
!! Uninitializes the fms_diag_object
-subroutine fms_diag_object_end (obj)
- class(fmsDiagObject_type) :: obj
+subroutine fms_diag_object_end (this)
+ class(fmsDiagObject_type) :: this
#ifdef use_yaml
!TODO: loop through files and force write
!TODO: Close all files
!TODO: Deallocate diag object arrays and clean up all memory
- obj%initialized = .false.
+ this%initialized = .false.
#endif
end subroutine fms_diag_object_end
@@ -104,11 +105,11 @@ end subroutine fms_diag_object_end
!! @description This to avoid having duplicate code in each of the _scalar, _array and _static register calls
!! @return field index for subsequent call to send_data.
integer function fms_register_diag_field_obj &
- (fms_diag_object, modname, varname, axes, init_time, &
+ (this, modname, varname, axes, init_time, &
longname, units, missing_value, varRange, mask_variant, standname, &
do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
- class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: modname !< The module name
CHARACTER(len=*), INTENT(in) :: varname !< The variable name
TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Initial time
@@ -147,14 +148,14 @@ integer function fms_register_diag_field_obj &
return
endif
- fms_diag_object%registered_variables = fms_diag_object%registered_variables + 1
- fms_register_diag_field_obj = fms_diag_object%registered_variables
+ this%registered_variables = this%registered_variables + 1
+ fms_register_diag_field_obj = this%registered_variables
- call fms_diag_object%FMS_diag_fields(fms_diag_object%registered_variables)%&
- &setID(fms_diag_object%registered_variables)
+ call this%FMS_diag_fields(this%registered_variables)%&
+ &setID(this%registered_variables)
!> Use pointers for convenience
- fieldptr => fms_diag_object%FMS_diag_fields(fms_diag_object%registered_variables)
+ fieldptr => this%FMS_diag_fields(this%registered_variables)
!> Register the data for the field
call fieldptr%register(modname, varname, diag_field_indices, &
axes, longname, units, missing_value, varRange, mask_variant, standname, &
@@ -164,7 +165,7 @@ integer function fms_register_diag_field_obj &
!> Add the axis information, initial time, and field IDs to the files
if (present(axes) .and. present(init_time)) then
do i = 1, size(file_ids)
- fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file
+ fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
call fileptr%set_domain_from_axis(axes)
call fileptr%add_axes(axes)
@@ -172,20 +173,20 @@ integer function fms_register_diag_field_obj &
enddo
elseif (present(axes)) then !only axes present
do i = 1, size(file_ids)
- fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file
+ fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
call fileptr%set_domain_from_axis(axes)
call fileptr%add_axes(axes)
enddo
elseif (present(init_time)) then !only inti time present
do i = 1, size(file_ids)
- fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file
+ fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
call fileptr%add_start_time(init_time)
enddo
else !no axis or init time present
do i = 1, size(file_ids)
- fileptr => fms_diag_object%FMS_diag_files(file_ids(i))%FMS_diag_file
+ fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
enddo
endif
@@ -197,10 +198,10 @@ end function fms_register_diag_field_obj
!> @brief Registers a scalar field
!! @return field index for subsequent call to send_data.
-INTEGER FUNCTION fms_register_diag_field_scalar(fms_diag_object,module_name, field_name, init_time, &
+INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, init_time, &
& long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,&
& area, volume, realm)
- class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
@@ -216,7 +217,7 @@ INTEGER FUNCTION fms_register_diag_field_scalar(fms_diag_object,module_name, fie
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
#ifdef use_yaml
- fms_register_diag_field_scalar = fms_diag_object%register(&
+ fms_register_diag_field_scalar = this%register(&
& module_name, field_name, init_time=init_time, &
& longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
@@ -228,10 +229,10 @@ end function fms_register_diag_field_scalar
!> @brief Registers an array field
!> @return field index for subsequent call to send_data.
-INTEGER FUNCTION fms_register_diag_field_array(fms_diag_object, module_name, field_name, axes, init_time, &
+INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, axes, init_time, &
& long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,&
& do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
- class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis
@@ -255,7 +256,7 @@ INTEGER FUNCTION fms_register_diag_field_array(fms_diag_object, module_name, fie
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
#ifdef use_yaml
- fms_register_diag_field_array = fms_diag_object%register( &
+ fms_register_diag_field_array = this%register( &
& module_name, field_name, init_time=init_time, &
& axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
@@ -267,10 +268,10 @@ end function fms_register_diag_field_array
!> @brief Return field index for subsequent call to send_data.
!! @return field index for subsequent call to send_data.
-INTEGER FUNCTION fms_register_static_field(fms_diag_object, module_name, field_name, axes, long_name, units,&
+INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, long_name, units,&
& missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
& tile_count, area, volume, realm)
- class(fmsDiagObject_type),TARGET,INTENT(inout):: fms_diag_object !< Diaj_obj to fill
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axes_id of the field
@@ -297,7 +298,7 @@ INTEGER FUNCTION fms_register_static_field(fms_diag_object, module_name, field_n
#ifdef use_yaml
! Include static as optional variable to register here
- fms_register_static_field = fms_diag_object%register( &
+ fms_register_static_field = this%register( &
& module_name, field_name, axes=axes, &
& longname=long_name, units=units, missing_value=missing_value, varrange=range, &
& standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm, &
@@ -308,8 +309,8 @@ INTEGER FUNCTION fms_register_static_field(fms_diag_object, module_name, field_n
end function fms_register_static_field
!> @brief Add a attribute to the diag_obj using the diag_field_id
-subroutine fms_diag_field_add_attribute(fms_diag_object, diag_field_id, att_name, att_value)
- class(fmsDiagObject_type), intent (inout) :: fms_diag_object !< The diag object
+subroutine fms_diag_field_add_attribute(this, diag_field_id, att_name, att_value)
+ class(fmsDiagObject_type), intent (inout) :: this !< The diag object
integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
@@ -318,11 +319,12 @@ subroutine fms_diag_field_add_attribute(fms_diag_object, diag_field_id, att_name
if ( diag_field_id .LE. 0 ) THEN
RETURN
else
- if (fms_diag_object%FMS_diag_fields(diag_field_id)%is_registered() ) &
- call fms_diag_object%FMS_diag_fields(diag_field_id)%add_attribute(att_name, att_value)
+ if (this%FMS_diag_fields(diag_field_id)%is_registered() ) &
+ call this%FMS_diag_fields(diag_field_id)%add_attribute(att_name, att_value)
endif
#endif
end subroutine fms_diag_field_add_attribute
+
!> \brief Gets the diag field ID from the module name and field name.
!> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered
PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, field_name) &
From fd3c088faf3d62af80b9d33f2bfea7c34289946e Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 13 Sep 2022 07:23:39 -0400
Subject: [PATCH 066/168] feat: update axis/subaxis types and add controller
object (#1024)
---
diag_manager/Makefile.am | 12 +-
diag_manager/diag_axis.F90 | 46 ++---
diag_manager/diag_manager.F90 | 3 -
diag_manager/fms_diag_axis_object.F90 | 250 +++++++++++--------------
diag_manager/fms_diag_field_object.F90 | 14 +-
diag_manager/fms_diag_file_object.F90 | 23 ++-
diag_manager/fms_diag_object.F90 | 167 ++++++++++++++++-
7 files changed, 311 insertions(+), 204 deletions(-)
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index caf2dc773e..73efc0c366 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -55,17 +55,15 @@ libdiag_manager_la_SOURCES = \
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
-diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT)
+diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT)
diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT)
diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \
diag_grid_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
-fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
-fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
- diag_util_mod.$(FC_MODEXT)
-fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
- diag_util_mod.$(FC_MODEXT)
-fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT)
+fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
+fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT)
fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90
index e574b8eef3..341f7fbfe6 100644
--- a/diag_manager/diag_axis.F90
+++ b/diag_manager/diag_axis.F90
@@ -40,8 +40,7 @@ MODULE diag_axis_mod
USE diag_data_mod, ONLY: diag_axis_type, max_subaxes, max_axes,&
& max_num_axis_sets, max_axis_attributes, debug_diag_manager,&
& first_send_data_call, diag_atttype, use_modern_diag, TWO_D_DOMAIN
- USE fms_diag_axis_object_mod, ONLY: fms_diag_axis_init, fms_diag_axis_add_attribute, &
- & diagDomain_t, DIAGDOMAIN2D_T, get_domain_and_domain_type, fms_get_axis_length
+ use fms_diag_object_mod, only:fms_diag_object
#ifdef use_netCDF
USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR
#endif
@@ -139,9 +138,9 @@ INTEGER FUNCTION diag_axis_init(name, array_data, units, cart_name, long_name, d
ENDIF
if (use_modern_diag) then
- diag_axis_init = fms_diag_axis_init(name, DATA, units, cart_name, long_name=long_name, direction=direction,&
- & set_name=set_name, edges=edges, Domain=Domain, Domain2=Domain2, DomainU=DomainU, aux=aux, req=req, &
- & tile_count=tile_count, domain_position=domain_position )
+ diag_axis_init = fms_diag_object%fms_diag_axis_init(name, DATA, units, cart_name, long_name=long_name,&
+ & direction=direction, set_name=set_name, edges=edges, Domain=Domain, Domain2=Domain2, DomainU=DomainU, &
+ & aux=aux, req=req, tile_count=tile_count, domain_position=domain_position )
return
endif
IF ( PRESENT(tile_count)) THEN
@@ -586,12 +585,16 @@ SUBROUTINE get_diag_axis_data(id, axis_data)
END SUBROUTINE get_diag_axis_data
!> @brief Return the short name of the axis.
- SUBROUTINE get_diag_axis_name(id, name)
+ SUBROUTINE get_diag_axis_name(id, axis_name)
INTEGER , INTENT(in) :: id !< Axis ID
- CHARACTER(len=*), INTENT(out) :: name !< Axis short name
+ CHARACTER(len=*), INTENT(out) :: axis_name !< Axis short name
- CALL valid_id_check(id, 'get_diag_axis_name')
- name = Axes(id)%name
+ if (use_modern_diag) then
+ axis_name = fms_diag_object%fms_get_axis_name_from_id(id)
+ else
+ CALL valid_id_check(id, 'get_diag_axis_name')
+ axis_name = Axes(id)%name
+ endif
END SUBROUTINE get_diag_axis_name
!> @brief Return the name of the axis' domain
@@ -610,7 +613,7 @@ INTEGER FUNCTION get_axis_length(id)
INTEGER :: length
if (use_modern_diag) then
- get_axis_length = fms_get_axis_length(id)
+ get_axis_length = fms_diag_object%fms_get_axis_length(id)
else
CALL valid_id_check(id, 'get_axis_length')
IF ( Axes(id)%Domain .NE. null_domain1d ) THEN
@@ -698,26 +701,17 @@ TYPE(domain2d) FUNCTION get_domain2d(ids)
INTEGER :: i, id, flag
- INTEGER :: type_of_domain !< The type of domain
- CLASS(diagDomain_t), POINTER :: domain !< Diag Domain pointer
-
IF ( SIZE(ids(:)) < 1 ) THEN
! input argument has incorrect size.
CALL error_mesg('diag_axis_mod::get_domain2d', 'input argument has incorrect size', FATAL)
END IF
- get_domain2d = null_domain2d
if (use_modern_diag) then
- call get_domain_and_domain_type(ids, type_of_domain, domain, "get_domain2d")
- if (type_of_domain .ne. TWO_D_DOMAIN) &
- call error_mesg('diag_axis_mod::get_domain2d', 'The axis do not correspond to a 2d Domain', FATAL)
- select type(domain)
- type is (diagDomain2d_t)
- get_domain2d = domain%domain2
- end select
+ get_domain2d = fms_diag_object%fms_get_domain2d(ids)
return
endif
+ get_domain2d = null_domain2d
flag = 0
DO i = 1, SIZE(ids(:))
id = ids(i)
@@ -1070,7 +1064,7 @@ SUBROUTINE diag_axis_add_attribute_scalar_r(diag_axis_id, att_name, att_value)
REAL, INTENT(in) :: att_value
if (use_modern_diag) then
- call fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /))
+ call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /))
else
CALL diag_axis_add_attribute_r1d(diag_axis_id, att_name, (/ att_value /))
endif
@@ -1082,7 +1076,7 @@ SUBROUTINE diag_axis_add_attribute_scalar_i(diag_axis_id, att_name, att_value)
INTEGER, INTENT(in) :: att_value
if (use_modern_diag) then
- call fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /))
+ call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /))
else
CALL diag_axis_add_attribute_i1d(diag_axis_id, att_name, (/ att_value /))
endif
@@ -1094,7 +1088,7 @@ SUBROUTINE diag_axis_add_attribute_scalar_c(diag_axis_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_value
if (use_modern_diag) then
- call fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /))
+ call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, (/ att_value /))
else
CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_CHAR, cval=att_value)
endif
@@ -1106,7 +1100,7 @@ SUBROUTINE diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value)
REAL, DIMENSION(:), INTENT(in) :: att_value
if (use_modern_diag) then
- call fms_diag_axis_add_attribute(diag_axis_id, att_name, att_value)
+ call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, att_value)
else
CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_FLOAT, rval=att_value)
endif
@@ -1117,7 +1111,7 @@ SUBROUTINE diag_axis_add_attribute_i1d(diag_axis_id, att_name, att_value)
CHARACTER(len=*), INTENT(in) :: att_name
INTEGER, DIMENSION(:), INTENT(in) :: att_value
if (use_modern_diag) then
- call fms_diag_axis_add_attribute(diag_axis_id, att_name, att_value)
+ call fms_diag_object%fms_diag_axis_add_attribute(diag_axis_id, att_name, att_value)
else
CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_INT, ival=att_value)
endif
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 7c8f79dcf2..db8497c3e0 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -239,7 +239,6 @@ MODULE diag_manager_mod
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
#ifdef use_yaml
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field
- use fms_diag_axis_object_mod, only: fms_diag_axis_object_end, fms_diag_axis_object_init
#endif
use fms_diag_object_mod, only:fms_diag_object
@@ -3825,7 +3824,6 @@ SUBROUTINE diag_manager_end(time)
#ifdef use_yaml
if (use_modern_diag) then
call diag_yaml_object_end
- call fms_diag_axis_object_end()
call fms_diag_object%diag_end()
endif
#endif
@@ -4042,7 +4040,6 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
#ifdef use_yaml
if (use_modern_diag) then
CALL diag_yaml_object_init(diag_subset_output)
- CALL fms_diag_axis_object_init()
CALL fms_diag_object%init(diag_subset_output)
endif
#else
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 085d01008a..eeeab90fb0 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -32,7 +32,8 @@ module fms_diag_axis_object_mod
& mpp_get_compute_domain, NORTH, EAST
use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind
use diag_data_mod, only: diag_atttype, max_axes, NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, &
- direction_down, direction_up, fmsDiagAttribute_type, max_axis_attributes
+ direction_down, direction_up, fmsDiagAttribute_type, max_axis_attributes, &
+ MAX_SUBAXES, DIAG_NULL
use mpp_mod, only: FATAL, mpp_error, uppercase
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, &
& register_axis, register_field, register_variable_attribute, write_data
@@ -40,9 +41,9 @@ module fms_diag_axis_object_mod
PRIVATE
- public :: diagAxis_t, fms_diag_axis_init, fms_diag_axis_object_init, fms_diag_axis_object_end, &
- & get_domain_and_domain_type, axis_obj, diagDomain_t, sub_axis_objs, fms_diag_axis_add_attribute, &
- & DIAGDOMAIN2D_T, fms_get_axis_length
+ public :: fmsDiagAxis_type, fms_diag_axis_object_init, fms_diag_axis_object_end, &
+ & get_domain_and_domain_type, diagDomain_t, &
+ & DIAGDOMAIN2D_T, fmsDiagSubAxis_type, fmsDiagAxisContainer_type, fmsDiagFullAxis_type
!> @}
!> @brief Type to hold the domain info for an axis
@@ -70,21 +71,36 @@ module fms_diag_axis_object_mod
type(domainUG) :: DomainUG !< Domain of "U" axis
end type
+ !> @brief Type to hold the diag_axis (either subaxis or a full axis)
+ !> @ingroup diag_axis_object_mod
+ type :: fmsDiagAxisContainer_type
+ class(fmsDiagAxis_type), allocatable :: axis
+ end type
+
+ !> @brief Type to hold the diagnostic axis description.
+ !> @ingroup diag_axis_object_mod
+ TYPE fmsDiagAxis_type
+ INTEGER , private :: axis_id !< ID of the axis
+ END TYPE fmsDiagAxis_type
+
!> @brief Type to hold the subaxis
!> @ingroup diag_axis_object_mod
- TYPE subaxis_t
- CHARACTER(len=:), ALLOCATABLE :: subaxis_name !< Name of the subaxis
- INTEGER :: starting_index !< Starting index of the subaxis relative to the parent axis
- INTEGER :: ending_index !< Ending index of the subaxis relative to the parent axis
- class(*) , ALLOCATABLE :: bounds !< Bounds of the subaxis (lat/lon or indices)
- INTEGER :: parent_axis_id !< Id of the parent_axis
+ TYPE, extends(fmsDiagAxis_type) :: fmsDiagSubAxis_type
+ INTEGER , private :: subaxis_id !< ID of the subaxis
+ CHARACTER(len=:), ALLOCATABLE, private :: subaxis_name !< Name of the subaxis
+ INTEGER , private :: starting_index !< Starting index of the subaxis relative to the
+ !! parent axis
+ INTEGER , private :: ending_index !< Ending index of the subaxis relative to the
+ !! parent axis
+ class(*) , ALLOCATABLE, private :: bounds !< Bounds of the subaxis (lat/lon or indices)
+ INTEGER , private :: parent_axis_id !< Id of the parent_axis
contains
procedure :: exists => check_if_subaxis_exists
- END TYPE subaxis_t
+ END TYPE fmsDiagSubAxis_type
!> @brief Type to hold the diagnostic axis description.
!> @ingroup diag_axis_object_mod
- TYPE diagAxis_t
+ TYPE, extends(fmsDiagAxis_type) :: fmsDiagFullAxis_type
CHARACTER(len=:), ALLOCATABLE, private :: axis_name !< Name of the axis
CHARACTER(len=:), ALLOCATABLE, private :: units !< Units of the axis
CHARACTER(len=:), ALLOCATABLE, private :: long_name !< Long_name attribute of the axis
@@ -92,14 +108,15 @@ module fms_diag_axis_object_mod
CLASS(*), ALLOCATABLE, private :: axis_data(:) !< Data of the axis
CHARACTER(len=:), ALLOCATABLE, private :: type_of_data !< The type of the axis_data ("float" or "double")
!< TO DO this can be a dlinked to avoid having limits
- type(subaxis_t) , private :: subaxis(3) !< Array of subaxis
+ type(fmsDiagSubAxis_type) , private :: subaxis(3) !< Array of subaxis
integer , private :: nsubaxis !< Number of subaxis
class(diagDomain_t),ALLOCATABLE, private :: axis_domain !< Domain
INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN", "TWO_D_DOMAIN",
!! or "UG_DOMAIN")
INTEGER , private :: length !< Global axis length
INTEGER , private :: direction !< Direction of the axis 0, 1, -1
- INTEGER , private :: edges !< Axis ID for the previously defined "edges axis"
+ CHARACTER(len=:), ALLOCATABLE, private :: edges_name !< Name for the previously defined "edges axis"
+ !! This will be written as an attribute
CHARACTER(len=128) , private :: aux !< Auxiliary name, can only be geolon_t
!! or geolat_t
CHARACTER(len=128) , private :: req !< Required field names.
@@ -113,19 +130,15 @@ module fms_diag_axis_object_mod
PROCEDURE :: add_axis_attribute
PROCEDURE :: register => register_diag_axis_obj
PROCEDURE :: axis_length => get_axis_length
+ PROCEDURE :: get_axis_name
+ PROCEDURE :: set_edges_name
PROCEDURE :: set_subaxis
PROCEDURE :: write_axis_metadata
PROCEDURE :: write_axis_data
! TO DO:
! Get/has/is subroutines as needed
- END TYPE diagAxis_t
-
- integer :: number_of_axis !< Number of axis that has been registered
- type(diagAxis_t), ALLOCATABLE, TARGET :: axis_obj(:) !< Diag_axis objects
- logical :: module_is_initialized !< Flag indicating if the module is initialized
- integer :: nsubaxis_objs !< Number of sub_axis that has been registered
- type(subaxis_t), ALLOCATABLE, Target :: sub_axis_objs(:) !< Registered sub_axis objects
+ END TYPE fmsDiagFullAxis_type
!> @addtogroup fms_diag_yaml_mod
!> @{
@@ -134,8 +147,8 @@ module fms_diag_axis_object_mod
!!!!!!!!!!!!!!!!! DIAG AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Initialize the axis
subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name, long_name, direction,&
- & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position )
- class(diagAxis_t), INTENT(out) :: this !< Diag_axis obj
+ & set_name, Domain, Domain2, DomainU, aux, req, tile_count, domain_position )
+ class(fmsDiagFullAxis_type),INTENT(out) :: this !< Diag_axis obj
CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
class(*), INTENT(in) :: axis_data(:) !< Array of coordinate values
CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
@@ -143,7 +156,6 @@ subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name,
CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis.
CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name !< Name of the parent axis, if it is a subaxis
INTEGER, INTENT(in), OPTIONAL :: direction !< Indicates the direction of the axis
- INTEGER, INTENT(in), OPTIONAL :: edges !< Axis ID for the previously defined "edges axis"
TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1D domain
TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2D domain
TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain
@@ -207,10 +219,6 @@ subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name,
if (present(direction)) this%direction = direction
call check_if_valid_direction(this%direction)
- this%edges = 0
- if (present(edges)) this%edges = edges
- call check_if_valid_edges(this%edges)
-
if (present(aux)) this%aux = trim(aux)
if (present(req)) this%req = trim(req)
@@ -220,7 +228,7 @@ end subroutine register_diag_axis_obj
!> @brief Add an attribute to an axis
subroutine add_axis_attribute(this, att_name, att_value)
- class(diagAxis_t),INTENT(INOUT) :: this !< diag_axis obj
+ class(fmsDiagFullAxis_type),INTENT(INOUT) :: this !< diag_axis obj
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
@@ -237,7 +245,7 @@ end subroutine add_axis_attribute
!> @brief Write the axis meta data to an open fileobj
subroutine write_axis_metadata(this, fileobj, sub_axis_id)
- class(diagAxis_t), target, INTENT(IN) :: this !< diag_axis obj
+ class(fmsDiagFullAxis_type), target, INTENT(IN) :: this !< diag_axis obj
class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
integer, OPTIONAL, INTENT(IN) :: sub_axis_id !< ID of the sub_axis, if it exists
@@ -299,10 +307,9 @@ subroutine write_axis_metadata(this, fileobj, sub_axis_id)
call register_variable_attribute(fileobj, axis_name, "positive", "down", str_len=4)
end select
- if (this%edges > 0) then
- axis_edges_name = axis_obj(this%edges)%axis_name
- call register_variable_attribute(fileobj, axis_name, "edges", axis_edges_name, &
- str_len=len_trim(axis_edges_name))
+ if (allocated(this%edges_name)) then
+ call register_variable_attribute(fileobj, axis_name, "edges", this%edges_name, &
+ str_len=len_trim(this%edges_name))
endif
if(allocated(this%attributes)) then
@@ -316,7 +323,7 @@ end subroutine write_axis_metadata
!> @brief Write the axis data to an open fileobj
subroutine write_axis_data(this, fileobj, sub_axis_id)
- class(diagAxis_t), INTENT(IN) :: this !< diag_axis obj
+ class(fmsDiagFullAxis_type),INTENT(IN):: this !< diag_axis obj
class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
integer, OPTIONAL, INTENT(IN) :: sub_axis_id !< ID of the sub_axis, if it exists
@@ -337,8 +344,8 @@ end subroutine write_axis_data
!> @return axis length
function get_axis_length(this) &
result (axis_length)
- class(diagAxis_t), intent(inout) :: this !< diag_axis obj
- integer :: axis_length
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
+ integer :: axis_length
!< If the axis is domain decomposed axis_length will be set to the length for the current PE:
if (allocated(this%axis_domain)) then
@@ -349,12 +356,30 @@ function get_axis_length(this) &
end function
+ !> @brief Get the name of the axis
+ !> @return axis name
+ pure function get_axis_name(this) &
+ result (axis_name)
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
+ CHARACTER(len=:), ALLOCATABLE :: axis_name
+
+ axis_name = this%axis_name
+ end function
+
+ !> @brief Set the name of the edges
+ subroutine set_edges_name(this, edges_name)
+ class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj
+ CHARACTER(len=*), intent(in) :: edges_name !< Name of the edges
+
+ this%edges_name = edges_name
+ end subroutine
+
!> @brief Set the subaxis of the axis obj
!> @return A sub_axis id corresponding to the indices of the sub_axes in the sub_axes_objs array
function set_subaxis(this, bounds) &
result(sub_axes_id)
- class(diagAxis_t), INTENT(INOUT) :: this !< diag_axis obj
- class(*), INTENT(INOUT) :: bounds(:) !< bound of the subaxis
+ class(fmsDiagFullAxis_type), INTENT(INOUT) :: this !< diag_axis obj
+ class(*), INTENT(INOUT) :: bounds(:) !< bound of the subaxis
integer :: sub_axes_id
@@ -367,30 +392,27 @@ function set_subaxis(this, bounds) &
!< TO DO: everything
this%nsubaxis = this%nsubaxis + 1
-
- nsubaxis_objs = nsubaxis_objs + 1
- sub_axes_id = nsubaxis_objs
- !< TO DO: set the parent_axis_id
+ sub_axes_id = -999
end function
!!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Check if a subaxis was already defined
!> @return Flag indicating if a subaxis is already defined
- function check_if_subaxis_exists(this, bounds) &
+ pure function check_if_subaxis_exists(this, bounds) &
result(exists)
- class(subaxis_t), INTENT(INOUT) :: this !< diag_axis obj
- class(*), INTENT(IN) :: bounds(:) !< bounds of the subaxis
- logical :: exists
+ class(fmsDiagSubAxis_type), INTENT(IN) :: this !< diag_axis obj
+ class(*), INTENT(IN) :: bounds(:) !< bounds of the subaxis
+ logical :: exists
!< TO DO: compare bounds
exists = .false.
- end function
+ end function check_if_subaxis_exists
!> @brief Get the length of a 2D domain
!> @return Length of the 2D domain
function get_length(this, cart_axis, domain_position, global_length) &
result (length)
- class(diagDomain_t), INTENT(INOUT) :: this !< diag_axis obj
+ class(diagDomain_t), INTENT(IN) :: this !< diag_axis obj
character(len=*), INTENT(IN) :: cart_axis !< cart_axis of the axis
integer, INTENT(IN) :: domain_position !< Domain position (CENTER, NORTH, EAST)
integer, INTENT(IN) :: global_length !< global_length of the axis
@@ -405,7 +427,7 @@ function get_length(this, cart_axis, domain_position, global_length) &
!< If domain is 1D or UG, just set it to the global length
length = global_length
end select
- end function
+ end function get_length
!!!!!!!!!!!!!!!!! FMS_DOMAIN PROCEDURES !!!!!!!!!!!!!!!!!
@@ -426,70 +448,27 @@ subroutine set_axis_domain(this, Domain, Domain2, DomainU)
end select
end subroutine set_axis_domain
- subroutine fms_diag_axis_object_init()
-
- if (module_is_initialized) return
+ !< @brief Allocates the array of axis/subaxis objects
+ !! @return true if there the aray of axis/subaxis objects is allocated
+ logical function fms_diag_axis_object_init(axis_array)
+ class(fmsDiagAxisContainer_type) , allocatable, intent(inout) :: axis_array(:) !< Array of diag_axis
- number_of_axis = 0
- allocate(axis_obj(max_axes))
+ if (allocated(axis_array)) call mpp_error(FATAL, "The diag_axis containers is already allocated")
+ allocate(axis_array(max_axes))
+ !axis_array%axis_id = DIAG_NULL
- module_is_initialized = .true.
- end subroutine fms_diag_axis_object_init
+ fms_diag_axis_object_init = .true.
+ end function fms_diag_axis_object_init
- subroutine fms_diag_axis_object_end()
- deallocate(axis_obj)
+ !< @brief Deallocates the array of axis/subaxis objects
+ !! @return false if the aray of axis/subaxis objects was allocated
+ logical function fms_diag_axis_object_end(axis_array)
+ class(fmsDiagAxisContainer_type) , allocatable, intent(inout) :: axis_array(:) !< Array of diag_axis
- module_is_initialized = .false.
- end subroutine fms_diag_axis_object_end
+ if (allocated(axis_array)) deallocate(axis_array)
+ fms_diag_axis_object_end = .false.
- !> @brief Wrapper for the register_diag_axis subroutine. This is needed to keep the diag_axis_init
- !! interface the same
- !> @return Axis id
- FUNCTION fms_diag_axis_init(axis_name, axis_data, units, cart_name, long_name, direction,&
- & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position ) &
- & result(id)
-
- CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
- CLASS(*), INTENT(in) :: axis_data(:) !< Array of coordinate values
- CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
- CHARACTER(len=1), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", "U", "N")
- CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis.
- CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name !< Name of the parent axis, if it is a subaxis
- INTEGER, INTENT(in), OPTIONAL :: direction !< Indicates the direction of the axis
- INTEGER, INTENT(in), OPTIONAL :: edges !< Axis ID for the previously defined "edges axis"
- TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1D domain
- TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2D domain
- TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain
- CHARACTER(len=*), INTENT(in), OPTIONAL :: aux !< Auxiliary name, can only be geolon_t
- !! or geolat_t
- CHARACTER(len=*), INTENT(in), OPTIONAL :: req !< Required field names.
- INTEGER, INTENT(in), OPTIONAL :: tile_count !< Number of tiles
- INTEGER, INTENT(in), OPTIONAL :: domain_position !< Domain position, "NORTH" or "EAST"
- integer :: id
-
- number_of_axis = number_of_axis + 1
-
- if (number_of_axis > max_axes) call mpp_error(FATAL, &
- &"diag_axis_init: max_axes exceeded, increase via diag_manager_nml")
-
- call axis_obj(number_of_axis)%register(axis_name, axis_data, units, cart_name, long_name=long_name, &
- & direction=direction, set_name=set_name, edges=edges, Domain=Domain, Domain2=Domain2, DomainU=DomainU, aux=aux, &
- & req=req, tile_count=tile_count, domain_position=domain_position)
-
- id = number_of_axis
- end function
-
- !> @brief Add an attribute to an axis
- subroutine fms_diag_axis_add_attribute(axis_id, att_name, att_value)
- integer, intent(in) :: axis_id !< Id of the axis to add the attribute to
- character(len=*), intent(in) :: att_name !< Name of the attribute
- class(*), intent(in) :: att_value(:) !< The attribute value to add
-
- if (axis_id < 0 .and. axis_id > number_of_axis) &
- call mpp_error(FATAL, "diag_axis_add_attribute: The axis_id is not valid")
-
- call axis_obj(axis_id)%add_axis_attribute(att_name, att_value)
- end subroutine fms_diag_axis_add_attribute
+ end function fms_diag_axis_object_end
!> @brief Check if a cart_name is valid and crashes if it isn't
subroutine check_if_valid_cart_name(cart_name)
@@ -527,17 +506,9 @@ subroutine check_if_valid_direction(direction)
end select
end subroutine check_if_valid_direction
- !> @brief Check if the edges id is valid and crashes if it isn't
- subroutine check_if_valid_edges(edges)
- integer, INTENT(IN) :: edges
-
- if (edges < 0 .or. edges > number_of_axis) &
- call mpp_error(FATAL, "diag_axit_init: The edge axis has not been defined. "&
- "Call diag_axis_init for the edge axis first")
- end subroutine check_if_valid_edges
-
!> @brief Loop through a variable's axis_id to determine and return the domain type and domain to use
- subroutine get_domain_and_domain_type(axis_id, domain_type, domain, var_name)
+ subroutine get_domain_and_domain_type(diag_axis, axis_id, domain_type, domain, var_name)
+ class(fmsDiagAxisContainer_type), target, intent(in) :: diag_axis(:) !< Array of diag_axis
integer, INTENT(IN) :: axis_id(:) !< Array of axis ids
integer, INTENT(OUT) :: domain_type !< fileobj_type to use
CLASS(diagDomain_t), POINTER, INTENT(OUT) :: domain !< Domain
@@ -551,36 +522,27 @@ subroutine get_domain_and_domain_type(axis_id, domain_type, domain, var_name)
do i = 1, size(axis_id)
j = axis_id(i)
- !< Check that all the axis are in the same domain
- if (domain_type .ne. axis_obj(j)%type_of_domain) then
- !< If they are different domains, one of them can be NO_DOMAIN
- !! i.e a variable can have axis that are domain decomposed (x,y) and an axis that isn't (z)
- if (domain_type .eq. NO_DOMAIN .or. axis_obj(j)%type_of_domain .eq. NO_DOMAIN ) then
- !< Update the domain_type and domain, if needed
- if ((axis_obj(j)%type_of_domain .eq. TWO_D_DOMAIN .and. size(axis_id) > 2) &
- & .or. axis_obj(j)%type_of_domain .eq. UG_DOMAIN) then
- domain_type = axis_obj(j)%type_of_domain
- domain => axis_obj(j)%axis_domain
+ select type (axis => diag_axis(j)%axis)
+ type is (fmsDiagFullAxis_type)
+ !< Check that all the axis are in the same domain
+ if (domain_type .ne. axis%type_of_domain) then
+ !< If they are different domains, one of them can be NO_DOMAIN
+ !! i.e a variable can have axis that are domain decomposed (x,y) and an axis that isn't (z)
+ if (domain_type .eq. NO_DOMAIN .or. axis%type_of_domain .eq. NO_DOMAIN ) then
+ !< Update the domain_type and domain, if needed
+ if ((axis%type_of_domain .eq. TWO_D_DOMAIN .and. size(axis_id) > 2) &
+ & .or. axis%type_of_domain .eq. UG_DOMAIN) then
+ domain_type = axis%type_of_domain
+ domain => axis%axis_domain
+ endif
+ else
+ call mpp_error(FATAL, "The variable:"//trim(var_name)//" has axis that are not in the same domain")
endif
- else
- call mpp_error(FATAL, "The variable:"//trim(var_name)//" has axis that are not in the same domain")
endif
- endif
+ end select
enddo
end subroutine get_domain_and_domain_type
- !> @brief Gets the length of the axis based on the axis_id
- !> @return Axis_length
- function fms_get_axis_length(axis_id)&
- result(axis_length)
- INTEGER, INTENT(in) :: axis_id !< Axis ID of the axis to the length of
- integer :: axis_length
-
- if (axis_id < 0 .and. axis_id > number_of_axis) &
- call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid")
-
- axis_length = axis_obj(axis_id)%axis_length()
- end function fms_get_axis_length
end module fms_diag_axis_object_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index c69b9caadd..2504617f34 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -13,12 +13,11 @@ module fms_diag_field_object_mod
use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
&DIAG_FIELD_NOT_FOUND
-
-use diag_axis_mod, only: diag_axis_type
use mpp_mod, only: fatal, note, warning, mpp_error
use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, &
& find_diag_field, get_num_unique_fields
-use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type
+use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
+ & fmsDiagAxisContainer_type
use time_manager_mod, ONLY: time_type
!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
@@ -167,8 +166,7 @@ end function fms_diag_fields_object_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> \Description Fills in and allocates (when necessary) the values in the diagnostic object
subroutine fms_register_diag_field_obj &
- !(dobj, modname, varname, axes, time, longname, units, missing_value, metadata)
- (this, modname, varname, diag_field_indices, axes, &
+ (this, modname, varname, diag_field_indices, diag_axis, axes, &
longname, units, missing_value, varRange, mask_variant, standname, &
do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
@@ -177,6 +175,7 @@ subroutine fms_register_diag_field_obj &
CHARACTER(len=*), INTENT(in) :: varname !< The variable name
integer, INTENT(in) :: diag_field_indices(:) !< Array of indices to the field
!! in the yaml object
+ class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis
INTEGER, TARGET, OPTIONAL, INTENT(in) :: axes(:) !< The axes indicies
CHARACTER(len=*), OPTIONAL, INTENT(in) :: longname !< THe variables long name
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< The units of the variables
@@ -197,9 +196,6 @@ subroutine fms_register_diag_field_obj &
!! modeling_realm attribute
LOGICAL, OPTIONAL, INTENT(in) :: static !< Set to true if it is a static field
- integer :: i !< For do loops
- integer :: j !< this%file_ids(i) (for less typing :)
-
!> Fill in information from the register call
this%varname = trim(varname)
this%modname = trim(modname)
@@ -210,7 +206,7 @@ subroutine fms_register_diag_field_obj &
!> Add axis and domain information
if (present(axes)) then
this%axis_ids = axes
- call get_domain_and_domain_type(this%axis_ids, this%type_of_domain, this%domain, this%varname)
+ call get_domain_and_domain_type(diag_axis, this%axis_ids, this%type_of_domain, this%domain, this%varname)
else
!> The variable is a scalar
this%type_of_domain = NO_DOMAIN
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index e3b33c2ee3..4c1aeb9efd 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -27,10 +27,11 @@ module fms_diag_file_object_mod
#ifdef use_yaml
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t
use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED
-use diag_util_mod, only: diag_time_inc
+!TODO cross dependency use diag_util_mod, only: diag_time_inc
use time_manager_mod, only: time_type, operator(/=), operator(==)
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type
-use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type
+use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
+ fmsDiagAxisContainer_type
use mpp_mod, only: mpp_error, FATAL
implicit none
private
@@ -176,8 +177,9 @@ logical function fms_diag_files_object_init (files_array)
!> Set the start_time of the file to the base_time and set up the *_output variables
obj%start_time = get_base_time()
obj%last_output = get_base_time()
- obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit())
- obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
+ !TODO cross dependency
+ !obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit())
+ !obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
obj%next_open = get_base_time()
nullify(obj)
@@ -487,10 +489,12 @@ pure function has_file_global_meta (this) result(res)
end function has_file_global_meta
!> @brief Sets the domain and type of domain from the axis IDs
-subroutine set_domain_from_axis(this, axes)
- class(fmsDiagFile_type), intent(inout) :: this !< The file object
+subroutine set_domain_from_axis(this, diag_axis, axes)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Array of diag_axis
integer, intent(in) :: axes (:)
- call get_domain_and_domain_type(axes, this%type_of_domain, this%domain, this%get_file_fname())
+
+ call get_domain_and_domain_type(diag_axis, axes, this%type_of_domain, this%domain, this%get_file_fname())
end subroutine set_domain_from_axis
!> @brief Set the domain and the type_of_domain for a file
@@ -574,8 +578,9 @@ subroutine add_start_time(this, start_time)
!! simply update it with the start_time and set up the *_output variables
this%start_time = start_time
this%last_output = start_time
- this%next_output = diag_time_inc(start_time, this%get_file_freq(), this%get_file_frequnit())
- this%next_next_output = diag_time_inc(this%next_output, this%get_file_freq(), this%get_file_frequnit())
+ !TODO circular dependency
+ !obj%next_output = diag_time_inc(start_time, obj%get_file_freq(), obj%get_file_frequnit())
+ !obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
endif
end subroutine
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index fb05cbccd6..0b5768b08c 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -19,7 +19,7 @@
module fms_diag_object_mod
use mpp_mod, only: fatal, note, warning, mpp_error
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
- &DIAG_FIELD_NOT_FOUND, diag_not_registered
+ &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
& OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
& get_ticks_per_second
@@ -27,8 +27,11 @@ module fms_diag_object_mod
use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init
use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init
use fms_diag_yaml_mod, only: diag_yaml_object_init, find_diag_field, get_diag_files_id
-use fms_diag_axis_object_mod, only: fms_diag_axis_object_init
+use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, &
+ &diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, &
+ &fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type
#endif
+use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d
implicit none
private
@@ -39,7 +42,9 @@ module fms_diag_object_mod
!TODO: Remove FMS prefix from variables in this type
class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files
class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields
+ class(fmsDiagAxisContainer_type), allocatable :: diag_axis(:) !< Array of diag_axis
integer, private :: registered_variables !< Number of registered variables
+ integer, private :: registered_axis !< Number of registered axis
logical, private :: initialized=.false. !< True if the fmsDiagObject is initialized
logical, private :: files_initialized=.false. !< True if the fmsDiagObject is initialized
logical, private :: fields_initialized=.false. !< True if the fmsDiagObject is initialized
@@ -51,9 +56,14 @@ module fms_diag_object_mod
procedure :: fms_register_diag_field_scalar
procedure :: fms_register_diag_field_array
procedure :: fms_register_static_field
+ procedure :: fms_diag_axis_init
procedure :: register => fms_register_diag_field_obj !! Merely initialize fields.
procedure :: fms_diag_field_add_attribute
+ procedure :: fms_diag_axis_add_attribute
+ procedure :: fms_get_domain2d
+ procedure :: fms_get_axis_length
procedure :: fms_get_diag_field_id_from_name
+ procedure :: fms_get_axis_name_from_id
procedure :: diag_end => fms_diag_object_end
end type fmsDiagObject_type
@@ -76,10 +86,11 @@ subroutine fms_diag_object_init (this,diag_subset_output)
!TODO: allocate the file, field, and buffer containers
! allocate(diag_objs(get_num_unique_fields()))
CALL diag_yaml_object_init(diag_subset_output)
- CALL fms_diag_axis_object_init()
+ this%axes_initialized = fms_diag_axis_object_init(this%diag_axis)
this%files_initialized = fms_diag_files_object_init(this%FMS_diag_files)
this%fields_initialized = fms_diag_fields_object_init (this%FMS_diag_fields)
this%registered_variables = 0
+ this%registered_axis = 0
this%initialized = .true.
#else
call mpp_error("fms_diag_object_init",&
@@ -97,6 +108,7 @@ subroutine fms_diag_object_end (this)
!TODO: loop through files and force write
!TODO: Close all files
!TODO: Deallocate diag object arrays and clean up all memory
+ this%axes_initialized = fms_diag_axis_object_end(this%diag_axis)
this%initialized = .false.
#endif
end subroutine fms_diag_object_end
@@ -157,7 +169,7 @@ integer function fms_register_diag_field_obj &
!> Use pointers for convenience
fieldptr => this%FMS_diag_fields(this%registered_variables)
!> Register the data for the field
- call fieldptr%register(modname, varname, diag_field_indices, &
+ call fieldptr%register(modname, varname, diag_field_indices, fms_diag_object%diag_axis, &
axes, longname, units, missing_value, varRange, mask_variant, standname, &
do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
!> Get the file IDs from the field indicies from the yaml
@@ -167,7 +179,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
- call fileptr%set_domain_from_axis(axes)
+ call fileptr%set_domain_from_axis(fms_diag_object%diag_axis, axes)
call fileptr%add_axes(axes)
call fileptr%add_start_time(init_time)
enddo
@@ -175,7 +187,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
- call fileptr%set_domain_from_axis(axes)
+ call fileptr%set_domain_from_axis(fms_diag_object%diag_axis, axes)
call fileptr%add_axes(axes)
enddo
elseif (present(init_time)) then !only inti time present
@@ -193,6 +205,8 @@ integer function fms_register_diag_field_obj &
nullify (fileptr)
nullify (fieldptr)
deallocate(diag_field_indices)
+#else
+ fms_register_diag_field_obj = diag_null
#endif
end function fms_register_diag_field_obj
@@ -308,6 +322,65 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes,
#endif
end function fms_register_static_field
+!> @brief Wrapper for the register_diag_axis subroutine. This is needed to keep the diag_axis_init
+!! interface the same
+!> @return Axis id
+FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_name, direction,&
+ & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position ) &
+ & result(id)
+
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
+ CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
+ CLASS(*), INTENT(in) :: axis_data(:) !< Array of coordinate values
+ CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
+ CHARACTER(len=1), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", "U", "N")
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name !< Name of the parent axis, if it is a subaxis
+ INTEGER, INTENT(in), OPTIONAL :: direction !< Indicates the direction of the axis
+ INTEGER, INTENT(in), OPTIONAL :: edges !< Axis ID for the previously defined "edges axis"
+ TYPE(domain1d), INTENT(in), OPTIONAL :: Domain !< 1D domain
+ TYPE(domain2d), INTENT(in), OPTIONAL :: Domain2 !< 2D domain
+ TYPE(domainUG), INTENT(in), OPTIONAL :: DomainU !< Unstructured domain
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: aux !< Auxiliary name, can only be geolon_t
+ !! or geolat_t
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: req !< Required field names.
+ INTEGER, INTENT(in), OPTIONAL :: tile_count !< Number of tiles
+ INTEGER, INTENT(in), OPTIONAL :: domain_position !< Domain position, "NORTH" or "EAST"
+ integer :: id
+
+#ifdef use_yaml
+ CHARACTER(len=:), ALLOCATABLE :: edges_name !< Name of the edges
+
+ this%registered_axis = this%registered_axis + 1
+
+ if (this%registered_axis > max_axes) call mpp_error(FATAL, &
+ &"diag_axis_init: max_axes exceeded, increase via diag_manager_nml")
+
+ allocate(fmsDiagFullAxis_type :: this%diag_axis(this%registered_axis)%axis)
+
+ select type (axis => this%diag_axis(this%registered_axis)%axis )
+ type is (fmsDiagFullAxis_type)
+ if(present(edges)) then
+ if (edges < 0 .or. edges > this%registered_axis) &
+ call mpp_error(FATAL, "diag_axit_init: The edge axis has not been defined. "&
+ "Call diag_axis_init for the edge axis first")
+ select type (edges_axis => this%diag_axis(edges)%axis)
+ type is (fmsDiagFullAxis_type)
+ edges_name = edges_axis%get_axis_name()
+ call axis%set_edges_name(edges_name)
+ end select
+ endif
+ call axis%register(axis_name, axis_data, units, cart_name, long_name=long_name, &
+ & direction=direction, set_name=set_name, Domain=Domain, Domain2=Domain2, DomainU=DomainU, aux=aux, &
+ & req=req, tile_count=tile_count, domain_position=domain_position)
+
+ id = this%registered_axis
+ end select
+#else
+ id = diag_null
+#endif
+end function fms_diag_axis_init
+
!> @brief Add a attribute to the diag_obj using the diag_field_id
subroutine fms_diag_field_add_attribute(this, diag_field_id, att_name, att_value)
class(fmsDiagObject_type), intent (inout) :: this !< The diag object
@@ -325,6 +398,24 @@ subroutine fms_diag_field_add_attribute(this, diag_field_id, att_name, att_value
#endif
end subroutine fms_diag_field_add_attribute
+!> @brief Add an attribute to an axis
+subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value)
+ class(fmsDiagObject_type), intent (inout) :: this !< The diag object
+ integer, intent(in) :: axis_id !< Id of the axis to add the attribute to
+ character(len=*), intent(in) :: att_name !< Name of the attribute
+ class(*), intent(in) :: att_value(:) !< The attribute value to add
+
+#ifdef use_yaml
+ if (axis_id < 0 .and. axis_id > this%registered_axis) &
+ call mpp_error(FATAL, "diag_axis_add_attribute: The axis_id is not valid")
+
+ select type (axis => this%diag_axis(axis_id)%axis)
+ type is (fmsDiagFullAxis_type)
+ call axis%add_axis_attribute(att_name, att_value)
+ end select
+#endif
+end subroutine fms_diag_axis_add_attribute
+
!> \brief Gets the diag field ID from the module name and field name.
!> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered
PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, field_name) &
@@ -345,4 +436,68 @@ PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, fiel
enddo
#endif
END FUNCTION fms_get_diag_field_id_from_name
+
+!> @brief Return the 2D domain for the axis IDs given.
+!! @return 2D domain for the axis IDs given
+type(domain2d) FUNCTION fms_get_domain2d(this, ids)
+ class(fmsDiagObject_type), intent (in) :: this !< The diag object
+ INTEGER, DIMENSION(:), INTENT(in) :: ids !< Axis IDs.
+
+#ifdef use_yaml
+ INTEGER :: type_of_domain !< The type of domain
+ CLASS(diagDomain_t), POINTER :: domain !< Diag Domain pointer
+
+ call get_domain_and_domain_type(fms_diag_object%diag_axis, ids, type_of_domain, domain, "get_domain2d")
+ if (type_of_domain .ne. TWO_D_DOMAIN) &
+ call mpp_error(FATAL, 'diag_axis_mod::get_domain2d- The axis do not correspond to a 2d Domain')
+ select type(domain)
+ type is (diagDomain2d_t)
+ fms_get_domain2d = domain%domain2
+ end select
+#else
+ fms_get_domain2d = null_domain2d
+#endif
+END FUNCTION fms_get_domain2d
+
+ !> @brief Gets the length of the axis based on the axis_id
+ !> @return Axis_length
+ integer function fms_get_axis_length(this, axis_id)
+ class(fmsDiagObject_type), intent (in) :: this !< The diag object
+ INTEGER, INTENT(in) :: axis_id !< Axis ID of the axis to the length of
+
+fms_get_axis_length = 0
+
+#ifdef use_yaml
+ if (axis_id < 0 .and. axis_id > this%registered_axis) &
+ call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid")
+
+ select type (axis => this%diag_axis(axis_id)%axis)
+ type is (fmsDiagFullAxis_type)
+ fms_get_axis_length = axis%axis_length()
+ end select
+#endif
+end function fms_get_axis_length
+
+!> @brief Gets the name of the axis based on the axis_id
+ !> @return The axis_name
+function fms_get_axis_name_from_id (this, axis_id) &
+result(axis_name)
+ class(fmsDiagObject_type), intent (in) :: this !< The diag object
+ INTEGER, INTENT(in) :: axis_id !< Axis ID of the axis to the length of
+
+ character (len=:), allocatable :: axis_name
+
+#ifdef use_yaml
+ if (axis_id < 0 .and. axis_id > this%registered_axis) &
+ call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid")
+
+ select type (axis => this%diag_axis(axis_id)%axis)
+ type is (fmsDiagFullAxis_type)
+ axis_name = axis%get_axis_name()
+ end select
+#else
+ axis_name = ""
+#endif
+end function fms_get_axis_name_from_id
+
end module fms_diag_object_mod
From 49da92e6fea195f6453cae6f2c658d36d785bc07 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 15 Sep 2022 15:04:05 -0400
Subject: [PATCH 067/168] feat: Add fms_diag_time_utils.F90 (#1041)
---
CMakeLists.txt | 1 +
diag_manager/Makefile.am | 18 +-
diag_manager/diag_util.F90 | 212 +--------------------
diag_manager/fms_diag_file_object.F90 | 20 +-
diag_manager/fms_diag_time_utils.F90 | 255 ++++++++++++++++++++++++++
5 files changed, 277 insertions(+), 229 deletions(-)
create mode 100644 diag_manager/fms_diag_time_utils.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 20104a36bf..7de0a8b9ae 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -130,6 +130,7 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_elem_weight_procs.F90
diag_manager/fms_diag_fieldbuff_update.F90
diag_manager/fms_diag_bbox.F90
+ diag_manager/fms_diag_time_utils.F90
diag_manager/fms_diag_object.F90
diag_manager/fms_diag_yaml.F90
diag_manager/fms_diag_file_object.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 73efc0c366..15e50ba8dd 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -45,6 +45,7 @@ libdiag_manager_la_SOURCES = \
fms_diag_bbox.F90 \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh \
+ fms_diag_time_utils.F90 \
fms_diag_file_object.F90 \
fms_diag_field_object.F90 \
fms_diag_yaml.F90 \
@@ -58,18 +59,20 @@ diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT)
diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT)
diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \
- diag_grid_mod.$(FC_MODEXT)
+ diag_grid_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
+fms_diag_time_utils_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
-fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
-fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
-fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT)
-fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT)
-fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
+fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
+ fms_diag_time_utils_mod.$(FC_MODEXT)
+fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
+fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
+fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
+fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) \
- fms_diag_yaml_mod.$(FC_MODEXT) \
+ fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
@@ -79,6 +82,7 @@ MODFILES = \
diag_grid_mod.$(FC_MODEXT) \
diag_output_mod.$(FC_MODEXT) \
diag_util_mod.$(FC_MODEXT) \
+ fms_diag_time_utils_mod.$(FC_MODEXT) \
diag_table_mod.$(FC_MODEXT) \
fms_diag_time_reduction_mod.$(FC_MODEXT) \
fms_diag_outfield_mod.$(FC_MODEXT) \
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index 3a36b07207..c4e807d0b0 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -59,6 +59,7 @@ MODULE diag_util_mod
& write_field_meta_data, done_meta_data, diag_flush
USE diag_output_mod, ONLY: diag_field_write, diag_write_time ! @brief 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)
- TYPE(time_type), INTENT(in) :: time !< Current model time.
- INTEGER, INTENT(in):: output_freq !< Output frequency number value.
- INTEGER, INTENT(in):: output_units !< Output frequency unit.
- CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Function error message.
- !! An empty string indicates the next output
- !! time was found successfully.
-
- 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
-
!> @brief Return the file number for file name and tile.
!! @return Integer find_file
INTEGER FUNCTION find_file(name, tile_count)
@@ -2118,148 +2050,6 @@ SUBROUTINE opening_file(file, time, filename_time)
if (associated(fileob)) nullify(fileob)
END SUBROUTINE opening_file
- !> @brief This function determines a string based on current time.
- !! This string is used as suffix in output file name
- !! @return Character(len=128) get_time_string
- CHARACTER(len=128) FUNCTION get_time_string(filename, current_time)
- CHARACTER(len=128), INTENT(in) :: filename !< File name.
- TYPE(time_type), INTENT(in) :: current_time !< Current model time.
-
- INTEGER :: yr1 !< get from current time
- INTEGER :: mo1 !< get from current time
- INTEGER :: dy1 !< get from current time
- INTEGER :: hr1 !< get from current time
- INTEGER :: mi1 !< get from current time
- INTEGER :: sc1 !< get from current time
- INTEGER :: yr2 !< for computing next_level time unit
- INTEGER :: dy2 !< for computing next_level time unit
- INTEGER :: hr2 !< for computing next_level time unit
- INTEGER :: mi2 !< for computing next_level time unit
- INTEGER :: yr1_s !< actual values to write string
- INTEGER :: mo1_s !< actual values to write string
- INTEGER :: dy1_s !< actual values to write string
- INTEGER :: hr1_s !< actual values to write string
- INTEGER :: mi1_s !< actual values to write string
- INTEGER :: sc1_s !< actual values to write string
- INTEGER :: abs_day !< component of current_time
- INTEGER :: abs_sec !< 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 !< string of current time (output)
- CHARACTER(len=20) :: mo !< string of current time (output)
- CHARACTER(len=20) :: dy !< string of current time (output)
- CHARACTER(len=20) :: hr !< string of current time (output)
- CHARACTER(len=20) :: mi !< string of current time (output)
- CHARACTER(len=20) :: 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
-
!> @brief Return the difference between two times in units.
!! @return Real get_data_dif
REAL FUNCTION get_date_dif(t2, t1, units)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 4c1aeb9efd..ee572b9b76 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -27,7 +27,7 @@ module fms_diag_file_object_mod
#ifdef use_yaml
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t
use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED
-!TODO cross dependency use diag_util_mod, only: diag_time_inc
+use fms_diag_time_utils_mod, only: diag_time_inc
use time_manager_mod, only: time_type, operator(/=), operator(==)
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
@@ -177,9 +177,8 @@ logical function fms_diag_files_object_init (files_array)
!> Set the start_time of the file to the base_time and set up the *_output variables
obj%start_time = get_base_time()
obj%last_output = get_base_time()
- !TODO cross dependency
- !obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit())
- !obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
+ obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit())
+ obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
obj%next_open = get_base_time()
nullify(obj)
@@ -564,23 +563,22 @@ subroutine add_start_time(this, start_time)
TYPE(time_type), intent(in) :: start_time !< Start time to add to the fileobj
!< If the start_time sent in is equal to the base_time return because
- !! obj%start_time was already set to the base_time
+ !! this%start_time was already set to the base_time
if (start_time .eq. get_base_time()) return
if (this%start_time .ne. get_base_time()) then
- !> If the obj%start_time is not equal to the base_time from the diag_table
- !! obj%start_time was already updated so make sure it is the same or error out
+ !> If the this%start_time is not equal to the base_time from the diag_table
+ !! this%start_time was already updated so make sure it is the same or error out
if (this%start_time .ne. start_time)&
call mpp_error(FATAL, "The variables associated with the file:"//this%get_file_fname()//" have"&
&" different start_time")
else
- !> If the obj%start_time is equal to the base_time,
+ !> If the this%start_time is equal to the base_time,
!! simply update it with the start_time and set up the *_output variables
this%start_time = start_time
this%last_output = start_time
- !TODO circular dependency
- !obj%next_output = diag_time_inc(start_time, obj%get_file_freq(), obj%get_file_frequnit())
- !obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
+ this%next_output = diag_time_inc(start_time, this%get_file_freq(), this%get_file_frequnit())
+ this%next_next_output = diag_time_inc(this%next_output, this%get_file_freq(), this%get_file_frequnit())
endif
end subroutine
diff --git a/diag_manager/fms_diag_time_utils.F90 b/diag_manager/fms_diag_time_utils.F90
new file mode 100644
index 0000000000..c595c74617
--- /dev/null
+++ b/diag_manager/fms_diag_time_utils.F90
@@ -0,0 +1,255 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @defgroup fms_diag_time_utils_mod fms_diag_time_utils_mod
+!> @ingroup diag_manager
+!! @brief fms_diag_time_utils contains functions and subroutines necessary for the
+!! diag_manager_mod related to time handling.
+!! @author Uriel Ramirez
+
+!> @addtogroup fms_diag_time_utils_mod
+!> @{
+module fms_diag_time_utils_mod
+
+use time_manager_mod, only: time_type, increment_date, increment_time, get_calendar_type, NO_CALENDAR, leap_year, &
+ get_date, get_time
+use diag_data_mod, only: END_OF_RUN, EVERY_TIME, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, &
+ DIAG_YEARS
+USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE
+use fms_mod, only: fms_error_handler
+
+implicit none
+private
+
+public :: diag_time_inc
+public :: get_time_string
+
+contains
+
+ !> @brief 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)
+ TYPE(time_type), INTENT(in) :: time !< Current model time.
+ INTEGER, INTENT(in) :: output_freq !< Output frequency number value.
+ INTEGER, INTENT(in) :: output_units !< Output frequency unit.
+ CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Function error message.
+ !! An empty string indicates the next output
+ !! time was found successfully.
+
+ CHARACTER(len=128) :: error_message_local !< Local variable to store the error_message
+
+ 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
+
+ !> @brief This function determines a string based on current time.
+ !! This string is used as suffix in output file name
+ !! @return Character(len=128) get_time_string
+ CHARACTER(len=128) FUNCTION get_time_string(filename, current_time)
+ CHARACTER(len=128), INTENT(in) :: filename !< File name.
+ TYPE(time_type), INTENT(in) :: current_time !< Current model time.
+
+ INTEGER :: yr1 !< get from current time
+ INTEGER :: mo1 !< get from current time
+ INTEGER :: dy1 !< get from current time
+ INTEGER :: hr1 !< get from current time
+ INTEGER :: mi1 !< get from current time
+ INTEGER :: sc1 !< get from current time
+ INTEGER :: yr2 !< for computing next_level time unit
+ INTEGER :: dy2 !< for computing next_level time unit
+ INTEGER :: hr2 !< for computing next_level time unit
+ INTEGER :: mi2 !< for computing next_level time unit
+ INTEGER :: yr1_s !< actual values to write string
+ INTEGER :: mo1_s !< actual values to write string
+ INTEGER :: dy1_s !< actual values to write string
+ INTEGER :: hr1_s !< actual values to write string
+ INTEGER :: mi1_s !< actual values to write string
+ INTEGER :: sc1_s !< actual values to write string
+ INTEGER :: abs_day !< component of current_time
+ INTEGER :: abs_sec !< 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 !< string of current time (output)
+ CHARACTER(len=20) :: mo !< string of current time (output)
+ CHARACTER(len=20) :: dy !< string of current time (output)
+ CHARACTER(len=20) :: hr !< string of current time (output)
+ CHARACTER(len=20) :: mi !< string of current time (output)
+ CHARACTER(len=20) :: 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
+
+end module fms_diag_time_utils_mod
From 8a3973414c06de1eab1b829061979f1d9710498c Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 15 Sep 2022 15:05:17 -0400
Subject: [PATCH 068/168] feat: modern diag Adds zbounds to the diag_field yaml
(#1037)
---
diag_manager/fms_diag_yaml.F90 | 24 ++++++++++++++++++++----
1 file changed, 20 insertions(+), 4 deletions(-)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 631a6cf82c..d4959109f5 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -77,7 +77,6 @@ module fms_diag_yaml_mod
!! acceptable values are latlon_gridtype, index_gridtype,
!! null_gridtype
class(*), allocatable :: corners(:,:)!< (x, y) coordinates of the four corner of the region
- integer :: zbounds(2) !< indices of the z axis limits (zbegin, zend)
integer :: tile !< Tile number of the sub region
!! required if using the "index" grid type
@@ -166,6 +165,7 @@ module fms_diag_yaml_mod
character (len=:), private, allocatable :: var_outname !< Name of the variable as written to the file
character (len=:), private, allocatable :: var_longname !< Overwrites the long name of the variable
character (len=:), private, allocatable :: var_units !< Overwrites the units
+ real(kind=r4_kind), private :: var_zbounds(2) !< The z axis limits [vert_min, vert_max]
integer , private :: n_diurnal !< Number of diurnal samples
!! 0 if var_reduction is not "diurnalXX"
integer , private :: pow_value !< The power value
@@ -185,6 +185,7 @@ module fms_diag_yaml_mod
procedure :: get_var_outname
procedure :: get_var_longname
procedure :: get_var_units
+ procedure :: get_var_zbounds
procedure :: get_var_attributes
procedure :: get_n_diurnal
procedure :: get_pow_value
@@ -198,6 +199,7 @@ module fms_diag_yaml_mod
procedure :: has_var_outname
procedure :: has_var_longname
procedure :: has_var_units
+ procedure :: has_var_zbounds
procedure :: has_var_attributes
procedure :: has_n_diurnal
procedure :: has_pow_value
@@ -570,6 +572,9 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field)
call mpp_error(FATAL, "diag_yaml_object_init: variable "//trim(field%var_varname)//" has multiple attribute blocks")
endif
+ !> Set the zbounds if they exist
+ field%var_zbounds = DIAG_NULL
+ call get_value_from_key(diag_file_id, var_id, "zbounds", field%var_zbounds, is_optional=.true.)
end subroutine
!> @brief diag_manager wrapper to get_value_from_key to use for allocatable
@@ -621,9 +626,6 @@ subroutine get_sub_region(diag_yaml_id, sub_region_id, sub_region, grid_type, fn
call get_value_from_key(diag_yaml_id, sub_region_id, "corner3", sub_region%corners(3,:))
call get_value_from_key(diag_yaml_id, sub_region_id, "corner4", sub_region%corners(4,:))
- sub_region%zbounds = DIAG_NULL
- call get_value_from_key(diag_yaml_id, sub_region_id, "zbounds", sub_region%zbounds, is_optional=.true.)
-
end subroutine get_sub_region
!> @brief gets the total number of variables in the diag_table yaml file
@@ -1004,6 +1006,14 @@ pure function get_var_units (diag_var_obj) &
character (len=:), allocatable :: res !< What is returned
res = diag_var_obj%var_units
end function get_var_units
+!> @brief Inquiry for diag_yaml_files_var_obj%var_zbounds
+!! @return var_zbounds of a diag_yaml_files_var_obj
+pure function get_var_zbounds (diag_var_obj) &
+result (res)
+ class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ real(kind=r4_kind) :: res(2) !< What is returned
+ res = diag_var_obj%var_zbounds
+end function get_var_zbounds
!> @brief Inquiry for diag_yaml_files_var_obj%var_attributes
!! @return var_attributes of a diag_yaml_files_var_obj
pure function get_var_attributes(diag_var_obj) &
@@ -1195,6 +1205,12 @@ pure logical function has_var_units (obj)
class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
has_var_units = allocated(obj%var_units)
end function has_var_units
+!> @brief Checks if obj%var_zbounds is allocated
+!! @return true if obj%var_zbounds is allocated
+pure logical function has_var_zbounds (obj)
+ class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+ has_var_zbounds = any(obj%var_zbounds .eq. diag_null)
+end function has_var_zbounds
!> @brief Checks if obj%var_attributes is allocated
!! @return true if obj%var_attributes is allocated
pure logical function has_var_attributes (obj)
From a9ba784afb4ee697445f8f9f15d217ebd5be7cd4 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Tue, 4 Oct 2022 11:01:28 -0400
Subject: [PATCH 069/168] feat: add diag buffer object (#1019)
---
CMakeLists.txt | 1 +
diag_manager/Makefile.am | 7 +-
diag_manager/fms_diag_buffer.F90 | 1414 +++++++++++++++++++
diag_manager/fms_diag_field_object.F90 | 1 +
diag_manager/fms_diag_file_object.F90 | 1 +
diag_manager/fms_diag_object.F90 | 42 +-
test_fms/diag_manager/Makefile.am | 3 +-
test_fms/diag_manager/test_diag_buffer.F90 | 189 +++
test_fms/diag_manager/test_diag_manager2.sh | 4 +
9 files changed, 1655 insertions(+), 7 deletions(-)
create mode 100644 diag_manager/fms_diag_buffer.F90
create mode 100644 test_fms/diag_manager/test_diag_buffer.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 7de0a8b9ae..a9922bae65 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -138,6 +138,7 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_axis_object.F90
diag_manager/fms_diag_dlinked_list.F90
diag_manager/fms_diag_object_container.F90
+ diag_manager/fms_diag_buffer.F90
drifters/cloud_interpolator.F90
drifters/drifters.F90
drifters/drifters_comm.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 15e50ba8dd..2d1fc1cf1c 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -52,7 +52,8 @@ libdiag_manager_la_SOURCES = \
fms_diag_object.F90 \
fms_diag_axis_object.F90 \
fms_diag_object_container.F90 \
- fms_diag_dlinked_list.F90
+ fms_diag_dlinked_list.F90 \
+ fms_diag_buffer.F90
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
@@ -64,7 +65,8 @@ fms_diag_time_utils_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
- fms_diag_time_utils_mod.$(FC_MODEXT)
+ fms_diag_time_utils_mod.$(FC_MODEXT) \
+ fms_diag_buffer_mod.$(FC_MODEXT)
fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
@@ -99,6 +101,7 @@ MODFILES = \
fms_diag_axis_object_mod.$(FC_MODEXT) \
fms_diag_dlinked_list_mod.$(FC_MODEXT) \
fms_diag_object_container_mod.$(FC_MODEXT) \
+ fms_diag_buffer_mod.$(FC_MODEXT) \
diag_manager_mod.$(FC_MODEXT)
nodist_include_HEADERS = $(MODFILES)
diff --git a/diag_manager/fms_diag_buffer.F90 b/diag_manager/fms_diag_buffer.F90
new file mode 100644
index 0000000000..7c22f1c7ad
--- /dev/null
+++ b/diag_manager/fms_diag_buffer.F90
@@ -0,0 +1,1414 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @author Ryan Mulhall
+!> @email ryan.mulhall@noaa.gov
+!! @brief Contains buffer types and routines for the diag manager
+!!
+!! @description Holds buffered data for fmsDiagVars_type objects
+!! buffer0-5d types extend fmsDiagBuffer_class, and upon allocation
+!! are added to the module's buffer_lists depending on it's dimension
+module fms_diag_buffer_mod
+
+use platform_mod
+use iso_c_binding
+use fms_diag_axis_object_mod, only: diagDomain_t
+use time_manager_mod, only: time_type
+use mpp_mod, only: mpp_error, FATAL
+use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8
+
+implicit none
+
+private
+
+#ifdef use_yaml
+!> @brief Object that holds buffered data and other diagnostics
+!! Abstract to ensure use through its extensions(buffer0-5d types)
+type, abstract :: fmsDiagBuffer_class
+ integer, allocatable, private :: buffer_id !< index in buffer list
+ integer, allocatable, public :: num_elements(:) !< used in time-averaging
+ class(*), allocatable, public :: count_0d(:) !< used in time-averaging along with
+ !! counter which is stored in the child types (bufferNd)
+ integer(i4_kind), public :: buffer_type ! holds an allocated buffer0-5d object
+type :: fmsDiagBufferContainer_type
+ class(fmsDiagBuffer_class), allocatable :: diag_buffer_obj !< any 0-5d buffer object
+end type
+
+!> Scalar buffer type to extend fmsDiagBufferContainer_type
+type, extends(fmsDiagBuffer_class) :: buffer0d_type
+ class(*), allocatable :: buffer(:) !< "scalar" numberic buffer value
+ !! will only be allocated to hold 1 value
+ class(*), allocatable :: counter(:) !< (x,y,z, time-of-day) used in the time averaging functions
+ contains
+ procedure :: allocate_buffer => allocate_buffer_0d
+ procedure :: initialize_buffer => initialize_buffer_0d
+ procedure :: add_to_buffer => add_to_buffer_0d
+ procedure :: get_buffer => get_0d
+
+end type buffer0d_type
+
+!> 1D buffer type to extend fmsDiagBuffer_class
+type, extends(fmsDiagBuffer_class) :: buffer1d_type
+ class(*), allocatable :: buffer(:) !< 1D numeric data array
+ class(*), allocatable :: counter(:) !< (x,y,z, time-of-day) used in the time averaging functions
+ contains
+ procedure :: allocate_buffer => allocate_buffer_1d
+ procedure :: initialize_buffer => initialize_buffer_1d
+ procedure :: add_to_buffer => add_to_buffer_1d
+ procedure :: get_buffer => get_1d
+end type buffer1d_type
+
+!> 2D buffer type to extend fmsDiagBuffer_class
+type, extends(fmsDiagBuffer_class) :: buffer2d_type
+ class(*), allocatable :: buffer(:,:) !< 2D numeric data array
+ class(*), allocatable :: counter(:,:) !< (x,y,z, time-of-day) used in the time averaging functions
+ contains
+ procedure :: allocate_buffer => allocate_buffer_2d
+ procedure :: initialize_buffer => initialize_buffer_2d
+ procedure :: add_to_buffer => add_to_buffer_2d
+ procedure :: get_buffer => get_2d
+end type buffer2d_type
+
+!> 3D buffer type to extend fmsDiagBuffer_class
+type, extends(fmsDiagBuffer_class) :: buffer3d_type
+ class(*), allocatable :: buffer(:,:,:) !< 3D numeric data array
+ class(*), allocatable :: counter(:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
+ contains
+ procedure :: allocate_buffer => allocate_buffer_3d
+ procedure :: initialize_buffer => initialize_buffer_3d
+ procedure :: add_to_buffer => add_to_buffer_3d
+ procedure :: get_buffer => get_3d
+end type buffer3d_type
+
+!> 4D buffer type to extend fmsDiagBuffer_class
+type, extends(fmsDiagBuffer_class) :: buffer4d_type
+ class(*), allocatable :: buffer(:,:,:,:) !< 4D numeric data array
+ class(*), allocatable :: counter(:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
+ contains
+ procedure :: allocate_buffer => allocate_buffer_4d
+ procedure :: initialize_buffer => initialize_buffer_4d
+ procedure :: add_to_buffer => add_to_buffer_4d
+ procedure :: get_buffer => get_4d
+end type buffer4d_type
+
+!> 5D buffer type to extend fmsDiagBuffer_class
+type, extends(fmsDiagBuffer_class) :: buffer5d_type
+ class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array
+ class(*), allocatable :: counter(:,:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
+ contains
+ procedure :: allocate_buffer => allocate_buffer_5d
+ procedure :: initialize_buffer => initialize_buffer_5d
+ procedure :: add_to_buffer => add_to_buffer_5d
+ procedure :: get_buffer => get_5d
+end type buffer5d_type
+
+! public types
+public :: buffer0d_type
+public :: buffer1d_type
+public :: buffer2d_type
+public :: buffer3d_type
+public :: buffer4d_type
+public :: buffer5d_type
+public :: fmsDiagBuffer_class
+public :: fmsDiagBufferContainer_type
+
+! public routines
+public :: fms_diag_buffer_init
+
+contains
+
+!!--------module routines
+
+!> Initializes a list of diag buffers
+!> @returns true if allocation is successfull
+logical function fms_diag_buffer_init(buffobjs, buff_list_size)
+ type(fmsDiagBufferContainer_type), allocatable, intent(out) :: buffobjs(:) !< an array of buffer container types
+ !! to allocate
+ integer, intent(in) :: buff_list_size !< number of dimensions needed for
+ !! the buffer data
+ if (allocated(buffobjs)) call mpp_error(FATAL,'fms_diag_buffer_init: passed in buffobjs array is already allocated')
+ allocate(buffobjs(buff_list_size))
+ fms_diag_buffer_init = allocated(buffobjs)
+end function fms_diag_buffer_init
+
+!> Creates a container type encapsulating a new buffer object for the given dimensions.
+!! The buffer object will still need to be allocated to a type via allocate_buffer() before use.
+!> @result A fmsDiagBufferContainer_type that holds a bufferNd_type, where N is buff_dims
+function fms_diag_buffer_create_container(buff_dims) &
+result(rslt)
+ integer, intent(in) :: buff_dims !< dimensions
+ type(fmsDiagBufferContainer_type), allocatable :: rslt
+ character(len=5) :: dim_output !< string to output buff_dims on error
+
+ allocate(rslt)
+ select case (buff_dims)
+ case (0)
+ allocate(buffer0d_type :: rslt%diag_buffer_obj)
+ case (1)
+ allocate(buffer1d_type :: rslt%diag_buffer_obj)
+ case (2)
+ allocate(buffer2d_type :: rslt%diag_buffer_obj)
+ case (3)
+ allocate(buffer3d_type :: rslt%diag_buffer_obj)
+ case (4)
+ allocate(buffer4d_type :: rslt%diag_buffer_obj)
+ case (5)
+ allocate(buffer5d_type :: rslt%diag_buffer_obj)
+ case default
+ write( dim_output, *) buff_dims
+ dim_output = adjustl(dim_output)
+ call mpp_error(FATAL, 'fms_diag_buffer_create_container: invalid number of dimensions given:' // dim_output //&
+ '. Must be 0-5')
+ end select
+end function fms_diag_buffer_create_container
+
+!!--------generic routines for any fmsDiagBuffer_class objects
+
+!> Setter for buffer_id for any buffer objects
+subroutine set_buffer_id(this, id)
+ class(fmsDiagBuffer_class), intent(inout) :: this !< buffer object to set id for
+ integer, intent(in) :: id !< positive integer id to set
+ if (.not.allocated(this%buffer_id) ) allocate(this%buffer_id)
+ this%buffer_id = id
+end subroutine set_buffer_id
+
+!> Remaps 0-5d data buffer from the given object onto a 5d array pointer.
+!> @returns a 5D remapped buffer, with 1:1 for any added dimensions.
+function remap_buffer(buffobj, field_name)
+ class(fmsDiagBuffer_class), target, intent(inout) :: buffobj !< any dimension buffer object
+ class(*), pointer :: remap_buffer(:,:,:,:,:)
+ character(len=*), intent(in) :: field_name !< name of field for error output
+
+ ! get num dimensions from type extension
+ select type (buffobj)
+ type is (buffer0d_type)
+ if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
+ "for field:" // field_name)
+ remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:1) => buffobj%buffer
+ type is (buffer1d_type)
+ if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
+ "for field:" // field_name)
+ remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:1) => buffobj%buffer(1:size(buffobj%buffer,1))
+ type is (buffer2d_type)
+ if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
+ "for field:" // field_name)
+ remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:1, 1:1, 1:1) => buffobj%buffer(:,:)
+ type is (buffer3d_type)
+ if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
+ "for field:" // field_name)
+ remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), 1:1, 1:1) => &
+ & buffobj%buffer(:,:,:)
+ type is (buffer4d_type)
+ if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
+ "for field:" // field_name)
+ remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
+ 1:size(buffobj%buffer,4), 1:1) => buffobj%buffer(:,:,:,:)
+ type is (buffer5d_type)
+ if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
+ "for field:" // field_name)
+ remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
+ 1:size(buffobj%buffer,4), 1:size(buffobj%buffer,5)) => buffobj%buffer(:,:,:,:,:)
+ class default
+ call mpp_error( FATAL, 'remap_buffer_pointer: invalid buffer type for remapping')
+ end select
+
+end function remap_buffer
+
+!> Deallocates data fields from a buffer object.
+subroutine flush_buffer(this)
+ class(fmsDiagBuffer_class), intent(inout) :: this !< any buffer object
+ select type (this)
+ type is (buffer0d_type)
+ if (allocated(this%buffer)) deallocate(this%buffer)
+ if (allocated(this%counter)) deallocate(this%counter)
+ type is (buffer1d_type)
+ if (allocated(this%buffer)) deallocate(this%buffer)
+ if (allocated(this%counter)) deallocate(this%counter)
+ type is (buffer2d_type)
+ if (allocated(this%buffer)) deallocate(this%buffer)
+ if (allocated(this%counter)) deallocate(this%counter)
+ type is (buffer3d_type)
+ if (allocated(this%buffer)) deallocate(this%buffer)
+ if (allocated(this%counter)) deallocate(this%counter)
+ type is (buffer4d_type)
+ if (allocated(this%buffer)) deallocate(this%buffer)
+ if (allocated(this%counter)) deallocate(this%counter)
+ type is (buffer5d_type)
+ if (allocated(this%buffer)) deallocate(this%buffer)
+ if (allocated(this%counter)) deallocate(this%counter)
+ end select
+ if (allocated(this%buffer_id)) deallocate(this%buffer_id)
+ if (allocated(this%count_0d)) deallocate(this%count_0d)
+ if (allocated(this%num_elements)) deallocate(this%num_elements)
+ if (allocated(this%buffer_dims)) deallocate(this%buffer_dims)
+end subroutine flush_buffer
+
+!! -----------Type-specific routines for buffer0-5d
+
+!> Allocates scalar buffer data to the given buff_type.
+subroutine allocate_buffer_0d(this, buff_type, field_name, diurnal_samples)
+ class(buffer0d_type), intent(inout), target :: this !< scalar buffer object
+ class(*),intent(in) :: buff_type !< allocates to the given type, value does not matter
+ character(len=*), intent(in) :: field_name !< field name for error output
+ integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
+ integer :: n_samples !< number of diurnal samples, defaults to 1
+
+ if(present(diurnal_samples)) then
+ n_samples = diurnal_samples
+ else
+ n_samples = 1
+ endif
+
+ if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_0d: buffer already allocated for field:"// &
+ field_name)
+ select type (buff_type)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: this%buffer(1))
+ allocate(integer(kind=i4_kind) :: this%counter(1))
+ allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i4
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: this%buffer(1))
+ allocate(integer(kind=i8_kind) :: this%counter(1))
+ allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i8
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: this%buffer(1))
+ allocate(real(kind=r4_kind) :: this%counter(1))
+ allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
+ this%counter = 0.0_r4_kind
+ this%count_0d = 0.0_r4_kind
+ this%buffer_type = r4
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: this%buffer(1))
+ allocate(real(kind=r8_kind) :: this%counter(1))
+ allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
+ this%counter = 0.0_r8_kind
+ this%count_0d = 0.0_r8_kind
+ this%buffer_type = r8
+ class default
+ call mpp_error("allocate_buffer_0d", &
+ "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
+ "for field:" // field_name, &
+ FATAL)
+ end select
+
+ allocate(this%num_elements(n_samples))
+ allocate(this%buffer_dims(1))
+ this%num_elements = 0
+ this%buffer_dims(1) = 1
+
+end subroutine allocate_buffer_0d
+
+!> Allocates 1D buffer data to given buff_type.
+subroutine allocate_buffer_1d(this, buff_type, buff_size, field_name, diurnal_samples)
+ class(buffer1d_type), intent(inout), target :: this !< scalar buffer object
+ class(*),intent(in) :: buff_type !< allocates to the type of buff_type
+ integer, intent(in) :: buff_size !< dimension bounds
+ character(len=*), intent(in) :: field_name !< field name for error output
+ integer, intent(in), optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
+ integer :: n_samples !< number of diurnal samples, defaults to 1
+
+ if(present(diurnal_samples)) then
+ n_samples = diurnal_samples
+ else
+ n_samples = 1
+ endif
+
+ if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_1d: buffer already allocated for field:" // &
+ field_name)
+ select type (buff_type)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: this%buffer(buff_size))
+ allocate(integer(kind=i4_kind) :: this%counter(buff_size))
+ allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i4
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: this%buffer(buff_size))
+ allocate(integer(kind=i8_kind) :: this%counter(buff_size))
+ allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i8
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: this%buffer(buff_size))
+ allocate(real(kind=r4_kind) :: this%count_0d(buff_size))
+ allocate(real(kind=r4_kind) :: this%counter(n_samples))
+ this%counter = 0.0_r4_kind
+ this%count_0d = 0.0_r4_kind
+ this%buffer_type = r4
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: this%buffer(buff_size))
+ allocate(real(kind=r8_kind) :: this%count_0d(buff_size))
+ allocate(real(kind=r8_kind) :: this%counter(n_samples))
+ this%counter = 0.0_r8_kind
+ this%count_0d = 0.0_r8_kind
+ this%buffer_type = r8
+ class default
+ call mpp_error("allocate_buffer_1d", &
+ "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4 " // &
+ "for field:" // field_name, &
+ FATAL)
+ end select
+
+ allocate(this%num_elements(n_samples))
+ allocate(this%buffer_dims(1))
+ this%num_elements = 0
+ this%count_0d = 0
+ this%buffer_dims(1) = buff_size
+
+end subroutine allocate_buffer_1d
+
+!> Allocates a 2D buffer to given buff_type.
+subroutine allocate_buffer_2d(this, buff_type, buff_sizes, field_name, diurnal_samples)
+ class(buffer2d_type), intent(inout), target :: this !< 2D buffer object
+ class(*),intent(in) :: buff_type !< allocates to the type of buff_type
+ integer, intent(in) :: buff_sizes(2) !< dimension sizes
+ integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
+ integer :: n_samples !< number of diurnal samples, defaults to 1
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(present(diurnal_samples)) then
+ n_samples = diurnal_samples
+ else
+ n_samples = 1
+ endif
+
+ if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_2d: buffer already allocated for field: " // &
+ field_name)
+ select type (buff_type)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
+ allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
+ allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i4
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
+ allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
+ allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i8
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
+ allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
+ allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
+ this%counter = 0.0_r4_kind
+ this%count_0d = 0.0_r4_kind
+ this%buffer_type = r4
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
+ allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
+ allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
+ this%counter = 0.0_r8_kind
+ this%count_0d = 0.0_r8_kind
+ this%buffer_type = r4
+ class default
+ call mpp_error("allocate_buffer_1d", &
+ "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
+ "for field:" // field_name, &
+ FATAL)
+ end select
+ allocate(this%num_elements(n_samples))
+ allocate(this%buffer_dims(2))
+ this%num_elements = 0
+ this%buffer_dims(1) = buff_sizes(1)
+ this%buffer_dims(2) = buff_sizes(2)
+
+end subroutine allocate_buffer_2d
+
+!> Allocates a 3D buffer to given buff_type.
+subroutine allocate_buffer_3d(this, buff_type, buff_sizes, field_name, diurnal_samples)
+ class(buffer3d_type), intent(inout), target :: this !< 3D buffer object
+ class(*),intent(in) :: buff_type !< allocates to the type of buff_type
+ integer, intent(in) :: buff_sizes(3) !< dimension sizes
+ integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
+ integer :: n_samples !< number of diurnal samples, defaults to 1
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(present(diurnal_samples)) then
+ n_samples = diurnal_samples
+ else
+ n_samples = 1
+ endif
+
+ if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_3d: buffer already allocated for field" // &
+ field_name)
+ select type (buff_type)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
+ allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3)))
+ allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i4
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
+ allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3)))
+ allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i8
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
+ allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3)))
+ allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0.0_r4_kind
+ this%buffer_type = r4
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
+ allocate(real(kind=r8_kind) :: this%counter( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
+ allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
+ this%buffer_type = r4
+ this%counter = 0
+ this%count_0d = 0.0_r8_kind
+ class default
+ call mpp_error("allocate_buffer_3d", &
+ "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
+ "for field:" // field_name, FATAL)
+ end select
+
+ allocate(this%num_elements(n_samples))
+ this%num_elements = 0
+ this%count_0d = 0
+ allocate(this%buffer_dims(3))
+ this%buffer_dims(1) = buff_sizes(1)
+ this%buffer_dims(2) = buff_sizes(2)
+ this%buffer_dims(3) = buff_sizes(3)
+
+end subroutine allocate_buffer_3d
+
+!> Allocates a 4D buffer to given buff_type.
+subroutine allocate_buffer_4d(this, buff_type, buff_sizes, field_name, diurnal_samples)
+ class(buffer4d_type), intent(inout), target :: this !< 4D buffer object
+ class(*),intent(in) :: buff_type !< allocates to the type of buff_type
+ integer, intent(in) :: buff_sizes(4) !< dimension buff_sizes
+ character(len=*), intent(in) :: field_name !< field name for error output
+ integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
+ integer :: n_samples !< number of diurnal samples, defaults to 1
+
+ if(present(diurnal_samples)) then
+ n_samples = diurnal_samples
+ else
+ n_samples = 1
+ endif
+
+ if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_4d: buffer already allocated for field:" // &
+ field_name)
+
+ select type (buff_type)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
+ allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
+ allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i4
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
+ allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
+ allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i8
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
+ allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
+ allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0.0_r4_kind
+ this%buffer_type = r4
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
+ allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
+ allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0.0_r8_kind
+ this%buffer_type = r8
+ class default
+ call mpp_error("allocate_buffer_4d", &
+ "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
+ "for field:" // field_name, FATAL)
+ end select
+
+ allocate(this%num_elements(n_samples))
+ this%num_elements = 0
+ this%count_0d = 0
+ allocate(this%buffer_dims(4))
+ this%buffer_dims(1) = buff_sizes(1)
+ this%buffer_dims(2) = buff_sizes(2)
+ this%buffer_dims(3) = buff_sizes(3)
+ this%buffer_dims(4) = buff_sizes(4)
+
+end subroutine allocate_buffer_4d
+
+!> Allocates a 5D buffer to given buff_type.
+subroutine allocate_buffer_5d(this, buff_type, buff_sizes, field_name, diurnal_samples)
+ class(buffer5d_type), intent(inout), target :: this !< 5D buffer object
+ class(*),intent(in) :: buff_type !< allocates to the type of buff_type
+ integer, intent(in) :: buff_sizes(5) !< dimension buff_sizes
+ character(len=*), intent(in) :: field_name !< field name for error output
+ integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
+ integer :: n_samples !< number of diurnal samples, defaults to 1
+
+ if(present(diurnal_samples)) then
+ n_samples = diurnal_samples
+ else
+ n_samples = 1
+ endif
+
+ if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_5d: buffer already allocated for field:" // &
+ field_name)
+ select type (buff_type)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i4
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0
+ this%buffer_type = i8
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0.0_r4_kind
+ this%buffer_type = r4
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
+ this%counter = 0
+ this%count_0d = 0.0_r8_kind
+ this%buffer_type = r8
+ class default
+ call mpp_error("allocate_buffer_5d", &
+ "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
+ "for field:" // field_name, FATAL)
+ end select
+ allocate(this%num_elements(n_samples))
+ this%num_elements = 0
+ this%count_0d = 0
+ allocate(this%buffer_dims(5))
+ this%buffer_dims(1) = buff_sizes(1)
+ this%buffer_dims(2) = buff_sizes(2)
+ this%buffer_dims(3) = buff_sizes(3)
+ this%buffer_dims(4) = buff_sizes(4)
+ this%buffer_dims(5) = buff_sizes(5)
+end subroutine allocate_buffer_5d
+
+!> Get routine for scalar buffers.
+!! Sets the buff_out argument to the integer or real value currently stored in the buffer.
+subroutine get_0d (this, buff_out, field_name)
+ class(buffer0d_type), intent(in) :: this !< 0d allocated buffer object
+ class(*), allocatable, intent(out) :: buff_out !< output of copied buffer data
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_0d(get_buffer): buffer not yet allocated for field:' &
+ & // field_name)
+ select type (buff=>this%buffer)
+ type is (real(r4_kind))
+ allocate(real(r4_kind) :: buff_out)
+ buff_out = buff(1)
+ type is (real(r8_kind))
+ allocate(real(r8_kind) :: buff_out)
+ buff_out = buff(1)
+ type is (integer(i4_kind))
+ allocate(integer(i4_kind) :: buff_out)
+ buff_out = buff(1)
+ type is (integer(i8_kind))
+ allocate(integer(i8_kind) :: buff_out)
+ buff_out = buff(1)
+ class default
+ call mpp_error(FATAL, "get_0d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
+ field_name)
+ end select
+end subroutine
+
+!> Get routine for 1D buffers.
+!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
+subroutine get_1d (this, buff_out, field_name)
+ class(buffer1d_type), intent(in) :: this !< 1d allocated buffer object
+ class(*), allocatable, intent(out) :: buff_out(:) !< output of copied buffer data
+ !! must be the same size as the allocated buffer
+ integer(i4_kind) :: buff_size !< size for allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_0d(get_buffer): buffer not yet allocated for field:' &
+ & // field_name)
+ buff_size = size(this%buffer,1)
+
+ select type (buff=>this%buffer)
+ type is (real(r4_kind))
+ allocate(real(r4_kind) :: buff_out(buff_size))
+ buff_out = buff
+ type is (real(r8_kind))
+ allocate(real(r8_kind) :: buff_out(buff_size))
+ buff_out = buff
+ type is (integer(i4_kind))
+ allocate(integer(i4_kind) :: buff_out(buff_size))
+ buff_out = buff
+ type is (integer(i8_kind))
+ allocate(integer(i8_kind) :: buff_out(buff_size))
+ buff_out = buff
+ class default
+ call mpp_error(FATAL, "get_1d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
+ "field name: "// field_name)
+ end select
+end subroutine
+
+!> Get routine for 2D buffers.
+!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
+subroutine get_2d (this, buff_out, field_name)
+ class(buffer2d_type), intent(in) :: this !< 2d allocated buffer object
+ class(*), allocatable, intent(out) :: buff_out(:,:) !< output of copied buffer data
+ !! must be the same size as the allocated buffer
+ integer(i4_kind) :: buff_size(2) !< sizes for allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_2d(get_buffer): buffer not yet allocated for field:' &
+ & // field_name)
+ buff_size(1) = size(this%buffer,1)
+ buff_size(2) = size(this%buffer,2)
+
+ select type (buff=>this%buffer)
+ type is (real(r4_kind))
+ allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2)))
+ buff_out = buff
+ type is (real(r8_kind))
+ allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2)))
+ buff_out = buff
+ type is (integer(i4_kind))
+ allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2)))
+ buff_out = buff
+ type is (integer(i8_kind))
+ allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2)))
+ buff_out = buff
+ class default
+ call mpp_error(FATAL, "get_2d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
+ "field name: "// field_name)
+
+ end select
+end subroutine
+
+!> Get routine for 3D buffers.
+!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
+subroutine get_3d (this, buff_out, field_name)
+ class(buffer3d_type), intent(in) :: this !< 3d allocated buffer object
+ class(*), allocatable, intent(out) :: buff_out(:,:,:) !< output of copied buffer data
+ !! must be the same size as the allocated buffer
+ integer(i4_kind) :: buff_size(3)!< sizes for allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_3d(get_buffer): buffer not yet allocated for field:' &
+ & // field_name)
+ buff_size(1) = size(this%buffer,1)
+ buff_size(2) = size(this%buffer,2)
+ buff_size(3) = size(this%buffer,3)
+
+ select type (buff=>this%buffer)
+ type is (real(r4_kind))
+ allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3)))
+ buff_out = buff
+ type is (real(r8_kind))
+ allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3)))
+ buff_out = buff
+ type is (integer(i4_kind))
+ allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3)))
+ buff_out = buff
+ type is (integer(i8_kind))
+ allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3)))
+ buff_out = buff
+ class default
+ call mpp_error(FATAL, "get_3d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
+ "field name: "// field_name)
+ end select
+end subroutine
+
+!> Get routine for 4D buffers.
+!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
+subroutine get_4d (this, buff_out, field_name)
+ class(buffer4d_type), intent(in) :: this !< 4d allocated buffer object
+ class(*), allocatable, intent(out) :: buff_out(:,:,:,:) !< output of copied buffer data
+ !! must be the same size as the allocated buffer
+ integer(i4_kind) :: buff_size(4)!< sizes for allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_4d(get_buffer): buffer not yet allocated for field:' &
+ & // field_name)
+ buff_size(1) = size(this%buffer,1)
+ buff_size(2) = size(this%buffer,2)
+ buff_size(3) = size(this%buffer,3)
+ buff_size(4) = size(this%buffer,4)
+
+ select type (buff=>this%buffer)
+ type is (real(r4_kind))
+ allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4)))
+ buff_out = buff
+ type is (real(r8_kind))
+ allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4)))
+ buff_out = buff
+ type is (integer(i4_kind))
+ allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4)))
+ buff_out = buff
+ type is (integer(i8_kind))
+ allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4)))
+ buff_out = buff
+ class default
+ call mpp_error(FATAL, "get_4d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
+ "field name: "// field_name)
+ end select
+end subroutine
+
+!> Get routine for 5D buffers.
+!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
+subroutine get_5d (this, buff_out, field_name)
+ class(buffer5d_type), intent(in) :: this !< 5d allocated buffer object
+ class(*), allocatable, intent(out) :: buff_out(:,:,:,:,:) !< output of copied buffer data
+ !! must be the same size as the allocated buffer
+ integer(i4_kind) :: buff_size(5)!< sizes for allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_5d: buffer not yet allocated for field:' &
+ & // field_name)
+ buff_size(1) = size(this%buffer,1)
+ buff_size(2) = size(this%buffer,2)
+ buff_size(3) = size(this%buffer,3)
+ buff_size(4) = size(this%buffer,4)
+ buff_size(5) = size(this%buffer,5)
+
+ select type (buff=>this%buffer)
+ type is (real(r4_kind))
+ allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
+ buff_out = buff
+ type is (real(r8_kind))
+ allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
+ buff_out = buff
+ type is (integer(i4_kind))
+ allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
+ buff_out = buff
+ type is (integer(i8_kind))
+ allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
+ buff_out = buff
+ class default
+ call mpp_error(FATAL, "get_5d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
+ "field name: "// field_name)
+ end select
+end subroutine
+
+!> @brief Initializes a buffer to a given fill value.
+subroutine initialize_buffer_0d (this, fillval, field_name)
+ class(buffer0d_type), intent(inout) :: this !< scalar buffer object
+ class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_0d: field:'// field_name // &
+ 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
+ select type(buff => this%buffer)
+ type is(real(r8_kind))
+ select type(fillval)
+ type is(real(r8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(r8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(real(r4_kind))
+ select type(fillval)
+ type is(real(r4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(r4_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i8_kind))
+ select type(fillval)
+ type is(integer(i8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(i8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i4_kind))
+ select type(fillval)
+ type is(integer(i4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(i4_kind)' // &
+ ' for field' // field_name )
+ end select
+ class default
+ call mpp_error(FATAL, 'initialize buffer_0d: buffer allocated to invalid data type, this shouldnt happen')
+ end select
+
+end subroutine initialize_buffer_0d
+
+!> @brief Initializes a buffer to a given fill value.
+subroutine initialize_buffer_1d (this, fillval, field_name)
+ class(buffer1d_type), intent(inout) :: this !< 1D buffer object
+ class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_1d: field:'// field_name // &
+ 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
+ ! have to check fill value and buffer types match
+ select type(buff => this%buffer)
+ type is(real(r8_kind))
+ select type(fillval)
+ type is(real(r8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(r8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(real(r4_kind))
+ select type(fillval)
+ type is(real(r4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(r4_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i8_kind))
+ select type(fillval)
+ type is(integer(i8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(i8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i4_kind))
+ select type(fillval)
+ type is(integer(i4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(i4_kind)' // &
+ ' for field' // field_name )
+ end select
+ class default
+ call mpp_error(FATAL, 'initialize buffer_1d: buffer allocated to invalid data type, this shouldnt happen')
+ end select
+
+end subroutine initialize_buffer_1d
+
+!> @brief Initializes a buffer to a given fill value.
+subroutine initialize_buffer_2d (this, fillval, field_name)
+ class(buffer2d_type), intent(inout) :: this !< 2D buffer object
+ class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_2d: field:'// field_name // &
+ 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
+ ! have to check fill value and buffer types match
+ select type(buff => this%buffer)
+ type is(real(r8_kind))
+ select type(fillval)
+ type is(real(r8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(r8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(real(r4_kind))
+ select type(fillval)
+ type is(real(r4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(r4_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i8_kind))
+ select type(fillval)
+ type is(integer(i8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(i8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i4_kind))
+ select type(fillval)
+ type is(integer(i4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(i4_kind)' // &
+ ' for field' // field_name )
+ end select
+ class default
+ call mpp_error(FATAL, 'initialize buffer_2d: buffer allocated to invalid data type, this shouldnt happen')
+ end select
+
+end subroutine initialize_buffer_2d
+
+!> @brief Initializes a buffer to a given fill value.
+subroutine initialize_buffer_3d (this, fillval, field_name)
+ class(buffer3d_type), intent(inout) :: this !< 3D buffer object
+ class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_3d: field:'// field_name // &
+ 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
+ ! have to check fill value and buffer types match
+ select type(buff => this%buffer)
+ type is(real(r8_kind))
+ select type(fillval)
+ type is(real(r8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(r8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(real(r4_kind))
+ select type(fillval)
+ type is(real(r4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(r4_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i8_kind))
+ select type(fillval)
+ type is(integer(i8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(i8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i4_kind))
+ select type(fillval)
+ type is(integer(i4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(i4_kind)' // &
+ ' for field' // field_name )
+ end select
+ class default
+ call mpp_error(FATAL, 'initialize buffer_3d: buffer allocated to invalid data type, this shouldnt happen')
+ end select
+
+end subroutine initialize_buffer_3d
+
+!> @brief Initializes a buffer to a given fill value.
+subroutine initialize_buffer_4d (this, fillval, field_name)
+ class(buffer4d_type), intent(inout) :: this !< allocated 4D buffer object
+ class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_4d: field:'// field_name // &
+ 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
+ ! have to check fill value and buffer types match
+ select type(buff => this%buffer)
+ type is(real(r8_kind))
+ select type(fillval)
+ type is(real(r8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(r8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(real(r4_kind))
+ select type(fillval)
+ type is(real(r4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(r4_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i8_kind))
+ select type(fillval)
+ type is(integer(i8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(i8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i4_kind))
+ select type(fillval)
+ type is(integer(i4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(i4_kind)' // &
+ ' for field' // field_name )
+ end select
+ class default
+ call mpp_error(FATAL, 'initialize buffer_4d: buffer allocated to invalid data type, this shouldnt happen')
+ end select
+
+end subroutine initialize_buffer_4d
+
+!> @brief Initializes a buffer to a given fill value.
+subroutine initialize_buffer_5d (this, fillval, field_name)
+ class(buffer5d_type), intent(inout) :: this !< allocated 5D buffer object
+ class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this
+ character(len=*), intent(in) :: field_name !< field name for error output
+
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_5d: field:'// field_name // &
+ 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
+ ! have to check fill value and buffer types match
+ select type(buff => this%buffer)
+ type is(real(r8_kind))
+ select type(fillval)
+ type is(real(r8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(r8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(real(r4_kind))
+ select type(fillval)
+ type is(real(r4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(r4_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i8_kind))
+ select type(fillval)
+ type is(integer(i8_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(i8_kind)' // &
+ ' for field' // field_name )
+ end select
+ type is(integer(i4_kind))
+ select type(fillval)
+ type is(integer(i4_kind))
+ buff = fillval
+ class default
+ call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(i4_kind)' // &
+ ' for field' // field_name )
+ end select
+ class default
+ call mpp_error(FATAL, 'initialize buffer_5d: buffer allocated to invalid data type, this shouldnt happen')
+ end select
+
+end subroutine initialize_buffer_5d
+
+!> @brief Add values to 0d buffer.
+!! This will just call the init routine since there's only one value.
+!! @note input_data must match allocated type of buffer object.
+subroutine add_to_buffer_0d(this, input_data, field_name)
+ class(buffer0d_type), intent(inout) :: this !< allocated scalar buffer object
+ class(*), intent(in) :: input_data !< data to copy into buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+ if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_0d: buffer not yet allocated for field:'// &
+ field_name)
+ call this%initialize_buffer(input_data, field_name)
+end subroutine add_to_buffer_0d
+
+!> @brief Copy values ( from 1 to size(input_data)) into a 1d buffer object.
+!! @note input_data must match allocated type of buffer object.
+subroutine add_to_buffer_1d(this, input_data, field_name)
+ class(buffer1d_type), intent(inout) :: this !< allocated 1d buffer object
+ class(*), intent(in) :: input_data(:) !< data to copy into the buffer
+ integer :: n !< number of elements in input data
+ logical :: type_error !< set to true if mismatch between input_data and allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+ type_error = .false.
+ if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_1d: buffer not yet allocated for field:' // &
+ field_name)
+ n = SIZE(input_data)
+ if( n .gt. SIZE(this%buffer)) call mpp_error( FATAL,"add_to_buffer_1d: input data larger than allocated buffer " // &
+ "for field: "// field_name)
+ ! have to check both types for assignment
+ select type( buffer => this%buffer )
+ type is(integer(i4_kind))
+ select type(input_data)
+ type is(integer(i4_kind))
+ buffer(1:n) = input_data(1:n)
+ class default
+ type_error = .true.
+ end select
+ type is(integer(i8_kind))
+ select type(input_data)
+ type is(integer(i8_kind))
+ buffer(1:n) = input_data(1:n)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r4_kind))
+ select type(input_data)
+ type is(real(r4_kind))
+ buffer(1:n) = input_data(1:n)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r8_kind))
+ select type(input_data)
+ type is(real(r8_kind))
+ buffer(1:n) = input_data(1:n)
+ class default
+ type_error = .true.
+ end select
+ end select
+ if( type_error ) call mpp_error (FATAL,'add_to_buffer_1d: mismatch between allocated buffer and input data types'// &
+ ' for field:' // field_name)
+end subroutine add_to_buffer_1d
+
+!> @brief Copy values ( from 1 to size(input_data)) into a 2d buffer object.
+!! @note input_data must match allocated type of buffer object.
+subroutine add_to_buffer_2d(this, input_data, field_name)
+ class(buffer2d_type), intent(inout) :: this !< allocated 2d buffer object
+ class(*), intent(in) :: input_data(:,:) !< 2d data array to copy into buffer
+ integer :: n1, n2 !< number of elements per dimension
+ logical :: type_error !< set to true if mismatch between input_data and allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+ type_error = .false.
+ if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_2d: buffer not yet allocated for field:' // &
+ field_name)
+ n1 = SIZE(input_data, 1)
+ n2 = SIZE(input_data, 2)
+ if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2)) then
+ call mpp_error( FATAL,"add_to_buffer_2d: input data larger than allocated buffer")
+ endif
+ ! have to check both types for assignment
+ select type( buffer => this%buffer )
+ type is(integer(i4_kind))
+ select type(input_data)
+ type is(integer(i4_kind))
+ buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2)
+ class default
+ type_error = .true.
+ end select
+ type is(integer(i8_kind))
+ select type(input_data)
+ type is(integer(i8_kind))
+ buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r4_kind))
+ select type(input_data)
+ type is(real(r4_kind))
+ buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r8_kind))
+ select type(input_data)
+ type is(real(r8_kind))
+ buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2)
+ class default
+ type_error = .true.
+ end select
+ end select
+ if( type_error ) call mpp_error (FATAL,'add_to_buffer_1d: mismatch between allocated buffer and input data types'//&
+ ' for field:'// field_name)
+end subroutine add_to_buffer_2d
+
+!> @brief Copy values ( from 1 to size(input_data)) into a 3d buffer object.
+!! @note input_data must match allocated type of buffer object.
+subroutine add_to_buffer_3d(this, input_data, field_name)
+ class(buffer3d_type), intent(inout) :: this !< allocated 3d buffer object
+ class(*), intent(in) :: input_data(:,:,:)!< 3d data array to copy into buffer
+ integer :: n1, n2, n3 !< number of elements per dimension
+ logical :: type_error !< set to true if mismatch between input_data and allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+ type_error = .false.
+ if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_3d: buffer not yet allocated for field:'//&
+ field_name)
+ n1 = SIZE(input_data, 1)
+ n2 = SIZE(input_data, 2)
+ n3 = SIZE(input_data, 3)
+ if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2) .or. &
+ n3 .gt. SIZE(this%buffer, 3)) then
+ call mpp_error( FATAL,"add_to_buffer_3d: input data larger than allocated buffer for field:"//field_name)
+ endif
+ ! have to check both types for assignment
+ select type( buffer => this%buffer )
+ type is(integer(i4_kind))
+ select type(input_data)
+ type is(integer(i4_kind))
+ buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3)
+ class default
+ type_error = .true.
+ end select
+ type is(integer(i8_kind))
+ select type(input_data)
+ type is(integer(i8_kind))
+ buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r4_kind))
+ select type(input_data)
+ type is(real(r4_kind))
+ buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r8_kind))
+ select type(input_data)
+ type is(real(r8_kind))
+ buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3)
+ class default
+ type_error = .true.
+ end select
+ end select
+ if( type_error ) call mpp_error (FATAL,'add_to_buffer_3d: mismatch between allocated buffer and input data types'//&
+ ' for field:'//field_name)
+end subroutine add_to_buffer_3d
+
+!> @brief Copy values ( from 1 to size(input_data)) into a 4d buffer object.
+!! @note input_data must match allocated type of buffer object.
+subroutine add_to_buffer_4d(this, input_data, field_name)
+ class(buffer4d_type), intent(inout) :: this !< allocated 4d buffer object
+ class(*), intent(in) :: input_data(:,:,:,:) !< 4d data to copy into buffer
+ integer :: n1, n2, n3, n4!< number of elements per dimension
+ logical :: type_error !< set to true if mismatch between input_data and allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+ type_error = .false.
+ if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_4d: buffer not yet allocated for field:'// &
+ field_name)
+ n1 = SIZE(input_data, 1)
+ n2 = SIZE(input_data, 2)
+ n3 = SIZE(input_data, 3)
+ n4 = SIZE(input_data, 4)
+ if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2) .or. &
+ n3 .gt. SIZE(this%buffer, 3) .or. n4 .gt. SIZE(this%buffer, 4)) then
+ call mpp_error( FATAL,"add_to_buffer_4d: input data larger than allocated buffer for field:"//field_name)
+ endif
+ ! have to check both types for assignment
+ select type( buffer => this%buffer )
+ type is(integer(i4_kind))
+ select type(input_data)
+ type is(integer(i4_kind))
+ buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4)
+ class default
+ type_error = .true.
+ end select
+ type is(integer(i8_kind))
+ select type(input_data)
+ type is(integer(i8_kind))
+ buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r4_kind))
+ select type(input_data)
+ type is(real(r4_kind))
+ buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r8_kind))
+ select type(input_data)
+ type is(real(r8_kind))
+ buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4)
+ class default
+ type_error = .true.
+ end select
+ end select
+ if( type_error ) call mpp_error (FATAL,'add_to_buffer_4d: mismatch between allocated buffer and input data types'// &
+ ' for field:' //field_name)
+end subroutine add_to_buffer_4d
+
+!> @brief Copy values (from 1 to size(input_data)) into a 5d buffer object.
+!! @note input_data must match allocated type of buffer object.
+subroutine add_to_buffer_5d(this, input_data, field_name)
+ class(buffer5d_type), intent(inout) :: this !< allocated 5d buffer object
+ class(*), intent(in) :: input_data(:,:,:,:,:) !< 5d data to copy into buffer
+ integer :: n1, n2, n3, n4, n5 !< number of elements per dimension
+ logical :: type_error !< set to true if mismatch between input_data and allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
+ type_error = .false.
+ if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_5d: buffer not yet allocated for field:'// &
+ field_name)
+ n1 = SIZE(input_data, 1)
+ n2 = SIZE(input_data, 2)
+ n3 = SIZE(input_data, 3)
+ n4 = SIZE(input_data, 4)
+ n5 = SIZE(input_data, 5)
+ if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2) .or. &
+ n3 .gt. SIZE(this%buffer, 3) .or. n4 .gt. SIZE(this%buffer, 4) .or. &
+ n5 .gt. SIZE(this%buffer, 5)) then
+ call mpp_error( FATAL,"add_to_buffer_4d: input data larger than allocated buffer for field:"//field_name)
+ endif
+ ! have to check both types for assignment
+ select type( buffer => this%buffer )
+ type is(integer(i4_kind))
+ select type(input_data)
+ type is(integer(i4_kind))
+ buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5)
+ class default
+ type_error = .true.
+ end select
+ type is(integer(i8_kind))
+ select type(input_data)
+ type is(integer(i8_kind))
+ buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r4_kind))
+ select type(input_data)
+ type is(real(r4_kind))
+ buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5)
+ class default
+ type_error = .true.
+ end select
+ type is(real(r8_kind))
+ select type(input_data)
+ type is(real(r8_kind))
+ buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5)
+ class default
+ type_error = .true.
+ end select
+ end select
+ if( type_error ) call mpp_error (FATAL,'add_to_buffer_5d: mismatch between allocated buffer and input data types'//&
+ 'for field:'// field_name)
+end subroutine add_to_buffer_5d
+#endif
+end module fms_diag_buffer_mod
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 2504617f34..4953084011 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -36,6 +36,7 @@ module fms_diag_field_object_mod
integer, allocatable, dimension(:) :: file_ids !< Ids of the FMS_diag_files the variable
!! belongs to
integer, allocatable, private :: diag_id !< unique id for varable
+ integer, allocatable, dimension(:) :: buffer_ids !< index/id for this field's buffers
type(fmsDiagAttribute_type), allocatable :: attributes(:) !< attributes for the variable
integer, private :: num_attributes !< Number of attributes currently added
logical, allocatable, private :: static !< true if this is a static var
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index ee572b9b76..e410309be7 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -68,6 +68,7 @@ module fms_diag_file_object_mod
integer, allocatable :: num_registered_fields !< The number of fields registered
!! to the file
integer, dimension(:), allocatable :: axis_ids !< Array of axis ids in the file
+ integer, dimension(:), allocatable :: buffer_ids !< array of buffer ids associated with the file
integer :: number_of_axis !< Number of axis in the file
contains
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 0b5768b08c..93ceab20f7 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -26,10 +26,11 @@ module fms_diag_object_mod
#ifdef use_yaml
use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init
use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init
-use fms_diag_yaml_mod, only: diag_yaml_object_init, find_diag_field, get_diag_files_id
+use fms_diag_yaml_mod, only: diag_yaml_object_init, find_diag_field, get_diag_files_id, diag_yaml
use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, &
&diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, &
&fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type
+use fms_diag_buffer_mod
#endif
use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d
implicit none
@@ -42,6 +43,8 @@ module fms_diag_object_mod
!TODO: Remove FMS prefix from variables in this type
class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files
class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields
+ type(fmsDiagBufferContainer_type), allocatable :: FMS_diag_buffers(:) !< array of buffer objects
+ integer, private :: registered_buffers = 0 !< number of registered buffers, per dimension
class(fmsDiagAxisContainer_type), allocatable :: diag_axis(:) !< Array of diag_axis
integer, private :: registered_variables !< Number of registered variables
integer, private :: registered_axis !< Number of registered axis
@@ -65,10 +68,20 @@ module fms_diag_object_mod
procedure :: fms_get_diag_field_id_from_name
procedure :: fms_get_axis_name_from_id
procedure :: diag_end => fms_diag_object_end
+#ifdef use_yaml
+ procedure :: get_diag_buffer
+#endif
end type fmsDiagObject_type
type (fmsDiagObject_type), target :: fms_diag_object
-public :: fms_diag_object
+integer, private :: registered_variables !< Number of registered variables
+public :: fms_register_diag_field_obj
+public :: fms_register_diag_field_scalar
+public :: fms_register_diag_field_array
+public :: fms_register_static_field
+public :: fms_diag_field_add_attribute
+public :: fms_get_diag_field_id_from_name
+public :: fms_diag_object
public :: fmsDiagObject_type
contains
@@ -83,12 +96,12 @@ subroutine fms_diag_object_init (this,diag_subset_output)
#ifdef use_yaml
if (this%initialized) return
-!TODO: allocate the file, field, and buffer containers
! allocate(diag_objs(get_num_unique_fields()))
CALL diag_yaml_object_init(diag_subset_output)
this%axes_initialized = fms_diag_axis_object_init(this%diag_axis)
this%files_initialized = fms_diag_files_object_init(this%FMS_diag_files)
- this%fields_initialized = fms_diag_fields_object_init (this%FMS_diag_fields)
+ this%fields_initialized = fms_diag_fields_object_init(this%FMS_diag_fields)
+ this%buffers_initialized = fms_diag_buffer_init(this%FMS_diag_buffers, SIZE(diag_yaml%get_diag_fields()))
this%registered_variables = 0
this%registered_axis = 0
this%initialized = .true.
@@ -104,10 +117,17 @@ end subroutine fms_diag_object_init
!! Uninitializes the fms_diag_object
subroutine fms_diag_object_end (this)
class(fmsDiagObject_type) :: this
+ integer :: i
#ifdef use_yaml
!TODO: loop through files and force write
!TODO: Close all files
!TODO: Deallocate diag object arrays and clean up all memory
+ do i=1, size(this%FMS_diag_buffers)
+ if(allocated(this%FMS_diag_buffers(i)%diag_buffer_obj)) then
+ call this%FMS_diag_buffers(i)%diag_buffer_obj%flush_buffer()
+ endif
+ enddo
+ deallocate(this%FMS_diag_buffers)
this%axes_initialized = fms_diag_axis_object_end(this%diag_axis)
this%initialized = .false.
#endif
@@ -437,6 +457,20 @@ PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, fiel
#endif
END FUNCTION fms_get_diag_field_id_from_name
+#ifdef use_yaml
+!> returns the buffer object for the given id
+!! actual data comes from %get_buffer_data() on the returned object
+function get_diag_buffer(this, bufferid) &
+result(rslt)
+ class(fmsDiagObject_type), intent(in) :: this
+ integer, intent(in) :: bufferid
+ class(fmsDiagBuffer_class),allocatable:: rslt
+ if( (bufferid .gt. UBOUND(this%FMS_diag_buffers, 1)) .or. (bufferid .lt. UBOUND(this%FMS_diag_buffers, 1))) &
+ call mpp_error(FATAL, 'get_diag_bufer: invalid bufferid given')
+ rslt = fms_diag_object%FMS_diag_buffers(bufferid)%diag_buffer_obj
+end function
+#endif
+
!> @brief Return the 2D domain for the axis IDs given.
!! @return 2D domain for the axis IDs given
type(domain2d) FUNCTION fms_get_domain2d(this, ids)
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 94dbc18774..5f643ec0c6 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -30,7 +30,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
# Build this test program.
check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_object_container \
test_diag_update_buffer test_diag_dlinked_list \
- test_diag_yaml test_diag_ocean test_modern_diag
+ test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -40,6 +40,7 @@ test_diag_yaml_SOURCES = test_diag_yaml.F90
test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90
test_diag_ocean_SOURCES = test_diag_ocean.F90
test_modern_diag_SOURCES = test_modern_diag.F90
+test_diag_buffer_SOURCES= test_diag_buffer.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
diff --git a/test_fms/diag_manager/test_diag_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90
new file mode 100644
index 0000000000..52d3d25458
--- /dev/null
+++ b/test_fms/diag_manager/test_diag_buffer.F90
@@ -0,0 +1,189 @@
+program test_diag_buffer
+#ifdef use_yaml
+
+ use fms_diag_buffer_mod
+ use platform_mod
+ use diag_data_mod, only: i4, i8, r4, r8
+
+ implicit none
+
+ type(buffer0d_type) :: buffobj0(10)
+ type(buffer1d_type) :: buffobj1
+ type(buffer2d_type) :: buffobj2
+ type(buffer3d_type) :: buffobj3
+ type(buffer4d_type) :: buffobj4
+ type(buffer5d_type) :: buffobj5
+ class(*),allocatable :: p_val, p_data1(:), p_data2(:,:)
+ real(r8_kind) :: r8_data
+ real(r4_kind) :: r4_data
+ integer(i8_kind) :: i8_data
+ integer(i4_kind) :: i4_data
+ integer :: buff_id
+ class(*), pointer :: remap_buffer_out(:,:,:,:,:)
+ integer :: i
+ real(4) :: arr(9)
+ real(4), allocatable :: arr1d(:)
+ class(*), allocatable :: arr2d(:,:)
+ integer(8), allocatable :: i8arr2d(:,:)
+ real(8), allocatable :: r8val
+ class(*), allocatable :: arr3d(:,:,:), arr4d(:,:,:,:), arr5d(:,:,:,:,:)
+ integer(8), allocatable :: i8arr3d(:,:,:), i8arr4d(:,:,:,:), i8arr5d(:,:,:,:,:)
+ logical :: test_5d = .true.
+ character(len=4) :: fname = 'test'
+
+ !! 0d
+ ! allocate some buffers
+ do i=1, 10
+ call buffobj0(i)%allocate_buffer(r8_data, fname)
+ call buffobj0(i)%initialize_buffer( real(i, kind=r8_kind) , fname)
+ end do
+ ! add some values
+ call buffobj0(5)%add_to_buffer(real(-1, kind=r8_kind), fname)
+ ! get the buffer data
+ !allocate(real(8) :: p_val)
+ !allocate(r8val)
+ call buffobj0(5)%get_buffer(p_val, fname)
+ select type(p_val)
+ type is(real(r8_kind))
+ print *, p_val
+ r8val = p_val
+ end select
+ ! get the 5d remapped buffer data
+ remap_buffer_out => buffobj0(5)%remap_buffer(fname)
+ ! check output from object and remapped buffer
+ print *, r8val
+ call print_5d(remap_buffer_out)
+ do i=1, 10
+ call buffobj0(i)%flush_buffer()
+ enddo
+
+ !! 1d
+ ! allocate a buffer to the given type and get it's id
+ call buffobj1%allocate_buffer(r4_data, 10, fname)
+ !! init to given value
+ call buffobj1%initialize_buffer( real(0.1, kind=r4_kind), fname )
+ !! add some values to the buffer
+ arr = 4.0
+ call buffobj1%add_to_buffer(arr, fname)
+ !! get the buffer
+ allocate(real(8) :: p_data1(10))
+ allocate(arr1d(10))
+ call buffobj1%get_buffer(p_data1, fname)
+ select type(p_data1)
+ type is(real(4))
+ print *, p_data1
+ arr1d = p_data1
+ end select
+ !! get the remapped buffer
+ remap_buffer_out => buffobj1%remap_buffer(fname)
+ !! check output
+ print *, arr1d
+ call print_5d(remap_buffer_out)
+ call buffobj1%flush_buffer()
+ print *, '********** 2d **********'
+
+ !! 2d
+ ! allocate a buffer to the given type and get it's id
+ call buffobj2%allocate_buffer(i4_data, (/ 5, 10 /), fname )
+ !!! init to given value
+ call buffobj2%initialize_buffer( int(2, kind=i4_kind), fname )
+ !! set some values in the buffer
+ allocate(integer(4) :: arr2d(5,10))
+ arr2d = 1
+ call buffobj2%add_to_buffer(arr2d, fname)
+ !!! get the buffer
+ call buffobj2%get_buffer(arr2d, fname)
+ !!! get the remapped buffer
+ remap_buffer_out => buffobj2%remap_buffer(fname)
+ !!! check output
+ select type(arr2d)
+ type is(integer(i4_kind))
+ print *, arr2d
+ end select
+ call print_5d(remap_buffer_out)
+ call buffobj2%flush_buffer()
+
+ !! 3d
+ ! allocate a buffer to the given type and get it's id
+ call buffobj3%allocate_buffer(i8_data, (/ 2, 2, 2/), fname )
+ !! init to given value
+ call buffobj3%initialize_buffer( int(3, kind=i8_kind), fname )
+ !! set some values in the buffer
+ allocate(i8arr3d(2,2,2))
+ i8arr3d = 6
+ call buffobj3%add_to_buffer(i8arr3d, fname)
+ !! get the buffer
+ call buffobj3%get_buffer(arr3d, fname)
+ !! get the remapped buffer
+ remap_buffer_out => buffobj3%remap_buffer(fname)
+ !! check output
+ select type (arr3d)
+ type is(integer(i8_kind))
+ print *, arr3d
+ end select
+ call print_5d(remap_buffer_out)
+ call buffobj3%flush_buffer()
+
+ !! 4d
+ ! allocate a buffer to the given type and get it's id
+ call buffobj4%allocate_buffer(i8_data, (/ 2, 2, 2, 2/), fname)
+ !! init to given value
+ call buffobj4%initialize_buffer( int(4, kind=i8_kind), fname )
+ !! set some values in the buffer
+ allocate(i8arr4d(2,2,2,2))
+ i8arr4d = 8
+ call buffobj4%add_to_buffer(i8arr4d, fname)
+ !! get the buffer
+ call buffobj4%get_buffer(arr4d, fname)
+ !! get the remapped buffer
+ remap_buffer_out => buffobj4%remap_buffer(fname)
+ !! check output
+ select type (arr4d)
+ type is(integer(i8_kind))
+ print *, arr4d
+ end select
+ call print_5d(remap_buffer_out)
+ call buffobj4%flush_buffer()
+
+ !! 5d
+ call buffobj5%allocate_buffer(i8_data, (/ 2, 2, 2, 2, 2/), fname )
+ !! init to given value
+ call buffobj5%initialize_buffer( int(5, kind=i8_kind), fname )
+ !! get the remapped buffer
+ remap_buffer_out => buffobj5%remap_buffer(fname)
+ !! set some values in the buffer
+ allocate(i8arr5d(2,2,2,2,2))
+ i8arr5d = 10
+ call buffobj5%add_to_buffer(i8arr5d, fname)
+ !! get the buffer
+ call buffobj5%get_buffer(arr5d, fname)
+ !! check output
+ select type (arr4d)
+ type is(integer(i8_kind))
+ print *, arr4d
+ end select
+ call print_5d(remap_buffer_out)
+ call buffobj5%flush_buffer()
+
+ contains
+
+ ! just prints polymorphic data types
+ subroutine print_5d(val)
+ class(*), intent(in) :: val(:,:,:,:,:)
+
+ select type (val)
+ type is (real(r4_kind))
+ print *, "5d:", val
+ type is (real(r8_kind))
+ print *, "5d:", val
+ type is (integer(i4_kind))
+ print *, "5d:",val
+ type is (integer(i8_kind))
+ print *, "5d:",val
+ end select
+ end subroutine
+
+
+
+#endif
+end program
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index b1451e2492..7807924fb2 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -723,5 +723,9 @@ my_test_count=43
test_expect_success "Test the modern diag manager end to end (test $my_test_count)" '
mpirun -n 6 ../test_modern_diag
'
+my_test_count=44
+test_expect_success "buffer functionality (test $my_test_count)" '
+ mpirun -n 1 ../test_diag_buffer
+'
test_done
From c50bb00af98b327d6663b3d4dab0f2efdf5ceac1 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 4 Oct 2022 11:02:29 -0400
Subject: [PATCH 070/168] feat: modern diag_manager add io to open_file (#1044)
---
diag_manager/diag_manager.F90 | 5 +
diag_manager/fms_diag_axis_object.F90 | 6 +-
diag_manager/fms_diag_field_object.F90 | 26 +++
diag_manager/fms_diag_file_object.F90 | 171 ++++++++++++++++++--
diag_manager/fms_diag_object.F90 | 24 ++-
diag_manager/fms_diag_yaml.F90 | 2 +-
test_fms/diag_manager/test_diag_manager2.sh | 32 ++++
test_fms/diag_manager/test_modern_diag.F90 | 5 +-
8 files changed, 252 insertions(+), 19 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index db8497c3e0..7e83a7ffb9 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -3758,6 +3758,11 @@ SUBROUTINE diag_send_complete(time_step, err_msg)
& "diag_manager_set_time_end must be called before diag_send_complete", FATAL)
END IF
+ if (use_modern_diag) then
+ call fms_diag_object%fms_diag_send_complete(time_step)
+ return
+ endif
+
DO file = 1, num_files
freq = files(file)%output_freq
DO j = 1, files(file)%num_fields
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index eeeab90fb0..4a0a7added 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -43,7 +43,7 @@ module fms_diag_axis_object_mod
public :: fmsDiagAxis_type, fms_diag_axis_object_init, fms_diag_axis_object_end, &
& get_domain_and_domain_type, diagDomain_t, &
- & DIAGDOMAIN2D_T, fmsDiagSubAxis_type, fmsDiagAxisContainer_type, fmsDiagFullAxis_type
+ & DIAGDOMAIN2D_T, fmsDiagSubAxis_type, fmsDiagAxisContainer_type, fmsDiagFullAxis_type, DIAGDOMAINUG_T
!> @}
!> @brief Type to hold the domain info for an axis
@@ -530,9 +530,9 @@ subroutine get_domain_and_domain_type(diag_axis, axis_id, domain_type, domain, v
!! i.e a variable can have axis that are domain decomposed (x,y) and an axis that isn't (z)
if (domain_type .eq. NO_DOMAIN .or. axis%type_of_domain .eq. NO_DOMAIN ) then
!< Update the domain_type and domain, if needed
- if ((axis%type_of_domain .eq. TWO_D_DOMAIN .and. size(axis_id) > 2) &
+ if ((axis%type_of_domain .eq. TWO_D_DOMAIN .and. size(axis_id) > 1) &
& .or. axis%type_of_domain .eq. UG_DOMAIN) then
- domain_type = axis%type_of_domain
+ domain_type = axis%type_of_domain
domain => axis%axis_domain
endif
else
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 4953084011..c539ea419d 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -125,6 +125,8 @@ module fms_diag_field_object_mod
procedure :: get_missing_value
procedure :: get_data_RANGE
procedure :: get_axis_id
+ procedure :: get_domain
+ procedure :: get_type_of_domain
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagField_type) :: null_ob
@@ -759,6 +761,30 @@ function get_axis_id (this) &
endif
end function get_axis_id
+!> @brief Gets field's domain
+!! @return pointer to the domain
+function get_domain (this) &
+result(rslt)
+ class (fmsDiagField_type), target, intent(in) :: this !< diag field
+ class(diagDomain_t), pointer :: rslt !< field's domain
+
+ if (associated(this%domain)) then
+ rslt => this%domain
+ else
+ rslt => null()
+ endif
+
+end function get_domain
+
+!> @brief Gets field's type of domain
+!! @return integer defining the type of domain (NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN)
+pure function get_type_of_domain (this) &
+result(rslt)
+ class (fmsDiagField_type), target, intent(in) :: this !< diag field
+ integer :: rslt !< field's domain
+
+ rslt = this%type_of_domain
+end function get_type_of_domain
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!! Allocation checks
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index e410309be7..f6c4d7d489 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -25,14 +25,17 @@
!! list of the variables and their variable IDs that are in the file.
module fms_diag_file_object_mod
#ifdef use_yaml
-use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t
-use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED
-use fms_diag_time_utils_mod, only: diag_time_inc
+use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t, &
+ get_instance_filename, open_file, close_file, get_mosaic_tile_file
+use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED, &
+ TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ
+use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date
+use fms_diag_time_utils_mod, only: diag_time_inc, get_time_string
use time_manager_mod, only: time_type, operator(/=), operator(==)
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
- fmsDiagAxisContainer_type
-use mpp_mod, only: mpp_error, FATAL
+ fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T
+use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL
implicit none
private
@@ -66,7 +69,7 @@ module fms_diag_file_object_mod
!! if the variable has been registered and
!! `field_id` has been set for the variable
integer, allocatable :: num_registered_fields !< The number of fields registered
- !! to the file
+ !! to the file
integer, dimension(:), allocatable :: axis_ids !< Array of axis ids in the file
integer, dimension(:), allocatable :: buffer_ids !< array of buffer ids associated with the file
integer :: number_of_axis !< Number of axis in the file
@@ -114,16 +117,19 @@ module fms_diag_file_object_mod
procedure, public :: has_file_duration_units
procedure, public :: has_file_varlist
procedure, public :: has_file_global_meta
-
end type fmsDiagFile_type
type, extends (fmsDiagFile_type) :: subRegionalFile_type
integer, dimension(:), allocatable :: sub_axis_ids !< Array of axis ids in the file
+ logical :: write_on_this_pe !< Flag indicating if the subregion is on the current PE
end type subRegionalFile_type
!> \brief A container for fmsDiagFile_type. This is used to create the array of files
type fmsDiagFileContainer_type
- class (fmsDiagFile_type),allocatable :: FMS_diag_file !< The individual file object
+ class (fmsDiagFile_type),allocatable :: FMS_diag_file !< The individual file object
+
+ contains
+ procedure :: open_diag_file
end type fmsDiagFileContainer_type
!type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_file !< The array of diag files
@@ -147,11 +153,11 @@ logical function fms_diag_files_object_init (files_array)
if (diag_yaml%diag_files(i)%has_file_sub_region()) then
allocate(subRegionalFile_type :: files_array(i)%FMS_diag_file)
obj => files_array(i)%FMS_diag_file
- obj%type_of_domain = SUB_REGIONAL
select type (obj)
type is (subRegionalFile_type)
allocate(obj%sub_axis_ids(max_axes))
obj%sub_axis_ids = diag_null
+ obj%write_on_this_pe = .true. !TODO this should be .false. probably
end select
else
allocate(FmsDiagFile_type::files_array(i)%FMS_diag_file)
@@ -506,9 +512,6 @@ subroutine set_file_domain(this, domain, type_of_domain)
integer, INTENT(in) :: type_of_domain !< fileobj_type to use
CLASS(diagDomain_t), INTENT(in), target :: domain !< Domain
- !! If this a sub_regional, don't do anything here
- if (this%type_of_domain .eq. SUB_REGIONAL) return
-
if (type_of_domain .ne. this%type_of_domain) then
!! If the current type_of_domain in the file obj is not the same as the variable calling this subroutine
@@ -583,5 +586,149 @@ subroutine add_start_time(this, start_time)
endif
end subroutine
+
+!< @brief Opens the diag_file if it is time to do so
+subroutine open_diag_file(this, time_step)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ TYPE(time_type), intent(in) :: time_step !< Current model step time
+
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
+ class(diagDomain_t), pointer :: domain !< The domain used in the file
+ character(len=:), allocatable :: diag_file_name !< The file name as defined in the yaml
+ character(len=128) :: base_name !< The file name as defined in the yaml
+ !! without the wildcard definition
+ character(len=128) :: file_name !< The file name as it will be written to disk
+ character(len=128) :: temp_name !< Temp variable to store the file_name
+ character(len=128) :: start_date !< The start_time as a string that will be added to
+ !! the begining of the filename (start_date.filename)
+ character(len=128) :: suffix !< The current time as a string that will be added to
+ !! the end of filename
+ integer :: pos !< Index of the filename with the first "%" in the file name
+ INTEGER :: year !< The year of the start_date
+ INTEGER :: month !< The month of the start_date
+ INTEGER :: day !< The day of the start_date
+ INTEGER :: hour !< The hour of the start_date
+ INTEGER :: minute !< The minute of the start_date
+ INTEGER :: second !< The second of the start_date
+ character(len=4) :: mype_string !< The pe as a string
+ logical :: is_regional !< Flag indicating if the file is regional
+ integer, allocatable :: pes(:) !< Array of the pes in the current pelist
+
+ diag_file => this%FMS_diag_file
+ domain => diag_file%domain
+
+ !< Go away if it is not time to open the file
+ if (diag_file%next_open > time_step) return
+
+ is_regional = .false.
+ !< Figure out what fileobj to use!
+ if (.not. allocated(diag_file%fileobj)) then
+ select type (diag_file)
+ type is (subRegionalFile_type)
+ !< Go away if the subregion is not on current PE
+ if (.not. diag_file%write_on_this_pe) return
+
+ !< In this case each PE is going to write its own file
+ allocate(FmsNetcdfFile_t :: diag_file%fileobj)
+
+ is_regional = .true.
+ type is (fmsDiagFile_type)
+ !< Use the type_of_domain to get the correct fileobj
+ select case (diag_file%type_of_domain)
+ case (NO_DOMAIN)
+ allocate(FmsNetcdfFile_t :: diag_file%fileobj)
+ case (TWO_D_DOMAIN)
+ allocate(FmsNetcdfDomainFile_t :: diag_file%fileobj)
+ case (UG_DOMAIN)
+ allocate(FmsNetcdfUnstructuredDomainFile_t :: diag_file%fileobj)
+ end select
+ end select
+ else
+ !< In this case, we are opening a new file so close the current the file
+ call close_file(diag_file%fileobj)
+ endif
+
+ !< Figure out what to name of the file
+ diag_file_name = diag_file%get_file_fname()
+
+ !< If using the new_file_freq figure out what the name is based on the current time
+ if (diag_file%has_file_new_file_freq()) then
+ !< If using a wildcard file name (i.e ocn%4yr%2mo%2dy%2hr), get the basename (i.e ocn)
+ pos = INDEX(diag_file_name, '%')
+ if (pos > 0) base_name = diag_file_name(1:pos-1)
+ suffix = get_time_string(diag_file_name, time_step) !TODO fname_time?
+ base_name = trim(base_name)//trim(suffix)
+ else
+ base_name = trim(diag_file_name)
+ endif
+
+ !< Add the ens number to the file name (if it exists)
+ file_name = trim(base_name)
+ call get_instance_filename(base_name, file_name)
+
+ !< Prepend the file start_time to the file name if prepend_date == .TRUE. in
+ !! the namelist
+ IF ( prepend_date ) THEN
+ call get_date(diag_file%start_time, year, month, day, hour, minute, second)
+ write (start_date, '(1I20.4, 2I2.2)') year, month, day
+
+ file_name = TRIM(adjustl(start_date))//'.'//TRIM(file_name)
+ END IF
+
+ file_name = trim(file_name)//".nc"
+
+ !< If this is a regional file add the PE and the tile_number to the filename
+ if (is_regional) then
+ !< Get the pe number that will be appended to the end of the file
+ write(mype_string,'(I0.4)') mpp_pe()
+
+ !< Add the tile number if appropriate
+ select type (domain)
+ type is (DIAGDOMAIN2D_T)
+ temp_name = file_name
+ call get_mosaic_tile_file(temp_name, file_name, .true., domain%domain2)
+ end select
+
+ file_name = trim(file_name)//"."//trim(mype_string)
+ endif
+
+ !< Open the file!
+ select type (fileobj => diag_file%fileobj)
+ type is (FmsNetcdfFile_t)
+ if (is_regional) then
+ if (.not. open_file(fileobj, file_name, "overwrite", pelist=(/mpp_pe()/))) &
+ &call mpp_error(FATAL, "Error opening the file:"//file_name)
+ else
+ allocate(pes(mpp_npes()))
+ call mpp_get_current_pelist(pes)
+
+ if (.not. open_file(fileobj, file_name, "overwrite", pelist=pes)) &
+ &call mpp_error(FATAL, "Error opening the file:"//file_name)
+ endif
+ type is (FmsNetcdfDomainFile_t)
+ select type (domain)
+ type is (diagDomain2d_t)
+ if (.not. open_file(fileobj, file_name, "overwrite", domain%Domain2)) &
+ &call mpp_error(FATAL, "Error opening the file:"//file_name)
+ end select
+ type is (FmsNetcdfUnstructuredDomainFile_t)
+ select type (domain)
+ type is (diagDomainUg_t)
+ if (.not. open_file(fileobj, file_name, "overwrite", domain%DomainUG)) &
+ &call mpp_error(FATAL, "Error opening the file:"//file_name)
+ end select
+ end select
+
+ if (diag_file%has_file_new_file_freq()) then
+ diag_file%next_open = diag_time_inc(diag_file%next_open, diag_file%get_file_new_file_freq(), &
+ diag_file%get_file_new_file_freq_units())
+ else
+ diag_file%next_open = diag_time_inc(diag_file%next_open, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ endif
+
+!TODO: closing the file here for now, just to see if it works
+ call close_file(diag_file%fileobj)
+end subroutine open_diag_file
+
#endif
end module fms_diag_file_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 93ceab20f7..8357a3669e 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -67,6 +67,7 @@ module fms_diag_object_mod
procedure :: fms_get_axis_length
procedure :: fms_get_diag_field_id_from_name
procedure :: fms_get_axis_name_from_id
+ procedure :: fms_diag_send_complete
procedure :: diag_end => fms_diag_object_end
#ifdef use_yaml
procedure :: get_diag_buffer
@@ -199,7 +200,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
- call fileptr%set_domain_from_axis(fms_diag_object%diag_axis, axes)
+ call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%add_axes(axes)
call fileptr%add_start_time(init_time)
enddo
@@ -207,7 +208,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
- call fileptr%set_domain_from_axis(fms_diag_object%diag_axis, axes)
+ call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%add_axes(axes)
enddo
elseif (present(init_time)) then !only inti time present
@@ -401,6 +402,25 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n
#endif
end function fms_diag_axis_init
+!> @brief Loops through all the files, open the file, writes out axis and
+!! variable metadata and data when necessary.
+subroutine fms_diag_send_complete(this, time_step)
+ class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object
+ TYPE (time_type), INTENT(in) :: time_step !< The current model time
+
+ integer :: i !< For do loops
+
+#ifdef use_yaml
+ class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience)
+
+ do i = 1, size(this%FMS_diag_files)
+ diag_file => this%FMS_diag_files(i)
+ call diag_file%open_diag_file(time_step)
+ enddo
+#endif
+
+end subroutine fms_diag_send_complete
+
!> @brief Add a attribute to the diag_obj using the diag_field_id
subroutine fms_diag_field_add_attribute(this, diag_field_id, att_name, att_value)
class(fmsDiagObject_type), intent (inout) :: this !< The diag object
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index d4959109f5..771b266351 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -1112,7 +1112,7 @@ end function has_file_sub_region
!! @return true
pure logical function has_file_new_file_freq (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_new_file_freq = .true.
+ has_file_new_file_freq = obj%file_new_file_freq .ne. DIAG_NULL
end function has_file_new_file_freq
!> @brief Checks if obj%file_new_file_freq_units is allocated
!! @return true if obj%file_new_file_freq_units is allocated
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 7807924fb2..5b36157c90 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -717,6 +717,38 @@ diag_files:
var_name: var1
reduction: average
kind: r4
+- file_name: file5
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: atm_mod
+ var_name: var4
+ reduction: average
+ kind: r4
+ sub_region:
+ - grid_type: index
+ tile: 1
+ corner1: 10, 15
+ corner2: 20, 15
+ corner3: 10, 25
+ corner4: 20, 25
+- file_name: wild_card_name%4yr%2mo%2dy%2hr
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6
+ new_file_freq_units: hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12
+ file_duration_units: hours
+ varlist:
+ - module: atm_mod
+ var_name: var4
+ reduction: average
+ kind: r4
_EOF
my_test_count=43
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index 57e5b55745..d6c1fbc3d8 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -26,7 +26,8 @@ program test_modern_diag
mpp_get_compute_domain, mpp_get_data_domain, mpp_get_UG_domain_grid_index, &
mpp_get_UG_compute_domain
use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
- diag_axis_add_attribute, diag_field_add_attribute
+ diag_axis_add_attribute, diag_field_add_attribute, diag_send_complete, &
+ diag_manager_set_time_end
use fms_mod, only: fms_init, fms_end
use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast
use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time
@@ -149,6 +150,8 @@ program test_modern_diag
call diag_field_add_attribute (id_var1, "real", 10.)
call diag_field_add_attribute (id_var2, '1d real', (/10./))
+call diag_manager_set_time_end(Time)
+call diag_send_complete(Time)
call diag_manager_end(Time)
call fms_end
From a02fcfb1195edb940df3aaa6d30eb81acea7758b Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Fri, 7 Oct 2022 12:38:57 -0400
Subject: [PATCH 071/168] feat: add dump routines for diag objects (#1048)
---
diag_manager/diag_manager.F90 | 2 +-
diag_manager/fms_diag_field_object.F90 | 76 +++++++++++++++++++++-
diag_manager/fms_diag_file_object.F90 | 29 ++++++++-
diag_manager/fms_diag_object.F90 | 55 +++++++++++++++-
diag_manager/fms_diag_yaml.F90 | 69 +++++++++++++++++++-
test_fms/diag_manager/test_diag_yaml.F90 | 4 ++
test_fms/diag_manager/test_modern_diag.F90 | 6 ++
7 files changed, 235 insertions(+), 6 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 7e83a7ffb9..8249f3919a 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -4045,7 +4045,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
#ifdef use_yaml
if (use_modern_diag) then
CALL diag_yaml_object_init(diag_subset_output)
- CALL fms_diag_object%init(diag_subset_output)
+ CALL fms_diag_object%init(diag_subset_output)
endif
#else
if (use_modern_diag) &
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index c539ea419d..5130b98737 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -13,7 +13,7 @@ module fms_diag_field_object_mod
use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
&DIAG_FIELD_NOT_FOUND
-use mpp_mod, only: fatal, note, warning, mpp_error
+use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe
use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, &
& find_diag_field, get_num_unique_fields
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
@@ -125,6 +125,7 @@ module fms_diag_field_object_mod
procedure :: get_missing_value
procedure :: get_data_RANGE
procedure :: get_axis_id
+ procedure :: dump_field_obj
procedure :: get_domain
procedure :: get_type_of_domain
end type fmsDiagField_type
@@ -964,5 +965,78 @@ PURE FUNCTION diag_field_id_from_name(this, module_name, field_name) &
diag_field_id = this%get_id()
endif
end function diag_field_id_from_name
+
+!> Dumps any data from a given fmsDiagField_type object
+subroutine dump_field_obj (this, unit_num)
+ class(fmsDiagField_type), intent(in) :: this
+ integer, intent(in) :: unit_num !< passed in from dump_diag_obj if log file is being written to
+ integer :: i
+
+ if( mpp_pe() .eq. mpp_root_pe()) then
+ if( allocated(this%file_ids)) write(unit_num, *) 'file_ids:' ,this%file_ids
+ if( allocated(this%diag_id)) write(unit_num, *) 'diag_id:' ,this%diag_id
+ if( allocated(this%static)) write(unit_num, *) 'static:' ,this%static
+ if( allocated(this%registered)) write(unit_num, *) 'registered:' ,this%registered
+ if( allocated(this%mask_variant)) write(unit_num, *) 'mask_variant:' ,this%mask_variant
+ if( allocated(this%do_not_log)) write(unit_num, *) 'do_not_log:' ,this%do_not_log
+ if( allocated(this%local)) write(unit_num, *) 'local:' ,this%local
+ if( allocated(this%vartype)) write(unit_num, *) 'vartype:' ,this%vartype
+ if( allocated(this%varname)) write(unit_num, *) 'varname:' ,this%varname
+ if( allocated(this%longname)) write(unit_num, *) 'longname:' ,this%longname
+ if( allocated(this%standname)) write(unit_num, *) 'standname:' ,this%standname
+ if( allocated(this%units)) write(unit_num, *) 'units:' ,this%units
+ if( allocated(this%modname)) write(unit_num, *) 'modname:' ,this%modname
+ if( allocated(this%realm)) write(unit_num, *) 'realm:' ,this%realm
+ if( allocated(this%interp_method)) write(unit_num, *) 'interp_method:' ,this%interp_method
+ if( allocated(this%tile_count)) write(unit_num, *) 'tile_count:' ,this%tile_count
+ if( allocated(this%axis_ids)) write(unit_num, *) 'axis_ids:' ,this%axis_ids
+ write(unit_num, *) 'type_of_domain:' ,this%type_of_domain
+ if( allocated(this%area)) write(unit_num, *) 'area:' ,this%area
+ if( allocated(this%missing_value)) then
+ select type(missing_val => this%missing_value)
+ type is (real(r4_kind))
+ write(unit_num, *) 'missing_value:', missing_val
+ type is (real(r8_kind))
+ write(unit_num, *) 'missing_value:' ,missing_val
+ type is(integer(i4_kind))
+ write(unit_num, *) 'missing_value:' ,missing_val
+ type is(integer(i8_kind))
+ write(unit_num, *) 'missing_value:' ,missing_val
+ end select
+ endif
+ if( allocated( this%data_RANGE)) then
+ select type(drange => this%data_RANGE)
+ type is (real(r4_kind))
+ write(unit_num, *) 'data_RANGE:' ,drange
+ type is (real(r8_kind))
+ write(unit_num, *) 'data_RANGE:' ,drange
+ type is(integer(i4_kind))
+ write(unit_num, *) 'data_RANGE:' ,drange
+ type is(integer(i8_kind))
+ write(unit_num, *) 'data_RANGE:' ,drange
+ end select
+ endif
+ write(unit_num, *) 'num_attributes:' ,this%num_attributes
+ if( allocated(this%attributes)) then
+ do i=1, this%num_attributes
+ if( allocated(this%attributes(i)%att_value)) then
+ select type( val => this%attributes(i)%att_value)
+ type is (real(r8_kind))
+ write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val
+ type is (real(r4_kind))
+ write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val
+ type is (integer(i4_kind))
+ write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val
+ type is (integer(i8_kind))
+ write(unit_num, *) 'attribute name', this%attributes(i)%att_name, 'val:', val
+ end select
+ endif
+ enddo
+ endif
+
+ endif
+
+end subroutine
+
#endif
end module fms_diag_field_object_mod
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index f6c4d7d489..45b2beeadd 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -31,11 +31,11 @@ module fms_diag_file_object_mod
TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ
use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date
use fms_diag_time_utils_mod, only: diag_time_inc, get_time_string
-use time_manager_mod, only: time_type, operator(/=), operator(==)
+use time_manager_mod, only: time_type, operator(/=), operator(==), date_to_string
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T
-use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL
+use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout
implicit none
private
@@ -117,6 +117,7 @@ module fms_diag_file_object_mod
procedure, public :: has_file_duration_units
procedure, public :: has_file_varlist
procedure, public :: has_file_global_meta
+ procedure, public :: dump_file_obj
end type fmsDiagFile_type
type, extends (fmsDiagFile_type) :: subRegionalFile_type
@@ -587,6 +588,30 @@ subroutine add_start_time(this, start_time)
end subroutine
+!> writes out internal values for fmsDiagFile_type object
+subroutine dump_file_obj(this, unit_num)
+ class(fmsDiagFile_type), intent(in) :: this !< the file object
+ integer, intent(in) :: unit_num !< passed in from dump_diag_obj
+ !! will either be for new log file or stdout
+ write( unit_num, *) 'file id:', this%id
+ write( unit_num, *) 'start time:', date_to_string(this%start_time)
+ write( unit_num, *) 'last_output', date_to_string(this%last_output)
+ write( unit_num, *) 'next_output', date_to_string(this%next_output)
+ write( unit_num, *)'next_next_output', date_to_string(this%next_next_output)
+ write( unit_num, *)'next_open', date_to_string(this%next_open)
+
+ if( allocated(this%fileobj)) write( unit_num, *)'fileobj path', this%fileobj%path
+
+ write( unit_num, *)'type_of_domain', this%type_of_domain
+ if( allocated(this%file_metadata_from_model)) write( unit_num, *) 'file_metadata_from_model', &
+ this%file_metadata_from_model
+ if( allocated(this%field_ids)) write( unit_num, *)'field_ids', this%field_ids
+ if( allocated(this%field_registered)) write( unit_num, *)'field_registered', this%field_registered
+ if( allocated(this%num_registered_fields)) write( unit_num, *)'num_registered_fields', this%num_registered_fields
+ if( allocated(this%axis_ids)) write( unit_num, *)'axis_ids', this%axis_ids(1:this%number_of_axis)
+
+end subroutine
+
!< @brief Opens the diag_file if it is time to do so
subroutine open_diag_file(this, time_step)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 8357a3669e..a51edc8683 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -17,7 +17,7 @@
!* License along with FMS. If not, see .
!***********************************************************************
module fms_diag_object_mod
-use mpp_mod, only: fatal, note, warning, mpp_error
+use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
&DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
@@ -84,6 +84,7 @@ module fms_diag_object_mod
public :: fms_get_diag_field_id_from_name
public :: fms_diag_object
public :: fmsDiagObject_type
+public :: dump_diag_obj
contains
@@ -554,4 +555,56 @@ function fms_get_axis_name_from_id (this, axis_id) &
#endif
end function fms_get_axis_name_from_id
+!> Dumps as much data as it can from the fmsDiagObject_type.
+!! Will dump any fields and files as well (see d)
+subroutine dump_diag_obj( filename )
+ character(len=*), intent(in), optional :: filename !< optional filename to print to,
+ !! otherwise prints to stdout
+#ifdef use_yaml
+ !type(fmsDiagObject_type) :: diag_obj
+ type(fmsDiagFile_type), pointer :: fileptr !< pointer for traversing file list
+ type(fmsDiagField_type), pointer :: fieldptr !< pointer for traversing field list
+ integer :: i !< do loops
+ integer :: unit_num !< unit num of opened log file or stdout
+
+ if( present(filename) ) then
+ open(newunit=unit_num, file=trim(filename), action='WRITE')
+ else
+ unit_num = stdout()
+ endif
+ if( mpp_pe() .eq. mpp_root_pe()) then
+ write(unit_num, *) '********** dumping diag object ***********'
+ write(unit_num, *) 'registered_variables:', fms_diag_object%registered_variables
+ write(unit_num, *) 'registered_axis:', fms_diag_object%registered_axis
+ write(unit_num, *) 'initialized:', fms_diag_object%initialized
+ write(unit_num, *) 'files_initialized:', fms_diag_object%files_initialized
+ write(unit_num, *) 'fields_initialized:', fms_diag_object%fields_initialized
+ write(unit_num, *) 'buffers_initialized:', fms_diag_object%buffers_initialized
+ write(unit_num, *) 'axes_initialized:', fms_diag_object%axes_initialized
+ write(unit_num, *) 'Files:'
+ if( fms_diag_object%files_initialized ) then
+ do i=1, SIZE(fms_diag_object%FMS_diag_files)
+ write(unit_num, *) 'File num:', i
+ fileptr => fms_diag_object%FMS_diag_files(i)%FMS_diag_file
+ call fileptr%dump_file_obj(unit_num)
+ enddo
+ else
+ write(unit_num, *) 'files not initialized'
+ endif
+ if( fms_diag_object%fields_initialized) then
+ do i=1, SIZE(fms_diag_object%FMS_diag_fields)
+ write(unit_num, *) 'Field num:', i
+ fieldptr => fms_diag_object%FMS_diag_fields(i)
+ call fieldptr%dump_field_obj(unit_num)
+ enddo
+ else
+ write(unit_num, *) 'fields not initialized'
+ endif
+ if( present(filename) ) close(unit_num)
+ endif
+#else
+ call mpp_error( FATAL, "You can not use the modern diag manager without compiling with -Duse_yaml")
+#endif
+end subroutine
+
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 771b266351..a4ab82c8e9 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -36,7 +36,7 @@ module fms_diag_yaml_mod
time_diurnal, time_power, time_none, r8, i8, r4, i4
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
-use mpp_mod, only: mpp_error, FATAL
+use mpp_mod, only: mpp_error, FATAL, mpp_pe, mpp_root_pe, stdout
use, intrinsic :: iso_c_binding, only : c_ptr, c_null_char
use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique
use platform_mod, only: r4_kind, i4_kind
@@ -50,6 +50,7 @@ module fms_diag_yaml_mod
public :: diagYamlObject_type, get_diag_yaml_obj
public :: diagYamlFiles_type, diagYamlFilesVar_type
public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_id
+public :: dump_diag_yaml_obj
!> @}
integer, parameter :: basedate_size = 6
@@ -1333,6 +1334,72 @@ function get_diag_files_id(indices) &
end do
end function get_diag_files_id
+
+!> Prints out values from diag_yaml object for debugging.
+!! Only writes on root.
+subroutine dump_diag_yaml_obj( filename )
+ character(len=*), optional, intent(in) :: filename !< optional name of logfile to write to, otherwise
+ !! prints to stdout
+ type(diagyamlfilesvar_type), allocatable :: fields(:)
+ type(diagyamlfiles_type), allocatable :: files(:)
+ integer :: i, unit_num
+ if( present(filename)) then
+ open(newunit=unit_num, file=trim(filename), action='WRITE')
+ else
+ unit_num = stdout()
+ endif
+ !! TODO write to log
+ if( mpp_pe() .eq. mpp_root_pe()) then
+ write(unit_num, *) '**********Dumping diag_yaml object**********'
+ if( diag_yaml%has_diag_title()) write(unit_num, *) 'Title:', diag_yaml%diag_title
+ if( diag_yaml%has_diag_basedate()) write(unit_num, *) 'basedate array:', diag_yaml%diag_basedate
+ write(unit_num, *) 'FILES'
+ allocate(fields(SIZE(diag_yaml%get_diag_fields())))
+ allocate(files(SIZE(diag_yaml%get_diag_files())))
+ files = diag_yaml%get_diag_files()
+ fields = diag_yaml%get_diag_fields()
+ do i=1, SIZE(files)
+ write(unit_num, *) 'File: ', files(i)%get_file_fname()
+ if(files(i)%has_file_frequnit()) write(unit_num, *) 'file_frequnit:', files(i)%get_file_frequnit()
+ if(files(i)%has_file_freq()) write(unit_num, *) 'freq:', files(i)%get_file_freq()
+ if(files(i)%has_file_timeunit()) write(unit_num, *) 'timeunit:', files(i)%get_file_timeunit()
+ if(files(i)%has_file_unlimdim()) write(unit_num, *) 'unlimdim:', files(i)%get_file_unlimdim()
+ !if(files(i)%has_file_sub_region()) write(unit_num, *) 'sub_region:', files(i)%get_file_sub_region()
+ if(files(i)%has_file_new_file_freq()) write(unit_num, *) 'new_file_freq:', files(i)%get_file_new_file_freq()
+ if(files(i)%has_file_new_file_freq_units()) write(unit_num, *) 'new_file_freq_units:', &
+ & files(i)%get_file_new_file_freq_units()
+ if(files(i)%has_file_start_time()) write(unit_num, *) 'start_time:', files(i)%get_file_start_time()
+ if(files(i)%has_file_duration()) write(unit_num, *) 'duration:', files(i)%get_file_duration()
+ if(files(i)%has_file_duration_units()) write(unit_num, *) 'duration_units:', files(i)%get_file_duration_units()
+ if(files(i)%has_file_varlist()) write(unit_num, *) 'varlist:', files(i)%get_file_varlist()
+ if(files(i)%has_file_global_meta()) write(unit_num, *) 'global_meta:', files(i)%get_file_global_meta()
+ if(files(i)%is_global_meta()) write(unit_num, *) 'global_meta:', files(i)%is_global_meta()
+ write(unit_num, *) ''
+ enddo
+ write(unit_num, *) 'FIELDS'
+ do i=1, SIZE(fields)
+ write(unit_num, *) 'Field: ', fields(i)%get_var_fname()
+ if(fields(i)%has_var_fname()) write(unit_num, *) 'fname:', fields(i)%get_var_fname()
+ if(fields(i)%has_var_varname()) write(unit_num, *) 'varname:', fields(i)%get_var_varname()
+ if(fields(i)%has_var_reduction()) write(unit_num, *) 'reduction:', fields(i)%get_var_reduction()
+ if(fields(i)%has_var_module()) write(unit_num, *) 'module:', fields(i)%get_var_module()
+ if(fields(i)%has_var_kind()) write(unit_num, *) 'kind:', fields(i)%get_var_kind()
+ if(fields(i)%has_var_outname()) write(unit_num, *) 'outname:', fields(i)%get_var_outname()
+ if(fields(i)%has_var_longname()) write(unit_num, *) 'longname:', fields(i)%get_var_longname()
+ if(fields(i)%has_var_units()) write(unit_num, *) 'units:', fields(i)%get_var_units()
+ if(fields(i)%has_var_zbounds()) write(unit_num, *) 'zbounds:', fields(i)%get_var_zbounds()
+ if(fields(i)%has_var_attributes()) write(unit_num, *) 'attributes:', fields(i)%get_var_attributes()
+ if(fields(i)%has_n_diurnal()) write(unit_num, *) 'n_diurnal:', fields(i)%get_n_diurnal()
+ if(fields(i)%has_pow_value()) write(unit_num, *) 'pow_value:', fields(i)%get_pow_value()
+ if(fields(i)%has_var_attributes()) write(unit_num, *) 'is_var_attributes:', fields(i)%is_var_attributes()
+ enddo
+ deallocate(files, fields)
+ if( present(filename)) then
+ close(unit_num)
+ endif
+ endif
+end subroutine
+
#endif
end module fms_diag_yaml_mod
!> @}
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index bd26afcb1e..00f0860e54 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -144,6 +144,10 @@ end subroutine compare_result_1d
endif
+!! test dump routines
+call dump_diag_yaml_obj('test_dump.log')
+call dump_diag_yaml_obj() ! to stdout
+
call diag_yaml_object_end
call fms_end()
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index d6c1fbc3d8..f75c99c9a5 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -31,6 +31,7 @@ program test_modern_diag
use fms_mod, only: fms_init, fms_end
use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast
use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time
+use fms_diag_object_mod,only: dump_diag_obj
implicit none
@@ -150,6 +151,11 @@ program test_modern_diag
call diag_field_add_attribute (id_var1, "real", 10.)
call diag_field_add_attribute (id_var2, '1d real', (/10./))
+!! test dump routines
+!! prints fields from objects for debugging to log if name is provided, othwerise goes to stdout
+call dump_diag_obj('diag_obj_dump.log')
+call dump_diag_obj()
+
call diag_manager_set_time_end(Time)
call diag_send_complete(Time)
call diag_manager_end(Time)
From 9a26ea891fda522865ac684bc657e0213503085d Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Fri, 7 Oct 2022 13:10:24 -0400
Subject: [PATCH 072/168] chore: modern diag ifdef cleanup (#1049)
---
diag_manager/diag_manager.F90 | 16 +-----
diag_manager/fms_diag_object.F90 | 98 ++++++++++++++++++++++----------
2 files changed, 68 insertions(+), 46 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 8249f3919a..4007a40aa4 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -237,9 +237,6 @@ MODULE diag_manager_mod
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end
-#ifdef use_yaml
- use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, get_num_unique_fields, find_diag_field
-#endif
use fms_diag_object_mod, only:fms_diag_object
USE constants_mod, ONLY: SECONDS_PER_DAY
@@ -3826,12 +3823,9 @@ SUBROUTINE diag_manager_end(time)
if (allocated(fileobjND)) deallocate(fileobjND)
if (allocated(fnum_for_domain)) deallocate(fnum_for_domain)
-#ifdef use_yaml
if (use_modern_diag) then
- call diag_yaml_object_end
call fms_diag_object%diag_end()
endif
-#endif
END SUBROUTINE diag_manager_end
!> @brief Replaces diag_manager_end; close just one file: files(file)
@@ -4042,17 +4036,9 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
END IF
END IF
-#ifdef use_yaml
if (use_modern_diag) then
- CALL diag_yaml_object_init(diag_subset_output)
- CALL fms_diag_object%init(diag_subset_output)
+ CALL fms_diag_object%init(diag_subset_output)
endif
-#else
- if (use_modern_diag) &
- call error_mesg("diag_manager_mod::diag_manager_init", &
- & "You need to compile with -Duse_yaml if diag_manager_nml::use_modern_diag=.true.", FATAL)
-#endif
-
if (.not. use_modern_diag) then
CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local)
IF ( mystat /= 0 ) THEN
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index a51edc8683..a213e57360 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -26,7 +26,8 @@ module fms_diag_object_mod
#ifdef use_yaml
use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init
use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init
-use fms_diag_yaml_mod, only: diag_yaml_object_init, find_diag_field, get_diag_files_id, diag_yaml
+use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, find_diag_field, &
+ & get_diag_files_id, diag_yaml
use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, &
&diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, &
&fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type
@@ -56,6 +57,7 @@ module fms_diag_object_mod
#endif
contains
procedure :: init => fms_diag_object_init
+ procedure :: diag_end => fms_diag_object_end
procedure :: fms_register_diag_field_scalar
procedure :: fms_register_diag_field_array
procedure :: fms_register_static_field
@@ -68,14 +70,13 @@ module fms_diag_object_mod
procedure :: fms_get_diag_field_id_from_name
procedure :: fms_get_axis_name_from_id
procedure :: fms_diag_send_complete
- procedure :: diag_end => fms_diag_object_end
#ifdef use_yaml
procedure :: get_diag_buffer
#endif
end type fmsDiagObject_type
type (fmsDiagObject_type), target :: fms_diag_object
-integer, private :: registered_variables !< Number of registered variables
+
public :: fms_register_diag_field_obj
public :: fms_register_diag_field_scalar
public :: fms_register_diag_field_array
@@ -84,6 +85,7 @@ module fms_diag_object_mod
public :: fms_get_diag_field_id_from_name
public :: fms_diag_object
public :: fmsDiagObject_type
+integer, private :: registered_variables !< Number of registered variables
public :: dump_diag_obj
contains
@@ -132,6 +134,9 @@ subroutine fms_diag_object_end (this)
deallocate(this%FMS_diag_buffers)
this%axes_initialized = fms_diag_axis_object_end(this%diag_axis)
this%initialized = .false.
+ call diag_yaml_object_end
+#else
+ call mpp_error(FATAL, "You can not call fms_diag_object%end without yaml")
#endif
end subroutine fms_diag_object_end
@@ -173,7 +178,11 @@ integer function fms_register_diag_field_obj &
integer, allocatable :: file_ids(:) !< The file IDs for this variable
integer :: i !< For do loops
integer, allocatable :: diag_field_indices(:) !< indices where the field was found in the yaml
-
+#endif
+#ifndef use_yaml
+fms_register_diag_field_obj = DIAG_FIELD_NOT_FOUND
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
diag_field_indices = find_diag_field(varname, modname)
if (diag_field_indices(1) .eq. diag_null) then
!< The field was not found in the table, so return diag_null
@@ -227,8 +236,6 @@ integer function fms_register_diag_field_obj &
nullify (fileptr)
nullify (fieldptr)
deallocate(diag_field_indices)
-#else
- fms_register_diag_field_obj = diag_null
#endif
end function fms_register_diag_field_obj
@@ -251,15 +258,15 @@ INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, in
INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
-
-#ifdef use_yaml
+#ifndef use_yaml
+fms_register_diag_field_scalar=diag_null
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
fms_register_diag_field_scalar = this%register(&
& module_name, field_name, init_time=init_time, &
& longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
& area=area, volume=volume, realm=realm)
-#else
-fms_register_diag_field_scalar = diag_not_registered
#endif
end function fms_register_diag_field_scalar
@@ -291,14 +298,15 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
-#ifdef use_yaml
+#ifndef use_yaml
+fms_register_diag_field_array=diag_null
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
fms_register_diag_field_array = this%register( &
& module_name, field_name, init_time=init_time, &
& axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
& interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
-#else
-fms_register_diag_field_array = diag_not_registered
#endif
end function fms_register_diag_field_array
@@ -332,15 +340,16 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes,
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
!! modeling_realm attribute
-#ifdef use_yaml
+#ifndef use_yaml
+fms_register_static_field=diag_null
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
! Include static as optional variable to register here
fms_register_static_field = this%register( &
& module_name, field_name, axes=axes, &
& longname=long_name, units=units, missing_value=missing_value, varrange=range, &
& standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm, &
& static=.true.)
-#else
-fms_register_static_field = diag_not_registered
#endif
end function fms_register_static_field
@@ -370,7 +379,10 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n
INTEGER, INTENT(in), OPTIONAL :: domain_position !< Domain position, "NORTH" or "EAST"
integer :: id
-#ifdef use_yaml
+#ifndef use_yaml
+id = diag_null
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
CHARACTER(len=:), ALLOCATABLE :: edges_name !< Name of the edges
this%registered_axis = this%registered_axis + 1
@@ -398,8 +410,6 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n
id = this%registered_axis
end select
-#else
- id = diag_null
#endif
end function fms_diag_axis_init
@@ -411,7 +421,9 @@ subroutine fms_diag_send_complete(this, time_step)
integer :: i !< For do loops
-#ifdef use_yaml
+#ifndef use_yaml
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience)
do i = 1, size(this%FMS_diag_files)
@@ -428,7 +440,9 @@ subroutine fms_diag_field_add_attribute(this, diag_field_id, att_name, att_value
integer, intent(in) :: diag_field_id !< Id of the axis to add the attribute to
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
-#ifdef use_yaml
+#ifndef use_yaml
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
!TODO: Value for diag not found
if ( diag_field_id .LE. 0 ) THEN
RETURN
@@ -446,7 +460,9 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value)
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
-#ifdef use_yaml
+#ifndef use_yaml
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
if (axis_id < 0 .and. axis_id > this%registered_axis) &
call mpp_error(FATAL, "diag_axis_add_attribute: The axis_id is not valid")
@@ -457,6 +473,7 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value)
#endif
end subroutine fms_diag_axis_add_attribute
+#ifdef use_yaml
!> \brief Gets the diag field ID from the module name and field name.
!> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered
PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, field_name) &
@@ -468,15 +485,29 @@ PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, fiel
integer :: i !< For looping
!> Initialize to not found
diag_field_id = DIAG_FIELD_NOT_FOUND
-#ifdef use_yaml
!> Loop through fields to find it.
if (fms_diag_object%registered_variables < 1) return
do i=1,fms_diag_object%registered_variables
diag_field_id = fms_diag_object%FMS_diag_fields(i)%id_from_name(module_name, field_name)
if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return
enddo
-#endif
END FUNCTION fms_get_diag_field_id_from_name
+#else
+!> \brief This replaces the pure function when not compiled with yaml so that an error can be called
+!> \returns Error
+FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, field_name) &
+ result(diag_field_id)
+ class(fmsDiagObject_type), intent (in) :: fms_diag_object !< The diag object
+ CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
+ CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
+ integer :: diag_field_id
+ integer :: i !< For looping
+!> Initialize to not found
+ diag_field_id = DIAG_FIELD_NOT_FOUND
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+END FUNCTION fms_get_diag_field_id_from_name
+#endif
+
#ifdef use_yaml
!> returns the buffer object for the given id
@@ -498,7 +529,10 @@ type(domain2d) FUNCTION fms_get_domain2d(this, ids)
class(fmsDiagObject_type), intent (in) :: this !< The diag object
INTEGER, DIMENSION(:), INTENT(in) :: ids !< Axis IDs.
-#ifdef use_yaml
+#ifndef use_yaml
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+fms_get_domain2d = null_domain2d
+#else
INTEGER :: type_of_domain !< The type of domain
CLASS(diagDomain_t), POINTER :: domain !< Diag Domain pointer
@@ -509,8 +543,6 @@ type(domain2d) FUNCTION fms_get_domain2d(this, ids)
type is (diagDomain2d_t)
fms_get_domain2d = domain%domain2
end select
-#else
- fms_get_domain2d = null_domain2d
#endif
END FUNCTION fms_get_domain2d
@@ -520,9 +552,12 @@ integer function fms_get_axis_length(this, axis_id)
class(fmsDiagObject_type), intent (in) :: this !< The diag object
INTEGER, INTENT(in) :: axis_id !< Axis ID of the axis to the length of
+#ifndef use_yaml
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+fms_get_axis_length = 0
+#else
fms_get_axis_length = 0
-#ifdef use_yaml
if (axis_id < 0 .and. axis_id > this%registered_axis) &
call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid")
@@ -542,7 +577,10 @@ function fms_get_axis_name_from_id (this, axis_id) &
character (len=:), allocatable :: axis_name
-#ifdef use_yaml
+#ifndef use_yaml
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+axis_name=" "
+#else
if (axis_id < 0 .and. axis_id > this%registered_axis) &
call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid")
@@ -550,8 +588,6 @@ function fms_get_axis_name_from_id (this, axis_id) &
type is (fmsDiagFullAxis_type)
axis_name = axis%get_axis_name()
end select
-#else
- axis_name = ""
#endif
end function fms_get_axis_name_from_id
From 36021b31cd7a98e6ba40be872037fabf31a79725 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Fri, 7 Oct 2022 13:13:11 -0400
Subject: [PATCH 073/168] test: add failure test for compiling without yaml +
skip empty tests (#1050)
---
configure.ac | 4 +-
test_fms/data_override/Makefile.am | 6 +-
test_fms/diag_manager/Makefile.am | 8 +-
test_fms/diag_manager/test_diag_manager2.sh | 121 +++++++++++---------
test_fms/diag_manager/test_modern_diag.F90 | 2 -
test_fms/parser/Makefile.am | 6 +-
6 files changed, 77 insertions(+), 70 deletions(-)
diff --git a/configure.ac b/configure.ac
index cd64493729..fd2076a528 100644
--- a/configure.ac
+++ b/configure.ac
@@ -191,9 +191,9 @@ if test $with_yaml = yes; then
#If the test pass, define use_yaml macro
AC_DEFINE([use_yaml], [1], [This is required to use yaml parser])
- AM_CONDITIONAL([SKIP_PARSER_TESTS], false )
+ AM_CONDITIONAL([USING_YAML], true)
else
- AM_CONDITIONAL([SKIP_PARSER_TESTS], true )
+ AM_CONDITIONAL([USING_YAML], false)
fi
# Require netCDF
diff --git a/test_fms/data_override/Makefile.am b/test_fms/data_override/Makefile.am
index a1267848af..69f09540fa 100644
--- a/test_fms/data_override/Makefile.am
+++ b/test_fms/data_override/Makefile.am
@@ -58,10 +58,10 @@ test_data_override_ongrid_r8_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r8_kind
test_get_grid_v1_r4_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r4_kind
test_get_grid_v1_r8_CPPFLAGS = $(AM_CPPFLAGS) -DDO_TEST_KIND_=r8_kind
-if SKIP_PARSER_TESTS
-skipflag="skip"
-else
+if USING_YAML
skipflag=""
+else
+skipflag="skip"
endif
TEST_EXTENSIONS = .sh
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 5f643ec0c6..4dfbd13602 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -52,12 +52,12 @@ TESTS = test_diag_manager2.sh
# Copy over other needed files to the srcdir
EXTRA_DIST = input.nml_base diagTables test_diag_manager2.sh check_crashes.sh
-if SKIP_PARSER_TESTS
-skipflag="skip"
-else
+if USING_YAML
skipflag=""
+else
+skipflag="skip"
endif
-TESTS_ENVIRONMENT = parser_skip=${skipflag}
+TESTS_ENVIRONMENT = skipflag=${skipflag}
CLEANFILES = input.nml *.nc *.out diag_table *-files/* *.dpi *.spi *.dyn *.spl
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 5b36157c90..6eefe73867 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -72,7 +72,7 @@ test_expect_success "Data array is too large in x and y direction (test $my_test
mpirun -n 1 ../test_diag_manager
'
-my_test_count=2
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_02
1 3 1 0 0 0
@@ -88,7 +88,7 @@ test_expect_success "Data array is too large in x direction (test $my_test_count
mpirun -n 1 ../test_diag_manager
'
-my_test_count=3
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_03
1 3 1 0 0 0
@@ -104,7 +104,7 @@ test_expect_success "Data array is too large in y direction (test $my_test_count
mpirun -n 1 ../test_diag_manager
'
-my_test_count=4
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_04
1 3 1 0 0 0
@@ -122,7 +122,7 @@ test_expect_success "Data array is too small in x and y direction, checks for 2
mpirun -n 1 ../test_diag_manager
'
-my_test_count=5
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_05
1 3 1 0 0 0
@@ -140,7 +140,7 @@ test_expect_success "Data array is too small in x directions, checks for 2 time
mpirun -n 1 ../test_diag_manager
'
-my_test_count=6
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_06
1 3 1 0 0 0
@@ -158,7 +158,7 @@ test_expect_success "Data array is too small in y direction, checks for 2 time s
mpirun -n 1 ../test_diag_manager
'
-my_test_count=7
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_07
1 3 1 0 0 0
@@ -174,7 +174,7 @@ test_expect_success "Data array is too large in x and y, with halos, 2 time step
mpirun -n 1 ../test_diag_manager
'
-my_test_count=8
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_08
1 3 1 0 0 0
@@ -192,7 +192,7 @@ test_expect_success "Data array is too small in x and y, with halos, 2 time step
mpirun -n 1 ../test_diag_manager
'
-my_test_count=9
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_09
1 3 1 0 0 0
@@ -208,7 +208,7 @@ test_expect_success "Data array is too small, 1D, static global data (test $my_t
mpirun -n 1 ../test_diag_manager
'
-my_test_count=10
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_10
1 3 1 0 0 0
@@ -224,7 +224,7 @@ test_expect_success "Data array is too large, 1D, static global data (test $my_t
mpirun -n 1 ../test_diag_manager
'
-my_test_count=11
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_11
1 3 1 0 0 0
@@ -240,7 +240,7 @@ test_expect_success "Missing je_in as an input (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager
'
-my_test_count=12
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_12
1 3 1 0 0 0
@@ -259,7 +259,7 @@ test_expect_success "Catch duplicate field in diag_table (test $my_test_count)"
mpirun -n 1 ../test_diag_manager
'
-my_test_count=13
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_13
1 3 1 0 0 0
@@ -279,7 +279,7 @@ test_expect_success "Output interval greater than runlength (test $my_test_count
mpirun -n 1 ../test_diag_manager
'
-my_test_count=14
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_14
1990 1 29 0 0 0
@@ -296,7 +296,7 @@ test_expect_success "Catch invalid date in register_diag_field call (test $my_te
mpirun -n 1 ../test_diag_manager
'
-my_test_count=15
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_15
1 3 1 0 0 0
@@ -313,7 +313,7 @@ test_expect_success "OpenMP thread test (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager
'
-my_test_count=16
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_16
1 3 1 0 0 0
@@ -330,7 +330,7 @@ test_expect_success "Filename appendix added (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager
'
-my_test_count=17
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_17
1 3 1 0 0 0
@@ -347,7 +347,7 @@ test_expect_success "Root-mean-square (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager
'
-my_test_count=18
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_18
1 3 1 0 0 0
@@ -367,7 +367,7 @@ test_expect_success "Added attributes, and cell_measures (test $my_test_count)"
mpirun -n 1 ../test_diag_manager
'
-my_test_count=19
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_19
1 3 1 0 0 0
@@ -386,7 +386,7 @@ test_expect_success "Area and Volume same field (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager
'
-my_test_count=20
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_20
1 3 1 0 0 0
@@ -405,7 +405,7 @@ test_expect_success "Get diag_field_id, ID found and not found (test $my_test_co
mpirun -n 1 ../test_diag_manager
'
-my_test_count=21
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_21
1 3 1 0 0 0
@@ -422,7 +422,7 @@ test_expect_success "Add axis attributes (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager
'
-my_test_count=22
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_22
1 3 1 0 0 0
@@ -439,7 +439,7 @@ test_expect_success "Get 'nv' axis id (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager
'
-my_test_count=23
+my_test_count=`expr $my_test_count + 1`
cat <<_EOF > diag_table
test_diag_manager_23
1990 1 1 0 0 0
@@ -458,7 +458,7 @@ setup_test
test_expect_success "Unstructured grid (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager
'
-my_test_count=24
+my_test_count=`expr $my_test_count + 1`
# test_diag_manager_time
cat <<_EOF > diag_table
test_diag_manager
@@ -498,11 +498,8 @@ test_diag_manager
"test_diag_manager_mod", "sst", "sst", "test_diurnal", "all", "diurnal3", "none", 2
"test_diag_manager_mod", "ice", "ice", "test_diurnal", "all", "diurnal3", "none", 2
_EOF
-<<<<<<< HEAD
-=======
-my_test_count=25
->>>>>>> 0088145b (Compiling dmUpdate post merge of 2022.03-beta1 (#979))
+my_test_count=`expr $my_test_count + 1`
test_expect_success "diurnal test (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager_time
'
@@ -512,7 +509,17 @@ test_expect_success "Test the diag update_buffer (test $my_test_count)" '
mpirun -n 1 ../test_diag_update_buffer
'
-cat <<_EOF > diag_table.yaml
+## uses some updated code but doesn't need flag
+my_test_count=`expr $my_test_count + 1`
+test_expect_success "test_diag_dlinked_list (test $my_test_count)" '
+ mpirun -n 1 ../test_diag_dlinked_list
+'
+
+## run tests that are ifdef'd out only if compiled with yaml
+## otherwise just run the updated end to end to check for error
+if [ -z "${skipflag}" ]; then
+
+ cat <<_EOF > diag_table.yaml
title: test_diag_manager
base_date: 2 1 1 0 0 0
diag_files:
@@ -588,17 +595,17 @@ diag_files:
unlimdim: records
write_file: false
_EOF
-cp diag_table.yaml diag_table.yaml_base
-
-my_test_count=26
-test_expect_success "diag_yaml test (test $my_test_count)" '
- mpirun -n 1 ../test_diag_yaml
-'
+ cp diag_table.yaml diag_table.yaml_base
-. $top_srcdir/test_fms/diag_manager/check_crashes.sh
+ my_test_count=`expr $my_test_count + 1`
+ test_expect_success "diag_yaml test (test $my_test_count)" '
+ mpirun -n 1 ../test_diag_yaml
+ '
+ . $top_srcdir/test_fms/diag_manager/check_crashes.sh
+ my_test_count = `expr $my_test_count + 14`
-printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml
-cat <<_EOF > diag_table.yaml
+ printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml
+ cat <<_EOF > diag_table.yaml
title: test_diag_manager
base_date: 2 1 1 0 0 0
diag_files:
@@ -643,18 +650,14 @@ diag_files:
kind: r4
_EOF
-my_test_count=41
-test_expect_success "Test the diag_ocean feature in diag_manager_init (test $my_test_count)" '
- mpirun -n 2 ../test_diag_ocean
-'
+ my_test_count=`expr $my_test_count + 1`
+ test_expect_success "Test the diag_ocean feature in diag_manager_init (test $my_test_count)" '
+ mpirun -n 2 ../test_diag_ocean
+ '
-my_test_count=42
-test_expect_success "test_diag_dlinked_list (test $my_test_count)" '
- mpirun -n 1 ../test_diag_dlinked_list
-'
-printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml
-cat <<_EOF > diag_table.yaml
+ printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml
+ cat <<_EOF > diag_table.yaml
title: test_diag_manager
base_date: 2 1 1 0 0 0
@@ -751,13 +754,19 @@ diag_files:
kind: r4
_EOF
-my_test_count=43
-test_expect_success "Test the modern diag manager end to end (test $my_test_count)" '
- mpirun -n 6 ../test_modern_diag
-'
-my_test_count=44
-test_expect_success "buffer functionality (test $my_test_count)" '
- mpirun -n 1 ../test_diag_buffer
-'
-
+ my_test_count=`expr $my_test_count + 1`
+ test_expect_success "buffer functionality (test $my_test_count)" '
+ mpirun -n 1 ../test_diag_buffer
+ '
+
+ my_test_count=`expr $my_test_count + 1`
+ test_expect_success "Test the modern diag manager end to end (test $my_test_count)" '
+ mpirun -n 6 ../test_modern_diag
+ '
+else
+ my_test_count=`expr $my_test_count + 1`
+ test_expect_failure "test modern diag manager failure when compiled without -Duse-yaml flag (test $my_test_count)" '
+ mpirun -n 6 ../test_modern_diag
+ '
+fi
test_done
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index f75c99c9a5..648867c8ec 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -20,7 +20,6 @@
!> @brief This programs tests the modern diag_manager
program test_modern_diag
-#ifdef use_yaml
use mpp_domains_mod, only: domain2d, mpp_domains_set_stack_size, mpp_define_domains, mpp_define_io_domain, &
mpp_define_mosaic, domainug, mpp_get_compute_domains, mpp_define_unstruct_domain, &
mpp_get_compute_domain, mpp_get_data_domain, mpp_get_UG_domain_grid_index, &
@@ -207,5 +206,4 @@ subroutine set_up_cube_sph_domain(Domain_cube_sph, nx, ny, io_layout)
global_indices, layout, pe_start, pe_end, &
io_layout, Domain_cube_sph)
end subroutine set_up_cube_sph_domain
-#endif
end program test_modern_diag
diff --git a/test_fms/parser/Makefile.am b/test_fms/parser/Makefile.am
index 05fbcd737c..ae8c282b99 100644
--- a/test_fms/parser/Makefile.am
+++ b/test_fms/parser/Makefile.am
@@ -49,10 +49,10 @@ TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
$(abs_top_srcdir)/test_fms/tap-driver.sh
-if SKIP_PARSER_TESTS
-skipflag="skip"
-else
+if USING_YAML
skipflag=""
+else
+skipflag="skip"
endif
TESTS_ENVIRONMENT = parser_skip=${skipflag}
From dd783354ae70ac5ec79b52477d62051c537c0ea2 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 8 Nov 2022 12:04:04 -0500
Subject: [PATCH 074/168] feat: modern diag subaxis setup (#1056)
---
diag_manager/Makefile.am | 6 +-
diag_manager/fms_diag_axis_object.F90 | 538 ++++++++++++++++++---
diag_manager/fms_diag_buffer.F90 | 1 -
diag_manager/fms_diag_field_object.F90 | 2 +
diag_manager/fms_diag_file_object.F90 | 153 ++++--
diag_manager/fms_diag_object.F90 | 19 +-
diag_manager/fms_diag_yaml.F90 | 14 +-
test_fms/diag_manager/test_modern_diag.F90 | 6 +-
8 files changed, 607 insertions(+), 132 deletions(-)
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 2d1fc1cf1c..91793c8f88 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -68,9 +68,11 @@ fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_objec
fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_buffer_mod.$(FC_MODEXT)
fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
-fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
+fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
+ fms_diag_axis_object_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
-fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
+fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
+ diag_grid_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) \
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 4a0a7added..899a937be4 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -28,15 +28,20 @@
!> @addtogroup fms_diag_axis_object_mod
!> @{
module fms_diag_axis_object_mod
+#ifdef use_yaml
use mpp_domains_mod, only: domain1d, domain2d, domainUG, mpp_get_compute_domain, CENTER, &
- & mpp_get_compute_domain, NORTH, EAST
+ & mpp_get_compute_domain, NORTH, EAST, mpp_get_tile_id, &
+ & mpp_get_ntile_count
use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind
use diag_data_mod, only: diag_atttype, max_axes, NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, &
direction_down, direction_up, fmsDiagAttribute_type, max_axis_attributes, &
- MAX_SUBAXES, DIAG_NULL
- use mpp_mod, only: FATAL, mpp_error, uppercase
+ MAX_SUBAXES, DIAG_NULL, index_gridtype, latlon_gridtype
+ use mpp_mod, only: FATAL, mpp_error, uppercase, mpp_pe, mpp_root_pe, stdout
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, &
& register_axis, register_field, register_variable_attribute, write_data
+ use fms_diag_yaml_mod, only: subRegion_type
+ use diag_grid_mod, only: get_local_indices_cubesphere => get_local_indexes
+ use axis_utils2_mod, only: nearest_index
implicit none
PRIVATE
@@ -44,6 +49,8 @@ module fms_diag_axis_object_mod
public :: fmsDiagAxis_type, fms_diag_axis_object_init, fms_diag_axis_object_end, &
& get_domain_and_domain_type, diagDomain_t, &
& DIAGDOMAIN2D_T, fmsDiagSubAxis_type, fmsDiagAxisContainer_type, fmsDiagFullAxis_type, DIAGDOMAINUG_T
+ public :: define_new_axis, define_subaxis
+
!> @}
!> @brief Type to hold the domain info for an axis
@@ -54,6 +61,7 @@ module fms_diag_axis_object_mod
contains
procedure :: set => set_axis_domain
procedure :: length => get_length
+ procedure :: get_ntiles
end type diagDomain_t
!> @brief Type to hold the 1d domain
@@ -81,21 +89,26 @@ module fms_diag_axis_object_mod
!> @ingroup diag_axis_object_mod
TYPE fmsDiagAxis_type
INTEGER , private :: axis_id !< ID of the axis
+
+ contains
+ procedure :: get_parent_axis_id
+ procedure :: get_subaxes_id
+ procedure :: write_axis_metadata
+ procedure :: write_axis_data
END TYPE fmsDiagAxis_type
!> @brief Type to hold the subaxis
!> @ingroup diag_axis_object_mod
TYPE, extends(fmsDiagAxis_type) :: fmsDiagSubAxis_type
- INTEGER , private :: subaxis_id !< ID of the subaxis
CHARACTER(len=:), ALLOCATABLE, private :: subaxis_name !< Name of the subaxis
INTEGER , private :: starting_index !< Starting index of the subaxis relative to the
!! parent axis
INTEGER , private :: ending_index !< Ending index of the subaxis relative to the
!! parent axis
- class(*) , ALLOCATABLE, private :: bounds !< Bounds of the subaxis (lat/lon or indices)
+ type(subRegion_type) , private :: subRegion !< Bounds of the subaxis (lat/lon or indices)
INTEGER , private :: parent_axis_id !< Id of the parent_axis
contains
- procedure :: exists => check_if_subaxis_exists
+ procedure :: fill_subaxis
END TYPE fmsDiagSubAxis_type
!> @brief Type to hold the diagnostic axis description.
@@ -108,7 +121,7 @@ module fms_diag_axis_object_mod
CLASS(*), ALLOCATABLE, private :: axis_data(:) !< Data of the axis
CHARACTER(len=:), ALLOCATABLE, private :: type_of_data !< The type of the axis_data ("float" or "double")
!< TO DO this can be a dlinked to avoid having limits
- type(fmsDiagSubAxis_type) , private :: subaxis(3) !< Array of subaxis
+ integer , private :: subaxis(MAX_SUBAXES) !< Array of subaxis
integer , private :: nsubaxis !< Number of subaxis
class(diagDomain_t),ALLOCATABLE, private :: axis_domain !< Domain
INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN", "TWO_D_DOMAIN",
@@ -132,9 +145,9 @@ module fms_diag_axis_object_mod
PROCEDURE :: axis_length => get_axis_length
PROCEDURE :: get_axis_name
PROCEDURE :: set_edges_name
- PROCEDURE :: set_subaxis
- PROCEDURE :: write_axis_metadata
- PROCEDURE :: write_axis_data
+ PROCEDURE :: set_axis_id
+ PROCEDURE :: get_compute_domain
+ PROCEDURE :: get_indices
! TO DO:
! Get/has/is subroutines as needed
@@ -244,23 +257,35 @@ subroutine add_axis_attribute(this, att_name, att_value)
end subroutine add_axis_attribute
!> @brief Write the axis meta data to an open fileobj
- subroutine write_axis_metadata(this, fileobj, sub_axis_id)
- class(fmsDiagFullAxis_type), target, INTENT(IN) :: this !< diag_axis obj
- class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
- integer, OPTIONAL, INTENT(IN) :: sub_axis_id !< ID of the sub_axis, if it exists
-
- character(len=:), ALLOCATABLE :: axis_edges_name !< Name of the edges, if it exist
- character(len=:), pointer :: axis_name !< Name of the axis
- integer :: axis_length !< Size of the axis
- integer :: i !< For do loops
+ subroutine write_axis_metadata(this, fileobj, parent_axis)
+ class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
+ class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis !< If the axis is a subaxis, axis object
+ !! for the parent axis (this will be used
+ !! to get some of the metadata info)
+
+ character(len=:), ALLOCATABLE :: axis_edges_name !< Name of the edges, if it exist
+ character(len=:), pointer :: axis_name !< Name of the axis
+ integer :: axis_length !< Size of the axis
+ integer :: i !< For do loops
+ type(fmsDiagFullAxis_type), pointer :: diag_axis !< Local pointer to the diag_axis
- if (present(sub_axis_id)) then
- axis_name => this%subaxis(sub_axis_id)%subaxis_name
- axis_length = this%subaxis(sub_axis_id)%ending_index - this%subaxis(sub_axis_id)%starting_index + 1
- else
+ select type(this)
+ type is (fmsDiagFullAxis_type)
axis_name => this%axis_name
axis_length = this%length
- endif
+ diag_axis => this
+ type is (fmsDiagSubAxis_type)
+ axis_name => this%subaxis_name
+ axis_length = this%ending_index - this%starting_index + 1
+ !< Get all the other information from the parent axis (i.e the cart_name, units, etc)
+ if (present(parent_axis)) then
+ select type(parent_axis)
+ type is (fmsDiagFullAxis_type)
+ diag_axis => parent_axis
+ end select
+ endif
+ end select
!< Add the axis as a dimension in the netcdf file based on the type of axis_domain and the fileobj type
select type (fileobj)
@@ -268,17 +293,17 @@ subroutine write_axis_metadata(this, fileobj, sub_axis_id)
!< Here the axis is not domain decomposed (i.e z_axis)
call register_axis(fileobj, axis_name, axis_length)
type is (FmsNetcdfDomainFile_t)
- select case (this%type_of_domain)
+ select case (diag_axis%type_of_domain)
case (NO_DOMAIN)
!< Here the fileobj is domain decomposed, but the axis is not
!! Domain decomposed fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
call register_axis(fileobj, axis_name, axis_length)
case (TWO_D_DOMAIN)
!< Here the axis is domain decomposed
- call register_axis(fileobj, axis_name, this%cart_name, domain_position=this%domain_position)
+ call register_axis(fileobj, axis_name, diag_axis%cart_name, domain_position=diag_axis%domain_position)
end select
type is (FmsNetcdfUnstructuredDomainFile_t)
- select case (this%type_of_domain)
+ select case (diag_axis%type_of_domain)
case (NO_DOMAIN)
!< Here the fileobj is in the unstructured domain, but the axis is not
!< Unstructured domain fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
@@ -290,54 +315,60 @@ subroutine write_axis_metadata(this, fileobj, sub_axis_id)
end select
!< Add the axis as a variable and write its metada
- call register_field(fileobj, axis_name, this%type_of_data, (/axis_name/))
- call register_variable_attribute(fileobj, axis_name, "longname", this%long_name, &
- str_len=len_trim(this%long_name))
+ call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
+ call register_variable_attribute(fileobj, axis_name, "longname", diag_axis%long_name, &
+ str_len=len_trim(diag_axis%long_name))
- if (this%cart_name .NE. "N") &
- call register_variable_attribute(fileobj, axis_name, "axis", this%cart_name, str_len=1)
+ if (diag_axis%cart_name .NE. "N") &
+ call register_variable_attribute(fileobj, axis_name, "axis", diag_axis%cart_name, str_len=1)
- if (trim(this%units) .NE. "none") &
- call register_variable_attribute(fileobj, axis_name, "units", this%units, str_len=len_trim(this%units))
+ if (trim(diag_axis%units) .NE. "none") &
+ call register_variable_attribute(fileobj, axis_name, "units", diag_axis%units, str_len=len_trim(diag_axis%units))
- select case (this%direction)
+ select case (diag_axis%direction)
case (direction_up)
call register_variable_attribute(fileobj, axis_name, "positive", "up", str_len=2)
case (direction_down)
call register_variable_attribute(fileobj, axis_name, "positive", "down", str_len=4)
end select
- if (allocated(this%edges_name)) then
- call register_variable_attribute(fileobj, axis_name, "edges", this%edges_name, &
- str_len=len_trim(this%edges_name))
+ if (allocated(diag_axis%edges_name)) then
+ call register_variable_attribute(fileobj, axis_name, "edges", diag_axis%edges_name, &
+ str_len=len_trim(diag_axis%edges_name))
endif
- if(allocated(this%attributes)) then
- do i = 1, size(this%attributes)
- call register_variable_attribute(fileobj, axis_name, this%attributes(i)%att_name, &
- & this%attributes(i)%att_value)
+ if(allocated(diag_axis%attributes)) then
+ do i = 1, diag_axis%num_attributes
+ call register_variable_attribute(fileobj, axis_name, diag_axis%attributes(i)%att_name, &
+ & diag_axis%attributes(i)%att_value)
enddo
endif
end subroutine write_axis_metadata
!> @brief Write the axis data to an open fileobj
- subroutine write_axis_data(this, fileobj, sub_axis_id)
- class(fmsDiagFullAxis_type),INTENT(IN):: this !< diag_axis obj
- class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
- integer, OPTIONAL, INTENT(IN) :: sub_axis_id !< ID of the sub_axis, if it exists
+ subroutine write_axis_data(this, fileobj, parent_axis)
+ class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
+ class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis
integer :: i !< Starting index of a sub_axis
integer :: j !< Ending index of a sub_axis
- if (present(sub_axis_id)) then
- i = this%subaxis(sub_axis_id)%starting_index
- j = this%subaxis(sub_axis_id)%ending_index
-
- call write_data(fileobj, this%subaxis(sub_axis_id)%subaxis_name, this%axis_data(i:j))
- else
+ select type(this)
+ type is (fmsDiagFullAxis_type)
call write_data(fileobj, this%axis_name, this%axis_data)
- endif
+ type is (fmsDiagSubAxis_type)
+ i = this%starting_index
+ j = this%ending_index
+
+ if (present(parent_axis)) then
+ select type(parent_axis)
+ type is (fmsDiagFullAxis_type)
+ call write_data(fileobj, this%subaxis_name, parent_axis%axis_data(i:j))
+ end select
+ endif
+ end select
end subroutine write_axis_data
!> @brief Get the length of the axis
@@ -366,6 +397,15 @@ pure function get_axis_name(this) &
axis_name = this%axis_name
end function
+ !> @brief Set the axis_id
+ subroutine set_axis_id(this, axis_id)
+ class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj
+ integer, intent(in) :: axis_id !< Axis_id
+
+ this%axis_id = axis_id
+
+ end subroutine set_axis_id
+
!> @brief Set the name of the edges
subroutine set_edges_name(this, edges_name)
class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj
@@ -374,39 +414,140 @@ subroutine set_edges_name(this, edges_name)
this%edges_name = edges_name
end subroutine
- !> @brief Set the subaxis of the axis obj
- !> @return A sub_axis id corresponding to the indices of the sub_axes in the sub_axes_objs array
- function set_subaxis(this, bounds) &
- result(sub_axes_id)
- class(fmsDiagFullAxis_type), INTENT(INOUT) :: this !< diag_axis obj
- class(*), INTENT(INOUT) :: bounds(:) !< bound of the subaxis
+ !> @brief Determine if the subRegion is in the current PE.
+ !! If it is, determine the starting and ending indices of the current PE that belong to the subRegion
+ subroutine get_indices(this, compute_idx, corners_indices, starting_index, ending_index, need_to_define_axis)
+ class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj
+ integer, intent(in) :: compute_idx(:) !< Current PE's compute domain
+ class(*), intent(in) :: corners_indices(:) !< The indices of the corners of the subRegion
+ integer, intent(out) :: starting_index !< Starting index of the subRegion
+ !! for the current PE
+ integer, intent(out) :: ending_index !< Ending index of the subRegion
+ !! for the current PE
+ logical, intent(out) :: need_to_define_axis !< .true. if it is needed to define
+ !! an axis
+
+ integer :: subregion_start !< Starting index of the subRegion
+ integer :: subregion_end !< Ending index of the subRegion
+
+ !< Get the rectangular coordinates of the subRegion
+ !! If the subRegion is not rectangular, the points outside of the subRegion will be masked
+ !! out later
+ select type (corners_indices)
+ type is (integer(kind=i4_kind))
+ subregion_start = minval(corners_indices)
+ subregion_end = maxval(corners_indices)
+ end select
- integer :: sub_axes_id
+ !< Initiliaze the output
+ need_to_define_axis = .false.
+ starting_index = diag_null
+ ending_index = diag_null
+
+ !< If the compute domain of the current PE is outisde of the range of sub_axis, return
+ if (compute_idx(1) > subregion_start .and. compute_idx(2) > subregion_start) return
+ if (compute_idx(1) > subregion_end .and. compute_idx(2) > subregion_end) return
+
+ need_to_define_axis = .true.
+ if (compute_idx(1) >= subregion_start .and. compute_idx(2) >= subregion_end) then
+ !< In this case all the point of the current PE are inside the range of the sub_axis
+ starting_index = compute_idx(1)
+ ending_index = compute_idx(2)
+ else if (compute_idx(1) >= subregion_start .and. compute_idx(2) <= subregion_end) then
+ !< In this case all the points of the current PE are valid up to the end point
+ starting_index = compute_idx(1)
+ ending_index = subregion_end
+ else if (compute_idx(1) <= subregion_start .and. compute_idx(2) <= subregion_end) then
+ !< In this case all the points of the current PE are valid starting with t subregion_start
+ starting_index = subregion_start
+ ending_index = compute_idx(2)
+ else if (compute_idx(1) <= subregion_start .and. compute_idx(2) >= subregion_end) then
+ !< In this case only the points in the current PE ar valid
+ starting_index = subregion_start
+ ending_index = subregion_end
+ endif
- integer :: i !< For do loops
+ end subroutine get_indices
+
+ !< Get the compute domain of the axis
+ subroutine get_compute_domain(this, compute_idx, need_to_define_axis, tile_number)
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
+ integer, intent(inout) :: compute_idx(:) !< Compute domain of the axis
+ logical, intent(out) :: need_to_define_axis !< .true. if it needed to define the axis
+ integer, optional, intent(in) :: tile_number !< The tile number of the axis
+
+ !< Initialize the output
+ need_to_define_axis = .false.
+ compute_idx = diag_null
+
+ if (.not. allocated(this%axis_domain)) then
+ !< If the axis is not domain decomposed, use the whole axis as the compute domain
+ if (this%cart_name .eq. "X" .or. this%cart_name .eq. "Y") then
+ compute_idx(1) = 1
+ compute_idx(2) = size(this%axis_data)
+ need_to_define_axis = .true.
+ endif
+ return
+ endif
- !< Check if the subaxis for this bouds already exists
- do i = 1, this%nsubaxis
- if (this%subaxis(i)%exists(bounds)) return
- enddo
+ select type(domain => this%axis_domain)
+ type is (diagDomain2d_t)
+ if (present(tile_number)) then
+ !< If the the tile number is present and the current PE is not on the tile, then there is no need
+ !! to define the axis
+ if (any(mpp_get_tile_id(domain%Domain2) .ne. tile_number)) then
+ need_to_define_axis = .false.
+ return
+ endif
+ endif
+
+ !< Get the compute domain for the current PE if it is an "X" or "Y" axis
+ select case (this%cart_name)
+ case ("X")
+ call mpp_get_compute_domain(domain%Domain2, xbegin=compute_idx(1), xend=compute_idx(2), &
+ & position=this%domain_position)
+ need_to_define_axis = .true.
+ case ("Y")
+ call mpp_get_compute_domain(domain%Domain2, ybegin=compute_idx(1), yend=compute_idx(2), &
+ & position=this%domain_position)
+ need_to_define_axis = .true.
+ end select
+ end select
- !< TO DO: everything
- this%nsubaxis = this%nsubaxis + 1
- sub_axes_id = -999
- end function
+ end subroutine get_compute_domain
!!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!!
- !> @brief Check if a subaxis was already defined
- !> @return Flag indicating if a subaxis is already defined
- pure function check_if_subaxis_exists(this, bounds) &
- result(exists)
- class(fmsDiagSubAxis_type), INTENT(IN) :: this !< diag_axis obj
- class(*), INTENT(IN) :: bounds(:) !< bounds of the subaxis
- logical :: exists
-
- !< TO DO: compare bounds
- exists = .false.
- end function check_if_subaxis_exists
+ !> @brief Fills in the information needed to define a subaxis
+ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, subRegion)
+ class(fmsDiagSubAxis_type), INTENT(INOUT) :: this !< diag_sub_axis obj
+ integer , intent(in) :: starting_index !< Starting index of the subRegion for the PE
+ integer , intent(in) :: ending_index !< Ending index of the subRegion for the PE
+ integer , intent(in) :: axis_id !< Axis id to assign to the subaxis
+ integer , intent(in) :: parent_id !< The id of the parent axis, the subaxis belongs to
+ type(subRegion_type) , intent(in) :: subRegion !< SubRegion definition as it is defined in the yaml
+ character(len=*) , intent(in) :: parent_axis_name !< Name of the parent_axis
+
+ this%axis_id = axis_id
+ this%starting_index = starting_index
+ this%ending_index = ending_index
+ this%parent_axis_id = parent_id
+ this%subRegion = subRegion
+ this%subaxis_name = trim(parent_axis_name)//"_sub01"
+ end subroutine fill_subaxis
+
+ !> @brief Get the ntiles in a domain
+ !> @return the number of tiles in a domain
+ function get_ntiles(this) &
+ result (ntiles)
+ class(diagDomain_t), INTENT(IN) :: this !< diag_axis obj
+
+ integer :: ntiles
+
+ select type (this)
+ type is (diagDomain2d_t)
+ ntiles = mpp_get_ntile_count(this%domain2)
+ end select
+ end function get_ntiles
!> @brief Get the length of a 2D domain
!> @return Length of the 2D domain
@@ -543,6 +684,243 @@ subroutine get_domain_and_domain_type(diag_axis, axis_id, domain_type, domain, v
enddo
end subroutine get_domain_and_domain_type
+ !> @brief Define a subaxis based on the subRegion defined by the yaml
+ subroutine define_subaxis (diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe)
+ class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
+ integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
+ integer, intent(inout) :: naxis !< Number of axis registered
+ type(subRegion_type), intent(in) :: subRegion !< The subRegion definition from
+ !! the yaml
+ logical, intent(in) :: is_cube_sphere !< .true. if this is a cubesphere
+ logical, intent(out) :: write_on_this_pe !< .true. if the subregion
+ !! is on this PE
+
+ select case(subRegion%grid_type)
+ case (latlon_gridtype)
+ call define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe)
+ case (index_gridtype)
+ call define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_this_pe)
+ end select
+ end subroutine define_subaxis
+
+ !> @brief Fill in the subaxis object for a subRegion defined by index
+ subroutine define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_this_pe)
+ class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
+ integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
+ integer, intent(inout) :: naxis !< Number of axis registered
+ type(subRegion_type), intent(in) :: subRegion !< SubRegion definition from the yaml
+ logical, intent(out) :: write_on_this_pe !< .true. if the subregion
+ !! is on this PE
+ integer :: i !< For do loops
+ integer :: compute_idx(2)
+ integer :: starting_index, ending_index
+ logical :: need_to_define_axis
+ integer :: lat_indices(2), lon_indices(2)
+
+
+ do i = 1, size(axis_ids)
+ select type (parent_axis => diag_axis(axis_ids(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ !< Get the PEs compute domain
+ call parent_axis%get_compute_domain(compute_idx, need_to_define_axis, tile_number=subRegion%tile)
+
+ !< If this is not a "X" or "Y" axis, go to the next axis
+ if (.not. need_to_define_axis) then
+ cycle
+ endif
+
+ !< Determine if the PE's compute domain is inside the subRegion
+ !! If it is get the starting and ending indices for that PE
+ call parent_axis%get_indices(compute_idx, subRegion%corners(:,i), starting_index, ending_index, &
+ need_to_define_axis)
+
+ !< If the PE's compute is not inside the subRegion, define a null subaxis and go to the next axis
+ if (.not. need_to_define_axis) then
+ call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
+ subRegion, diag_null, diag_null)
+ cycle
+ endif
+
+ !< If it made it to this point, the current PE is in the subRegion!
+ write_on_this_pe = .true.
+
+ call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
+ subRegion, starting_index, ending_index)
+ end select
+ enddo
+
+ end subroutine define_subaxis_index
+
+ !> @brief Fill in the subaxis object for a subRegion defined by lat lon
+ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe)
+ class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
+ integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
+ integer, intent(inout) :: naxis !< Number of axis registered
+ type(subRegion_type), intent(in) :: subRegion !< SubRegion definition from the yaml
+ logical, intent(in) :: is_cube_sphere !< .true. if this is a cubesphere
+ logical, intent(out) :: write_on_this_pe !< .true. if the subregion
+ !! is on this PE
+
+ real :: lat(2) !< Starting and ending lattiude of the subRegion
+ real :: lon(2) !< Starting and ending longitude or the subRegion
+ integer :: lat_indices(2) !< Starting and ending latitude indices of the subRegion
+ integer :: lon_indices(2) !< Starting and ending longitude indices of the subRegion
+ integer :: compute_idx(2) !< Compute domain of the current axis
+ integer :: starting_index !< Starting index of the subRegion for the current PE
+ integer :: ending_index !< Ending index of the subRegion for the current PE
+ logical :: need_to_define_axis !< .true. if it is needed to define the subaxis
+ integer :: i !< For do loops
+
+ !< Get the rectangular coordinates of the subRegion
+ !! If the subRegion is not rectangular, the points outside of the subRegion will be masked
+ !! out later
+ select type (corners => subRegion%corners)
+ type is (real(kind=r4_kind))
+ lon(1) = minval(corners(:,1))
+ lon(2) = maxval(corners(:,1))
+ lat(1) = minval(corners(:,2))
+ lat(2) = maxval(corners(:,2))
+ end select
+
+ if_is_cube_sphere: if (is_cube_sphere) then
+ !< Get the starting and ending indices of the subregion in the cubesphere relative to the global domain
+ call get_local_indices_cubesphere(lat(1), lat(2), lon(1), lon(2),&
+ & lon_indices(1), lon_indices(2), lat_indices(1), lat_indices(2))
+ loop_over_axis_ids: do i = 1, size(axis_ids)
+ select_axis_type: select type (parent_axis => diag_axis(axis_ids(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ !< Get the PEs compute domain
+ call parent_axis%get_compute_domain(compute_idx, need_to_define_axis)
+
+ !< If this is not a "X" or "Y" axis go to the next axis
+ if (.not. need_to_define_axis) cycle
+
+ !< Determine if the PE's compute domain is inside the subRegion
+ !! If it is get the starting and ending indices for that PE
+ if (parent_axis%cart_name .eq. "X") then
+ call parent_axis%get_indices(compute_idx, lon_indices, starting_index, ending_index, &
+ need_to_define_axis)
+ else if (parent_axis%cart_name .eq. "Y") then
+ call parent_axis%get_indices(compute_idx, lat_indices, starting_index, ending_index, &
+ need_to_define_axis)
+ endif
+
+ !< If the PE's compute is not inside the subRegion move to the next axis
+ if (.not. need_to_define_axis) cycle
+
+ !< If it made it to this point, the current PE is in the subRegion!
+ write_on_this_pe = .true.
+
+ call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
+ subRegion, starting_index, ending_index)
+ end select select_axis_type
+ enddo loop_over_axis_ids
+ else if_is_cube_sphere
+ loop_over_axis_ids2: do i = 1, size(axis_ids)
+ select type (parent_axis => diag_axis(axis_ids(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ !< Get the PEs compute domain
+ call parent_axis%get_compute_domain(compute_idx, need_to_define_axis)
+
+ !< If this is not a "X" or "Y" axis go to the next axis
+ if (.not. need_to_define_axis) cycle
+
+ !< Get the starting and ending indices of the subregion relative to the global grid
+ if (parent_axis%cart_name .eq. "X") then
+ select type(adata=>parent_axis%axis_data)
+ type is (real)
+ lon_indices(1) = nearest_index(lon(1), adata)
+ lon_indices(2) = nearest_index(lon(2), adata) + 1
+ end select
+ call parent_axis%get_indices(compute_idx, lon_indices, starting_index, ending_index, &
+ need_to_define_axis)
+ else if (parent_axis%cart_name .eq. "Y") then
+ select type(adata=>parent_axis%axis_data)
+ type is (real)
+ lat_indices(1) = nearest_index(lat(1), adata)
+ lat_indices(2) = nearest_index(lat(2), adata) + 1
+ end select
+ call parent_axis%get_indices(compute_idx, lat_indices, starting_index, ending_index, &
+ need_to_define_axis)
+ endif
+
+ !< If the PE's compute is not inside the subRegion move to the next axis
+ if (.not. need_to_define_axis) cycle
+
+ !< If it made it to this point, the current PE is in the subRegion!
+ write_on_this_pe = .true.
+
+ call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
+ subRegion, starting_index, ending_index)
+ end select
+ enddo loop_over_axis_ids2
+ endif if_is_cube_sphere
+ end subroutine define_subaxis_latlon
+
+ !< Creates a new subaxis and fills it will all the information it needs
+ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, subRegion, &
+ starting_index, ending_index)
+
+ class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
+ class(fmsDiagFullAxis_type), intent(inout) :: parent_axis !< The parent axis
+ integer, intent(inout) :: naxis !< The number of axis that
+ !! have been defined
+ integer, intent(in) :: parent_id !< Id of the parent axis
+ type(subRegion_type), intent(in) :: subRegion !< SubRegion definition from the yaml
+ integer, intent(in) :: starting_index !< PE's Starting index
+ integer, intent(in) :: ending_index !< PE's Ending index
+
+ naxis = naxis + 1 !< This is the axis id of the new axis!
+
+ !< Add the axis_id of the new subaxis to the parent axis
+ parent_axis%nsubaxis = parent_axis%nsubaxis + 1
+ parent_axis%subaxis(parent_axis%nsubaxis) = naxis
+
+ !< Allocate the new axis as a subaxis and fill it
+ allocate(fmsDiagSubAxis_type :: diag_axis(naxis)%axis)
+ diag_axis(naxis)%axis%axis_id = naxis
+
+ select type (sub_axis => diag_axis(naxis)%axis)
+ type is (fmsDiagSubAxis_type)
+ call sub_axis%fill_subaxis(starting_index, ending_index, naxis, parent_id, &
+ parent_axis%axis_name, subRegion)
+ end select
+ end subroutine define_new_axis
+
+ !< @brief Determine the parent_axis_id of a subaxis
+ !! @return parent_axis_id if it is a subaxis and diag_null if is not a subaxis
+ pure function get_parent_axis_id(this) &
+ result(parent_axis_id)
+
+ class(fmsDiagAxis_type), intent(in) :: this !< Axis Object
+ integer :: parent_axis_id
+
+ select type (this)
+ type is (fmsDiagFullAxis_type)
+ parent_axis_id = diag_null
+ type is (fmsDiagSubAxis_type)
+ parent_axis_id = this%parent_axis_id
+ end select
+
+ end function
+
+ !< @brief Determine the most recent subaxis id in a diag_axis object
+ !! @return the most recent subaxis id in a diag_axis object
+ pure function get_subaxes_id(this) &
+ result(sub_axis_id)
+
+ class(fmsDiagAxis_type), intent(in) :: this !< Axis Object
+ integer :: sub_axis_id
+
+ sub_axis_id = this%axis_id
+ select type (this)
+ type is (fmsDiagFullAxis_type)
+ if (this%cart_name .ne. "Z") sub_axis_id = this%subaxis(this%nsubaxis)
+ end select
+
+ end function
+
+#endif
end module fms_diag_axis_object_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/fms_diag_buffer.F90 b/diag_manager/fms_diag_buffer.F90
index 7c22f1c7ad..4d6c91783b 100644
--- a/diag_manager/fms_diag_buffer.F90
+++ b/diag_manager/fms_diag_buffer.F90
@@ -27,7 +27,6 @@ module fms_diag_buffer_mod
use platform_mod
use iso_c_binding
-use fms_diag_axis_object_mod, only: diagDomain_t
use time_manager_mod, only: time_type
use mpp_mod, only: mpp_error, FATAL
use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 5130b98737..bf5b244d04 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -330,6 +330,8 @@ subroutine set_diag_id(this , id)
if (allocated(this%registered)) then
if (this%registered) then
call mpp_error("set_diag_id", "The variable"//this%varname//" is already registered", FATAL)
+ else
+ this%diag_id = id
endif
else
this%diag_id = id
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 45b2beeadd..074353e585 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -29,13 +29,15 @@ module fms_diag_file_object_mod
get_instance_filename, open_file, close_file, get_mosaic_tile_file
use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED, &
TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ
-use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date
+use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date, &
+ date_to_string
use fms_diag_time_utils_mod, only: diag_time_inc, get_time_string
-use time_manager_mod, only: time_type, operator(/=), operator(==), date_to_string
-use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type
+use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type, subRegion_type
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
- fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T
+ fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T, &
+ fmsDiagFullAxis_type, define_subaxis
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout
+
implicit none
private
@@ -95,8 +97,7 @@ module fms_diag_file_object_mod
procedure, public :: get_file_freq
procedure, public :: get_file_timeunit
procedure, public :: get_file_unlimdim
-!! TODO get functions for sub region stuff
-! procedure, public :: get_file_sub_region
+ procedure, public :: get_file_sub_region
procedure, public :: get_file_new_file_freq
procedure, public :: get_file_new_file_freq_units
procedure, public :: get_file_start_time
@@ -123,6 +124,7 @@ module fms_diag_file_object_mod
type, extends (fmsDiagFile_type) :: subRegionalFile_type
integer, dimension(:), allocatable :: sub_axis_ids !< Array of axis ids in the file
logical :: write_on_this_pe !< Flag indicating if the subregion is on the current PE
+ logical :: is_subaxis_defined !< Flag indicating if the subaxes have already been defined
end type subRegionalFile_type
!> \brief A container for fmsDiagFile_type. This is used to create the array of files
@@ -131,6 +133,8 @@ module fms_diag_file_object_mod
contains
procedure :: open_diag_file
+ procedure :: write_axis_metadata
+ procedure :: write_axis_data
end type fmsDiagFileContainer_type
!type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_file !< The array of diag files
@@ -158,7 +162,9 @@ logical function fms_diag_files_object_init (files_array)
type is (subRegionalFile_type)
allocate(obj%sub_axis_ids(max_axes))
obj%sub_axis_ids = diag_null
- obj%write_on_this_pe = .true. !TODO this should be .false. probably
+ obj%write_on_this_pe = .false.
+ obj%is_subaxis_defined = .false.
+ obj%number_of_axis = 0
end select
else
allocate(FmsDiagFile_type::files_array(i)%FMS_diag_file)
@@ -326,14 +332,13 @@ pure function get_file_unlimdim (this) result(res)
res = this%diag_yaml_file%get_file_unlimdim()
end function get_file_unlimdim
-!! TODO - get functions for sub region stuff
!> \brief Returns a copy of file_sub_region from the yaml object
!! \return Copy of file_sub_region
-!pure function get_file_sub_region (obj) result(res)
-! class(fmsDiagFile_type), intent(in) :: obj !< The file object
-! integer :: res
-! res = obj%diag_yaml_file%get_file_sub_region()
-!end function get_file_sub_region
+function get_file_sub_region (obj) result(res)
+ class(fmsDiagFile_type), intent(in) :: obj !< The file object
+ type(subRegion_type) :: res
+ res = obj%diag_yaml_file%get_file_sub_region()
+end function get_file_sub_region
!> \brief Returns a copy of file_new_file_freq from the yaml object
!! \return Copy of file_new_file_freq
@@ -537,27 +542,51 @@ subroutine set_file_domain(this, domain, type_of_domain)
end subroutine set_file_domain
!> @brief Loops through a variable's axis_ids and adds them to the FMSDiagFile object if they don't exist
-subroutine add_axes(this, axis_ids)
- class(fmsDiagFile_type), intent(inout) :: this !< The file object
- integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
+subroutine add_axes(this, axis_ids, diag_axis, naxis)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
+ class(fmsDiagAxisContainer_type), intent(inout) :: diag_axis(:) !< Diag_axis object
+ integer, intent(inout) :: naxis !< Number of axis that have been registered
integer :: i, j !< For do loops
+ logical :: is_cube_sphere !< Flag indicating if the file's domain is a cubesphere
- do i = 1, size(axis_ids)
- do j = 1, this%number_of_axis
- !> Check if the axis already exists, return
- if (axis_ids(i) .eq. this%axis_ids(j)) return
- enddo
-
- !> If the axis does not exist add it to the list
- this%number_of_axis = this%number_of_axis + 1
- this%axis_ids(this%number_of_axis) = axis_ids(i)
+ is_cube_sphere = .false.
- !> If this is a sub_regional file, set up the sub_axes
- !> TO DO:
- !!
- enddo
+ select type(this)
+ type is (subRegionalFile_type)
+ if (.not. this%is_subaxis_defined) then
+ if (associated(this%domain)) then
+ if (this%domain%get_ntiles() .eq. 6) is_cube_sphere = .true.
+ endif
+ call define_subaxis(diag_axis, axis_ids, naxis, this%get_file_sub_region(), &
+ is_cube_sphere, this%write_on_this_pe)
+ this%is_subaxis_defined = .true.
+
+ !> add the axis to the list of axis in the file
+ if (this%write_on_this_pe) then
+ do i = 1, size(axis_ids)
+ this%number_of_axis = this%number_of_axis + 1 !< This is the current number of axis in the file
+ this%axis_ids(this%number_of_axis) = diag_axis(axis_ids(i))%axis%get_subaxes_id()
+ enddo
+ else
+ this%axis_ids = diag_null
+ endif
+ endif
+ return
+ type is (fmsDiagFile_type)
+ do i = 1, size(axis_ids)
+ do j = 1, this%number_of_axis
+ !> Check if the axis already exists, return
+ if (axis_ids(i) .eq. this%axis_ids(j)) return
+ enddo
+
+ !> If the axis does not exist add it to the list
+ this%number_of_axis = this%number_of_axis + 1
+ this%axis_ids(this%number_of_axis) = axis_ids(i)
+ enddo
+ end select
end subroutine add_axes
!> @brief adds the start time to the fileobj
@@ -592,7 +621,7 @@ subroutine add_start_time(this, start_time)
subroutine dump_file_obj(this, unit_num)
class(fmsDiagFile_type), intent(in) :: this !< the file object
integer, intent(in) :: unit_num !< passed in from dump_diag_obj
- !! will either be for new log file or stdout
+ !! will either be for new log file or stdout
write( unit_num, *) 'file id:', this%id
write( unit_num, *) 'start time:', date_to_string(this%start_time)
write( unit_num, *) 'last_output', date_to_string(this%last_output)
@@ -613,9 +642,11 @@ subroutine dump_file_obj(this, unit_num)
end subroutine
!< @brief Opens the diag_file if it is time to do so
-subroutine open_diag_file(this, time_step)
+subroutine open_diag_file(this, time_step, file_is_opened)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
TYPE(time_type), intent(in) :: time_step !< Current model step time
+ logical, intent(out) :: file_is_opened !< .true. if the file was opened in this
+ !! time
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
class(diagDomain_t), pointer :: domain !< The domain used in the file
@@ -642,6 +673,7 @@ subroutine open_diag_file(this, time_step)
diag_file => this%FMS_diag_file
domain => diag_file%domain
+ file_is_opened = .false.
!< Go away if it is not time to open the file
if (diag_file%next_open > time_step) return
@@ -751,9 +783,64 @@ subroutine open_diag_file(this, time_step)
diag_file%next_open = diag_time_inc(diag_file%next_open, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
endif
-!TODO: closing the file here for now, just to see if it works
- call close_file(diag_file%fileobj)
+ file_is_opened = .true.
+ domain => null()
+ diag_file => null()
end subroutine open_diag_file
+!< @brief Writes the axis metadata for the file
+subroutine write_axis_metadata(this, diag_axis)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
+
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
+ class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ integer :: i !< For do loops
+ integer :: j !< diag_file%axis_ids(i) (for less typing)
+ integer :: parent_axis_id !< Id of the parent_axis
+
+ diag_file => this%FMS_diag_file
+ fileobj => diag_file%fileobj
+
+ do i = 1, diag_file%number_of_axis
+ j = diag_file%axis_ids(i)
+ parent_axis_id = diag_axis(j)%axis%get_parent_axis_id()
+ if (parent_axis_id .eq. DIAG_NULL) then
+ call diag_axis(j)%axis%write_axis_metadata(fileobj)
+ else
+ call diag_axis(j)%axis%write_axis_metadata(fileobj, diag_axis(parent_axis_id)%axis)
+ endif
+ enddo
+
+end subroutine write_axis_metadata
+
+!< @brief Writes the axis data for the file
+subroutine write_axis_data(this, diag_axis)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
+
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
+ class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ integer :: i !< For do loops
+ integer :: j !< diag_file%axis_ids(i) (for less typing)
+ integer :: parent_axis_id !< Id of the parent_axis
+
+ diag_file => this%FMS_diag_file
+ fileobj => diag_file%fileobj
+
+ do i = 1, diag_file%number_of_axis
+ j = diag_file%axis_ids(i)
+ parent_axis_id = diag_axis(j)%axis%get_parent_axis_id()
+ if (parent_axis_id .eq. DIAG_NULL) then
+ call diag_axis(j)%axis%write_axis_data(fileobj)
+ else
+ call diag_axis(j)%axis%write_axis_data(fileobj, diag_axis(parent_axis_id)%axis)
+ endif
+ enddo
+
+ !TODO: closing the file here for now, just to see if it works
+ call close_file(fileobj)
+end subroutine write_axis_data
+
#endif
end module fms_diag_file_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index a213e57360..28cbd9f549 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -211,7 +211,7 @@ integer function fms_register_diag_field_obj &
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
- call fileptr%add_axes(axes)
+ call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
call fileptr%add_start_time(init_time)
enddo
elseif (present(axes)) then !only axes present
@@ -219,7 +219,7 @@ integer function fms_register_diag_field_obj &
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
- call fileptr%add_axes(axes)
+ call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
enddo
elseif (present(init_time)) then !only inti time present
do i = 1, size(file_ids)
@@ -409,6 +409,7 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n
& req=req, tile_count=tile_count, domain_position=domain_position)
id = this%registered_axis
+ call axis%set_axis_id(id)
end select
#endif
end function fms_diag_axis_init
@@ -426,9 +427,16 @@ subroutine fms_diag_send_complete(this, time_step)
#else
class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience)
+ logical :: file_is_opened_this_time_step !< True if the file was opened in this time_step
+ !! If true the metadata will need to be written
+
do i = 1, size(this%FMS_diag_files)
diag_file => this%FMS_diag_files(i)
- call diag_file%open_diag_file(time_step)
+ call diag_file%open_diag_file(time_step, file_is_opened_this_time_step)
+ if (file_is_opened_this_time_step) then
+ call diag_file%write_axis_metadata(this%diag_axis)
+ call diag_file%write_axis_data(this%diag_axis)
+ endif
enddo
#endif
@@ -619,7 +627,7 @@ subroutine dump_diag_obj( filename )
write(unit_num, *) 'axes_initialized:', fms_diag_object%axes_initialized
write(unit_num, *) 'Files:'
if( fms_diag_object%files_initialized ) then
- do i=1, SIZE(fms_diag_object%FMS_diag_files)
+ do i=1, SIZE(fms_diag_object%FMS_diag_files)
write(unit_num, *) 'File num:', i
fileptr => fms_diag_object%FMS_diag_files(i)%FMS_diag_file
call fileptr%dump_file_obj(unit_num)
@@ -628,7 +636,7 @@ subroutine dump_diag_obj( filename )
write(unit_num, *) 'files not initialized'
endif
if( fms_diag_object%fields_initialized) then
- do i=1, SIZE(fms_diag_object%FMS_diag_fields)
+ do i=1, SIZE(fms_diag_object%FMS_diag_fields)
write(unit_num, *) 'Field num:', i
fieldptr => fms_diag_object%FMS_diag_fields(i)
call fieldptr%dump_field_obj(unit_num)
@@ -642,5 +650,4 @@ subroutine dump_diag_obj( filename )
call mpp_error( FATAL, "You can not use the modern diag manager without compiling with -Duse_yaml")
#endif
end subroutine
-
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index a4ab82c8e9..b3137d38b6 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -47,7 +47,7 @@ module fms_diag_yaml_mod
public :: diag_yaml
public :: diag_yaml_object_init, diag_yaml_object_end
-public :: diagYamlObject_type, get_diag_yaml_obj
+public :: diagYamlObject_type, get_diag_yaml_obj, subRegion_type
public :: diagYamlFiles_type, diagYamlFilesVar_type
public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_id
public :: dump_diag_yaml_obj
@@ -1337,20 +1337,20 @@ end function get_diag_files_id
!> Prints out values from diag_yaml object for debugging.
!! Only writes on root.
-subroutine dump_diag_yaml_obj( filename )
+subroutine dump_diag_yaml_obj( filename )
character(len=*), optional, intent(in) :: filename !< optional name of logfile to write to, otherwise
!! prints to stdout
type(diagyamlfilesvar_type), allocatable :: fields(:)
type(diagyamlfiles_type), allocatable :: files(:)
integer :: i, unit_num
if( present(filename)) then
- open(newunit=unit_num, file=trim(filename), action='WRITE')
+ open(newunit=unit_num, file=trim(filename), action='WRITE')
else
- unit_num = stdout()
+ unit_num = stdout()
endif
!! TODO write to log
if( mpp_pe() .eq. mpp_root_pe()) then
- write(unit_num, *) '**********Dumping diag_yaml object**********'
+ write(unit_num, *) '**********Dumping diag_yaml object**********'
if( diag_yaml%has_diag_title()) write(unit_num, *) 'Title:', diag_yaml%diag_title
if( diag_yaml%has_diag_basedate()) write(unit_num, *) 'basedate array:', diag_yaml%diag_basedate
write(unit_num, *) 'FILES'
@@ -1359,7 +1359,7 @@ subroutine dump_diag_yaml_obj( filename )
files = diag_yaml%get_diag_files()
fields = diag_yaml%get_diag_fields()
do i=1, SIZE(files)
- write(unit_num, *) 'File: ', files(i)%get_file_fname()
+ write(unit_num, *) 'File: ', files(i)%get_file_fname()
if(files(i)%has_file_frequnit()) write(unit_num, *) 'file_frequnit:', files(i)%get_file_frequnit()
if(files(i)%has_file_freq()) write(unit_num, *) 'freq:', files(i)%get_file_freq()
if(files(i)%has_file_timeunit()) write(unit_num, *) 'timeunit:', files(i)%get_file_timeunit()
@@ -1378,7 +1378,7 @@ subroutine dump_diag_yaml_obj( filename )
enddo
write(unit_num, *) 'FIELDS'
do i=1, SIZE(fields)
- write(unit_num, *) 'Field: ', fields(i)%get_var_fname()
+ write(unit_num, *) 'Field: ', fields(i)%get_var_fname()
if(fields(i)%has_var_fname()) write(unit_num, *) 'fname:', fields(i)%get_var_fname()
if(fields(i)%has_var_varname()) write(unit_num, *) 'varname:', fields(i)%get_var_varname()
if(fields(i)%has_var_reduction()) write(unit_num, *) 'reduction:', fields(i)%get_var_reduction()
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index 648867c8ec..0e2a57da77 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -109,7 +109,7 @@ program test_modern_diag
set_name="land", DomainU=land_domain, aux="geolon_t geolat_t")
id_z = diag_axis_init('z', z, 'point_Z', 'z', long_name='point_Z')
-call diag_axis_add_attribute (id_z, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)')
+!TODO call diag_axis_add_attribute (id_z, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)')
call diag_axis_add_attribute (id_z, 'integer', 10)
call diag_axis_add_attribute (id_z, '1d integer', (/10, 10/))
call diag_axis_add_attribute (id_z, 'real', 10.)
@@ -146,9 +146,9 @@ program test_modern_diag
call diag_field_add_attribute (id_var1, "some string", "this is a string")
call diag_field_add_attribute (id_var1, "integer", 10)
-call diag_field_add_attribute (id_var1, "1d integer", (/10, 10/))
+call diag_field_add_attribute (id_var1, "1d_integer", (/10, 10/))
call diag_field_add_attribute (id_var1, "real", 10.)
-call diag_field_add_attribute (id_var2, '1d real', (/10./))
+call diag_field_add_attribute (id_var2, '1d_real', (/10./))
!! test dump routines
!! prints fields from objects for debugging to log if name is provided, othwerise goes to stdout
From c2bd92fb5b789aa7bbf714068b8370aba92621a6 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 22 Nov 2022 15:40:44 -0500
Subject: [PATCH 075/168] feat: modern diag add time axis io (#1068)
---
diag_manager/diag_util.F90 | 49 +----
diag_manager/fms_diag_axis_object.F90 | 55 ++++--
diag_manager/fms_diag_file_object.F90 | 207 ++++++++++++++++++--
diag_manager/fms_diag_object.F90 | 25 ++-
diag_manager/fms_diag_time_utils.F90 | 37 +++-
test_fms/diag_manager/test_diag_manager2.sh | 14 +-
test_fms/diag_manager/test_modern_diag.F90 | 8 +-
7 files changed, 316 insertions(+), 79 deletions(-)
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index c4e807d0b0..1386014ddb 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -59,7 +59,7 @@ MODULE diag_util_mod
& write_field_meta_data, done_meta_data, diag_flush
USE diag_output_mod, ONLY: diag_field_write, diag_write_time ! @brief Return the difference between two times in units.
- !! @return Real get_data_dif
- REAL FUNCTION get_date_dif(t2, t1, units)
- TYPE(time_type), INTENT(in) :: t2 !< Most recent time.
- TYPE(time_type), INTENT(in) :: t1 !< Most distant time.
- INTEGER, INTENT(in) :: units !< Unit of return value.
-
- 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
-
!> @brief Write data out to file, and if necessary flush the buffers.
SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time)
INTEGER, INTENT(in) :: file !< File ID.
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 899a937be4..a2030e91ee 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -30,8 +30,8 @@
module fms_diag_axis_object_mod
#ifdef use_yaml
use mpp_domains_mod, only: domain1d, domain2d, domainUG, mpp_get_compute_domain, CENTER, &
- & mpp_get_compute_domain, NORTH, EAST, mpp_get_tile_id, &
- & mpp_get_ntile_count
+ & mpp_get_global_domain, NORTH, EAST, mpp_get_tile_id, &
+ & mpp_get_ntile_count, mpp_get_io_domain
use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind
use diag_data_mod, only: diag_atttype, max_axes, NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, &
direction_down, direction_up, fmsDiagAttribute_type, max_axis_attributes, &
@@ -148,7 +148,7 @@ module fms_diag_axis_object_mod
PROCEDURE :: set_axis_id
PROCEDURE :: get_compute_domain
PROCEDURE :: get_indices
-
+ PROCEDURE :: get_global_io_domain
! TO DO:
! Get/has/is subroutines as needed
END TYPE fmsDiagFullAxis_type
@@ -339,8 +339,13 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
if(allocated(diag_axis%attributes)) then
do i = 1, diag_axis%num_attributes
- call register_variable_attribute(fileobj, axis_name, diag_axis%attributes(i)%att_name, &
- & diag_axis%attributes(i)%att_value)
+ select type (att_value => diag_axis%attributes(i)%att_value)
+ type is (character(len=*))
+ call register_variable_attribute(fileobj, axis_name, diag_axis%attributes(i)%att_name, trim(att_value(1)), &
+ str_len=len_trim(att_value(1)))
+ class default
+ call register_variable_attribute(fileobj, axis_name, diag_axis%attributes(i)%att_name, att_value)
+ end select
enddo
endif
@@ -348,16 +353,17 @@ end subroutine write_axis_metadata
!> @brief Write the axis data to an open fileobj
subroutine write_axis_data(this, fileobj, parent_axis)
- class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj
- class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
- class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis
-
- integer :: i !< Starting index of a sub_axis
- integer :: j !< Ending index of a sub_axis
+ class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
+ class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis !< The parent axis if this is a subaxis
+ integer :: i !< Starting index of a sub_axis
+ integer :: j !< Ending index of a sub_axis
+ integer :: global_io_index(2)!< Global io domain starting and ending index
select type(this)
type is (fmsDiagFullAxis_type)
- call write_data(fileobj, this%axis_name, this%axis_data)
+ call this%get_global_io_domain(global_io_index)
+ call write_data(fileobj, this%axis_name, this%axis_data(global_io_index(1):global_io_index(2)))
type is (fmsDiagSubAxis_type)
i = this%starting_index
j = this%ending_index
@@ -371,6 +377,31 @@ subroutine write_axis_data(this, fileobj, parent_axis)
end select
end subroutine write_axis_data
+ !> @brief Get the starting and ending indices of the global io domain of the axis
+ subroutine get_global_io_domain(this, global_io_index)
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
+ integer, intent(out) :: global_io_index(2) !< Global io domain starting and ending index
+
+ type(domain2d), pointer :: io_domain !< pointer to the io domain
+
+ global_io_index(1) = 1
+ global_io_index(2) = this%length
+
+ if (allocated(this%axis_domain)) then
+ select type(domain => this%axis_domain)
+ type is (diagDomain2d_t)
+ io_domain => mpp_get_io_domain(domain%domain2)
+ if (this%cart_name .eq. "X") then
+ call mpp_get_global_domain(io_domain, xbegin=global_io_index(1), xend=global_io_index(2), &
+ position=this%domain_position)
+ elseif (this%cart_name .eq. "Y") then
+ call mpp_get_global_domain(io_domain, ybegin=global_io_index(1), yend=global_io_index(2), &
+ position=this%domain_position)
+ endif
+ end select
+ endif
+ end subroutine get_global_io_domain
+
!> @brief Get the length of the axis
!> @return axis length
function get_axis_length(this) &
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 074353e585..ce926170ed 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -26,17 +26,22 @@
module fms_diag_file_object_mod
#ifdef use_yaml
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t, &
- get_instance_filename, open_file, close_file, get_mosaic_tile_file
+ get_instance_filename, open_file, close_file, get_mosaic_tile_file, unlimited, &
+ register_axis, register_field, register_variable_attribute, write_data
use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED, &
- TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ
-use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date, &
- date_to_string
-use fms_diag_time_utils_mod, only: diag_time_inc, get_time_string
-use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type, subRegion_type
+ TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ, &
+ get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute, &
+ get_base_second, time_unit_list, time_average, time_rms, time_max, time_min, time_sum, &
+ time_diurnal, time_power, time_none
+use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date, get_calendar_type, &
+ VALID_CALENDAR_TYPES, operator(>=), date_to_string
+use fms_diag_time_utils_mod, only: diag_time_inc, get_time_string, get_date_dif
+use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type, subRegion_type, diagYamlFilesVar_type
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T, &
fmsDiagFullAxis_type, define_subaxis
-use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout
+use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, &
+ uppercase, lowercase
implicit none
private
@@ -75,6 +80,9 @@ module fms_diag_file_object_mod
integer, dimension(:), allocatable :: axis_ids !< Array of axis ids in the file
integer, dimension(:), allocatable :: buffer_ids !< array of buffer ids associated with the file
integer :: number_of_axis !< Number of axis in the file
+ logical :: time_ops !< .True. if file contains variables that are time_min, time_max, time_average or time_sum
+ integer :: unlimited_dimension !< The unlimited dimension currently being written
+ logical :: is_static !< .True. if the frequency is -1
contains
procedure, public :: add_field_id
@@ -85,6 +93,7 @@ module fms_diag_file_object_mod
procedure, public :: set_file_domain
procedure, public :: add_axes
procedure, public :: add_start_time
+ procedure, public :: set_file_time_ops
procedure, public :: has_field_ids
procedure, public :: get_id
! TODO procedure, public :: get_fileobj ! TODO
@@ -133,8 +142,15 @@ module fms_diag_file_object_mod
contains
procedure :: open_diag_file
+ procedure :: write_time_metadata
procedure :: write_axis_metadata
procedure :: write_axis_data
+ procedure :: writing_on_this_pe
+ procedure :: is_time_to_write
+ procedure :: write_time_data
+ procedure :: update_next_write
+ procedure :: increase_unlimited_dimension
+ procedure :: close_diag_file
end type fmsDiagFileContainer_type
!type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_file !< The array of diag files
@@ -194,6 +210,9 @@ logical function fms_diag_files_object_init (files_array)
obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit())
obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
obj%next_open = get_base_time()
+ obj%time_ops = .false.
+ obj%unlimited_dimension = 0
+ obj%is_static = obj%get_file_freq() .eq. -1
nullify(obj)
enddo set_ids_loop
@@ -219,6 +238,27 @@ subroutine add_field_id (this, new_field_id)
endif
end subroutine add_field_id
+!> \brief Set the time_ops variable in the diag_file object
+subroutine set_file_time_ops(this, VarYaml, is_static)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ type (diagYamlFilesVar_type), intent(in) :: VarYaml !< The variable's yaml file
+ logical, intent(in) :: is_static !< Flag indicating if variable is static
+
+ if (this%time_ops) then
+ if (is_static) return
+ if (VarYaml%get_var_reduction() .eq. time_none) then
+ call mpp_error(FATAL, "The file: "//this%get_file_fname()//&
+ " has variables that are time averaged and instantaneous")
+ endif
+ else
+ select case (VarYaml%get_var_reduction())
+ case (time_average, time_rms, time_max, time_min, time_sum, time_diurnal, time_power)
+ this%time_ops = .true.
+ end select
+ endif
+
+end subroutine set_file_time_ops
+
!> \brief Logical function to determine if the variable file_metadata_from_model has been allocated or associated
!! \return .True. if file_metadata_from_model exists .False. if file_metadata_from_model has not been set
pure logical function has_file_metadata_from_model (this)
@@ -682,12 +722,8 @@ subroutine open_diag_file(this, time_step, file_is_opened)
if (.not. allocated(diag_file%fileobj)) then
select type (diag_file)
type is (subRegionalFile_type)
- !< Go away if the subregion is not on current PE
- if (.not. diag_file%write_on_this_pe) return
-
!< In this case each PE is going to write its own file
allocate(FmsNetcdfFile_t :: diag_file%fileobj)
-
is_regional = .true.
type is (fmsDiagFile_type)
!< Use the type_of_domain to get the correct fileobj
@@ -702,7 +738,7 @@ subroutine open_diag_file(this, time_step, file_is_opened)
end select
else
!< In this case, we are opening a new file so close the current the file
- call close_file(diag_file%fileobj)
+ call this%close_diag_file()
endif
!< Figure out what to name of the file
@@ -788,6 +824,134 @@ subroutine open_diag_file(this, time_step, file_is_opened)
diag_file => null()
end subroutine open_diag_file
+!> \brief Write the time metadata to the diag file
+subroutine write_time_metadata(this)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
+ class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ character(len=50) :: time_units_str !< Time units written as a string
+ character(len=50) :: calendar !< The calendar name
+
+ character(len=:), allocatable :: time_var_name !< The name of the time variable as it is defined in the yaml
+
+ diag_file => this%FMS_diag_file
+ fileobj => diag_file%fileobj
+
+ time_var_name = diag_file%get_file_unlimdim()
+ call register_axis(fileobj, time_var_name, unlimited)
+
+ WRITE(time_units_str, 11) &
+ TRIM(time_unit_list(diag_file%get_file_timeunit())), get_base_year(),&
+ & get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_base_second()
+11 FORMAT(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
+
+ !TODO harcodded "double"
+ call register_field(fileobj, time_var_name, "double", (/time_var_name/))
+ call register_variable_attribute(fileobj, time_var_name, "units", trim(time_units_str), &
+ str_len=len_trim(time_units_str))
+
+ call register_variable_attribute(fileobj, time_var_name, "axis", "T", str_len=1 )
+ call register_variable_attribute(fileobj, time_var_name, "long_name", trim(time_var_name), &
+ str_len=len_trim(time_var_name) )
+
+ !TODO no need to have both attributes, probably?
+ calendar = valid_calendar_types(get_calendar_type())
+ call register_variable_attribute(fileobj, time_var_name, "calendar_type", &
+ uppercase(trim(calendar)), str_len=len_trim(calendar))
+ call register_variable_attribute(fileobj, time_var_name, "calendar", &
+ lowercase(trim(calendar)), str_len=len_trim(calendar))
+
+ if (diag_file%time_ops) call register_variable_attribute(fileobj, time_var_name, "bounds", &
+ trim(time_var_name)//"_bounds", str_len=len_trim(time_var_name//"_bounds"))
+
+end subroutine write_time_metadata
+
+!> \brief Determine if it is time to "write" to the file
+logical function is_time_to_write(this, time_step)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
+ TYPE(time_type), intent(in) :: time_step !< Current model step time
+
+ if (time_step >= this%FMS_diag_file%next_output) then
+ is_time_to_write = .true.
+ if (this%FMS_diag_file%is_static) return
+ if (time_step >= this%FMS_diag_file%next_next_output) &
+ call mpp_error(FATAL, this%FMS_diag_file%get_file_fname()//&
+ &": Diag_manager_mod:: You skipped a time_step. Be sure that diag_send_complete is called at every time step "&
+ &" needed by the file.")
+ else
+ is_time_to_write = .false.
+ endif
+end function is_time_to_write
+
+!> \brief Determine if the current PE has data to write
+logical function writing_on_this_pe(this)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
+
+ select type(diag_file => this%FMS_diag_file)
+ type is (subRegionalFile_type)
+ writing_on_this_pe = diag_file%write_on_this_pe
+ class default
+ writing_on_this_pe = .true.
+ end select
+
+end function
+
+!> \brief Write out the time data to the file
+subroutine write_time_data(this, time_step)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
+ TYPE(time_type), intent(in) :: time_step !< Current model step time
+
+ real :: dif !< The time as a real number
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
+ class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+
+ diag_file => this%FMS_diag_file
+ fileobj => diag_file%fileobj
+
+ !> dif is the time as a real that is evaluated
+ dif = get_date_dif(time_step, get_base_time(), diag_file%get_file_timeunit())
+ select type (fileobj)
+ type is (FmsNetcdfDomainFile_t)
+ call write_data(fileobj, diag_file%get_file_unlimdim(), dif, &
+ unlim_dim_level=diag_file%unlimited_dimension)
+ type is (FmsNetcdfUnstructuredDomainFile_t)
+ call write_data(fileobj, diag_file%get_file_unlimdim(), dif, &
+ unlim_dim_level=diag_file%unlimited_dimension)
+ type is (FmsNetcdfFile_t)
+ call write_data(fileobj, diag_file%get_file_unlimdim(), dif, &
+ unlim_dim_level=diag_file%unlimited_dimension)
+ end select
+
+end subroutine write_time_data
+
+!> \brief Set up the next_output and next_next_output variable in a file obj
+subroutine update_next_write(this, time_step)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
+ TYPE(time_type), intent(in) :: time_step !< Current model step time
+
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
+
+ diag_file => this%FMS_diag_file
+ if (diag_file%is_static) then
+ diag_file%next_output = diag_time_inc(diag_file%next_output, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ diag_file%next_next_output = diag_time_inc(diag_file%next_output, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ else
+ diag_file%next_output = diag_time_inc(diag_file%next_output, diag_file%get_file_freq(), &
+ diag_file%get_file_frequnit())
+ diag_file%next_next_output = diag_time_inc(diag_file%next_output, diag_file%get_file_freq(), &
+ diag_file%get_file_frequnit())
+ endif
+
+end subroutine update_next_write
+
+!> \brief Increase the unlimited dimension variable that the file is currently being written to
+subroutine increase_unlimited_dimension(this)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+
+ this%FMS_diag_file%unlimited_dimension = this%FMS_diag_file%unlimited_dimension + 1
+end subroutine increase_unlimited_dimension
+
!< @brief Writes the axis metadata for the file
subroutine write_axis_metadata(this, diag_axis)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
@@ -838,9 +1002,24 @@ subroutine write_axis_data(this, diag_axis)
endif
enddo
- !TODO: closing the file here for now, just to see if it works
- call close_file(fileobj)
end subroutine write_axis_data
+!< @brief Closes the diag_file
+subroutine close_diag_file(this)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+
+ !< The select types are needed here because otherwise the code will go to the
+ !! wrong close_file routine and things will not close propertly
+ select type( fileobj => this%FMS_diag_file%fileobj)
+ type is (FmsNetcdfDomainFile_t)
+ call close_file(fileobj)
+ type is (FmsNetcdfFile_t)
+ call close_file(fileobj)
+ type is (FmsNetcdfUnstructuredDomainFile_t)
+ call close_file(fileobj)
+ end select
+
+end subroutine close_diag_file
+
#endif
end module fms_diag_file_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 28cbd9f549..3811cfcc0e 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -124,7 +124,14 @@ subroutine fms_diag_object_end (this)
integer :: i
#ifdef use_yaml
!TODO: loop through files and force write
- !TODO: Close all files
+ if (.not. this%initialized) return
+
+ do i = 1, size(this%FMS_diag_files)
+ !< Go away if the file is a subregional file and the current PE does not have any data for it
+ if (.not. this%FMS_diag_files(i)%writing_on_this_pe()) cycle
+
+ call this%FMS_diag_files(i)%close_diag_file()
+ enddo
!TODO: Deallocate diag object arrays and clean up all memory
do i=1, size(this%FMS_diag_buffers)
if(allocated(this%FMS_diag_buffers(i)%diag_buffer_obj)) then
@@ -213,6 +220,7 @@ integer function fms_register_diag_field_obj &
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
call fileptr%add_start_time(init_time)
+ call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
elseif (present(axes)) then !only axes present
do i = 1, size(file_ids)
@@ -220,17 +228,20 @@ integer function fms_register_diag_field_obj &
call fileptr%add_field_id(fieldptr%get_id())
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
+ call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
elseif (present(init_time)) then !only inti time present
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
call fileptr%add_start_time(init_time)
+ call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
else !no axis or init time present
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_id(fieldptr%get_id())
+ call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
endif
nullify (fileptr)
@@ -432,11 +443,23 @@ subroutine fms_diag_send_complete(this, time_step)
do i = 1, size(this%FMS_diag_files)
diag_file => this%FMS_diag_files(i)
+
+ !< Go away if the file is a subregional file and the current PE does not have any data for it
+ if (.not. diag_file%writing_on_this_pe()) cycle
+
call diag_file%open_diag_file(time_step, file_is_opened_this_time_step)
if (file_is_opened_this_time_step) then
+ call diag_file%write_time_metadata()
call diag_file%write_axis_metadata(this%diag_axis)
call diag_file%write_axis_data(this%diag_axis)
endif
+
+ if (diag_file%is_time_to_write(time_step)) then
+ call diag_file%increase_unlimited_dimension()
+ call diag_file%write_time_data(time_step)
+ !TODO call diag_file%add_variable_data()
+ call diag_file%update_next_write(time_step)
+ endif
enddo
#endif
diff --git a/diag_manager/fms_diag_time_utils.F90 b/diag_manager/fms_diag_time_utils.F90
index c595c74617..779f3d5fa4 100644
--- a/diag_manager/fms_diag_time_utils.F90
+++ b/diag_manager/fms_diag_time_utils.F90
@@ -27,17 +27,19 @@
module fms_diag_time_utils_mod
use time_manager_mod, only: time_type, increment_date, increment_time, get_calendar_type, NO_CALENDAR, leap_year, &
- get_date, get_time
+ get_date, get_time, operator(>), operator(<), operator(-)
use diag_data_mod, only: END_OF_RUN, EVERY_TIME, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, &
DIAG_YEARS
USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE
use fms_mod, only: fms_error_handler
+use mpp_mod, only: mpp_error, FATAL
implicit none
private
public :: diag_time_inc
public :: get_time_string
+public :: get_date_dif
contains
@@ -252,4 +254,37 @@ CHARACTER(len=128) FUNCTION get_time_string(filename, current_time)
get_time_string = TRIM(yr)//TRIM(mo)//TRIM(dy)//TRIM(hr)//TRIM(mi)//TRIM(sc)
END FUNCTION get_time_string
+ !> @brief Return the difference between two times in units.
+ !! @return Real get_data_dif
+ REAL FUNCTION get_date_dif(t2, t1, units)
+ TYPE(time_type), INTENT(in) :: t2 !< Most recent time.
+ TYPE(time_type), INTENT(in) :: t1 !< Most distant time.
+ INTEGER, INTENT(in) :: units !< Unit of return value.
+
+ INTEGER :: dif_seconds, dif_days
+ TYPE(time_type) :: dif_time
+
+ IF ( t2 < t1 ) CALL mpp_error(FATAL, 'diag_util_mod::get_date_dif '//&
+ &'in variable t2 is less than in variable t1')
+
+ 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
+ CALL mpp_error(FATAL, 'diag_util_mod::get_date_dif months not supported as output units')
+ ELSE IF ( units == DIAG_YEARS ) THEN
+ CALL mpp_error(FATAL, 'diag_util_mod::get_date_dif years not supported as output units')
+ ELSE
+ CALL mpp_error(FATAL, 'diag_util_mod::diag_date_dif illegal time units')
+ END IF
+ END FUNCTION get_date_dif
end module fms_diag_time_utils_mod
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 6eefe73867..aaed7f1dd8 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -516,7 +516,7 @@ test_expect_success "test_diag_dlinked_list (test $my_test_count)" '
'
## run tests that are ifdef'd out only if compiled with yaml
-## otherwise just run the updated end to end to check for error
+## otherwise just run the updated end to end to check for error
if [ -z "${skipflag}" ]; then
cat <<_EOF > diag_table.yaml
@@ -602,7 +602,7 @@ _EOF
mpirun -n 1 ../test_diag_yaml
'
. $top_srcdir/test_fms/diag_manager/check_crashes.sh
- my_test_count = `expr $my_test_count + 14`
+ my_test_count = `expr $my_test_count + 14`
printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml
cat <<_EOF > diag_table.yaml
@@ -752,6 +752,16 @@ diag_files:
var_name: var4
reduction: average
kind: r4
+- file_name: file6
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: none
+ kind: r4
_EOF
my_test_count=`expr $my_test_count + 1`
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index 0e2a57da77..fcd1d05283 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -149,6 +149,7 @@ program test_modern_diag
call diag_field_add_attribute (id_var1, "1d_integer", (/10, 10/))
call diag_field_add_attribute (id_var1, "real", 10.)
call diag_field_add_attribute (id_var2, '1d_real', (/10./))
+call diag_field_add_attribute (id_var2, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)')
!! test dump routines
!! prints fields from objects for debugging to log if name is provided, othwerise goes to stdout
@@ -156,7 +157,12 @@ program test_modern_diag
call dump_diag_obj()
call diag_manager_set_time_end(Time)
-call diag_send_complete(Time)
+call diag_manager_set_time_end(set_date(2,1,2,0,0,0))
+
+do i=1,23
+ call diag_send_complete(set_date(2,1,1,i,0,0))
+enddo
+
call diag_manager_end(Time)
call fms_end
From 169f094284bda2cbb1b41b8d2647406560601ff1 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 16 Dec 2022 08:17:10 -0500
Subject: [PATCH 076/168] feat: Add flexible timing feature in modern
diag_manager (#1077)
---
diag_manager/diag_data.F90 | 6 +
diag_manager/diag_manager.F90 | 13 +-
diag_manager/fms_diag_file_object.F90 | 215 ++++++++++---
diag_manager/fms_diag_object.F90 | 6 +-
diag_manager/fms_diag_time_utils.F90 | 109 ++++++-
diag_manager/fms_diag_yaml.F90 | 298 ++++++++++++-------
test_fms/diag_manager/Makefile.am | 3 +-
test_fms/diag_manager/check_crashes.sh | 2 +-
test_fms/diag_manager/test_diag_manager2.sh | 74 ++++-
test_fms/diag_manager/test_flexible_time.F90 | 63 ++++
10 files changed, 615 insertions(+), 174 deletions(-)
create mode 100644 test_fms/diag_manager/test_flexible_time.F90
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index bb41a98cdd..20e72ae4e2 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -120,6 +120,8 @@ MODULE diag_data_mod
INTEGER, PARAMETER :: time_sum = 5 !< The reudction method is sum
INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal
INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power
+ CHARACTER(len=7) :: avg_name = 'average' !< Name of the average fields
+ CHARACTER(len=8) :: no_units = "NO UNITS"!< String indicating that the variable has no units
!> @}
!> @brief Contains the coordinates of the local domain to output.
@@ -377,6 +379,10 @@ MODULE diag_data_mod
!! .TRUE. is only supported if the diag_manager_init
!! routine is called with the optional time_init parameter.
LOGICAL :: use_modern_diag = .false. !< Namelist flag to use the modernized diag_manager code
+ LOGICAL :: use_clock_average = .false. !< .TRUE. if the averaging of variable is done based on the clock
+ !! For example, if doing daily averages and your start the simulation in
+ !! day1_hour3, it will do the average between day1_hour3 to day2_hour 0
+ !! the default behavior will do the average between day1 hour3 to day2 hour3
!
REAL :: FILL_VALUE = NF_FILL_REAL !< Fill value used. Value will be NF90_FILL_REAL if using the
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 4007a40aa4..855eaa29a6 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -208,7 +208,7 @@ MODULE diag_manager_mod
& get_ticks_per_second
USE mpp_mod, ONLY: mpp_get_current_pelist, mpp_pe, mpp_npes, mpp_root_pe, mpp_sum
- USE mpp_mod, ONLY: input_nml_file
+ USE mpp_mod, ONLY: input_nml_file, mpp_error
USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,&
& fms_error_handler, check_nml_error, lowercase
@@ -231,7 +231,7 @@ MODULE diag_manager_mod
& use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,&
& max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,&
& max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time,diag_data_init,&
- & use_modern_diag, diag_null
+ & use_modern_diag, use_clock_average, diag_null
USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND
USE diag_table_mod, ONLY: parse_diag_table
@@ -3923,7 +3923,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
& max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
& max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
& oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
- & max_file_attributes, max_axis_attributes, prepend_date, field_log_separator, use_modern_diag
+ & max_file_attributes, max_axis_attributes, prepend_date, field_log_separator, use_modern_diag, &
+ & use_clock_average
! If the module was already initialized do nothing
IF ( module_is_initialized ) RETURN
@@ -3977,6 +3978,10 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
END IF
END IF
+ IF (.not. use_modern_diag .and. use_clock_average) &
+ call mpp_error(FATAL, "diag_manager_mod: You cannot set use_modern_diag=.false. and &
+ & use_clock_average=.true. in diag_manager_nml")
+
IF ( mpp_pe() == mpp_root_pe() ) THEN
WRITE (stdlog_unit, diag_manager_nml)
END IF
@@ -4037,7 +4042,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
END IF
if (use_modern_diag) then
- CALL fms_diag_object%init(diag_subset_output)
+ CALL fms_diag_object%init(diag_subset_output)
endif
if (.not. use_modern_diag) then
CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index ce926170ed..b7135867cd 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -32,9 +32,10 @@ module fms_diag_file_object_mod
TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ, &
get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute, &
get_base_second, time_unit_list, time_average, time_rms, time_max, time_min, time_sum, &
- time_diurnal, time_power, time_none
+ time_diurnal, time_power, time_none, avg_name, no_units
use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date, get_calendar_type, &
- VALID_CALENDAR_TYPES, operator(>=), date_to_string
+ VALID_CALENDAR_TYPES, operator(>=), date_to_string, &
+ OPERATOR(/), OPERATOR(+), operator(<)
use fms_diag_time_utils_mod, only: diag_time_inc, get_time_string, get_date_dif
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type, subRegion_type, diagYamlFilesVar_type
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
@@ -60,9 +61,12 @@ module fms_diag_file_object_mod
TYPE(time_type) :: last_output !< Time of the last time output was writen
TYPE(time_type) :: next_output !< Time of the next write
TYPE(time_type) :: next_next_output !< Time of the next next write
+ TYPE(time_type) :: no_more_data !< Time to stop receiving data for this file
!< This will be used when using the new_file_freq keys in the diag_table.yaml
- TYPE(time_type) :: next_open !< The next time to open the file
+ TYPE(time_type) :: next_close !< Time to close the file
+ logical :: is_file_open !< .True. if the file is opened
+
class(FmsNetcdfFile_t), allocatable :: fileobj !< fms2_io file object for this history file
type(diagYamlFiles_type), pointer :: diag_yaml_file => null() !< Pointer to the diag_yaml_file data
integer :: type_of_domain !< The type of domain to use to open the file
@@ -147,8 +151,10 @@ module fms_diag_file_object_mod
procedure :: write_axis_data
procedure :: writing_on_this_pe
procedure :: is_time_to_write
+ procedure :: is_time_to_close_file
procedure :: write_time_data
procedure :: update_next_write
+ procedure :: update_current_new_file_freq_index
procedure :: increase_unlimited_dimension
procedure :: close_diag_file
end type fmsDiagFileContainer_type
@@ -209,7 +215,22 @@ logical function fms_diag_files_object_init (files_array)
obj%last_output = get_base_time()
obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit())
obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
- obj%next_open = get_base_time()
+
+ if (obj%has_file_new_file_freq()) then
+ obj%next_close = diag_time_inc(obj%start_time, obj%get_file_new_file_freq(), &
+ obj%get_file_new_file_freq_units())
+ else
+ obj%next_close = diag_time_inc(obj%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ endif
+ obj%is_file_open = .false.
+
+ if(obj%has_file_duration()) then
+ obj%no_more_data = diag_time_inc(obj%start_time, obj%get_file_duration(), &
+ obj%get_file_duration_units())
+ else
+ obj%no_more_data = diag_time_inc(obj%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ endif
+
obj%time_ops = .false.
obj%unlimited_dimension = 0
obj%is_static = obj%get_file_freq() .eq. -1
@@ -653,6 +674,20 @@ subroutine add_start_time(this, start_time)
this%last_output = start_time
this%next_output = diag_time_inc(start_time, this%get_file_freq(), this%get_file_frequnit())
this%next_next_output = diag_time_inc(this%next_output, this%get_file_freq(), this%get_file_frequnit())
+ if (this%has_file_new_file_freq()) then
+ this%next_close = diag_time_inc(this%start_time, this%get_file_new_file_freq(), &
+ this%get_file_new_file_freq_units())
+ else
+ this%next_close = diag_time_inc(this%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ endif
+
+ if(this%has_file_duration()) then
+ this%no_more_data = diag_time_inc(this%start_time, this%get_file_duration(), &
+ this%get_file_duration_units())
+ else
+ this%no_more_data = diag_time_inc(this%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ endif
+
endif
end subroutine
@@ -667,7 +702,7 @@ subroutine dump_file_obj(this, unit_num)
write( unit_num, *) 'last_output', date_to_string(this%last_output)
write( unit_num, *) 'next_output', date_to_string(this%next_output)
write( unit_num, *)'next_next_output', date_to_string(this%next_next_output)
- write( unit_num, *)'next_open', date_to_string(this%next_open)
+ write( unit_num, *)'next_close', date_to_string(this%next_close)
if( allocated(this%fileobj)) write( unit_num, *)'fileobj path', this%fileobj%path
@@ -714,8 +749,8 @@ subroutine open_diag_file(this, time_step, file_is_opened)
domain => diag_file%domain
file_is_opened = .false.
- !< Go away if it is not time to open the file
- if (diag_file%next_open > time_step) return
+ !< Go away if it the file is already open
+ if (diag_file%is_file_open) return
is_regional = .false.
!< Figure out what fileobj to use!
@@ -736,9 +771,6 @@ subroutine open_diag_file(this, time_step, file_is_opened)
allocate(FmsNetcdfUnstructuredDomainFile_t :: diag_file%fileobj)
end select
end select
- else
- !< In this case, we are opening a new file so close the current the file
- call this%close_diag_file()
endif
!< Figure out what to name of the file
@@ -812,18 +844,29 @@ subroutine open_diag_file(this, time_step, file_is_opened)
end select
end select
- if (diag_file%has_file_new_file_freq()) then
- diag_file%next_open = diag_time_inc(diag_file%next_open, diag_file%get_file_new_file_freq(), &
- diag_file%get_file_new_file_freq_units())
- else
- diag_file%next_open = diag_time_inc(diag_file%next_open, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
- endif
-
file_is_opened = .true.
+ diag_file%is_file_open = file_is_opened
domain => null()
diag_file => null()
end subroutine open_diag_file
+!< @brief Writes a variable's metadata in the netcdf file
+subroutine write_var_metadata(fileobj, variable_name, dimensions, long_name, units)
+ class(FmsNetcdfFile_t), intent(inout) :: fileobj !< The file object to write into
+ character(len=*) , intent(in) :: variable_name !< The name of the time variables
+ character(len=*) , intent(in) :: dimensions(:) !< The dimensions of the variable
+ character(len=*) , intent(in) :: long_name !< The long_name of the variable
+ character(len=*) , intent(in) :: units !< The units of the variable
+
+ !TODO harcodded double
+ call register_field(fileobj, variable_name, "double", dimensions)
+ call register_variable_attribute(fileobj, variable_name, "long_name", &
+ trim(long_name), str_len=len_trim(long_name))
+ if (trim(units) .ne. no_units) &
+ call register_variable_attribute(fileobj, variable_name, "units", &
+ trim(units), str_len=len_trim(units))
+end subroutine write_var_metadata
+
!> \brief Write the time metadata to the diag file
subroutine write_time_metadata(this)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
@@ -834,6 +877,7 @@ subroutine write_time_metadata(this)
character(len=50) :: calendar !< The calendar name
character(len=:), allocatable :: time_var_name !< The name of the time variable as it is defined in the yaml
+ character(len=50) :: dimensions(2) !< Array of dimensions names for the variable
diag_file => this%FMS_diag_file
fileobj => diag_file%fileobj
@@ -846,14 +890,14 @@ subroutine write_time_metadata(this)
& get_base_month(), get_base_day(), get_base_hour(), get_base_minute(), get_base_second()
11 FORMAT(a, ' since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
- !TODO harcodded "double"
- call register_field(fileobj, time_var_name, "double", (/time_var_name/))
- call register_variable_attribute(fileobj, time_var_name, "units", trim(time_units_str), &
- str_len=len_trim(time_units_str))
+ dimensions(1) = "nv"
+ dimensions(2) = trim(time_var_name)
+
+ call write_var_metadata(fileobj, time_var_name, dimensions(2:2), &
+ time_var_name, time_units_str)
+ !< Add additional variables to the time variable
call register_variable_attribute(fileobj, time_var_name, "axis", "T", str_len=1 )
- call register_variable_attribute(fileobj, time_var_name, "long_name", trim(time_var_name), &
- str_len=len_trim(time_var_name) )
!TODO no need to have both attributes, probably?
calendar = valid_calendar_types(get_calendar_type())
@@ -862,11 +906,41 @@ subroutine write_time_metadata(this)
call register_variable_attribute(fileobj, time_var_name, "calendar", &
lowercase(trim(calendar)), str_len=len_trim(calendar))
- if (diag_file%time_ops) call register_variable_attribute(fileobj, time_var_name, "bounds", &
- trim(time_var_name)//"_bounds", str_len=len_trim(time_var_name//"_bounds"))
+ if (diag_file%time_ops) then
+ call register_variable_attribute(fileobj, time_var_name, "bounds", &
+ trim(time_var_name)//"_bounds", str_len=len_trim(time_var_name//"_bounds"))
+
+ !< Write out the "average_*" variables metadata
+ call write_var_metadata(fileobj, avg_name//"_T1", dimensions(2:2), &
+ "Start time for average period", time_units_str)
+ call write_var_metadata(fileobj, avg_name//"_T2", dimensions(2:2), &
+ "End time for average period", time_units_str)
+ call write_var_metadata(fileobj, avg_name//"_DT", dimensions(2:2), &
+ "Length time for average period", time_units_str)
+
+ !< Write out the *_bounds variable metadata
+ call register_axis(fileobj, "nv", 2) !< Time bounds need a vertex number
+ call write_var_metadata(fileobj, "nv", dimensions(1:1), &
+ "vertex number", no_units)
+ call write_var_metadata(fileobj, time_var_name//"_bounds", dimensions, &
+ trim(time_var_name)//" axis boundaries", time_units_str)
+ endif
end subroutine write_time_metadata
+!> \brief Determine if it is time to close the file
+!! \return .True. if it is time to close the file
+logical function is_time_to_close_file (this, time_step)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
+ TYPE(time_type), intent(in) :: time_step !< Current model step time
+
+ if (time_step >= this%FMS_diag_file%next_close) then
+ is_time_to_close_file = .true.
+ else
+ is_time_to_close_file = .false.
+ endif
+end function
+
!> \brief Determine if it is time to "write" to the file
logical function is_time_to_write(this, time_step)
class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
@@ -875,7 +949,7 @@ logical function is_time_to_write(this, time_step)
if (time_step >= this%FMS_diag_file%next_output) then
is_time_to_write = .true.
if (this%FMS_diag_file%is_static) return
- if (time_step >= this%FMS_diag_file%next_next_output) &
+ if (time_step > this%FMS_diag_file%next_next_output) &
call mpp_error(FATAL, this%FMS_diag_file%get_file_fname()//&
&": Diag_manager_mod:: You skipped a time_step. Be sure that diag_send_complete is called at every time step "&
&" needed by the file.")
@@ -898,33 +972,75 @@ logical function writing_on_this_pe(this)
end function
!> \brief Write out the time data to the file
-subroutine write_time_data(this, time_step)
- class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
- TYPE(time_type), intent(in) :: time_step !< Current model step time
+subroutine write_time_data(this)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
real :: dif !< The time as a real number
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ TYPE(time_type) :: middle_time !< The middle time of the averaging period
+
+ real :: T1 !< The beginning time of the averaging period
+ real :: T2 !< The ending time of the averaging period
+ real :: DT !< The difference between the ending and beginning time of the averaging period
diag_file => this%FMS_diag_file
fileobj => diag_file%fileobj
- !> dif is the time as a real that is evaluated
- dif = get_date_dif(time_step, get_base_time(), diag_file%get_file_timeunit())
- select type (fileobj)
- type is (FmsNetcdfDomainFile_t)
- call write_data(fileobj, diag_file%get_file_unlimdim(), dif, &
- unlim_dim_level=diag_file%unlimited_dimension)
- type is (FmsNetcdfUnstructuredDomainFile_t)
- call write_data(fileobj, diag_file%get_file_unlimdim(), dif, &
- unlim_dim_level=diag_file%unlimited_dimension)
- type is (FmsNetcdfFile_t)
- call write_data(fileobj, diag_file%get_file_unlimdim(), dif, &
- unlim_dim_level=diag_file%unlimited_dimension)
- end select
+ if (diag_file%time_ops) then
+ middle_time = (diag_file%last_output+diag_file%next_output)/2
+ dif = get_date_dif(middle_time, get_base_time(), diag_file%get_file_timeunit())
+ else
+ dif = get_date_dif(diag_file%next_output, get_base_time(), diag_file%get_file_timeunit())
+ endif
+
+ call write_data(fileobj, diag_file%get_file_unlimdim(), dif, &
+ unlim_dim_level=diag_file%unlimited_dimension)
+
+ if (diag_file%time_ops) then
+ T1 = get_date_dif(diag_file%last_output, get_base_time(), diag_file%get_file_timeunit())
+ T2 = get_date_dif(diag_file%next_output, get_base_time(), diag_file%get_file_timeunit())
+ DT = T2 - T1
+
+ call write_data(fileobj, avg_name//"_T1", T1, unlim_dim_level=diag_file%unlimited_dimension)
+ call write_data(fileobj, avg_name//"_T2", T2, unlim_dim_level=diag_file%unlimited_dimension)
+ call write_data(fileobj, avg_name//"_DT", DT, unlim_dim_level=diag_file%unlimited_dimension)
+ call write_data(fileobj, trim(diag_file%get_file_unlimdim())//"_bounds", &
+ (/T1, T2/), unlim_dim_level=diag_file%unlimited_dimension)
+
+ if (diag_file%unlimited_dimension .eq. 1) then
+ call write_data(fileobj, "nv", (/1, 2/))
+ endif
+ endif
end subroutine write_time_data
+!> \brief Updates the current_new_file_freq_index if using a new_file_freq
+subroutine update_current_new_file_freq_index(this, time_step)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ TYPE(time_type), intent(in) :: time_step !< Current model step time
+
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
+
+ diag_file => this%FMS_diag_file
+
+ if (time_step >= diag_file%no_more_data) then
+ call diag_file%diag_yaml_file%increase_new_file_freq_index()
+
+ if (diag_file%has_file_duration()) then
+ diag_file%no_more_data = diag_time_inc(diag_file%no_more_data, diag_file%get_file_duration(), &
+ diag_file%get_file_duration_units())
+ else
+ !< At this point you are done writing data
+ diag_file%no_more_data = diag_time_inc(diag_file%no_more_data, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ diag_file%next_output = diag_file%no_more_data
+ diag_file%next_next_output = diag_file%no_more_data
+ diag_file%last_output = diag_file%no_more_data
+ diag_file%next_close = diag_file%no_more_data
+ endif
+ endif
+end subroutine update_current_new_file_freq_index
+
!> \brief Set up the next_output and next_next_output variable in a file obj
subroutine update_next_write(this, time_step)
class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
@@ -934,9 +1050,11 @@ subroutine update_next_write(this, time_step)
diag_file => this%FMS_diag_file
if (diag_file%is_static) then
+ diag_file%last_output = diag_file%next_output
diag_file%next_output = diag_time_inc(diag_file%next_output, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
diag_file%next_next_output = diag_time_inc(diag_file%next_output, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
else
+ diag_file%last_output = diag_file%next_output
diag_file%next_output = diag_time_inc(diag_file%next_output, diag_file%get_file_freq(), &
diag_file%get_file_frequnit())
diag_file%next_next_output = diag_time_inc(diag_file%next_output, diag_file%get_file_freq(), &
@@ -1008,6 +1126,8 @@ end subroutine write_axis_data
subroutine close_diag_file(this)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ if (.not. this%FMS_diag_file%is_file_open) return
+
!< The select types are needed here because otherwise the code will go to the
!! wrong close_file routine and things will not close propertly
select type( fileobj => this%FMS_diag_file%fileobj)
@@ -1019,6 +1139,17 @@ subroutine close_diag_file(this)
call close_file(fileobj)
end select
+ !< Reset the unlimited dimension back to 0, in case the fileobj is re-used
+ this%FMS_diag_file%unlimited_dimension = 0
+ this%FMS_diag_file%is_file_open = .false.
+
+ if (this%FMS_diag_file%has_file_new_file_freq()) then
+ this%FMS_diag_file%next_close = diag_time_inc(this%FMS_diag_file%next_close, &
+ this%FMS_diag_file%get_file_new_file_freq(), &
+ this%FMS_diag_file%get_file_new_file_freq_units())
+ else
+ this%FMS_diag_file%next_close = diag_time_inc(this%FMS_diag_file%next_close, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ endif
end subroutine close_diag_file
#endif
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 3811cfcc0e..95e92694d1 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -456,9 +456,11 @@ subroutine fms_diag_send_complete(this, time_step)
if (diag_file%is_time_to_write(time_step)) then
call diag_file%increase_unlimited_dimension()
- call diag_file%write_time_data(time_step)
- !TODO call diag_file%add_variable_data()
+ call diag_file%write_time_data()
+ !TODO call diag_file%add_variable_data()
call diag_file%update_next_write(time_step)
+ call diag_file%update_current_new_file_freq_index(time_step)
+ if (diag_file%is_time_to_close_file(time_step)) call diag_file%close_diag_file
endif
enddo
#endif
diff --git a/diag_manager/fms_diag_time_utils.F90 b/diag_manager/fms_diag_time_utils.F90
index 779f3d5fa4..de18228dcd 100644
--- a/diag_manager/fms_diag_time_utils.F90
+++ b/diag_manager/fms_diag_time_utils.F90
@@ -27,9 +27,9 @@
module fms_diag_time_utils_mod
use time_manager_mod, only: time_type, increment_date, increment_time, get_calendar_type, NO_CALENDAR, leap_year, &
- get_date, get_time, operator(>), operator(<), operator(-)
+ get_date, get_time, operator(>), operator(<), operator(-), set_date
use diag_data_mod, only: END_OF_RUN, EVERY_TIME, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, &
- DIAG_YEARS
+ DIAG_YEARS, use_clock_average
USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE
use fms_mod, only: fms_error_handler
use mpp_mod, only: mpp_error, FATAL
@@ -52,65 +52,144 @@ TYPE(time_type) FUNCTION diag_time_inc(time, output_freq, output_units, err_msg)
!! An empty string indicates the next output
!! time was found successfully.
+ if (use_clock_average) then
+ diag_time_inc = diag_clock_time_inc(time, output_freq, output_units, err_msg)
+ else
+ diag_time_inc = diag_forecast_time_inc(time, output_freq, output_units, err_msg)
+ endif
+ end function diag_time_inc
+
+ !> @brief Determine the next time data/file is to be written based on the frequency and units using the clock.
+ !! For example, if doing daily averages and the input time is day1_hour3, the output time will be day2_hour0.
+ !! @return the next time data/file is to be written
+ TYPE(time_type) FUNCTION diag_clock_time_inc(time, output_freq, output_units, err_msg)
+ TYPE(time_type), INTENT(in) :: time !< Current model time.
+ INTEGER, INTENT(in) :: output_freq !< Output frequency number value.
+ INTEGER, INTENT(in) :: output_units !< Output frequency unit.
+ CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Function error message.
+ !! An empty string indicates the next output
+ !! time was found successfully.
CHARACTER(len=128) :: error_message_local !< Local variable to store the error_message
+ integer :: cyear !< The current year stored in the time type
+ integer :: cmonth !< The current month stored in the time type
+ integer :: cday !< The current day stored in the time type
+ integer :: chour !< The current hour stored in the time type
+ integer :: cmin !< The current minute stored in the time type
+ integer :: csecond !< The current second stored in the time type
+ type(time_type) :: my_time !< Time set at the begining of the
IF ( PRESENT(err_msg) ) err_msg = ''
error_message_local = ''
+ IF ( get_calendar_type() == NO_CALENDAR) then
+ error_message_local = 'If using use_clock_average =.TRUE., your calendar must be set.'
+ IF ( fms_error_handler('diag_clock_time_inc',error_message_local,err_msg) ) RETURN
+ endif
+
! 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
+ diag_clock_time_inc = time
+ RETURN
+ END IF
+
+ call get_date(Time, cyear, cmonth, cday, chour, cmin, csecond)
+
+ select case (output_units)
+ case (DIAG_SECONDS)
+ my_time = set_date(cyear, cmonth, cday, chour, cmin, csecond) !< set my_time to the begining of the hour
+ diag_clock_time_inc = increment_date(my_time, 0, 0, 0, 0, 0, output_freq, err_msg=error_message_local)
+ case (DIAG_MINUTES)
+ my_time = set_date(cyear, cmonth, cday, chour, cmin, 0) !< set my_time to the begining of the hour
+ diag_clock_time_inc = increment_date(my_time, 0, 0, 0, 0, output_freq, 0, err_msg=error_message_local)
+ case (DIAG_HOURS)
+ my_time = set_date(cyear, cmonth, cday, chour, 0, 0) !< set my_time to the begining of the hour
+ diag_clock_time_inc = increment_date(my_time, 0, 0, 0, output_freq, 0, 0, err_msg=error_message_local)
+ case (DIAG_DAYS)
+ my_time = set_date(cyear, cmonth, cday, 0, 0, 0) !< set my_time to the begining of the day
+ diag_clock_time_inc = increment_date(my_time, 0, 0, output_freq, 0, 0, 0, err_msg=error_message_local)
+ case (DIAG_MONTHS)
+ my_time = set_date(cyear, cmonth, 1, 0, 0, 0) !< set my_time to the begining of the month
+ diag_clock_time_inc = increment_date(my_time, 0, output_freq, 0, 0, 0, 0, err_msg=error_message_local)
+ case (DIAG_YEARS)
+ my_time = set_date(cyear, 1, 1, 0, 0, 0) !< set my_time to the begining of the year
+ diag_clock_time_inc = increment_date(my_time, output_freq, 0, 0, 0, 0, 0, err_msg=error_message_local)
+ end select
+
+ end function diag_clock_time_inc
+
+ !> @brief Determine the next time data/file is to be written based on the frequency and units using forecast time.
+ !! For example, if doing daily averages and the input time is day1_hour3, the output time will be day2_hour3.
+ !! @return the next time data/file is to be written
+ TYPE(time_type) FUNCTION diag_forecast_time_inc(time, output_freq, output_units, err_msg)
+ TYPE(time_type), INTENT(in) :: time !< Current model time.
+ INTEGER, INTENT(in) :: output_freq !< Output frequency number value.
+ INTEGER, INTENT(in) :: output_units !< Output frequency unit.
+ CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Function error message.
+ !! An empty string indicates the next output
+ !! time was found successfully.
+
+ CHARACTER(len=128) :: error_message_local !< Local variable to store the error_message
+
+ 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_forecast_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)
+ diag_forecast_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)
+ diag_forecast_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, &
+ diag_forecast_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)
+ diag_forecast_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)
+ diag_forecast_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)
+ diag_forecast_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)
+ diag_forecast_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)
+ diag_forecast_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)
+ diag_forecast_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)
+ diag_forecast_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
+ IF ( fms_error_handler('diag_forecast_time_inc',error_message_local,err_msg) ) RETURN
END IF
- END FUNCTION diag_time_inc
+ END FUNCTION diag_forecast_time_inc
!> @brief This function determines a string based on current time.
!! This string is used as suffix in output file name
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index b3137d38b6..8e42b5cc80 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -56,6 +56,7 @@ module fms_diag_yaml_mod
integer, parameter :: basedate_size = 6
integer, parameter :: NUM_SUB_REGION_ARRAY = 8
integer, parameter :: MAX_STR_LEN = 255
+integer, parameter :: MAX_FREQ = 12
!> @brief type to hold an array of sorted diag_fiels
@@ -85,73 +86,79 @@ module fms_diag_yaml_mod
!> @brief type to hold the diag_file information
type diagYamlFiles_type
- character (len=:), private, allocatable :: file_fname !< file name
- integer, private :: file_frequnit !< the frequency unit (DIAG_SECONDS, DIAG_MINUTES, &
- !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
- integer, private :: file_freq !< the frequency of data
- integer, private :: file_timeunit !< The unit of time (DIAG_SECONDS, DIAG_MINUTES, &
- !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
- character (len=:), private, allocatable :: file_unlimdim !< The name of the unlimited dimension
- type(subRegion_type), private :: file_sub_region !< type containing info about the subregion, if any
- integer, private :: file_new_file_freq !< Frequency for closing the existing file
- integer, private :: file_new_file_freq_units !< Time units for creating a new file.
- !! Required if “new_file_freq” used
- !! (DIAG_SECONDS, DIAG_MINUTES, &
- !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
- character (len=:), private, allocatable :: file_start_time !< Time to start the file for the first time. Requires
- !! “new_file_freq”
- integer, private :: file_duration !< How long the file should receive data after start time
- !! in “file_duration_units”. This optional field can only
- !! be used if the start_time field is present. If this field
- !! is absent, then the file duration will be equal to the
- !! frequency for creating new files.
- !! NOTE: The file_duration_units field must also be present if
- !! this field is present.
- integer, private :: file_duration_units !< The file duration units
- !! (DIAG_SECONDS, DIAG_MINUTES, &
- !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
+ private
+ character (len=:), allocatable :: file_fname !< file name
+ integer :: file_frequnit(MAX_FREQ) !< the frequency unit (DIAG_SECONDS,
+ !! DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS,
+ !! DIAG_YEARS)
+ integer :: file_freq(MAX_FREQ) !< the frequency of data
+ integer :: file_timeunit !< The unit of time (DIAG_SECONDS,
+ !! DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS,
+ !! DIAG_YEARS)
+ character (len=:), allocatable :: file_unlimdim !< The name of the unlimited dimension
+ type(subRegion_type) :: file_sub_region !< type containing info about the subregion
+ integer :: file_new_file_freq(MAX_FREQ) !< Frequency for closing the existing file
+ integer :: file_new_file_freq_units(MAX_FREQ) !< Time units for creating a new file.
+ !! Required if “new_file_freq” used
+ !! (DIAG_SECONDS, DIAG_MINUTES, &
+ !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
+ character (len=:), allocatable :: file_start_time !< Time to start the file for the
+ !! first time. Requires “new_file_freq”
+ integer :: file_duration(MAX_FREQ) !< How long the file should receive data
+ !! after start time in file_duration_units.
+ !! This optional field can only be used if
+ !! the start_time field is present. If this
+ !! field is absent, then the file duration
+ !! will be equal to the frequency for
+ !! creating new files. NOTE: The
+ !! file_duration_units field must also
+ !! be present if this field is present.
+ integer :: file_duration_units(MAX_FREQ) !< The file duration units
+ !! (DIAG_SECONDS, DIAG_MINUTES, &
+ !! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
+ integer :: current_new_file_freq_index !< The index of the new_file_freq array
!< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
- character (len=MAX_STR_LEN), dimension(:), private, allocatable :: file_varlist !< An array of variable names
- !! within a file
- character (len=MAX_STR_LEN), dimension(:,:), private, allocatable :: file_global_meta !< Array of key(dim=1)
- !! and values(dim=2) to be
- !! added as global meta data to
- !! the file
+ character (len=MAX_STR_LEN), allocatable :: file_varlist(:) !< An array of variable names
+ !! within a file
+ character (len=MAX_STR_LEN), allocatable :: file_global_meta(:,:) !< Array of key(dim=1)
+ !! and values(dim=2) to be
+ !! added as global meta data to
+ !! the file
contains
!> All getter functions (functions named get_x(), for member field named x)
!! return copies of the member variables unless explicitly noted.
- procedure :: size_file_varlist
- procedure :: get_file_fname
- procedure :: get_file_frequnit
- procedure :: get_file_freq
- procedure :: get_file_timeunit
- procedure :: get_file_unlimdim
- procedure :: get_file_sub_region
- procedure :: get_file_new_file_freq
- procedure :: get_file_new_file_freq_units
- procedure :: get_file_start_time
- procedure :: get_file_duration
- procedure :: get_file_duration_units
- procedure :: get_file_varlist
- procedure :: get_file_global_meta
- procedure :: is_global_meta
+ procedure, public :: size_file_varlist
+ procedure, public :: get_file_fname
+ procedure, public :: get_file_frequnit
+ procedure, public :: get_file_freq
+ procedure, public :: get_file_timeunit
+ procedure, public :: get_file_unlimdim
+ procedure, public :: get_file_sub_region
+ procedure, public :: get_file_new_file_freq
+ procedure, public :: get_file_new_file_freq_units
+ procedure, public :: get_file_start_time
+ procedure, public :: get_file_duration
+ procedure, public :: get_file_duration_units
+ procedure, public :: get_file_varlist
+ procedure, public :: get_file_global_meta
+ procedure, public :: is_global_meta
!> Has functions to determine if allocatable variables are true. If a variable is not an allocatable
!! then is will always return .true.
- procedure :: has_file_fname
- procedure :: has_file_frequnit
- procedure :: has_file_freq
- procedure :: has_file_timeunit
- procedure :: has_file_unlimdim
- procedure :: has_file_sub_region
- procedure :: has_file_new_file_freq
- procedure :: has_file_new_file_freq_units
- procedure :: has_file_start_time
- procedure :: has_file_duration
- procedure :: has_file_duration_units
- procedure :: has_file_varlist
- procedure :: has_file_global_meta
-
+ procedure, public :: has_file_fname
+ procedure, public :: has_file_frequnit
+ procedure, public :: has_file_freq
+ procedure, public :: has_file_timeunit
+ procedure, public :: has_file_unlimdim
+ procedure, public :: has_file_sub_region
+ procedure, public :: has_file_new_file_freq
+ procedure, public :: has_file_new_file_freq_units
+ procedure, public :: has_file_start_time
+ procedure, public :: has_file_duration
+ procedure, public :: has_file_duration_units
+ procedure, public :: has_file_varlist
+ procedure, public :: has_file_global_meta
+ procedure, public :: increase_new_file_freq_index
end type diagYamlFiles_type
!> @brief type to hold the info a diag_field
@@ -470,30 +477,31 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
integer, allocatable :: key_ids(:) !< Id of the gloabl atttributes key/value pairs
character(len=:), ALLOCATABLE :: grid_type !< grid_type as it is read in from the yaml
- character(len=:), ALLOCATABLE :: buffer !< buffer to store any *_units as it is read from the yaml
+ character(len=:), ALLOCATABLE :: freq_buffer !< buffer to store any freq as it is read from the yaml
+ character(len=:), ALLOCATABLE :: buffer !< buffer to store any *_units as it is read from the yaml
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", buffer)
- call get_value_from_key(diag_yaml_id, diag_file_id, "freq", fileobj%file_freq)
- call set_file_freq(fileobj, buffer)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq", freq_buffer)
+ call set_file_freq(fileobj, freq_buffer, buffer)
- deallocate(buffer)
+ deallocate(freq_buffer, buffer)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", fileobj%file_unlimdim)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", buffer)
call set_file_time_units(fileobj, buffer)
deallocate(buffer)
- call get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", fileobj%file_new_file_freq, is_optional=.true.)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", freq_buffer, is_optional=.true.)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq_units", buffer, &
is_optional=.true.)
- call set_new_file_freq(fileobj, buffer)
+ call set_new_file_freq(fileobj, freq_buffer, buffer)
- deallocate(buffer)
+ deallocate(freq_buffer, buffer)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", fileobj%file_start_time, is_optional=.true.)
- call get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", fileobj%file_duration, is_optional=.true.)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", freq_buffer, is_optional=.true.)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration_units", buffer, &
is_optional=.true.)
- call set_file_duration(fileobj, buffer)
+ call set_file_duration(fileobj, freq_buffer, buffer)
nsubregion = 0
nsubregion = get_num_blocks(diag_yaml_id, "sub_region", parent_block_id=diag_file_id)
@@ -522,7 +530,8 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
enddo
deallocate(key_ids)
elseif (natt .ne. 0) then
- call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//" has multiple global_meta blocks")
+ call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//&
+ &" has multiple global_meta blocks")
endif
end subroutine
@@ -658,14 +667,31 @@ function get_total_num_vars(diag_yaml_id, diag_file_id) &
!> @brief This checks if the file frequency and file frequency units in a diag file are valid and
!! sets the integer equivalent
-subroutine set_file_freq(fileobj, file_frequnit)
+subroutine set_file_freq(fileobj, file_freq, file_frequnit)
type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+ character(len=*), intent(in) :: file_freq !< File_freq as it is read from the diag_table
character(len=*), intent(in) :: file_frequnit !< File_freq_units as it is read from the diag_table
- if (.not. (fileobj%file_freq >= -1) ) &
- call mpp_error(FATAL, "freq must be greater than or equal to -1. &
- &Check you entry for"//trim(fileobj%file_fname))
- fileobj%file_frequnit = set_valid_time_units(file_frequnit, "frequnit for file:"//trim(fileobj%file_fname))
+ integer :: i !< For do loops
+ character(len=10) :: file_freq_units(MAX_FREQ) !< Array of file frequencies as a string
+ integer :: err_unit !< Dummy error unit
+
+ file_freq_units = ""
+ read(file_freq, *, iostat=err_unit) fileobj%file_freq
+ read(file_frequnit, *, iostat=err_unit) file_freq_units
+
+ do i = 1, MAX_FREQ
+ if (fileobj%file_freq(i) >= -1) then
+ if (trim(file_freq_units(i)) .eq. "") &
+ call mpp_error(FATAL, "file_freq_units is required. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+
+ fileobj%file_frequnit(i) = set_valid_time_units(file_freq_units(i), &
+ "file_freq_units for file:"//trim(fileobj%file_fname))
+ else
+ return
+ endif
+ enddo
end subroutine set_file_freq
!> @brief This checks if the time unit in a diag file is valid and sets the integer equivalent
@@ -678,34 +704,89 @@ end subroutine set_file_time_units
!> @brief This checks if the new file frequency and the new file frequency units in a diag file are valid
!! and sets the integer equivalent
-subroutine set_new_file_freq(fileobj, file_new_file_freq_units)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
- character(len=*), intent(in) :: file_new_file_freq_units !< new file freq units as it is read from
+subroutine set_new_file_freq(fileobj, new_file_freq, new_file_freq_units)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+ character(len=*), intent(in) :: new_file_freq !< new file freq units as it is read from
+ !! the diag_table
+ character(len=*), intent(in) :: new_file_freq_units !< new file freq units as it is read from
!! the diag_table
- if (fileobj%file_new_file_freq > 0) then
- if (trim(file_new_file_freq_units) .eq. "") &
- call mpp_error(FATAL, "new_file_freq_units is required if using new_file_freq. &
+ integer :: i !< For do loops
+ character(len=10) :: file_new_file_freq_units(MAX_FREQ) !< Array of new file frequencies as string
+ integer :: err_unit !< Dummy error unit
+
+ file_new_file_freq_units = ""
+ read(new_file_freq, *, iostat=err_unit) fileobj%file_new_file_freq
+ read(new_file_freq_units, *, iostat=err_unit) file_new_file_freq_units
+
+ do i = 1, MAX_FREQ
+ if (fileobj%file_new_file_freq(i) > 0) then
+ if (trim(file_new_file_freq_units(i)) .eq. "") &
+ call mpp_error(FATAL, "new_file_freq_units is required if using new_file_freq. &
&Check your entry for file:"//trim(fileobj%file_fname))
- fileobj%file_new_file_freq_units = set_valid_time_units(file_new_file_freq_units, &
+ fileobj%file_new_file_freq_units(i) = set_valid_time_units(file_new_file_freq_units(i), &
"new_file_freq_units for file:"//trim(fileobj%file_fname))
- endif
+ else
+ return
+ endif
+ enddo
end subroutine set_new_file_freq
!> @brief This checks if the file duration and the file duration units in a diag file are valid
!! and sets the integer equivalent
-subroutine set_file_duration(fileobj, file_duration_units)
+subroutine set_file_duration(fileobj, file_duration, file_duration_units)
type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
- character(len=*), intent(in) :: file_duration_units !< file_duration as it is read from the diag_table
-
- if (fileobj%file_duration > 0) then
- if(trim(file_duration_units) .eq. "") &
+ character(len=*), intent(in) :: file_duration !< file_duration as it is read from the yaml
+ character(len=*), intent(in) :: file_duration_units !< file_duration units as it is read from the yaml
+
+ integer :: i !< For do loops
+ character(len=10) :: file_duration_units_array(MAX_FREQ) !< Array of file_duration_units as string
+ integer :: err_unit !< Dummy error unit
+ logical :: mask(MAX_FREQ) !< Array of logical
+ integer :: nfile_duration !< Number of file durations defined
+ integer :: nfile_freq !< Number of file frequencies defined
+ integer :: nnew_file_freq !< Number of new file frequencies defined
+
+ file_duration_units_array = ""
+ read(file_duration, *, iostat=err_unit) fileobj%file_duration
+ read(file_duration_units, *, iostat=err_unit) file_duration_units_array
+
+ nfile_duration = 0
+ do i = 1, MAX_FREQ
+ if (fileobj%file_duration(i) > 0) then
+ if(trim(file_duration_units_array(i)) .eq. "") &
call mpp_error(FATAL, "file_duration_units is required if using file_duration. &
&Check your entry for file:"//trim(fileobj%file_fname))
- fileobj%file_duration_units = set_valid_time_units(file_duration_units, &
+ fileobj%file_duration_units(i) = set_valid_time_units(file_duration_units_array(i), &
"file_duration_units for file:"//trim(fileobj%file_fname))
- endif
+ nfile_duration = nfile_duration + 1
+ else
+ exit
+ endif
+ enddo
+
+ !< Make sure the user send in the correct number of freq, new_file_freq, and file_duration
+ mask = .FALSE.
+ mask = fileobj%file_freq .ne. DIAG_NULL
+ nfile_freq = count(mask)
+
+ mask = .FALSE.
+ mask = fileobj%file_new_file_freq .ne. DIAG_NULL
+ nnew_file_freq = count(mask)
+
+ if (nfile_freq .ne. nfile_duration .and. nfile_freq-1 .ne. nfile_duration) &
+ call mpp_error(FATAL, "freq and file_duration do not have consistent size. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+
+ if (nfile_freq .ne. nnew_file_freq .and. nfile_freq-1 .ne. nnew_file_freq) &
+ call mpp_error(FATAL, "freq and new_file_freq do not have consistent size. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+
+ if (nnew_file_freq .ne. nfile_duration .and. nnew_file_freq-1 .ne. nfile_duration) &
+ call mpp_error(FATAL, "new_file_freq and file_duration do not have consistent size. &
+ &Check your entry for file:"//trim(fileobj%file_fname))
+
end subroutine set_file_duration
!> @brief This checks if the kind of a diag field is valid and sets it
@@ -836,7 +917,7 @@ pure function get_file_frequnit (diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_frequnit
+ res = diag_files_obj%file_frequnit(diag_files_obj%current_new_file_freq_index)
end function get_file_frequnit
!> @brief Inquiry for diag_files_obj%file_freq
!! @return file_freq of a diag_yaml_file_obj
@@ -844,7 +925,7 @@ pure function get_file_freq(diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_freq
+ res = diag_files_obj%file_freq(diag_files_obj%current_new_file_freq_index)
end function get_file_freq
!> @brief Inquiry for diag_files_obj%file_timeunit
!! @return file_timeunit of a diag_yaml_file_obj
@@ -876,7 +957,7 @@ pure function get_file_new_file_freq(diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_new_file_freq
+ res = diag_files_obj%file_new_file_freq(diag_files_obj%current_new_file_freq_index)
end function get_file_new_file_freq
!> @brief Inquiry for diag_files_obj%file_new_file_freq_units
!! @return file_new_file_freq_units of a diag_yaml_file_obj
@@ -884,7 +965,7 @@ pure function get_file_new_file_freq_units (diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_new_file_freq_units
+ res = diag_files_obj%file_new_file_freq_units(diag_files_obj%current_new_file_freq_index)
end function get_file_new_file_freq_units
!> @brief Inquiry for diag_files_obj%file_start_time
!! @return file_start_time of a diag_yaml_file_obj
@@ -900,7 +981,7 @@ pure function get_file_duration (diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_duration
+ res = diag_files_obj%file_duration(diag_files_obj%current_new_file_freq_index)
end function get_file_duration
!> @brief Inquiry for diag_files_obj%file_duration_units
!! @return file_duration_units of a diag_yaml_file_obj
@@ -908,7 +989,7 @@ pure function get_file_duration_units (diag_files_obj) &
result (res)
class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_duration_units
+ res = diag_files_obj%file_duration_units(diag_files_obj%current_new_file_freq_index)
end function get_file_duration_units
!> @brief Inquiry for diag_files_obj%file_varlist
!! @return file_varlist of a diag_yaml_file_obj
@@ -936,6 +1017,12 @@ function is_global_meta(diag_files_obj) &
if (allocated(diag_files_obj%file_global_meta)) &
res = .true.
end function
+
+!> @brief Increate the current_new_file_freq_index by 1
+subroutine increase_new_file_freq_index(this)
+ class(diagYamlFiles_type), intent(inout) :: this !< The file object
+ this%current_new_file_freq_index = this%current_new_file_freq_index + 1
+end subroutine
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -1056,11 +1143,12 @@ subroutine diag_yaml_files_obj_init(obj)
type(diagYamlFiles_type), intent(out) :: obj !< diagYamlFiles_type object to initialize
obj%file_freq = DIAG_NULL
- obj%file_duration = DIAG_NULL
- obj%file_duration_units = DIAG_NULL
- obj%file_new_file_freq = DIAG_NULL
- obj%file_new_file_freq_units = DIAG_NULL
obj%file_sub_region%tile = DIAG_NULL
+ obj%file_new_file_freq = DIAG_NULL
+ obj%file_duration = DIAG_NULL
+ obj%file_new_file_freq_units = DIAG_NULL
+ obj%file_duration_units = DIAG_NULL
+ obj%current_new_file_freq_index = 1
end subroutine diag_yaml_files_obj_init
!> @brief Checks if obj%file_fname is allocated
@@ -1073,7 +1161,7 @@ end function has_file_fname
!! @return true if obj%file_frequnit is allocated
pure logical function has_file_frequnit (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_frequnit = obj%file_frequnit .NE. DIAG_NULL
+ has_file_frequnit = obj%file_frequnit(obj%current_new_file_freq_index) .NE. DIAG_NULL
end function has_file_frequnit
!> @brief obj%file_freq is on the stack, so the object always has it
!! @return true if obj%file_freq is allocated
@@ -1113,13 +1201,13 @@ end function has_file_sub_region
!! @return true
pure logical function has_file_new_file_freq (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_new_file_freq = obj%file_new_file_freq .ne. DIAG_NULL
+ has_file_new_file_freq = obj%file_new_file_freq(obj%current_new_file_freq_index) .ne. DIAG_NULL
end function has_file_new_file_freq
!> @brief Checks if obj%file_new_file_freq_units is allocated
!! @return true if obj%file_new_file_freq_units is allocated
pure logical function has_file_new_file_freq_units (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_new_file_freq_units = obj%file_new_file_freq_units .ne. diag_null
+ has_file_new_file_freq_units = obj%file_new_file_freq_units(obj%current_new_file_freq_index) .ne. diag_null
end function has_file_new_file_freq_units
!> @brief Checks if obj%file_start_time is allocated
!! @return true if obj%file_start_time is allocated
@@ -1131,13 +1219,13 @@ end function has_file_start_time
!! @return true
pure logical function has_file_duration (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_duration = .true.
+ has_file_duration = obj%file_duration(obj%current_new_file_freq_index) .ne. DIAG_NULL
end function has_file_duration
!> @brief obj%file_duration_units is on the stack, so this will retrun true
!! @return true
pure logical function has_file_duration_units (obj)
class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_duration_units = obj%file_duration_units .ne. diag_null
+ has_file_duration_units = obj%file_duration_units(obj%current_new_file_freq_index) .ne. diag_null
end function has_file_duration_units
!> @brief Checks if obj%file_varlist is allocated
!! @return true if obj%file_varlist is allocated
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 4dfbd13602..1a3b6b75ba 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -30,7 +30,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
# Build this test program.
check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_object_container \
test_diag_update_buffer test_diag_dlinked_list \
- test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer
+ test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer test_flexible_time
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -41,6 +41,7 @@ test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90
test_diag_ocean_SOURCES = test_diag_ocean.F90
test_modern_diag_SOURCES = test_modern_diag.F90
test_diag_buffer_SOURCES= test_diag_buffer.F90
+test_flexible_time_SOURCES = test_flexible_time.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
diff --git a/test_fms/diag_manager/check_crashes.sh b/test_fms/diag_manager/check_crashes.sh
index 9ec803ebec..537e5824d6 100755
--- a/test_fms/diag_manager/check_crashes.sh
+++ b/test_fms/diag_manager/check_crashes.sh
@@ -56,7 +56,7 @@ test_expect_failure "freq units is not valid" '
mpirun -n 1 ../test_diag_yaml
'
-sed 's/freq: 6/freq: -666/g' diag_table.yaml_base > diag_table.yaml
+sed 's/freq: 6/freq: 6 6/g' diag_table.yaml_base > diag_table.yaml
test_expect_failure "freq is less than -1" '
mpirun -n 1 ../test_diag_yaml
'
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index aaed7f1dd8..ace739b1cb 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -737,7 +737,7 @@ diag_files:
corner2: 20, 15
corner3: 10, 25
corner4: 20, 25
-- file_name: wild_card_name%4yr%2mo%2dy%2hr
+- file_name: file6%4yr%2mo%2dy%2hr
freq: 6
freq_units: hours
time_units: hours
@@ -748,11 +748,11 @@ diag_files:
file_duration: 12
file_duration_units: hours
varlist:
- - module: atm_mod
- var_name: var4
+ - module: ocn_mod
+ var_name: var1
reduction: average
kind: r4
-- file_name: file6
+- file_name: file7
freq: 6
freq_units: hours
time_units: hours
@@ -762,6 +762,21 @@ diag_files:
var_name: var1
reduction: none
kind: r4
+- file_name: file8%4yr%2mo%2dy%2hr
+ freq: 1 1 1
+ freq_units: hours hours hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6 3 1
+ new_file_freq_units: hours hours hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12 3 9
+ file_duration_units: hours hours hours
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: average
+ kind: r4
_EOF
my_test_count=`expr $my_test_count + 1`
@@ -773,6 +788,57 @@ _EOF
test_expect_success "Test the modern diag manager end to end (test $my_test_count)" '
mpirun -n 6 ../test_modern_diag
'
+
+printf "&diag_manager_nml \n use_modern_diag = .true. \n use_clock_average = .true. \n /" | cat > input.nml
+cat <<_EOF > diag_table.yaml
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+
+diag_files:
+- file_name: file1_clock
+ freq: 1
+ freq_units: days
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: atm_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+_EOF
+
+my_test_count=`expr $my_test_count + 1`
+ test_expect_success "Test the modern diag manager with use_clock_average = .true. (test $my_test_count)" '
+ mpirun -n 1 ../test_flexible_time
+ '
+
+printf "&diag_manager_nml \n use_modern_diag = .true. \n use_clock_average = .false. \n /" | cat > input.nml
+cat <<_EOF > diag_table.yaml
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+
+diag_files:
+- file_name: file1_forecast
+ freq: 1
+ freq_units: days
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: atm_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+_EOF
+
+my_test_count=`expr $my_test_count + 1`
+ test_expect_success "Test the modern diag manager with use_clock_average = .false. (test $my_test_count)" '
+ mpirun -n 1 ../test_flexible_time
+ '
+printf "&diag_manager_nml \n use_modern_diag = .false. \n use_clock_average = .true. \n /" | cat > input.nml
+ test_expect_failure "Test if use_modern_diag = .false. and use_clock_average = .true. fails (test $my_test_count)" '
+ mpirun -n 1 ../test_flexible_time
+ '
+
else
my_test_count=`expr $my_test_count + 1`
test_expect_failure "test modern diag manager failure when compiled without -Duse-yaml flag (test $my_test_count)" '
diff --git a/test_fms/diag_manager/test_flexible_time.F90 b/test_fms/diag_manager/test_flexible_time.F90
new file mode 100644
index 0000000000..eb67eb345a
--- /dev/null
+++ b/test_fms/diag_manager/test_flexible_time.F90
@@ -0,0 +1,63 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This programs tests the flexible timing capability in the modern diag_manager
+program test_flexible_time
+use fms_mod, only: fms_init, fms_end
+use time_manager_mod, only: set_date, time_type, increment_date, set_calendar_type, &
+ JULIAN
+use diag_manager_mod, only: diag_manager_init, diag_axis_init, register_diag_field, &
+ diag_manager_set_time_end, diag_send_complete, diag_manager_end
+use mpp_mod, only: FATAL, mpp_error
+
+implicit none
+
+type(time_type) :: Time !< Time of the simulation
+type(time_type) :: Start_Time !< Start time of the simulation
+type(time_type) :: End_Time !< End Time of the simulation
+integer :: i
+integer :: id_z, id_var
+
+call fms_init()
+call set_calendar_type(JULIAN)
+call diag_manager_init
+
+!< Starting time of the simulation
+Start_Time = set_date(2,1,1,3,0,0) !02/01/01 hour 3
+
+!< Set up a dummy variable
+id_z = diag_axis_init('z', (/1. ,2. /), 'point_Z', 'z', long_name='point_Z')
+id_var = register_diag_field ('atm_mod', 'var1', (/id_z/), Start_Time, 'Var not domain decomposed', 'mullions')
+
+!< Set up the end of the simulation (i.e 2 days long)
+End_Time = set_date(2,1,3,3,0,0)
+call diag_manager_set_time_end(End_Time)
+
+!< Set up the simulation
+do i=1,48
+ !< Increase the time by 1 hour
+ Time = increment_date(Start_Time, 0, 0, 0, i, 0, 0)
+ call diag_send_complete(Time)
+enddo
+
+call diag_manager_end(End_Time)
+
+call fms_end()
+
+end program test_flexible_time
From eb09d9eee57da7d92462384d2e11464a4fe4967d Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Wed, 25 Jan 2023 12:53:55 -0500
Subject: [PATCH 077/168] feat: modern diag add diag_accept_data (#1088)
---
diag_manager/diag_manager.F90 | 22 ++-
diag_manager/fms_diag_field_object.F90 | 177 ++++++++++++++++++++++++-
diag_manager/fms_diag_object.F90 | 114 +++++++++++++++-
3 files changed, 297 insertions(+), 16 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 855eaa29a6..29bcee9aa4 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -1571,7 +1571,7 @@ END FUNCTION send_data_2d
LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
& mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
INTEGER, INTENT(in) :: diag_field_id
- CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field
+ CLASS(*), DIMENSION(:,:,:), INTENT(in), TARGET, CONTIGUOUS :: field
CLASS(*), INTENT(in), OPTIONAL :: weight
TYPE (time_type), INTENT(in), OPTIONAL :: time
INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
@@ -1638,7 +1638,6 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
CHARACTER(len=128) :: error_string, error_string1
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field
-
REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask
REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! null() !< i8 4d remapped pointer
! If diag_field_id is < 0 it means that this field is not registered, simply return
IF ( diag_field_id <= 0 ) THEN
diag_send_data = .FALSE.
@@ -1678,6 +1677,12 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
& SIZE(field,1), SIZE(field,2), SIZE(field,3), status
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN
END IF
+ if (use_modern_diag) then !> Set up array lengths for remapping
+ ie = SIZE(field,1)
+ je = SIZE(field,2)
+ ke = SIZE(field,3)
+ field_modern(1:ie,1:je,1:ke,1:1) => field
+ endif
SELECT TYPE (field)
TYPE IS (real(kind=r4_kind))
field_out = field
@@ -1685,9 +1690,15 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
field_out = real(field)
CLASS DEFAULT
CALL error_mesg ('diag_manager_mod::send_data_3d',&
- & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ & 'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//&
+ & 'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', FATAL)
END SELECT
-
+ ! Split old and modern2023 here
+ modern_if: iF (use_modern_diag) then
+ send_data_3d = fms_diag_object%fms_diag_accept_data(diag_field_id, field_modern, time, is_in, js_in, ks_in, &
+ & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
+ deallocate (field_modern)
+ elSE ! modern_if
! oor_mask is only used for checking out of range values.
ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status)
IF ( status .NE. 0 ) THEN
@@ -3372,6 +3383,7 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
+ endIF modern_if
END FUNCTION diag_send_data
!> @return true if send is successful
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index bf5b244d04..d154c9cfdc 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -17,7 +17,7 @@ module fms_diag_field_object_mod
use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, &
& find_diag_field, get_num_unique_fields
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
- & fmsDiagAxisContainer_type
+ & fmsDiagAxisContainer_type, fmsDiagFullAxis_Type
use time_manager_mod, ONLY: time_type
!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
@@ -65,7 +65,12 @@ module fms_diag_field_object_mod
integer, allocatable, private :: area, volume !< The Area and Volume
class(*), allocatable, private :: missing_value !< The missing fill value
class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data
- contains
+ class(*), allocatable, dimension(:,:,:,:), private :: data_buffer !< Buffer for field data
+ logical, allocatable, private :: data_buffer_allocated !< True if the buffer has
+ !! been allocated
+ logical, allocatable, private :: math_needs_to_be_done !< If true, do math
+ !! functions. False when done.
+ contains
! procedure :: send_data => fms_send_data !!TODO
! Get ID functions
procedure :: get_id => fms_diag_get_id
@@ -74,6 +79,8 @@ module fms_diag_field_object_mod
procedure :: register => fms_register_diag_field_obj !! Merely initialize fields.
procedure :: setID => set_diag_id
procedure :: set_type => set_vartype
+ procedure :: set_data_buffer => set_data_buffer
+ procedure :: set_math_needs_to_be_done => set_math_needs_to_be_done
procedure :: add_attribute => diag_field_add_attribute
procedure :: vartype_inq => what_is_vartype
! Check functions
@@ -104,6 +111,7 @@ module fms_diag_field_object_mod
procedure :: has_volume
procedure :: has_missing_value
procedure :: has_data_RANGE
+ procedure :: has_data_buffer
! Get functions
procedure :: get_attributes
procedure :: get_static
@@ -128,6 +136,7 @@ module fms_diag_field_object_mod
procedure :: dump_field_obj
procedure :: get_domain
procedure :: get_type_of_domain
+ procedure :: get_math_needs_to_be_done
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagField_type) :: null_ob
@@ -359,7 +368,117 @@ subroutine set_vartype(objin , var)
" r8, r4, i8, i4, or string.", warning)
end select
end subroutine set_vartype
-
+!> Allocates the data buffer in the field object.
+!! Adds the input data to the buffered data.
+subroutine set_data_buffer (this, input_data, diag_axis, is, js, ks, ie, je, ke)
+ class (fmsDiagField_type) , intent(inout):: this !< The field object
+ class(*), dimension(:,:,:,:), intent(in) :: input_data !< The input array
+ class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis
+ integer :: is, js, ks !< Starting indicies of the field_data
+ integer :: ie, je, ke !< Ending indicied of the field_data
+!> Allocate the buffer if it is not allocated
+ if (.not.allocated(this%data_buffer_allocated)) this%data_buffer_allocated = .false.
+ if (.not.this%data_buffer_allocated) &
+ this%data_buffer_allocated = allocate_data_buffer(this, input_data, diag_axis)
+ if (.not.this%data_buffer_allocated) &
+ call mpp_error ("set_data_buffer", "The data buffer for the field "//trim(this%varname)//" was unable to be "//&
+ "allocated.", FATAL)
+
+!> Buffer a copy of the data
+ select type (input_data)
+ type is (real(kind=r4_kind))
+ select type (db => this%data_buffer)
+ type is (real(kind=r4_kind))
+ db(is:ie, js:je, ks:ke, :) = input_data
+ end select
+ type is (real(kind=r8_kind))
+ select type (db => this%data_buffer)
+ type is (real(kind=r8_kind))
+ db(is:ie, js:je, ks:ke, :) = input_data
+ end select
+ type is (integer(kind=i4_kind))
+ select type (db => this%data_buffer)
+ type is (integer(kind=i4_kind))
+ db(is:ie, js:je, ks:ke, :) = input_data
+ end select
+ type is (integer(kind=i8_kind))
+ select type (db => this%data_buffer)
+ type is (integer(kind=i8_kind))
+ db(is:ie, js:je, ks:ke, :) = input_data
+ end select
+ class default
+ call mpp_error ("set_data_buffer", "The data input to set_data_buffer for "//&
+ trim(this%varname)//" does not match the buffer for the field object", FATAL)
+ end select
+end subroutine set_data_buffer
+!> Allocates the global data buffer for a given field using a single thread. Returns true when the
+!! buffer is allocated
+logical function allocate_data_buffer(this, input_data, diag_axis)
+ class (fmsDiagField_type), target, intent(inout):: this !< The field object
+ class(*), dimension(:,:,:,:), intent(in) :: input_data !< The input array
+ class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis
+ integer :: naxes !< The number of axes in the field
+ integer, parameter :: ndims = 4
+ integer, dimension (ndims) :: length !< The length of an axis
+ integer :: a !< For looping through axes
+ integer, pointer :: axis_id !< The axis ID
+!!TODO:
+!! Use global data
+!! use is, ie, js, je, ks, ke, ls, le
+!! Use the axis to get the size
+!> Initialize the axis lengths to 1. Any dimension that does not have an axis will have a length
+!! of 1.
+ length = 1
+!> Get the number of axes
+ naxes = size(this%axis_ids)
+!> Loop through the axes and get the length of the axes for this field
+ axis_loop: do a = 1,naxes
+ axis_id => this%axis_ids(a)
+ select type (axis => diag_axis(axis_id)%axis)
+ type is (fmsDiagFullAxis_type)
+ length(a) = axis%axis_length()
+ end select
+ enddo axis_loop
+!> On a single thread, allocate the data buffer to the correct kind and size
+!$omp single
+ select type (input_data)
+ type is (real(r4_kind))
+ if (.not.allocated(this%data_buffer)) allocate(real(kind=r4_kind) :: this%data_buffer( &
+ length(1),&
+ length(2),&
+ length(3),&
+ length(4)))
+ type is (real(r8_kind))
+ if (.not.allocated(this%data_buffer)) allocate(real(kind=r8_kind) :: this%data_buffer( &
+ length(1),&
+ length(2),&
+ length(3),&
+ length(4)))
+ type is (integer(i4_kind))
+ if (.not.allocated(this%data_buffer)) allocate(integer(kind=i4_kind) :: this%data_buffer( &
+ length(1),&
+ length(2),&
+ length(3),&
+ length(4)))
+ type is (integer(i8_kind))
+ if (.not.allocated(this%data_buffer)) allocate(integer(kind=i8_kind) :: this%data_buffer( &
+ length(1),&
+ length(2),&
+ length(3),&
+ length(4)))
+ class default
+ call mpp_error ("allocate_data_buffer","The data input to set_data_buffer for "//&
+ trim(this%varname)//" is not a supported type", FATAL)
+ end select
+!$omp end single
+ allocate_data_buffer = allocated(this%data_buffer)
+end function allocate_data_buffer
+!> Sets the flag saying that the math functions need to be done
+subroutine set_math_needs_to_be_done (this, math_needs_to_be_done)
+ class (fmsDiagField_type) , intent(inout):: this
+ logical, intent (in) :: math_needs_to_be_done !< Flag saying that the math functions need to be done
+ this%math_needs_to_be_done = math_needs_to_be_done
+end subroutine set_math_needs_to_be_done
!> \brief Prints to the screen what type the diag variable is
subroutine what_is_vartype(this)
class (fmsDiagField_type) , intent(inout):: this
@@ -788,6 +907,51 @@ pure function get_type_of_domain (this) &
rslt = this%type_of_domain
end function get_type_of_domain
+!> @brief Gets a fields data buffer
+!! @return a pointer to the data buffer
+function get_data_buffer (this) &
+result(rslt)
+ class (fmsDiagField_type), target, intent(in) :: this !< diag field
+ class(*),dimension(:,:,:,:), pointer :: rslt !< The field's data buffer
+
+ if (allocated(this%data_buffer)) then
+ rslt => this%data_buffer
+ else
+ rslt => null()
+ endif
+! select type (db => this%data_buffer)
+! type is (real(kind=r4_kind))
+! allocate (real(kind=r4_kind) :: rslt(size(this%data_buffer,1), &
+! size(this%data_buffer,2), &
+! size(this%data_buffer,3), &
+! size(this%data_buffer,4) ))
+! rslt = this%data_buffer
+! type is (real(kind=r8_kind))
+! allocate (real(kind=r8_kind) :: rslt(size(this%data_buffer,1), &
+! size(this%data_buffer,2), &
+! size(this%data_buffer,3), &
+! size(this%data_buffer,4) ))
+! rslt = this%data_buffer
+! type is (integer(kind=i4_kind))
+! allocate (integer(kind=i4_kind) :: rslt(size(this%data_buffer,1), &
+! size(this%data_buffer,2), &
+! size(this%data_buffer,3), &
+! size(this%data_buffer,4) ))
+! rslt = this%data_buffer
+! type is (integer(kind=i8_kind))
+! allocate (integer(kind=i8_kind) :: rslt(size(this%data_buffer,1), &
+! size(this%data_buffer,2), &
+! size(this%data_buffer,3), &
+! size(this%data_buffer,4) ))
+! rslt = this%data_buffer
+! end select
+end function get_data_buffer
+!> Gets the flag telling if the math functions need to be done
+!! \return Copy of math_needs_to_be_done flag
+pure logical function get_math_needs_to_be_done(this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ get_math_needs_to_be_done = this%math_needs_to_be_done
+end function get_math_needs_to_be_done
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!! Allocation checks
@@ -936,7 +1100,12 @@ pure logical function has_data_RANGE (this)
class (fmsDiagField_type), intent(in) :: this !< diag object
has_data_RANGE = allocated(this%data_RANGE)
end function has_data_RANGE
-
+!> @brief Checks if obj%data_buffer is allocated
+!! @return true if obj%data_buffer is allocated
+pure logical function has_data_buffer (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ has_data_buffer = allocated(this%data_buffer)
+end function has_data_buffer
!> @brief Add a attribute to the diag_obj using the diag_field_id
subroutine diag_field_add_attribute(this, att_name, att_value)
class (fmsDiagField_type), intent (inout) :: this !< The field object
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 95e92694d1..416aac72d3 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -33,6 +33,9 @@ module fms_diag_object_mod
&fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type
use fms_diag_buffer_mod
#endif
+#if defined(_OPENMP)
+use omp_lib
+#endif
use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d
implicit none
private
@@ -69,6 +72,7 @@ module fms_diag_object_mod
procedure :: fms_get_axis_length
procedure :: fms_get_diag_field_id_from_name
procedure :: fms_get_axis_name_from_id
+ procedure :: fms_diag_accept_data
procedure :: fms_diag_send_complete
#ifdef use_yaml
procedure :: get_diag_buffer
@@ -425,25 +429,121 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n
#endif
end function fms_diag_axis_init
+!> Accepts data from the send_data functions. If this is in an openmp region with more than
+!! one thread, the data is buffered in the field object and processed later. If only a single thread
+!! is being used, then the processing can be done and stored in the buffer object. The hope is that
+!! the increase in memory footprint related to buffering can be handled by the shared memory of the
+!! multithreaded case.
+!! \note If some of the diag manager is offloaded in the future, then it should be treated similarly
+!! to the multi-threaded option for processing later
+logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is_in, js_in, ks_in, &
+ mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
+ class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
+ INTEGER, INTENT(in) :: diag_field_id !< The ID of the input diagnostic field
+ CLASS(*), DIMENSION(:,:,:,:), INTENT(in) :: field_data !< The data for the input diagnostic
+ CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight used for averaging
+ TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current time
+ INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in !< Indicies for the variable
+ LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask !< The location of the mask
+ CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask !< The masking values
+ CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< An error message returned
+ integer :: is, js, ks !< Starting indicies of the field_data
+ integer :: ie, je, ke !< Ending indicied of the field_data
+ integer :: n1, n2, n3 !< Size of the 3 indicies of the field data
+ integer :: omp_num_threads !< Number of openmp threads
+ integer :: omp_level !< The openmp active level
+ logical :: buffer_the_data !< True if the user selects to buffer the data and run the calculations
+ !! later. \note This is experimental
+#ifndef use_yaml
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
+!> Does the user want to push off calculations until send_diag_complete?
+ buffer_the_data = .false.
+!> initialize the number of threads and level to be 0
+ omp_num_threads = 0
+ omp_level = 0
+#if defined(_OPENMP)
+ omp_num_threads = omp_get_num_threads()
+ omp_level = omp_get_level()
+ buffer_the_data = (omp_num_threads > 1 .AND. omp_level > 0)
+#endif
+!If this is true, buffer data
+ main_if: if (buffer_the_data) then
+!> Calculate the i,j,k start and end
+ ! If is, js, or ks not present default them to 1
+ is = 1
+ js = 1
+ ks = 1
+ IF ( PRESENT(is_in) ) is = is_in
+ IF ( PRESENT(js_in) ) js = js_in
+ IF ( PRESENT(ks_in) ) ks = ks_in
+ n1 = SIZE(field_data, 1)
+ n2 = SIZE(field_data, 2)
+ n3 = SIZE(field_data, 3)
+ ie = is+n1-1
+ je = js+n2-1
+ ke = ks+n3-1
+ IF ( PRESENT(ie_in) ) ie = ie_in
+ IF ( PRESENT(je_in) ) je = je_in
+ IF ( PRESENT(ke_in) ) ke = ke_in
+!> Buffer the data
+ call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, FMS_diag_object%diag_axis,&
+ is, js, ks, ie, je, ke)
+ call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.)
+ fms_diag_accept_data = .TRUE.
+ return
+ else
+!!TODO: Loop through fields and do averages/math functions
+ call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.)
+ fms_diag_accept_data = .TRUE.
+ return
+ end if main_if
+!> Return false if nothing is done
+ fms_diag_accept_data = .FALSE.
+ return
+#endif
+end function fms_diag_accept_data
+!! TODO: This entire routine
!> @brief Loops through all the files, open the file, writes out axis and
!! variable metadata and data when necessary.
subroutine fms_diag_send_complete(this, time_step)
class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object
TYPE (time_type), INTENT(in) :: time_step !< The current model time
- integer :: i !< For do loops
+ integer :: ifile !< For file loops
+ integer :: ifield !< For field loops
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience)
-
+ class(fmsDiagField_type), pointer :: diag_field !< Pointer to this%FMS_diag_files(i)%diag_field(j)
logical :: file_is_opened_this_time_step !< True if the file was opened in this time_step
!! If true the metadata will need to be written
-
- do i = 1, size(this%FMS_diag_files)
- diag_file => this%FMS_diag_files(i)
-
+ logical :: math !< True if the math functions need to be called using the data buffer,
+ !! False if the math functions were done in accept_data
+ integer, dimension(:), allocatable :: file_field_ids !< Array of field IDs for a file
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! In the future, this may be parallelized for offloading
+ file_loop: do ifile = 1, size(this%FMS_diag_files)
+ diag_file => this%FMS_diag_files(ifile)
+ field_outer_if: if (size(diag_file%FMS_diag_file%get_field_ids()) .ge. 1) then
+ allocate (file_field_ids(size(diag_file%FMS_diag_file%get_field_ids() )))
+ file_field_ids = diag_file%FMS_diag_file%get_field_ids()
+ field_loop: do ifield = 1, size(file_field_ids)
+ diag_field => this%FMS_diag_fields(file_field_ids(ifield))
+ !> Check if math needs to be done
+! math = diag_field%get_math_needs_to_be_done()
+ math = .false. !TODO: replace this with real thing
+ calling_math: if (math) then
+ !!TODO: call math functions !!
+ endif calling_math
+ !> Clean up, clean up, everybody everywhere
+ if (associated(diag_field)) nullify(diag_field)
+ enddo field_loop
+ !> Clean up, clean up, everybody do your share
+ if (allocated(file_field_ids)) deallocate(file_field_ids)
+ endif field_outer_if
!< Go away if the file is a subregional file and the current PE does not have any data for it
if (.not. diag_file%writing_on_this_pe()) cycle
@@ -462,7 +562,7 @@ subroutine fms_diag_send_complete(this, time_step)
call diag_file%update_current_new_file_freq_index(time_step)
if (diag_file%is_time_to_close_file(time_step)) call diag_file%close_diag_file
endif
- enddo
+ enddo file_loop
#endif
end subroutine fms_diag_send_complete
From 4c736d4c266c7643a52c7b6b91d50d027a07ef50 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 31 Jan 2023 07:12:03 -0500
Subject: [PATCH 078/168] feat: modern diag Add some of the io for the field's
metadata (#1102)
---
diag_manager/diag_manager.F90 | 2 +-
diag_manager/fms_diag_axis_object.F90 | 49 ++-
diag_manager/fms_diag_field_object.F90 | 393 ++++++++++++++++----
diag_manager/fms_diag_file_object.F90 | 115 +++++-
diag_manager/fms_diag_object.F90 | 90 +++--
diag_manager/fms_diag_yaml.F90 | 36 +-
test_fms/diag_manager/test_diag_manager2.sh | 6 +
7 files changed, 563 insertions(+), 128 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 29bcee9aa4..bae77f2439 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -3836,7 +3836,7 @@ SUBROUTINE diag_manager_end(time)
if (allocated(fnum_for_domain)) deallocate(fnum_for_domain)
if (use_modern_diag) then
- call fms_diag_object%diag_end()
+ call fms_diag_object%diag_end(time)
endif
END SUBROUTINE diag_manager_end
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index a2030e91ee..30abd44888 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -93,6 +93,7 @@ module fms_diag_axis_object_mod
contains
procedure :: get_parent_axis_id
procedure :: get_subaxes_id
+ procedure :: get_axis_name
procedure :: write_axis_metadata
procedure :: write_axis_data
END TYPE fmsDiagAxis_type
@@ -143,7 +144,6 @@ module fms_diag_axis_object_mod
PROCEDURE :: add_axis_attribute
PROCEDURE :: register => register_diag_axis_obj
PROCEDURE :: axis_length => get_axis_length
- PROCEDURE :: get_axis_name
PROCEDURE :: set_edges_name
PROCEDURE :: set_axis_id
PROCEDURE :: get_compute_domain
@@ -289,18 +289,23 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
!< Add the axis as a dimension in the netcdf file based on the type of axis_domain and the fileobj type
select type (fileobj)
+ !< The register_field calls need to be inside the select type block so that it can go inside the correct
+ !! register_field interface
type is (FmsNetcdfFile_t)
!< Here the axis is not domain decomposed (i.e z_axis)
call register_axis(fileobj, axis_name, axis_length)
+ call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
type is (FmsNetcdfDomainFile_t)
select case (diag_axis%type_of_domain)
case (NO_DOMAIN)
!< Here the fileobj is domain decomposed, but the axis is not
!! Domain decomposed fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
call register_axis(fileobj, axis_name, axis_length)
+ call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
case (TWO_D_DOMAIN)
!< Here the axis is domain decomposed
call register_axis(fileobj, axis_name, diag_axis%cart_name, domain_position=diag_axis%domain_position)
+ call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
end select
type is (FmsNetcdfUnstructuredDomainFile_t)
select case (diag_axis%type_of_domain)
@@ -308,15 +313,16 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
!< Here the fileobj is in the unstructured domain, but the axis is not
!< Unstructured domain fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
call register_axis(fileobj, axis_name, axis_length)
+ call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
case (UG_DOMAIN)
!< Here the axis is in a unstructured domain
call register_axis(fileobj, axis_name)
+ call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
end select
end select
- !< Add the axis as a variable and write its metada
- call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
- call register_variable_attribute(fileobj, axis_name, "longname", diag_axis%long_name, &
+ !< Write its metadata
+ call register_variable_attribute(fileobj, axis_name, "long_name", diag_axis%long_name, &
str_len=len_trim(diag_axis%long_name))
if (diag_axis%cart_name .NE. "N") &
@@ -418,16 +424,6 @@ function get_axis_length(this) &
end function
- !> @brief Get the name of the axis
- !> @return axis name
- pure function get_axis_name(this) &
- result (axis_name)
- class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
- CHARACTER(len=:), ALLOCATABLE :: axis_name
-
- axis_name = this%axis_name
- end function
-
!> @brief Set the axis_id
subroutine set_axis_id(this, axis_id)
class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj
@@ -642,6 +638,31 @@ logical function fms_diag_axis_object_end(axis_array)
end function fms_diag_axis_object_end
+ !< @brief Determine the axis name of an axis_object
+ !! @return The name of the axis
+ !! @note This function may be called from the field object (i.e. to determine the dimension names for io),
+ !! The field object only contains the parent axis ids, because the subregion is defined in a per file basis,
+ !! so the is_regional flag is needed so that the correct axis name can be used
+ pure function get_axis_name(this, is_regional) &
+ result(axis_name)
+ class(fmsDiagAxis_type), intent(in) :: this !< Axis object
+ logical, intent(in), optional :: is_regional !< Flag indicating if the axis is regional
+
+ character(len=:), allocatable :: axis_name
+
+ select type (this)
+ type is (fmsDiagFullAxis_type)
+ axis_name = this%axis_name
+ if (present(is_regional)) then
+ if (is_regional) then
+ if (this%cart_name .eq. "X" .or. this%cart_name .eq. "Y") axis_name = axis_name//"_sub01"
+ endif
+ endif
+ type is (fmsDiagSubAxis_type)
+ axis_name = this%subaxis_name
+ end select
+ end function get_axis_name
+
!> @brief Check if a cart_name is valid and crashes if it isn't
subroutine check_if_valid_cart_name(cart_name)
character(len=*), intent(in) :: cart_name
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index d154c9cfdc..30f8a45412 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -12,13 +12,17 @@ module fms_diag_field_object_mod
use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN
use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
- &DIAG_FIELD_NOT_FOUND
+ &DIAG_FIELD_NOT_FOUND, avg_name, time_average, time_min, time_max, &
+ &time_none, time_diurnal, time_power, time_rms, time_sum
+use fms_string_utils_mod, only: int2str=>string
use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe
use fms_diag_yaml_mod, only: diagYamlFilesVar_type, get_diag_fields_entries, get_diag_files_id, &
- & find_diag_field, get_num_unique_fields
+ & find_diag_field, get_num_unique_fields, diag_yaml
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
& fmsDiagAxisContainer_type, fmsDiagFullAxis_Type
use time_manager_mod, ONLY: time_type
+use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, register_field, &
+ register_variable_attribute
!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
!!! & get_ticks_per_second
@@ -136,6 +140,11 @@ module fms_diag_field_object_mod
procedure :: dump_field_obj
procedure :: get_domain
procedure :: get_type_of_domain
+ procedure :: set_file_ids
+ procedure :: get_dimnames
+ procedure :: get_var_skind
+ procedure :: get_longname_to_write
+ procedure :: write_field_metadata
procedure :: get_math_needs_to_be_done
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -229,9 +238,14 @@ subroutine fms_register_diag_field_obj &
!> get the optional arguments if included and the diagnostic is in the diag table
if (present(longname)) this%longname = trim(longname)
if (present(standname)) this%standname = trim(standname)
- if (present(units)) this%units = trim(units)
+
+ !> Ignore the units if they are set to "none". This is to reproduce previous diag_manager behavior
+ if (present(units)) then
+ if (trim(units) .ne. "none") this%units = trim(units)
+ endif
if (present(realm)) this%realm = trim(realm)
if (present(interp_method)) this%interp_method = trim(interp_method)
+
if (present(tile_count)) then
allocate(this%tile_count)
this%tile_count = tile_count
@@ -251,22 +265,16 @@ subroutine fms_register_diag_field_obj &
allocate(integer(kind=i8_kind) :: this%missing_value)
this%missing_value = missing_value
type is (real(kind=r4_kind))
- allocate(integer(kind=r4_kind) :: this%missing_value)
+ allocate(real(kind=r4_kind) :: this%missing_value)
this%missing_value = missing_value
type is (real(kind=r8_kind))
- allocate(integer(kind=r8_kind) :: this%missing_value)
+ allocate(real(kind=r8_kind) :: this%missing_value)
this%missing_value = missing_value
class default
call mpp_error("fms_register_diag_field_obj", &
"The missing value passed to register a diagnostic is not a r8, r4, i8, or i4",&
FATAL)
end select
- else
- allocate(real :: this%missing_value)
- select type (miss => this%missing_value)
- type is (real)
- miss = real(CMOR_MISSING_VALUE)
- end select
endif
if (present(varRANGE)) then
@@ -288,12 +296,6 @@ subroutine fms_register_diag_field_obj &
"The varRange passed to register a diagnostic is not a r8, r4, i8, or i4",&
FATAL)
end select
- else
- allocate(real :: this%data_RANGE(2))
- select type (varRANGE => this%data_RANGE)
- type is (real)
- varRANGE = real(CMOR_MISSING_VALUE)
- end select
endif
if (present(area)) then
@@ -809,64 +811,104 @@ end function get_volume
!> @brief Gets missing_value
!! @return copy of The missing value
-function get_missing_value (this) &
+!! @note Netcdf requires the type of the variable and the type of the missing_value and _Fillvalue to be the same
+!! var_type is the type of the variable which may not be in the same type as the missing_value in the register call
+!! For example, if compiling with r8 but the in diag_table.yaml the kind is r4
+function get_missing_value (this, var_type) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: this !< diag object
- class(*),allocatable :: rslt
- if (allocated(this%missing_value)) then
- select type (miss => this%missing_value)
- type is (integer(kind=i4_kind))
- allocate (integer(kind=i4_kind) :: rslt)
- rslt = miss
- type is (integer(kind=i8_kind))
- allocate (integer(kind=i8_kind) :: rslt)
- rslt = miss
- type is (real(kind=r4_kind))
- allocate (integer(kind=i4_kind) :: rslt)
- rslt = miss
- type is (real(kind=r8_kind))
- allocate (integer(kind=i4_kind) :: rslt)
- rslt = miss
- class default
- call mpp_error ("get_missing_value", &
- "The missing value is not a r8, r4, i8, or i4",&
- FATAL)
- end select
- else
- call mpp_error ("get_missing_value", &
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ integer, intent(in) :: var_type !< The type of the variable as it will writen to the netcdf file
+ !! and the missing value is return as
+
+ class(*),allocatable :: rslt
+
+ if (.not. allocated(this%missing_value)) then
+ call mpp_error ("get_missing_value", &
"The missing value is not allocated", FATAL)
- endif
+ endif
+
+ !< The select types are needed so that the missing_value can be correctly converted and copied as the needed variable
+ !! type
+ select case (var_type)
+ case (r4)
+ allocate (real(kind=r4_kind) :: rslt)
+ select type (miss => this%missing_value)
+ type is (real(kind=r4_kind))
+ select type (rslt)
+ type is (real(kind=r4_kind))
+ rslt = real(miss, kind=r4_kind)
+ end select
+ type is (real(kind=r8_kind))
+ select type (rslt)
+ type is (real(kind=r4_kind))
+ rslt = real(miss, kind=r4_kind)
+ end select
+ end select
+ case (r8)
+ allocate (real(kind=r8_kind) :: rslt)
+ select type (miss => this%missing_value)
+ type is (real(kind=r4_kind))
+ select type (rslt)
+ type is (real(kind=r8_kind))
+ rslt = real(miss, kind=r8_kind)
+ end select
+ type is (real(kind=r8_kind))
+ select type (rslt)
+ type is (real(kind=r8_kind))
+ rslt = real(miss, kind=r8_kind)
+ end select
+ end select
+ end select
+
end function get_missing_value
!> @brief Gets data_range
!! @return copy of the data range
-function get_data_RANGE (this) &
+!! @note Netcdf requires the type of the variable and the type of the range to be the same
+!! var_type is the type of the variable which may not be in the same type as the range in the register call
+!! For example, if compiling with r8 but the in diag_table.yaml the kind is r4
+function get_data_RANGE (this, var_type) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: this !< diag object
- class(*),allocatable :: rslt(:)
- if (allocated(this%data_RANGE)) then
- select type (r => this%data_RANGE)
- type is (integer(kind=i4_kind))
- allocate (integer(kind=i4_kind) :: rslt(2))
- rslt = r
- type is (integer(kind=i8_kind))
- allocate (integer(kind=i8_kind) :: rslt(2))
- rslt = r
- type is (real(kind=r4_kind))
- allocate (integer(kind=i4_kind) :: rslt(2))
- rslt = r
- type is (real(kind=r8_kind))
- allocate (integer(kind=i4_kind) :: rslt(2))
- rslt = r
- class default
- call mpp_error ("get_data_RANGE", &
- "The data_RANGE value is not a r8, r4, i8, or i4",&
- FATAL)
- end select
- else
- call mpp_error ("get_data_RANGE", &
- "The data_RANGE value is not allocated", FATAL)
- endif
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ integer, intent(in) :: var_type !< The type of the variable as it will writen to the netcdf file
+ !! and the data_range is returned as
+ class(*),allocatable :: rslt(:)
+
+ if ( .not. allocated(this%data_RANGE)) call mpp_error ("get_data_RANGE", &
+ "The data_RANGE value is not allocated", FATAL)
+
+ !< The select types are needed so that the range can be correctly converted and copied as the needed variable
+ !! type
+ select case (var_type)
+ case (r4)
+ allocate (real(kind=r4_kind) :: rslt(2))
+ select type (r => this%data_RANGE)
+ type is (real(kind=r4_kind))
+ select type (rslt)
+ type is (real(kind=r4_kind))
+ rslt = real(r, kind=r4_kind)
+ end select
+ type is (real(kind=r8_kind))
+ select type (rslt)
+ type is (real(kind=r4_kind))
+ rslt = real(r, kind=r4_kind)
+ end select
+ end select
+ case (r8)
+ allocate (real(kind=r8_kind) :: rslt(2))
+ select type (r => this%data_RANGE)
+ type is (real(kind=r4_kind))
+ select type (rslt)
+ type is (real(kind=r8_kind))
+ rslt = real(r, kind=r8_kind)
+ end select
+ type is (real(kind=r8_kind))
+ select type (rslt)
+ type is (real(kind=r8_kind))
+ rslt = real(r, kind=r8_kind)
+ end select
+ end select
+ end select
end function get_data_RANGE
!> @brief Gets axis_ids
@@ -907,6 +949,178 @@ pure function get_type_of_domain (this) &
rslt = this%type_of_domain
end function get_type_of_domain
+
+!> @brief Set the file ids of the files that the field belongs to
+subroutine set_file_ids(this, file_ids)
+ class (fmsDiagField_type), intent(inout) :: this !< diag field
+ integer, intent(in) :: file_ids(:) !< File_ids to add
+
+ allocate(this%file_ids(size(file_ids)))
+ this%file_ids = file_ids
+end subroutine set_file_ids
+
+!> @brief Get the kind of the variable based on the yaml
+!! @return A string indicating the kind of the variable (as it is used in fms2_io)
+pure function get_var_skind(this, field_yaml) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: this !< diag field
+ type(diagYamlFilesVar_type), intent(in) :: field_yaml !< The corresponding yaml of the field
+
+ character(len=:), allocatable :: rslt
+
+ integer :: var_kind !< The integer corresponding to the kind of the variable (i4, i8, r4, r8)
+
+ var_kind = field_yaml%get_var_kind()
+ select case (var_kind)
+ case (r4)
+ rslt = "float"
+ case (r8)
+ rslt = "double"
+ case (i4)
+ rslt = "int"
+ case (i8)
+ rslt = "int64"
+ end select
+
+end function get_var_skind
+
+!> @brief Determine the long name to write for the field
+!! @return Long name to write
+pure function get_longname_to_write(this, field_yaml) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: this !< diag field
+ type(diagYamlFilesVar_type), intent(in) :: field_yaml !< The corresponding yaml of the field
+
+ character(len=:), allocatable :: rslt
+
+ rslt = field_yaml%get_var_longname() !! This is the long name defined in the yaml
+ if (rslt .eq. "") then !! If the long name is not defined in the yaml, use the long name in the
+ !! register_diag_field
+ rslt = this%get_longname()
+ endif
+end function get_longname_to_write
+
+!> @brief Determine the dimension names to use when registering the field to fms2_io
+subroutine get_dimnames(this, diag_axis, unlim_dimname, dimnames, is_regional)
+ class (fmsDiagField_type), target, intent(inout) :: this !< diag field
+ class(fmsDiagAxisContainer_type), target, intent(in) :: diag_axis(:) !< Diag_axis object
+ character(len=*), intent(in) :: unlim_dimname !< The name of unlimited dimension
+ character(len=120), allocatable, intent(out) :: dimnames(:) !< Array of the dimension names
+ !! for the field
+ logical, intent(in) :: is_regional !< Flag indicating if the field is regional
+
+ integer :: i !< For do loops
+ integer :: naxis !< Number of axis for the field
+ class(fmsDiagAxisContainer_type), pointer :: axis_ptr !diag_axis(this%axis_ids(i), for convenience
+
+ !TODO there may be more stuff needed for the diurnal axis
+ if (this%is_static()) then
+ naxis = size(this%axis_ids)
+ else
+ naxis = size(this%axis_ids) + 1 !< Adding 1 more dimension for the unlimited dimension
+ endif
+
+ allocate(dimnames(naxis))
+
+ do i = 1, size(this%axis_ids)
+ axis_ptr => diag_axis(this%axis_ids(i))
+ dimnames(i) = axis_ptr%axis%get_axis_name(is_regional)
+ enddo
+
+ !< The last dimension is always the unlimited dimensions
+ if (.not. this%is_static()) dimnames(naxis) = unlim_dimname
+
+end subroutine get_dimnames
+
+!> @brief Wrapper for the register_field call. The select types are needed so that the code can go
+!! in the correct interface
+subroutine register_field_wrap(fileobj, varname, vartype, dimensions)
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write to
+ character(len=*), INTENT(IN) :: varname !< Name of the variable
+ character(len=*), INTENT(IN) :: vartype !< The type of the variable
+ character(len=*), optional, INTENT(IN) :: dimensions(:) !< The dimension names of the field
+
+ select type(fileobj)
+ type is (FmsNetcdfFile_t)
+ call register_field(fileobj, varname, vartype, dimensions)
+ type is (FmsNetcdfDomainFile_t)
+ call register_field(fileobj, varname, vartype, dimensions)
+ type is (FmsNetcdfUnstructuredDomainFile_t)
+ call register_field(fileobj, varname, vartype, dimensions)
+ end select
+end subroutine register_field_wrap
+
+!> @brief Write the field's metadata to the file
+subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unlim_dimname, is_regional, &
+ cell_measures)
+ class (fmsDiagField_type), target, intent(inout) :: this !< diag field
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write to
+ integer, intent(in) :: file_id !< File id of the file to write to
+ integer, intent(in) :: yaml_id !< Yaml id of the yaml entry of this field
+ class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
+ character(len=*), intent(in) :: unlim_dimname !< The name of the unlimited dimension
+ logical, intent(in) :: is_regional !< Flag indicating if the field is regional
+ character(len=*), intent(inout) :: cell_measures
+
+ type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry
+ character(len=:), allocatable :: var_name !< Variable name
+ character(len=:), allocatable :: long_name !< Longname to write
+ character(len=:), allocatable :: units !< Units of the field to write
+ character(len=120), allocatable :: dimnames(:) !< Dimension names of the field
+
+ field_yaml => diag_yaml%get_diag_field_from_id(yaml_id)
+ var_name = field_yaml%get_var_outname()
+
+ if (allocated(this%axis_ids)) then
+ call this%get_dimnames(diag_axis, unlim_dimname, dimnames, is_regional)
+ call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml), dimnames)
+ else
+ call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml))
+ endif
+
+ !TODO Not sure what the old diag_manager did if long_name was never defined
+ long_name = this%get_longname_to_write(field_yaml)
+ call register_variable_attribute(fileobj, var_name, "long_name", long_name, str_len=len_trim(long_name))
+
+ units = this%get_units()
+ if (units .ne. diag_null_string) &
+ call register_variable_attribute(fileobj, var_name, "units", units, str_len=len_trim(units))
+
+ if (this%has_missing_value()) then
+ call register_variable_attribute(fileobj, var_name, "missing_value", &
+ this%get_missing_value(field_yaml%get_var_kind()))
+ call register_variable_attribute(fileobj, var_name, "_FillValue", &
+ this%get_missing_value(field_yaml%get_var_kind()))
+ else
+ call register_variable_attribute(fileobj, var_name, "missing_value", &
+ get_default_missing_value(field_yaml%get_var_kind()))
+ call register_variable_attribute(fileobj, var_name, "_FillValue", &
+ get_default_missing_value(field_yaml%get_var_kind()))
+ endif
+
+ if (this%has_data_RANGE()) then
+ call register_variable_attribute(fileobj, var_name, "valid_range", &
+ this%get_data_range(field_yaml%get_var_kind()))
+ endif
+
+ if (this%has_interp_method()) then
+ call register_variable_attribute(fileobj, var_name, "interp_method", this%get_interp_method(), &
+ str_len=len_trim(this%get_interp_method()))
+ endif
+
+ select case (field_yaml%get_var_reduction())
+ case (time_average, time_max, time_min)
+ call register_variable_attribute(fileobj, var_name, "time_avg_info", &
+ trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT', &
+ str_len=len(trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT'))
+ end select
+
+ call append_time_cell_measure(cell_measures, field_yaml)
+ if (trim(cell_measures) .ne. "") &
+ call register_variable_attribute(fileobj, var_name, "cell_methods", &
+ trim(adjustl(cell_measures)), str_len=len_trim(adjustl(cell_measures)))
+
+end subroutine write_field_metadata
!> @brief Gets a fields data buffer
!! @return a pointer to the data buffer
function get_data_buffer (this) &
@@ -1120,6 +1334,25 @@ subroutine diag_field_add_attribute(this, att_name, att_value)
call this%attributes(this%num_attributes)%add(att_name, att_value)
end subroutine diag_field_add_attribute
+!> @brief Determine the default missing value to use based on the requested variable type
+!! @return The missing value
+function get_default_missing_value(var_type) &
+ result(rslt)
+
+ integer, intent(in) :: var_type !< The type of the variable to return the missing value as
+ class(*),allocatable :: rslt
+
+ select case(var_type)
+ case (r4)
+ allocate(integer(kind=r4_kind) :: rslt)
+ rslt = real(CMOR_MISSING_VALUE, kind=r4_kind)
+ case (r8)
+ allocate(integer(kind=r8_kind) :: rslt)
+ rslt = real(CMOR_MISSING_VALUE, kind=r8_kind)
+ case default
+ end select
+end function
+
!> @brief Determines the diag_obj id corresponding to a module name and field_name
!> @return diag_obj id
PURE FUNCTION diag_field_id_from_name(this, module_name, field_name) &
@@ -1137,6 +1370,30 @@ PURE FUNCTION diag_field_id_from_name(this, module_name, field_name) &
endif
end function diag_field_id_from_name
+!> @brief Append the time cell measured based on the variable's reduction
+subroutine append_time_cell_measure(cell_measures, field_yaml)
+ character(len=*), intent(inout) :: cell_measures !< The cell measures to append to
+ type(diagYamlFilesVar_type), intent(in) :: field_yaml !< The field's yaml
+
+ select case (field_yaml%get_var_reduction())
+ case (time_none)
+ cell_measures = trim(cell_measures)//" time: point "
+ case (time_diurnal)
+ cell_measures = trim(cell_measures)//" time: mean"
+ case (time_power)
+ cell_measures = trim(cell_measures)//" time: mean_pow"//int2str(field_yaml%get_pow_value())
+ case (time_rms)
+ cell_measures = trim(cell_measures)//" time: root_mean_square"
+ case (time_max)
+ cell_measures = trim(cell_measures)//" time: max"
+ case (time_min)
+ cell_measures = trim(cell_measures)//" time: min"
+ case (time_average)
+ cell_measures = trim(cell_measures)//" time: mean"
+ case (time_sum)
+ cell_measures = trim(cell_measures)//" time: sum"
+ end select
+end subroutine append_time_cell_measure
!> Dumps any data from a given fmsDiagField_type object
subroutine dump_field_obj (this, unit_num)
class(fmsDiagField_type), intent(in) :: this
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index b7135867cd..96a5ca3166 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -41,6 +41,7 @@ module fms_diag_file_object_mod
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T, &
fmsDiagFullAxis_type, define_subaxis
+use fms_diag_field_object_mod, only: fmsDiagField_type
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, &
uppercase, lowercase
@@ -76,6 +77,7 @@ module fms_diag_file_object_mod
character(len=:) , dimension(:), allocatable :: file_metadata_from_model !< File metadata that comes from
!! the model.
integer, dimension(:), allocatable :: field_ids !< Variable IDs corresponding to file_varlist
+ integer, dimension(:), allocatable :: yaml_ids !< IDs corresponding to the yaml field section
logical, dimension(:), private, allocatable :: field_registered !< Array corresponding to `field_ids`, .true.
!! if the variable has been registered and
!! `field_id` has been set for the variable
@@ -89,7 +91,7 @@ module fms_diag_file_object_mod
logical :: is_static !< .True. if the frequency is -1
contains
- procedure, public :: add_field_id
+ procedure, public :: add_field_and_yaml_id
procedure, public :: has_file_metadata_from_model
procedure, public :: has_fileobj
procedure, public :: has_diag_yaml_file
@@ -145,9 +147,12 @@ module fms_diag_file_object_mod
class (fmsDiagFile_type),allocatable :: FMS_diag_file !< The individual file object
contains
+ procedure :: is_regional
+ procedure :: is_file_static
procedure :: open_diag_file
procedure :: write_time_metadata
procedure :: write_axis_metadata
+ procedure :: write_field_metadata
procedure :: write_axis_data
procedure :: writing_on_this_pe
procedure :: is_time_to_write
@@ -196,9 +201,11 @@ logical function fms_diag_files_object_init (files_array)
obj%diag_yaml_file => diag_yaml%diag_files(i)
obj%id = i
allocate(obj%field_ids(diag_yaml%diag_files(i)%size_file_varlist()))
+ allocate(obj%yaml_ids(diag_yaml%diag_files(i)%size_file_varlist()))
allocate(obj%field_registered(diag_yaml%diag_files(i)%size_file_varlist()))
!! Initialize the integer arrays
obj%field_ids = DIAG_NOT_REGISTERED
+ obj%yaml_ids = DIAG_NOT_REGISTERED
obj%field_registered = .FALSE.
obj%num_registered_fields = 0
@@ -245,19 +252,22 @@ logical function fms_diag_files_object_init (files_array)
endif
end function fms_diag_files_object_init
-!> \brief Adds a field ID to the file
-subroutine add_field_id (this, new_field_id)
- class(fmsDiagFile_type), intent(inout) :: this !< The file object
- integer, intent(in) :: new_field_id !< The field ID to be added to field_ids
+!> \brief Adds a field and yaml ID to the file
+subroutine add_field_and_yaml_id (this, new_field_id, yaml_id)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ integer, intent(in) :: new_field_id !< The field ID to be added to field_ids
+ integer, intent(in) :: yaml_id !< The yaml_id
+
this%num_registered_fields = this%num_registered_fields + 1
if (this%num_registered_fields .le. size(this%field_ids)) then
this%field_ids( this%num_registered_fields ) = new_field_id
+ this%yaml_ids( this%num_registered_fields ) = yaml_id
this%field_registered( this%num_registered_fields ) = .true.
else
call mpp_error(FATAL, "The file: "//this%get_file_fname()//" has already been assigned its maximum "//&
"number of fields.")
endif
-end subroutine add_field_id
+end subroutine add_field_and_yaml_id
!> \brief Set the time_ops variable in the diag_file object
subroutine set_file_time_ops(this, VarYaml, is_static)
@@ -611,6 +621,7 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis)
integer :: i, j !< For do loops
logical :: is_cube_sphere !< Flag indicating if the file's domain is a cubesphere
+ logical :: axis_found !< Flag indicating that the axis was already to the file obj
is_cube_sphere = .false.
@@ -638,14 +649,20 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis)
return
type is (fmsDiagFile_type)
do i = 1, size(axis_ids)
+ axis_found = .false.
do j = 1, this%number_of_axis
- !> Check if the axis already exists, return
- if (axis_ids(i) .eq. this%axis_ids(j)) return
+ !> Check if the axis already exists, move on
+ if (axis_ids(i) .eq. this%axis_ids(j)) then
+ axis_found = .true.
+ cycle
+ endif
enddo
- !> If the axis does not exist add it to the list
- this%number_of_axis = this%number_of_axis + 1
- this%axis_ids(this%number_of_axis) = axis_ids(i)
+ if (.not. axis_found) then
+ !> If the axis does not exist add it to the list
+ this%number_of_axis = this%number_of_axis + 1
+ this%axis_ids(this%number_of_axis) = axis_ids(i)
+ endif
enddo
end select
end subroutine add_axes
@@ -716,6 +733,34 @@ subroutine dump_file_obj(this, unit_num)
end subroutine
+!> @brief Determine if a file is regional
+!! @return Flag indicating if the file is regional or not
+logical pure function is_regional(this)
+ class(fmsDiagFileContainer_type), intent(in) :: this !< The file object
+
+ select type (wut=>this%FMS_diag_file)
+ type is (subRegionalFile_type)
+ is_regional = .true.
+ type is (fmsDiagFile_type)
+ is_regional = .false.
+ end select
+
+end function is_regional
+
+!> @brief Determine if a file is static
+!! @return Flag indicating if the file is static or not
+logical pure function is_file_static(this)
+class(fmsDiagFileContainer_type), intent(in) :: this !< The file object
+
+is_file_static = .false.
+
+select type (fileptr=>this%FMS_diag_file)
+type is (fmsDiagFile_type)
+ is_file_static = fileptr%is_static
+end select
+
+end function is_file_static
+
!< @brief Opens the diag_file if it is time to do so
subroutine open_diag_file(this, time_step, file_is_opened)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
@@ -908,7 +953,7 @@ subroutine write_time_metadata(this)
if (diag_file%time_ops) then
call register_variable_attribute(fileobj, time_var_name, "bounds", &
- trim(time_var_name)//"_bounds", str_len=len_trim(time_var_name//"_bounds"))
+ trim(time_var_name)//"_bnds", str_len=len_trim(time_var_name//"_bnds"))
!< Write out the "average_*" variables metadata
call write_var_metadata(fileobj, avg_name//"_T1", dimensions(2:2), &
@@ -916,13 +961,13 @@ subroutine write_time_metadata(this)
call write_var_metadata(fileobj, avg_name//"_T2", dimensions(2:2), &
"End time for average period", time_units_str)
call write_var_metadata(fileobj, avg_name//"_DT", dimensions(2:2), &
- "Length time for average period", time_units_str)
+ "Length of average period", time_unit_list(diag_file%get_file_timeunit()))
!< Write out the *_bounds variable metadata
call register_axis(fileobj, "nv", 2) !< Time bounds need a vertex number
call write_var_metadata(fileobj, "nv", dimensions(1:1), &
"vertex number", no_units)
- call write_var_metadata(fileobj, time_var_name//"_bounds", dimensions, &
+ call write_var_metadata(fileobj, time_var_name//"_bnds", dimensions, &
trim(time_var_name)//" axis boundaries", time_units_str)
endif
@@ -1005,7 +1050,7 @@ subroutine write_time_data(this)
call write_data(fileobj, avg_name//"_T1", T1, unlim_dim_level=diag_file%unlimited_dimension)
call write_data(fileobj, avg_name//"_T2", T2, unlim_dim_level=diag_file%unlimited_dimension)
call write_data(fileobj, avg_name//"_DT", DT, unlim_dim_level=diag_file%unlimited_dimension)
- call write_data(fileobj, trim(diag_file%get_file_unlimdim())//"_bounds", &
+ call write_data(fileobj, trim(diag_file%get_file_unlimdim())//"_bnds", &
(/T1, T2/), unlim_dim_level=diag_file%unlimited_dimension)
if (diag_file%unlimited_dimension .eq. 1) then
@@ -1096,6 +1141,46 @@ subroutine write_axis_metadata(this, diag_axis)
end subroutine write_axis_metadata
+!< @brief Writes the field metadata for the file
+subroutine write_field_metadata(this, diag_field, diag_axis)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ class(fmsDiagField_type) , intent(inout), target :: diag_field(:) !<
+ class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
+
+ class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
+ class(fmsDiagField_type), pointer :: field_ptr !< diag_field(diag_file%field_ids(i)), for convenience
+
+ integer :: i !< For do loops
+ logical :: is_regional !< Flag indicating if the field is in a regional file
+ character(len=255) :: cell_measures !< cell_measures attributes for the field
+
+ is_regional = this%is_regional()
+
+ diag_file => this%FMS_diag_file
+ fileobj => diag_file%fileobj
+
+ do i = 1, size(diag_file%field_ids)
+ if (.not. diag_file%field_registered(i)) cycle !TODO do something else here
+ field_ptr => diag_field(diag_file%field_ids(i))
+
+ !TODO I think if the area and the volume field are no in the same file, a global attribute containing the
+ !the file that the fields are in needs to be added
+ cell_measures = ""
+ if (field_ptr%has_area()) then
+ cell_measures = "area:"//diag_field(field_ptr%get_area())%get_varname()
+ endif
+
+ if (field_ptr%has_volume()) then
+ cell_measures = trim(cell_measures)//" volume:"//diag_field(field_ptr%get_volume())%get_varname()
+ endif
+
+ call field_ptr%write_field_metadata(fileobj, diag_file%id, diag_file%yaml_ids(i), diag_axis, &
+ this%FMS_diag_file%get_file_unlimdim(), is_regional, cell_measures)
+ enddo
+
+end subroutine write_field_metadata
+
!< @brief Writes the axis data for the file
subroutine write_axis_data(this, diag_axis)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 416aac72d3..6fb95af12e 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -74,6 +74,7 @@ module fms_diag_object_mod
procedure :: fms_get_axis_name_from_id
procedure :: fms_diag_accept_data
procedure :: fms_diag_send_complete
+ procedure :: fms_diag_do_io
#ifdef use_yaml
procedure :: get_diag_buffer
#endif
@@ -123,19 +124,16 @@ end subroutine fms_diag_object_init
!! Closes all files
!! Deallocates all buffers, fields, and files
!! Uninitializes the fms_diag_object
-subroutine fms_diag_object_end (this)
+subroutine fms_diag_object_end (this, time)
class(fmsDiagObject_type) :: this
+ TYPE(time_type), INTENT(in) :: time
+
integer :: i
#ifdef use_yaml
!TODO: loop through files and force write
if (.not. this%initialized) return
- do i = 1, size(this%FMS_diag_files)
- !< Go away if the file is a subregional file and the current PE does not have any data for it
- if (.not. this%FMS_diag_files(i)%writing_on_this_pe()) cycle
-
- call this%FMS_diag_files(i)%close_diag_file()
- enddo
+ call this%fms_diag_do_io(time, is_end_of_run=.true.)
!TODO: Deallocate diag object arrays and clean up all memory
do i=1, size(this%FMS_diag_buffers)
if(allocated(this%FMS_diag_buffers(i)%diag_buffer_obj)) then
@@ -212,15 +210,18 @@ integer function fms_register_diag_field_obj &
fieldptr => this%FMS_diag_fields(this%registered_variables)
!> Register the data for the field
call fieldptr%register(modname, varname, diag_field_indices, fms_diag_object%diag_axis, &
- axes, longname, units, missing_value, varRange, mask_variant, standname, &
- do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
+ axes=axes, longname=longname, units=units, missing_value=missing_value, varRange= varRange, &
+ mask_variant= mask_variant, standname=standname, do_not_log=do_not_log, err_msg=err_msg, &
+ interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
+ static=static)
!> Get the file IDs from the field indicies from the yaml
file_ids = get_diag_files_id(diag_field_indices)
+ call fieldptr%set_file_ids(file_ids)
!> Add the axis information, initial time, and field IDs to the files
if (present(axes) .and. present(init_time)) then
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
- call fileptr%add_field_id(fieldptr%get_id())
+ call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
call fileptr%add_start_time(init_time)
@@ -229,7 +230,7 @@ integer function fms_register_diag_field_obj &
elseif (present(axes)) then !only axes present
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
- call fileptr%add_field_id(fieldptr%get_id())
+ call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
@@ -237,14 +238,14 @@ integer function fms_register_diag_field_obj &
elseif (present(init_time)) then !only inti time present
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
- call fileptr%add_field_id(fieldptr%get_id())
+ call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%add_start_time(init_time)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
else !no axis or init time present
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
- call fileptr%add_field_id(fieldptr%get_id())
+ call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
endif
@@ -363,7 +364,8 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes,
fms_register_static_field = this%register( &
& module_name, field_name, axes=axes, &
& longname=long_name, units=units, missing_value=missing_value, varrange=range, &
- & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm, &
+ & mask_variant=mask_variant, do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, &
+ & standname=standard_name, area=area, volume=volume, realm=realm, &
& static=.true.)
#endif
end function fms_register_static_field
@@ -507,24 +509,25 @@ end function fms_diag_accept_data
!> @brief Loops through all the files, open the file, writes out axis and
!! variable metadata and data when necessary.
subroutine fms_diag_send_complete(this, time_step)
- class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object
+ class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object
TYPE (time_type), INTENT(in) :: time_step !< The current model time
+ integer :: i !< For do loops
+
integer :: ifile !< For file loops
integer :: ifield !< For field loops
-
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
- class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience)
+
+ class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience
class(fmsDiagField_type), pointer :: diag_field !< Pointer to this%FMS_diag_files(i)%diag_field(j)
- logical :: file_is_opened_this_time_step !< True if the file was opened in this time_step
- !! If true the metadata will need to be written
logical :: math !< True if the math functions need to be called using the data buffer,
- !! False if the math functions were done in accept_data
+ !! False if the math functions were done in accept_data
integer, dimension(:), allocatable :: file_field_ids !< Array of field IDs for a file
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! In the future, this may be parallelized for offloading
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !! In the future, this may be parallelized for offloading
file_loop: do ifile = 1, size(this%FMS_diag_files)
diag_file => this%FMS_diag_files(ifile)
field_outer_if: if (size(diag_file%FMS_diag_file%get_field_ids()) .ge. 1) then
@@ -533,7 +536,7 @@ subroutine fms_diag_send_complete(this, time_step)
field_loop: do ifield = 1, size(file_field_ids)
diag_field => this%FMS_diag_fields(file_field_ids(ifield))
!> Check if math needs to be done
-! math = diag_field%get_math_needs_to_be_done()
+ ! math = diag_field%get_math_needs_to_be_done()
math = .false. !TODO: replace this with real thing
calling_math: if (math) then
!!TODO: call math functions !!
@@ -544,6 +547,35 @@ subroutine fms_diag_send_complete(this, time_step)
!> Clean up, clean up, everybody do your share
if (allocated(file_field_ids)) deallocate(file_field_ids)
endif field_outer_if
+ enddo file_loop
+
+ call this%fms_diag_do_io(time_step)
+#endif
+
+end subroutine fms_diag_send_complete
+
+!> @brief Loops through all the files, open the file, writes out axis and
+!! variable metadata and data when necessary.
+subroutine fms_diag_do_io(this, time_step, is_end_of_run)
+ class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object
+ TYPE (time_type), INTENT(in) :: time_step !< The current model time
+ logical, optional, intent(in) :: is_end_of_run !< If .true. this is the end of the run,
+ !! so force write
+#ifdef use_yaml
+ integer :: i !< For do loops
+ class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience)
+
+
+ logical :: file_is_opened_this_time_step !< True if the file was opened in this time_step
+ !! If true the metadata will need to be written
+ logical :: force_write
+
+ force_write = .false.
+ if (present (is_end_of_run)) force_write = .true.
+
+ do i = 1, size(this%FMS_diag_files)
+ diag_file => this%FMS_diag_files(i)
+
!< Go away if the file is a subregional file and the current PE does not have any data for it
if (.not. diag_file%writing_on_this_pe()) cycle
@@ -551,6 +583,7 @@ subroutine fms_diag_send_complete(this, time_step)
if (file_is_opened_this_time_step) then
call diag_file%write_time_metadata()
call diag_file%write_axis_metadata(this%diag_axis)
+ call diag_file%write_field_metadata(this%FMS_diag_fields, this%diag_axis)
call diag_file%write_axis_data(this%diag_axis)
endif
@@ -560,12 +593,15 @@ subroutine fms_diag_send_complete(this, time_step)
!TODO call diag_file%add_variable_data()
call diag_file%update_next_write(time_step)
call diag_file%update_current_new_file_freq_index(time_step)
- if (diag_file%is_time_to_close_file(time_step)) call diag_file%close_diag_file
+ if (diag_file%is_time_to_close_file(time_step)) call diag_file%close_diag_file()
+ else if (force_write .and. .not. diag_file%is_file_static()) then
+ call diag_file%increase_unlimited_dimension()
+ call diag_file%write_time_data()
+ call diag_file%close_diag_file()
endif
- enddo file_loop
+ enddo
#endif
-
-end subroutine fms_diag_send_complete
+end subroutine fms_diag_do_io
!> @brief Add a attribute to the diag_obj using the diag_field_id
subroutine fms_diag_field_add_attribute(this, diag_field_id, att_name, att_value)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 8e42b5cc80..555c60969a 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -33,7 +33,7 @@ module fms_diag_yaml_mod
use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER, set_base_time, latlon_gridtype, &
index_gridtype, null_gridtype, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, &
DIAG_MONTHS, DIAG_YEARS, time_average, time_rms, time_max, time_min, time_sum, &
- time_diurnal, time_power, time_none, r8, i8, r4, i4
+ time_diurnal, time_power, time_none, r8, i8, r4, i4, DIAG_NOT_REGISTERED
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL, mpp_pe, mpp_root_pe, stdout
@@ -228,6 +228,7 @@ module fms_diag_yaml_mod
procedure :: get_basedate !< Returns the basedate array
procedure :: get_diag_files !< Returns the diag_files array
procedure :: get_diag_fields !< Returns the diag_field array
+ procedure :: get_diag_field_from_id
procedure :: has_diag_title
procedure :: has_diag_basedate
@@ -297,6 +298,22 @@ function get_diag_files(diag_yaml) &
diag_files = diag_yaml%diag_files
end function get_diag_files
+!> @brief Get the diag_field yaml corresponding to a yaml_id
+!! @return Pointer to the diag_field yaml entry
+function get_diag_field_from_id(diag_yaml, yaml_id) &
+ result(diag_field)
+ class (diagYamlObject_type), target, intent(in) :: diag_yaml !< The diag_yaml
+ integer, intent(in) :: yaml_id !< Yaml id
+
+ type(diagYamlFilesVar_type), pointer :: diag_field !< Diag fields info
+
+ if (yaml_id .eq. DIAG_NOT_REGISTERED) call mpp_error(FATAL, &
+ "Diag_manager: The yaml id for this field is not is not set")
+
+ diag_field => diag_yaml%diag_fields(variable_list%diag_field_indices(yaml_id))
+
+end function get_diag_field_from_id
+
!> @brief get the diag_fields of a diag_yaml type
!! @return the diag_fields
pure function get_diag_fields(diag_yaml) &
@@ -1076,7 +1093,12 @@ pure function get_var_outname (diag_var_obj) &
result (res)
class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_outname
+
+ if (diag_var_obj%has_var_outname()) then
+ res = diag_var_obj%var_outname
+ else
+ res = diag_var_obj%var_varname !< If outname is not set, the variable name will be used
+ endif
end function get_var_outname
!> @brief Inquiry for diag_yaml_files_var_obj%var_longname
!! @return var_longname of a diag_yaml_files_var_obj
@@ -1280,7 +1302,15 @@ end function has_var_write
!! @return true if obj%var_outname is allocated
pure logical function has_var_outname (obj)
class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_outname = allocated(obj%var_outname)
+ if (allocated(obj%var_outname)) then
+ if (trim(obj%var_outname) .ne. "") then
+ has_var_outname = .true.
+ else
+ has_var_outname = .false.
+ endif
+ else
+ has_var_outname = .true.
+ endif
end function has_var_outname
!> @brief Checks if obj%var_longname is allocated
!! @return true if obj%var_longname is allocated
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index ace739b1cb..c66ff346af 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -828,6 +828,12 @@ diag_files:
var_name: var1
reduction: average
kind: r4
+ output_name: var1_min
+ - module: atm_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+ output_name: var2_max
_EOF
my_test_count=`expr $my_test_count + 1`
From 552ae0139a3001ac8248e62fa72c633757c61d6f Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 1 Feb 2023 09:42:43 -0500
Subject: [PATCH 079/168] feat: modern diag add support for unstructured grid
files axis (#1114)
---
diag_manager/diag_axis.F90 | 8 +-
diag_manager/fms_diag_axis_object.F90 | 108 ++++++++++++++++++---
diag_manager/fms_diag_file_object.F90 | 33 +++++--
diag_manager/fms_diag_object.F90 | 30 +++++-
test_fms/diag_manager/test_modern_diag.F90 | 3 +-
5 files changed, 156 insertions(+), 26 deletions(-)
diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90
index 341f7fbfe6..d4cdf6b8df 100644
--- a/diag_manager/diag_axis.F90
+++ b/diag_manager/diag_axis.F90
@@ -138,9 +138,11 @@ INTEGER FUNCTION diag_axis_init(name, array_data, units, cart_name, long_name, d
ENDIF
if (use_modern_diag) then
- diag_axis_init = fms_diag_object%fms_diag_axis_init(name, DATA, units, cart_name, long_name=long_name,&
- & direction=direction, set_name=set_name, edges=edges, Domain=Domain, Domain2=Domain2, DomainU=DomainU, &
- & aux=aux, req=req, tile_count=tile_count, domain_position=domain_position )
+ !TODO Passing in the axis_length because of a gnu issue where inside fms_diag_axis_init, the size of DATA
+ !was 2 which was causing the axis_data to not be written correctly...
+ diag_axis_init = fms_diag_object%fms_diag_axis_init(name, DATA, units, cart_name, size(DATA(:)), &
+ & long_name=long_name, direction=direction, set_name=set_name, edges=edges, Domain=Domain, Domain2=Domain2, &
+ & DomainU=DomainU, aux=aux, req=req, tile_count=tile_count, domain_position=domain_position)
return
endif
IF ( PRESENT(tile_count)) THEN
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 30abd44888..13d73a8337 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -49,7 +49,7 @@ module fms_diag_axis_object_mod
public :: fmsDiagAxis_type, fms_diag_axis_object_init, fms_diag_axis_object_end, &
& get_domain_and_domain_type, diagDomain_t, &
& DIAGDOMAIN2D_T, fmsDiagSubAxis_type, fmsDiagAxisContainer_type, fmsDiagFullAxis_type, DIAGDOMAINUG_T
- public :: define_new_axis, define_subaxis
+ public :: define_new_axis, define_subaxis, parse_compress_att, get_axis_id_from_name
!> @}
@@ -96,6 +96,9 @@ module fms_diag_axis_object_mod
procedure :: get_axis_name
procedure :: write_axis_metadata
procedure :: write_axis_data
+ procedure :: add_structured_axis_ids
+ procedure :: get_structured_axis
+ procedure :: is_unstructured_grid
END TYPE fmsDiagAxis_type
!> @brief Type to hold the subaxis
@@ -138,6 +141,8 @@ module fms_diag_axis_object_mod
TYPE(fmsDiagAttribute_type),allocatable , private :: attributes(:) !< Array to hold user definable attributes
INTEGER , private :: num_attributes !< Number of defined attibutes
INTEGER , private :: domain_position !< The position in the doman (NORTH, EAST or CENTER)
+ integer, allocatable , private :: structured_ids(:) !< If the axis is in the unstructured grid,
+ !! this is the axis ids of the structured axis
contains
@@ -160,7 +165,7 @@ module fms_diag_axis_object_mod
!!!!!!!!!!!!!!!!! DIAG AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Initialize the axis
subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name, long_name, direction,&
- & set_name, Domain, Domain2, DomainU, aux, req, tile_count, domain_position )
+ & set_name, Domain, Domain2, DomainU, aux, req, tile_count, domain_position, axis_length )
class(fmsDiagFullAxis_type),INTENT(out) :: this !< Diag_axis obj
CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
class(*), INTENT(in) :: axis_data(:) !< Array of coordinate values
@@ -177,6 +182,7 @@ subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name,
CHARACTER(len=*), INTENT(in), OPTIONAL :: req !< Required field names.
INTEGER, INTENT(in), OPTIONAL :: tile_count !< Number of tiles
INTEGER, INTENT(in), OPTIONAL :: domain_position !< Domain position, "NORTH" or "EAST"
+ integer, intent(in), optional :: axis_length !< The length of the axis size(axis_data(:))
this%axis_name = trim(axis_name)
this%units = trim(units)
@@ -187,12 +193,14 @@ subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name,
select type (axis_data)
type is (real(kind=r8_kind))
- allocate(real(kind=r8_kind) :: this%axis_data(size(axis_data)))
+ allocate(real(kind=r8_kind) :: this%axis_data(axis_length))
this%axis_data = axis_data
+ this%length = axis_length
this%type_of_data = "double" !< This is what fms2_io expects in the register_field call
type is (real(kind=r4_kind))
- allocate(real(kind=r4_kind) :: this%axis_data(size(axis_data)))
+ allocate(real(kind=r4_kind) :: this%axis_data(axis_length))
this%axis_data = axis_data
+ this%length = axis_length
this%type_of_data = "float" !< This is what fms2_io expects in the register_field call
class default
call mpp_error(FATAL, "The axis_data in your diag_axis_init call is not a supported type. &
@@ -226,8 +234,6 @@ subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name,
if (present(domain_position)) this%domain_position = domain_position
call check_if_valid_domain_position(this%domain_position)
- this%length = size(axis_data)
-
this%direction = 0
if (present(direction)) this%direction = direction
call check_if_valid_direction(this%direction)
@@ -309,15 +315,15 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
end select
type is (FmsNetcdfUnstructuredDomainFile_t)
select case (diag_axis%type_of_domain)
- case (NO_DOMAIN)
- !< Here the fileobj is in the unstructured domain, but the axis is not
- !< Unstructured domain fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
- call register_axis(fileobj, axis_name, axis_length)
- call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
case (UG_DOMAIN)
!< Here the axis is in a unstructured domain
call register_axis(fileobj, axis_name)
call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
+ case default
+ !< Here the fileobj is in the unstructured domain, but the axis is not
+ !< Unstructured domain fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
+ call register_axis(fileobj, axis_name, axis_length)
+ call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
end select
end select
@@ -383,6 +389,44 @@ subroutine write_axis_data(this, fileobj, parent_axis)
end select
end subroutine write_axis_data
+ !< @brief Determine if the axis is in the unstructured grid
+ !! @return .True. if the axis is in unstructured grid
+ pure logical function is_unstructured_grid(this)
+ class(fmsDiagAxis_type), target, INTENT(in) :: this !< diag_axis obj
+
+ is_unstructured_grid = .false.
+ select type (this)
+ type is (fmsDiagFullAxis_type)
+ is_unstructured_grid = trim(this%cart_name) .eq. "U"
+ end select
+ end function is_unstructured_grid
+
+ !< @brief Adds the structured axis ids to the axis object
+ subroutine add_structured_axis_ids(this, axis_ids)
+ class(fmsDiagAxis_type), target, INTENT(inout) :: this !< diag_axis obj
+ integer, intent(in) :: axis_ids(2) !< axis ids to add to the axis object
+
+ select type (this)
+ type is (fmsDiagFullAxis_type)
+ allocate(this%structured_ids(2))
+ this%structured_ids = axis_ids
+ end select
+ end subroutine add_structured_axis_ids
+
+ !< @brief Get the structured axis ids from the axis object
+ !! @return the structured axis ids
+ pure function get_structured_axis(this) &
+ result(rslt)
+ class(fmsDiagAxis_type), target, INTENT(in) :: this !< diag_axis obj
+ integer :: rslt(2)
+
+ rslt = diag_null
+ select type (this)
+ type is (fmsDiagFullAxis_type)
+ rslt = this%structured_ids
+ end select
+ end function get_structured_axis
+
!> @brief Get the starting and ending indices of the global io domain of the axis
subroutine get_global_io_domain(this, global_io_index)
class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
@@ -972,6 +1016,48 @@ pure function get_subaxes_id(this) &
end function
+ !< @brief Parses the "compress" attribute to get the names of the two axis
+ !! @return the names of the structured axis
+ pure function parse_compress_att(compress_att) &
+ result(axis_names)
+ class(*), intent(in) :: compress_att(:) !< The compress attribute to parse
+ character(len=120) :: axis_names(2)
+
+ integer :: ios !< Errorcode after parsing the compress attribute
+
+ select type (compress_att)
+ type is (character(len=*))
+ read(compress_att(1),*, iostat=ios) axis_names
+ if (ios .ne. 0) axis_names = ""
+ class default
+ axis_names = ""
+ end select
+ end function parse_compress_att
+
+ !< @brief Determine the axis id of a axis
+ !! @return Axis id
+ pure function get_axis_id_from_name(axis_name, diag_axis, naxis) &
+ result(axis_id)
+ class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Array of axis object
+ character(len=*), intent(in) :: axis_name !< Name of the axis
+ integer, intent(in) :: naxis !< Number of axis that have been registered
+ integer :: axis_id
+
+ integer :: i !< For do loops
+
+ axis_id = diag_null
+ do i = 1, naxis
+ select type(axis => diag_axis(i)%axis)
+ type is (fmsDiagFullAxis_type)
+ if (trim(axis%axis_name) .eq. trim(axis_name)) then
+ axis_id = i
+ return
+ endif
+ end select
+ enddo
+
+ end function get_axis_id_from_name
+
#endif
end module fms_diag_axis_object_mod
!> @}
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 96a5ca3166..7e3765c1f4 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -1118,24 +1118,33 @@ end subroutine increase_unlimited_dimension
!< @brief Writes the axis metadata for the file
subroutine write_axis_metadata(this, diag_axis)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
- class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
+ class(fmsDiagAxisContainer_type), intent(in), target :: diag_axis(:) !< Diag_axis object
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
- integer :: i !< For do loops
- integer :: j !< diag_file%axis_ids(i) (for less typing)
+ integer :: i,k !< For do loops
integer :: parent_axis_id !< Id of the parent_axis
+ integer :: structured_ids(2) !< Ids of the uncompress axis
+
+ class(fmsDiagAxisContainer_type), pointer :: axis_ptr !< pointer to the axis object currently writing
diag_file => this%FMS_diag_file
fileobj => diag_file%fileobj
do i = 1, diag_file%number_of_axis
- j = diag_file%axis_ids(i)
- parent_axis_id = diag_axis(j)%axis%get_parent_axis_id()
+ axis_ptr => diag_axis(diag_file%axis_ids(i))
+ parent_axis_id = axis_ptr%axis%get_parent_axis_id()
if (parent_axis_id .eq. DIAG_NULL) then
- call diag_axis(j)%axis%write_axis_metadata(fileobj)
+ call axis_ptr%axis%write_axis_metadata(fileobj)
else
- call diag_axis(j)%axis%write_axis_metadata(fileobj, diag_axis(parent_axis_id)%axis)
+ call axis_ptr%axis%write_axis_metadata(fileobj, diag_axis(parent_axis_id)%axis)
+ endif
+
+ if (axis_ptr%axis%is_unstructured_grid()) then
+ structured_ids = axis_ptr%axis%get_structured_axis()
+ do k = 1, size(structured_ids)
+ call diag_axis(structured_ids(k))%axis%write_axis_metadata(fileobj)
+ enddo
endif
enddo
@@ -1188,9 +1197,10 @@ subroutine write_axis_data(this, diag_axis)
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
- integer :: i !< For do loops
+ integer :: i, k !< For do loops
integer :: j !< diag_file%axis_ids(i) (for less typing)
integer :: parent_axis_id !< Id of the parent_axis
+ integer :: structured_ids(2) !< Ids of the uncompress axis
diag_file => this%FMS_diag_file
fileobj => diag_file%fileobj
@@ -1203,6 +1213,13 @@ subroutine write_axis_data(this, diag_axis)
else
call diag_axis(j)%axis%write_axis_data(fileobj, diag_axis(parent_axis_id)%axis)
endif
+
+ if (diag_axis(j)%axis%is_unstructured_grid()) then
+ structured_ids = diag_axis(j)%axis%get_structured_axis()
+ do k = 1, size(structured_ids)
+ call diag_axis(structured_ids(k))%axis%write_axis_data(fileobj)
+ enddo
+ endif
enddo
end subroutine write_axis_data
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 6fb95af12e..93e615b177 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -30,7 +30,8 @@ module fms_diag_object_mod
& get_diag_files_id, diag_yaml
use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, &
&diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, &
- &fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type
+ &fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, &
+ &parse_compress_att, get_axis_id_from_name
use fms_diag_buffer_mod
#endif
#if defined(_OPENMP)
@@ -373,7 +374,7 @@ end function fms_register_static_field
!> @brief Wrapper for the register_diag_axis subroutine. This is needed to keep the diag_axis_init
!! interface the same
!> @return Axis id
-FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_name, direction,&
+FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, axis_length, long_name, direction,&
& set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position ) &
& result(id)
@@ -382,6 +383,7 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n
CLASS(*), INTENT(in) :: axis_data(:) !< Array of coordinate values
CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
CHARACTER(len=1), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", "U", "N")
+ integer, intent(in) :: axis_length !< The length of the axis size(axis_data(:))
CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis.
CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name !< Name of the parent axis, if it is a subaxis
INTEGER, INTENT(in), OPTIONAL :: direction !< Indicates the direction of the axis
@@ -423,7 +425,7 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n
endif
call axis%register(axis_name, axis_data, units, cart_name, long_name=long_name, &
& direction=direction, set_name=set_name, Domain=Domain, Domain2=Domain2, DomainU=DomainU, aux=aux, &
- & req=req, tile_count=tile_count, domain_position=domain_position)
+ & req=req, tile_count=tile_count, domain_position=domain_position, axis_length=axis_length)
id = this%registered_axis
call axis%set_axis_id(id)
@@ -629,6 +631,9 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value)
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
+ character(len=20) :: axis_names(2) !< Names of the uncompress axis
+ integer :: uncmx_ids(2) !< Ids of the uncompress axis
+ integer :: j !< For do loops
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
@@ -638,6 +643,25 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value)
select type (axis => this%diag_axis(axis_id)%axis)
type is (fmsDiagFullAxis_type)
call axis%add_axis_attribute(att_name, att_value)
+
+ !! Axis that are in the "unstructured" domain require a "compress" attribute for the
+ !! combiner and PP. This attribute is passed in via a diag_axis_add_attribute call in the model code
+ !! The compress attribute indicates the names of the axis that were compressed
+ !! For example grid_index:compress = "grid_yt grid_xt"
+ !! The metadata and the data for these axis also needs to be written to the file
+ if (trim(att_name) .eq. "compress") then
+ !< If the attribute is the "compress" attribute, get the axis names,
+ !! and the ids of the axis and add it to the axis object so it can be written to netcdf files
+ !! that use this axis
+ axis_names = parse_compress_att(att_value)
+ do j = 1, size(axis_names)
+ uncmx_ids(j) = get_axis_id_from_name(axis_names(j), this%diag_axis, this%registered_axis)
+ if (uncmx_ids(j) .eq. diag_null) call mpp_error(FATAL, &
+ &"Error parsing the compress attribute for axis: "//trim(axis%get_axis_name())//&
+ &". Be sure that the axes in the compress attribute are registered")
+ enddo
+ call axis%add_structured_axis_ids(uncmx_ids)
+ endif
end select
#endif
end subroutine fms_diag_axis_add_attribute
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index fcd1d05283..f557470dc1 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -109,11 +109,12 @@ program test_modern_diag
set_name="land", DomainU=land_domain, aux="geolon_t geolat_t")
id_z = diag_axis_init('z', z, 'point_Z', 'z', long_name='point_Z')
-!TODO call diag_axis_add_attribute (id_z, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)')
+call diag_axis_add_attribute (id_z, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)')
call diag_axis_add_attribute (id_z, 'integer', 10)
call diag_axis_add_attribute (id_z, '1d integer', (/10, 10/))
call diag_axis_add_attribute (id_z, 'real', 10.)
call diag_axis_add_attribute (id_x, '1d real', (/10./))
+call diag_axis_add_attribute (id_ug, 'compress', 'x y')
if (id_x .ne. 1) call mpp_error(FATAL, "The x axis does not have the expected id")
if (id_y .ne. 2) call mpp_error(FATAL, "The y axis does not have the expected id")
From 59ebadfc27838101f1daa227865967580387030a Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 2 Feb 2023 07:57:57 -0500
Subject: [PATCH 080/168] docs: modern diag table documentation (#1122)
---
diag_manager/README.md | 344 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 344 insertions(+)
create mode 100644 diag_manager/README.md
diff --git a/diag_manager/README.md b/diag_manager/README.md
new file mode 100644
index 0000000000..a5a77e09d8
--- /dev/null
+++ b/diag_manager/README.md
@@ -0,0 +1,344 @@
+## Diag Table Yaml Format:
+
+The purpose of this documents is to explain the diag_table yaml format.
+
+## Contents
+- [1. Coverting from legacy ascii diag_table format](README.md#1-coverting-from-legacy-ascii-diag_table-format)
+- [2. Diag table yaml sections](README.md#2-diag-table-yaml-sections)
+- [2.1 Global Section](README.md#21-global-section)
+- [2.2 File Section](README.md#22-file-section)
+- [2.2.1 Flexible output timings](README.md#221-flexible-output-timings)
+- [2.3 Variable Section](README.md#23-variable-section)
+- [2.4 Variable Metadata Section](README.md#24-variable-metadata-section)
+- [2.5 Global Meta Data Section](README.md#25-global-meta-data-section)
+- [2.6 Sub_region Section](README.md#26-sub_region-section)
+- [3. More examples](README.md#3-more-examples)
+
+### 1. Coverting from legacy ascii diag_table format
+
+To convert the legacy ascii diad_table format to this yaml format, the python script [**diag_table_to_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/diag_table_to_yaml.py#L23-L26) can be used. To confirm that your diag_table.yaml was created correctly, the python script [**is_valid_diag_table_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/is_valid_diag_table_yaml.py#L24-L27) can be used.
+
+### 2. Diag table yaml sections
+The diag_table.yaml is organized by file. Each file has the required and optional key/value pairs for the file, an optional subsection defining any additional global metadata to add to the file, an optional subsection defining a subregion of the grid to output the data for and a required subsection for all of the variables in the file. Each variable has the required and optional key/value pairs for the variable and an optional subsection defining any additional variable attributes to add to the file. The hierarchical structure looks like this:
+
+```yaml
+title:
+base_date:
+diag_files:
+- file1
+ - #key/value pairs for file1
+ varlist:
+ - var1
+ - #key/value pairs for var1
+ attributes:
+ - #atributes for var1
+ global_metadata:
+ - #global attributes for file1
+ subregion:
+ - #subregion for file1
+```
+
+### 2.1 Global Section
+The diag_yaml requires “title” and the “baseDate”.
+- The **title** is a string that labels the diag yaml. The equivalent in the diag table would be the experiment. It is recommended that each diag_yaml have a separate title label that is descriptive of the experiment that is using it.
+- The **basedate** is an array of 6 integer indicating the base_date in the format [year month day hour minute second].
+
+**Example:**
+
+In the YAML format:
+```yaml
+title: ESM4_piControl
+base_date: 2022 5 26 12 3 1
+```
+
+In the legacy ascii format:
+```
+ESM4_piControl
+2022 5 26 12 3 1
+```
+
+### 2.2 File Section
+The files are listed under the diagFiles section as a dashed array.
+
+Below are the **required** keys needed to define each file.
+- **file_name** is a string that defines the name of the file. Do not add ".nc" and "tileX" to the filename as this will handle by FMS.
+- **freq** is an integer that defines the frequency that data will be written. The acceptable values are:
+ - =-1: output at the end of the run only
+ - =0: output every timestep
+ - \>0: output frequency
+- **freq_units** is a string that defines the units of the frequency from above. The acceptable values are seconds, minutes, hours, days, months, years.
+- **time_units** is a string that defines units for time. The acceptable values are seconds, minutes, hours, days, months, years.
+- **unlimdim** is a string that defines the name of the unlimited dimension in the output netcdf file, usually “time”.
+- **varlist** is a subsection that list all of the variable in the file
+
+**Example:** The following creates a file with data written every 6 hours.
+
+In the YAML format:
+```yaml
+diag_files:
+- file_name: atmos_6hours
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - varinfo
+```
+
+In the legacy ascii format:
+```
+"atmos_6hours", 6, "hours", 1, "hours", "time"
+```
+
+**NOTE:** The fourth column (file_format) has been deprecated. Netcdf files will always be written.
+
+Below are some *optional* keys that may be added.
+- **write_file** is a logical that indicates if you want the file to be created (default is true). This is a new feature that is not supported by the legacy ascii data_table.
+- **new_file_freq** is a integer that defines the frequency for closing the existing file
+- **new_file_freq_units** is a string that defines the time units for creating a new file. Required if “new_file_freq” used. The acceptable values are seconds, minuts, hours, days, months, years.
+- **start_time** is an array of 6 integer indicating when to start the file for the first time. It is in the format [year month day hour minute second]. Requires “new_file_freq”
+- **filename_time** is the time used to set the name of new files when using new_file_freq. The acceptable values are begin (which will use the begining of the file's time bounds), middle (which will use the middle of the file's time bounds), and end (which will use the end of the file's time bounds). The default is middle
+
+**Example:** The following will create a new file every 6 hours starting at Jan 1 2020. Variable data will be written to the file every 6 hours.
+
+In the YAML format:
+```yaml
+- file_name: ocn%4yr%2mo%2dy%2hr
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6
+ new_file_freq_units: hours
+ start_time: 2020 1 1 0 0 0
+```
+
+In the legacy ascii format:
+```
+"ocn%4yr%2mo%2dy%2hr", 6, "hours", 1, "hours", "time", 6, "hours", "1901 1 1 0 0 0"
+```
+
+Because this is using the default `filename_time` (middle), this example will create the files:
+```
+ocn_2020_01_01_03.nc for time_bnds [0,6]
+ocn_2020_01_01_09.nc for time_bnds [6,12]
+ocn_2020_01_01_15.nc for time_bnds [12,18]
+ocn_2020_01_01_21.nc for time_bnds [18,24]
+```
+
+**NOTE** If using the new_file_freq, there must be a way to distinguish each file, as it was done in the example above.
+
+- **file_duration** is an integer that defines how long the file should receive data after start time in “file_duration_units”. This optional field can only be used if the start_time field is present. If this field is absent, then the file duration will be equal to the frequency for creating new files. The file_duration_units field must also be present if this field is present.
+- **file_duration_units** is a string that defines the file duration units. The acceptable values are seconds, minutes, hours, days, months, years.
+- **global_meta** is a subsection that lists any additional global metadata to add to the file. This is a new feature that is not supported by the legacy ascii data_table.
+- **sub_region** is a subsection that defines the four corners of a subregional section to capture.
+
+### 2.2.1 Flexible output timings
+
+In order to provide more flexibility in output timings, the new diag_table yaml format allows for different file frequencies for the same file by allowing the `freq`, `freq_units`, `new_file_freq`, `new_file_freq_units`, `file_duration`, `file_duration_units` keys to accept array of integers/strings.
+
+For example,
+``` yaml
+- file_name: flexible_timing%4yr%2mo%2dy%2hr
+ freq: 1 1 1
+ freq_units: hours hours hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6 3 1
+ new_file_freq_units: hours hours hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12 3 9
+ file_duration_units: hours hours hours
+ filename_time: begin
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+```
+This will create a file every 6 hours for 12 hours
+```
+flexible_timing_0002_01_01_00.nc - using hourly averaged data from hour 0 to hour 6
+flexible_timing_0002_01_01_06.nc - using hourly averaged data from hour 6 to hour 12
+```
+
+Then it will create a file every 3 hours for 3 hours
+```
+flexible_timing_0002_01_01_12.nc - using hourly averaged data from hour 12 to hour 15
+```
+
+Then it will create a file every 1 hour for 9 hours.
+```
+flexible_timing_0002_01_01_15.nc - using data from hour 15 to hour 16
+flexible_timing_0002_01_01_16.nc - using data from hour 16 to hour 17
+flexible_timing_0002_01_01_17.nc - using data from hour 17 to hour 18
+flexible_timing_0002_01_01_18.nc - using data from hour 18 to hour 19
+flexible_timing_0002_01_01_19.nc - using data from hour 19 to hour 20
+flexible_timing_0002_01_01_20.nc - using data from hour 20 to hour 21
+flexible_timing_0002_01_01_21.nc - using data from hour 21 to hour 22
+flexible_timing_0002_01_01_22.nc - using data from hour 22 to hour 23
+flexible_timing_0002_01_01_23.nc - using data from hour 23 to hour 24
+
+```
+
+### 2.3 Variable Section
+The variables in each file are listed under the varlist section as a dashed array.
+
+- **var_name:** is a string that defines the variable name as it is defined in the register_diag_field call in the model
+- **reduction:** is a string that describes the data reduction method to perform prior to writing data to disk. Acceptable values are average, diurnalXX (where XX is the number of diurnal samples), powXX (whre XX is the power level), min, max, none, rms, and sum.
+- **module:** is a string that defines the module where the variable is registered in the model code
+- **kind:** is a string that defines the type of variable as it will be written out in the file. Acceptable values are r4, r8, i4, and i8
+
+**Example:**
+
+In the YAML format:
+```yaml
+ varlist:
+ - module: moist
+ var_name: precip
+ reduction: average
+ kind: r4
+```
+
+In the legacy ascii format:
+```
+"moist", "precip", "precip", "atmos_8xdaily", "all", .true., "none", 2
+```
+**NOTE:** The fifth column (time_sampling) has be deprecated. The reduction_method (`.true.`) has been replaced with `average`. The output name was not included in the yaml because it is the same as the var_name.
+
+which corresponds to the following model code
+```F90
+id_precip = register_diag_field ( 'moist', 'precip', axes, Time)
+```
+where:
+- `moist` corresonds to the module key in the diag_table.yaml
+- `precip` corresponds to the var_name key in the diag_table.yaml
+- `axes` are the ids of the axes the variable is a function of
+- `Time` is the model time
+
+Below are some *optional* keys that may be added.
+- **write_var:** is a logical that is set to false if the user doesn’t want the variable to be written to the file (default: true).
+- **out_name:** is a string that defines the name of the variable that will be written to the file (default same as var_name)
+- **long_name:** is a string defining the long_name attribute of the variable. It overwrites the long_name in the variable's register_diag_field call
+- **attributes:** is a subsection with any additional metadata to add to the variable in the netcdf file. This is a new feature that is not supported by the legacy ascii data_table.
+- **zbounds:** is a 2 member array of integers that define the bounds of the z axis (zmin, zmin), optional default is no limits.
+
+### 2.4 Variable Metadata Section
+Any aditional variable attributes can be added for each varible can be listed under the attributes section as a dashed array. The key is attribute name and the value is the attribute value.
+
+**Example:**
+
+```yaml
+ attributes:
+ - attribute_name: attribute_value
+ attribute_name: attribute_value
+```
+
+Although this was not supported by the legacy ascii data_table, with the legacy diag_manager, a call to `diag_field_add_attribute` could have been used to do the same thing.
+
+```F90
+call diag_field_add_attribute(diag_field_id, attribute_name, attribute_value)
+```
+
+### 2.5 Global Meta Data Section
+Any aditional global attributes can be added for each file can be listed under the global_meta section as a dashed array. The key is the attribute name and the value is the attribute value.
+
+```yaml
+ global_meta:
+ - attribute_name: attribute_value
+ attribute_name: attribute_value
+```
+
+### 2.6 Sub_region Section
+The sub region can be listed under the sub_region section as a dashed array. The legacy ascii diag_table only allows regions to be defined using the latitude and longitude, and it only allowed rectangular sub regions. With the yaml diag_table, you can use indices to defined the sub_region and you can define **any** four corner shape. Each file can only have 1 sub_region defined. These are keys that can be used:
+- **grid_type:** is a **required** string defining the method used to define the fourth sub_region corners. The acceptable values are "latlon" if using latitude/longitude or "indices" if using the indices of the corners.
+- **corner1:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the first corner of a sub_grid.
+- **corner2:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the second corner of a sub_grid.
+- **corner3:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the third corner of a sub_grid.
+- **corner4:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the fourth corner of a sub_grid.
+- **tile:** is an integer defining the tile number the sub_grid is on. It is **required** only if using (grid_type="indices").
+
+**Exampe:**
+
+```yaml
+ sub_region:
+ - grid_type: latlon
+ corner1: -80, 0
+ corner2: -80, 75
+ corner3: -60, 0
+ corner4: -60, 75
+```
+
+### 3. More examples
+Bellow is a complete example of diag_table.yaml:
+```yaml
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: wild_card_name%4yr%2mo%2dy%2hr
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6
+ new_file_freq_units: hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12
+ file_duration_units: hours
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst
+ reduction: average
+ kind: r4
+ global_meta:
+ - is_a_file: true
+- file_name: normal
+ freq: 24
+ freq_units: days
+ time_units: hours
+ unlimdim: records
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst
+ reduction: average
+ kind: r4
+ write_var: true
+ attributes:
+ - do_sst: .true.
+ sub_region:
+ - grid_type: latlon
+ corner1: -80, 0
+ corner2: -80, 75
+ corner3: -60, 0
+ corner4: -60, 75
+- file_name: normal2
+ freq: -1
+ freq_units: days
+ time_units: hours
+ unlimdim: records
+ write_file: true
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sstt
+ reduction: average
+ kind: r4
+ long_name: S S T
+ - module: test_diag_manager_mod
+ var_name: sstt2
+ reduction: average
+ kind: r4
+ write_var: false
+ sub_region:
+ - grid_type: index
+ tile: 1
+ corner1: 10, 15
+ corner2: 20, 15
+ corner3: 10, 25
+ corner4: 20, 25
+- file_name: normal3
+ freq: -1
+ freq_units: days
+ time_units: hours
+ unlimdim: records
+ write_file: false
+```
From 050a32c3e3c392cd7f633c145a041173068570a8 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 8 Feb 2023 14:18:55 -0500
Subject: [PATCH 081/168] fix: modern diag race conditions and add send_data
tests (#1130)
---
diag_manager/diag_manager.F90 | 3 +-
test_fms/diag_manager/test_diag_manager2.sh | 10 ++
test_fms/diag_manager/test_modern_diag.F90 | 137 +++++++++++++++++---
3 files changed, 130 insertions(+), 20 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index bae77f2439..8af026c7bc 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -1678,6 +1678,7 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN
END IF
if (use_modern_diag) then !> Set up array lengths for remapping
+ field_modern => null()
ie = SIZE(field,1)
je = SIZE(field,2)
ke = SIZE(field,3)
@@ -1697,7 +1698,7 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
modern_if: iF (use_modern_diag) then
send_data_3d = fms_diag_object%fms_diag_accept_data(diag_field_id, field_modern, time, is_in, js_in, ks_in, &
& mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
- deallocate (field_modern)
+ nullify (field_modern)
elSE ! modern_if
! oor_mask is only used for checking out of range values.
ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status)
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index c66ff346af..d82a64a782 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -662,6 +662,16 @@ title: test_diag_manager
base_date: 2 1 1 0 0 0
diag_files:
+- file_name: static_file
+ freq: -1
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: atm_mod
+ var_name: var7
+ reduction: none
+ kind: r4
- file_name: file1
freq: 6
freq_units: hours
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index f557470dc1..8d9e6d20e9 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -26,14 +26,25 @@ program test_modern_diag
mpp_get_UG_compute_domain
use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
diag_axis_add_attribute, diag_field_add_attribute, diag_send_complete, &
- diag_manager_set_time_end
+ diag_manager_set_time_end, send_data, register_static_field
+use platform_mod, only: r8_kind, r4_kind
use fms_mod, only: fms_init, fms_end
-use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast
+use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast, input_nml_file
use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time
use fms_diag_object_mod,only: dump_diag_obj
implicit none
+!> @brief Type to hold all the dummy data variables
+type data_type
+ real(kind=r8_kind), allocatable :: var1(:,:) !< Dummy data for var1
+ real(kind=r8_kind), allocatable :: var2(:,:) !< Dummy data for var2
+ real(kind=r8_kind), allocatable :: var3(:,:) !< Dummy data for var3
+ real(kind=r8_kind), allocatable :: var4(:,:,:) !< Dummy data for var4
+ real(kind=r8_kind), allocatable :: var5(:) !< Dummy data for var5
+ real(kind=r8_kind), allocatable :: var6(:) !< Dummy data for var6
+end type data_type
+
type(time_type) :: Time !< Time of the simulation
integer, dimension(2) :: layout !< Layout to use when setting up the domain
integer, dimension(2) :: io_layout !< io layout to use when setting up the io domain
@@ -55,18 +66,30 @@ program test_modern_diag
integer :: id_y3 !< axis id for the y dimension in the cube sphere domain
integer :: id_UG !< axis id for the unstructured dimension
integer :: id_z !< axis id for the z dimention
+integer :: id_z2 !< axis id for the z dimention
integer :: id_var1 !< diag_field id for var in lon/lat grid
integer :: id_var2 !< diag_field id for var in lat/lon grid
integer :: id_var3 !< diag_field id for var in cube sphere grid
integer :: id_var4 !< diag_field id for 3d var in cube sphere grid
integer :: id_var5 !< diag_field id for var in UG grid
integer :: id_var6 !< diag_field id for var that is not domain decomposed
-integer :: id_var7 !< Scalar var
+integer :: id_var7 !< 1D var
+integer :: id_var8 !< Scalar var
+type(data_type) :: var_data !< Dummy variable data to send to diag_manager
+logical :: used !< Used for send_data call
+integer :: io_status !< Status after reading the namelist
+logical :: debug = .false. !< Flag used to ignore the axis/field_ids checks in the test.
+ !! Useful when using a portion or a different diag_table.yaml
+
+namelist / test_modern_diag_nml / debug
call fms_init
call set_calendar_type(JULIAN)
call diag_manager_init
+read (input_nml_file, test_modern_diag_nml, iostat=io_status)
+if (io_status > 0) call mpp_error(FATAL,'=>test_modern_diag: Error reading input.nml')
+
nx = 96
ny = 96
nz = 5
@@ -108,7 +131,9 @@ program test_modern_diag
id_ug = diag_axis_init("grid_index", real(ug_dim_data), "none", "U", long_name="grid indices", &
set_name="land", DomainU=land_domain, aux="geolon_t geolat_t")
-id_z = diag_axis_init('z', z, 'point_Z', 'z', long_name='point_Z')
+id_z2 = diag_axis_init('z_edge', z, 'point_Z', 'z', long_name='point_Z')
+id_z = diag_axis_init('z', z, 'point_Z', 'z', long_name='point_Z', edges = id_z2)
+
call diag_axis_add_attribute (id_z, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)')
call diag_axis_add_attribute (id_z, 'integer', 10)
call diag_axis_add_attribute (id_z, '1d integer', (/10, 10/))
@@ -116,12 +141,15 @@ program test_modern_diag
call diag_axis_add_attribute (id_x, '1d real', (/10./))
call diag_axis_add_attribute (id_ug, 'compress', 'x y')
-if (id_x .ne. 1) call mpp_error(FATAL, "The x axis does not have the expected id")
-if (id_y .ne. 2) call mpp_error(FATAL, "The y axis does not have the expected id")
-if (id_x3 .ne. 3) call mpp_error(FATAL, "The x3 axis does not have the expected id")
-if (id_y3 .ne. 4) call mpp_error(FATAL, "The y3 axis does not have the expected id")
-if (id_ug .ne. 5) call mpp_error(FATAL, "The ug axis does not have the expected id")
-if (id_z .ne. 6) call mpp_error(FATAL, "The z axis does not have the expected id")
+if (.not. debug) then
+ if (id_x .ne. 1) call mpp_error(FATAL, "The x axis does not have the expected id")
+ if (id_y .ne. 2) call mpp_error(FATAL, "The y axis does not have the expected id")
+ if (id_x3 .ne. 3) call mpp_error(FATAL, "The x3 axis does not have the expected id")
+ if (id_y3 .ne. 4) call mpp_error(FATAL, "The y3 axis does not have the expected id")
+ if (id_ug .ne. 5) call mpp_error(FATAL, "The ug axis does not have the expected id")
+ if (id_z2 .ne. 6) call mpp_error(FATAL, "The z2 axis does not have the expected id")
+ if (id_z .ne. 7) call mpp_error(FATAL, "The z axis does not have the expected id")
+endif
! Register the variables
id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x, id_y/), Time, 'Var in a lon/lat domain', 'mullions')
@@ -136,14 +164,18 @@ program test_modern_diag
!< This has the same name as var1, but it should have a different id because the module is different
!! so it should have its own diag_obj
id_var7 = register_diag_field ('lnd_mod', 'var1', Time, 'Some scalar var', 'mullions')
-
-if (id_var1 .ne. 1) call mpp_error(FATAL, "var1 does not have the expected id")
-if (id_var2 .ne. 2) call mpp_error(FATAL, "var2 does not have the expected id")
-if (id_var3 .ne. 3) call mpp_error(FATAL, "var3 does not have the expected id")
-if (id_var4 .ne. 4) call mpp_error(FATAL, "var4 does not have the expected id")
-if (id_var5 .ne. 5) call mpp_error(FATAL, "var5 does not have the expected id")
-if (id_var6 .ne. 6) call mpp_error(FATAL, "var6 does not have the expected id")
-if (id_var7 .ne. 7) call mpp_error(FATAL, "var7 does not have the expected id")
+id_var8 = register_static_field ('atm_mod', 'var7', (/id_z/), "Be static!", "none")
+
+if (.not. debug) then
+ if (id_var1 .ne. 1) call mpp_error(FATAL, "var1 does not have the expected id")
+ if (id_var2 .ne. 2) call mpp_error(FATAL, "var2 does not have the expected id")
+ if (id_var3 .ne. 3) call mpp_error(FATAL, "var3 does not have the expected id")
+ if (id_var4 .ne. 4) call mpp_error(FATAL, "var4 does not have the expected id")
+ if (id_var5 .ne. 5) call mpp_error(FATAL, "var5 does not have the expected id")
+ if (id_var6 .ne. 6) call mpp_error(FATAL, "var6 does not have the expected id")
+ if (id_var7 .ne. 7) call mpp_error(FATAL, "var7 does not have the expected id")
+ if (id_var8 .ne. 8) call mpp_error(FATAL, "var8 does not have the expected id")
+endif
call diag_field_add_attribute (id_var1, "some string", "this is a string")
call diag_field_add_attribute (id_var1, "integer", 10)
@@ -160,9 +192,24 @@ program test_modern_diag
call diag_manager_set_time_end(Time)
call diag_manager_set_time_end(set_date(2,1,2,0,0,0))
+call allocate_dummy_data(var_data, domain, Domain_cube_sph, land_domain, nz)
do i=1,23
- call diag_send_complete(set_date(2,1,1,i,0,0))
+ Time = set_date(2,1,1,i,0,0)
+ call set_dummy_data(var_data, i)
+ used = send_data(id_var1, var_data%var1, Time)
+ used = send_data(id_var2, var_data%var2, Time)
+ used = send_data(id_var3, var_data%var3, Time)
+ used = send_data(id_var4, var_data%var4, Time)
+ used = send_data(id_var5, var_data%var5, Time)
+ used = send_data(id_var6, var_data%var6, Time)
+ used = send_data(id_var7, var_data%var6, Time)
+
+ !TODO I don't know about this (scalar field) or how this is suppose to work #WUT
+ used = send_data(id_var8, var_data%var6, Time)
+
+ call diag_send_complete(Time)
enddo
+call deallocate_dummy_data(var_data)
call diag_manager_end(Time)
call fms_end
@@ -172,6 +219,57 @@ program test_modern_diag
include "../fms2_io/create_atmosphere_domain.inc"
include "../fms2_io/create_land_domain.inc"
+!> @brief Allocates the dummy data to send to send_data
+subroutine allocate_dummy_data(var, lat_lon_domain, cube_sphere, lnd_domain, nz)
+ type(data_type), intent(inout) :: var !< Data var to allocate
+ type(domain2d), intent(in) :: lat_lon_domain !< Lat/Lon domain
+ type(domain2d), intent(in) :: cube_sphere !< Cube sphere domain
+ type(domainug), intent(in) :: lnd_domain !< Land domain
+ integer, intent(in) :: nz !< Number of Z points
+
+ integer :: nland !< Size of the unstructured grid per PE
+ integer :: is !< Starting x compute index
+ integer :: ie !< Ending x compute index
+ integer :: js !< Starting y compute index
+ integer :: je !< Ending y compute index
+
+ call mpp_get_compute_domain(lat_lon_domain, is, ie, js, je)
+ allocate(var%var1(is:ie, js:je)) !< Variable in a lat/lon domain
+ allocate(var%var2(js:je, is:ie)) !< Variable in a lat/lon domain with flipped dimensions
+
+ call mpp_get_compute_domain(cube_sphere, is, ie, js, je)
+ allocate(var%var3(is:ie, js:je)) !< Variable in a cube sphere domain
+ allocate(var%var4(is:ie, js:je, nz)) !< Variable in a 3D cube sphere domain
+
+ call mpp_get_UG_compute_domain(lnd_domain, size=nland)
+ allocate(var%var5(nz)) !< Variable in the land unstructured domain
+
+ allocate(var%var6(nz)) !< 1D variable not domain decomposed
+
+end subroutine allocate_dummy_data
+
+!> @brief Allocates the dummy data to send to send_data
+subroutine deallocate_dummy_data(var)
+ type(data_type), intent(inout) :: var !< Data var to deallocate
+
+ deallocate(var%var1, var%var2, var%var3, var%var4, var%var5, var%var6)
+end subroutine deallocate_dummy_data
+
+!> @brief Sets the dummy_data to use in send_data
+subroutine set_dummy_data(var, data_value)
+ type(data_type), intent(inout) :: var !< Data type to set
+ integer, intent(in) :: data_value !< Value to send the data as
+
+ var%var1 = real(data_value, kind=r8_kind)
+ var%var2 = real(data_value + 1, kind=r8_kind)
+ var%var3 = real(data_value + 2, kind=r8_kind)
+ var%var4 = real(data_value + 3, kind=r8_kind)
+ var%var5 = real(data_value + 4, kind=r8_kind)
+ var%var6 = real(data_value + 5, kind=r8_kind)
+
+end subroutine set_dummy_data
+
+!> @brief Sets up a lat/lon domain
subroutine set_up_2D_domain(Domain, layout, nx, ny, io_layout)
type(domain2d), intent(out) :: Domain !< 2D domain
integer, intent(in) :: layout(:) !< Layout to use when setting up the domain
@@ -184,6 +282,7 @@ subroutine set_up_2D_domain(Domain, layout, nx, ny, io_layout)
call mpp_define_io_domain(Domain, io_layout)
end subroutine set_up_2D_domain
+!> @brief Sets up a cube sphere domain
subroutine set_up_cube_sph_domain(Domain_cube_sph, nx, ny, io_layout)
type(domain2d), intent(out) :: Domain_cube_sph !< 2D domain
integer, intent(in) :: nx !< Number of x points
From d559557fb21af9771c7304b47fe3c3c88608ad64 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 22 Feb 2023 14:06:20 -0500
Subject: [PATCH 082/168] fix: modern diag io updates for pack size and setting
time to use in filename (#1129)
---
diag_manager/diag_data.F90 | 11 ++++++
diag_manager/diag_manager.F90 | 9 +++--
diag_manager/fms_diag_file_object.F90 | 26 +++++++++++--
diag_manager/fms_diag_yaml.F90 | 41 ++++++++++++++++++++-
test_fms/diag_manager/test_diag_manager2.sh | 19 +++++++++-
test_fms/diag_manager/test_diag_yaml.F90 | 6 ++-
6 files changed, 102 insertions(+), 10 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 20e72ae4e2..5ef94b9075 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -122,6 +122,9 @@ MODULE diag_data_mod
INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power
CHARACTER(len=7) :: avg_name = 'average' !< Name of the average fields
CHARACTER(len=8) :: no_units = "NO UNITS"!< String indicating that the variable has no units
+ INTEGER, PARAMETER :: begin_time = 1 !< Use the begining of the time average bounds
+ INTEGER, PARAMETER :: middle_time = 2 !< Use the middle of the time average bounds
+ INTEGER, PARAMETER :: end_time = 3 !< Use the end of the time average bounds
!> @}
!> @brief Contains the coordinates of the local domain to output.
@@ -389,7 +392,15 @@ MODULE diag_data_mod
!! netCDF module, otherwise will be 9.9692099683868690e+36.
! from file /usr/local/include/netcdf.inc
+ !! @note `pack_size` and `pack_size_str` are set in diag_manager_init depending on how FMS was compiled
+ !! if FMS was compiled with default reals as 64bit, it will be set to 1 and "double",
+ !! if FMS was compiled with default reals as 32bit, it will set to 2 and "float"
+ !! The time variables will written in the precision defined by `pack_size_str`
+ !! This is to reproduce previous diag manager behavior.
+ !TODO This may not be mixed precision friendly
INTEGER :: pack_size = 1 !< 1 for double and 2 for float
+ CHARACTER(len=6) :: pack_size_str="double" !< Pack size as a string to be used in fms2_io register call
+ !! set to "double" or "float"
!
REAL :: EMPTY = 0.0
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 8af026c7bc..b1c993b797 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -231,8 +231,7 @@ MODULE diag_manager_mod
& use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,&
& max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,&
& max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time,diag_data_init,&
- & use_modern_diag, use_clock_average, diag_null
-
+ & use_modern_diag, use_clock_average, diag_null, pack_size_str
USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND
USE diag_table_mod, ONLY: parse_diag_table
USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att
@@ -3952,7 +3951,11 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
! Determine pack_size from how many bytes a real value has (how compiled)
pack_size = SIZE(TRANSFER(0.0_DblKind, (/0.0, 0.0, 0.0, 0.0/)))
- IF ( pack_size.NE.1 .AND. pack_size.NE.2 ) THEN
+ IF (pack_size .EQ. 1) then
+ pack_size_str = "double"
+ else if (pack_size .EQ. 2) then
+ pack_size_str = "float"
+ else
IF ( fms_error_handler('diag_manager_mod::diag_manager_init', 'unknown pack_size. Must be 1, or 2.', &
& err_msg) ) RETURN
END IF
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 7e3765c1f4..4bbff13be9 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -32,7 +32,8 @@ module fms_diag_file_object_mod
TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ, &
get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute, &
get_base_second, time_unit_list, time_average, time_rms, time_max, time_min, time_sum, &
- time_diurnal, time_power, time_none, avg_name, no_units
+ time_diurnal, time_power, time_none, avg_name, no_units, pack_size_str, &
+ middle_time, begin_time, end_time
use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date, get_calendar_type, &
VALID_CALENDAR_TYPES, operator(>=), date_to_string, &
OPERATOR(/), OPERATOR(+), operator(<)
@@ -114,6 +115,7 @@ module fms_diag_file_object_mod
procedure, public :: get_file_unlimdim
procedure, public :: get_file_sub_region
procedure, public :: get_file_new_file_freq
+ procedure, public :: get_filename_time
procedure, public :: get_file_new_file_freq_units
procedure, public :: get_file_start_time
procedure, public :: get_file_duration
@@ -311,6 +313,23 @@ pure logical function has_diag_yaml_file (this)
has_diag_yaml_file = associated(this%diag_yaml_file)
end function has_diag_yaml_file
+!> \brief Get the time to use to determine the filename, if using a wildcard file name (i.e ocn%4yr%2mo%2dy%2hr)
+!! \return The time to use when determining the filename
+function get_filename_time(this) &
+ result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
+ type(time_type) :: res
+
+ select case (this%diag_yaml_file%get_filename_time())
+ case (begin_time)
+ res = this%last_output
+ case (middle_time)
+ res = (this%last_output + this%next_close)/2
+ case (end_time)
+ res = this%next_close
+ end select
+end function get_filename_time
+
!> \brief Logical function to determine if the variable field_ids has been allocated or associated
!! \return .True. if field_ids exists .False. if field_ids has not been set
pure logical function has_field_ids (this)
@@ -826,7 +845,7 @@ subroutine open_diag_file(this, time_step, file_is_opened)
!< If using a wildcard file name (i.e ocn%4yr%2mo%2dy%2hr), get the basename (i.e ocn)
pos = INDEX(diag_file_name, '%')
if (pos > 0) base_name = diag_file_name(1:pos-1)
- suffix = get_time_string(diag_file_name, time_step) !TODO fname_time?
+ suffix = get_time_string(diag_file_name, diag_file%get_filename_time())
base_name = trim(base_name)//trim(suffix)
else
base_name = trim(diag_file_name)
@@ -903,8 +922,7 @@ subroutine write_var_metadata(fileobj, variable_name, dimensions, long_name, uni
character(len=*) , intent(in) :: long_name !< The long_name of the variable
character(len=*) , intent(in) :: units !< The units of the variable
- !TODO harcodded double
- call register_field(fileobj, variable_name, "double", dimensions)
+ call register_field(fileobj, variable_name, pack_size_str, dimensions)
call register_variable_attribute(fileobj, variable_name, "long_name", &
trim(long_name), str_len=len_trim(long_name))
if (trim(units) .ne. no_units) &
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 555c60969a..65c9af44ef 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -33,7 +33,8 @@ module fms_diag_yaml_mod
use diag_data_mod, only: DIAG_NULL, DIAG_OCEAN, DIAG_ALL, DIAG_OTHER, set_base_time, latlon_gridtype, &
index_gridtype, null_gridtype, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, &
DIAG_MONTHS, DIAG_YEARS, time_average, time_rms, time_max, time_min, time_sum, &
- time_diurnal, time_power, time_none, r8, i8, r4, i4, DIAG_NOT_REGISTERED
+ time_diurnal, time_power, time_none, r8, i8, r4, i4, DIAG_NOT_REGISTERED, &
+ middle_time, begin_time, end_time
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL, mpp_pe, mpp_root_pe, stdout
@@ -104,6 +105,9 @@ module fms_diag_yaml_mod
!! DIAG_HOURS, DIAG_DAYS, DIAG_YEARS)
character (len=:), allocatable :: file_start_time !< Time to start the file for the
!! first time. Requires “new_file_freq”
+ integer :: filename_time !< The time to use when setting the name of
+ !! new files: begin, middle, or end of the
+ !! time_bounds
integer :: file_duration(MAX_FREQ) !< How long the file should receive data
!! after start time in file_duration_units.
!! This optional field can only be used if
@@ -142,6 +146,7 @@ module fms_diag_yaml_mod
procedure, public :: get_file_duration_units
procedure, public :: get_file_varlist
procedure, public :: get_file_global_meta
+ procedure, public :: get_filename_time
procedure, public :: is_global_meta
!> Has functions to determine if allocatable variables are true. If a variable is not an allocatable
!! then is will always return .true.
@@ -513,6 +518,10 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
is_optional=.true.)
call set_new_file_freq(fileobj, freq_buffer, buffer)
+ deallocate(buffer)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "filename_time", buffer, is_optional=.true.)
+ call set_filename_time(fileobj, buffer)
+
deallocate(freq_buffer, buffer)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", fileobj%file_start_time, is_optional=.true.)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", freq_buffer, is_optional=.true.)
@@ -749,6 +758,27 @@ subroutine set_new_file_freq(fileobj, new_file_freq, new_file_freq_units)
enddo
end subroutine set_new_file_freq
+!> @brief This checks if the filename_time in a diag file is correct and sets the integer equivalent
+subroutine set_filename_time(fileobj, filename_time)
+ type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+ character(len=*), intent(in) :: filename_time !< filename_time as it is read from the yaml
+
+ select case (trim(filename_time))
+ case ("")
+ fileobj%filename_time = middle_time !< This is the default
+ case ("begin")
+ fileobj%filename_time = begin_time
+ case ("middle")
+ fileobj%filename_time = middle_time
+ case ("end")
+ fileobj%filename_time = end_time
+ case default
+ call mpp_error(FATAL, trim(filename_time)//" is an invalid filename_time &
+ &The acceptable values are begin, middle, and end. &
+ &Check your entry for file "//trim(fileobj%file_fname))
+ end select
+end subroutine set_filename_time
+
!> @brief This checks if the file duration and the file duration units in a diag file are valid
!! and sets the integer equivalent
subroutine set_file_duration(fileobj, file_duration, file_duration_units)
@@ -1024,6 +1054,15 @@ pure function get_file_global_meta (diag_files_obj) &
character (:), allocatable :: res(:,:) !< What is returned
res = diag_files_obj%file_global_meta
end function get_file_global_meta
+!> @brief Get the integer equivalent of the time to use to determine the filename,
+!! if using a wildcard file name (i.e ocn%4yr%2mo%2dy%2hr)
+!! @return the integer equivalent of the time to use to determine the filename
+pure function get_filename_time(diag_files_obj) &
+result (res)
+ class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ integer :: res !< What is returned
+ res = diag_files_obj%filename_time
+end function
!> @brief Inquiry for whether file_global_meta is allocated
!! @return Flag indicating if file_global_meta is allocated
function is_global_meta(diag_files_obj) &
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index d82a64a782..7694d1936b 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -524,6 +524,7 @@ title: test_diag_manager
base_date: 2 1 1 0 0 0
diag_files:
- file_name: wild_card_name%4yr%2mo%2dy%2hr
+ filename_time: end
freq: 6
freq_units: hours
time_units: hours
@@ -772,7 +773,23 @@ diag_files:
var_name: var1
reduction: none
kind: r4
-- file_name: file8%4yr%2mo%2dy%2hr
+- file_name: file8%4yr%2mo%2dy%2hr%2min
+ freq: 1 1 1
+ freq_units: hours hours hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6 3 1
+ new_file_freq_units: hours hours hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12 3 9
+ file_duration_units: hours hours hours
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+- file_name: file9%4yr%2mo%2dy%2hr%2min
+ filename_time: begin
freq: 1 1 1
freq_units: hours hours hours
time_units: hours
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index 00f0860e54..c94eb6184f 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -26,7 +26,7 @@ program test_diag_yaml
use fms_diag_yaml_mod
use diag_data_mod, only: DIAG_NULL, DIAG_ALL, get_base_year, get_base_month, get_base_day, get_base_hour, &
& get_base_minute, get_base_second, diag_data_init, DIAG_HOURS, DIAG_NULL, DIAG_DAYS, &
- & time_average, r4
+ & time_average, r4, middle_time, end_time
use time_manager_mod, only: set_calendar_type, JULIAN
use mpp_mod
use platform_mod
@@ -212,6 +212,10 @@ subroutine compare_diag_files(res)
call compare_result("file_fname 2", res(2)%get_file_fname(), "normal")
call compare_result("file_fname 3", res(3)%get_file_fname(), "normal2")
+ call compare_result("get_filename_time 1", res(1)%get_filename_time(), end_time)
+ call compare_result("get_filename_time 2", res(2)%get_filename_time(), middle_time)
+ call compare_result("get_filename_time 3", res(3)%get_filename_time(), middle_time)
+
call compare_result("file_freq 1", res(1)%get_file_freq(), 6)
call compare_result("file_freq 2", res(2)%get_file_freq(), 24)
call compare_result("file_freq 3", res(3)%get_file_freq(), -1)
From c85d9cb86cacfbf356e9378c37293d179bd5765d Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 22 Feb 2023 14:07:46 -0500
Subject: [PATCH 083/168] docs: modern diag add documentation explaining the
is_ocean key (#1133)
---
diag_manager/README.md | 10 ++++++++++
1 file changed, 10 insertions(+)
diff --git a/diag_manager/README.md b/diag_manager/README.md
index a5a77e09d8..9d8b33983b 100644
--- a/diag_manager/README.md
+++ b/diag_manager/README.md
@@ -8,6 +8,7 @@ The purpose of this documents is to explain the diag_table yaml format.
- [2.1 Global Section](README.md#21-global-section)
- [2.2 File Section](README.md#22-file-section)
- [2.2.1 Flexible output timings](README.md#221-flexible-output-timings)
+- [2.2.2 Coupled Model Diag Files](README.md#222-coupled-model-diag-files)
- [2.3 Variable Section](README.md#23-variable-section)
- [2.4 Variable Metadata Section](README.md#24-variable-metadata-section)
- [2.5 Global Meta Data Section](README.md#25-global-meta-data-section)
@@ -181,6 +182,15 @@ flexible_timing_0002_01_01_23.nc - using data from hour 23 to hour 24
```
+### 2.2.2 Coupled Model Diag Files
+In the *legacy ascii diag_table*, when running a coupled model (ATM + OCN) in a seperate PE list:
+ - The ATM PEs ignored the files in the diag_table that contain "OCEAN" in the filename
+ - The OCN PEs ignored the files in the diag_table that did not contain "OCEAN" in the filename
+
+In the *yaml diag_table*:
+ - The ATM PEs will ignore the files in the diag_table.yaml that contain the key/value pair `is_ocean: true`
+ - The OCN PEs will ignore the files in the diag_table.yaml that do not contain the key/value pair `is_ocean: true`
+
### 2.3 Variable Section
The variables in each file are listed under the varlist section as a dashed array.
From 0e4a2a8db235e99eb9b8b1dd631fc5ee03e48d2c Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 7 Mar 2023 13:16:04 -0500
Subject: [PATCH 084/168] feat: Modern diag_manager add diurnal axis (#1138)
---
diag_manager/fms_diag_axis_object.F90 | 122 +++++++++++++++++++-
diag_manager/fms_diag_field_object.F90 | 21 +++-
diag_manager/fms_diag_file_object.F90 | 41 ++++++-
diag_manager/fms_diag_object.F90 | 2 +
test_fms/diag_manager/test_diag_manager2.sh | 10 ++
5 files changed, 186 insertions(+), 10 deletions(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 13d73a8337..f18a9b0900 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -35,11 +35,13 @@ module fms_diag_axis_object_mod
use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind
use diag_data_mod, only: diag_atttype, max_axes, NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, &
direction_down, direction_up, fmsDiagAttribute_type, max_axis_attributes, &
- MAX_SUBAXES, DIAG_NULL, index_gridtype, latlon_gridtype
+ MAX_SUBAXES, DIAG_NULL, index_gridtype, latlon_gridtype, pack_size_str, &
+ get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute,&
+ get_base_second
use mpp_mod, only: FATAL, mpp_error, uppercase, mpp_pe, mpp_root_pe, stdout
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, &
& register_axis, register_field, register_variable_attribute, write_data
- use fms_diag_yaml_mod, only: subRegion_type
+ use fms_diag_yaml_mod, only: subRegion_type, diag_yaml
use diag_grid_mod, only: get_local_indices_cubesphere => get_local_indexes
use axis_utils2_mod, only: nearest_index
implicit none
@@ -49,7 +51,8 @@ module fms_diag_axis_object_mod
public :: fmsDiagAxis_type, fms_diag_axis_object_init, fms_diag_axis_object_end, &
& get_domain_and_domain_type, diagDomain_t, &
& DIAGDOMAIN2D_T, fmsDiagSubAxis_type, fmsDiagAxisContainer_type, fmsDiagFullAxis_type, DIAGDOMAINUG_T
- public :: define_new_axis, define_subaxis, parse_compress_att, get_axis_id_from_name
+ public :: define_new_axis, define_subaxis, parse_compress_att, get_axis_id_from_name, define_diurnal_axis, &
+ & fmsDiagDiurnalAxis_type
!> @}
@@ -115,6 +118,22 @@ module fms_diag_axis_object_mod
procedure :: fill_subaxis
END TYPE fmsDiagSubAxis_type
+ !> @brief Type to hold the diurnal axis
+ !> @ingroup diag_axis_object_mod
+ TYPE, extends(fmsDiagAxis_type) :: fmsDiagDiurnalAxis_type
+ INTEGER , private :: ndiurnal_samples !< The number of diurnal samples
+ CHARACTER(len=:), ALLOCATABLE, private :: axis_name !< The diurnal axis name
+ CHARACTER(len=:), ALLOCATABLE, private :: long_name !< The longname of the diurnal axis
+ CHARACTER(len=:), ALLOCATABLE, private :: units !< The units
+ INTEGER , private :: edges_id !< The id of the diurnal edges
+ CHARACTER(len=:), ALLOCATABLE, private :: edges_name !< The name of the edges axis
+ CLASS(*), ALLOCATABLE, private :: diurnal_data(:) !< The diurnal data
+
+ contains
+ procedure :: get_diurnal_axis_samples
+ procedure :: write_diurnal_metadata
+ END TYPE fmsDiagDiurnalAxis_type
+
!> @brief Type to hold the diagnostic axis description.
!> @ingroup diag_axis_object_mod
TYPE, extends(fmsDiagAxis_type) :: fmsDiagFullAxis_type
@@ -291,6 +310,9 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
diag_axis => parent_axis
end select
endif
+ type is (fmsDiagDiurnalAxis_type)
+ call this%write_diurnal_metadata(fileobj)
+ return
end select
!< Add the axis as a dimension in the netcdf file based on the type of axis_domain and the fileobj type
@@ -386,9 +408,74 @@ subroutine write_axis_data(this, fileobj, parent_axis)
call write_data(fileobj, this%subaxis_name, parent_axis%axis_data(i:j))
end select
endif
+ type is (fmsDiagDiurnalAxis_type)
+ call write_data(fileobj, this%axis_name, this%diurnal_data)
end select
end subroutine write_axis_data
+
+ !> @brief Defined a new diurnal axis
+ subroutine define_diurnal_axis(diag_axis, naxis, n_diurnal_samples, is_edges)
+ class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Array of axis containers
+ integer, intent(inout) :: naxis !< Number of axis that have
+ !! been defined
+ integer, intent(in) :: n_diurnal_samples !< The number of diurnal samples
+ !! for the curent axis
+ logical, intent(in) :: is_edges !< Flag indicating if this is
+ !! an edge axis
+
+ CHARACTER(32) :: axis_name !< name of the axis
+ CHARACTER(32) :: long_name !< long name of the axis
+ CHARACTER(32) :: edges_name !< name of the axis edge
+ CHARACTER(128) :: units !< units of the axis
+ real(kind=r8_kind), allocatable :: diurnal_data(:) !< Data for the axis
+ integer :: edges_id !< Id of the axis edge
+ integer :: i !< For do loops
+
+ naxis = naxis + 1
+
+ axis_name = ''
+ edges_name = ''
+ if (is_edges) then
+ WRITE (axis_name,'(a,i2.2)') 'time_of_day_edges_', n_diurnal_samples
+ long_name = "time of day edges"
+ allocate(diurnal_data(n_diurnal_samples + 1))
+ diurnal_data(1) = 0.0
+ edges_id = diag_null
+ do i = 1, n_diurnal_samples
+ diurnal_data(i+1) = 24.0* REAL(i)/n_diurnal_samples
+ enddo
+ else
+ WRITE (axis_name,'(a,i2.2)') 'time_of_day_', n_diurnal_samples
+ long_name = "time of day"
+ allocate(diurnal_data(n_diurnal_samples))
+ edges_id = naxis -1 !< The diurnal edges is the last defined axis
+ do i = 1, n_diurnal_samples
+ diurnal_data(i) = 24.0*(REAL(i)-0.5)/n_diurnal_samples
+ enddo
+ WRITE (edges_name,'(a,i2.2)') 'time_of_day_edges_', n_diurnal_samples
+ endif
+
+ WRITE (units,11) 'hours', get_base_year(), get_base_month(), &
+ get_base_day(), get_base_hour(), get_base_minute(), get_base_second()
+11 FORMAT(a,' since ',i4.4,'-',i2.2,'-',i2.2,' ',i2.2,':',i2.2,':',i2.2)
+
+ allocate(fmsDiagDiurnalAxis_type :: diag_axis(naxis)%axis)
+ select type (diurnal_axis => diag_axis(naxis)%axis)
+ type is (fmsDiagDiurnalAxis_type)
+ diurnal_axis%axis_id = naxis
+ diurnal_axis%ndiurnal_samples = n_diurnal_samples
+ diurnal_axis%axis_name = trim(axis_name)
+ diurnal_axis%long_name = trim(long_name)
+ diurnal_axis%units = trim(units)
+ diurnal_axis%diurnal_data = diurnal_data
+ diurnal_axis%edges_id = edges_id
+ if (is_edges) &
+ WRITE (edges_name,'(a,i2.2)') 'time_of_day_edges_', n_diurnal_samples
+ diurnal_axis%edges_name = trim(edges_name)
+ end select
+ end subroutine define_diurnal_axis
+
!< @brief Determine if the axis is in the unstructured grid
!! @return .True. if the axis is in unstructured grid
pure logical function is_unstructured_grid(this)
@@ -996,6 +1083,8 @@ pure function get_parent_axis_id(this) &
parent_axis_id = diag_null
type is (fmsDiagSubAxis_type)
parent_axis_id = this%parent_axis_id
+ type is (fmsDiagDiurnalAxis_type)
+ parent_axis_id = diag_null
end select
end function
@@ -1058,6 +1147,33 @@ pure function get_axis_id_from_name(axis_name, diag_axis, naxis) &
end function get_axis_id_from_name
+ !< @brief Get the number of diurnal samples for a diurnal axis
+ !! @return The number of diurnal samples
+ pure function get_diurnal_axis_samples(this) &
+ result(n_diurnal_samples)
+
+ class(fmsDiagDiurnalAxis_type), intent(in) :: this !< Axis Object
+ integer :: n_diurnal_samples
+
+ n_diurnal_samples = this%ndiurnal_samples
+ end function get_diurnal_axis_samples
+
+ !< @brief Writes out the metadata for a diurnal axis
+ subroutine write_diurnal_metadata(this, fileobj)
+ class(fmsDiagDiurnalAxis_type), intent(in) :: this !< Diurnal axis Object
+ class(FmsNetcdfFile_t), intent(inout) :: fileobj !< Fms2_io fileobj to write the data to
+
+ call register_axis(fileobj, this%axis_name, size(this%diurnal_data))
+ call register_field(fileobj, this%axis_name, pack_size_str, (/trim(this%axis_name)/))
+ call register_variable_attribute(fileobj, this%axis_name, "units", &
+ &trim(this%units), str_len=len_trim(this%units))
+ call register_variable_attribute(fileobj, this%axis_name, "long_name", &
+ &trim(this%long_name), str_len=len_trim(this%long_name))
+ if (this%edges_id .ne. diag_null) &
+ call register_variable_attribute(fileobj, this%axis_name, "edges", &
+ &trim(this%edges_name), str_len=len_trim(this%edges_name))
+ end subroutine write_diurnal_metadata
+
#endif
end module fms_diag_axis_object_mod
!> @}
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 30f8a45412..75cac92bd3 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -1001,25 +1001,29 @@ pure function get_longname_to_write(this, field_yaml) &
end function get_longname_to_write
!> @brief Determine the dimension names to use when registering the field to fms2_io
-subroutine get_dimnames(this, diag_axis, unlim_dimname, dimnames, is_regional)
- class (fmsDiagField_type), target, intent(inout) :: this !< diag field
+subroutine get_dimnames(this, diag_axis, field_yaml, unlim_dimname, dimnames, is_regional)
+ class (fmsDiagField_type), target, intent(inout) :: this !< diag field
class(fmsDiagAxisContainer_type), target, intent(in) :: diag_axis(:) !< Diag_axis object
+ type(diagYamlFilesVar_type), intent(in) :: field_yaml !< Field info from diag_table yaml
character(len=*), intent(in) :: unlim_dimname !< The name of unlimited dimension
character(len=120), allocatable, intent(out) :: dimnames(:) !< Array of the dimension names
!! for the field
logical, intent(in) :: is_regional !< Flag indicating if the field is regional
- integer :: i !< For do loops
- integer :: naxis !< Number of axis for the field
+ integer :: i !< For do loops
+ integer :: naxis !< Number of axis for the field
class(fmsDiagAxisContainer_type), pointer :: axis_ptr !diag_axis(this%axis_ids(i), for convenience
- !TODO there may be more stuff needed for the diurnal axis
if (this%is_static()) then
naxis = size(this%axis_ids)
else
naxis = size(this%axis_ids) + 1 !< Adding 1 more dimension for the unlimited dimension
endif
+ if (field_yaml%has_n_diurnal()) then
+ naxis = naxis + 1 !< Adding 1 more dimension for the diurnal axis
+ endif
+
allocate(dimnames(naxis))
do i = 1, size(this%axis_ids)
@@ -1027,6 +1031,11 @@ subroutine get_dimnames(this, diag_axis, unlim_dimname, dimnames, is_regional)
dimnames(i) = axis_ptr%axis%get_axis_name(is_regional)
enddo
+ !< The second to last dimension is always the diurnal axis
+ if (field_yaml%has_n_diurnal()) then
+ dimnames(naxis - 1) = 'time_of_day_'//int2str(field_yaml%get_n_diurnal())
+ endif
+
!< The last dimension is always the unlimited dimensions
if (.not. this%is_static()) dimnames(naxis) = unlim_dimname
@@ -1072,7 +1081,7 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
var_name = field_yaml%get_var_outname()
if (allocated(this%axis_ids)) then
- call this%get_dimnames(diag_axis, unlim_dimname, dimnames, is_regional)
+ call this%get_dimnames(diag_axis, field_yaml, unlim_dimname, dimnames, is_regional)
call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml), dimnames)
else
call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml))
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 4bbff13be9..7873124100 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -41,7 +41,7 @@ module fms_diag_file_object_mod
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type, subRegion_type, diagYamlFilesVar_type
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T, &
- fmsDiagFullAxis_type, define_subaxis
+ fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, fmsDiagDiurnalAxis_type
use fms_diag_field_object_mod, only: fmsDiagField_type
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, &
uppercase, lowercase
@@ -93,6 +93,7 @@ module fms_diag_file_object_mod
contains
procedure, public :: add_field_and_yaml_id
+ procedure, public :: init_diurnal_axis
procedure, public :: has_file_metadata_from_model
procedure, public :: has_fileobj
procedure, public :: has_diag_yaml_file
@@ -271,6 +272,44 @@ subroutine add_field_and_yaml_id (this, new_field_id, yaml_id)
endif
end subroutine add_field_and_yaml_id
+!> \brief Initializes a diurnal axis for a fileobj
+!! \note This is going to be called for every variable in the file, if the variable is not a diurnal variable
+!! it will do nothing. It only defined a diurnal axis once.
+subroutine init_diurnal_axis(this, diag_axis, naxis, yaml_id)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ class(fmsDiagAxisContainer_type), intent(inout) :: diag_axis(:) !< Array of diag_axis object
+ integer, intent(inout) :: naxis !< Number of diag_axis that heve been defined
+ integer, intent(in) :: yaml_id !< The ID to the variable's yaml
+
+ integer :: i !< For do loops
+ type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry
+
+ field_yaml => diag_yaml%get_diag_field_from_id(yaml_id)
+
+ !< Go away if the file does not need a diurnal axis
+ if (.not. field_yaml%has_n_diurnal()) return
+
+ !< Check if the diurnal axis is already defined for this number of diurnal samples
+ do i = 1, this%number_of_axis
+ select type(axis=>diag_axis(this%axis_ids(i))%axis)
+ type is (fmsDiagDiurnalAxis_type)
+ if(field_yaml%get_n_diurnal() .eq. axis%get_diurnal_axis_samples()) return
+ end select
+ end do
+
+ !< If it is not already defined, define it
+ call define_diurnal_axis(diag_axis, naxis, field_yaml%get_n_diurnal(), .true.)
+ call define_diurnal_axis(diag_axis, naxis, field_yaml%get_n_diurnal(), .False.)
+
+ !< Add it to the list of axis for the file
+ this%number_of_axis = this%number_of_axis + 1
+ this%axis_ids(this%number_of_axis) = naxis !< This is the diurnal axis edges
+
+ this%number_of_axis = this%number_of_axis + 1
+ this%axis_ids(this%number_of_axis) = naxis - 1 !< This the diurnal axis
+
+end subroutine init_diurnal_axis
+
!> \brief Set the time_ops variable in the diag_file object
subroutine set_file_time_ops(this, VarYaml, is_static)
class(fmsDiagFile_type), intent(inout) :: this !< The file object
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 93e615b177..95bcb93ef7 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -224,6 +224,7 @@ integer function fms_register_diag_field_obj &
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
+ call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
call fileptr%add_start_time(init_time)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
@@ -232,6 +233,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
+ call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 7694d1936b..1a017a76ff 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -804,6 +804,16 @@ diag_files:
var_name: var1
reduction: average
kind: r4
+- file_name: file10_diurnal
+ freq: 1
+ freq_units: days
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: diurnal12
+ kind: r4
_EOF
my_test_count=`expr $my_test_count + 1`
From 0c0967a2e29b7975d7fcc2ba5cb5c824a3a12a18 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 10 Mar 2023 12:48:03 -0500
Subject: [PATCH 085/168] feat: Modern diag manager add subzaxis (#1148)
---
diag_manager/fms_diag_axis_object.F90 | 140 ++++++++++++++++----
diag_manager/fms_diag_field_object.F90 | 20 ++-
diag_manager/fms_diag_file_object.F90 | 39 ++++--
diag_manager/fms_diag_object.F90 | 4 +-
diag_manager/fms_diag_yaml.F90 | 2 +-
test_fms/diag_manager/test_diag_manager2.sh | 6 +
6 files changed, 165 insertions(+), 46 deletions(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index f18a9b0900..7f69674a35 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -52,7 +52,7 @@ module fms_diag_axis_object_mod
& get_domain_and_domain_type, diagDomain_t, &
& DIAGDOMAIN2D_T, fmsDiagSubAxis_type, fmsDiagAxisContainer_type, fmsDiagFullAxis_type, DIAGDOMAINUG_T
public :: define_new_axis, define_subaxis, parse_compress_att, get_axis_id_from_name, define_diurnal_axis, &
- & fmsDiagDiurnalAxis_type
+ & fmsDiagDiurnalAxis_type, create_new_z_subaxis
!> @}
@@ -97,6 +97,7 @@ module fms_diag_axis_object_mod
procedure :: get_parent_axis_id
procedure :: get_subaxes_id
procedure :: get_axis_name
+ procedure :: is_z_axis
procedure :: write_axis_metadata
procedure :: write_axis_data
procedure :: add_structured_axis_ids
@@ -107,13 +108,13 @@ module fms_diag_axis_object_mod
!> @brief Type to hold the subaxis
!> @ingroup diag_axis_object_mod
TYPE, extends(fmsDiagAxis_type) :: fmsDiagSubAxis_type
- CHARACTER(len=:), ALLOCATABLE, private :: subaxis_name !< Name of the subaxis
- INTEGER , private :: starting_index !< Starting index of the subaxis relative to the
- !! parent axis
- INTEGER , private :: ending_index !< Ending index of the subaxis relative to the
- !! parent axis
- type(subRegion_type) , private :: subRegion !< Bounds of the subaxis (lat/lon or indices)
- INTEGER , private :: parent_axis_id !< Id of the parent_axis
+ CHARACTER(len=:), ALLOCATABLE , private :: subaxis_name !< Name of the subaxis
+ INTEGER , private :: starting_index !< Starting index of the subaxis relative to the
+ !! parent axis
+ INTEGER , private :: ending_index !< Ending index of the subaxis relative to the
+ !! parent axis
+ INTEGER , private :: parent_axis_id !< Id of the parent_axis
+ real(kind=r4_kind), allocatable, private :: zbounds(:) !< Bounds of the Z axis
contains
procedure :: fill_subaxis
END TYPE fmsDiagSubAxis_type
@@ -295,11 +296,14 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
integer :: i !< For do loops
type(fmsDiagFullAxis_type), pointer :: diag_axis !< Local pointer to the diag_axis
+ integer :: type_of_domain !< The type of domain the current axis is in
+
select type(this)
type is (fmsDiagFullAxis_type)
axis_name => this%axis_name
axis_length = this%length
diag_axis => this
+ type_of_domain = this%type_of_domain
type is (fmsDiagSubAxis_type)
axis_name => this%subaxis_name
axis_length = this%ending_index - this%starting_index + 1
@@ -310,6 +314,7 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
diag_axis => parent_axis
end select
endif
+ type_of_domain = NO_DOMAIN !< All subaxes are treated as non-domain decomposed (each rank writes it own file)
type is (fmsDiagDiurnalAxis_type)
call this%write_diurnal_metadata(fileobj)
return
@@ -324,7 +329,7 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
call register_axis(fileobj, axis_name, axis_length)
call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
type is (FmsNetcdfDomainFile_t)
- select case (diag_axis%type_of_domain)
+ select case (type_of_domain)
case (NO_DOMAIN)
!< Here the fileobj is domain decomposed, but the axis is not
!! Domain decomposed fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
@@ -336,7 +341,7 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
end select
type is (FmsNetcdfUnstructuredDomainFile_t)
- select case (diag_axis%type_of_domain)
+ select case (type_of_domain)
case (UG_DOMAIN)
!< Here the axis is in a unstructured domain
call register_axis(fileobj, axis_name)
@@ -676,21 +681,25 @@ end subroutine get_compute_domain
!!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Fills in the information needed to define a subaxis
- subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, subRegion)
- class(fmsDiagSubAxis_type), INTENT(INOUT) :: this !< diag_sub_axis obj
- integer , intent(in) :: starting_index !< Starting index of the subRegion for the PE
- integer , intent(in) :: ending_index !< Ending index of the subRegion for the PE
- integer , intent(in) :: axis_id !< Axis id to assign to the subaxis
- integer , intent(in) :: parent_id !< The id of the parent axis, the subaxis belongs to
- type(subRegion_type) , intent(in) :: subRegion !< SubRegion definition as it is defined in the yaml
- character(len=*) , intent(in) :: parent_axis_name !< Name of the parent_axis
+ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, zbounds)
+ class(fmsDiagSubAxis_type) , INTENT(INOUT) :: this !< diag_sub_axis obj
+ integer , intent(in) :: starting_index !< Starting index of the subRegion for the PE
+ integer , intent(in) :: ending_index !< Ending index of the subRegion for the PE
+ integer , intent(in) :: axis_id !< Axis id to assign to the subaxis
+ integer , intent(in) :: parent_id !< The id of the parent axis, the subaxis belongs to
+ character(len=*) , intent(in) :: parent_axis_name !< Name of the parent_axis
+ real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the z-axis
this%axis_id = axis_id
this%starting_index = starting_index
this%ending_index = ending_index
this%parent_axis_id = parent_id
- this%subRegion = subRegion
this%subaxis_name = trim(parent_axis_name)//"_sub01"
+
+ if (present(zbounds)) then
+ allocate(this%zbounds(2))
+ this%zbounds = zbounds
+ endif
end subroutine fill_subaxis
!> @brief Get the ntiles in a domain
@@ -794,6 +803,17 @@ pure function get_axis_name(this, is_regional) &
end select
end function get_axis_name
+ !< @brief Determine if the axis is a Z axis by looking at the cartesian name
+ !! @return .True. if the axis is a Z axis
+ pure logical function is_z_axis(this)
+ class(fmsDiagAxis_type), intent(in) :: this !< Axis object
+ is_z_axis = .false.
+ select type (this)
+ type is (fmsDiagFullAxis_type)
+ if (this%cart_name .eq. "Z") is_z_axis = .true.
+ end select
+ end function
+
!> @brief Check if a cart_name is valid and crashes if it isn't
subroutine check_if_valid_cart_name(cart_name)
character(len=*), intent(in) :: cart_name
@@ -920,7 +940,7 @@ subroutine define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_
!< If the PE's compute is not inside the subRegion, define a null subaxis and go to the next axis
if (.not. need_to_define_axis) then
call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- subRegion, diag_null, diag_null)
+ diag_null, diag_null)
cycle
endif
@@ -928,7 +948,7 @@ subroutine define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_
write_on_this_pe = .true.
call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- subRegion, starting_index, ending_index)
+ starting_index, ending_index)
end select
enddo
@@ -995,7 +1015,7 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_
write_on_this_pe = .true.
call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- subRegion, starting_index, ending_index)
+ starting_index, ending_index)
end select select_axis_type
enddo loop_over_axis_ids
else if_is_cube_sphere
@@ -1034,24 +1054,25 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_
write_on_this_pe = .true.
call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- subRegion, starting_index, ending_index)
+ starting_index, ending_index)
end select
enddo loop_over_axis_ids2
endif if_is_cube_sphere
end subroutine define_subaxis_latlon
- !< Creates a new subaxis and fills it will all the information it needs
- subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, subRegion, &
- starting_index, ending_index)
+ !> @brief Creates a new subaxis and fills it will all the information it needs
+ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
+ starting_index, ending_index, new_axis_id, zbounds)
class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
class(fmsDiagFullAxis_type), intent(inout) :: parent_axis !< The parent axis
integer, intent(inout) :: naxis !< The number of axis that
!! have been defined
integer, intent(in) :: parent_id !< Id of the parent axis
- type(subRegion_type), intent(in) :: subRegion !< SubRegion definition from the yaml
integer, intent(in) :: starting_index !< PE's Starting index
integer, intent(in) :: ending_index !< PE's Ending index
+ integer, optional, intent(out) :: new_axis_id !< Axis id of the axis this is creating
+ real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the Z axis
naxis = naxis + 1 !< This is the axis id of the new axis!
@@ -1062,11 +1083,12 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, subRegion,
!< Allocate the new axis as a subaxis and fill it
allocate(fmsDiagSubAxis_type :: diag_axis(naxis)%axis)
diag_axis(naxis)%axis%axis_id = naxis
+ if (present(new_axis_id)) new_axis_id = naxis
select type (sub_axis => diag_axis(naxis)%axis)
type is (fmsDiagSubAxis_type)
call sub_axis%fill_subaxis(starting_index, ending_index, naxis, parent_id, &
- parent_axis%axis_name, subRegion)
+ parent_axis%axis_name, zbounds)
end select
end subroutine define_new_axis
@@ -1174,6 +1196,68 @@ subroutine write_diurnal_metadata(this, fileobj)
&trim(this%edges_name), str_len=len_trim(this%edges_name))
end subroutine write_diurnal_metadata
+ !> @brief Creates a new z subaxis to use
+ subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_axis_id, nfile_axis)
+ real(kind=r4_kind), intent(in) :: zbounds(2) !< Bounds of the Z axis
+ integer, intent(inout) :: var_axis_ids(:) !< The variable's axis_ids
+ class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Array of diag_axis objects
+ integer, intent(inout) :: naxis !< Number of axis that have been
+ !! registered
+ integer, intent(inout) :: file_axis_id(:) !< The file's axis_ids
+ integer, intent(inout) :: nfile_axis !< Number of axis that have been
+ !! defined in file
+
+ class(*), pointer :: zaxis_data(:) !< The data of the full zaxis
+ integer :: subaxis_indices(2) !< The starting and ending indices of the subaxis relative to the full
+ !! axis
+ integer :: i !< For do loops
+ integer :: subaxis_id !< The id of the new z subaxis
+ logical :: axis_found !< Flag that indicated if the zsubaxis already exists
+
+ !< Determine if the axis was already created
+ axis_found = .false.
+ do i = 1, nfile_axis
+ select type (axis => diag_axis(file_axis_id(i))%axis)
+ type is (fmsDiagSubAxis_type)
+ if (axis%zbounds(1) .eq. zbounds(1) .and. axis%zbounds(2) .eq. zbounds(2)) then
+ axis_found = .true.
+ subaxis_id = file_axis_id(i)
+ exit
+ endif
+ end select
+ enddo
+
+ !< Determine which of the variable's axis is the zaxis!
+ do i = 1, size(var_axis_ids)
+ select type (parent_axis => diag_axis(var_axis_ids(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ if (parent_axis%cart_name .eq. "Z") then
+ !< If the axis was previously defined set the var_axis_ids and leave
+ if (axis_found) then
+ var_axis_ids(i) = subaxis_id
+ return
+ endif
+ zaxis_data => parent_axis%axis_data
+
+ select type(zaxis_data)
+ type is (real(kind=r4_kind))
+ !TODO need to include the conversion to "real" because nearest_index doesn't take r4s and r8s
+ subaxis_indices(1) = nearest_index(real(zbounds(1)), real(zaxis_data))
+ subaxis_indices(2) = nearest_index(real(zbounds(2)), real(zaxis_data))
+ type is (real(kind=r8_kind))
+ subaxis_indices(1) = nearest_index(real(zbounds(1)), real(zaxis_data))
+ subaxis_indices(2) = nearest_index(real(zbounds(2)), real(zaxis_data))
+ end select
+
+ call define_new_axis(diag_axis, parent_axis, naxis, parent_axis%axis_id, &
+ &subaxis_indices(1), subaxis_indices(2), subaxis_id, zbounds)
+ var_axis_ids(i) = subaxis_id
+ return
+ endif
+ end select
+ enddo
+
+ end subroutine
#endif
end module fms_diag_axis_object_mod
!> @}
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 75cac92bd3..f82ca0d842 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -1026,10 +1026,22 @@ subroutine get_dimnames(this, diag_axis, field_yaml, unlim_dimname, dimnames, is
allocate(dimnames(naxis))
- do i = 1, size(this%axis_ids)
- axis_ptr => diag_axis(this%axis_ids(i))
- dimnames(i) = axis_ptr%axis%get_axis_name(is_regional)
- enddo
+ !< Duplicated do loops for performance
+ if (field_yaml%has_var_zbounds()) then
+ do i = 1, size(this%axis_ids)
+ axis_ptr => diag_axis(this%axis_ids(i))
+ if (axis_ptr%axis%is_z_axis()) then
+ dimnames(i) = axis_ptr%axis%get_axis_name(is_regional)//"_sub01"
+ else
+ dimnames(i) = axis_ptr%axis%get_axis_name(is_regional)
+ endif
+ enddo
+ else
+ do i = 1, size(this%axis_ids)
+ axis_ptr => diag_axis(this%axis_ids(i))
+ dimnames(i) = axis_ptr%axis%get_axis_name(is_regional)
+ enddo
+ endif
!< The second to last dimension is always the diurnal axis
if (field_yaml%has_n_diurnal()) then
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 7873124100..fd2985ffb8 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -41,7 +41,8 @@ module fms_diag_file_object_mod
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type, subRegion_type, diagYamlFilesVar_type
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T, &
- fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, fmsDiagDiurnalAxis_type
+ fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, &
+ fmsDiagDiurnalAxis_type, create_new_z_subaxis
use fms_diag_field_object_mod, only: fmsDiagField_type
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, &
uppercase, lowercase
@@ -671,18 +672,34 @@ subroutine set_file_domain(this, domain, type_of_domain)
end subroutine set_file_domain
!> @brief Loops through a variable's axis_ids and adds them to the FMSDiagFile object if they don't exist
-subroutine add_axes(this, axis_ids, diag_axis, naxis)
+subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id)
class(fmsDiagFile_type), intent(inout) :: this !< The file object
integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
class(fmsDiagAxisContainer_type), intent(inout) :: diag_axis(:) !< Diag_axis object
integer, intent(inout) :: naxis !< Number of axis that have been registered
+ integer, intent(in) :: yaml_id !< Yaml id of the yaml section for this var
- integer :: i, j !< For do loops
- logical :: is_cube_sphere !< Flag indicating if the file's domain is a cubesphere
- logical :: axis_found !< Flag indicating that the axis was already to the file obj
+ type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry
+
+ integer :: i, j !< For do loops
+ logical :: is_cube_sphere !< Flag indicating if the file's domain is a cubesphere
+ logical :: axis_found !< Flag indicating that the axis was already to the file obj
+ integer, allocatable :: var_axis_ids(:) !< Array of the variable's axis ids
is_cube_sphere = .false.
+ field_yaml => diag_yaml%get_diag_field_from_id(yaml_id)
+ !< Created a copy here, because if the variable has a z subaxis var_axis_ids will be modified in
+ !! `create_new_z_subaxis` to contain the id of the new z subaxis instead of the parent axis,
+ !! which will be added to the the list of axis in the file object (axis_ids is intent(in),
+ !! which is why the copy was needed)
+ var_axis_ids = axis_ids
+
+ if (field_yaml%has_var_zbounds()) then
+ call create_new_z_subaxis(field_yaml%get_var_zbounds(), var_axis_ids, diag_axis, naxis, &
+ this%axis_ids, this%number_of_axis)
+ endif
+
select type(this)
type is (subRegionalFile_type)
if (.not. this%is_subaxis_defined) then
@@ -690,15 +707,15 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis)
if (this%domain%get_ntiles() .eq. 6) is_cube_sphere = .true.
endif
- call define_subaxis(diag_axis, axis_ids, naxis, this%get_file_sub_region(), &
+ call define_subaxis(diag_axis, var_axis_ids, naxis, this%get_file_sub_region(), &
is_cube_sphere, this%write_on_this_pe)
this%is_subaxis_defined = .true.
!> add the axis to the list of axis in the file
if (this%write_on_this_pe) then
- do i = 1, size(axis_ids)
+ do i = 1, size(var_axis_ids)
this%number_of_axis = this%number_of_axis + 1 !< This is the current number of axis in the file
- this%axis_ids(this%number_of_axis) = diag_axis(axis_ids(i))%axis%get_subaxes_id()
+ this%axis_ids(this%number_of_axis) = diag_axis(var_axis_ids(i))%axis%get_subaxes_id()
enddo
else
this%axis_ids = diag_null
@@ -706,11 +723,11 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis)
endif
return
type is (fmsDiagFile_type)
- do i = 1, size(axis_ids)
+ do i = 1, size(var_axis_ids)
axis_found = .false.
do j = 1, this%number_of_axis
!> Check if the axis already exists, move on
- if (axis_ids(i) .eq. this%axis_ids(j)) then
+ if (var_axis_ids(i) .eq. this%axis_ids(j)) then
axis_found = .true.
cycle
endif
@@ -719,7 +736,7 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis)
if (.not. axis_found) then
!> If the axis does not exist add it to the list
this%number_of_axis = this%number_of_axis + 1
- this%axis_ids(this%number_of_axis) = axis_ids(i)
+ this%axis_ids(this%number_of_axis) = var_axis_ids(i)
endif
enddo
end select
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 95bcb93ef7..79e899769e 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -225,7 +225,7 @@ integer function fms_register_diag_field_obj &
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
- call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
+ call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%add_start_time(init_time)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
@@ -235,7 +235,7 @@ integer function fms_register_diag_field_obj &
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
- call fileptr%add_axes(axes, this%diag_axis, this%registered_axis)
+ call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
elseif (present(init_time)) then !only inti time present
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 65c9af44ef..8ee06fd145 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -1367,7 +1367,7 @@ end function has_var_units
!! @return true if obj%var_zbounds is allocated
pure logical function has_var_zbounds (obj)
class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_zbounds = any(obj%var_zbounds .eq. diag_null)
+ has_var_zbounds = any(obj%var_zbounds .ne. diag_null)
end function has_var_zbounds
!> @brief Checks if obj%var_attributes is allocated
!! @return true if obj%var_attributes is allocated
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 1a017a76ff..949918b2ca 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -707,6 +707,12 @@ diag_files:
var_name: var6
reduction: average
kind: r8
+ - module: atm_mod
+ var_name: var4
+ output_name: var4_bounded
+ reduction: average
+ kind: r8
+ zbounds: 2.0 3.0
- file_name: file3
freq: 6
freq_units: hours
From 54f28a74f49a05824b78176573cb0d6ce7f39b6e Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 22 Mar 2023 13:15:29 -0400
Subject: [PATCH 086/168] fix: Adds a variable to the diag_object to store the
current model time + updates test (#1150)
---
diag_manager/fms_diag_file_object.F90 | 8 +++--
diag_manager/fms_diag_object.F90 | 37 ++++++++++++--------
test_fms/diag_manager/test_flexible_time.F90 | 6 ++--
test_fms/diag_manager/test_modern_diag.F90 | 8 +++--
4 files changed, 35 insertions(+), 24 deletions(-)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index fd2985ffb8..31e185f0a6 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -745,9 +745,12 @@ end subroutine add_axes
!> @brief adds the start time to the fileobj
!! @note This should be called from the register field calls. It can be called multiple times (one for each variable)
!! So it needs to make sure that the start_time is the same for each variable. The initial value is the base_time
-subroutine add_start_time(this, start_time)
- class(fmsDiagFile_type), intent(inout) :: this !< The file object
+subroutine add_start_time(this, start_time, model_time)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
TYPE(time_type), intent(in) :: start_time !< Start time to add to the fileobj
+ TYPE(time_type), intent(out) :: model_time !< The current model time
+ !! this will be set to the start_time
+ !! at the begining of the run
!< If the start_time sent in is equal to the base_time return because
!! this%start_time was already set to the base_time
@@ -762,6 +765,7 @@ subroutine add_start_time(this, start_time)
else
!> If the this%start_time is equal to the base_time,
!! simply update it with the start_time and set up the *_output variables
+ model_time = start_time
this%start_time = start_time
this%last_output = start_time
this%next_output = diag_time_inc(start_time, this%get_file_freq(), this%get_file_frequnit())
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 79e899769e..aa0cde7141 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -19,7 +19,8 @@
module fms_diag_object_mod
use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
- &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN
+ &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, &
+ &get_base_time
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
& OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
& get_ticks_per_second
@@ -51,6 +52,7 @@ module fms_diag_object_mod
type(fmsDiagBufferContainer_type), allocatable :: FMS_diag_buffers(:) !< array of buffer objects
integer, private :: registered_buffers = 0 !< number of registered buffers, per dimension
class(fmsDiagAxisContainer_type), allocatable :: diag_axis(:) !< Array of diag_axis
+ type(time_type) :: current_model_time !< The current model time
integer, private :: registered_variables !< Number of registered variables
integer, private :: registered_axis !< Number of registered axis
logical, private :: initialized=.false. !< True if the fmsDiagObject is initialized
@@ -114,6 +116,7 @@ subroutine fms_diag_object_init (this,diag_subset_output)
this%buffers_initialized = fms_diag_buffer_init(this%FMS_diag_buffers, SIZE(diag_yaml%get_diag_fields()))
this%registered_variables = 0
this%registered_axis = 0
+ this%current_model_time = get_base_time()
this%initialized = .true.
#else
call mpp_error("fms_diag_object_init",&
@@ -134,7 +137,7 @@ subroutine fms_diag_object_end (this, time)
!TODO: loop through files and force write
if (.not. this%initialized) return
- call this%fms_diag_do_io(time, is_end_of_run=.true.)
+ call this%fms_diag_do_io(is_end_of_run=.true.)
!TODO: Deallocate diag object arrays and clean up all memory
do i=1, size(this%FMS_diag_buffers)
if(allocated(this%FMS_diag_buffers(i)%diag_buffer_obj)) then
@@ -226,7 +229,7 @@ integer function fms_register_diag_field_obj &
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i))
- call fileptr%add_start_time(init_time)
+ call fileptr%add_start_time(init_time, this%current_model_time)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
elseif (present(axes)) then !only axes present
@@ -242,7 +245,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
- call fileptr%add_start_time(init_time)
+ call fileptr%add_start_time(init_time, this%current_model_time)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
else !no axis or init time present
@@ -514,7 +517,7 @@ end function fms_diag_accept_data
!! variable metadata and data when necessary.
subroutine fms_diag_send_complete(this, time_step)
class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object
- TYPE (time_type), INTENT(in) :: time_step !< The current model time
+ TYPE (time_type), INTENT(in) :: time_step !< The time_step
integer :: i !< For do loops
@@ -530,6 +533,9 @@ subroutine fms_diag_send_complete(this, time_step)
!! False if the math functions were done in accept_data
integer, dimension(:), allocatable :: file_field_ids !< Array of field IDs for a file
+ !< Update the current model time by adding the time_step
+ this%current_model_time = this%current_model_time + time_step
+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! In the future, this may be parallelized for offloading
file_loop: do ifile = 1, size(this%FMS_diag_files)
@@ -553,22 +559,21 @@ subroutine fms_diag_send_complete(this, time_step)
endif field_outer_if
enddo file_loop
- call this%fms_diag_do_io(time_step)
+ call this%fms_diag_do_io()
#endif
end subroutine fms_diag_send_complete
!> @brief Loops through all the files, open the file, writes out axis and
!! variable metadata and data when necessary.
-subroutine fms_diag_do_io(this, time_step, is_end_of_run)
- class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object
- TYPE (time_type), INTENT(in) :: time_step !< The current model time
+subroutine fms_diag_do_io(this, is_end_of_run)
+ class(fmsDiagObject_type), target, intent(inout) :: this !< The diag object
logical, optional, intent(in) :: is_end_of_run !< If .true. this is the end of the run,
!! so force write
#ifdef use_yaml
integer :: i !< For do loops
class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience)
-
+ TYPE (time_type), pointer :: model_time!< The current model time
logical :: file_is_opened_this_time_step !< True if the file was opened in this time_step
!! If true the metadata will need to be written
@@ -577,13 +582,15 @@ subroutine fms_diag_do_io(this, time_step, is_end_of_run)
force_write = .false.
if (present (is_end_of_run)) force_write = .true.
+ model_time => this%current_model_time
+
do i = 1, size(this%FMS_diag_files)
diag_file => this%FMS_diag_files(i)
!< Go away if the file is a subregional file and the current PE does not have any data for it
if (.not. diag_file%writing_on_this_pe()) cycle
- call diag_file%open_diag_file(time_step, file_is_opened_this_time_step)
+ call diag_file%open_diag_file(model_time, file_is_opened_this_time_step)
if (file_is_opened_this_time_step) then
call diag_file%write_time_metadata()
call diag_file%write_axis_metadata(this%diag_axis)
@@ -591,13 +598,13 @@ subroutine fms_diag_do_io(this, time_step, is_end_of_run)
call diag_file%write_axis_data(this%diag_axis)
endif
- if (diag_file%is_time_to_write(time_step)) then
+ if (diag_file%is_time_to_write(model_time)) then
call diag_file%increase_unlimited_dimension()
call diag_file%write_time_data()
!TODO call diag_file%add_variable_data()
- call diag_file%update_next_write(time_step)
- call diag_file%update_current_new_file_freq_index(time_step)
- if (diag_file%is_time_to_close_file(time_step)) call diag_file%close_diag_file()
+ call diag_file%update_next_write(model_time)
+ call diag_file%update_current_new_file_freq_index(model_time)
+ if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file()
else if (force_write .and. .not. diag_file%is_file_static()) then
call diag_file%increase_unlimited_dimension()
call diag_file%write_time_data()
diff --git a/test_fms/diag_manager/test_flexible_time.F90 b/test_fms/diag_manager/test_flexible_time.F90
index eb67eb345a..a3a78a5f8f 100644
--- a/test_fms/diag_manager/test_flexible_time.F90
+++ b/test_fms/diag_manager/test_flexible_time.F90
@@ -21,7 +21,7 @@
program test_flexible_time
use fms_mod, only: fms_init, fms_end
use time_manager_mod, only: set_date, time_type, increment_date, set_calendar_type, &
- JULIAN
+ JULIAN, set_time
use diag_manager_mod, only: diag_manager_init, diag_axis_init, register_diag_field, &
diag_manager_set_time_end, diag_send_complete, diag_manager_end
use mpp_mod, only: FATAL, mpp_error
@@ -51,9 +51,7 @@ program test_flexible_time
!< Set up the simulation
do i=1,48
- !< Increase the time by 1 hour
- Time = increment_date(Start_Time, 0, 0, 0, i, 0, 0)
- call diag_send_complete(Time)
+ call diag_send_complete(set_time(3600,0))
enddo
call diag_manager_end(End_Time)
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index 8d9e6d20e9..67000e1ac2 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -30,7 +30,7 @@ program test_modern_diag
use platform_mod, only: r8_kind, r4_kind
use fms_mod, only: fms_init, fms_end
use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast, input_nml_file
-use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time
+use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+)
use fms_diag_object_mod,only: dump_diag_obj
implicit none
@@ -46,6 +46,7 @@ program test_modern_diag
end type data_type
type(time_type) :: Time !< Time of the simulation
+type(time_type) :: Time_step !< Time_step of the simulation
integer, dimension(2) :: layout !< Layout to use when setting up the domain
integer, dimension(2) :: io_layout !< io layout to use when setting up the io domain
integer :: nx !< Number of x points
@@ -193,8 +194,9 @@ program test_modern_diag
call diag_manager_set_time_end(set_date(2,1,2,0,0,0))
call allocate_dummy_data(var_data, domain, Domain_cube_sph, land_domain, nz)
+Time_step = set_time (3600,0) !< 1 hour
do i=1,23
- Time = set_date(2,1,1,i,0,0)
+ Time = Time + Time_step
call set_dummy_data(var_data, i)
used = send_data(id_var1, var_data%var1, Time)
used = send_data(id_var2, var_data%var2, Time)
@@ -207,7 +209,7 @@ program test_modern_diag
!TODO I don't know about this (scalar field) or how this is suppose to work #WUT
used = send_data(id_var8, var_data%var6, Time)
- call diag_send_complete(Time)
+ call diag_send_complete(Time_step)
enddo
call deallocate_dummy_data(var_data)
From 51bb47f57cafd4dd6dd6aad7dff9701bc21fd8ca Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 22 Mar 2023 13:18:01 -0400
Subject: [PATCH 087/168] style: modern diag follow the this convention for
object procedures (#1159)
---
diag_manager/fms_diag_yaml.F90 | 514 ++++++++++++++++-----------------
1 file changed, 257 insertions(+), 257 deletions(-)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 8ee06fd145..632334d77e 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -264,20 +264,20 @@ end function get_diag_yaml_obj
!> @brief get the basedate of a diag_yaml type
!! @return the basedate as an integer array
-pure function get_basedate (diag_yaml) &
+pure function get_basedate (this) &
result (diag_basedate)
- class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
- integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return
+ class (diagYamlObject_type), intent(in) :: this !< The diag_yaml
+ integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return
- diag_basedate = diag_yaml%diag_basedate
+ diag_basedate = this%diag_basedate
end function get_basedate
!> @brief Find the number of files listed in the diag yaml
!! @return the number of files in the diag yaml
-pure integer function size_diag_files(diag_yaml)
- class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
- if (diag_yaml%has_diag_files()) then
- size_diag_files = size(diag_yaml%diag_files)
+pure integer function size_diag_files(this)
+ class (diagYamlObject_type), intent(in) :: this !< The diag_yaml
+ if (this%has_diag_files()) then
+ size_diag_files = size(this%diag_files)
else
size_diag_files = 0
endif
@@ -285,29 +285,29 @@ end function size_diag_files
!> @brief get the title of a diag_yaml type
!! @return the title of the diag table as an allocated string
-pure function get_title (diag_yaml) &
+pure function get_title (this) &
result (diag_title)
- class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
- character(len=:),allocatable :: diag_title !< Basedate array result to return
+ class (diagYamlObject_type), intent(in) :: this !< The diag_yaml
+ character(len=:),allocatable :: diag_title !< Basedate array result to return
- diag_title = diag_yaml%diag_title
+ diag_title = this%diag_title
end function get_title
!> @brief get the diag_files of a diag_yaml type
!! @return the diag_files
-function get_diag_files(diag_yaml) &
+function get_diag_files(this) &
result(diag_files)
- class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
- type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files!< History file info
+ class (diagYamlObject_type), intent(in) :: this !< The diag_yaml
+ type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< History file info
- diag_files = diag_yaml%diag_files
+ diag_files = this%diag_files
end function get_diag_files
!> @brief Get the diag_field yaml corresponding to a yaml_id
!! @return Pointer to the diag_field yaml entry
-function get_diag_field_from_id(diag_yaml, yaml_id) &
+function get_diag_field_from_id(this, yaml_id) &
result(diag_field)
- class (diagYamlObject_type), target, intent(in) :: diag_yaml !< The diag_yaml
+ class (diagYamlObject_type), target, intent(in) :: this !< The diag_yaml
integer, intent(in) :: yaml_id !< Yaml id
type(diagYamlFilesVar_type), pointer :: diag_field !< Diag fields info
@@ -315,18 +315,18 @@ function get_diag_field_from_id(diag_yaml, yaml_id) &
if (yaml_id .eq. DIAG_NOT_REGISTERED) call mpp_error(FATAL, &
"Diag_manager: The yaml id for this field is not is not set")
- diag_field => diag_yaml%diag_fields(variable_list%diag_field_indices(yaml_id))
+ diag_field => this%diag_fields(variable_list%diag_field_indices(yaml_id))
end function get_diag_field_from_id
!> @brief get the diag_fields of a diag_yaml type
!! @return the diag_fields
-pure function get_diag_fields(diag_yaml) &
+pure function get_diag_fields(this) &
result(diag_fields)
- class (diagYamlObject_type), intent(in) :: diag_yaml !< The diag_yaml
+ class (diagYamlObject_type), intent(in) :: this !< The diag_yaml
type(diagYamlFilesVar_type), allocatable, dimension (:) :: diag_fields !< Diag fields info
- diag_fields = diag_yaml%diag_fields
+ diag_fields = this%diag_fields
end function get_diag_fields
!> @brief Uses the yaml_parser_mod to read in the diag_table and fill in the
@@ -945,132 +945,132 @@ end function set_valid_time_units
!!!!!!! YAML FILE INQUIRIES !!!!!!!
!> @brief Finds the number of variables in the file_varlist
!! @return the size of the diag_files_obj%file_varlist array
-integer pure function size_file_varlist (diag_files_obj)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
- size_file_varlist = size(diag_files_obj%file_varlist)
+integer pure function size_file_varlist (this)
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
+ size_file_varlist = size(this%file_varlist)
end function size_file_varlist
!> @brief Inquiry for diag_files_obj%file_fname
!! @return file_fname of a diag_yaml_file obj
-pure function get_file_fname (diag_files_obj) &
+pure function get_file_fname (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- res = diag_files_obj%file_fname
+ res = this%file_fname
end function get_file_fname
!> @brief Inquiry for diag_files_obj%file_frequnit
!! @return file_frequnit of a diag_yaml_file_obj
-pure function get_file_frequnit (diag_files_obj) &
+pure function get_file_frequnit (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_frequnit(diag_files_obj%current_new_file_freq_index)
+ res = this%file_frequnit(this%current_new_file_freq_index)
end function get_file_frequnit
!> @brief Inquiry for diag_files_obj%file_freq
!! @return file_freq of a diag_yaml_file_obj
-pure function get_file_freq(diag_files_obj) &
+pure function get_file_freq(this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_freq(diag_files_obj%current_new_file_freq_index)
+ res = this%file_freq(this%current_new_file_freq_index)
end function get_file_freq
!> @brief Inquiry for diag_files_obj%file_timeunit
!! @return file_timeunit of a diag_yaml_file_obj
-pure function get_file_timeunit (diag_files_obj) &
+pure function get_file_timeunit (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_timeunit
+ res = this%file_timeunit
end function get_file_timeunit
!> @brief Inquiry for diag_files_obj%file_unlimdim
!! @return file_unlimdim of a diag_yaml_file_obj
-pure function get_file_unlimdim(diag_files_obj) &
+pure function get_file_unlimdim(this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- res = diag_files_obj%file_unlimdim
+ res = this%file_unlimdim
end function get_file_unlimdim
!> @brief Inquiry for diag_files_obj%file_subregion
!! @return file_sub_region of a diag_yaml_file_obj
-function get_file_sub_region (diag_files_obj) &
+function get_file_sub_region (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
type(subRegion_type) :: res !< What is returned
- res = diag_files_obj%file_sub_region
+ res = this%file_sub_region
end function get_file_sub_region
!> @brief Inquiry for diag_files_obj%file_new_file_freq
!! @return file_new_file_freq of a diag_yaml_file_obj
-pure function get_file_new_file_freq(diag_files_obj) &
+pure function get_file_new_file_freq(this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_new_file_freq(diag_files_obj%current_new_file_freq_index)
+ res = this%file_new_file_freq(this%current_new_file_freq_index)
end function get_file_new_file_freq
!> @brief Inquiry for diag_files_obj%file_new_file_freq_units
!! @return file_new_file_freq_units of a diag_yaml_file_obj
-pure function get_file_new_file_freq_units (diag_files_obj) &
+pure function get_file_new_file_freq_units (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_new_file_freq_units(diag_files_obj%current_new_file_freq_index)
+ res = this%file_new_file_freq_units(this%current_new_file_freq_index)
end function get_file_new_file_freq_units
!> @brief Inquiry for diag_files_obj%file_start_time
!! @return file_start_time of a diag_yaml_file_obj
-pure function get_file_start_time (diag_files_obj) &
+pure function get_file_start_time (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- res = diag_files_obj%file_start_time
+ res = this%file_start_time
end function get_file_start_time
!> @brief Inquiry for diag_files_obj%file_duration
!! @return file_duration of a diag_yaml_file_obj
-pure function get_file_duration (diag_files_obj) &
+pure function get_file_duration (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_duration(diag_files_obj%current_new_file_freq_index)
+ res = this%file_duration(this%current_new_file_freq_index)
end function get_file_duration
!> @brief Inquiry for diag_files_obj%file_duration_units
!! @return file_duration_units of a diag_yaml_file_obj
-pure function get_file_duration_units (diag_files_obj) &
+pure function get_file_duration_units (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%file_duration_units(diag_files_obj%current_new_file_freq_index)
+ res = this%file_duration_units(this%current_new_file_freq_index)
end function get_file_duration_units
!> @brief Inquiry for diag_files_obj%file_varlist
!! @return file_varlist of a diag_yaml_file_obj
-pure function get_file_varlist (diag_files_obj) &
+pure function get_file_varlist (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
character (:), allocatable :: res(:) !< What is returned
- res = diag_files_obj%file_varlist
+ res = this%file_varlist
end function get_file_varlist
!> @brief Inquiry for diag_files_obj%file_global_meta
!! @return file_global_meta of a diag_yaml_file_obj
-pure function get_file_global_meta (diag_files_obj) &
+pure function get_file_global_meta (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
character (:), allocatable :: res(:,:) !< What is returned
- res = diag_files_obj%file_global_meta
+ res = this%file_global_meta
end function get_file_global_meta
!> @brief Get the integer equivalent of the time to use to determine the filename,
!! if using a wildcard file name (i.e ocn%4yr%2mo%2dy%2hr)
!! @return the integer equivalent of the time to use to determine the filename
-pure function get_filename_time(diag_files_obj) &
+pure function get_filename_time(this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_files_obj%filename_time
+ res = this%filename_time
end function
!> @brief Inquiry for whether file_global_meta is allocated
!! @return Flag indicating if file_global_meta is allocated
-function is_global_meta(diag_files_obj) &
+function is_global_meta(this) &
result(res)
- class (diagYamlFiles_type), intent(in) :: diag_files_obj !< The object being inquiried
+ class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
logical :: res
res = .false.
- if (allocated(diag_files_obj%file_global_meta)) &
+ if (allocated(this%file_global_meta)) &
res = .true.
end function
@@ -1088,113 +1088,113 @@ subroutine increase_new_file_freq_index(this)
!!!!!!! YAML VAR INQUIRIES !!!!!!!
!> @brief Inquiry for diag_yaml_files_var_obj%var_fname
!! @return var_fname of a diag_yaml_files_var_obj
-pure function get_var_fname (diag_var_obj) &
+pure function get_var_fname (this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_fname
+ res = this%var_fname
end function get_var_fname
!> @brief Inquiry for diag_yaml_files_var_obj%var_varname
!! @return var_varname of a diag_yaml_files_var_obj
-pure function get_var_varname (diag_var_obj) &
+pure function get_var_varname (this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_varname
+ res = this%var_varname
end function get_var_varname
!> @brief Inquiry for diag_yaml_files_var_obj%var_reduction
!! @return var_reduction of a diag_yaml_files_var_obj
-pure function get_var_reduction (diag_var_obj) &
+pure function get_var_reduction (this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
integer, allocatable :: res !< What is returned
- res = diag_var_obj%var_reduction
+ res = this%var_reduction
end function get_var_reduction
!> @brief Inquiry for diag_yaml_files_var_obj%var_module
!! @return var_module of a diag_yaml_files_var_obj
-pure function get_var_module (diag_var_obj) &
+pure function get_var_module (this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_module
+ res = this%var_module
end function get_var_module
!> @brief Inquiry for diag_yaml_files_var_obj%var_kind
!! @return var_kind of a diag_yaml_files_var_obj
-pure function get_var_kind (diag_var_obj) &
+pure function get_var_kind (this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
integer, allocatable :: res !< What is returned
- res = diag_var_obj%var_kind
+ res = this%var_kind
end function get_var_kind
!> @brief Inquiry for diag_yaml_files_var_obj%var_outname
!! @return var_outname of a diag_yaml_files_var_obj
-pure function get_var_outname (diag_var_obj) &
+pure function get_var_outname (this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- if (diag_var_obj%has_var_outname()) then
- res = diag_var_obj%var_outname
+ if (this%has_var_outname()) then
+ res = this%var_outname
else
- res = diag_var_obj%var_varname !< If outname is not set, the variable name will be used
+ res = this%var_varname !< If outname is not set, the variable name will be used
endif
end function get_var_outname
!> @brief Inquiry for diag_yaml_files_var_obj%var_longname
!! @return var_longname of a diag_yaml_files_var_obj
-pure function get_var_longname (diag_var_obj) &
+pure function get_var_longname (this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_longname
+ res = this%var_longname
end function get_var_longname
!> @brief Inquiry for diag_yaml_files_var_obj%var_units
!! @return var_units of a diag_yaml_files_var_obj
-pure function get_var_units (diag_var_obj) &
+pure function get_var_units (this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
character (len=:), allocatable :: res !< What is returned
- res = diag_var_obj%var_units
+ res = this%var_units
end function get_var_units
!> @brief Inquiry for diag_yaml_files_var_obj%var_zbounds
!! @return var_zbounds of a diag_yaml_files_var_obj
-pure function get_var_zbounds (diag_var_obj) &
+pure function get_var_zbounds (this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
real(kind=r4_kind) :: res(2) !< What is returned
- res = diag_var_obj%var_zbounds
+ res = this%var_zbounds
end function get_var_zbounds
!> @brief Inquiry for diag_yaml_files_var_obj%var_attributes
!! @return var_attributes of a diag_yaml_files_var_obj
-pure function get_var_attributes(diag_var_obj) &
+pure function get_var_attributes(this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned
- res = diag_var_obj%var_attributes
+ res = this%var_attributes
end function get_var_attributes
!> @brief Inquiry for diag_yaml_files_var_obj%n_diurnal
!! @return the number of diurnal samples of a diag_yaml_files_var_obj
-pure function get_n_diurnal(diag_var_obj) &
+pure function get_n_diurnal(this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_var_obj%n_diurnal
+ res = this%n_diurnal
end function get_n_diurnal
!> @brief Inquiry for diag_yaml_files_var_obj%pow_value
!! @return the pow_value of a diag_yaml_files_var_obj
-pure function get_pow_value(diag_var_obj) &
+pure function get_pow_value(this) &
result (res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
integer :: res !< What is returned
- res = diag_var_obj%pow_value
+ res = this%pow_value
end function get_pow_value
!> @brief Inquiry for whether var_attributes is allocated
!! @return Flag indicating if var_attributes is allocated
-function is_var_attributes(diag_var_obj) &
+function is_var_attributes(this) &
result(res)
- class (diagYamlFilesVar_type), intent(in) :: diag_var_obj !< The object being inquiried
+ class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried
logical :: res
res = .false.
- if (allocated(diag_var_obj%var_attributes)) &
+ if (allocated(this%var_attributes)) &
res = .true.
end function is_var_attributes
@@ -1212,137 +1212,137 @@ subroutine diag_yaml_files_obj_init(obj)
obj%current_new_file_freq_index = 1
end subroutine diag_yaml_files_obj_init
-!> @brief Checks if obj%file_fname is allocated
-!! @return true if obj%file_fname is allocated
-pure logical function has_file_fname (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_fname = allocated(obj%file_fname)
+!> @brief Checks if diag_file_obj%file_fname is allocated
+!! @return true if diag_file_obj%file_fname is allocated
+pure logical function has_file_fname (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_fname = allocated(this%file_fname)
end function has_file_fname
-!> @brief Checks if obj%file_frequnit is allocated
-!! @return true if obj%file_frequnit is allocated
-pure logical function has_file_frequnit (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_frequnit = obj%file_frequnit(obj%current_new_file_freq_index) .NE. DIAG_NULL
+!> @brief Checks if diag_file_obj%file_frequnit is allocated
+!! @return true if diag_file_obj%file_frequnit is allocated
+pure logical function has_file_frequnit (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_frequnit = this%file_frequnit(this%current_new_file_freq_index) .NE. DIAG_NULL
end function has_file_frequnit
-!> @brief obj%file_freq is on the stack, so the object always has it
-!! @return true if obj%file_freq is allocated
-pure logical function has_file_freq (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+!> @brief diag_file_obj%file_freq is on the stack, so the object always has it
+!! @return true if diag_file_obj%file_freq is allocated
+pure logical function has_file_freq (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
has_file_freq = .true.
end function has_file_freq
-!> @brief Checks if obj%file_timeunit is allocated
-!! @return true if obj%file_timeunit is allocated
-pure logical function has_file_timeunit (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_timeunit = obj%file_timeunit .ne. diag_null
+!> @brief Checks if diag_file_obj%file_timeunit is allocated
+!! @return true if diag_file_obj%file_timeunit is allocated
+pure logical function has_file_timeunit (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_timeunit = this%file_timeunit .ne. diag_null
end function has_file_timeunit
-!> @brief Checks if obj%file_unlimdim is allocated
-!! @return true if obj%file_unlimdim is allocated
-pure logical function has_file_unlimdim (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_unlimdim = allocated(obj%file_unlimdim)
+!> @brief Checks if diag_file_obj%file_unlimdim is allocated
+!! @return true if diag_file_obj%file_unlimdim is allocated
+pure logical function has_file_unlimdim (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_unlimdim = allocated(this%file_unlimdim)
end function has_file_unlimdim
-!> @brief Checks if obj%file_write is on the stack, so this will always be true
+!> @brief Checks if diag_file_obj%file_write is on the stack, so this will always be true
!! @return true
-pure logical function has_file_write (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
+pure logical function has_file_write (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
has_file_write = .true.
end function has_file_write
-!> @brief Checks if obj%file_sub_region is being used and has the sub region variables allocated
-!! @return true if obj%file_sub_region sub region variables are allocated
-pure logical function has_file_sub_region (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- if ( obj%file_sub_region%grid_type .eq. latlon_gridtype .or. obj%file_sub_region%grid_type .eq. index_gridtype) then
+!> @brief Checks if diag_file_obj%file_sub_region is being used and has the sub region variables allocated
+!! @return true if diag_file_obj%file_sub_region sub region variables are allocated
+pure logical function has_file_sub_region (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ if ( this%file_sub_region%grid_type .eq. latlon_gridtype .or. this%file_sub_region%grid_type .eq. index_gridtype) then
has_file_sub_region = .true.
else
has_file_sub_region = .false.
endif
end function has_file_sub_region
-!> @brief obj%file_new_file_freq is defined on the stack, so this will return true
+!> @brief diag_file_obj%file_new_file_freq is defined on the stack, so this will return true
!! @return true
-pure logical function has_file_new_file_freq (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_new_file_freq = obj%file_new_file_freq(obj%current_new_file_freq_index) .ne. DIAG_NULL
+pure logical function has_file_new_file_freq (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_new_file_freq = this%file_new_file_freq(this%current_new_file_freq_index) .ne. DIAG_NULL
end function has_file_new_file_freq
-!> @brief Checks if obj%file_new_file_freq_units is allocated
-!! @return true if obj%file_new_file_freq_units is allocated
-pure logical function has_file_new_file_freq_units (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_new_file_freq_units = obj%file_new_file_freq_units(obj%current_new_file_freq_index) .ne. diag_null
+!> @brief Checks if diag_file_obj%file_new_file_freq_units is allocated
+!! @return true if diag_file_obj%file_new_file_freq_units is allocated
+pure logical function has_file_new_file_freq_units (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_new_file_freq_units = this%file_new_file_freq_units(this%current_new_file_freq_index) .ne. diag_null
end function has_file_new_file_freq_units
-!> @brief Checks if obj%file_start_time is allocated
-!! @return true if obj%file_start_time is allocated
-pure logical function has_file_start_time (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_start_time = allocated(obj%file_start_time)
+!> @brief Checks if diag_file_obj%file_start_time is allocated
+!! @return true if diag_file_obj%file_start_time is allocated
+pure logical function has_file_start_time (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_start_time = allocated(this%file_start_time)
end function has_file_start_time
-!> @brief obj%file_duration is allocated on th stack, so this is always true
+!> @brief diag_file_obj%file_duration is allocated on th stack, so this is always true
!! @return true
-pure logical function has_file_duration (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_duration = obj%file_duration(obj%current_new_file_freq_index) .ne. DIAG_NULL
+pure logical function has_file_duration (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_duration = this%file_duration(this%current_new_file_freq_index) .ne. DIAG_NULL
end function has_file_duration
-!> @brief obj%file_duration_units is on the stack, so this will retrun true
+!> @brief diag_file_obj%file_duration_units is on the stack, so this will retrun true
!! @return true
-pure logical function has_file_duration_units (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_duration_units = obj%file_duration_units(obj%current_new_file_freq_index) .ne. diag_null
+pure logical function has_file_duration_units (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_duration_units = this%file_duration_units(this%current_new_file_freq_index) .ne. diag_null
end function has_file_duration_units
-!> @brief Checks if obj%file_varlist is allocated
-!! @return true if obj%file_varlist is allocated
-pure logical function has_file_varlist (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_varlist = allocated(obj%file_varlist)
+!> @brief Checks if diag_file_obj%file_varlist is allocated
+!! @return true if diag_file_obj%file_varlist is allocated
+pure logical function has_file_varlist (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_varlist = allocated(this%file_varlist)
end function has_file_varlist
-!> @brief Checks if obj%file_global_meta is allocated
-!! @return true if obj%file_global_meta is allocated
-pure logical function has_file_global_meta (obj)
- class(diagYamlFiles_type), intent(in) :: obj !< diagYamlFiles_type object to initialize
- has_file_global_meta = allocated(obj%file_global_meta)
+!> @brief Checks if diag_file_obj%file_global_meta is allocated
+!! @return true if diag_file_obj%file_global_meta is allocated
+pure logical function has_file_global_meta (this)
+ class(diagYamlFiles_type), intent(in) :: this !< diagYamlFiles_type object to initialize
+ has_file_global_meta = allocated(this%file_global_meta)
end function has_file_global_meta
-!> @brief Checks if obj%var_fname is allocated
-!! @return true if obj%var_fname is allocated
-pure logical function has_var_fname (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_fname = allocated(obj%var_fname)
+!> @brief Checks if diag_file_obj%var_fname is allocated
+!! @return true if diag_file_obj%var_fname is allocated
+pure logical function has_var_fname (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ has_var_fname = allocated(this%var_fname)
end function has_var_fname
-!> @brief Checks if obj%var_varname is allocated
-!! @return true if obj%var_varname is allocated
-pure logical function has_var_varname (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_varname = allocated(obj%var_varname)
+!> @brief Checks if diag_file_obj%var_varname is allocated
+!! @return true if diag_file_obj%var_varname is allocated
+pure logical function has_var_varname (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ has_var_varname = allocated(this%var_varname)
end function has_var_varname
-!> @brief Checks if obj%var_reduction is allocated
-!! @return true if obj%var_reduction is allocated
-pure logical function has_var_reduction (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_reduction = allocated(obj%var_reduction)
+!> @brief Checks if diag_file_obj%var_reduction is allocated
+!! @return true if diag_file_obj%var_reduction is allocated
+pure logical function has_var_reduction (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ has_var_reduction = allocated(this%var_reduction)
end function has_var_reduction
-!> @brief Checks if obj%var_module is allocated
-!! @return true if obj%var_module is allocated
-pure logical function has_var_module (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_module = allocated(obj%var_module)
+!> @brief Checks if diag_file_obj%var_module is allocated
+!! @return true if diag_file_obj%var_module is allocated
+pure logical function has_var_module (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ has_var_module = allocated(this%var_module)
end function has_var_module
-!> @brief Checks if obj%var_kind is allocated
-!! @return true if obj%var_kind is allocated
-pure logical function has_var_kind (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_kind = allocated(obj%var_kind)
+!> @brief Checks if diag_file_obj%var_kind is allocated
+!! @return true if diag_file_obj%var_kind is allocated
+pure logical function has_var_kind (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ has_var_kind = allocated(this%var_kind)
end function has_var_kind
-!> @brief obj%var_write is on the stack, so this returns true
+!> @brief diag_file_obj%var_write is on the stack, so this returns true
!! @return true
-pure logical function has_var_write (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
+pure logical function has_var_write (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
has_var_write = .true.
end function has_var_write
-!> @brief Checks if obj%var_outname is allocated
-!! @return true if obj%var_outname is allocated
-pure logical function has_var_outname (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- if (allocated(obj%var_outname)) then
- if (trim(obj%var_outname) .ne. "") then
+!> @brief Checks if diag_file_obj%var_outname is allocated
+!! @return true if diag_file_obj%var_outname is allocated
+pure logical function has_var_outname (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ if (allocated(this%var_outname)) then
+ if (trim(this%var_outname) .ne. "") then
has_var_outname = .true.
else
has_var_outname = .false.
@@ -1351,66 +1351,66 @@ pure logical function has_var_outname (obj)
has_var_outname = .true.
endif
end function has_var_outname
-!> @brief Checks if obj%var_longname is allocated
-!! @return true if obj%var_longname is allocated
-pure logical function has_var_longname (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_longname = allocated(obj%var_longname)
+!> @brief Checks if diag_file_obj%var_longname is allocated
+!! @return true if diag_file_obj%var_longname is allocated
+pure logical function has_var_longname (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ has_var_longname = allocated(this%var_longname)
end function has_var_longname
-!> @brief Checks if obj%var_units is allocated
-!! @return true if obj%var_units is allocated
-pure logical function has_var_units (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_units = allocated(obj%var_units)
+!> @brief Checks if diag_file_obj%var_units is allocated
+!! @return true if diag_file_obj%var_units is allocated
+pure logical function has_var_units (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ has_var_units = allocated(this%var_units)
end function has_var_units
-!> @brief Checks if obj%var_zbounds is allocated
-!! @return true if obj%var_zbounds is allocated
-pure logical function has_var_zbounds (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_zbounds = any(obj%var_zbounds .ne. diag_null)
+!> @brief Checks if diag_file_obj%var_zbounds is allocated
+!! @return true if diag_file_obj%var_zbounds is allocated
+pure logical function has_var_zbounds (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ has_var_zbounds = any(this%var_zbounds .ne. diag_null)
end function has_var_zbounds
-!> @brief Checks if obj%var_attributes is allocated
-!! @return true if obj%var_attributes is allocated
-pure logical function has_var_attributes (obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to initialize
- has_var_attributes = allocated(obj%var_attributes)
+!> @brief Checks if diag_file_obj%var_attributes is allocated
+!! @return true if diag_file_obj%var_attributes is allocated
+pure logical function has_var_attributes (this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to initialize
+ has_var_attributes = allocated(this%var_attributes)
end function has_var_attributes
-!> @brief Checks if obj%n_diurnal is set
-!! @return true if obj%n_diurnal is set
-pure logical function has_n_diurnal(obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to inquire
- has_n_diurnal = (obj%n_diurnal .ne. 0)
+!> @brief Checks if diag_file_obj%n_diurnal is set
+!! @return true if diag_file_obj%n_diurnal is set
+pure logical function has_n_diurnal(this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to inquire
+ has_n_diurnal = (this%n_diurnal .ne. 0)
end function has_n_diurnal
-!> @brief Checks if obj%pow_value is set
-!! @return true if obj%pow_value is set
-pure logical function has_pow_value(obj)
- class(diagYamlFilesVar_type), intent(in) :: obj !< diagYamlvar_type object to inquire
- has_pow_value = (obj%pow_value .ne. 0)
+!> @brief Checks if diag_file_obj%pow_value is set
+!! @return true if diag_file_obj%pow_value is set
+pure logical function has_pow_value(this)
+ class(diagYamlFilesVar_type), intent(in) :: this !< diagYamlvar_type object to inquire
+ has_pow_value = (this%pow_value .ne. 0)
end function has_pow_value
-!> @brief Checks if obj%diag_title is allocated
-!! @return true if obj%diag_title is allocated
-pure logical function has_diag_title (obj)
- class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
- has_diag_title = allocated(obj%diag_title)
+!> @brief Checks if diag_file_obj%diag_title is allocated
+!! @return true if diag_file_obj%diag_title is allocated
+pure logical function has_diag_title (this)
+ class(diagYamlObject_type), intent(in) :: this !< diagYamlObject_type object to inquire
+ has_diag_title = allocated(this%diag_title)
end function has_diag_title
-!> @brief obj%diag_basedate is on the stack, so this is always true
+!> @brief diag_file_obj%diag_basedate is on the stack, so this is always true
!! @return true
-pure logical function has_diag_basedate (obj)
- class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
+pure logical function has_diag_basedate (this)
+ class(diagYamlObject_type), intent(in) :: this !< diagYamlObject_type object to initialize
has_diag_basedate = .true.
end function has_diag_basedate
-!> @brief Checks if obj%diag_files is allocated
-!! @return true if obj%diag_files is allocated
-pure logical function has_diag_files (obj)
- class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
- has_diag_files = allocated(obj%diag_files)
+!> @brief Checks if diag_file_obj%diag_files is allocated
+!! @return true if diag_file_obj%diag_files is allocated
+pure logical function has_diag_files (this)
+ class(diagYamlObject_type), intent(in) :: this !< diagYamlObject_type object to initialize
+ has_diag_files = allocated(this%diag_files)
end function has_diag_files
-!> @brief Checks if obj%diag_fields is allocated
-!! @return true if obj%diag_fields is allocated
-pure logical function has_diag_fields (obj)
- class(diagYamlObject_type), intent(in) :: obj !< diagYamlObject_type object to initialize
- has_diag_fields = allocated(obj%diag_fields)
+!> @brief Checks if diag_file_obj%diag_fields is allocated
+!! @return true if diag_file_obj%diag_fields is allocated
+pure logical function has_diag_fields (this)
+ class(diagYamlObject_type), intent(in) :: this !< diagYamlObject_type object to initialize
+ has_diag_fields = allocated(this%diag_fields)
end function has_diag_fields
!> @brief Determine the number of unique diag_fields in the diag_yaml_object
From 9e255a663bb91a6cde39c961bc46c41695aa129e Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 29 Mar 2023 11:32:02 -0400
Subject: [PATCH 088/168] fix: Modern diag manager check if field is registered
(#1151)
---
diag_manager/fms_diag_file_object.F90 | 10 ++++++++++
diag_manager/fms_diag_object.F90 | 3 +++
2 files changed, 13 insertions(+)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 31e185f0a6..12e453fb0f 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -94,6 +94,7 @@ module fms_diag_file_object_mod
contains
procedure, public :: add_field_and_yaml_id
+ procedure, public :: is_field_registered
procedure, public :: init_diurnal_axis
procedure, public :: has_file_metadata_from_model
procedure, public :: has_fileobj
@@ -256,6 +257,15 @@ logical function fms_diag_files_object_init (files_array)
endif
end function fms_diag_files_object_init
+!< @brief Determine if the field corresponding to the field_id was registered to the file
+!! @return .True. if the field was registed to the file
+pure logical function is_field_registered(this, field_id)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
+ integer, intent(in) :: field_id !< Id of the field to check
+
+ is_field_registered = this%field_registered(field_id)
+end function is_field_registered
+
!> \brief Adds a field and yaml ID to the file
subroutine add_field_and_yaml_id (this, new_field_id, yaml_id)
class(fmsDiagFile_type), intent(inout) :: this !< The file object
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index aa0cde7141..b5ac522847 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -544,6 +544,9 @@ subroutine fms_diag_send_complete(this, time_step)
allocate (file_field_ids(size(diag_file%FMS_diag_file%get_field_ids() )))
file_field_ids = diag_file%FMS_diag_file%get_field_ids()
field_loop: do ifield = 1, size(file_field_ids)
+ ! If the field is not registered go away
+ if (.not. diag_file%FMS_diag_file%is_field_registered(ifield)) cycle
+
diag_field => this%FMS_diag_fields(file_field_ids(ifield))
!> Check if math needs to be done
! math = diag_field%get_math_needs_to_be_done()
From d8605312b02de84b433010bd2593b4ba5fdb8847 Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Thu, 6 Apr 2023 09:40:27 -0400
Subject: [PATCH 089/168] fix: modern diag add has routine and fixes some type
bound procedure formatting (#1182)
---
diag_manager/fms_diag_field_object.F90 | 8 ++++++++
diag_manager/fms_diag_object.F90 | 12 ++++++------
2 files changed, 14 insertions(+), 6 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index f82ca0d842..6742f81766 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -111,6 +111,7 @@ module fms_diag_field_object_mod
procedure :: has_interp_method
procedure :: has_frequency
procedure :: has_tile_count
+ procedure :: has_axis_ids
procedure :: has_area
procedure :: has_volume
procedure :: has_missing_value
@@ -1308,6 +1309,13 @@ pure logical function has_tile_count (this)
has_tile_count = allocated(this%tile_count)
end function has_tile_count
+!> @brief Checks if axis_ids of the object is allocated
+!! @return true if it is allocated
+pure logical function has_axis_ids (this)
+ class (fmsDiagField_type), intent(in) :: this !< diag field object
+ has_axis_ids = allocated(this%axis_ids)
+end function has_axis_ids
+
!> @brief Checks if obj%area is allocated
!! @return true if obj%area is allocated
pure logical function has_area (this)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index b5ac522847..a28a6f871a 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -213,7 +213,7 @@ integer function fms_register_diag_field_obj &
!> Use pointers for convenience
fieldptr => this%FMS_diag_fields(this%registered_variables)
!> Register the data for the field
- call fieldptr%register(modname, varname, diag_field_indices, fms_diag_object%diag_axis, &
+ call fieldptr%register(modname, varname, diag_field_indices, this%diag_axis, &
axes=axes, longname=longname, units=units, missing_value=missing_value, varRange= varRange, &
mask_variant= mask_variant, standname=standname, do_not_log=do_not_log, err_msg=err_msg, &
interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
@@ -681,9 +681,9 @@ end subroutine fms_diag_axis_add_attribute
#ifdef use_yaml
!> \brief Gets the diag field ID from the module name and field name.
!> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered
-PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, field_name) &
+PURE FUNCTION fms_get_diag_field_id_from_name(this, module_name, field_name) &
result(diag_field_id)
- class(fmsDiagObject_type), intent (in) :: fms_diag_object !< The diag object
+ class(fmsDiagObject_type), intent (in) :: this !< The diag object, the caller
CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
integer :: diag_field_id
@@ -691,9 +691,9 @@ PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, fiel
!> Initialize to not found
diag_field_id = DIAG_FIELD_NOT_FOUND
!> Loop through fields to find it.
- if (fms_diag_object%registered_variables < 1) return
- do i=1,fms_diag_object%registered_variables
- diag_field_id = fms_diag_object%FMS_diag_fields(i)%id_from_name(module_name, field_name)
+ if (this%registered_variables < 1) return
+ do i=1, this%registered_variables
+ diag_field_id = this%FMS_diag_fields(i)%id_from_name(module_name, field_name)
if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return
enddo
END FUNCTION fms_get_diag_field_id_from_name
From eb514147f6c45995d4af9eea281ee758af12f3aa Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Thu, 6 Apr 2023 09:41:15 -0400
Subject: [PATCH 090/168] fix: bounds typo and change get_buffer to reference
its argument instead of the module variable (#1160)
---
diag_manager/fms_diag_buffer.F90 | 5 +++--
diag_manager/fms_diag_object.F90 | 4 ++--
2 files changed, 5 insertions(+), 4 deletions(-)
diff --git a/diag_manager/fms_diag_buffer.F90 b/diag_manager/fms_diag_buffer.F90
index 4d6c91783b..37a71439bb 100644
--- a/diag_manager/fms_diag_buffer.F90
+++ b/diag_manager/fms_diag_buffer.F90
@@ -50,7 +50,8 @@ module fms_diag_buffer_mod
procedure :: flush_buffer
procedure :: remap_buffer
procedure :: set_buffer_id
- ! TODO deferred routines, will require some interfaces
+ ! TODO could make these 'defered' ie. declared here but defined in each child type
+ ! holding off cause the class(*) + polymorphism in here is probably already enough to upset the gods of compilation
!procedure(allocate_buffer), deferred :: allocate_buffer
!procedure, deferred :: get_buffer
!procedure, deferred :: initialize_buffer
@@ -64,7 +65,7 @@ module fms_diag_buffer_mod
!> Scalar buffer type to extend fmsDiagBufferContainer_type
type, extends(fmsDiagBuffer_class) :: buffer0d_type
- class(*), allocatable :: buffer(:) !< "scalar" numberic buffer value
+ class(*), allocatable :: buffer(:) !< "scalar" numeric buffer value
!! will only be allocated to hold 1 value
class(*), allocatable :: counter(:) !< (x,y,z, time-of-day) used in the time averaging functions
contains
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index a28a6f871a..061e2688c3 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -722,9 +722,9 @@ function get_diag_buffer(this, bufferid) &
class(fmsDiagObject_type), intent(in) :: this
integer, intent(in) :: bufferid
class(fmsDiagBuffer_class),allocatable:: rslt
- if( (bufferid .gt. UBOUND(this%FMS_diag_buffers, 1)) .or. (bufferid .lt. UBOUND(this%FMS_diag_buffers, 1))) &
+ if( (bufferid .gt. UBOUND(this%FMS_diag_buffers, 1)) .or. (bufferid .lt. LBOUND(this%FMS_diag_buffers, 1))) &
call mpp_error(FATAL, 'get_diag_bufer: invalid bufferid given')
- rslt = fms_diag_object%FMS_diag_buffers(bufferid)%diag_buffer_obj
+ rslt = this%FMS_diag_buffers(bufferid)%diag_buffer_obj
end function
#endif
From 20b9efe1d3e633af193acc77686b3c2468af6a04 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 6 Apr 2023 12:56:23 -0400
Subject: [PATCH 091/168] feat: modern diag store a variable that defines if a
variable is a scalar (#1175)
---
diag_manager/fms_diag_field_object.F90 | 14 +++++++++++++-
1 file changed, 13 insertions(+), 1 deletion(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 6742f81766..2e5c588f03 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -44,6 +44,7 @@ module fms_diag_field_object_mod
type(fmsDiagAttribute_type), allocatable :: attributes(:) !< attributes for the variable
integer, private :: num_attributes !< Number of attributes currently added
logical, allocatable, private :: static !< true if this is a static var
+ logical, allocatable, private :: scalar !< .True. if the variable is a scalar
logical, allocatable, private :: registered !< true when registered
logical, allocatable, private :: mask_variant !< If there is a mask variant
logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field
@@ -89,6 +90,7 @@ module fms_diag_field_object_mod
procedure :: vartype_inq => what_is_vartype
! Check functions
procedure :: is_static => diag_obj_is_static
+ procedure :: is_scalar
procedure :: is_registered => get_registered
procedure :: is_registeredB => diag_obj_is_registered
procedure :: is_mask_variant => get_mask_variant
@@ -228,10 +230,12 @@ subroutine fms_register_diag_field_obj &
!> Add axis and domain information
if (present(axes)) then
+ this%scalar = .false.
this%axis_ids = axes
call get_domain_and_domain_type(diag_axis, this%axis_ids, this%type_of_domain, this%domain, this%varname)
else
- !> The variable is a scalar
+ !> The variable is a scalar
+ this%scalar = .true.
this%type_of_domain = NO_DOMAIN
this%domain => null()
endif
@@ -610,6 +614,14 @@ function diag_obj_is_static (this) result (rslt)
rslt = this%static
end function diag_obj_is_static
+!> @brief Determine if the field is a scalar
+!! @return .True. if the field is a scalar
+function is_scalar (this) result (rslt)
+ class(fmsDiagField_type), intent(in) :: this !< diag_field object
+ logical :: rslt
+ rslt = this%scalar
+end function is_scalar
+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Get functions
From 707ddab7d55ed7f07ba0beeafeba93bcc47c9559 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Thu, 6 Apr 2023 15:09:16 -0400
Subject: [PATCH 092/168] fix: modern diag rename to add output to buffer names
(#1184)
---
CMakeLists.txt | 6 +
diag_manager/Makefile.am | 25 ++-
diag_manager/fms_diag_object.F90 | 22 +--
..._buffer.F90 => fms_diag_output_buffer.F90} | 161 +++++++++---------
test_fms/diag_manager/test_diag_buffer.F90 | 14 +-
5 files changed, 125 insertions(+), 103 deletions(-)
rename diag_manager/{fms_diag_buffer.F90 => fms_diag_output_buffer.F90} (92%)
diff --git a/CMakeLists.txt b/CMakeLists.txt
index a9922bae65..e975010fdb 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -139,6 +139,12 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_dlinked_list.F90
diag_manager/fms_diag_object_container.F90
diag_manager/fms_diag_buffer.F90
+ diag_manager/fms_diag_output_buffer.F90
+ diag_manager/fms_diag_time_reduction.F90
+ diag_manager/fms_diag_outfield.F90
+ diag_manager/fms_diag_elem_weight_procs.F90
+ diag_manager/fms_diag_fieldbuff_update.F90
+ diag_manager/fms_diag_bbox.F90
drifters/cloud_interpolator.F90
drifters/drifters.F90
drifters/drifters_comm.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 91793c8f88..aa0e5c3800 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -53,7 +53,14 @@ libdiag_manager_la_SOURCES = \
fms_diag_axis_object.F90 \
fms_diag_object_container.F90 \
fms_diag_dlinked_list.F90 \
- fms_diag_buffer.F90
+ fms_diag_output_buffer.F90 \
+ fms_diag_time_reduction.F90 \
+ fms_diag_outfield.F90 \
+ fms_diag_elem_weight_procs.F90 \
+ fms_diag_fieldbuff_update.F90 \
+ fms_diag_bbox.F90 \
+ include/fms_diag_fieldbuff_update.inc \
+ include/fms_diag_fieldbuff_update.fh
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
@@ -66,8 +73,9 @@ diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEX
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_time_utils_mod.$(FC_MODEXT) \
- fms_diag_buffer_mod.$(FC_MODEXT)
-fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
+ fms_diag_output_buffer_mod.$(FC_MODEXT)
+fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
+ fms_diag_axis_object_mod.$(FC_MODEXT)
fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_axis_object_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
@@ -103,8 +111,15 @@ MODFILES = \
fms_diag_axis_object_mod.$(FC_MODEXT) \
fms_diag_dlinked_list_mod.$(FC_MODEXT) \
fms_diag_object_container_mod.$(FC_MODEXT) \
- fms_diag_buffer_mod.$(FC_MODEXT) \
- diag_manager_mod.$(FC_MODEXT)
+ fms_diag_output_buffer_mod.$(FC_MODEXT) \
+ diag_manager_mod.$(FC_MODEXT) \
+ fms_diag_time_reduction_mod.$(FC_MODEXT) \
+ fms_diag_outfield_mod.$(FC_MODEXT) \
+ fms_diag_bbox_mod.$(FC_MODEXT) \
+ fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \
+ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \
+ include/fms_diag_fieldbuff_update.inc \
+ include/fms_diag_fieldbuff_update.fh
nodist_include_HEADERS = $(MODFILES)
BUILT_SOURCES = $(MODFILES)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 061e2688c3..713e37529c 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -33,7 +33,7 @@ module fms_diag_object_mod
&diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, &
&fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, &
&parse_compress_att, get_axis_id_from_name
-use fms_diag_buffer_mod
+use fms_diag_output_buffer_mod
#endif
#if defined(_OPENMP)
use omp_lib
@@ -49,7 +49,8 @@ module fms_diag_object_mod
!TODO: Remove FMS prefix from variables in this type
class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files
class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields
- type(fmsDiagBufferContainer_type), allocatable :: FMS_diag_buffers(:) !< array of buffer objects
+ type(fmsDiagOutputBufferContainer_type), allocatable :: FMS_diag_output_buffers(:) !< array of output buffer objects
+ !! one for each variable in the diag_table.yaml
integer, private :: registered_buffers = 0 !< number of registered buffers, per dimension
class(fmsDiagAxisContainer_type), allocatable :: diag_axis(:) !< Array of diag_axis
type(time_type) :: current_model_time !< The current model time
@@ -113,7 +114,7 @@ subroutine fms_diag_object_init (this,diag_subset_output)
this%axes_initialized = fms_diag_axis_object_init(this%diag_axis)
this%files_initialized = fms_diag_files_object_init(this%FMS_diag_files)
this%fields_initialized = fms_diag_fields_object_init(this%FMS_diag_fields)
- this%buffers_initialized = fms_diag_buffer_init(this%FMS_diag_buffers, SIZE(diag_yaml%get_diag_fields()))
+ this%buffers_initialized =fms_diag_output_buffer_init(this%FMS_diag_output_buffers,SIZE(diag_yaml%get_diag_fields()))
this%registered_variables = 0
this%registered_axis = 0
this%current_model_time = get_base_time()
@@ -139,12 +140,12 @@ subroutine fms_diag_object_end (this, time)
call this%fms_diag_do_io(is_end_of_run=.true.)
!TODO: Deallocate diag object arrays and clean up all memory
- do i=1, size(this%FMS_diag_buffers)
- if(allocated(this%FMS_diag_buffers(i)%diag_buffer_obj)) then
- call this%FMS_diag_buffers(i)%diag_buffer_obj%flush_buffer()
+ do i=1, size(this%FMS_diag_output_buffers)
+ if(allocated(this%FMS_diag_output_buffers(i)%diag_buffer_obj)) then
+ call this%FMS_diag_output_buffers(i)%diag_buffer_obj%flush_buffer()
endif
enddo
- deallocate(this%FMS_diag_buffers)
+ deallocate(this%FMS_diag_output_buffers)
this%axes_initialized = fms_diag_axis_object_end(this%diag_axis)
this%initialized = .false.
call diag_yaml_object_end
@@ -721,10 +722,11 @@ function get_diag_buffer(this, bufferid) &
result(rslt)
class(fmsDiagObject_type), intent(in) :: this
integer, intent(in) :: bufferid
- class(fmsDiagBuffer_class),allocatable:: rslt
- if( (bufferid .gt. UBOUND(this%FMS_diag_buffers, 1)) .or. (bufferid .lt. LBOUND(this%FMS_diag_buffers, 1))) &
+ class(fmsDiagOutputBuffer_class),allocatable:: rslt
+ if( (bufferid .gt. UBOUND(this%FMS_diag_output_buffers, 1)) .or. &
+ (bufferid .lt. LBOUND(this%FMS_diag_output_buffers, 1))) &
call mpp_error(FATAL, 'get_diag_bufer: invalid bufferid given')
- rslt = this%FMS_diag_buffers(bufferid)%diag_buffer_obj
+ rslt = this%FMS_diag_output_buffers(bufferid)%diag_buffer_obj
end function
#endif
diff --git a/diag_manager/fms_diag_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
similarity index 92%
rename from diag_manager/fms_diag_buffer.F90
rename to diag_manager/fms_diag_output_buffer.F90
index 37a71439bb..3036777526 100644
--- a/diag_manager/fms_diag_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -23,7 +23,7 @@
!! @description Holds buffered data for fmsDiagVars_type objects
!! buffer0-5d types extend fmsDiagBuffer_class, and upon allocation
!! are added to the module's buffer_lists depending on it's dimension
-module fms_diag_buffer_mod
+module fms_diag_output_buffer_mod
use platform_mod
use iso_c_binding
@@ -38,7 +38,7 @@ module fms_diag_buffer_mod
#ifdef use_yaml
!> @brief Object that holds buffered data and other diagnostics
!! Abstract to ensure use through its extensions(buffer0-5d types)
-type, abstract :: fmsDiagBuffer_class
+type, abstract :: fmsDiagOutputBuffer_class
integer, allocatable, private :: buffer_id !< index in buffer list
integer, allocatable, public :: num_elements(:) !< used in time-averaging
class(*), allocatable, public :: count_0d(:) !< used in time-averaging along with
@@ -56,15 +56,15 @@ module fms_diag_buffer_mod
!procedure, deferred :: get_buffer
!procedure, deferred :: initialize_buffer
-end type fmsDiagBuffer_class
+end type fmsDiagOutputBuffer_class
!> holds an allocated buffer0-5d object
-type :: fmsDiagBufferContainer_type
- class(fmsDiagBuffer_class), allocatable :: diag_buffer_obj !< any 0-5d buffer object
+type :: fmsDiagOutputBufferContainer_type
+ class(fmsDiagOutputBuffer_class), allocatable :: diag_buffer_obj !< any 0-5d buffer object
end type
!> Scalar buffer type to extend fmsDiagBufferContainer_type
-type, extends(fmsDiagBuffer_class) :: buffer0d_type
+type, extends(fmsDiagOutputBuffer_class) :: outputBuffer0d_type
class(*), allocatable :: buffer(:) !< "scalar" numeric buffer value
!! will only be allocated to hold 1 value
class(*), allocatable :: counter(:) !< (x,y,z, time-of-day) used in the time averaging functions
@@ -74,10 +74,10 @@ module fms_diag_buffer_mod
procedure :: add_to_buffer => add_to_buffer_0d
procedure :: get_buffer => get_0d
-end type buffer0d_type
+end type outputBuffer0d_type
!> 1D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagBuffer_class) :: buffer1d_type
+type, extends(fmsDiagOutputBuffer_class) :: outputBuffer1d_type
class(*), allocatable :: buffer(:) !< 1D numeric data array
class(*), allocatable :: counter(:) !< (x,y,z, time-of-day) used in the time averaging functions
contains
@@ -85,10 +85,10 @@ module fms_diag_buffer_mod
procedure :: initialize_buffer => initialize_buffer_1d
procedure :: add_to_buffer => add_to_buffer_1d
procedure :: get_buffer => get_1d
-end type buffer1d_type
+end type outputBuffer1d_type
!> 2D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagBuffer_class) :: buffer2d_type
+type, extends(fmsDiagOutputBuffer_class) :: outputBuffer2d_type
class(*), allocatable :: buffer(:,:) !< 2D numeric data array
class(*), allocatable :: counter(:,:) !< (x,y,z, time-of-day) used in the time averaging functions
contains
@@ -96,10 +96,10 @@ module fms_diag_buffer_mod
procedure :: initialize_buffer => initialize_buffer_2d
procedure :: add_to_buffer => add_to_buffer_2d
procedure :: get_buffer => get_2d
-end type buffer2d_type
+end type outputBuffer2d_type
!> 3D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagBuffer_class) :: buffer3d_type
+type, extends(fmsDiagOutputBuffer_class) :: outputBuffer3d_type
class(*), allocatable :: buffer(:,:,:) !< 3D numeric data array
class(*), allocatable :: counter(:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
contains
@@ -107,10 +107,10 @@ module fms_diag_buffer_mod
procedure :: initialize_buffer => initialize_buffer_3d
procedure :: add_to_buffer => add_to_buffer_3d
procedure :: get_buffer => get_3d
-end type buffer3d_type
+end type outputBuffer3d_type
!> 4D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagBuffer_class) :: buffer4d_type
+type, extends(fmsDiagOutputBuffer_class) :: outputBuffer4d_type
class(*), allocatable :: buffer(:,:,:,:) !< 4D numeric data array
class(*), allocatable :: counter(:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
contains
@@ -118,10 +118,10 @@ module fms_diag_buffer_mod
procedure :: initialize_buffer => initialize_buffer_4d
procedure :: add_to_buffer => add_to_buffer_4d
procedure :: get_buffer => get_4d
-end type buffer4d_type
+end type outputBuffer4d_type
!> 5D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagBuffer_class) :: buffer5d_type
+type, extends(fmsDiagOutputBuffer_class) :: outputBuffer5d_type
class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array
class(*), allocatable :: counter(:,:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
contains
@@ -129,20 +129,20 @@ module fms_diag_buffer_mod
procedure :: initialize_buffer => initialize_buffer_5d
procedure :: add_to_buffer => add_to_buffer_5d
procedure :: get_buffer => get_5d
-end type buffer5d_type
+end type outputBuffer5d_type
! public types
-public :: buffer0d_type
-public :: buffer1d_type
-public :: buffer2d_type
-public :: buffer3d_type
-public :: buffer4d_type
-public :: buffer5d_type
-public :: fmsDiagBuffer_class
-public :: fmsDiagBufferContainer_type
+public :: outputBuffer0d_type
+public :: outputBuffer1d_type
+public :: outputBuffer2d_type
+public :: outputBuffer3d_type
+public :: outputBuffer4d_type
+public :: outputBuffer5d_type
+public :: fmsDiagOutputBuffer_class
+public :: fmsDiagOutputBufferContainer_type
! public routines
-public :: fms_diag_buffer_init
+public :: fms_diag_output_buffer_init
contains
@@ -150,52 +150,51 @@ module fms_diag_buffer_mod
!> Initializes a list of diag buffers
!> @returns true if allocation is successfull
-logical function fms_diag_buffer_init(buffobjs, buff_list_size)
- type(fmsDiagBufferContainer_type), allocatable, intent(out) :: buffobjs(:) !< an array of buffer container types
+logical function fms_diag_output_buffer_init(buffobjs, buff_list_size)
+ type(fmsDiagOutputBufferContainer_type), allocatable, intent(out) :: buffobjs(:) !< an array of buffer container types
!! to allocate
- integer, intent(in) :: buff_list_size !< number of dimensions needed for
- !! the buffer data
+ integer, intent(in) :: buff_list_size !< size of buffer array to allocate
if (allocated(buffobjs)) call mpp_error(FATAL,'fms_diag_buffer_init: passed in buffobjs array is already allocated')
allocate(buffobjs(buff_list_size))
- fms_diag_buffer_init = allocated(buffobjs)
-end function fms_diag_buffer_init
+ fms_diag_output_buffer_init = allocated(buffobjs)
+end function fms_diag_output_buffer_init
!> Creates a container type encapsulating a new buffer object for the given dimensions.
!! The buffer object will still need to be allocated to a type via allocate_buffer() before use.
!> @result A fmsDiagBufferContainer_type that holds a bufferNd_type, where N is buff_dims
-function fms_diag_buffer_create_container(buff_dims) &
+function fms_diag_output_buffer_create_container(buff_dims) &
result(rslt)
integer, intent(in) :: buff_dims !< dimensions
- type(fmsDiagBufferContainer_type), allocatable :: rslt
+ type(fmsDiagOutputBufferContainer_type), allocatable :: rslt
character(len=5) :: dim_output !< string to output buff_dims on error
allocate(rslt)
select case (buff_dims)
case (0)
- allocate(buffer0d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer0d_type :: rslt%diag_buffer_obj)
case (1)
- allocate(buffer1d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer1d_type :: rslt%diag_buffer_obj)
case (2)
- allocate(buffer2d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer2d_type :: rslt%diag_buffer_obj)
case (3)
- allocate(buffer3d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer3d_type :: rslt%diag_buffer_obj)
case (4)
- allocate(buffer4d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer4d_type :: rslt%diag_buffer_obj)
case (5)
- allocate(buffer5d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer5d_type :: rslt%diag_buffer_obj)
case default
write( dim_output, *) buff_dims
dim_output = adjustl(dim_output)
call mpp_error(FATAL, 'fms_diag_buffer_create_container: invalid number of dimensions given:' // dim_output //&
'. Must be 0-5')
end select
-end function fms_diag_buffer_create_container
+end function fms_diag_output_buffer_create_container
!!--------generic routines for any fmsDiagBuffer_class objects
!> Setter for buffer_id for any buffer objects
subroutine set_buffer_id(this, id)
- class(fmsDiagBuffer_class), intent(inout) :: this !< buffer object to set id for
+ class(fmsDiagOutputBuffer_class), intent(inout) :: this !< buffer object to set id for
integer, intent(in) :: id !< positive integer id to set
if (.not.allocated(this%buffer_id) ) allocate(this%buffer_id)
this%buffer_id = id
@@ -204,35 +203,35 @@ end subroutine set_buffer_id
!> Remaps 0-5d data buffer from the given object onto a 5d array pointer.
!> @returns a 5D remapped buffer, with 1:1 for any added dimensions.
function remap_buffer(buffobj, field_name)
- class(fmsDiagBuffer_class), target, intent(inout) :: buffobj !< any dimension buffer object
+ class(fmsDiagOutputBuffer_class), target, intent(inout) :: buffobj !< any dimension buffer object
class(*), pointer :: remap_buffer(:,:,:,:,:)
character(len=*), intent(in) :: field_name !< name of field for error output
! get num dimensions from type extension
select type (buffobj)
- type is (buffer0d_type)
+ type is (outputBuffer0d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:1) => buffobj%buffer
- type is (buffer1d_type)
+ type is (outputBuffer1d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:1) => buffobj%buffer(1:size(buffobj%buffer,1))
- type is (buffer2d_type)
+ type is (outputBuffer2d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:1, 1:1, 1:1) => buffobj%buffer(:,:)
- type is (buffer3d_type)
+ type is (outputBuffer3d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), 1:1, 1:1) => &
& buffobj%buffer(:,:,:)
- type is (buffer4d_type)
+ type is (outputBuffer4d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
1:size(buffobj%buffer,4), 1:1) => buffobj%buffer(:,:,:,:)
- type is (buffer5d_type)
+ type is (outputBuffer5d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
@@ -245,24 +244,24 @@ end function remap_buffer
!> Deallocates data fields from a buffer object.
subroutine flush_buffer(this)
- class(fmsDiagBuffer_class), intent(inout) :: this !< any buffer object
+ class(fmsDiagOutputBuffer_class), intent(inout) :: this !< any buffer object
select type (this)
- type is (buffer0d_type)
+ type is (outputBuffer0d_type)
if (allocated(this%buffer)) deallocate(this%buffer)
if (allocated(this%counter)) deallocate(this%counter)
- type is (buffer1d_type)
+ type is (outputBuffer1d_type)
if (allocated(this%buffer)) deallocate(this%buffer)
if (allocated(this%counter)) deallocate(this%counter)
- type is (buffer2d_type)
+ type is (outputBuffer2d_type)
if (allocated(this%buffer)) deallocate(this%buffer)
if (allocated(this%counter)) deallocate(this%counter)
- type is (buffer3d_type)
+ type is (outputBuffer3d_type)
if (allocated(this%buffer)) deallocate(this%buffer)
if (allocated(this%counter)) deallocate(this%counter)
- type is (buffer4d_type)
+ type is (outputBuffer4d_type)
if (allocated(this%buffer)) deallocate(this%buffer)
if (allocated(this%counter)) deallocate(this%counter)
- type is (buffer5d_type)
+ type is (outputBuffer5d_type)
if (allocated(this%buffer)) deallocate(this%buffer)
if (allocated(this%counter)) deallocate(this%counter)
end select
@@ -276,7 +275,7 @@ end subroutine flush_buffer
!> Allocates scalar buffer data to the given buff_type.
subroutine allocate_buffer_0d(this, buff_type, field_name, diurnal_samples)
- class(buffer0d_type), intent(inout), target :: this !< scalar buffer object
+ class(outputBuffer0d_type), intent(inout), target :: this !< scalar buffer object
class(*),intent(in) :: buff_type !< allocates to the given type, value does not matter
character(len=*), intent(in) :: field_name !< field name for error output
integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
@@ -335,7 +334,7 @@ end subroutine allocate_buffer_0d
!> Allocates 1D buffer data to given buff_type.
subroutine allocate_buffer_1d(this, buff_type, buff_size, field_name, diurnal_samples)
- class(buffer1d_type), intent(inout), target :: this !< scalar buffer object
+ class(outputBuffer1d_type), intent(inout), target :: this !< scalar buffer object
class(*),intent(in) :: buff_type !< allocates to the type of buff_type
integer, intent(in) :: buff_size !< dimension bounds
character(len=*), intent(in) :: field_name !< field name for error output
@@ -396,7 +395,7 @@ end subroutine allocate_buffer_1d
!> Allocates a 2D buffer to given buff_type.
subroutine allocate_buffer_2d(this, buff_type, buff_sizes, field_name, diurnal_samples)
- class(buffer2d_type), intent(inout), target :: this !< 2D buffer object
+ class(outputBuffer2d_type), intent(inout), target :: this !< 2D buffer object
class(*),intent(in) :: buff_type !< allocates to the type of buff_type
integer, intent(in) :: buff_sizes(2) !< dimension sizes
integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
@@ -456,7 +455,7 @@ end subroutine allocate_buffer_2d
!> Allocates a 3D buffer to given buff_type.
subroutine allocate_buffer_3d(this, buff_type, buff_sizes, field_name, diurnal_samples)
- class(buffer3d_type), intent(inout), target :: this !< 3D buffer object
+ class(outputBuffer3d_type), intent(inout), target :: this !< 3D buffer object
class(*),intent(in) :: buff_type !< allocates to the type of buff_type
integer, intent(in) :: buff_sizes(3) !< dimension sizes
integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
@@ -518,7 +517,7 @@ end subroutine allocate_buffer_3d
!> Allocates a 4D buffer to given buff_type.
subroutine allocate_buffer_4d(this, buff_type, buff_sizes, field_name, diurnal_samples)
- class(buffer4d_type), intent(inout), target :: this !< 4D buffer object
+ class(outputBuffer4d_type), intent(inout), target :: this !< 4D buffer object
class(*),intent(in) :: buff_type !< allocates to the type of buff_type
integer, intent(in) :: buff_sizes(4) !< dimension buff_sizes
character(len=*), intent(in) :: field_name !< field name for error output
@@ -582,7 +581,7 @@ end subroutine allocate_buffer_4d
!> Allocates a 5D buffer to given buff_type.
subroutine allocate_buffer_5d(this, buff_type, buff_sizes, field_name, diurnal_samples)
- class(buffer5d_type), intent(inout), target :: this !< 5D buffer object
+ class(outputBuffer5d_type), intent(inout), target :: this !< 5D buffer object
class(*),intent(in) :: buff_type !< allocates to the type of buff_type
integer, intent(in) :: buff_sizes(5) !< dimension buff_sizes
character(len=*), intent(in) :: field_name !< field name for error output
@@ -653,7 +652,7 @@ end subroutine allocate_buffer_5d
!> Get routine for scalar buffers.
!! Sets the buff_out argument to the integer or real value currently stored in the buffer.
subroutine get_0d (this, buff_out, field_name)
- class(buffer0d_type), intent(in) :: this !< 0d allocated buffer object
+ class(outputBuffer0d_type), intent(in) :: this !< 0d allocated buffer object
class(*), allocatable, intent(out) :: buff_out !< output of copied buffer data
character(len=*), intent(in) :: field_name !< field name for error output
@@ -681,7 +680,7 @@ subroutine get_0d (this, buff_out, field_name)
!> Get routine for 1D buffers.
!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
subroutine get_1d (this, buff_out, field_name)
- class(buffer1d_type), intent(in) :: this !< 1d allocated buffer object
+ class(outputBuffer1d_type), intent(in) :: this !< 1d allocated buffer object
class(*), allocatable, intent(out) :: buff_out(:) !< output of copied buffer data
!! must be the same size as the allocated buffer
integer(i4_kind) :: buff_size !< size for allocated buffer
@@ -713,7 +712,7 @@ subroutine get_1d (this, buff_out, field_name)
!> Get routine for 2D buffers.
!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
subroutine get_2d (this, buff_out, field_name)
- class(buffer2d_type), intent(in) :: this !< 2d allocated buffer object
+ class(outputBuffer2d_type), intent(in) :: this !< 2d allocated buffer object
class(*), allocatable, intent(out) :: buff_out(:,:) !< output of copied buffer data
!! must be the same size as the allocated buffer
integer(i4_kind) :: buff_size(2) !< sizes for allocated buffer
@@ -747,7 +746,7 @@ subroutine get_2d (this, buff_out, field_name)
!> Get routine for 3D buffers.
!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
subroutine get_3d (this, buff_out, field_name)
- class(buffer3d_type), intent(in) :: this !< 3d allocated buffer object
+ class(outputBuffer3d_type), intent(in) :: this !< 3d allocated buffer object
class(*), allocatable, intent(out) :: buff_out(:,:,:) !< output of copied buffer data
!! must be the same size as the allocated buffer
integer(i4_kind) :: buff_size(3)!< sizes for allocated buffer
@@ -781,7 +780,7 @@ subroutine get_3d (this, buff_out, field_name)
!> Get routine for 4D buffers.
!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
subroutine get_4d (this, buff_out, field_name)
- class(buffer4d_type), intent(in) :: this !< 4d allocated buffer object
+ class(outputBuffer4d_type), intent(in) :: this !< 4d allocated buffer object
class(*), allocatable, intent(out) :: buff_out(:,:,:,:) !< output of copied buffer data
!! must be the same size as the allocated buffer
integer(i4_kind) :: buff_size(4)!< sizes for allocated buffer
@@ -816,7 +815,7 @@ subroutine get_4d (this, buff_out, field_name)
!> Get routine for 5D buffers.
!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
subroutine get_5d (this, buff_out, field_name)
- class(buffer5d_type), intent(in) :: this !< 5d allocated buffer object
+ class(outputBuffer5d_type), intent(in) :: this !< 5d allocated buffer object
class(*), allocatable, intent(out) :: buff_out(:,:,:,:,:) !< output of copied buffer data
!! must be the same size as the allocated buffer
integer(i4_kind) :: buff_size(5)!< sizes for allocated buffer
@@ -851,7 +850,7 @@ subroutine get_5d (this, buff_out, field_name)
!> @brief Initializes a buffer to a given fill value.
subroutine initialize_buffer_0d (this, fillval, field_name)
- class(buffer0d_type), intent(inout) :: this !< scalar buffer object
+ class(outputBuffer0d_type), intent(inout) :: this !< scalar buffer object
class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this
character(len=*), intent(in) :: field_name !< field name for error output
@@ -898,7 +897,7 @@ end subroutine initialize_buffer_0d
!> @brief Initializes a buffer to a given fill value.
subroutine initialize_buffer_1d (this, fillval, field_name)
- class(buffer1d_type), intent(inout) :: this !< 1D buffer object
+ class(outputBuffer1d_type), intent(inout) :: this !< 1D buffer object
class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this
character(len=*), intent(in) :: field_name !< field name for error output
@@ -946,7 +945,7 @@ end subroutine initialize_buffer_1d
!> @brief Initializes a buffer to a given fill value.
subroutine initialize_buffer_2d (this, fillval, field_name)
- class(buffer2d_type), intent(inout) :: this !< 2D buffer object
+ class(outputBuffer2d_type), intent(inout) :: this !< 2D buffer object
class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this
character(len=*), intent(in) :: field_name !< field name for error output
@@ -994,7 +993,7 @@ end subroutine initialize_buffer_2d
!> @brief Initializes a buffer to a given fill value.
subroutine initialize_buffer_3d (this, fillval, field_name)
- class(buffer3d_type), intent(inout) :: this !< 3D buffer object
+ class(outputBuffer3d_type), intent(inout) :: this !< 3D buffer object
class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this
character(len=*), intent(in) :: field_name !< field name for error output
@@ -1042,7 +1041,7 @@ end subroutine initialize_buffer_3d
!> @brief Initializes a buffer to a given fill value.
subroutine initialize_buffer_4d (this, fillval, field_name)
- class(buffer4d_type), intent(inout) :: this !< allocated 4D buffer object
+ class(outputBuffer4d_type), intent(inout) :: this !< allocated 4D buffer object
class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this
character(len=*), intent(in) :: field_name !< field name for error output
@@ -1090,7 +1089,7 @@ end subroutine initialize_buffer_4d
!> @brief Initializes a buffer to a given fill value.
subroutine initialize_buffer_5d (this, fillval, field_name)
- class(buffer5d_type), intent(inout) :: this !< allocated 5D buffer object
+ class(outputBuffer5d_type), intent(inout) :: this !< allocated 5D buffer object
class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this
character(len=*), intent(in) :: field_name !< field name for error output
@@ -1140,7 +1139,7 @@ end subroutine initialize_buffer_5d
!! This will just call the init routine since there's only one value.
!! @note input_data must match allocated type of buffer object.
subroutine add_to_buffer_0d(this, input_data, field_name)
- class(buffer0d_type), intent(inout) :: this !< allocated scalar buffer object
+ class(outputBuffer0d_type), intent(inout) :: this !< allocated scalar buffer object
class(*), intent(in) :: input_data !< data to copy into buffer
character(len=*), intent(in) :: field_name !< field name for error output
if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_0d: buffer not yet allocated for field:'// &
@@ -1151,7 +1150,7 @@ end subroutine add_to_buffer_0d
!> @brief Copy values ( from 1 to size(input_data)) into a 1d buffer object.
!! @note input_data must match allocated type of buffer object.
subroutine add_to_buffer_1d(this, input_data, field_name)
- class(buffer1d_type), intent(inout) :: this !< allocated 1d buffer object
+ class(outputBuffer1d_type), intent(inout) :: this !< allocated 1d buffer object
class(*), intent(in) :: input_data(:) !< data to copy into the buffer
integer :: n !< number of elements in input data
logical :: type_error !< set to true if mismatch between input_data and allocated buffer
@@ -1200,7 +1199,7 @@ end subroutine add_to_buffer_1d
!> @brief Copy values ( from 1 to size(input_data)) into a 2d buffer object.
!! @note input_data must match allocated type of buffer object.
subroutine add_to_buffer_2d(this, input_data, field_name)
- class(buffer2d_type), intent(inout) :: this !< allocated 2d buffer object
+ class(outputBuffer2d_type), intent(inout) :: this !< allocated 2d buffer object
class(*), intent(in) :: input_data(:,:) !< 2d data array to copy into buffer
integer :: n1, n2 !< number of elements per dimension
logical :: type_error !< set to true if mismatch between input_data and allocated buffer
@@ -1251,7 +1250,7 @@ end subroutine add_to_buffer_2d
!> @brief Copy values ( from 1 to size(input_data)) into a 3d buffer object.
!! @note input_data must match allocated type of buffer object.
subroutine add_to_buffer_3d(this, input_data, field_name)
- class(buffer3d_type), intent(inout) :: this !< allocated 3d buffer object
+ class(outputBuffer3d_type), intent(inout) :: this !< allocated 3d buffer object
class(*), intent(in) :: input_data(:,:,:)!< 3d data array to copy into buffer
integer :: n1, n2, n3 !< number of elements per dimension
logical :: type_error !< set to true if mismatch between input_data and allocated buffer
@@ -1304,7 +1303,7 @@ end subroutine add_to_buffer_3d
!> @brief Copy values ( from 1 to size(input_data)) into a 4d buffer object.
!! @note input_data must match allocated type of buffer object.
subroutine add_to_buffer_4d(this, input_data, field_name)
- class(buffer4d_type), intent(inout) :: this !< allocated 4d buffer object
+ class(outputBuffer4d_type), intent(inout) :: this !< allocated 4d buffer object
class(*), intent(in) :: input_data(:,:,:,:) !< 4d data to copy into buffer
integer :: n1, n2, n3, n4!< number of elements per dimension
logical :: type_error !< set to true if mismatch between input_data and allocated buffer
@@ -1358,7 +1357,7 @@ end subroutine add_to_buffer_4d
!> @brief Copy values (from 1 to size(input_data)) into a 5d buffer object.
!! @note input_data must match allocated type of buffer object.
subroutine add_to_buffer_5d(this, input_data, field_name)
- class(buffer5d_type), intent(inout) :: this !< allocated 5d buffer object
+ class(outputBuffer5d_type), intent(inout) :: this !< allocated 5d buffer object
class(*), intent(in) :: input_data(:,:,:,:,:) !< 5d data to copy into buffer
integer :: n1, n2, n3, n4, n5 !< number of elements per dimension
logical :: type_error !< set to true if mismatch between input_data and allocated buffer
@@ -1411,4 +1410,4 @@ subroutine add_to_buffer_5d(this, input_data, field_name)
'for field:'// field_name)
end subroutine add_to_buffer_5d
#endif
-end module fms_diag_buffer_mod
+end module fms_diag_output_buffer_mod
diff --git a/test_fms/diag_manager/test_diag_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90
index 52d3d25458..cd127c6b7d 100644
--- a/test_fms/diag_manager/test_diag_buffer.F90
+++ b/test_fms/diag_manager/test_diag_buffer.F90
@@ -1,18 +1,18 @@
program test_diag_buffer
#ifdef use_yaml
- use fms_diag_buffer_mod
+ use fms_diag_output_buffer_mod
use platform_mod
use diag_data_mod, only: i4, i8, r4, r8
implicit none
- type(buffer0d_type) :: buffobj0(10)
- type(buffer1d_type) :: buffobj1
- type(buffer2d_type) :: buffobj2
- type(buffer3d_type) :: buffobj3
- type(buffer4d_type) :: buffobj4
- type(buffer5d_type) :: buffobj5
+ type(outputBuffer0d_type) :: buffobj0(10)
+ type(outputBuffer1d_type) :: buffobj1
+ type(outputBuffer2d_type) :: buffobj2
+ type(outputBuffer3d_type) :: buffobj3
+ type(outputBuffer4d_type) :: buffobj4
+ type(outputBuffer5d_type) :: buffobj5
class(*),allocatable :: p_val, p_data1(:), p_data2(:,:)
real(r8_kind) :: r8_data
real(r4_kind) :: r4_data
From 3065a3e232f1b33a01a425b31a4d3fb658bc2fb1 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Fri, 21 Apr 2023 10:57:29 -0400
Subject: [PATCH 093/168] feat: update log_diag_field_info for modern diag
(#1090)
---
diag_manager/diag_manager.F90 | 27 +++++++++++++++++++++
diag_manager/fms_diag_object.F90 | 14 ++++++++---
test_fms/diag_manager/test_diag_manager2.sh | 3 ++-
3 files changed, 40 insertions(+), 4 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index b1c993b797..7cf5239bee 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -393,6 +393,15 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
if (use_modern_diag) then
+ if( do_diag_field_log) then
+ if ( PRESENT(do_not_log) ) THEN
+ if(.not. do_not_log) call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), long_name,&
+ & units, missing_value, range, dynamic=.true.)
+ else
+ call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), long_name, units,&
+ & missing_value, range, dynamic=.true.)
+ endif
+ endif
register_diag_field_scalar = fms_diag_object%fms_register_diag_field_scalar( &
& module_name, field_name, init_time, long_name=long_name, units=units, &
& missing_value=missing_value, var_range=range, standard_name=standard_name, &
@@ -432,6 +441,15 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
if (use_modern_diag) then
+ if( do_diag_field_log) then
+ if ( PRESENT(do_not_log) ) THEN
+ if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, long_name,&
+ & units, missing_value, range, dynamic=.true.)
+ else
+ call log_diag_field_info(module_name, field_name, axes, long_name, units,&
+ & missing_value, range, dynamic=.true.)
+ endif
+ endif
register_diag_field_array = fms_diag_object%fms_register_diag_field_array( &
& module_name, field_name, axes, init_time, long_name=long_name, &
& units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
@@ -481,6 +499,15 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
END IF
if (use_modern_diag) then
+ if( do_diag_field_log) then
+ if ( PRESENT(do_not_log) ) THEN
+ if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, long_name,&
+ & units, missing_value, range, dynamic=.false.)
+ else
+ call log_diag_field_info(module_name, field_name, axes, long_name, units,&
+ & missing_value, range, dynamic=.false.)
+ endif
+ endif
register_static_field = fms_diag_object%fms_register_static_field(module_name, field_name, axes, &
& long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
& standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,&
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 713e37529c..765d9f4bab 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -20,7 +20,7 @@ module fms_diag_object_mod
use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
&DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, &
- &get_base_time
+ &get_base_time, NULL_AXIS_ID
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
& OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
& get_ticks_per_second
@@ -28,7 +28,7 @@ module fms_diag_object_mod
use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init
use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, find_diag_field, &
- & get_diag_files_id, diag_yaml
+ & get_diag_files_id, diag_yaml
use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, &
&diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, &
&fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, &
@@ -789,7 +789,15 @@ function fms_get_axis_name_from_id (this, axis_id) &
axis_name=" "
#else
if (axis_id < 0 .and. axis_id > this%registered_axis) &
- call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid")
+ call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid")
+
+ !! if its a scalar (null axis id) just returns n/a since no axis is defined
+ if (axis_id .eq. NULL_AXIS_ID) then
+ allocate(character(len=3) :: axis_name)
+ axis_name = "n/a"
+ return
+ endif
+
select type (axis => this%diag_axis(axis_id)%axis)
type is (fmsDiagFullAxis_type)
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 949918b2ca..e0727704d6 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -45,6 +45,7 @@ setup_test () {
&diag_manager_nml
max_field_attributes=3
debug_diag_manager=.true.
+ do_diag_field_log=.true.
/
&ensemble_nml
@@ -657,7 +658,7 @@ _EOF
'
- printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml
+ printf "&diag_manager_nml \n use_modern_diag = .true. \n do_diag_field_log = .true. \n/" | cat > input.nml
cat <<_EOF > diag_table.yaml
title: test_diag_manager
base_date: 2 1 1 0 0 0
From 1ea7d6064b7dbb521fd157f2576487ffa9b5a6ab Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 21 Apr 2023 11:29:43 -0400
Subject: [PATCH 094/168] feat: Modern diag_manager write out the cell_measures
and cell_methods attribute (#1177)
---
diag_manager/diag_data.F90 | 36 +++++-
diag_manager/diag_manager.F90 | 5 +
diag_manager/fms_diag_axis_object.F90 | 57 +++++++---
diag_manager/fms_diag_field_object.F90 | 126 ++++++++++++++++-----
diag_manager/fms_diag_file_object.F90 | 27 ++++-
diag_manager/fms_diag_object.F90 | 17 ++-
test_fms/diag_manager/test_modern_diag.F90 | 6 +-
7 files changed, 224 insertions(+), 50 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 5ef94b9075..c3f77b9e38 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -332,6 +332,7 @@ MODULE diag_data_mod
character(len=:), allocatable :: att_name !< Name of the attribute
contains
procedure :: add => fms_add_attribute
+ procedure :: write_metadata
end type fmsDiagAttribute_type
! Include variable "version" to be written to log file.
#include
@@ -553,8 +554,9 @@ function get_base_second() &
res = base_second
end function get_base_second
+ !> @brief Adds an attribute to the attribute type
subroutine fms_add_attribute(this, att_name, att_value)
- class(fmsDiagAttribute_type), intent(inout) :: this !< Diag attribute type
+ class(fmsDiagAttribute_type), intent(inout) :: this !< Diag attribute type
character(len=*), intent(in) :: att_name !< Name of the attribute
class(*), intent(in) :: att_value(:) !< The attribute value to add
@@ -580,6 +582,38 @@ subroutine fms_add_attribute(this, att_name, att_value)
this%att_value = att_value
end select
end subroutine fms_add_attribute
+
+ !> @brief Writes out the attributes from an fmsDiagAttribute_type
+ subroutine write_metadata(this, fileobj, var_name, cell_methods)
+ class(fmsDiagAttribute_type), intent(inout) :: this !< Diag attribute type
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write to
+ character(len=*), intent(in) :: var_name !< The name of the variable to write to
+ character(len=*), optional, intent(inout) :: cell_methods !< The cell methods attribute
+
+ select type (att_value =>this%att_value)
+ type is (character(len=*))
+ !< If the attribute is cell methods append to the current cell_methods attribute value
+ !! This will be writen once all of the cell_methods attributes are gathered ...
+ if (present(cell_methods)) then
+ if (trim(this%att_name) .eq. "cell_methods") then
+ cell_methods = trim(cell_methods)//" "//trim(att_value(1))
+ return
+ endif
+ endif
+
+ call register_variable_attribute(fileobj, var_name, this%att_name, trim(att_value(1)), &
+ str_len=len_trim(att_value(1)))
+ type is (real(kind=r8_kind))
+ call register_variable_attribute(fileobj, var_name, this%att_name, real(att_value, kind=r8_kind))
+ type is (real(kind=r4_kind))
+ call register_variable_attribute(fileobj, var_name, this%att_name, real(att_value, kind=r4_kind))
+ type is (integer(kind=i4_kind))
+ call register_variable_attribute(fileobj, var_name, this%att_name, int(att_value, kind=i4_kind))
+ type is (integer(kind=i8_kind))
+ call register_variable_attribute(fileobj, var_name, this%att_name, int(att_value, kind=i8_kind))
+ end select
+
+ end subroutine write_metadata
END MODULE diag_data_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 7cf5239bee..7908c55e66 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -4453,6 +4453,11 @@ SUBROUTINE diag_field_add_cell_measures(diag_field_id, area, volume)
& 'either area or volume arguments must be present', FATAL )
END IF
+ if (use_modern_diag) then
+ call fms_diag_object%fms_diag_field_add_cell_measures(diag_field_id, area, volume)
+ return
+ ENDIF
+
DO j=1, input_fields(diag_field_id)%num_output_fields
ind = input_fields(diag_field_id)%output_fields(j)
CALL init_field_cell_measures(output_fields(ind), area=area, volume=volume)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 7f69674a35..0af439c0de 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -103,6 +103,7 @@ module fms_diag_axis_object_mod
procedure :: add_structured_axis_ids
procedure :: get_structured_axis
procedure :: is_unstructured_grid
+ procedure :: get_edges_id
END TYPE fmsDiagAxis_type
!> @brief Type to hold the subaxis
@@ -152,6 +153,8 @@ module fms_diag_axis_object_mod
!! or "UG_DOMAIN")
INTEGER , private :: length !< Global axis length
INTEGER , private :: direction !< Direction of the axis 0, 1, -1
+ INTEGER, ALLOCATABLE, private :: edges_id !< Axis ID for the edges axis
+ !! This axis will be written to the file
CHARACTER(len=:), ALLOCATABLE, private :: edges_name !< Name for the previously defined "edges axis"
!! This will be written as an attribute
CHARACTER(len=128) , private :: aux !< Auxiliary name, can only be geolon_t
@@ -169,7 +172,7 @@ module fms_diag_axis_object_mod
PROCEDURE :: add_axis_attribute
PROCEDURE :: register => register_diag_axis_obj
PROCEDURE :: axis_length => get_axis_length
- PROCEDURE :: set_edges_name
+ PROCEDURE :: set_edges
PROCEDURE :: set_axis_id
PROCEDURE :: get_compute_domain
PROCEDURE :: get_indices
@@ -186,7 +189,7 @@ module fms_diag_axis_object_mod
!> @brief Initialize the axis
subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name, long_name, direction,&
& set_name, Domain, Domain2, DomainU, aux, req, tile_count, domain_position, axis_length )
- class(fmsDiagFullAxis_type),INTENT(out) :: this !< Diag_axis obj
+ class(fmsDiagFullAxis_type),INTENT(inout):: this !< Diag_axis obj
CHARACTER(len=*), INTENT(in) :: axis_name !< Name of the axis
class(*), INTENT(in) :: axis_data(:) !< Array of coordinate values
CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
@@ -283,12 +286,14 @@ subroutine add_axis_attribute(this, att_name, att_value)
end subroutine add_axis_attribute
!> @brief Write the axis meta data to an open fileobj
- subroutine write_axis_metadata(this, fileobj, parent_axis)
- class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj
- class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
- class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis !< If the axis is a subaxis, axis object
- !! for the parent axis (this will be used
- !! to get some of the metadata info)
+ subroutine write_axis_metadata(this, fileobj, edges_in_file, parent_axis)
+ class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
+ logical, INTENT(IN) :: edges_in_file !< .True. if the edges to this axis are
+ !! already in the file
+ class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis !< If the axis is a subaxis, axis object
+ !! for the parent axis (this will be used
+ !! to get some of the metadata info)
character(len=:), ALLOCATABLE :: axis_edges_name !< Name of the edges, if it exist
character(len=:), pointer :: axis_name !< Name of the axis
@@ -297,6 +302,9 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
type(fmsDiagFullAxis_type), pointer :: diag_axis !< Local pointer to the diag_axis
integer :: type_of_domain !< The type of domain the current axis is in
+ logical :: is_subaxis !< .true. if the axis is a subaxis
+
+ is_subaxis = .false.
select type(this)
type is (fmsDiagFullAxis_type)
@@ -305,6 +313,7 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
diag_axis => this
type_of_domain = this%type_of_domain
type is (fmsDiagSubAxis_type)
+ is_subaxis = .true.
axis_name => this%subaxis_name
axis_length = this%ending_index - this%starting_index + 1
!< Get all the other information from the parent axis (i.e the cart_name, units, etc)
@@ -371,7 +380,8 @@ subroutine write_axis_metadata(this, fileobj, parent_axis)
call register_variable_attribute(fileobj, axis_name, "positive", "down", str_len=4)
end select
- if (allocated(diag_axis%edges_name)) then
+ !< Ignore the edges attribute, if the edges are already in the file or if it is subaxis
+ if (.not. edges_in_file .and. allocated(diag_axis%edges_name) .and. .not. is_subaxis) then
call register_variable_attribute(fileobj, axis_name, "edges", diag_axis%edges_name, &
str_len=len_trim(diag_axis%edges_name))
endif
@@ -519,6 +529,19 @@ pure function get_structured_axis(this) &
end select
end function get_structured_axis
+
+ !< @brief Get the edges_id of an axis_object
+ !! @return The edges_id of an axis object
+ pure integer function get_edges_id(this)
+ class(fmsDiagAxis_type), INTENT(in) :: this !< diag_axis obj
+
+ get_edges_id = diag_null
+ select type (this)
+ type is (fmsDiagFullAxis_type)
+ if (allocated(this%edges_id)) get_edges_id = this%edges_id
+ end select
+ end function
+
!> @brief Get the starting and ending indices of the global io domain of the axis
subroutine get_global_io_domain(this, global_io_index)
class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
@@ -569,13 +592,19 @@ subroutine set_axis_id(this, axis_id)
end subroutine set_axis_id
- !> @brief Set the name of the edges
- subroutine set_edges_name(this, edges_name)
- class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj
- CHARACTER(len=*), intent(in) :: edges_name !< Name of the edges
+ !> @brief Set the name and ids of the edges
+ subroutine set_edges(this, edges_name, edges_id)
+ class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj
+ CHARACTER(len=*), intent(in) :: edges_name !< Name of the edges
+ integer, intent(in) :: edges_id !< Axis id of the edges
+ !< Saving the name and the id of the edges axis because it will make it easier to use
+ !! downstream (i.e you need the edges name to write the attribute to the current axis,
+ !! and you need the edges id to add to the diag file object so that you can write the edges
+ !! to the file)
this%edges_name = edges_name
- end subroutine
+ this%edges_id = edges_id
+ end subroutine set_edges
!> @brief Determine if the subRegion is in the current PE.
!! If it is, determine the starting and ending indices of the current PE that belong to the subRegion
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 2e5c588f03..bd3165f6f1 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -149,6 +149,8 @@ module fms_diag_field_object_mod
procedure :: get_longname_to_write
procedure :: write_field_metadata
procedure :: get_math_needs_to_be_done
+ procedure :: add_area_volume
+ procedure :: append_time_cell_methods
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagField_type) :: null_ob
@@ -683,11 +685,21 @@ end function get_vartype
!> @brief Gets varname
!! @return copy of the variable name
-pure function get_varname (this) &
+pure function get_varname (this, to_write) &
result(rslt)
- class (fmsDiagField_type), intent(in) :: this !< diag object
- character(len=:), allocatable :: rslt
- rslt = this%varname
+ class (fmsDiagField_type), intent(in) :: this !< diag object
+ logical, optional, intent(in) :: to_write !< .true. if getting the varname that will be writen to the file
+ character(len=:), allocatable :: rslt
+ rslt = this%varname
+
+ !< If writing the varname can be the outname which is defined in the yaml
+ if (present(to_write)) then
+ if (to_write) then
+ !TODO this is wrong
+ rslt = this%diag_field(1)%get_var_outname()
+ endif
+ endif
+
end function get_varname
!> @brief Gets longname
@@ -1010,6 +1022,12 @@ pure function get_longname_to_write(this, field_yaml) &
if (rslt .eq. "") then !! If the long name is not defined in the yaml, use the long name in the
!! register_diag_field
rslt = this%get_longname()
+ else
+ return
+ endif
+ if (rslt .eq. "") then !! If the long name is not defined in the yaml and in the register_diag_field
+ !! use the variable name
+ rslt = field_yaml%get_var_outname()
endif
end function get_longname_to_write
@@ -1094,13 +1112,15 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
character(len=*), intent(in) :: unlim_dimname !< The name of the unlimited dimension
logical, intent(in) :: is_regional !< Flag indicating if the field is regional
- character(len=*), intent(inout) :: cell_measures
+ character(len=*), intent(in) :: cell_measures !< The cell measures attribute to write
type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry
character(len=:), allocatable :: var_name !< Variable name
character(len=:), allocatable :: long_name !< Longname to write
character(len=:), allocatable :: units !< Units of the field to write
character(len=120), allocatable :: dimnames(:) !< Dimension names of the field
+ character(len=120) :: cell_methods!< Cell methods attribute to write
+ integer :: i !< For do loops
field_yaml => diag_yaml%get_diag_field_from_id(yaml_id)
var_name = field_yaml%get_var_outname()
@@ -1112,7 +1132,6 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml))
endif
- !TODO Not sure what the old diag_manager did if long_name was never defined
long_name = this%get_longname_to_write(field_yaml)
call register_variable_attribute(fileobj, var_name, "long_name", long_name, str_len=len_trim(long_name))
@@ -1142,16 +1161,34 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
str_len=len_trim(this%get_interp_method()))
endif
- select case (field_yaml%get_var_reduction())
- case (time_average, time_max, time_min)
- call register_variable_attribute(fileobj, var_name, "time_avg_info", &
- trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT', &
- str_len=len(trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT'))
- end select
+ if (.not. this%static) then
+ select case (field_yaml%get_var_reduction())
+ case (time_average, time_max, time_min, time_diurnal, time_power, time_rms, time_sum)
+ call register_variable_attribute(fileobj, var_name, "time_avg_info", &
+ trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT', &
+ str_len=len(trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT'))
+ end select
+ endif
- call append_time_cell_measure(cell_measures, field_yaml)
- if (trim(cell_measures) .ne. "") &
+ cell_methods = ""
+ !< Check if any of the attributes defined via a "diag_field_add_attribute" call
+ !! are the cell_methods, if so add to the "cell_methods" variable:
+ do i = 1, this%num_attributes
+ call this%attributes(i)%write_metadata(fileobj, var_name, &
+ cell_methods=cell_methods)
+ enddo
+
+ !< Append the time cell methods based on the variable's reduction
+ call this%append_time_cell_methods(cell_methods, field_yaml)
+ if (trim(cell_methods) .ne. "") &
call register_variable_attribute(fileobj, var_name, "cell_methods", &
+ trim(adjustl(cell_methods)), str_len=len_trim(adjustl(cell_methods)))
+
+ !< Write out the cell_measures attribute (i.e Area, Volume)
+ !! The diag field ids for the Area and Volume are sent in the register call
+ !! This was defined in file object and passed in here
+ if (trim(cell_measures) .ne. "") &
+ call register_variable_attribute(fileobj, var_name, "cell_measures", &
trim(adjustl(cell_measures)), str_len=len_trim(adjustl(cell_measures)))
end subroutine write_field_metadata
@@ -1411,30 +1448,65 @@ PURE FUNCTION diag_field_id_from_name(this, module_name, field_name) &
endif
end function diag_field_id_from_name
-!> @brief Append the time cell measured based on the variable's reduction
-subroutine append_time_cell_measure(cell_measures, field_yaml)
- character(len=*), intent(inout) :: cell_measures !< The cell measures to append to
- type(diagYamlFilesVar_type), intent(in) :: field_yaml !< The field's yaml
+!> @brief Adds the area and volume id to a field object
+subroutine add_area_volume(this, area, volume)
+ CLASS(fmsDiagField_type), intent(inout) :: this !< The field object
+ INTEGER, optional, INTENT(in) :: area !< diag ids of area
+ INTEGER, optional, INTENT(in) :: volume !< diag ids of volume
+
+ if (present(area)) then
+ if (area > 0) then
+ this%area = area
+ else
+ call mpp_error(FATAL, "diag_field_add_cell_measures: the area id is not valid. "&
+ &"Verify that the area_id passed in to the field:"//this%varname//&
+ &" is valid and that the field is registered and in the diag_table.yaml")
+ endif
+ endif
+
+ if (present(volume)) then
+ if (volume > 0) then
+ this%volume = volume
+ else
+ call mpp_error(FATAL, "diag_field_add_cell_measures: the volume id is not valid. "&
+ &"Verify that the volume_id passed in to the field:"//this%varname//&
+ &" is valid and that the field is registered and in the diag_table.yaml")
+ endif
+ endif
+
+end subroutine add_area_volume
+
+!> @brief Append the time cell meathods based on the variable's reduction
+subroutine append_time_cell_methods(this, cell_methods, field_yaml)
+ class (fmsDiagField_type), target, intent(inout) :: this !< diag field
+ character(len=*), intent(inout) :: cell_methods !< The cell methods var to append to
+ type(diagYamlFilesVar_type), intent(in) :: field_yaml !< The field's yaml
+
+ if (this%static) then
+ cell_methods = trim(cell_methods)//" time: point "
+ return
+ endif
select case (field_yaml%get_var_reduction())
case (time_none)
- cell_measures = trim(cell_measures)//" time: point "
+ cell_methods = trim(cell_methods)//" time: point "
case (time_diurnal)
- cell_measures = trim(cell_measures)//" time: mean"
+ cell_methods = trim(cell_methods)//" time: mean"
case (time_power)
- cell_measures = trim(cell_measures)//" time: mean_pow"//int2str(field_yaml%get_pow_value())
+ cell_methods = trim(cell_methods)//" time: mean_pow"//int2str(field_yaml%get_pow_value())
case (time_rms)
- cell_measures = trim(cell_measures)//" time: root_mean_square"
+ cell_methods = trim(cell_methods)//" time: root_mean_square"
case (time_max)
- cell_measures = trim(cell_measures)//" time: max"
+ cell_methods = trim(cell_methods)//" time: max"
case (time_min)
- cell_measures = trim(cell_measures)//" time: min"
+ cell_methods = trim(cell_methods)//" time: min"
case (time_average)
- cell_measures = trim(cell_measures)//" time: mean"
+ cell_methods = trim(cell_methods)//" time: mean"
case (time_sum)
- cell_measures = trim(cell_measures)//" time: sum"
+ cell_methods = trim(cell_methods)//" time: sum"
end select
-end subroutine append_time_cell_measure
+end subroutine append_time_cell_methods
+
!> Dumps any data from a given fmsDiagField_type object
subroutine dump_field_obj (this, unit_num)
class(fmsDiagField_type), intent(in) :: this
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 12e453fb0f..f657a63b16 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -1213,27 +1213,42 @@ subroutine write_axis_metadata(this, diag_axis)
integer :: i,k !< For do loops
integer :: parent_axis_id !< Id of the parent_axis
integer :: structured_ids(2) !< Ids of the uncompress axis
+ integer :: edges_id !< Id of the axis edge
- class(fmsDiagAxisContainer_type), pointer :: axis_ptr !< pointer to the axis object currently writing
+ class(fmsDiagAxisContainer_type), pointer :: axis_ptr !< pointer to the axis object currently writing
+ logical :: edges_in_file !< .true. if the edges are already in the file
diag_file => this%FMS_diag_file
fileobj => diag_file%fileobj
do i = 1, diag_file%number_of_axis
+ edges_in_file = .false.
axis_ptr => diag_axis(diag_file%axis_ids(i))
parent_axis_id = axis_ptr%axis%get_parent_axis_id()
+
+ edges_id = axis_ptr%axis%get_edges_id()
+ if (edges_id .ne. diag_null) then
+ !< write the edges if is not in the list of axis in the file, otherwrise ignore
+ if (any(diag_file%axis_ids(1:diag_file%number_of_axis) .eq. edges_id)) then
+ edges_in_file = .true.
+ else
+ call diag_axis(edges_id)%axis%write_axis_metadata(fileobj, .true.)
+ endif
+ endif
+
if (parent_axis_id .eq. DIAG_NULL) then
- call axis_ptr%axis%write_axis_metadata(fileobj)
+ call axis_ptr%axis%write_axis_metadata(fileobj, edges_in_file)
else
- call axis_ptr%axis%write_axis_metadata(fileobj, diag_axis(parent_axis_id)%axis)
+ call axis_ptr%axis%write_axis_metadata(fileobj, edges_in_file, diag_axis(parent_axis_id)%axis)
endif
if (axis_ptr%axis%is_unstructured_grid()) then
structured_ids = axis_ptr%axis%get_structured_axis()
do k = 1, size(structured_ids)
- call diag_axis(structured_ids(k))%axis%write_axis_metadata(fileobj)
+ call diag_axis(structured_ids(k))%axis%write_axis_metadata(fileobj, .false.)
enddo
endif
+
enddo
end subroutine write_axis_metadata
@@ -1265,11 +1280,11 @@ subroutine write_field_metadata(this, diag_field, diag_axis)
!the file that the fields are in needs to be added
cell_measures = ""
if (field_ptr%has_area()) then
- cell_measures = "area:"//diag_field(field_ptr%get_area())%get_varname()
+ cell_measures = "area: "//diag_field(field_ptr%get_area())%get_varname(to_write=.true.)
endif
if (field_ptr%has_volume()) then
- cell_measures = trim(cell_measures)//" volume:"//diag_field(field_ptr%get_volume())%get_varname()
+ cell_measures = trim(cell_measures)//" volume: "//diag_field(field_ptr%get_volume())%get_varname(to_write=.true.)
endif
call field_ptr%write_field_metadata(fileobj, diag_file%id, diag_file%yaml_ids(i), diag_axis, &
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 765d9f4bab..0827d2d5fc 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -79,6 +79,7 @@ module fms_diag_object_mod
procedure :: fms_diag_accept_data
procedure :: fms_diag_send_complete
procedure :: fms_diag_do_io
+ procedure :: fms_diag_field_add_cell_measures
#ifdef use_yaml
procedure :: get_diag_buffer
#endif
@@ -426,7 +427,7 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, axis_l
select type (edges_axis => this%diag_axis(edges)%axis)
type is (fmsDiagFullAxis_type)
edges_name = edges_axis%get_axis_name()
- call axis%set_edges_name(edges_name)
+ call axis%set_edges(edges_name, edges)
end select
endif
call axis%register(axis_name, axis_data, units, cart_name, long_name=long_name, &
@@ -618,6 +619,20 @@ subroutine fms_diag_do_io(this, is_end_of_run)
#endif
end subroutine fms_diag_do_io
+!> @brief Adds the diag ids of the Area and or Volume of the diag_field_object
+subroutine fms_diag_field_add_cell_measures(this, diag_field_id, area, volume)
+ class(fmsDiagObject_type), intent (inout) :: this !< The diag object
+ integer, intent(in) :: diag_field_id !< diag_field to add the are and volume to
+ INTEGER, optional, INTENT(in) :: area !< diag ids of area
+ INTEGER, optional, INTENT(in) :: volume !< diag ids of volume
+
+#ifndef use_yaml
+ CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
+ call this%FMS_diag_fields(diag_field_id)%add_area_volume(area, volume)
+#endif
+end subroutine fms_diag_field_add_cell_measures
+
!> @brief Add a attribute to the diag_obj using the diag_field_id
subroutine fms_diag_field_add_attribute(this, diag_field_id, att_name, att_value)
class(fmsDiagObject_type), intent (inout) :: this !< The diag object
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index 67000e1ac2..8205b8eee1 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -26,7 +26,8 @@ program test_modern_diag
mpp_get_UG_compute_domain
use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
diag_axis_add_attribute, diag_field_add_attribute, diag_send_complete, &
- diag_manager_set_time_end, send_data, register_static_field
+ diag_manager_set_time_end, send_data, register_static_field, &
+ diag_field_add_cell_measures
use platform_mod, only: r8_kind, r4_kind
use fms_mod, only: fms_init, fms_end
use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast, input_nml_file
@@ -178,12 +179,15 @@ program test_modern_diag
if (id_var8 .ne. 8) call mpp_error(FATAL, "var8 does not have the expected id")
endif
+call diag_field_add_cell_measures(id_var6, area=id_var8, volume=id_var8)
+
call diag_field_add_attribute (id_var1, "some string", "this is a string")
call diag_field_add_attribute (id_var1, "integer", 10)
call diag_field_add_attribute (id_var1, "1d_integer", (/10, 10/))
call diag_field_add_attribute (id_var1, "real", 10.)
call diag_field_add_attribute (id_var2, '1d_real', (/10./))
call diag_field_add_attribute (id_var2, 'formula', 'p(n,k,j,i) = ap(k) + b(k)*ps(n,j,i)')
+call diag_field_add_attribute (id_var2, 'cell_methods', 'area: mullions')
!! test dump routines
!! prints fields from objects for debugging to log if name is provided, othwerise goes to stdout
From 3dc191bbf1245743a1ab5bd92a381b03384819ed Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 21 Apr 2023 12:05:15 -0400
Subject: [PATCH 095/168] feat: Modern diag_manager Add a function that
determine the type of the variable (#1197)
---
diag_manager/diag_data.F90 | 24 ++++++++++++++++++++++++
1 file changed, 24 insertions(+)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index c3f77b9e38..b4a80d62f7 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -583,6 +583,30 @@ subroutine fms_add_attribute(this, att_name, att_value)
end select
end subroutine fms_add_attribute
+ !> @brief gets the type of a variable
+ !> @return the type of the variable (r4,r8,i4,i8,string)
+ function get_var_type(var) &
+ result(var_type)
+ class(*), intent(in) :: var !< Variable to get the type for
+ integer :: var_type !< The variable's type
+
+ select type(var)
+ type is (real(r4_kind))
+ var_type = r4
+ type is (real(r8_kind))
+ var_type = r8
+ type is (integer(i4_kind))
+ var_type = i4
+ type is (integer(i8_kind))
+ var_type = i8
+ type is (character(len=*))
+ var_type = string
+ class default
+ call mpp_error(FATAL, "get_var_type:: The variable does not have a supported type. "&
+ &"The supported types are r4, r8, i4, i8 and string.")
+ end select
+ end function get_var_type
+
!> @brief Writes out the attributes from an fmsDiagAttribute_type
subroutine write_metadata(this, fileobj, var_name, cell_methods)
class(fmsDiagAttribute_type), intent(inout) :: this !< Diag attribute type
From a935cc19aae5c207ac0a490fcd6b219cb4c05db0 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 25 Apr 2023 12:49:41 -0400
Subject: [PATCH 096/168] feat: Modern diag_manager add standard_name and
coordinates attributes + minor bug fixes (#1176)
---
diag_manager/fms_diag_axis_object.F90 | 26 +++++++++++++++-
diag_manager/fms_diag_field_object.F90 | 41 ++++++++++++++++++++++++++
diag_manager/fms_diag_time_utils.F90 | 2 +-
diag_manager/fms_diag_yaml.F90 | 8 +++--
4 files changed, 73 insertions(+), 4 deletions(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 0af439c0de..61555b52e6 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -157,7 +157,7 @@ module fms_diag_axis_object_mod
!! This axis will be written to the file
CHARACTER(len=:), ALLOCATABLE, private :: edges_name !< Name for the previously defined "edges axis"
!! This will be written as an attribute
- CHARACTER(len=128) , private :: aux !< Auxiliary name, can only be geolon_t
+ CHARACTER(len=:), ALLOCATABLE, private :: aux !< Auxiliary name, can only be geolon_t
!! or geolat_t
CHARACTER(len=128) , private :: req !< Required field names.
INTEGER , private :: tile_count !< The number of tiles
@@ -177,6 +177,8 @@ module fms_diag_axis_object_mod
PROCEDURE :: get_compute_domain
PROCEDURE :: get_indices
PROCEDURE :: get_global_io_domain
+ PROCEDURE :: get_aux
+ PROCEDURE :: has_aux
! TO DO:
! Get/has/is subroutines as needed
END TYPE fmsDiagFullAxis_type
@@ -583,6 +585,28 @@ function get_axis_length(this) &
end function
+
+ !> @brief Determine if an axis object has an auxiliary name
+ !! @return .true. if an axis object has an auxiliary name
+ pure function has_aux(this) &
+ result(rslt)
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
+ logical :: rslt
+
+ rslt = .false.
+ if (allocated(this%aux)) rslt = trim(this%aux) .ne. ""
+ end function has_aux
+
+ !> @brief Get the auxiliary name of an axis object
+ !! @return the auxiliary name of an axis object
+ pure function get_aux(this) &
+ result(rslt)
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
+ character(len=:), allocatable :: rslt
+
+ rslt = this%aux
+ end function get_aux
+
!> @brief Set the axis_id
subroutine set_axis_id(this, axis_id)
class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index bd3165f6f1..8aa1010891 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -148,6 +148,7 @@ module fms_diag_field_object_mod
procedure :: get_var_skind
procedure :: get_longname_to_write
procedure :: write_field_metadata
+ procedure :: write_coordinate_attribute
procedure :: get_math_needs_to_be_done
procedure :: add_area_volume
procedure :: append_time_cell_methods
@@ -1191,7 +1192,47 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
call register_variable_attribute(fileobj, var_name, "cell_measures", &
trim(adjustl(cell_measures)), str_len=len_trim(adjustl(cell_measures)))
+ !< Write out the standard_name (this was defined in the register call)
+ if (this%has_standname()) &
+ call register_variable_attribute(fileobj, var_name, "standard_name", &
+ trim(this%get_standname()), str_len=len_trim(this%get_standname()))
+
+ call this%write_coordinate_attribute(fileobj, var_name, diag_axis)
end subroutine write_field_metadata
+
+!> @brief Writes the coordinate attribute of a field if any of the field's axis has an
+!! auxiliary axis
+subroutine write_coordinate_attribute (this, fileobj, var_name, diag_axis)
+ CLASS(fmsDiagField_type), intent(in) :: this !< The field object
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write to
+ character(len=*), intent(in) :: var_name !< Variable name
+ class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
+
+ integer :: i !< For do loops
+ character(len = 252) :: aux_coord !< Auxuliary axis name
+
+ !> If the variable is a scalar, go away
+ if (.not. allocated(this%axis_ids)) return
+
+ !> Determine if any of the field's axis has an auxiliary axis and the
+ !! axis_names as a variable attribute
+ aux_coord = ""
+ do i = 1, size(this%axis_ids)
+ select type (obj => diag_axis(this%axis_ids(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ if (obj%has_aux()) then
+ aux_coord = trim(aux_coord)//" "//obj%get_aux()
+ endif
+ end select
+ enddo
+
+ if (trim(aux_coord) .eq. "") return
+
+ call register_variable_attribute(fileobj, var_name, "coordinates", &
+ trim(adjustl(aux_coord)), str_len=len_trim(adjustl(aux_coord)))
+
+end subroutine write_coordinate_attribute
+
!> @brief Gets a fields data buffer
!! @return a pointer to the data buffer
function get_data_buffer (this) &
diff --git a/diag_manager/fms_diag_time_utils.F90 b/diag_manager/fms_diag_time_utils.F90
index de18228dcd..efcf4690f9 100644
--- a/diag_manager/fms_diag_time_utils.F90
+++ b/diag_manager/fms_diag_time_utils.F90
@@ -195,7 +195,7 @@ END FUNCTION diag_forecast_time_inc
!! This string is used as suffix in output file name
!! @return Character(len=128) get_time_string
CHARACTER(len=128) FUNCTION get_time_string(filename, current_time)
- CHARACTER(len=128), INTENT(in) :: filename !< File name.
+ CHARACTER(len=*), INTENT(in) :: filename !< File name.
TYPE(time_type), INTENT(in) :: current_time !< Current model time.
INTEGER :: yr1 !< get from current time
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 632334d77e..a7a8e49a83 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -41,6 +41,7 @@ module fms_diag_yaml_mod
use, intrinsic :: iso_c_binding, only : c_ptr, c_null_char
use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique
use platform_mod, only: r4_kind, i4_kind
+use fms_mod, only: lowercase
implicit none
@@ -413,7 +414,8 @@ subroutine diag_yaml_object_init(diag_subset_output)
call fill_in_diag_files(diag_yaml_id, diag_file_ids(i), diag_yaml%diag_files(file_count))
!> Save the file name in the file_list
- file_list%file_name(file_count) = trim(diag_yaml%diag_files(file_count)%file_fname)//c_null_char
+ !! The diag_table is not case sensitive (so we are saving it as lowercase)
+ file_list%file_name(file_count) = lowercase(trim(diag_yaml%diag_files(file_count)%file_fname)//c_null_char)
file_list%diag_file_indices(file_count) = file_count
nvars = 0
@@ -441,6 +443,8 @@ subroutine diag_yaml_object_init(diag_subset_output)
!> Save the variable name and the module name in the variable_list
variable_list%var_name(var_count) = trim(diag_yaml%diag_fields(var_count)%var_varname)//&
":"//trim(diag_yaml%diag_fields(var_count)%var_module)//c_null_char
+ !! The diag_table is not case sensitive (so we are saving it as lowercase)
+ variable_list%var_name(var_count) = lowercase(variable_list%var_name(var_count))
variable_list%diag_field_indices(var_count) = var_count
enddo nvars_loop
deallocate(var_ids)
@@ -1433,7 +1437,7 @@ function find_diag_field(diag_field_name, module_name) &
integer, allocatable :: indices(:)
indices = fms_find_my_string(variable_list%var_pointer, size(variable_list%var_pointer), &
- & trim(diag_field_name)//":"//trim(module_name)//c_null_char)
+ & lowercase(trim(diag_field_name))//":"//lowercase(trim(module_name)//c_null_char))
end function find_diag_field
!> @brief Gets the diag_field entries corresponding to the indices of the sorted variable_list
From 233099ab3853c5aeea61fcf9ef4dcb8e1641a5e9 Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Tue, 25 Apr 2023 12:52:37 -0400
Subject: [PATCH 097/168] feat: add get_diag_field_ids to fms_diag_yaml_mod
(#1186)
---
diag_manager/fms_diag_yaml.F90 | 17 +++++++++++++++++
1 file changed, 17 insertions(+)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index a7a8e49a83..5bba6946cd 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -52,6 +52,7 @@ module fms_diag_yaml_mod
public :: diagYamlObject_type, get_diag_yaml_obj, subRegion_type
public :: diagYamlFiles_type, diagYamlFilesVar_type
public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_id
+public :: get_diag_field_ids
public :: dump_diag_yaml_obj
!> @}
@@ -1460,6 +1461,22 @@ function get_diag_fields_entries(indices) &
end function get_diag_fields_entries
+!> @brief Gets field indices corresponding to the indices (input argument) in the sorted variable_list
+!! @return Copy of array of field indices
+function get_diag_field_ids(indices) result(field_ids)
+
+ integer, intent(in) :: indices(:) !< Indices of the fields in the sorted variable_list array
+ integer, allocatable :: field_ids(:)
+ integer :: i !< For do loop
+
+ allocate(field_ids(size(indices)))
+
+ do i = 1, size(indices)
+ field_ids(i) = variable_list%diag_field_indices(indices(i))
+ end do
+
+end function get_diag_field_ids
+
!> @brief Finds the indices of the diag_yaml%diag_files(:) corresponding to fields in variable_list(indices)
!! @return indices of the diag_yaml%diag_files(:)
function get_diag_files_id(indices) &
From 719e0dfa2362a36d02a36d4415e848cae7348deb Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Tue, 25 Apr 2023 12:55:15 -0400
Subject: [PATCH 098/168] docs: update modern diag uml diagrams (#1161)
---
diag_manager/docs_uml/MDMClassObjects.drawio | 1 +
1 file changed, 1 insertion(+)
create mode 100644 diag_manager/docs_uml/MDMClassObjects.drawio
diff --git a/diag_manager/docs_uml/MDMClassObjects.drawio b/diag_manager/docs_uml/MDMClassObjects.drawio
new file mode 100644
index 0000000000..890182f218
--- /dev/null
+++ b/diag_manager/docs_uml/MDMClassObjects.drawio
@@ -0,0 +1 @@
+7T1bc9s21r+lD5pJdyYe3nR7dBynm9a51En3S/rCoURKZkORCi+xnV//ASABgSRIAhBJyTU62o1F8QAHwLnj4GBiXu0efoud/d27yPWCiaG5DxPz9cQA/2kz8A988pg/0fXFMn+yjX23eHZ48Mn/6RUPteJp5rteUnoxjaIg9fflh+soDL11WnrmxHF0X35tEwXlXvfO1qs9+LR2gvrT//Pd9K4YmGkuDz/81/O3d0XXpqkVmO8c/HbxILlz3OieemReT8yrOIrS/K/dw5UXwOnDE5PDvWn4lWAWe2HKA/CHtrIe36dvv2fLW+t74uw/Z7+/LFr54QRZMeKJMQtAe69W4I8t/GOzS177zvbD6h8wwXb6uPfwK6Av8lYxxvQRz9xdugvAXzr4LfrhxZsAjX0VROtvsHX476e9s/bDbfFWcu/vAicE4K/Wd37g3jiPUQZHlqTO+hv+9uouiv2fUZg6uPXDg0/wRfBUA09jLwHE9BHPjl559M55KL144yRp8WAdBYGzT/wVGgl8sgGtfypGBr/vnHjrh6+iNI12xSOM/Bs/CK6iIIrRJJgb9B/8PXXitCBvYwoe3N/5qQcnAD65B9yD+8nf0WcX8+IJ1ZzpWLrlgOdO4G9D8GwNhuLFsH0ylQibNI6+eSzA/JcP8O0U8qSuoTmIstD13GKenFUSBVnqXcZrjA18Sr4tSTuYJbSLBSEBmiAxdXlx6j1QjwoC/c2Ldl4aP4JX8K9zzD6FwMDMc39gvumieHZH8d1sVjx0CobfkrYPLAH+KLhCgEOMGoesAydJXhRsARYcTDSgPj/0YsQdv06MK4hIAEjcSR1IRmAU5iX8GNqbd59sF8DZGwCYgAcvwPNfCdPFB37SoFgrd+UFrlgXACBp7QC2htt/lW02Xiw1mBUCbe/KB6S6BcSKGtzH/g8nLTUWe1s/AdTsubg59CuYcUgT2i+gNWcH2SQgbZrg/6NNCRZ8IdBvXH/nhYkfhVzze/ngJyKjRyN3AFBfw/7hxD7sJBEaLgV1NAZwNEKd5wDsfoNo6wNN2tivH/qpDyTZTyR5LjZOkHgXzN592G96h3CLkB6CD+G3MEorLUkig9jRbkBJtknIfv22WdB2v406D81Dr2h1IN2xOqUUfK5DiR1UV0FhhPT6htKOxSOsyQJvAxGGqgLielk83vmuC/vGCu4GvfbaOjy5LTq1yobGHQD0QqTb0oJ1c8T2EeAHpCSmr8AHzM+VdjGdTF/D6Zm+0g/fwQe+HgMNHILhALEA+/GApXDvQWuBQ+mzlO1xmr+uZFvtum7NixXtlE/RGtZ0IEVrMkzRCvUFPqKZsvGh90JYnyOwDq9f6jVSM+ukZjLIKnBWXvAxSgATRbD9OH+3Qm5dFDXY6s457ajFQItr1RZ3H0drz83imkrAWp9IMKCecysjF/12/hLwLE1dIzIu/zAbRbBe6HY2jN7hbxeCY2VIGVx2AsjMiftoCXiwzqN0Q8DnACSfNyXaCLFthGcbd8+cbdYgweRDpQ+0vvYOWBXBY0mhEz16ITWEYh5d8L80jf1VBjWf7FQc1czWS2032gGeN4RXA8IiDAIv3AL+len6MBu+a2/iaGeHzk5qFAgTCJw340sS13rt7QFeQIpKwSeAW+11tNsHnuSaupHtRyVI09+4HrQ1s8SzHx1g3wi0S2Y5t9HKDQNkoRGrrKlnYk3NF3z61lwYx2vcUPvz91evfg8//+/b+lK7CXY3v719qeNICkVvnrv1cCALrMRdtI1CJ7g+PKUiQXByD+/cRMg+guT5j5emj8X0OlkalYnXe/DTL9TfX1F4CIW84NfXOOyGvjziLyEY8Rf6SwFmWPjBARB9K0F+9GLg6KNA2GutLRCVRFm89tomrQgxOzHg5u6gEJzPVnIA6gzo4B/lYDJrqQvQj5CdJodw2GxZDoeRRcVt5JgWYAeKucwNB/JawaaNHS2w+V/0Y87LoeSO1zFaB3rNEThQL5mTIwiaO1TNCmSpmLWKWQ8Ts7Y6I9bWlBWx7sHVYvJJR8A6Zw4bPeOIb+bGTG6k16NLyp45d3umVZQeEx1iErXZQ3CIibEKDg23uDNOiTWUwMIpAW2LO4LlKm81TsexBs3K3uiSzxbsy/6adttfQAsDwl2nFXe7qnaULaZssWFsMaPiLs0Zuxozhmgzqn5Vb8Jt1sg1YMrDEsnPvmcRYidAhVs0pS/X+RJQu6VonvCbmHlKO7wla651GzEP3WFWzPHB3Fi39fInrv+Ds9dsFfhrutMw29le4O3A8uItc8Zeb5agjWUfzk0K3PqXDlh+ZwuJ84ArhQUDsdze/Q/LumVjtgaTndqaW9rI7+ymGP8L37K/+aH7a1PrxWRXvND2tscnkia0XX/XslrpHaSrJA/Uo/QAz1nfIeehknrRQGHVmVAexZP0KKbckrplv5klmXVtKJdirlyKwVZXNxn7zazlHcynaFS7lLRhbw8FWXJ32MPhE9cNO6E7Z99LS4mX2iyVrSTnM5ScusnYW2Lx1myorSWDJTorrqD3kHqh2xR1rFoZmquC9MoxHDKxfFr2DC1GQpRlsuyP+VCeodGso3q0+lt8oSoTNlv5h2ZJbtOhmwZHscHeH3toyLVrG9uLBwAPVvPqZ94O8jmjzUvXefx1vLEIzKPS809SzxOledSmC0tETYfykAyOwLxykWSXd8GpgcRdJHJEAs1AISZYfkUhMz3ipFRSNiu/25pbS4hrTOPN0zebWq69wd02TMJMo0aM6V+529wS/6rWIPwJNmN0MYupUatdcJcS089ATC/q7hibj8XdMfC14GWRrfJ6rv2R3pmuvDPlnY3pnc24vbM+jv2yuah5u/uk3plyt5S7pfR4tx4nWrB3d6uPA5BslFm5Asrd6ml5eVXKCdytXEI2OV26y5JWEr5XuZu6BybYEdsRq4yl5I4JdsDwysqtwxd0Lt9srnyzZynTGcewTuubNcf8JX0zQ/lmyjcb0zdbTE/vm7Hi0qf2zeBrT8xDIygrP03p9FPp9AW3QDoXPw0f+FN+2hDL+2T9NGMsP02wI3E/TbADLj/N4PHTLJo0lJ/2fGT6uflpltG3n2YqP035aWP6abrGyMEf2VGzWMe2z8NRe7LuWgVx5YMpfX2sviba7gn5YKwkF+WD9bS8T9YHM8fywQQ7EvfBBDvg8sFMLh9sqnywZynTz84Hay6dIOmDWcoHUz7YqD4YucfohD5Y82HN8/DBnrgnpvwxpbv71t0zbsFzNv4YK7FF+WM9Le+T9cessfwxwY7E/THBDrj8MYvLH1sqf+xZyvRz88ewbdufPzZV/pjyx0b1x8zlyf2xaXMd+3Pyx/4VXpnyzZQe77tcl8YthM7FN5uyklmUb9bT8j5Z32w6lm8m2JG4bybYAZdvNuXxzaam8s2epUw/N99syfLNKiJ+jMu/yD1eFzN9PqHu8tIvNG0x6fMuL/qOrrYSsIPfyjAr34VlVQsG5tdH1K5lYDRUKVE40F1fNYTHuLxraZ2EHvFldID6yhfSabPlhO9GuoulsSxRsgwVw7b7u6UOy6tzYYFZ5WIS3TIr1g4vD5A7ErHtbAzDA9V+9AoT1IdYjSSIAlh6+/tTq/X9gbhyfmItMZ8uK1rC+lcqiSq9mRYfXXc2NKteAtTAaaIMMtPZ/TSSe+V9fIFU0/uWNW17fyByX5xaCRllJTQ3eJXQYmpVGUXKnOpXEWExfz5sppfVR9UW60l9zMwytS+KUuuN3FF5H/sKjdyBKZX9/kDcsTwld7zU6uyxtHjZQ59XvQ3TOD174BzMs2GPeUULLSohx57YQ9eXZWNJK6T9sPcDa/w3BL/xA0/dD6w2IcfYhDSmlUu8GQVU2HfDD7YHqWv1LYHiZkbtBcUiiDPa99/evPtko4uCNz78Qe1qPckI6EF2HnWBF4uKjaG2tXRNXQo85ALziqmhrvACVkOjPu+6MMtP7Njb+tASpRS7xM1boCEo2Gyg61J4PeIxbUV7L6Rl5TFt3cdAKtiwKJMNZttxAWVxNzhA3kMLjs4DmEMGjjyXQYrMxcb3Ald8Mrow76cxIArsKLTTO9CiwC2gTSSJ1j2NbIRnb62tgyjx+qXN42cv27twzzr0HtI+hls0t85iKDBBs/c5f29i77vtA4Px4cjpDNcxkM6enYWBvwPoujbrJlSJlvPV6RQfygB7LgbYlHENINONwMZ+/xoaB31Ptn8AA29U3Afu60nvz32h/v5K/c0OPslHhchS02GhP7SV9fg+ffs9W95a3xNn/zn7/aUxTlio5qBW/c6e9hQMa8F0hJuioLX3ZyNEQXVdLIqkgkcTFTyaDBY8Mq1FeaOMUdRpxpL6h1T3AcR+PXpELpenTCG3KSvv89eP1y9yqzOPLx2AEFkg2zF/tfKp16n9nF9AD8EmeZVa8M8mgpjkd9PTxpIAIgGgfxsw2D5LudDIO442pF/YwAEj0tK9k2ATOZRAC9nBx6AFG8AIyPZfRkKg12M7j+xdFGOvgm/owHiA5AFMC6gn157/A0oFQyvawJTiJ/KkgqYDmee8NEuhhuG6iTWIttDSZvZRfKpRCxhx6MTm4nOceRcQalPBQ0OzAhvxGnk5P6TxZpe899K1u8lVYnvIGDYerf5hIgM0q2H70QEFnATN7h2uxQvoE311dgHsO6FD1sggKQsl5D89gpcLJ4qZ/xtmQfCCefQF9kmJupE/eBBwiHa0sd1oB5yc9pWBA36N3iPLQk2LLAYdPd85sbOGp3IC6NK9zs/gaHnvxB0u7ojqIBQS0QEuerQD/O96QefKCPcDQ0e+mzBJ8u1r+HwdxcAw2kehm8uPFNOo/cOJAz9pJFFZpBCRSuCUMzCExiPrFChNmO1j/4cDJXXn3MFgawIWvFlOlKah0lbf/BFmOwqjPDLInkdgCU4KRUXeosdCT2mbbJZdZBRiRIvcb7vFwYgm8nEKzw0NnByFyN8GQiNa+2DZ4fDvfWBkCk1AaRVWAAcgp+Aou6a/eAcKFTFdSIQi1M3Rnt1RWccVon+dJwBACMDDPpxDZAXkJkFhw+y92Emp4B3HwJmhv0bTlbxNrzDELg9RBnCdVl7O4NBwarEbGbMCyAtvXfCq/tj7nnnh+nFS6P+Xes2VVVHFJxJV1PvY1mX6l9ZssH1dXe3rDrnCFuMMPHOJB9vY1esbu9SWB7I8slWAZFbpVGBuazihaxfG0aTldm92M3dO4RqxzUrJ1pA3IwNcdUdE20i8tPAC8nHkWlSmFTQpxKwXbAAujvPgSXQNIemYjzTqB/Uvt4jEAxAFh4dFS5T4C1TtH15/EIAvecQF8DHt1bxcRrOC6PXDMHlr9bn+hZhDmwhYtPe5ubPJ1lCG5q4OMsfufSReMipkUng6fvg985GY22QhBqPR4x/pJnSqpCgADM2n0E+PgZeFhTxwTN/IFAU2qCx8kq2KtBvZFkr78ZKNwNVjSBNJJGw4odKk1CTa+FsAL2H/4yj448ZxiHFIgW+DaOUESIQINkH0tQxTHoDlmLIELwsryZQEXpIpCbw0U5IWjmFKdiNSxHgYkSxTkRYkmaoGf9w45JiKgMszlZvt9sUGATQ6lHP/XJx7cq6s0/VbDpczND1JzhB9zKxSCkDjLAVAMotyuOmkI9Go17NkZLU7D5ORwx395Q0dueLNFchJtkylcCR9+IRy9rLVbZHVrVJvJir1ZtKcegMlQJK/0sp3Apk400X5UK5OjlPSVYDwlWe0NF22RNKK/m69deqEW+Ss4/S32dwsd2jhB3SHBkN84yQh3KETgJUJndR7BSc3qbF0L3lz9QrgsrtX0GTt2hlj7HXkeef1NHvObZJslSf8exsf5Tsos+iJmkVzbtZuqdDI4uMBtzxYN9qrLY++FphV9Ze1wIPteDCWc0SjF3A1cBBLNq8+5bN5tQsrr8JAF3I7gxJYhAi6zWG82zR4Gv1iUdXXRkUPN9RX6E0HG6ep59TmW1m8dDafz8r+lW6eA50ZZp3ORjysIXzGwqyesSiMz8ZDFlWA+bxCmkMcsjBYW/xNhyzgdpFy9ZSr1+Dq9eDbGdNZlWvqFgO7uoFW9bV6NBrqaRI5G2jllOf/OXFjoQ6W50UFgvPTpC05ouRT8uWO/AhgiKLULW4gG79aBySTtYfsUjRpcMe/A6CebpeF/vfMy9cd5xnizMMjB1ifQfGB0UmjHcigvPtCQF+maeyvsrStWkxX1w5uIynwH4Aa+6QBmGF8wLkT3VKm9aDEWa5TcQYIdWeGnwCpnZN8sxHnhY15+ydAy43sMEpt0OEZIQWbbjxxQT68DCmPKsYHLBttDDZixD6Ectx0UTgU6QinwyGIwu3JkQDiJnRPjgXehT8dBrvo9LMQe06wOykG6FjZHmYk3EWCFmWnQdOOEDEXD4cXzsZeTKEJi66pOsmUdG2kHCij87zgQbbzzc9Br7WdFiSft+8/X/92fXvUpFc/PItJForrWOUJKAi4tk7e6g/gIfOImeab03rBjYg9P0lgaavcQz0XrFCW8u3l+9+u+ZyJDrxKbDcxGLfLVbAv4YFP152NPUdhZeMroc7LNk/v7NDz3ATd8AQPJYSe2o19qruxJNLbe2HRmTbYdixGQW3HDrLCM0YRm3FLixqz2gI3XhWXh/rgO0QybnbF0a3a4Z+KVGPXCHTzMzS5x1Bp+hCStcvvCXWxjvaPtabhwxxt1nm19gZxGIc5FfhHm0K+OM4ED/a882IPHWM+XA04weftLwTxSLz07esaEgk+8yS8FhCyCKrXmzyEGkSbLKl+FrIl00C09QYVyein4U2hHtHhPhzrbKPXyotCnRRTbfvh91oX93cO4LKEsRyQuq7uvPW3SeOxr25upE7IM4YG6NimXhFtulRMotw8lB2l6Kh0069aUT+mj3KglDGASiRVsPkitshoF0cd6ZV+S1dqmBwuNIVTu26hgl8OpyfbMSIncvGWmMhwCLCwDIKQpc0EUWAp4oSA0qQBgY9YegheXWFeODmhXEBKqNIcVxJrlVgbEiEVhWWcLuJbmUi2RxxDFIWrRv5E4em4nShsKb4mzHcotCJOSjgOI7w0lYiJsIQhsQ1Z4JrVAUXrbx4U77IqFApsaQEGgaUE2FH680jdxVJRvHByAqyAlODrHFcpAVasjZQAg7AyAgytjJQAywlCXIAhJ+4IAYaOOUsKMAgrLcAQ34kLMERKMgIMLc0RAmyLPR8ZAYYGm+9lCEIWx12JVyqOM7ssCsfKVncURD09Kv1JGGl/B3lIBhTIGTv55ocyjIAlDX09hUgbDZd5iMt2FUV+1lHkmcl5PYJuDnfWeXrSKzWLI8pc1xlQifjU+Y48ER9eGN/npcwcSfeMe2VPeUOCrs/KF8vqnPc3C9+caRhauSPTGiMdv352c9KQjn8JVLC6OVOl5Y+Rlq9r0zI3EO6ghDq5Sp0W6tV7n3vcOaqf1MzzByj+4Lg2My/Up8yRJ2qOLLhJuXlTm0m45mB72njPVe1pD7LAM07JpA8mmczZSY1N2tS8aD9dLG8ZWvNxDL7KmUhyRrL/g7zu2/APw7l7u8r+/jmNPm6+2l8eGRW3z99tID7CV9yeqMNQkcoa+O/Nm6q1NDvOszC5j41jeXkuVZRMjipKVRtEmebKNB/KNLfmF5WbyeYsG2daV4HEiherhzQ3uvvT5yybqtLdGNWQzLpH3Xt6e0PaMQmSN4LWT6ainCrqvq6ijngtJ1g5LE/TYTH7qInEZubhHBZVE2nIBcahla4FHiwHF3tHPDm4+QQw9v+at61hOTeP923UcGXLWeBOe14QntfzGxHibJ1m8PIq6vhW95jLYF0gPswwomC2MZwsJeKfi4hnXCDOlAD6rIcNMqafaz4VP5fbNaUcYkNfllziC+3wYKR9NMvg9XaxMB58J40EwHDcrBoQG2onbTad0u0x9vgMsw1goK03vEQCxZHpLYaDNC9+/JStlPs/Ue7/ZFD3fzkr++JzXGSRzrbAnF3WJVK+/2xWjTbMGfarZTJ6PIX3b9XL21399/L28urz9W2t7sLlzc2Hq8vPl69urlmnaUk6WFGfuLvORI+BhhZ0IKPAREAfUOTDGSDkoVtwedBBxatILfmDJJWZBdzKGUxA1UdShvx5GfJhdANDAo3ai9fQJxbDUSeqmcK57UQ1QzgLNl8NFY0iies1FFUQqT/K0lknuVlrP1wUqX5UnxnsgGuJa/wr2XhusnFICmXkATOl01BBjrrAGTHIUSrH3RrioCIXs8WiErmwzI7IhViApM8QB/eG/kAhDuHAhIX3KPHlBIVL1BiYmC6OBJhNOwCMxbQNYKjQh/i9UK2hjzdZEKjYx0TFPibDxj4a+LekYTSGhqmFOnu0gurpBs0Bh/zTFnYopRJwFbbsoze+Mp599AQPqcmNSxesrd2EwRpeYcqHwc3lp0+kOl37h3tN4UYkX3G8PqabHIPMtz85yyoeHytpXYHCF3jx7vKL/emvV5dfrj8J1B0fGLmQeCpSRTv56eBElTm7COW80AKUvwWS/VzQcf3YW6edQcdJP8wLzWVJJQDsSn5x2USmWUc0d6B+86uuz2PB6QIBVaB6Lt9nlMEXZrsVElR5Vh+8J6RzPJ+/frzmv9WhacEEr3IYaxIFr2wYjZlzsb3HMT75qsOyGFAZQL6LF00FyJ5ogKyPRE+m92INV27VUpmeQ66wxQrSs5Z4sCA93qunFvjj7Yer69d/3V6XdIdbJDxylJFkNtBYprRcohT10VoLho0eBMPGYKUDkkVKjEWRlmGtl5KhJQrcWRmHCQmRXke7PVTzXTVqGhvwQ9dft9WZaYTcBtHKCWw/Ip0rtfNc1I7F2pdhCSV93sPGzMfk7w/Rzz+1L6l//9L9K/34NbnCpyzbws/0PXv4mj0VWVaR5YEO1c0to5LmtsBbOXSa25J1TAPzTu9sYtTYhNwhBB7XIgvEw2ipfgELjG3aQgq99NBxSxdnLE+kR+BDZa2RmV7GtYvcrPnCyAGGVZSCG25EQLYNTg1d96X10knrFgasTfkCzSXwESw0q523ODE/dI8/Vyh56oXRGGmRIQjusAaJrgDDOgPs1nhT4ChY7KP79ruIGIuM4v+fb+2b6/e/Vi78gS+hhq/yTgSJgY42KcP23A3bVhPxmGgKU10bsx6iKUyUWTerq1hKT6vLuBacbY0NtLj1bNbWIq6tNlYrZIft1ArbaQW1QrdbN62gbXZKK2CH/dEK22VXtAK32gutkIXel4Lt3gZpBO/U881HuLt0c9MZ5SMwLm59kOADDCnDBxhWjg8wtAQfYFBhPsCAMnyAYaX4AAOL8wGGlOEDDHsEVcnxAYSk+EAZhc/EKFzWY51Ms2GqDRXrnNao7UxP2pM09JewErUxMelK1JpOEtN7P0HfttTdyeVGYZmdOrl8iS1UfEy2+N6U+m2Y8yMBZsVdin3liseb64/X7t+2nr1ffHf/cm6Dm488ofoibwVG6z+s/vHWqQrWT1Swvubm0sH6mgRnCInmYL1R5gN9xgjVTzE7lk6kV4+ky0h5JpvUQ/WY/sGkhyWin33PIsQ/gA63aFJfrvNFQGZ3flMnmin85oF98iZd/wd+RMJqtcApT8YY2pJP/TSguZVqndFhKQuqFI8rBe9WTuK54Ccb8s2vtT7xzySFLlwle6rDTjTQSXJ6j7C59DdCNFsF8JorVpCxjt2GztmTQAXvV3auBC868L7WdnzA05zQVL3Ac7ZwO+ReswYWSiJjib5FD1FPJnoq6jnc4uo6p2ITj3pGyFIDMEFRGoFSWZR8Yd+PBSjelpCULfewiaigxmaatYrG8aiez33rpVkM72QsarMe2tec3D04FuPSJB6PIN1czygWKqiKIzdO6Frf/nHK72n33ePaJDcI90CIpC2KGvtoTozVBrA+OS5upvErmyNstI0u5WJR4rFQRsqo+fcbNbrOSFFk6T3gCwprPvC1UH4CVs6sOwzyw4lv/EQFP1TwY8jgh6GVgx9MG5FZjm/Zw9Y4kzeai0mMG/swptP2q7/gzhPcKCsdj+NRpVWrB7n8a3ufxt0dIhEPcDy2z7bjZ/VwAT4bwNGtCh38a7XsTDR0wBQcfSRMMdFj3X2pQgf9LC4rX4q1uEMpBayVWjeOgEujTCZlMo1tMhmsox2jmkx687bqmdlMkEcljCZeCwk1L2UiCdhDoAtlDilzqNBJ52sP4WCGMoiGWN6TW0SsnbKKRVSuja5MImUSjWQSWdbJTSJWvfAxTCJSb0hm03CER2TjK/bdqlhoN5HyEnX/abfA1lEcenGCj9tJmWDnME29PcITAyt3KVPxuZqK5pmbivXi+8pU7G15T24qsspytRRIUYW3lbk4pLm4rJiL/BnXS/xi/xnXzQHmYe1Fkr3La4W1lLfgMVDaImel45XP1F472tDLZzL2vsOzkKgq9Zvb6z+fuxnc37SqKe11SlN/50FKHUcAtUmfLAz8nevvuDFh3/93XtML0LPj0s2Cilr5AhT5VpF3byvOH2Au85P6EjM6GPsj4xmJI7W64qsLLTc1ebKs4WaxA2MHSsL0Mo3SwkVNZh5Ez2J0BXBZYpduRJaR0/UKeW3y+IcTB36SiqVRHN1rUUoaOPUO9x6CCpz/ewPnS9HAecNJ/aEi5wYr9UpFzntaX5N1Jd+oJ1arYpo6tkZXAjhIMXSalRag3LJTuCt4dlEibndEP0VUa6SuRuhGOPoh35VweEO+K4mgg3xnJSNl7P7KBeeGnFJx71S+M2xHj9jVaBM5nlSkTMnhexP3v4W78pNxhgQPYY+hVg79DK5WSl2N0M3waoV0NbxaIV2NoVZIZyOpFXZ/Q0vDw5SOoFZIZ8OrlVpXo03k4GqF9DSKDPbDdQwcrCpZtoaAjE5f1aCcLVX/4vmEScwZZwGM2VgFMAyzFiUZs47thKpiS2radtSx1S4WS1K1NoecWfOJdBnbSoXZzrq2rWlLdGFb9otsAuGuYntckMx6gqu9nM3Kq71YGOOtdtsNXoMvNgIVLlk8w7eD4rQ+rbgasKkEcR1iVpwbaYJYWMcCzBclANEqx+BrHEUp/TqQ8nfvIhfGEK//Hw==7Z1bc9o6F4Z/TWb2d1GNzpIvm6THJD03bXrDEDDBDeDUQE6//pPAJj4IG4itqI07s3eLcSBa8qO11istaY8cjG/fRN2r4UnY90d7GPZv98jhHsaIEqr+0lfulleEIMsLF1HQj296uPA1uPfjizC+Og/6/jRz4ywMR7PgKnuxF04mfm+WudaNovAme9sgHGW/9ap74RcufO11R8WrP4L+bLi8SgiED2+89YOLYfzV6i1v+c64m9wd3zoddvvhTeoSebVHDqIwnC3/Nb498Efaeolhlj/3es27q98s8iezTX7gPeHvXv3ov+sMh29+BR1yfC2iF/GnXHdH87jFp340C5QB1NVvke+rv467d+F8FjdidpeYZnoTjEfdiXq1P511o1nceeq3IPvDMAruw8lMfQw5ROpCbxiM+vEHkcOZ+uDkRerexfeRQ/0BkT8N7rvno+R1T98QTPzo292VH3+CujxQl+PvRcqg+0WbJA1UrfJvU5diG73xw7E/i+7ULcm7LO6v+IlFJH5989D/lAq+vDhM9T2lyYMXP3QXqw9/6Bb1j7hntuglXOilPcxH2njn6h8X+h+D8bTTD7oXnfD8twYhfl993eqWQg/eDIOZ//Wq29OvbxTAujdm46TPisYsfYQ2tjBmkgPOFUPxH5YxOC3aGyW4pc2d9Evt1iYFa78++bo07iAY+dP/9sjL/606IErMqx5Y/789rH4ahgP9e/Vm8wVGix/SXzrRA6H6GD2I6Wf7f670iEQCIJbtBoQN/SAh4J7hyW+qK6jhwc+ZzO+rATt+6Y/Ow5tXDxf2FxfUG9fJoJYxZxTOJ32/nwxR8+h68UKPN9NwHvX8T34UqIb4ke6SYHIRv6lGuwt/tubN9FjI9a8w6adebdeDy9+iemBY/kLVj7S2VenzEPmj7iy4zjq/2nuVlQHmj/qbEjafBH/m/uKTokADNXWGKDVkUYDoaoiDpBouhkDiQazAxVu4aoGLOQWXaHu1ll6Vdfdq/KOfwkC1YzVQvBDcoxgwj6DlQIEyA4WXgz828vIzck/K6pfa/eGR60fm8/lg4EelQ/PivruuelgwS43mzgzKhAgOBHkYlWn1oMwRYDYHZa/FtxZ8EwHBAr/Cc4bfpNWpx2cBYvc2KCNXf+x0oVncqlt1suIIsJ5ggEtRjSkkANpMTFBROGk5NWQc1Zxie5yqLNcVTouKTk5jQM54TSqywsBKm03zh2wKNKio0LTw7QQftQafR9bDh6Rl+oqyEkj/cYU8BGVWi3YAvaJ206K3E3rcGnrcJfSKolPO8U2ccXxohZE7+LXqTjl+SWBVzZ89fQeT9fmhdf5KFB7NnyvsUanGrCx8XhE+yYrs4cbYa6WZCvbohuxhe9qMS+zhojjzl4SdBvTs+j3cyi0V7PFN2bOntzjFXoXg4gx7hZjz6dlr1ZYK9uSm7NmTW4hgwFuxh7OPlLDMXlFuWUwMdoLylR7p6cTiLTmt1HCHfrNz3Y1GwXTmTFKJs3gTvuFqN97Y2sJW0akLb3uSDhFyrWtdPVK28C5KOsu1Aim+3WAP8Wr4ZEOu1T/2zujP05Ozw97x9xffe78ImhpWX7foGVZWpckz2tFaTMsopE8wh1jW6JJVlO7MISJBJcDZ5TZGNRV6xuU2dRB493kyODkc3U1G8mg+OOtdvqbnLYHbE2i0ozUCCaMMSEispZNlzTUrOa5Ap4JGnQRsAB0HDFuErk0o64HOWjqJpScAZJI/KXTFNDLv8NyZO8QMYkA3YU8Cz1BL1hh77QTiir2yqKqSPWvThxhTpEIn/LQOrzhtuFBXKhScQpVickHXbe7pqt1RGC0+jv+Zh8sbFmWBg0H6UkbwUaBnvlI1Z/lp2W9IFz4afr2l5qvaPF38GlHkT6/CSV8/dLrCWN3WHeuhYnI+1X+FPfUsqyestyjk08VH2fdnw8X62aQOyZVRCJFNZnKwBwzzqPkHrLYRqJ1GrWcEsrfCHRMpgOC5IahBGbm0vX+BzsSot8HqBdGQ1GS2Xpvp1oSdtVQXcc4BRIibxCbr9BVT3n531o3LwjR+e/gg9393gORsEyCbTIS/y5PB7dGbiwtJPow/f5nuo4sfrfpUkQgbZl6MdrSGJBRCIUmhzDxLzcXiZa0tK9J0R/klUOj0JascGDNhDIE0lHA1Bl+rQtUDnzUVCqpsBhAqc1spNOcIy5q7ZhGfM9gxjoCXODOXsGuXG9SDna3FBtxjhAOufJ5xHZ9l+krKRxLf544ITIQaHCTFq/0GntYL/gx57+w38o5OPnReBPPh4HDQLkFI4VgWbKVxNNrRVgjKJVePCCM4G4I2yGFZc/P7DMSCTHj+2xkGoWTAy8efhuTPQ6v5mrrBwzdvv30V3cHgy5/9b9cvP0+9Y9GCVwGeoZjEaMd/F7yy5v6V4adx8qE5f2e0X5v1lWNnqCMx2tFW1ucIdsWsz1V/J4gElDzEnNnNc4xVlB4QDa25+8RHbNq7uPx2z079e3JzT4LW81UuOIdFBo2GtOb6PKTcDEE0p7ygxhgsa65xbyuHBE8pCRCkWnkxbaRbB3PkxRWeT2fD9zz6NH4z5zN0+71lbgfmjIa0F25SBAGWXHjLP9nnCTaGXlmr3V7vSjwPu0deG3DWRJ61iFNQhgEiFC/BywaetslbE3gunJ47Sqcaq5BGLwk6c2sVLDJ49JF8Pfz6E0ZHnR+f5q/3v3x614qcKQbLIqs0gkY7WnN+nHK9Uy8SlhEsa3Xq6dH0uYIe8SABMnmiS9I8LNVtFqFrHd8KurKYqhI6a37PKehKp9ndYc8UcRrYs+rt2hn2cvAMMwtGO1qbYXcKvOIMu0veji4mDPC6QNOAHoGNub1vgh3+OBZvYWc4EG8P7v68ujhsC6we6CubOU7TZ7SjrQIrLiDBgLI1QktzRf1lrTbVOLiCIOaMAQLRmlM0iCgyqH7AIxYZbEuM6mHQWolROYSkuQXWpc1OPT+T+bjjj/yxsn9pxaNqOgzVJZg6pqwfzKPJ4iTAaXd85dQpZYIhoDD0kj/Z0MOEMhLQVC1Yx0Eb5r5otZuaWLYm3gioT7KDNGY5OwFtneWietNTfT7rwFUZcaaS99/g2uNajl3PNQXJoR6Zs64ESJYLZNw0SYivn+5WJKqJbnsqEVQeADNsnB2xTndRJorj5Zk+J9oRHAniEsitImbOQdI2KxFze65HXSBaU42YBtGDLFGNskucrZO4dhfIfjB2qzyfYOX/PJqVjkwQSmVfm9JRe7pHXRBaE49UmMsA5sgNb7hOPfpvoiF0B0DiMSD5RgAKm7pRe8RHTQBaO+GDK/AIIEg6kWwaTvhYJJvuEcgQB8x7iEizK3tNLDZYH8U6H+969+LLq/37H4P7y5fdz/SknUfZfr8aox2tuUJMsV6wumbZXHPzKGWtzi2bO+uOR6/1kQGn3SRDzKs9evMavX8NdGTvurU7661kqMXedOmt6WBuNzpnRh0kIQf5wyhMK5X03pmyONawGsaa3tfb95+PfswjJL9/EAff8P67r+36wB2OQDAaElsabJjHPKH8Ebee/JY1O/X86OlaqP+pXyWrFJ6eQJzbD9J0AkIylVO3lzdartV/ayLPlv7LJGEEcEaw5YC7rNWpx0efF/QsDxYiGxxuYj5ZqCm2W0m5JrZtScpMwMVEhWdciGib7aKgvDw1LPIvFHd+5PefHeMMusZ4m6XXxLitNJ1RLDzAMXaC8WKarhcbV/hv/aE6vx13bzvdW9+Ztcmc7khnPQss0Nz/dPX7JpLTdx9/81F4encO28x2exXNaEdriS3yCAKYedjyauSyVueLT11NbiGVm2y73tBeJ2eju3HnN/wVnHnTD4y+3z/3W2VpB/6MdrTFHxX6CDrPY2ueo/rBK2vuer/oCHFoo33VOW9s6mjmTV9+3OdfboYvRx3282x6eXbaQrdDUGo0pDXqCIIYoNweX4STpqAra23qsbnSX+VH+jQDvdw3zijjA+PzoeniZh2XzsKtkk83UBYbKMPIJA3r9S81RK+Tzg9y+5Fdv+Y/X51ei/uzt+xtC/IDyGUn4qU5NtrRFsdqpPcwkMoHGKszm6tkLWv1+jPL3CBP17SuDr0trSEHvKElwSdve1/wn6s3dzjsX1x+5GHn80ELX4UXNYSuRjtagw8LXZgpPGbcbbzB3frKmp16fB6E206yNGFqWoAR55WpJQ7zSfBn7u89LGlwRvOhSA14JLeWGGGD7yQQeA0VzuFfB7P907uX43P6+kvn6FX08/JLi+/2vtNoR2v4QkEQEBLH+CaFa4lHaE6ZLWu2cf8VV+DTVUgA0VWVm1e9y3uDTtRoxnZ9Qz0U2lregCSXVCU0AjpB4Zrd/1YCLIYTZ2Dkevhao1fbIRB+H5++wh+jHiW97p/Dk/fBXbvb9C5ikNGQthwh4kgQQClfUy2ZXwVaH4JlzV5z4ILyhXAcRn6xjNwNKr0NVgVJ05RkDTheBr+C/fBX98vp5T759eX2zfj3sHWIFQ7RkFUa7WjNIepN7oC3mo+0txF1WbPd3hZQb5EE1k3dWjpv9tNFh59P+79fHb2fk/OzIxS9a8/e20HSMdrR1oI8TwgKJLIm5JQ1dh1ysftzgzxKOAHYq5ZjtExtqDCpQ4052H8x/vGhN74/vLwYnb6C7OQ1NG0pdZpAhOG3yNfq1nH3LpzPCrac3gTjUXfi52jQGcD+MIyC+3Ay6yaW7Q2DUT/+IHI4Ux+cvEjdu/i+JV+RPw3utaQWv+7pG4KJH33T5VHLT9hbFj3F36tSIlMHbl8NhHOrGQU1DJEeNBQA0+b6qZguJIVjH89/+71ZXDYGkzqxNbsHZeb6ljOBptqux1JT/qxt3hWQc+WwKBPZyXxTh+CGRExzU4rRd6aOb5feWM685srwquvtCtWAxPzjS8W625vNF2gvvq2GuaaaeppilX4zhFeiWbbDETH1uGnWV9axZNHcqGeQIpT2ZjpMKR2k0nFKKT71BSqP61mznGWoyq0COirgWqy03ZrxWThbIJuaeFphvJp4cgdlhD0BPLwBwMIywM8gzbAFcO1p/qY9O74gf97CX/vRpOeffYZ3N/h6/hy01Ed2rCGDNFrSmpgKJfQAwxLHPj+bS/LmxNSyZmceoM1jNrRmNHdkQFYZDGAoNyDrY1eKW20aJVdUx4hsNHsbUT1wW/ZcVmJrTXWFHqIxttnnSRQdd8PMFoO2dG1kWQ1mKpBKLdyBwUSbeujH2ZFDERXM2poYzi1D3IyuaIrdNpiqy+faUm1dgrdCvHUEPEqZspeLnvMZ1Ddbos9WgTOCQmAA10W89hEs1jhvE/NOYhfpcNyrz4ORqVV4uYlPI8YeA55pFVAtJE8n0d3p6MN3eCD+vMbhcThmpM1dK0k2rMUzWtJe7goJA/yB5Gx5WIO5a1mzd+B4IUY6nrx60gPS28gDG+ZNG+S2jX/r4tbeqgXMdTGnGdtGHXBZux2PgREhGAixCYHmTUSaQ7ANgutC0FYQ7BFI13tO+wjuHgMvfOfEbd+JuFThbH7LCHPca5fcZ7Cf/cbklgV1leBaOwlRqj8xuRa1o9I2p56e627UGUy6460X/KksdnSw2jGb9Lu+HPQWvR2Fl37qHd6T/vmgSVqlRAB61UovN8W5NSx0Mtu6TU+3n6IxW9JWeupR5K33sRLbzU4NK+UW0zR/O61EQADxBrQ2VMRiNnablFb4Vb4prbaSUkkYjZPSJ/erxYT0X/CrSEEI+Gr3CZg76MEIbUO7gplDvaLZW2h3CoaxsAUtw9AIrW3viosSSLPVn3UxiaAoyLomEoUENsNdbBIEWhZ3cKDYs8SikAIBxh1gsShqaPep/qvDgTJf9qnJgUp8TvgOPb2VAsy2dKAqlWU2uSVFSeD5clu2Wq6SW4Js+VBIBcCEiKTo52npJUWhI7OccPsdMR0iOLFlQqz3sC6wYgkTlrXsomk2eVEaaKHdDVpiDVqvDFoPFhecNs1tcQ05eMQ0qkPQovyxDY5QW1x33VK7G7XMErWCqXgMU1IIkZ+C16JEmfGzE/WPv9rV5jc2MlNrmm9tlNpWZKqg1rDdmNmStkQmjjAEENHE18qn1odJUWwyVNw4ojAxzgGjDzlrdusVo9SkxkhRpLK5nLVdBFETkkmgZON4XwKQxMnUanZFue2UlRZFj9qmVgcDn/eMEzZ94Z1D2CS6enMpQjaYWuVAcIvA0nYtRIU4vDGw2BKwVHIKJEPCCKx9F5o0vIEp1qckFjE9T8M2QFaAxAR2kG0rzOtC1laJOeXqIYFch71PqwjTotBR33zOQPZ8M63nUoetjdLKJVeh7kaTr0mQaofWdvlSBa1JClaNq7WzuQlEwOOScidCYtPh3I+axWmMQl1bLlOTqvntxI0nhBozVFzLlllme7YlNrURae0kbaKPW6LriPQKVR1NM1lcU5PZqd6dUjfGBEA85xfd4LDViurikNkSi1QgSwGCpLD1ln0E2RqlqM5Jl6eMaDmXgOYVIwO4HgSmbZvrAde4SXkrGe2w5aTRktYkI8gZEEJinsOW88agLWtw/oylWTAb1bCvfW25JIWAiNz5SqbdXpkEXkNqrdF8rfJTF3m2lB+CdKEGfdgG/Gn5W3PG2Xl36ve7M4cQFMQDhGyAoLHIuwb+Di9e8oPTu/vriH0IoiGicjhp+duhqsVoSFv4CeX3EOFSiqUoQbLPE2zuRKWyZv9zq+n1hkablHk3V/liNHcrvW5f+GI0pCXhlSEChHw4MUM8La1r9zLac70SjTKx0WRIgyUtRou2yuv2M5dGQ1rSXZGkDHhYcCKoC0SuVV2dJ1LqPaL4NuVmDU5UmhtVHO6e+6lpONEYSw5NE+YTXRs71qc4hKrw8TiYbntYWrJJfEeLpTZ3/OLb9gLJBZaGTjAlgc2dk1YchXQUr0P4sg36n/bEo62tvjqJbOvDjhqz+7OdL+LF6KF0cKg+6qj2+OFRPZs8anlZarEjYSeY9INe7hTBHdkq/PBMBQ2LYzJm+v/hzaQ4bsL4+50hk5Idyczv4Vxf/z3bGaHayUxQsE/m8e0PdnR08AZ+fnt1PPH6Z6PL989X8Ny4Yw0Zm9GS9k4zwtaOHStrqCk60ivVoOFcSXWXvhGmDvBlxdvyG7wbbnmEmtrYcJ2Lo1avq/aY5jWM1sYOeraqaO1MW9vkPemifB5qCekn2dR9+4yFV5NmStbrSFiMZnu2amftoFlbZirWCD6WQCtRFuLlbPW4z/jD/hYPKjdwocjkQpsKi5/vDtKPSXjMpsSW2Ea5tJlbZtuwabSG7Up/nx+tUTcW72ppYhYupYy0zOgInpxuoEdgA56ENHYsOi4a+7lPZhDC1zi3VD9RZugnnJ/lq6+bivqCXsNtms6AhRmMxWpvy7MXq+dqm5m/jNWfevYCrzliuGr6wiStLk5NbGog2t7Um8xYmMah5mz9XFPtVTurwoRkAKjWRWvXzx7Xs8WUeHWO6CYTFmU0bTJJsZyUCBqblXj8OGekjxjoa25W4rnm3w3QV7vS9aj067lOBD+qY81JiaXCQSxgrvDB8qyE4XytxVidTb8cGUsJqx5LzcuOtgZOvYzCcJY2tmrn8CTs+/qO/wM=
\ No newline at end of file
From 7e87981d681634d3988390eed3f146651b3803da Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 26 Apr 2023 13:15:18 -0400
Subject: [PATCH 099/168] fix: Modern diag_manager fixes related to static and
scalar fields (#1188)
---
diag_manager/fms_diag_field_object.F90 | 8 ++-
diag_manager/fms_diag_file_object.F90 | 58 ++++++++++++++-------
diag_manager/fms_diag_object.F90 | 72 +++++++++++++++-----------
3 files changed, 87 insertions(+), 51 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 8aa1010891..128d62fe1d 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -1130,7 +1130,13 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
call this%get_dimnames(diag_axis, field_yaml, unlim_dimname, dimnames, is_regional)
call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml), dimnames)
else
- call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml))
+ if (this%is_static()) then
+ call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml))
+ else
+ !< In this case, the scalar variable is a function of time, so we need to pass in the
+ !! unlimited dimension as a dimension
+ call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml), (/unlim_dimname/))
+ endif
endif
long_name = this%get_longname_to_write(field_yaml)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index f657a63b16..534d881adc 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -27,7 +27,8 @@ module fms_diag_file_object_mod
#ifdef use_yaml
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t, &
get_instance_filename, open_file, close_file, get_mosaic_tile_file, unlimited, &
- register_axis, register_field, register_variable_attribute, write_data
+ register_axis, register_field, register_variable_attribute, write_data, &
+ dimension_exists
use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED, &
TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ, &
get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute, &
@@ -89,7 +90,7 @@ module fms_diag_file_object_mod
integer, dimension(:), allocatable :: buffer_ids !< array of buffer ids associated with the file
integer :: number_of_axis !< Number of axis in the file
logical :: time_ops !< .True. if file contains variables that are time_min, time_max, time_average or time_sum
- integer :: unlimited_dimension !< The unlimited dimension currently being written
+ integer :: unlim_dimension_level !< The unlimited dimension level currently being written
logical :: is_static !< .True. if the frequency is -1
contains
@@ -165,7 +166,8 @@ module fms_diag_file_object_mod
procedure :: write_time_data
procedure :: update_next_write
procedure :: update_current_new_file_freq_index
- procedure :: increase_unlimited_dimension
+ procedure :: increase_unlim_dimension_level
+ procedure :: get_unlim_dimension_level
procedure :: close_diag_file
end type fmsDiagFileContainer_type
@@ -244,7 +246,7 @@ logical function fms_diag_files_object_init (files_array)
endif
obj%time_ops = .false.
- obj%unlimited_dimension = 0
+ obj%unlim_dimension_level = 0
obj%is_static = obj%get_file_freq() .eq. -1
nullify(obj)
@@ -327,6 +329,9 @@ subroutine set_file_time_ops(this, VarYaml, is_static)
type (diagYamlFilesVar_type), intent(in) :: VarYaml !< The variable's yaml file
logical, intent(in) :: is_static !< Flag indicating if variable is static
+ !< Go away if the file is static
+ if (this%is_static) return
+
if (this%time_ops) then
if (is_static) return
if (VarYaml%get_var_reduction() .eq. time_none) then
@@ -1051,10 +1056,13 @@ subroutine write_time_metadata(this)
call write_var_metadata(fileobj, avg_name//"_DT", dimensions(2:2), &
"Length of average period", time_unit_list(diag_file%get_file_timeunit()))
- !< Write out the *_bounds variable metadata
- call register_axis(fileobj, "nv", 2) !< Time bounds need a vertex number
- call write_var_metadata(fileobj, "nv", dimensions(1:1), &
- "vertex number", no_units)
+ !< It is possible that the "nv" "axis" was registered via "diag_axis_init" call
+ !! so only adding it if it doesn't exist already
+ if ( .not. dimension_exists(fileobj, "nv")) then
+ call register_axis(fileobj, "nv", 2) !< Time bounds need a vertex number
+ call write_var_metadata(fileobj, "nv", dimensions(1:1), &
+ "vertex number", no_units)
+ endif
call write_var_metadata(fileobj, time_var_name//"_bnds", dimensions, &
trim(time_var_name)//" axis boundaries", time_units_str)
endif
@@ -1128,20 +1136,20 @@ subroutine write_time_data(this)
endif
call write_data(fileobj, diag_file%get_file_unlimdim(), dif, &
- unlim_dim_level=diag_file%unlimited_dimension)
+ unlim_dim_level=diag_file%unlim_dimension_level)
if (diag_file%time_ops) then
T1 = get_date_dif(diag_file%last_output, get_base_time(), diag_file%get_file_timeunit())
T2 = get_date_dif(diag_file%next_output, get_base_time(), diag_file%get_file_timeunit())
DT = T2 - T1
- call write_data(fileobj, avg_name//"_T1", T1, unlim_dim_level=diag_file%unlimited_dimension)
- call write_data(fileobj, avg_name//"_T2", T2, unlim_dim_level=diag_file%unlimited_dimension)
- call write_data(fileobj, avg_name//"_DT", DT, unlim_dim_level=diag_file%unlimited_dimension)
+ call write_data(fileobj, avg_name//"_T1", T1, unlim_dim_level=diag_file%unlim_dimension_level)
+ call write_data(fileobj, avg_name//"_T2", T2, unlim_dim_level=diag_file%unlim_dimension_level)
+ call write_data(fileobj, avg_name//"_DT", DT, unlim_dim_level=diag_file%unlim_dimension_level)
call write_data(fileobj, trim(diag_file%get_file_unlimdim())//"_bnds", &
- (/T1, T2/), unlim_dim_level=diag_file%unlimited_dimension)
+ (/T1, T2/), unlim_dim_level=diag_file%unlim_dimension_level)
- if (diag_file%unlimited_dimension .eq. 1) then
+ if (diag_file%unlim_dimension_level .eq. 1) then
call write_data(fileobj, "nv", (/1, 2/))
endif
endif
@@ -1196,12 +1204,22 @@ subroutine update_next_write(this, time_step)
end subroutine update_next_write
-!> \brief Increase the unlimited dimension variable that the file is currently being written to
-subroutine increase_unlimited_dimension(this)
+!> \brief Increase the unlimited dimension level that the file is currently being written to
+subroutine increase_unlim_dimension_level(this)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
- this%FMS_diag_file%unlimited_dimension = this%FMS_diag_file%unlimited_dimension + 1
-end subroutine increase_unlimited_dimension
+ this%FMS_diag_file%unlim_dimension_level = this%FMS_diag_file%unlim_dimension_level + 1
+end subroutine increase_unlim_dimension_level
+
+!> \brief Get the unlimited dimension level that is in the file
+!! \return The unlimited dimension
+pure function get_unlim_dimension_level(this) &
+result(res)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
+ integer :: res
+
+ res = this%FMS_diag_file%unlim_dimension_level
+end function
!< @brief Writes the axis metadata for the file
subroutine write_axis_metadata(this, diag_axis)
@@ -1344,8 +1362,8 @@ subroutine close_diag_file(this)
call close_file(fileobj)
end select
- !< Reset the unlimited dimension back to 0, in case the fileobj is re-used
- this%FMS_diag_file%unlimited_dimension = 0
+ !< Reset the unlimited dimension level back to 0, in case the fileobj is re-used
+ this%FMS_diag_file%unlim_dimension_level = 0
this%FMS_diag_file%is_file_open = .false.
if (this%FMS_diag_file%has_file_new_file_freq()) then
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 0827d2d5fc..c4c1f1bcbf 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -20,7 +20,7 @@ module fms_diag_object_mod
use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
&DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, &
- &get_base_time, NULL_AXIS_ID
+ &get_base_time, null_axis_id, diag_not_registered
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
& OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
& get_ticks_per_second
@@ -368,13 +368,24 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes,
fms_register_static_field=diag_null
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
-! Include static as optional variable to register here
- fms_register_static_field = this%register( &
+ !TODO The register_static_field interface does not have the capabiliy to register a variable as a "scalar"
+ ! since the axes argument is required, this forced model code to pass in a null_axis_id as an argument
+ if (size(axes) .eq. 1 .and. axes(1) .eq. null_axis_id) then
+ ! If they are passing in the null_axis_ids, ignore the `axes` argument
+ fms_register_static_field = this%register( &
+ & module_name, field_name, &
+ & longname=long_name, units=units, missing_value=missing_value, varrange=range, &
+ & mask_variant=mask_variant, do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, &
+ & standname=standard_name, area=area, volume=volume, realm=realm, &
+ & static=.true.)
+ else
+ fms_register_static_field = this%register( &
& module_name, field_name, axes=axes, &
& longname=long_name, units=units, missing_value=missing_value, varrange=range, &
& mask_variant=mask_variant, do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, &
& standname=standard_name, area=area, volume=volume, realm=realm, &
& static=.true.)
+ endif
#endif
end function fms_register_static_field
@@ -597,22 +608,24 @@ subroutine fms_diag_do_io(this, is_end_of_run)
call diag_file%open_diag_file(model_time, file_is_opened_this_time_step)
if (file_is_opened_this_time_step) then
- call diag_file%write_time_metadata()
call diag_file%write_axis_metadata(this%diag_axis)
+ call diag_file%write_time_metadata()
call diag_file%write_field_metadata(this%FMS_diag_fields, this%diag_axis)
call diag_file%write_axis_data(this%diag_axis)
endif
if (diag_file%is_time_to_write(model_time)) then
- call diag_file%increase_unlimited_dimension()
+ call diag_file%increase_unlim_dimension_level()
call diag_file%write_time_data()
!TODO call diag_file%add_variable_data()
call diag_file%update_next_write(model_time)
call diag_file%update_current_new_file_freq_index(model_time)
if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file()
- else if (force_write .and. .not. diag_file%is_file_static()) then
- call diag_file%increase_unlimited_dimension()
- call diag_file%write_time_data()
+ else if (force_write) then
+ if (diag_file%get_unlim_dimension_level() .eq. 0) then
+ call diag_file%increase_unlim_dimension_level()
+ call diag_file%write_time_data()
+ endif
call diag_file%close_diag_file()
endif
enddo
@@ -694,41 +707,40 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value)
#endif
end subroutine fms_diag_axis_add_attribute
-#ifdef use_yaml
!> \brief Gets the diag field ID from the module name and field name.
!> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered
-PURE FUNCTION fms_get_diag_field_id_from_name(this, module_name, field_name) &
+FUNCTION fms_get_diag_field_id_from_name(this, module_name, field_name) &
result(diag_field_id)
class(fmsDiagObject_type), intent (in) :: this !< The diag object, the caller
CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
integer :: diag_field_id
- integer :: i !< For looping
-!> Initialize to not found
+
+#ifdef use_yaml
+ integer :: i !< For looping
+ integer, allocatable :: diag_field_indices(:) !< indices where the field was found in the yaml
+
diag_field_id = DIAG_FIELD_NOT_FOUND
-!> Loop through fields to find it.
- if (this%registered_variables < 1) return
+
+ !> Loop through fields to find it.
do i=1, this%registered_variables
- diag_field_id = this%FMS_diag_fields(i)%id_from_name(module_name, field_name)
- if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return
+ !< Check if the field was registered, if it was return the diag_field_id
+ diag_field_id = this%FMS_diag_fields(i)%id_from_name(module_name, field_name)
+ if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return
enddo
-END FUNCTION fms_get_diag_field_id_from_name
+
+ !< Check if the field is in the diag_table.yaml. If it is, return DIAG_FIELD_NOT_REGISTERED
+ !! Otherwsie it will return DIAG_FIELD_NOT_FOUND
+ diag_field_indices = find_diag_field(field_name, module_name)
+ if (diag_field_indices(1) .ne. diag_null) then
+ diag_field_id = DIAG_NOT_REGISTERED
+ endif
+ deallocate(diag_field_indices)
#else
-!> \brief This replaces the pure function when not compiled with yaml so that an error can be called
-!> \returns Error
-FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, field_name) &
- result(diag_field_id)
- class(fmsDiagObject_type), intent (in) :: fms_diag_object !< The diag object
- CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable
- CHARACTER(len=*), INTENT(in) :: field_name !< Variable name
- integer :: diag_field_id
- integer :: i !< For looping
-!> Initialize to not found
diag_field_id = DIAG_FIELD_NOT_FOUND
-CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
-END FUNCTION fms_get_diag_field_id_from_name
+ CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#endif
-
+END FUNCTION fms_get_diag_field_id_from_name
#ifdef use_yaml
!> returns the buffer object for the given id
From 9a59b1f462ec213680a11a218c485691061ba4d9 Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Wed, 3 May 2023 13:06:14 -0400
Subject: [PATCH 100/168] feat: Adds allocate_diag_field_output_buffers() to
fms_diag_object_mod (#1198)
---
diag_manager/Makefile.am | 5 +-
diag_manager/fms_diag_field_object.F90 | 1 +
diag_manager/fms_diag_object.F90 | 129 +++++++++++++++++++++++-
diag_manager/fms_diag_output_buffer.F90 | 1 +
4 files changed, 132 insertions(+), 4 deletions(-)
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index aa0e5c3800..cf73c87f17 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -85,7 +85,10 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD
diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) \
fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
- fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT)
+ fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT) \
+ fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \
+ fms_diag_fieldbuff_update_mod.$(FC_MODEXT)
+fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
MODFILES = \
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 128d62fe1d..b41d18fca1 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -164,6 +164,7 @@ module fms_diag_field_object_mod
public :: fms_diag_fields_object_init
public :: null_ob
public :: fms_diag_field_object_end
+public :: get_default_missing_value
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
CONTAINS
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index c4c1f1bcbf..a4bc1a2174 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -20,15 +20,16 @@ module fms_diag_object_mod
use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
&DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, &
- &get_base_time, null_axis_id, diag_not_registered
+ &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered
+
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
& OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
& get_ticks_per_second
#ifdef use_yaml
use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init
-use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init
+use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init, get_default_missing_value
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, find_diag_field, &
- & get_diag_files_id, diag_yaml
+ & get_diag_files_id, diag_yaml, DiagYamlFilesVar_type
use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, &
&diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, &
&fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, &
@@ -39,6 +40,7 @@ module fms_diag_object_mod
use omp_lib
#endif
use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d
+use platform_mod
implicit none
private
@@ -80,6 +82,7 @@ module fms_diag_object_mod
procedure :: fms_diag_send_complete
procedure :: fms_diag_do_io
procedure :: fms_diag_field_add_cell_measures
+ procedure :: allocate_diag_field_output_buffers
#ifdef use_yaml
procedure :: get_diag_buffer
#endif
@@ -884,4 +887,124 @@ subroutine dump_diag_obj( filename )
call mpp_error( FATAL, "You can not use the modern diag manager without compiling with -Duse_yaml")
#endif
end subroutine
+
+!> @brief Allocates the output buffers of the fields corresponding to the registered variable
+!! Input arguments are the field and its ID passed to routine fms_diag_accept_data()
+subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
+ class(fmsDiagObject_type), target, intent(inout) :: this !< diag object
+ class(*), dimension(:,:,:,:), intent(in) :: field_data !< field data
+ integer, intent(in) :: field_id !< Id of the field data
+#ifdef use_yaml
+ integer :: ndims !< Number of dimensions in the input field data
+ integer :: buffer_id !< Buffer index of FMS_diag_buffers
+ integer :: num_diurnal_samples !< Number of diurnal samples from diag_yaml
+ integer, allocatable :: axes_length(:) !< Length of each axis
+ integer :: i, j !< For looping
+ class(fmsDiagOutputBuffer_class), pointer :: ptr_diag_buffer_obj !< Pointer to the buffer class
+ class(DiagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields
+ integer, pointer :: axis_ids(:) !< Pointer to indices of axes of the field variable
+ integer :: var_type !< Stores type of the field data (r4, r8, i4, i8, and string) represented as an integer.
+ real :: missing_value !< Fill value to initialize output buffers
+ character(len=128), allocatable :: var_name !< Field name to initialize output buffers
+
+ ! Determine the type of the field data
+ var_type = get_var_type(field_data(1, 1, 1, 1))
+
+ ! Get variable/field name
+ var_name = this%Fms_diag_fields(field_id)%get_varname()
+
+ ! Get missing value for the field
+ if (this%FMS_diag_fields(field_id)%has_missing_value()) then
+ select type (my_type => this%FMS_diag_fields(field_id)%get_missing_value(var_type))
+ type is (real(kind=r4_kind))
+ missing_value = my_type
+ type is (real(kind=r8_kind))
+ missing_value = real(my_type)
+ class default
+ call mpp_error( FATAL, 'fms_diag_object_mod:allocate_diag_field_output_buffers Invalid type')
+ end select
+ else
+ select type (my_type => get_default_missing_value(var_type))
+ type is (real(kind=r4_kind))
+ missing_value = real(my_type, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ missing_value = real(my_type, kind=r8_kind)
+ class default
+ call mpp_error( FATAL, 'fms_diag_object_mod:allocate_diag_field_output_buffers Invalid type')
+ end select
+ endif
+
+ ! Determine dimensions of the field
+ ndims = 0
+ if (this%FMS_diag_fields(field_id)%has_axis_ids()) then
+ axis_ids => this%FMS_diag_fields(field_id)%get_axis_id() !< Get ids of axes of the variable
+ ndims = size(axis_ids) !< Dimensions of the field
+ endif
+
+ ! Loop over a number of fields/buffers where this variable occurs
+ do i = 1, size(this%FMS_diag_fields(field_id)%buffer_ids)
+ buffer_id = this%FMS_diag_fields(field_id)%buffer_ids(i)
+ ptr_diag_field_yaml => diag_yaml%get_diag_field_from_id(buffer_id)
+ num_diurnal_samples = ptr_diag_field_yaml%get_n_diurnal() !< Get number of diurnal samples
+
+ ! If diurnal axis exists, fill lengths of axes.
+ if (num_diurnal_samples .ne. 0) then
+ allocate(axes_length(ndims + 1)) !< Include extra length for the diurnal axis
+ do j = 1, ndims
+ axes_length(j) = this%fms_get_axis_length(axis_ids(j))
+ enddo
+ !TODO This is going to require more work for when we have subRegion variables
+ axes_length(ndims + 1) = num_diurnal_samples
+ ndims = ndims + 1 !< Add one more dimension for the diurnal axis
+ endif
+
+ ! Allocates diag_buffer_obj to the correct outputBuffer type based on the dimension:
+ ! outputBuffer0d_type, outputBuffer1d_type, outputBuffer2d_type, outputBuffer3d_type,
+ ! outputBuffer4d_type or outputBuffer5d_type.
+ if (.not. allocated(this%FMS_diag_output_buffers(buffer_id)%diag_buffer_obj)) then
+ this%FMS_diag_output_buffers(buffer_id) = fms_diag_output_buffer_create_container(ndims)
+ end if
+
+ ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id)%diag_buffer_obj
+
+ select type (ptr_diag_buffer_obj)
+ type is (outputBuffer0d_type) !< Scalar buffer
+ if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
+ call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), & !< If scalar field variable
+ this%FMS_diag_fields(field_id)%get_varname())
+ call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
+ type is (outputBuffer1d_type) !< 1D buffer
+ if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
+ call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1), &
+ this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
+ call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
+ type is (outputBuffer2d_type) !< 2D buffer
+ if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
+ call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:2), &
+ this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
+ call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
+ type is (outputBuffer3d_type) !< 3D buffer
+ if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
+ call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:3), &
+ this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
+ call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
+ type is (outputBuffer4d_type) !< 4D buffer
+ if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
+ call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:4), &
+ this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
+ call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
+ type is (outputBuffer5d_type) !< 5D buffer
+ if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
+ call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:5), &
+ this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
+ call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
+ class default
+ call mpp_error( FATAL, 'allocate_diag_field_output_buffers: invalid buffer type')
+ end select
+ enddo
+#else
+ call mpp_error( FATAL, "allocate_diag_field_output_buffers: "//&
+ "you can not use the modern diag manager without compiling with -Duse_yaml")
+#endif
+end subroutine allocate_diag_field_output_buffers
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 3036777526..d6ade5621d 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -143,6 +143,7 @@ module fms_diag_output_buffer_mod
! public routines
public :: fms_diag_output_buffer_init
+public :: fms_diag_output_buffer_create_container
contains
From 454538e32ed24d68c5f62571f627f6f4e0c10ae0 Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Wed, 3 May 2023 13:08:03 -0400
Subject: [PATCH 101/168] feat: Adds a function, check_indices_order(), to
diag_util_mod (#1203)
---
diag_manager/diag_util.F90 | 58 +++++++++++++++++++++++++++-----
diag_manager/fms_diag_object.F90 | 11 ++++++
2 files changed, 60 insertions(+), 9 deletions(-)
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index 1386014ddb..3a05b51e87 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -83,7 +83,8 @@ MODULE diag_util_mod
& prepend_attribute, attribute_init, diag_util_init,&
& update_bounds, check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,&
& fms_diag_check_out_of_bounds, &
- & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static, get_file_start_time
+ & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static,&
+ & get_time_string, check_indices_order
!> @brief Prepend a value to a string attribute in the output field or output file.
@@ -2494,16 +2495,55 @@ SUBROUTINE prepend_attribute_file(out_file, att_name, prepend_value, err_msg)
END IF
END SUBROUTINE prepend_attribute_file
- !> @brief Get the a diag_file's start_time as it is defined in the diag_table
- !! @return the start_time for the file
- function get_file_start_time(file_num) &
- result (start_time)
- integer, intent(in) :: file_num !< File number of the file to get the start_time from
+ !> @brief Checks improper combinations of is, ie, js, and je.
+ !> @return Returns .false. if there is no error else .true.
+ !> @note send_data works in either one or another of two modes.
+ ! 1. Input field is a window (e.g. FMS physics)
+ ! 2. Input field includes halo data
+ ! It cannot handle a window of data that has halos.
+ ! (A field with no windows or halos can be thought of as a special case of either mode.)
+ ! The logic for indexing is quite different for these two modes, but is not clearly separated.
+ ! If both the beggining and ending indices are present, then field is assumed to have halos.
+ ! If only beggining indices are present, then field is assumed to be a window.
+ !> @par
+ ! There are a number of ways a user could mess up this logic, depending on the combination
+ ! of presence/absence of is,ie,js,je. The checks below should catch improper combinations.
+ function check_indices_order(is_in, ie_in, js_in, je_in, error_msg) result(rslt)
+ integer, intent(in), optional :: is_in, ie_in, js_in, je_in !< Indices passed to fms_diag_accept_data()
+ character(len=*), intent(inout), optional :: error_msg !< An error message used only for testing purpose!!!
+
+ character(len=128) :: err_module_name !< Stores the module name to be used in error calls
+ logical :: rslt !< Return value
+
+ rslt = .false. !< If no error occurs.
+
+ err_module_name = 'diag_util_mod:check_indices_order'
+
+ IF ( PRESENT(ie_in) ) THEN
+ IF ( .NOT.PRESENT(is_in) ) THEN
+ rslt = fms_error_handler(trim(err_module_name), 'ie_in present without is_in', error_msg)
+ IF (rslt) return
+ END IF
+ IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN
+ rslt = fms_error_handler(trim(err_module_name),&
+ & 'is_in and ie_in present, but js_in present without je_in', error_msg)
+ IF (rslt) return
+ END IF
+ END IF
- TYPE(time_type) :: start_time !< The start_time to return
+ IF ( PRESENT(je_in) ) THEN
+ IF ( .NOT.PRESENT(js_in) ) THEN
+ rslt = fms_error_handler(trim(err_module_name), 'je_in present without js_in', error_msg)
+ IF (rslt) return
+ END IF
+ IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN
+ rslt = fms_error_handler(trim(err_module_name),&
+ & 'js_in and je_in present, but is_in present without ie_in', error_msg)
+ IF (rslt) return
+ END IF
+ END IF
+ end function check_indices_order
- start_time = files(file_num)%start_time
- end function get_file_start_time
END MODULE diag_util_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index a4bc1a2174..db81f997cc 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -35,6 +35,7 @@ module fms_diag_object_mod
&fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, &
&parse_compress_att, get_axis_id_from_name
use fms_diag_output_buffer_mod
+use fms_mod, only: fms_error_handler
#endif
#if defined(_OPENMP)
use omp_lib
@@ -479,9 +480,19 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is
integer :: omp_level !< The openmp active level
logical :: buffer_the_data !< True if the user selects to buffer the data and run the calculations
!! later. \note This is experimental
+ !TODO logical, allocatable, dimension(:,:,:) :: oor_mask !< Out of range mask
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
+ !TODO: weight is for time averaging where each time level may have a different weight
+ ! call real_copy_set()
+
+ !TODO: oor_mask is only used for checking out of range values.
+ ! call init_mask_3d()
+
+ !TODO: Check improper combinations of is, ie, js, and je.
+ ! if (check_indices_order()) deallocate(oor_mask)
+
!> Does the user want to push off calculations until send_diag_complete?
buffer_the_data = .false.
!> initialize the number of threads and level to be 0
From dde71388e88a876a880f74711066b3503503bbc0 Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Wed, 3 May 2023 14:14:37 -0400
Subject: [PATCH 102/168] feat: modern diag add real_copy_set to diag_util_mod
(#1204)
---
diag_manager/diag_util.F90 | 30 +++++++++++++++++++++++++++++-
1 file changed, 29 insertions(+), 1 deletion(-)
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index 3a05b51e87..7c3d9ec3f9 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -84,7 +84,7 @@ MODULE diag_util_mod
& update_bounds, check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,&
& fms_diag_check_out_of_bounds, &
& fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static,&
- & get_time_string, check_indices_order
+ & get_time_string, real_copy_set, check_indices_order
!> @brief Prepend a value to a string attribute in the output field or output file.
@@ -2495,6 +2495,34 @@ SUBROUTINE prepend_attribute_file(out_file, att_name, prepend_value, err_msg)
END IF
END SUBROUTINE prepend_attribute_file
+ !> @brief Copies input data to output data with proper type if the input data is present
+ !! else sets the output data to a given value val if it is present.
+ !! If the value val and the input data are not present, the output data is untouched.
+ subroutine real_copy_set(out_data, in_data, val, err_msg)
+ real, intent(out) :: out_data !< Proper type copy of in_data
+ class(*), intent(in), optional :: in_data !< Data to copy to out_data
+ real, intent(in), optional :: val !< Default value to assign to out_data if in_data is absent
+ character(len=*), intent(out), optional :: err_msg !< Error message to pass back to caller
+
+ IF ( PRESENT(err_msg) ) err_msg = ''
+
+ IF ( PRESENT(in_data) ) THEN
+ SELECT TYPE (in_data)
+ TYPE IS (real(kind=r4_kind))
+ out_data = in_data
+ TYPE IS (real(kind=r8_kind))
+ out_data = real(in_data)
+ CLASS DEFAULT
+ if (fms_error_handler('diag_util_mod:real_copy_set',&
+ & 'The in_data is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) THEN
+ return
+ end if
+ END SELECT
+ ELSE
+ if (present(val)) out_data = val
+ END IF
+ end subroutine real_copy_set
+
!> @brief Checks improper combinations of is, ie, js, and je.
!> @return Returns .false. if there is no error else .true.
!> @note send_data works in either one or another of two modes.
From 6a07b27e0129c91c2a579efd9bb05b353bffa708 Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Wed, 10 May 2023 14:38:09 -0400
Subject: [PATCH 103/168] feat: modern diag add routine init_mask_3d() to
diag_util_mod (#1201)
---
diag_manager/diag_util.F90 | 54 +++++++++++++++++++++++++++++++++++++-
1 file changed, 53 insertions(+), 1 deletion(-)
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index 7c3d9ec3f9..e03d86497b 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -84,7 +84,7 @@ MODULE diag_util_mod
& update_bounds, check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,&
& fms_diag_check_out_of_bounds, &
& fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static,&
- & get_time_string, real_copy_set, check_indices_order
+ & get_time_string, init_mask_3d, real_copy_set, check_indices_order
!> @brief Prepend a value to a string attribute in the output field or output file.
@@ -2495,6 +2495,58 @@ SUBROUTINE prepend_attribute_file(out_file, att_name, prepend_value, err_msg)
END IF
END SUBROUTINE prepend_attribute_file
+ !> @brief Allocates outmask(second argument) with sizes of the first three dimensions of field(first argument).
+ !! Initializes the outmask depending on presence/absence of inmask and rmask.
+ !! Uses and sets rmask_threshold.
+ subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg)
+ class(*), intent(in) :: field(:,:,:,:) !< Dummy variable whose sizes only in the first three dimensions are important
+ logical, allocatable, intent(inout) :: outmask(:,:,:) !< Output logical mask
+ real, intent(inout) :: rmask_threshold !< Holds the values 0.5_r4_kind or 0.5_r8_kind, or related threhold values
+ !! needed to be passed to the math/buffer update functions.
+ logical, intent(in), optional :: inmask(:,:,:) !< Input logical mask
+ class(*), intent(in), optional :: rmask(:,:,:) !< Floating point input mask value
+ character(len=*), intent(out), optional :: err_msg !< Error message to relay back to caller
+
+ character(len=256) :: err_msg_local !< Stores locally generated error message
+ integer :: status !< Stores status of memory allocation call
+
+ ! Initialize character strings
+ err_msg_local = ''
+ if (present(err_msg)) err_msg = ''
+
+ ! Check if outmask is allocated
+ if (allocated(outmask)) deallocate(outmask)
+ ALLOCATE(outmask(SIZE(field, 1), SIZE(field, 2), SIZE(field, 3)), STAT=status)
+ IF ( status .NE. 0 ) THEN
+ WRITE (err_msg_local, FMT='("Unable to allocate outmask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
+ & SIZE(field, 1), SIZE(field, 2), SIZE(field, 3), status
+ if (fms_error_handler('diag_util_mod:init_mask_3d', trim(err_msg_local), err_msg)) then
+ return
+ end if
+ END IF
+
+ IF ( PRESENT(inmask) ) THEN
+ outmask = inmask
+ ELSE
+ outmask = .TRUE.
+ END IF
+
+ IF ( PRESENT(rmask) ) THEN
+ SELECT TYPE (rmask)
+ TYPE IS (real(kind=r4_kind))
+ WHERE (rmask < real(rmask_threshold, kind=r4_kind)) outmask = .FALSE.
+ rmask_threshold = real(rmask_threshold, kind=r4_kind)
+ TYPE IS (real(kind=r8_kind))
+ WHERE ( rmask < real(rmask_threshold, kind=r8_kind) ) outmask = .FALSE.
+ rmask_threshold = real(rmask_threshold, kind=r8_kind)
+ CLASS DEFAULT
+ if (fms_error_handler('diag_util_mod:init_mask_3d',&
+ & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) then
+ end if
+ END SELECT
+ END IF
+ end subroutine init_mask_3d
+
!> @brief Copies input data to output data with proper type if the input data is present
!! else sets the output data to a given value val if it is present.
!! If the value val and the input data are not present, the output data is untouched.
From abeb277b143e0e459bf516c99ad4bad8f82c2fc8 Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Wed, 31 May 2023 13:03:02 -0400
Subject: [PATCH 104/168] feat: modern diag initializes buffer_ids and
buffer_allocated (#1210)
---
diag_manager/fms_diag_field_object.F90 | 3 +++
diag_manager/fms_diag_object.F90 | 11 ++++++++++-
2 files changed, 13 insertions(+), 1 deletion(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index b41d18fca1..cba28046db 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -75,6 +75,9 @@ module fms_diag_field_object_mod
!! been allocated
logical, allocatable, private :: math_needs_to_be_done !< If true, do math
!! functions. False when done.
+ logical, allocatable, dimension(:) :: buffer_allocated !< True if a buffer pointed by
+ !! the corresponding index in
+ !! buffer_ids(:) is allocated.
contains
! procedure :: send_data => fms_send_data !!TODO
! Get ID functions
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index db81f997cc..7d94c66c2f 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -29,7 +29,7 @@ module fms_diag_object_mod
use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init
use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init, get_default_missing_value
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, find_diag_field, &
- & get_diag_files_id, diag_yaml, DiagYamlFilesVar_type
+ & get_diag_files_id, diag_yaml, get_diag_field_ids, DiagYamlFilesVar_type
use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, &
&diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, &
&fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, &
@@ -218,6 +218,15 @@ integer function fms_register_diag_field_obj &
!> Use pointers for convenience
fieldptr => this%FMS_diag_fields(this%registered_variables)
+
+!> Initialize buffer_ids of this field with the diag_field_indices(diag_field_indices)
+!! of the sorted variable list
+ fieldptr%buffer_ids = get_diag_field_ids(diag_field_indices)
+
+!> Allocate and initialize member buffer_allocated of this field
+ allocate(fieldptr%buffer_allocated(size(diag_field_indices)))
+ fieldptr%buffer_allocated = .false.
+
!> Register the data for the field
call fieldptr%register(modname, varname, diag_field_indices, this%diag_axis, &
axes=axes, longname=longname, units=units, missing_value=missing_value, varRange= varRange, &
From 78aa657ddf25642b78ca47fb8c4fffe90d2b9736 Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Wed, 31 May 2023 13:34:32 -0400
Subject: [PATCH 105/168] feat: modern diag add fms_diag_compare_window() to
fmsDiagObject_type (#1230)
---
diag_manager/fms_diag_object.F90 | 99 ++++++++++++++++++++++++++++++++
1 file changed, 99 insertions(+)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 7d94c66c2f..a11152561d 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -36,6 +36,7 @@ module fms_diag_object_mod
&parse_compress_att, get_axis_id_from_name
use fms_diag_output_buffer_mod
use fms_mod, only: fms_error_handler
+use constants_mod, only: SECONDS_PER_DAY
#endif
#if defined(_OPENMP)
use omp_lib
@@ -84,6 +85,7 @@ module fms_diag_object_mod
procedure :: fms_diag_do_io
procedure :: fms_diag_field_add_cell_measures
procedure :: allocate_diag_field_output_buffers
+ procedure :: fms_diag_compare_window
#ifdef use_yaml
procedure :: get_diag_buffer
#endif
@@ -490,9 +492,19 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is
logical :: buffer_the_data !< True if the user selects to buffer the data and run the calculations
!! later. \note This is experimental
!TODO logical, allocatable, dimension(:,:,:) :: oor_mask !< Out of range mask
+ integer :: sample !< Index along the diurnal time axis
+ integer :: day !< Number of days
+ integer :: second !< Number of seconds
+ integer :: tick !< Number of ticks representing fractional second
+ integer :: buffer_id !< Index of a buffer
+ !TODO: logical :: phys_window
+ character(len=128) :: error_string !< Store error text
+ integer :: i !< For looping
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
+ class(diagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields
+
!TODO: weight is for time averaging where each time level may have a different weight
! call real_copy_set()
@@ -539,6 +551,47 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is
return
else
!!TODO: Loop through fields and do averages/math functions
+ do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids)
+ buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(i)
+
+ !!TODO: Check if the field is a physics window
+ !! phys_window = fms_diag_compare_window()
+
+ !!TODO: Get local start and end indices on 3 axes for regional output
+
+ !> Compute the diurnal index
+ sample = 1
+ if (present(time)) then
+ call get_time(time, second, day, tick) !< Current time in days and seconds
+ ptr_diag_field_yaml => diag_yaml%get_diag_field_from_id(buffer_id)
+ sample = floor((second + real(tick) / get_ticks_per_second()) &
+ & * ptr_diag_field_yaml%get_n_diurnal() / SECONDS_PER_DAY) + 1
+ end if
+
+ !!TODO: Get the vertical layer start and end indices
+
+ !!TODO: Initialize output time for fields output every time step
+
+ !< Check if time should be present for this field
+ if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) then
+ write(error_string, '(a,"/",a)') trim(this%FMS_diag_fields(diag_field_id)%get_modname()),&
+ & trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname())
+ if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '&
+ &//trim(error_string)//', time must be present for nonstatic field', err_msg)) then
+ !!TODO: deallocate local pointers/allocatables if needed
+ return
+ end if
+ end if
+
+ !!TODO: Is it time to output for this field? CAREFUL ABOUT > vs >= HERE
+ !--- The fields send out within openmp parallel region will be written out in
+ !--- diag_send_complete.
+
+ !!TODO: Is check to bounds of current field necessary?
+
+ !!TODO: Take care of submitted field data
+
+ enddo
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.)
fms_diag_accept_data = .TRUE.
return
@@ -1027,4 +1080,50 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
"you can not use the modern diag manager without compiling with -Duse_yaml")
#endif
end subroutine allocate_diag_field_output_buffers
+
+!> @brief Determines if the window defined by the input bounds is a physics window.
+!> @return TRUE if the window size is less then the actual field size else FALSE.
+function fms_diag_compare_window(this, field, field_id, &
+ is_in, ie_in, js_in, je_in, ks_in, ke_in) result(is_phys_win)
+ class(fmsDiagObject_type), intent(in) :: this !< Diag Object
+ class(*), intent(in) :: field(:,:,:,:) !< Field data
+ integer, intent(in) :: field_id !< ID of the input field
+ integer, intent(in) :: is_in, js_in !< Starting field indices for the first 2 dimensions;
+ !< pass reconditioned indices fis and fjs
+ !< which are computed elsewhere.
+ integer, intent(in) :: ie_in, je_in !< Ending field indices for the first 2 dimensions;
+ !< pass reconditioned indices fie and fje
+ !< which are computed elsewhere.
+ integer, intent(in) :: ks_in, ke_in !< Starting and ending indices of the field in 3rd dimension
+ logical :: is_phys_win !< Return flag
+#ifdef use_yaml
+ integer, pointer :: axis_ids(:)
+ integer :: total_elements
+ integer :: i !< For do loop
+ integer :: field_size
+ integer, allocatable :: field_shape(:) !< Shape of the field data
+ integer :: window_size
+
+ !> Determine shape of the field defined by the input bounds
+ field_shape = shape(field(is_in:ie_in, js_in:je_in, ks_in:ke_in, :))
+
+ window_size = field_shape(1) * field_shape(2) * field_shape(3)
+
+ total_elements = 1
+ axis_ids => this%FMS_diag_fields(field_id)%get_axis_id()
+ do i=1, size(axis_ids)
+ total_elements = total_elements * this%fms_get_axis_length(axis_ids(i))
+ enddo
+
+ if (total_elements > window_size) then
+ is_phys_win = .true.
+ else
+ is_phys_win = .false.
+ end if
+#else
+ is_phys_win = .false.
+ call mpp_error( FATAL, "fms_diag_compare_window: "//&
+ "you can not use the modern diag manager without compiling with -Duse_yaml")
+#endif
+end function fms_diag_compare_window
end module fms_diag_object_mod
From 0c4f54b11ccee31a4571f0080be74808666dfb74 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 28 Jun 2023 13:55:33 -0400
Subject: [PATCH 106/168] feat: modern diag write global/variable attributes
defined in the yaml + subregional files update (#1261)
---
diag_manager/diag_data.F90 | 1 +
diag_manager/fms_diag_field_object.F90 | 12 +++++++-
diag_manager/fms_diag_file_object.F90 | 31 +++++++++++++++++++--
diag_manager/fms_diag_object.F90 | 1 +
diag_manager/fms_diag_yaml.F90 | 5 ++--
test_fms/diag_manager/test_diag_manager2.sh | 5 ++++
6 files changed, 48 insertions(+), 7 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index b4a80d62f7..4e8b774afc 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -125,6 +125,7 @@ MODULE diag_data_mod
INTEGER, PARAMETER :: begin_time = 1 !< Use the begining of the time average bounds
INTEGER, PARAMETER :: middle_time = 2 !< Use the middle of the time average bounds
INTEGER, PARAMETER :: end_time = 3 !< Use the end of the time average bounds
+ INTEGER, PARAMETER :: MAX_STR_LEN = 255 !< Max length for a string
!> @}
!> @brief Contains the coordinates of the local domain to output.
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index cba28046db..d9d270ef36 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -8,7 +8,7 @@ module fms_diag_field_object_mod
!! that contains all of the information of the variable. It is extended by a type that holds the
!! appropriate buffer for the data for manipulation.
#ifdef use_yaml
-use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string
+use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string, MAX_STR_LEN
use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN
use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
@@ -1126,6 +1126,7 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
character(len=120), allocatable :: dimnames(:) !< Dimension names of the field
character(len=120) :: cell_methods!< Cell methods attribute to write
integer :: i !< For do loops
+ character (len=MAX_STR_LEN), allocatable :: yaml_field_attributes(:,:) !< Variable attributes defined in the yaml
field_yaml => diag_yaml%get_diag_field_from_id(yaml_id)
var_name = field_yaml%get_var_outname()
@@ -1208,6 +1209,15 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
trim(this%get_standname()), str_len=len_trim(this%get_standname()))
call this%write_coordinate_attribute(fileobj, var_name, diag_axis)
+
+ if (field_yaml%has_var_attributes()) then
+ yaml_field_attributes = field_yaml%get_var_attributes()
+ do i = 1, size(yaml_field_attributes,1)
+ call register_variable_attribute(fileobj, var_name, trim(yaml_field_attributes(i,1)), &
+ trim(yaml_field_attributes(i,2)), str_len=len_trim(yaml_field_attributes(i,2)))
+ enddo
+ deallocate(yaml_field_attributes)
+ endif
end subroutine write_field_metadata
!> @brief Writes the coordinate attribute of a field if any of the field's axis has an
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 534d881adc..4dd4228b99 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -28,13 +28,13 @@ module fms_diag_file_object_mod
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfUnstructuredDomainFile_t, FmsNetcdfDomainFile_t, &
get_instance_filename, open_file, close_file, get_mosaic_tile_file, unlimited, &
register_axis, register_field, register_variable_attribute, write_data, &
- dimension_exists
+ dimension_exists, register_global_attribute
use diag_data_mod, only: DIAG_NULL, NO_DOMAIN, max_axes, SUB_REGIONAL, get_base_time, DIAG_NOT_REGISTERED, &
TWO_D_DOMAIN, UG_DOMAIN, prepend_date, DIAG_DAYS, VERY_LARGE_FILE_FREQ, &
get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute, &
get_base_second, time_unit_list, time_average, time_rms, time_max, time_min, time_sum, &
time_diurnal, time_power, time_none, avg_name, no_units, pack_size_str, &
- middle_time, begin_time, end_time
+ middle_time, begin_time, end_time, MAX_STR_LEN
use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date, get_calendar_type, &
VALID_CALENDAR_TYPES, operator(>=), date_to_string, &
OPERATOR(/), OPERATOR(+), operator(<)
@@ -156,6 +156,7 @@ module fms_diag_file_object_mod
procedure :: is_regional
procedure :: is_file_static
procedure :: open_diag_file
+ procedure :: write_global_metadata
procedure :: write_time_metadata
procedure :: write_axis_metadata
procedure :: write_field_metadata
@@ -537,7 +538,7 @@ end function get_file_varlist
!! \return Copy of file_global_meta
pure function get_file_global_meta (this) result(res)
class(fmsDiagFile_type), intent(in) :: this !< The file object
- character (len=:), allocatable, dimension(:,:) :: res
+ character (len=MAX_STR_LEN), allocatable, dimension(:,:) :: res
res = this%diag_yaml_file%get_file_global_meta()
end function get_file_global_meta
@@ -962,6 +963,7 @@ subroutine open_diag_file(this, time_step, file_is_opened)
if (is_regional) then
if (.not. open_file(fileobj, file_name, "overwrite", pelist=(/mpp_pe()/))) &
&call mpp_error(FATAL, "Error opening the file:"//file_name)
+ call register_global_attribute(fileobj, "is_subregional", "True", str_len=4)
else
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
@@ -989,6 +991,29 @@ subroutine open_diag_file(this, time_step, file_is_opened)
diag_file => null()
end subroutine open_diag_file
+!< @brief Write global attributes in the diag_file
+subroutine write_global_metadata(this)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+
+ class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ integer :: i !< For do loops
+ character (len=MAX_STR_LEN), allocatable :: yaml_file_attributes(:,:) !< Global attributes defined in the yaml
+
+ type(diagYamlFiles_type), pointer :: diag_file_yaml !< The diag_file yaml
+
+ diag_file_yaml => this%FMS_diag_file%diag_yaml_file
+ fileobj => this%FMS_diag_file%fileobj
+
+ if (diag_file_yaml%has_file_global_meta()) then
+ yaml_file_attributes = diag_file_yaml%get_file_global_meta()
+ do i = 1, size(yaml_file_attributes,1)
+ call register_global_attribute(fileobj, trim(yaml_file_attributes(i,1)), &
+ trim(yaml_file_attributes(i,2)), str_len=len_trim(yaml_file_attributes(i,2)))
+ enddo
+ deallocate(yaml_file_attributes)
+ endif
+end subroutine write_global_metadata
+
!< @brief Writes a variable's metadata in the netcdf file
subroutine write_var_metadata(fileobj, variable_name, dimensions, long_name, units)
class(FmsNetcdfFile_t), intent(inout) :: fileobj !< The file object to write into
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index a11152561d..865466ccca 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -684,6 +684,7 @@ subroutine fms_diag_do_io(this, is_end_of_run)
call diag_file%open_diag_file(model_time, file_is_opened_this_time_step)
if (file_is_opened_this_time_step) then
+ call diag_file%write_global_metadata()
call diag_file%write_axis_metadata(this%diag_axis)
call diag_file%write_time_metadata()
call diag_file%write_field_metadata(this%FMS_diag_fields, this%diag_axis)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 5bba6946cd..a22dba5265 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -34,7 +34,7 @@ module fms_diag_yaml_mod
index_gridtype, null_gridtype, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, &
DIAG_MONTHS, DIAG_YEARS, time_average, time_rms, time_max, time_min, time_sum, &
time_diurnal, time_power, time_none, r8, i8, r4, i4, DIAG_NOT_REGISTERED, &
- middle_time, begin_time, end_time
+ middle_time, begin_time, end_time, MAX_STR_LEN
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL, mpp_pe, mpp_root_pe, stdout
@@ -58,7 +58,6 @@ module fms_diag_yaml_mod
integer, parameter :: basedate_size = 6
integer, parameter :: NUM_SUB_REGION_ARRAY = 8
-integer, parameter :: MAX_STR_LEN = 255
integer, parameter :: MAX_FREQ = 12
@@ -1056,7 +1055,7 @@ end function get_file_varlist
pure function get_file_global_meta (this) &
result (res)
class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
- character (:), allocatable :: res(:,:) !< What is returned
+ character (len=MAX_STR_LEN), allocatable :: res(:,:) !< What is returned
res = this%file_global_meta
end function get_file_global_meta
!> @brief Get the integer equivalent of the time to use to determine the filename,
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index e0727704d6..a9615d11e4 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -674,6 +674,9 @@ diag_files:
var_name: var7
reduction: none
kind: r4
+ global_meta:
+ - is_important: False
+ has_important: True
- file_name: file1
freq: 6
freq_units: hours
@@ -780,6 +783,8 @@ diag_files:
var_name: var1
reduction: none
kind: r4
+ attributes:
+ - GFDL_name: var_var
- file_name: file8%4yr%2mo%2dy%2hr%2min
freq: 1 1 1
freq_units: hours hours hours
From 84558cd1e2a7ad478b1a516d44bb1b9c8975ee38 Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Wed, 28 Jun 2023 14:16:10 -0400
Subject: [PATCH 107/168] feat: updates function
fms_diag_output_buffer_mod::remap_buffer (#1260)
---
diag_manager/fms_diag_output_buffer.F90 | 27 +++++++++++++++++-----
test_fms/diag_manager/test_diag_buffer.F90 | 12 +++++-----
2 files changed, 27 insertions(+), 12 deletions(-)
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index d6ade5621d..979c3a66cb 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -203,10 +203,11 @@ end subroutine set_buffer_id
!> Remaps 0-5d data buffer from the given object onto a 5d array pointer.
!> @returns a 5D remapped buffer, with 1:1 for any added dimensions.
-function remap_buffer(buffobj, field_name)
+function remap_buffer(buffobj, field_name, has_diurnal_axis)
class(fmsDiagOutputBuffer_class), target, intent(inout) :: buffobj !< any dimension buffer object
class(*), pointer :: remap_buffer(:,:,:,:,:)
character(len=*), intent(in) :: field_name !< name of field for error output
+ logical, intent(in) :: has_diurnal_axis !< true if the buffer has diurnal axis
! get num dimensions from type extension
select type (buffobj)
@@ -221,17 +222,31 @@ function remap_buffer(buffobj, field_name)
type is (outputBuffer2d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
- remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:1, 1:1, 1:1) => buffobj%buffer(:,:)
+ if (has_diurnal_axis) then
+ remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:size(buffobj%buffer,2)) => buffobj%buffer(:,:)
+ else
+ remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:1, 1:1, 1:1) => buffobj%buffer(:,:)
+ end if
type is (outputBuffer3d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
- remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), 1:1, 1:1) => &
- & buffobj%buffer(:,:,:)
+ if (has_diurnal_axis) then
+ remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:1, 1:1, &
+ 1:size(buffobj%buffer,3)) => buffobj%buffer(:,:,:)
+ else
+ remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), &
+ 1:size(buffobj%buffer,3), 1:1, 1:1) => buffobj%buffer(:,:,:)
+ end if
type is (outputBuffer4d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
- remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
- 1:size(buffobj%buffer,4), 1:1) => buffobj%buffer(:,:,:,:)
+ if (has_diurnal_axis) then
+ remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
+ 1:1, 1:size(buffobj%buffer,4)) => buffobj%buffer(:,:,:,:)
+ else
+ remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
+ 1:size(buffobj%buffer,4), 1:1) => buffobj%buffer(:,:,:,:)
+ end if
type is (outputBuffer5d_type)
if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
"for field:" // field_name)
diff --git a/test_fms/diag_manager/test_diag_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90
index cd127c6b7d..c9dc7374e0 100644
--- a/test_fms/diag_manager/test_diag_buffer.F90
+++ b/test_fms/diag_manager/test_diag_buffer.F90
@@ -49,7 +49,7 @@ program test_diag_buffer
r8val = p_val
end select
! get the 5d remapped buffer data
- remap_buffer_out => buffobj0(5)%remap_buffer(fname)
+ remap_buffer_out => buffobj0(5)%remap_buffer(fname, .false.)
! check output from object and remapped buffer
print *, r8val
call print_5d(remap_buffer_out)
@@ -75,7 +75,7 @@ program test_diag_buffer
arr1d = p_data1
end select
!! get the remapped buffer
- remap_buffer_out => buffobj1%remap_buffer(fname)
+ remap_buffer_out => buffobj1%remap_buffer(fname, .false.)
!! check output
print *, arr1d
call print_5d(remap_buffer_out)
@@ -94,7 +94,7 @@ program test_diag_buffer
!!! get the buffer
call buffobj2%get_buffer(arr2d, fname)
!!! get the remapped buffer
- remap_buffer_out => buffobj2%remap_buffer(fname)
+ remap_buffer_out => buffobj2%remap_buffer(fname, .false.)
!!! check output
select type(arr2d)
type is(integer(i4_kind))
@@ -115,7 +115,7 @@ program test_diag_buffer
!! get the buffer
call buffobj3%get_buffer(arr3d, fname)
!! get the remapped buffer
- remap_buffer_out => buffobj3%remap_buffer(fname)
+ remap_buffer_out => buffobj3%remap_buffer(fname, .false.)
!! check output
select type (arr3d)
type is(integer(i8_kind))
@@ -136,7 +136,7 @@ program test_diag_buffer
!! get the buffer
call buffobj4%get_buffer(arr4d, fname)
!! get the remapped buffer
- remap_buffer_out => buffobj4%remap_buffer(fname)
+ remap_buffer_out => buffobj4%remap_buffer(fname, .false.)
!! check output
select type (arr4d)
type is(integer(i8_kind))
@@ -150,7 +150,7 @@ program test_diag_buffer
!! init to given value
call buffobj5%initialize_buffer( int(5, kind=i8_kind), fname )
!! get the remapped buffer
- remap_buffer_out => buffobj5%remap_buffer(fname)
+ remap_buffer_out => buffobj5%remap_buffer(fname, .false.)
!! set some values in the buffer
allocate(i8arr5d(2,2,2,2,2))
i8arr5d = 10
From 4a7166bdedba76efe0a3746a9efc1abec5f1a90c Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Thu, 6 Jul 2023 07:03:19 -0400
Subject: [PATCH 108/168] chore: removed mpp_io_init from
test_diag_dlinked_list
---
test_fms/diag_manager/test_diag_dlinked_list.F90 | 2 --
1 file changed, 2 deletions(-)
diff --git a/test_fms/diag_manager/test_diag_dlinked_list.F90 b/test_fms/diag_manager/test_diag_dlinked_list.F90
index 355733b6bd..5fbd4a8356 100644
--- a/test_fms/diag_manager/test_diag_dlinked_list.F90
+++ b/test_fms/diag_manager/test_diag_dlinked_list.F90
@@ -34,7 +34,6 @@
!! 3rd Edition, by Mark Allen Weiss.
program test_diag_dlinked_list
use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated
- use mpp_io_mod, only: mpp_io_init
use fms_mod, ONLY: error_mesg, FATAL,NOTE
use fms_diag_object_mod, only : fmsDiagObject_type
use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t
@@ -63,7 +62,6 @@ program test_diag_dlinked_list
!!
call mpp_init(mpp_init_test_requests_allocated)
- call mpp_io_init()
call mpp_set_stack_size(145746)
call error_mesg("test_diag_linked_list", "Starting tests",NOTE)
From 28f699910f96ea791fb79168dee9e22901df6a34 Mon Sep 17 00:00:00 2001
From: Tom Robinson
Date: Thu, 6 Jul 2023 07:05:44 -0400
Subject: [PATCH 109/168] chore: Removes mpp_io from test_diag_object_container
---
test_fms/diag_manager/test_diag_object_container.F90 | 2 --
1 file changed, 2 deletions(-)
diff --git a/test_fms/diag_manager/test_diag_object_container.F90 b/test_fms/diag_manager/test_diag_object_container.F90
index e55b3fa30b..b46b50bcc7 100644
--- a/test_fms/diag_manager/test_diag_object_container.F90
+++ b/test_fms/diag_manager/test_diag_object_container.F90
@@ -25,7 +25,6 @@
!! is also being tested.
program test_diag_obj_container
use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated
- use mpp_io_mod, only: mpp_io_init
use fms_mod, ONLY: error_mesg, FATAL,NOTE
use fms_diag_object_mod, only : fmsDiagObject_type
@@ -56,7 +55,6 @@ program test_diag_obj_container
call mpp_init(mpp_init_test_requests_allocated)
- call mpp_io_init()
call mpp_set_stack_size(145746)
call error_mesg('test_diag_object_container', 'Test has started',NOTE)
From 9d058914d4ea64b266bbddb62184851428e070e1 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Wed, 12 Jul 2023 13:34:16 -0400
Subject: [PATCH 110/168] fix: modern diag incorrect type values and static
kind sizes (#1263)
---
diag_manager/fms_diag_output_buffer.F90 | 64 ++++++++++++-------------
1 file changed, 32 insertions(+), 32 deletions(-)
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 979c3a66cb..8ec8570ae6 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -310,15 +310,15 @@ subroutine allocate_buffer_0d(this, buff_type, field_name, diurnal_samples)
allocate(integer(kind=i4_kind) :: this%buffer(1))
allocate(integer(kind=i4_kind) :: this%counter(1))
allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i4_kind
+ this%count_0d = 0_i4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer(1))
allocate(integer(kind=i8_kind) :: this%counter(1))
allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i8_kind
+ this%count_0d = 0_i8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(1))
@@ -370,15 +370,15 @@ subroutine allocate_buffer_1d(this, buff_type, buff_size, field_name, diurnal_sa
allocate(integer(kind=i4_kind) :: this%buffer(buff_size))
allocate(integer(kind=i4_kind) :: this%counter(buff_size))
allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i4_kind
+ this%count_0d = 0_i4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer(buff_size))
allocate(integer(kind=i8_kind) :: this%counter(buff_size))
allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i8_kind
+ this%count_0d = 0_i8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(buff_size))
@@ -431,15 +431,15 @@ subroutine allocate_buffer_2d(this, buff_type, buff_sizes, field_name, diurnal_s
allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i4_kind
+ this%count_0d = 0_i4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i8_kind
+ this%count_0d = 0_i8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
@@ -454,7 +454,7 @@ subroutine allocate_buffer_2d(this, buff_type, buff_sizes, field_name, diurnal_s
allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
this%counter = 0.0_r8_kind
this%count_0d = 0.0_r8_kind
- this%buffer_type = r4
+ this%buffer_type = r8
class default
call mpp_error("allocate_buffer_1d", &
"The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
@@ -491,30 +491,30 @@ subroutine allocate_buffer_3d(this, buff_type, buff_sizes, field_name, diurnal_s
allocate(integer(kind=i4_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3)))
allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i4_kind
+ this%count_0d = 0_i4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3)))
allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i8_kind
+ this%count_0d = 0_i8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3)))
allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
- this%counter = 0
+ this%counter = 0.0_r4_kind
this%count_0d = 0.0_r4_kind
this%buffer_type = r4
type is (real(kind=r8_kind))
allocate(real(kind=r8_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
allocate(real(kind=r8_kind) :: this%counter( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
- this%buffer_type = r4
- this%counter = 0
+ this%counter = 0.0_r8_kind
this%count_0d = 0.0_r8_kind
+ this%buffer_type = r8
class default
call mpp_error("allocate_buffer_3d", &
"The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
@@ -554,28 +554,28 @@ subroutine allocate_buffer_4d(this, buff_type, buff_sizes, field_name, diurnal_s
allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i4_kind
+ this%count_0d = 0_i4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i8_kind
+ this%count_0d = 0_i8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
- this%counter = 0
+ this%counter = 0.0_r4_kind
this%count_0d = 0.0_r4_kind
this%buffer_type = r4
type is (real(kind=r8_kind))
allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
- this%counter = 0
+ this%counter = 0.0_r8_kind
this%count_0d = 0.0_r8_kind
this%buffer_type = r8
class default
@@ -619,8 +619,8 @@ subroutine allocate_buffer_5d(this, buff_type, buff_sizes, field_name, diurnal_s
allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i4_kind
+ this%count_0d = 0_i4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
@@ -628,8 +628,8 @@ subroutine allocate_buffer_5d(this, buff_type, buff_sizes, field_name, diurnal_s
allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0
- this%count_0d = 0
+ this%counter = 0_i8_kind
+ this%count_0d = 0_i8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
@@ -637,7 +637,7 @@ subroutine allocate_buffer_5d(this, buff_type, buff_sizes, field_name, diurnal_s
allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
- this%counter = 0
+ this%counter = 0.0_r4_kind
this%count_0d = 0.0_r4_kind
this%buffer_type = r4
type is (real(kind=r8_kind))
@@ -646,7 +646,7 @@ subroutine allocate_buffer_5d(this, buff_type, buff_sizes, field_name, diurnal_s
allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
- this%counter = 0
+ this%counter = 0.0_r8_kind
this%count_0d = 0.0_r8_kind
this%buffer_type = r8
class default
From 50624efec36739cadc0a24d7cbe98019e89a88b7 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 13 Jul 2023 08:10:03 -0400
Subject: [PATCH 111/168] feat: modern diag remove redundant fields in yaml
object (#1269)
---
diag_manager/README.md | 92 ++++-----
diag_manager/fms_diag_yaml.F90 | 195 +++++++-------------
test_fms/diag_manager/check_crashes.sh | 12 +-
test_fms/diag_manager/test_diag_manager2.sh | 78 +++-----
4 files changed, 139 insertions(+), 238 deletions(-)
diff --git a/diag_manager/README.md b/diag_manager/README.md
index 9d8b33983b..53abdab392 100644
--- a/diag_manager/README.md
+++ b/diag_manager/README.md
@@ -1,9 +1,9 @@
## Diag Table Yaml Format:
-The purpose of this documents is to explain the diag_table yaml format.
+The purpose of this document is to explain the diag_table yaml format.
## Contents
-- [1. Coverting from legacy ascii diag_table format](README.md#1-coverting-from-legacy-ascii-diag_table-format)
+- [1. Converting from legacy ascii diag_table format](README.md#1-converting-from-legacy-ascii-diag_table-format)
- [2. Diag table yaml sections](README.md#2-diag-table-yaml-sections)
- [2.1 Global Section](README.md#21-global-section)
- [2.2 File Section](README.md#22-file-section)
@@ -15,7 +15,7 @@ The purpose of this documents is to explain the diag_table yaml format.
- [2.6 Sub_region Section](README.md#26-sub_region-section)
- [3. More examples](README.md#3-more-examples)
-### 1. Coverting from legacy ascii diag_table format
+### 1. Converting from legacy ascii diag_table format
To convert the legacy ascii diad_table format to this yaml format, the python script [**diag_table_to_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/diag_table_to_yaml.py#L23-L26) can be used. To confirm that your diag_table.yaml was created correctly, the python script [**is_valid_diag_table_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/is_valid_diag_table_yaml.py#L24-L27) can be used.
@@ -41,10 +41,10 @@ diag_files:
### 2.1 Global Section
The diag_yaml requires “title” and the “baseDate”.
-- The **title** is a string that labels the diag yaml. The equivalent in the diag table would be the experiment. It is recommended that each diag_yaml have a separate title label that is descriptive of the experiment that is using it.
-- The **basedate** is an array of 6 integer indicating the base_date in the format [year month day hour minute second].
+- The **title** is a string that labels the diag yaml. The equivalent in the legacy diag_table would be the experiment. It is recommended that each diag_yaml have a separate title label that is descriptive of the experiment that is using it.
+- The **basedate** is an array of 6 integers indicating the base_date in the format [year month day hour minute second].
-**Example:**
+**Example:**
In the YAML format:
```yaml
@@ -59,27 +59,28 @@ ESM4_piControl
```
### 2.2 File Section
-The files are listed under the diagFiles section as a dashed array.
+The files are listed under the diagFiles section as a dashed array.
Below are the **required** keys needed to define each file.
-- **file_name** is a string that defines the name of the file. Do not add ".nc" and "tileX" to the filename as this will handle by FMS.
-- **freq** is an integer that defines the frequency that data will be written. The acceptable values are:
- - =-1: output at the end of the run only
- - =0: output every timestep
- - \>0: output frequency
-- **freq_units** is a string that defines the units of the frequency from above. The acceptable values are seconds, minutes, hours, days, months, years.
-- **time_units** is a string that defines units for time. The acceptable values are seconds, minutes, hours, days, months, years.
+- **file_name** is a string that defines the name of the file. Do not add ".nc" and "tileX" to the filename as this will be handled by FMS.
+- **freq** defines the frequency and the units that data will be written
+ - The acceptable values for freq are:
+ - =-1: output at the end of the run only
+ - =0: output every timestep
+ - \>0 units: output frequency and units (with a space between the frequency number and units e.g 24 hours)
+ - Values of -1 or 0 do not require units.
+ - The acceptable values for units are seconds, minutes, hours, days, months, years.
+- **time_units** is a string that defines units for time. The acceptable values are seconds, minutes, hours, days, months, years.
- **unlimdim** is a string that defines the name of the unlimited dimension in the output netcdf file, usually “time”.
- **varlist** is a subsection that list all of the variable in the file
-**Example:** The following creates a file with data written every 6 hours.
+**Example:** The following creates a file with data written every 6 hours.
In the YAML format:
```yaml
diag_files:
- file_name: atmos_6hours
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
varlist:
@@ -93,10 +94,9 @@ In the legacy ascii format:
**NOTE:** The fourth column (file_format) has been deprecated. Netcdf files will always be written.
-Below are some *optional* keys that may be added.
+Below are some *optional* keys that may be added.
- **write_file** is a logical that indicates if you want the file to be created (default is true). This is a new feature that is not supported by the legacy ascii data_table.
-- **new_file_freq** is a integer that defines the frequency for closing the existing file
-- **new_file_freq_units** is a string that defines the time units for creating a new file. Required if “new_file_freq” used. The acceptable values are seconds, minuts, hours, days, months, years.
+- **new_file_freq** is a string that defines the frequency and the frequency units (with a space between the frequency number and units) for closing the existing file
- **start_time** is an array of 6 integer indicating when to start the file for the first time. It is in the format [year month day hour minute second]. Requires “new_file_freq”
- **filename_time** is the time used to set the name of new files when using new_file_freq. The acceptable values are begin (which will use the begining of the file's time bounds), middle (which will use the middle of the file's time bounds), and end (which will use the end of the file's time bounds). The default is middle
@@ -105,12 +105,10 @@ Below are some *optional* keys that may be added.
In the YAML format:
```yaml
- file_name: ocn%4yr%2mo%2dy%2hr
- freq: 6
+ freq: 6 hours
freq_units: hours
- time_units: hours
unlimdim: time
- new_file_freq: 6
- new_file_freq_units: hours
+ new_file_freq: 6 hours
start_time: 2020 1 1 0 0 0
```
@@ -127,29 +125,25 @@ ocn_2020_01_01_15.nc for time_bnds [12,18]
ocn_2020_01_01_21.nc for time_bnds [18,24]
```
-**NOTE** If using the new_file_freq, there must be a way to distinguish each file, as it was done in the example above.
+**NOTE** If using the new_file_freq, there must be a way to distinguish each file, as it was done in the example above.
-- **file_duration** is an integer that defines how long the file should receive data after start time in “file_duration_units”. This optional field can only be used if the start_time field is present. If this field is absent, then the file duration will be equal to the frequency for creating new files. The file_duration_units field must also be present if this field is present.
-- **file_duration_units** is a string that defines the file duration units. The acceptable values are seconds, minutes, hours, days, months, years.
+- **file_duration** is a string that defines how long the file should receive data after start time in “file_duration_units”. This optional field can only be used if the start_time field is present. If this field is absent, then the file duration will be equal to the frequency for creating new files.
- **global_meta** is a subsection that lists any additional global metadata to add to the file. This is a new feature that is not supported by the legacy ascii data_table.
- **sub_region** is a subsection that defines the four corners of a subregional section to capture.
### 2.2.1 Flexible output timings
-In order to provide more flexibility in output timings, the new diag_table yaml format allows for different file frequencies for the same file by allowing the `freq`, `freq_units`, `new_file_freq`, `new_file_freq_units`, `file_duration`, `file_duration_units` keys to accept array of integers/strings.
+In order to provide more flexibility in output timings, the diag_table yaml format allows for different file frequencies for the same file by allowing the `freq`, `new_file_freq`, and `file_duration` keys to accept a comma seperated list.
-For example,
+For example,
``` yaml
- file_name: flexible_timing%4yr%2mo%2dy%2hr
- freq: 1 1 1
- freq_units: hours hours hours
+ freq: 1 hours, 1 hours, 1 hours
time_units: hours
unlimdim: time
- new_file_freq: 6 3 1
- new_file_freq_units: hours hours hours
+ new_file_freq: 6 hours, 3 hours, 1 hours
start_time: 2 1 1 0 0 0
- file_duration: 12 3 9
- file_duration_units: hours hours hours
+ file_duration: 12 hours, 3 hours, 9 hours
filename_time: begin
varlist:
- module: ocn_mod
@@ -195,7 +189,7 @@ In the *yaml diag_table*:
The variables in each file are listed under the varlist section as a dashed array.
- **var_name:** is a string that defines the variable name as it is defined in the register_diag_field call in the model
-- **reduction:** is a string that describes the data reduction method to perform prior to writing data to disk. Acceptable values are average, diurnalXX (where XX is the number of diurnal samples), powXX (whre XX is the power level), min, max, none, rms, and sum.
+- **reduction:** is a string that describes the data reduction method to perform prior to writing data to disk. Acceptable values are average, diurnalXX (where XX is the number of diurnal samples), powXX (whre XX is the power level), min, max, none, rms, and sum.
- **module:** is a string that defines the module where the variable is registered in the model code
- **kind:** is a string that defines the type of variable as it will be written out in the file. Acceptable values are r4, r8, i4, and i8
@@ -214,7 +208,7 @@ In the legacy ascii format:
```
"moist", "precip", "precip", "atmos_8xdaily", "all", .true., "none", 2
```
-**NOTE:** The fifth column (time_sampling) has be deprecated. The reduction_method (`.true.`) has been replaced with `average`. The output name was not included in the yaml because it is the same as the var_name.
+**NOTE:** The fifth column (time_sampling) has been deprecated. The reduction_method (`.true.`) has been replaced with `average`. The output name was not included in the yaml because it is the same as the var_name.
which corresponds to the following model code
```F90
@@ -226,15 +220,15 @@ where:
- `axes` are the ids of the axes the variable is a function of
- `Time` is the model time
-Below are some *optional* keys that may be added.
+Below are some *optional* keys that may be added.
- **write_var:** is a logical that is set to false if the user doesn’t want the variable to be written to the file (default: true).
- **out_name:** is a string that defines the name of the variable that will be written to the file (default same as var_name)
- **long_name:** is a string defining the long_name attribute of the variable. It overwrites the long_name in the variable's register_diag_field call
- **attributes:** is a subsection with any additional metadata to add to the variable in the netcdf file. This is a new feature that is not supported by the legacy ascii data_table.
-- **zbounds:** is a 2 member array of integers that define the bounds of the z axis (zmin, zmin), optional default is no limits.
+- **zbounds:** is a 2 member array of integers that define the bounds of the z axis (zmin, zmin), optional default is no limits.
### 2.4 Variable Metadata Section
-Any aditional variable attributes can be added for each varible can be listed under the attributes section as a dashed array. The key is attribute name and the value is the attribute value.
+Any aditional variable attributes can be added for each variable can be listed under the attributes section as a dashed array. The key is attribute name and the value is the attribute value.
**Example:**
@@ -286,15 +280,12 @@ title: test_diag_manager
base_date: 2 1 1 0 0 0
diag_files:
- file_name: wild_card_name%4yr%2mo%2dy%2hr
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
- new_file_freq: 6
- new_file_freq_units: hours
+ new_file_freq: 6 hours
start_time: 2 1 1 0 0 0
- file_duration: 12
- file_duration_units: hours
+ file_duration: 12 hours
varlist:
- module: test_diag_manager_mod
var_name: sst
@@ -303,8 +294,7 @@ diag_files:
global_meta:
- is_a_file: true
- file_name: normal
- freq: 24
- freq_units: days
+ freq: 24 days
time_units: hours
unlimdim: records
varlist:
@@ -322,8 +312,7 @@ diag_files:
corner3: -60, 0
corner4: -60, 75
- file_name: normal2
- freq: -1
- freq_units: days
+ freq: -1 days
time_units: hours
unlimdim: records
write_file: true
@@ -346,8 +335,7 @@ diag_files:
corner3: 10, 25
corner4: 20, 25
- file_name: normal3
- freq: -1
- freq_units: days
+ freq: -1 days
time_units: hours
unlimdim: records
write_file: false
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index a22dba5265..85be393ea6 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -503,35 +503,31 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
integer, allocatable :: key_ids(:) !< Id of the gloabl atttributes key/value pairs
character(len=:), ALLOCATABLE :: grid_type !< grid_type as it is read in from the yaml
- character(len=:), ALLOCATABLE :: freq_buffer !< buffer to store any freq as it is read from the yaml
character(len=:), ALLOCATABLE :: buffer !< buffer to store any *_units as it is read from the yaml
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", buffer)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq", freq_buffer)
- call set_file_freq(fileobj, freq_buffer, buffer)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq", buffer)
+ call parse_key(fileobj%file_fname, buffer, fileobj%file_freq, fileobj%file_frequnit, "freq")
+ deallocate(buffer)
- deallocate(freq_buffer, buffer)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", fileobj%file_unlimdim)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", buffer)
call set_file_time_units(fileobj, buffer)
-
deallocate(buffer)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", freq_buffer, is_optional=.true.)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq_units", buffer, &
- is_optional=.true.)
- call set_new_file_freq(fileobj, freq_buffer, buffer)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", buffer, is_optional=.true.)
+ call parse_key(fileobj%file_fname, buffer, fileobj%file_new_file_freq, fileobj%file_new_file_freq_units, &
+ "new_file_freq")
deallocate(buffer)
+
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "filename_time", buffer, is_optional=.true.)
call set_filename_time(fileobj, buffer)
+ deallocate(buffer)
- deallocate(freq_buffer, buffer)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", fileobj%file_start_time, is_optional=.true.)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", freq_buffer, is_optional=.true.)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration_units", buffer, &
- is_optional=.true.)
- call set_file_duration(fileobj, freq_buffer, buffer)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", buffer, is_optional=.true.)
+ call parse_key(fileobj%file_fname, buffer, fileobj%file_duration, fileobj%file_duration_units, &
+ "file_duration")
nsubregion = 0
nsubregion = get_num_blocks(diag_yaml_id, "sub_region", parent_block_id=diag_file_id)
@@ -695,34 +691,66 @@ function get_total_num_vars(diag_yaml_id, diag_file_id) &
end do
end function
-!> @brief This checks if the file frequency and file frequency units in a diag file are valid and
-!! sets the integer equivalent
-subroutine set_file_freq(fileobj, file_freq, file_frequnit)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
- character(len=*), intent(in) :: file_freq !< File_freq as it is read from the diag_table
- character(len=*), intent(in) :: file_frequnit !< File_freq_units as it is read from the diag_table
-
- integer :: i !< For do loops
- character(len=10) :: file_freq_units(MAX_FREQ) !< Array of file frequencies as a string
- integer :: err_unit !< Dummy error unit
-
- file_freq_units = ""
- read(file_freq, *, iostat=err_unit) fileobj%file_freq
- read(file_frequnit, *, iostat=err_unit) file_freq_units
-
- do i = 1, MAX_FREQ
- if (fileobj%file_freq(i) >= -1) then
- if (trim(file_freq_units(i)) .eq. "") &
- call mpp_error(FATAL, "file_freq_units is required. &
- &Check your entry for file:"//trim(fileobj%file_fname))
-
- fileobj%file_frequnit(i) = set_valid_time_units(file_freq_units(i), &
- "file_freq_units for file:"//trim(fileobj%file_fname))
+!> @brief This parses the freq, new_file_freq, or file_duration keys which are read in as a comma list
+subroutine parse_key(filename, buffer, file_freq, file_frequnit, var)
+ character(len=*), intent(in) :: filename !< The name of the file (for error messages)
+ character(len=*), intent(inout) :: buffer !< Buffer that was read in from the yaml
+ integer, intent(out) :: file_freq(:) !< buffer to store the freq, new_file_freq, or
+ !! file_duration after it is parsed
+ integer, intent(out) :: file_frequnit(:) !< buffer to store the freq units, new_file_freq units,
+ !! or file_duration units after it is parsed
+ character(len=*), intent(in) :: var !< Name of the key parsing
+
+ integer :: j !< location of the ",' in the buffer
+ integer :: k !< location of the " " that seperated the units
+ logical :: finished !< .true. if the parsing is complete
+ integer :: count !< Number of keys that have been parsed
+ character(len=255) :: str !< Member of the comma seperated list
+ character(len=10) :: units !< String to hold the units
+ integer :: err_unit !< Error key
+
+ if (buffer .eq. "") return
+
+ finished = .false.
+ j = 0
+ count = 0
+ do while (.not. finished)
+ count = count + 1
+ buffer = buffer(j+1:len_trim(buffer))
+ j = index(buffer, ",")
+ if (j == 0) then
+ !< There is only 1 member in the list
+ j = len_trim(buffer)+1
+ finished = .true.
+ endif
+
+ str = adjustl(buffer(1:j-1))
+
+ k = index(str, " ")
+ read(str(1:k-1), *, iostat=err_unit) file_freq(count)
+ units = str(k+1:len_trim(str))
+
+ if (err_unit .ne. 0) &
+ call mpp_error(FATAL, "Error parsing "//trim(var)//". Check your entry for file"//&
+ trim(filename))
+
+ if (file_freq(count) .lt. -1) &
+ call mpp_error(FATAL, trim(var)//" is not valid. &
+ &Check your entry for file:"//trim(filename))
+
+ if (file_freq(count) .eq. -1 .or. file_freq(count) .eq. 0) then
+ !! The file is static so no need to read the units
+ file_frequnit(count) = DIAG_DAYS
else
- return
+ if (trim(units) .eq. "") &
+ call mpp_error(FATAL, trim(var)//" units is required. &
+ &Check your entry for file:"//trim(filename))
+
+ file_frequnit(count) = set_valid_time_units(units, &
+ trim(var)//" for file:"//trim(filename))
endif
enddo
-end subroutine set_file_freq
+end subroutine parse_key
!> @brief This checks if the time unit in a diag file is valid and sets the integer equivalent
subroutine set_file_time_units (fileobj, file_timeunit)
@@ -732,36 +760,6 @@ subroutine set_file_time_units (fileobj, file_timeunit)
fileobj%file_timeunit = set_valid_time_units(file_timeunit, "timeunit for file:"//trim(fileobj%file_fname))
end subroutine set_file_time_units
-!> @brief This checks if the new file frequency and the new file frequency units in a diag file are valid
-!! and sets the integer equivalent
-subroutine set_new_file_freq(fileobj, new_file_freq, new_file_freq_units)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
- character(len=*), intent(in) :: new_file_freq !< new file freq units as it is read from
- !! the diag_table
- character(len=*), intent(in) :: new_file_freq_units !< new file freq units as it is read from
- !! the diag_table
- integer :: i !< For do loops
- character(len=10) :: file_new_file_freq_units(MAX_FREQ) !< Array of new file frequencies as string
- integer :: err_unit !< Dummy error unit
-
- file_new_file_freq_units = ""
- read(new_file_freq, *, iostat=err_unit) fileobj%file_new_file_freq
- read(new_file_freq_units, *, iostat=err_unit) file_new_file_freq_units
-
- do i = 1, MAX_FREQ
- if (fileobj%file_new_file_freq(i) > 0) then
- if (trim(file_new_file_freq_units(i)) .eq. "") &
- call mpp_error(FATAL, "new_file_freq_units is required if using new_file_freq. &
- &Check your entry for file:"//trim(fileobj%file_fname))
-
- fileobj%file_new_file_freq_units(i) = set_valid_time_units(file_new_file_freq_units(i), &
- "new_file_freq_units for file:"//trim(fileobj%file_fname))
- else
- return
- endif
- enddo
-end subroutine set_new_file_freq
-
!> @brief This checks if the filename_time in a diag file is correct and sets the integer equivalent
subroutine set_filename_time(fileobj, filename_time)
type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
@@ -783,63 +781,6 @@ subroutine set_filename_time(fileobj, filename_time)
end select
end subroutine set_filename_time
-!> @brief This checks if the file duration and the file duration units in a diag file are valid
-!! and sets the integer equivalent
-subroutine set_file_duration(fileobj, file_duration, file_duration_units)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
- character(len=*), intent(in) :: file_duration !< file_duration as it is read from the yaml
- character(len=*), intent(in) :: file_duration_units !< file_duration units as it is read from the yaml
-
- integer :: i !< For do loops
- character(len=10) :: file_duration_units_array(MAX_FREQ) !< Array of file_duration_units as string
- integer :: err_unit !< Dummy error unit
- logical :: mask(MAX_FREQ) !< Array of logical
- integer :: nfile_duration !< Number of file durations defined
- integer :: nfile_freq !< Number of file frequencies defined
- integer :: nnew_file_freq !< Number of new file frequencies defined
-
- file_duration_units_array = ""
- read(file_duration, *, iostat=err_unit) fileobj%file_duration
- read(file_duration_units, *, iostat=err_unit) file_duration_units_array
-
- nfile_duration = 0
- do i = 1, MAX_FREQ
- if (fileobj%file_duration(i) > 0) then
- if(trim(file_duration_units_array(i)) .eq. "") &
- call mpp_error(FATAL, "file_duration_units is required if using file_duration. &
- &Check your entry for file:"//trim(fileobj%file_fname))
-
- fileobj%file_duration_units(i) = set_valid_time_units(file_duration_units_array(i), &
- "file_duration_units for file:"//trim(fileobj%file_fname))
- nfile_duration = nfile_duration + 1
- else
- exit
- endif
- enddo
-
- !< Make sure the user send in the correct number of freq, new_file_freq, and file_duration
- mask = .FALSE.
- mask = fileobj%file_freq .ne. DIAG_NULL
- nfile_freq = count(mask)
-
- mask = .FALSE.
- mask = fileobj%file_new_file_freq .ne. DIAG_NULL
- nnew_file_freq = count(mask)
-
- if (nfile_freq .ne. nfile_duration .and. nfile_freq-1 .ne. nfile_duration) &
- call mpp_error(FATAL, "freq and file_duration do not have consistent size. &
- &Check your entry for file:"//trim(fileobj%file_fname))
-
- if (nfile_freq .ne. nnew_file_freq .and. nfile_freq-1 .ne. nnew_file_freq) &
- call mpp_error(FATAL, "freq and new_file_freq do not have consistent size. &
- &Check your entry for file:"//trim(fileobj%file_fname))
-
- if (nnew_file_freq .ne. nfile_duration .and. nnew_file_freq-1 .ne. nfile_duration) &
- call mpp_error(FATAL, "new_file_freq and file_duration do not have consistent size. &
- &Check your entry for file:"//trim(fileobj%file_fname))
-
-end subroutine set_file_duration
-
!> @brief This checks if the kind of a diag field is valid and sets it
subroutine set_field_kind(field, skind)
type(diagYamlFilesVar_type), intent(inout) :: field !< diagYamlFilesVar_type obj to read the contents into
diff --git a/test_fms/diag_manager/check_crashes.sh b/test_fms/diag_manager/check_crashes.sh
index 537e5824d6..c6634f7926 100755
--- a/test_fms/diag_manager/check_crashes.sh
+++ b/test_fms/diag_manager/check_crashes.sh
@@ -31,32 +31,32 @@ test_expect_failure "Missing tile when using the 'index' grid type" '
mpirun -n 1 ../test_diag_yaml
'
-sed '/new_file_freq_units/d' diag_table.yaml_base > diag_table.yaml
+sed '/new_file_freq: 6 hours/new_file_freq: 6/g' diag_table.yaml_base > diag_table.yaml
test_expect_failure "Missing new_file_freq_units when using new_file_freq_units" '
mpirun -n 1 ../test_diag_yaml
'
-sed 's/new_file_freq_units: hours/new_file_freq_units: mullions/g' diag_table.yaml_base > diag_table.yaml
+sed 's/new_file_freq: 6 hours/new_file_freq: 6 mullions/g' diag_table.yaml_base > diag_table.yaml
test_expect_failure "new_file_freq_units is not valid" '
mpirun -n 1 ../test_diag_yaml
'
-sed '/file_duration_units/d' diag_table.yaml_base > diag_table.yaml
+sed '/file_duration: 12 hours/file_duration: 12/g' diag_table.yaml_base > diag_table.yaml
test_expect_failure "Missing file_duration_units when using file_duration" '
mpirun -n 1 ../test_diag_yaml
'
-sed 's/file_duration_units: hours/file_duration_units: mullions/g' diag_table.yaml_base > diag_table.yaml
+sed 's/file_duration: 12 hours/file_duration: 12 mullions/g' diag_table.yaml_base > diag_table.yaml
test_expect_failure "file_duration_units is not valid" '
mpirun -n 1 ../test_diag_yaml
'
-sed 's/freq_units: hours/freq_units: mullions/g' diag_table.yaml_base > diag_table.yaml
+sed 's/freq: 6 hours/freq: 6 mullions/g' diag_table.yaml_base > diag_table.yaml
test_expect_failure "freq units is not valid" '
mpirun -n 1 ../test_diag_yaml
'
-sed 's/freq: 6/freq: 6 6/g' diag_table.yaml_base > diag_table.yaml
+sed 's/freq: 6 hours/freq: -6 hours/g' diag_table.yaml_base > diag_table.yaml
test_expect_failure "freq is less than -1" '
mpirun -n 1 ../test_diag_yaml
'
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index a9615d11e4..754d782476 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -526,15 +526,12 @@ base_date: 2 1 1 0 0 0
diag_files:
- file_name: wild_card_name%4yr%2mo%2dy%2hr
filename_time: end
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
- new_file_freq: 6
- new_file_freq_units: hours
+ new_file_freq: 6 hours
start_time: 2 1 1 0 0 0
- file_duration: 12
- file_duration_units: hours
+ file_duration: 12 hours
varlist:
- module: test_diag_manager_mod
var_name: sst
@@ -544,8 +541,7 @@ diag_files:
global_meta:
- is_a_file: true
- file_name: normal
- freq: 24
- freq_units: days
+ freq: 24 days
time_units: hours
unlimdim: records
varlist:
@@ -565,7 +561,6 @@ diag_files:
corner4: -60, 75
- file_name: normal2
freq: -1
- freq_units: days
time_units: hours
unlimdim: records
write_file: true
@@ -592,7 +587,6 @@ diag_files:
corner4: 20, 25
- file_name: normal3
freq: -1
- freq_units: days
time_units: hours
unlimdim: records
write_file: false
@@ -612,8 +606,7 @@ title: test_diag_manager
base_date: 2 1 1 0 0 0
diag_files:
- file_name: file1
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
varlist:
@@ -623,8 +616,7 @@ diag_files:
reduction: average
kind: r4
- file_name: file2
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
is_ocean: True
@@ -635,8 +627,7 @@ diag_files:
reduction: average
kind: r4
- file_name: file3
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
varlist:
@@ -666,7 +657,6 @@ base_date: 2 1 1 0 0 0
diag_files:
- file_name: static_file
freq: -1
- freq_units: hours
time_units: hours
unlimdim: time
varlist:
@@ -678,8 +668,7 @@ diag_files:
- is_important: False
has_important: True
- file_name: file1
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
varlist:
@@ -693,8 +682,7 @@ diag_files:
reduction: average
kind: r4
- file_name: file2
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
varlist:
@@ -718,8 +706,7 @@ diag_files:
kind: r8
zbounds: 2.0 3.0
- file_name: file3
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
varlist:
@@ -732,8 +719,7 @@ diag_files:
reduction: average
kind: r4
- file_name: file4
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
varlist:
@@ -742,8 +728,7 @@ diag_files:
reduction: average
kind: r4
- file_name: file5
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
varlist:
@@ -759,23 +744,19 @@ diag_files:
corner3: 10, 25
corner4: 20, 25
- file_name: file6%4yr%2mo%2dy%2hr
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
- new_file_freq: 6
- new_file_freq_units: hours
+ new_file_freq: 6 hours
start_time: 2 1 1 0 0 0
- file_duration: 12
- file_duration_units: hours
+ file_duration: 12 hours
varlist:
- module: ocn_mod
var_name: var1
reduction: average
kind: r4
- file_name: file7
- freq: 6
- freq_units: hours
+ freq: 6 hours
time_units: hours
unlimdim: time
varlist:
@@ -786,15 +767,12 @@ diag_files:
attributes:
- GFDL_name: var_var
- file_name: file8%4yr%2mo%2dy%2hr%2min
- freq: 1 1 1
- freq_units: hours hours hours
+ freq: 1 hours,1 hours,1 hours
time_units: hours
unlimdim: time
- new_file_freq: 6 3 1
- new_file_freq_units: hours hours hours
+ new_file_freq: 6 hours, 3 hours, 1 hours
start_time: 2 1 1 0 0 0
- file_duration: 12 3 9
- file_duration_units: hours hours hours
+ file_duration: 12 hours, 3 hours, 9 hours
varlist:
- module: ocn_mod
var_name: var1
@@ -802,23 +780,19 @@ diag_files:
kind: r4
- file_name: file9%4yr%2mo%2dy%2hr%2min
filename_time: begin
- freq: 1 1 1
- freq_units: hours hours hours
+ freq: 1 hours,1 hours,1 hours
time_units: hours
unlimdim: time
- new_file_freq: 6 3 1
- new_file_freq_units: hours hours hours
+ new_file_freq: 6 hours, 3 hours, 1 hours
start_time: 2 1 1 0 0 0
- file_duration: 12 3 9
- file_duration_units: hours hours hours
+ file_duration: 12 hours, 3 hours, 9 hours
varlist:
- module: ocn_mod
var_name: var1
reduction: average
kind: r4
- file_name: file10_diurnal
- freq: 1
- freq_units: days
+ freq: 1 days
time_units: hours
unlimdim: time
varlist:
@@ -845,8 +819,7 @@ base_date: 2 1 1 0 0 0
diag_files:
- file_name: file1_clock
- freq: 1
- freq_units: days
+ freq: 1 days
time_units: hours
unlimdim: time
varlist:
@@ -868,8 +841,7 @@ base_date: 2 1 1 0 0 0
diag_files:
- file_name: file1_forecast
- freq: 1
- freq_units: days
+ freq: 1 days
time_units: hours
unlimdim: time
varlist:
From 116fd0850075b1079fd16a64a7797fa61489eebd Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 13 Jul 2023 08:11:36 -0400
Subject: [PATCH 112/168] feat: modern diag add axis ids to the buffer object
(#1278)
---
diag_manager/Makefile.am | 2 +-
diag_manager/fms_diag_file_object.F90 | 23 ++++++++++++++-----
diag_manager/fms_diag_object.F90 | 21 ++++++++++++-----
diag_manager/fms_diag_output_buffer.F90 | 30 +++++++++++++++++++++++++
4 files changed, 63 insertions(+), 13 deletions(-)
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index cf73c87f17..8554ba144a 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -77,7 +77,7 @@ fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_objec
fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_axis_object_mod.$(FC_MODEXT)
fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
- fms_diag_axis_object_mod.$(FC_MODEXT)
+ fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
diag_grid_mod.$(FC_MODEXT)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 4dd4228b99..62f01f7fe0 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -45,6 +45,7 @@ module fms_diag_file_object_mod
fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, &
fmsDiagDiurnalAxis_type, create_new_z_subaxis
use fms_diag_field_object_mod, only: fmsDiagField_type
+use fms_diag_output_buffer_mod, only: fmsDiagOutputBufferContainer_type
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, &
uppercase, lowercase
@@ -688,12 +689,16 @@ subroutine set_file_domain(this, domain, type_of_domain)
end subroutine set_file_domain
!> @brief Loops through a variable's axis_ids and adds them to the FMSDiagFile object if they don't exist
-subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id)
- class(fmsDiagFile_type), intent(inout) :: this !< The file object
- integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
- class(fmsDiagAxisContainer_type), intent(inout) :: diag_axis(:) !< Diag_axis object
- integer, intent(inout) :: naxis !< Number of axis that have been registered
- integer, intent(in) :: yaml_id !< Yaml id of the yaml section for this var
+subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id, buffer_id, output_buffers)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
+ class(fmsDiagAxisContainer_type), intent(inout) :: diag_axis(:) !< Diag_axis object
+ integer, intent(inout) :: naxis !< Number of axis that have been
+ !! registered
+ integer, intent(in) :: yaml_id !< Yaml id of the field section for
+ !! this var
+ integer, intent(in) :: buffer_id !< ID of the buffer
+ type(fmsDiagOutputBufferContainer_type), intent(inout) :: output_buffers(:) !< Array of output buffers
type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry
@@ -732,6 +737,9 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id)
do i = 1, size(var_axis_ids)
this%number_of_axis = this%number_of_axis + 1 !< This is the current number of axis in the file
this%axis_ids(this%number_of_axis) = diag_axis(var_axis_ids(i))%axis%get_subaxes_id()
+
+ !< Change the variable axis ids to the subaxis that was just created
+ var_axis_ids(i) = this%axis_ids(this%number_of_axis)
enddo
else
this%axis_ids = diag_null
@@ -756,6 +764,9 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id)
endif
enddo
end select
+
+ !> Add the axis to the buffer object
+ call output_buffers(buffer_id)%add_axis_ids(var_axis_ids)
end subroutine add_axes
!> @brief adds the start time to the fileobj
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 865466ccca..8bbe5b2266 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -245,7 +245,8 @@ integer function fms_register_diag_field_obj &
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
- call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i))
+ call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i), &
+ fieldptr%buffer_ids(i), this%FMS_diag_output_buffers)
call fileptr%add_start_time(init_time, this%current_model_time)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
@@ -255,7 +256,8 @@ integer function fms_register_diag_field_obj &
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
- call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i))
+ call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i), &
+ fieldptr%buffer_ids(i), this%FMS_diag_output_buffers)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
elseif (present(init_time)) then !only inti time present
@@ -976,10 +978,11 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
integer :: i, j !< For looping
class(fmsDiagOutputBuffer_class), pointer :: ptr_diag_buffer_obj !< Pointer to the buffer class
class(DiagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields
- integer, pointer :: axis_ids(:) !< Pointer to indices of axes of the field variable
+ integer, allocatable :: axis_ids(:) !< Pointer to indices of axes of the field variable
integer :: var_type !< Stores type of the field data (r4, r8, i4, i8, and string) represented as an integer.
real :: missing_value !< Fill value to initialize output buffers
character(len=128), allocatable :: var_name !< Field name to initialize output buffers
+ logical :: is_scalar !< Flag indicating that the variable is a scalar
! Determine the type of the field data
var_type = get_var_type(field_data(1, 1, 1, 1))
@@ -1009,15 +1012,21 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
endif
! Determine dimensions of the field
- ndims = 0
+ is_scalar = .True.
if (this%FMS_diag_fields(field_id)%has_axis_ids()) then
- axis_ids => this%FMS_diag_fields(field_id)%get_axis_id() !< Get ids of axes of the variable
- ndims = size(axis_ids) !< Dimensions of the field
+ is_scalar = .False.
endif
! Loop over a number of fields/buffers where this variable occurs
do i = 1, size(this%FMS_diag_fields(field_id)%buffer_ids)
buffer_id = this%FMS_diag_fields(field_id)%buffer_ids(i)
+
+ ndims = 0
+ if (.not. is_scalar) then
+ axis_ids = this%FMS_diag_output_buffers(buffer_id)%get_axis_ids()
+ ndims = size(axis_ids)
+ endif
+
ptr_diag_field_yaml => diag_yaml%get_diag_field_from_id(buffer_id)
num_diurnal_samples = ptr_diag_field_yaml%get_n_diurnal() !< Get number of diurnal samples
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 8ec8570ae6..5b3d267dfd 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -61,6 +61,11 @@ module fms_diag_output_buffer_mod
!> holds an allocated buffer0-5d object
type :: fmsDiagOutputBufferContainer_type
class(fmsDiagOutputBuffer_class), allocatable :: diag_buffer_obj !< any 0-5d buffer object
+ integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
+
+ contains
+ procedure :: add_axis_ids
+ procedure :: get_axis_ids
end type
!> Scalar buffer type to extend fmsDiagBufferContainer_type
@@ -1425,5 +1430,30 @@ subroutine add_to_buffer_5d(this, input_data, field_name)
if( type_error ) call mpp_error (FATAL,'add_to_buffer_5d: mismatch between allocated buffer and input data types'//&
'for field:'// field_name)
end subroutine add_to_buffer_5d
+
+!> @brief Adds the axis ids to the buffer object
+subroutine add_axis_ids(this, axis_ids)
+ class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object
+ integer, intent(in) :: axis_ids(:) !< Axis ids to add
+
+ this%axis_ids = axis_ids
+end subroutine
+
+!> @brief Get the axis_ids for the buffer
+!! @return Axis_ids, if the buffer doesn't have axis ids it returns diag_null
+function get_axis_ids(this) &
+ result(res)
+
+ class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object
+ integer, allocatable :: res(:)
+
+ if (allocated(this%axis_ids)) then
+ res = this%axis_ids
+ else
+ allocate(res(1))
+ res = diag_null
+ endif
+end function
+
#endif
end module fms_diag_output_buffer_mod
From 417a14613f08fc5cc273d3bf929d30382cf4aabe Mon Sep 17 00:00:00 2001
From: ganganoaa <121043264+ganganoaa@users.noreply.github.com>
Date: Fri, 14 Jul 2023 11:09:14 -0400
Subject: [PATCH 113/168] feat: modern diag adds function recondition_indices
to diag_util_mod (#1207)
---
diag_manager/fms_diag_bbox.F90 | 159 ++++++++++++++++++++++++++++++++-
1 file changed, 158 insertions(+), 1 deletion(-)
diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90
index 7fa331258a..956dabd31c 100644
--- a/diag_manager/fms_diag_bbox.F90
+++ b/diag_manager/fms_diag_bbox.F90
@@ -30,7 +30,7 @@
!> @{
MODULE fms_diag_bbox_mod
- USE fms_mod, ONLY: error_mesg, FATAL
+ USE fms_mod, ONLY: error_mesg, FATAL, fms_error_handler
implicit none
@@ -59,6 +59,30 @@ MODULE fms_diag_bbox_mod
procedure :: get_kmax
END TYPE fmsDiagIbounds_type
+ !> @brief Data structure holding starting and ending indices in the I, J, and
+ !! K dimensions. It also has extra members related to halo sizes and updated indices
+ !! in I and J dimensions.
+ type, public :: fmsDiagBoundsHalos_type
+ private
+ type(fmsDiagIbounds_type) :: bounds3D !< Holds starting and ending indices of
+ !! the I, J, and K dimensions
+ integer :: hi !< Halo size in the I dimension
+ integer :: hj !< Halo size in the J dimension
+ integer :: fis !< Updated starting index in the I dimension
+ integer :: fie !< Updated ending index in the I dimension
+ integer :: fjs !< Updated starting index in the J dimension
+ integer :: fje !< Updated ending index in the J dimension
+ contains
+ procedure :: get_hi
+ procedure :: get_hj
+ procedure :: get_fis
+ procedure :: get_fie
+ procedure :: get_fjs
+ procedure :: get_fje
+ end type fmsDiagBoundsHalos_type
+
+ public :: recondition_indices
+
CONTAINS
!> @brief Gets imin of fmsDiagIbounds_type
@@ -104,6 +128,48 @@ pure integer function get_kmax (this) result(rslt)
rslt = this%kmax
end function get_kmax
+ !> @brief Gets the halo size of fmsDiagBoundsHalos_type in the I dimension
+ !! @return copy of integer member hi
+ pure integer function get_hi (this) result(rslt)
+ class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object
+ rslt = this%hi
+ end function get_hi
+
+ !> @brief Gets the halo size of fmsDiagBoundsHalos_type in the J dimension
+ !! @return copy of integer member hj
+ pure integer function get_hj (this) result(rslt)
+ class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object
+ rslt = this%hj
+ end function get_hj
+
+ !> @brief Gets the updated index `fis' of fmsDiagBoundsHalos_type in the I dimension
+ !! @return copy of integer member `fis'
+ pure integer function get_fis (this) result(rslt)
+ class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object
+ rslt = this%fis
+ end function get_fis
+
+ !> @brief Gets the updated index `fie' of fmsDiagBoundsHalos_type in the I dimension
+ !! @return copy of integer member `fie'
+ pure integer function get_fie (this) result(rslt)
+ class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object
+ rslt = this%fie
+ end function get_fie
+
+ !> @brief Gets the updated index `fjs' of fmsDiagBoundsHalos_type in the I dimension
+ !! @return copy of integer member `fjs'
+ pure integer function get_fjs (this) result(rslt)
+ class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object
+ rslt = this%fjs
+ end function get_fjs
+
+ !> @brief Gets the updated index `fje' of fmsDiagBoundsHalos_type in the I dimension
+ !! @return copy of integer member `fje'
+ pure integer function get_fje (this) result(rslt)
+ class (fmsDiagBoundsHalos_type), intent(in) :: this !< Calling object
+ rslt = this%fje
+ end function get_fje
+
!> @brief Reset the instance bounding lower and upper bounds to lower_val and upper_val, respectively.
SUBROUTINE reset_bounds (this, lower_val, upper_val)
class (fmsDiagIbounds_type), target, intent(inout) :: this !< ibounds instance
@@ -162,6 +228,97 @@ SUBROUTINE reset_bounds_from_array_5D(this, array)
this%kmax = UBOUND(array,3)
END SUBROUTINE reset_bounds_from_array_5D
+ !> @brief Updates indices based on presence/absence of input indices is, js, ks, ie, je, and ke.
+ ! Computes halo sizes in the I and J dimensions.
+ ! This routine is intended to be used in diag manager.
+ !> @return .false. if there is no error else .true.
+ function recondition_indices(indices, field, is_in, js_in, ks_in, &
+ ie_in, je_in, ke_in, err_msg) result(ierr)
+ type(fmsDiagBoundsHalos_type), intent(inout) :: indices !< Stores indices in order:
+ !! (/is, js, ks, ie, je, ke, hi, fis, fie, hj, fjs, fje/)
+ class(*), intent(in) :: field(:,:,:,:) !< Dummy variable; only the sizes of the first 3 dimensions are used
+ integer, intent(in), optional :: is_in, js_in, ks_in, ie_in, je_in, ke_in !< User input indices
+ character(len=*), intent(out), optional :: err_msg !< Error message to pass back to caller
+ logical :: ierr !< Error flag
+
+ integer :: is, js, ks, ie, je, ke !< Local indices to update
+ integer :: hi !< halo size in the I dimension
+ integer :: hj !< halo size in the J dimension
+ integer :: twohi, twohj !< Temporary storages
+ integer :: fis, fie, fjs, fje !< ! Updated starting and ending indices in the I and J dimensions
+ integer :: n1, n2, n3 !< Sizes of the first 3 dimenstions indicies of the data
+
+ ierr = .false.
+ if (present(err_msg)) err_msg = ''
+
+ ! If is, js, or ks not present default them to 1
+ is = 1
+ js = 1
+ ks = 1
+
+ IF ( PRESENT(is_in) ) is = is_in
+ IF ( PRESENT(js_in) ) js = js_in
+ IF ( PRESENT(ks_in) ) ks = ks_in
+
+ n1 = SIZE(field, 1)
+ n2 = SIZE(field, 2)
+ n3 = SIZE(field, 3)
+
+ ie = is + n1 - 1
+ je = js + n2 - 1
+ ke = ks + n3 - 1
+
+ IF ( PRESENT(ie_in) ) ie = ie_in
+ IF ( PRESENT(je_in) ) je = je_in
+ IF ( PRESENT(ke_in) ) ke = ke_in
+
+ twohi = n1 - (ie - is + 1)
+ IF ( MOD(twohi, 2) /= 0 ) THEN
+ ierr = fms_error_handler('diag_util_mod:recondition_indices', &
+ 'non-symmetric halos in first dimension', err_msg)
+ IF (ierr) RETURN
+ END IF
+
+ twohj = n2 - (je - js + 1)
+ IF ( MOD(twohj, 2) /= 0 ) THEN
+ ierr = fms_error_handler('diag_util_mod:recondition_indices', &
+ 'non-symmetric halos in second dimension', err_msg)
+ IF (ierr) RETURN
+ END IF
+
+ hi = twohi/2
+ hj = twohj/2
+
+ ! The next line is necessary to ensure that is, ie, js, ie are relative to field(1:,1:)
+ ! But this works only when there is no windowing.
+ IF ( PRESENT(ie_in) .AND. PRESENT(je_in) ) THEN
+ is = 1 + hi
+ ie = n1 - hi
+ js = 1 + hj
+ je = n2 - hj
+ END IF
+
+ ! Used for field, mask and rmask bounds
+ fis = 1 + hi
+ fie = n1 - hi
+ fjs = 1 + hj
+ fje = n2 - hj
+
+ ! Update indices
+ indices%bounds3D%imin = is
+ indices%bounds3D%imax = ie
+ indices%bounds3D%jmin = js
+ indices%bounds3D%jmax = je
+ indices%bounds3D%kmin = ks
+ indices%bounds3D%kmax = ke
+ indices%hi = hi
+ indices%hj = hj
+ indices%fis = fis
+ indices%fie = fie
+ indices%fjs = fjs
+ indices%fje = fje
+ end function recondition_indices
+
END MODULE fms_diag_bbox_mod
!> @}
! close documentation grouping
From 242991473a2481b69f903f5fd0dc89ad576eeaec Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 31 Jul 2023 12:32:19 -0400
Subject: [PATCH 114/168] test: Add diag_manager testing for openmp (#1281)
---
diag_manager/fms_diag_field_object.F90 | 73 +++++++---
diag_manager/fms_diag_object.F90 | 16 ++-
test_fms/diag_manager/Makefile.am | 6 +-
test_fms/diag_manager/test_diag_manager2.sh | 30 ++++
test_fms/diag_manager/test_dm_openmp.F90 | 149 ++++++++++++++++++++
5 files changed, 249 insertions(+), 25 deletions(-)
create mode 100644 test_fms/diag_manager/test_dm_openmp.F90
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index d9d270ef36..3127e5c588 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -71,7 +71,7 @@ module fms_diag_field_object_mod
class(*), allocatable, private :: missing_value !< The missing fill value
class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data
class(*), allocatable, dimension(:,:,:,:), private :: data_buffer !< Buffer for field data
- logical, allocatable, private :: data_buffer_allocated !< True if the buffer has
+ logical, allocatable, private :: data_buffer_is_allocated !< True if the buffer has
!! been allocated
logical, allocatable, private :: math_needs_to_be_done !< If true, do math
!! functions. False when done.
@@ -88,6 +88,9 @@ module fms_diag_field_object_mod
procedure :: setID => set_diag_id
procedure :: set_type => set_vartype
procedure :: set_data_buffer => set_data_buffer
+ procedure :: set_data_buffer_is_allocated
+ procedure :: is_data_buffer_allocated
+ procedure :: allocate_data_buffer
procedure :: set_math_needs_to_be_done => set_math_needs_to_be_done
procedure :: add_attribute => diag_field_add_attribute
procedure :: vartype_inq => what_is_vartype
@@ -382,19 +385,15 @@ subroutine set_vartype(objin , var)
" r8, r4, i8, i4, or string.", warning)
end select
end subroutine set_vartype
-!> Allocates the data buffer in the field object.
-!! Adds the input data to the buffered data.
-subroutine set_data_buffer (this, input_data, diag_axis, is, js, ks, ie, je, ke)
+
+!> @brief Adds the input data to the buffered data.
+subroutine set_data_buffer (this, input_data, is, js, ks, ie, je, ke)
class (fmsDiagField_type) , intent(inout):: this !< The field object
class(*), dimension(:,:,:,:), intent(in) :: input_data !< The input array
- class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis
- integer :: is, js, ks !< Starting indicies of the field_data
- integer :: ie, je, ke !< Ending indicied of the field_data
-!> Allocate the buffer if it is not allocated
- if (.not.allocated(this%data_buffer_allocated)) this%data_buffer_allocated = .false.
- if (.not.this%data_buffer_allocated) &
- this%data_buffer_allocated = allocate_data_buffer(this, input_data, diag_axis)
- if (.not.this%data_buffer_allocated) &
+ integer :: is, js, ks !< Starting indicies of the field_data relative to the global domain
+ integer :: ie, je, ke !< Ending indicies of the field_data relative to the global domain
+
+ if (.not.this%data_buffer_is_allocated) &
call mpp_error ("set_data_buffer", "The data buffer for the field "//trim(this%varname)//" was unable to be "//&
"allocated.", FATAL)
@@ -436,16 +435,12 @@ logical function allocate_data_buffer(this, input_data, diag_axis)
integer, dimension (ndims) :: length !< The length of an axis
integer :: a !< For looping through axes
integer, pointer :: axis_id !< The axis ID
-!!TODO:
-!! Use global data
-!! use is, ie, js, je, ks, ke, ls, le
+
!! Use the axis to get the size
!> Initialize the axis lengths to 1. Any dimension that does not have an axis will have a length
!! of 1.
length = 1
-!> Get the number of axes
naxes = size(this%axis_ids)
-!> Loop through the axes and get the length of the axes for this field
axis_loop: do a = 1,naxes
axis_id => this%axis_ids(a)
select type (axis => diag_axis(axis_id)%axis)
@@ -453,8 +448,7 @@ logical function allocate_data_buffer(this, input_data, diag_axis)
length(a) = axis%axis_length()
end select
enddo axis_loop
-!> On a single thread, allocate the data buffer to the correct kind and size
-!$omp single
+
select type (input_data)
type is (real(r4_kind))
if (.not.allocated(this%data_buffer)) allocate(real(kind=r4_kind) :: this%data_buffer( &
@@ -484,7 +478,6 @@ logical function allocate_data_buffer(this, input_data, diag_axis)
call mpp_error ("allocate_data_buffer","The data input to set_data_buffer for "//&
trim(this%varname)//" is not a supported type", FATAL)
end select
-!$omp end single
allocate_data_buffer = allocated(this%data_buffer)
end function allocate_data_buffer
!> Sets the flag saying that the math functions need to be done
@@ -493,6 +486,24 @@ subroutine set_math_needs_to_be_done (this, math_needs_to_be_done)
logical, intent (in) :: math_needs_to_be_done !< Flag saying that the math functions need to be done
this%math_needs_to_be_done = math_needs_to_be_done
end subroutine set_math_needs_to_be_done
+
+!> @brief Sets the flag saying that the data buffer is allocated
+subroutine set_data_buffer_is_allocated (this, data_buffer_is_allocated)
+ class (fmsDiagField_type) , intent(inout) :: this !< The field object
+ logical, intent (in) :: data_buffer_is_allocated !< .true. if the
+ !! data buffer is allocated
+ this%data_buffer_is_allocated = data_buffer_is_allocated
+end subroutine set_data_buffer_is_allocated
+
+!> @brief Determine if the data_buffer is allocated
+!! @return logical indicating if the data_buffer is allocated
+pure logical function is_data_buffer_allocated (this)
+ class (fmsDiagField_type) , intent(in) :: this !< The field object
+
+ is_data_buffer_allocated = .false.
+ if (allocated(this%data_buffer_is_allocated)) is_data_buffer_allocated = this%data_buffer_is_allocated
+
+end function
!> \brief Prints to the screen what type the diag variable is
subroutine what_is_vartype(this)
class (fmsDiagField_type) , intent(inout):: this
@@ -1640,5 +1651,27 @@ subroutine dump_field_obj (this, unit_num)
end subroutine
+!< @brief Get the starting compute domain indices for a set of axis
+!! @return compute domain starting indices
+function get_starting_compute_domain(axis_ids, diag_axis) &
+result(compute_domain)
+ integer, intent(in) :: axis_ids(:) !< Array of axis ids
+ class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of axis object
+
+ integer :: compute_domain(4)
+ integer :: a !< For looping through axes
+ integer :: compute_idx(2) !< Compute domain indices (starting, ending)
+ logical :: dummy !< Dummy variable for the `get_compute_domain` subroutine
+
+ compute_domain = 1
+ axis_loop: do a = 1,size(axis_ids)
+ select type (axis => diag_axis(axis_ids(a))%axis)
+ type is (fmsDiagFullAxis_type)
+ call axis%get_compute_domain(compute_idx, dummy)
+ if ( compute_idx(1) .ne. diag_null) compute_domain(a) = compute_idx(1)
+ end select
+ enddo axis_loop
+end function get_starting_compute_domain
+
#endif
end module fms_diag_field_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 8bbe5b2266..88424dfcd5 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -502,6 +502,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is
!TODO: logical :: phys_window
character(len=128) :: error_string !< Store error text
integer :: i !< For looping
+ logical :: data_buffer_is_allocated !< .true. if the data buffer is allocated
+
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
@@ -545,10 +547,18 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is
IF ( PRESENT(ie_in) ) ie = ie_in
IF ( PRESENT(je_in) ) je = je_in
IF ( PRESENT(ke_in) ) ke = ke_in
-!> Buffer the data
- call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, FMS_diag_object%diag_axis,&
- is, js, ks, ie, je, ke)
+
+!> Only 1 thread allocates the output buffer and sets set_math_needs_to_be_done
+!$omp critical
+ if (.not. this%FMS_diag_fields(diag_field_id)%is_data_buffer_allocated()) then
+ data_buffer_is_allocated = &
+ this%FMS_diag_fields(diag_field_id)%allocate_data_buffer(field_data, this%diag_axis)
+ endif
+ call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.)
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.)
+!$omp end critical
+ call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data,&
+ is, js, ks, ie, je, ke)
fms_diag_accept_data = .TRUE.
return
else
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 1a3b6b75ba..bfe3814a5d 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -28,9 +28,10 @@ AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager/include -I$(
LDADD = $(top_builddir)/libFMS/libFMS.la
# Build this test program.
-check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_object_container \
+check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_diag_update_buffer test_diag_dlinked_list \
- test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer test_flexible_time
+ test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer test_flexible_time \
+ test_dm_openmp
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -42,6 +43,7 @@ test_diag_ocean_SOURCES = test_diag_ocean.F90
test_modern_diag_SOURCES = test_modern_diag.F90
test_diag_buffer_SOURCES= test_diag_buffer.F90
test_flexible_time_SOURCES = test_flexible_time.F90
+test_dm_openmp_SOURCES = test_dm_openmp.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 754d782476..1fc8c1e3c1 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -866,6 +866,36 @@ printf "&diag_manager_nml \n use_modern_diag = .false. \n use_clock_average = .t
mpirun -n 1 ../test_flexible_time
'
+printf "&diag_manager_nml \n use_modern_diag = .true. \n /" | cat > input.nml
+cat <<_EOF > diag_table.yaml
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: file_openmp_test
+ freq: 1 hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: none
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ reduction: none
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ reduction: none
+ kind: r4
+_EOF
+
+export OMP_NUM_THREADS=2
+my_test_count=`expr $my_test_count + 1`
+ test_expect_success "Test the modern diag manager end to end but it uses the openmp stuff(test $my_test_count)" '
+ mpirun -n 6 ../test_dm_openmp
+ '
+export OMP_NUM_THREADS=1
else
my_test_count=`expr $my_test_count + 1`
test_expect_failure "test modern diag manager failure when compiled without -Duse-yaml flag (test $my_test_count)" '
diff --git a/test_fms/diag_manager/test_dm_openmp.F90 b/test_fms/diag_manager/test_dm_openmp.F90
new file mode 100644
index 0000000000..99ca790aac
--- /dev/null
+++ b/test_fms/diag_manager/test_dm_openmp.F90
@@ -0,0 +1,149 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This programs tests the modern diag_manager
+
+program test_diag_openmp
+ use omp_lib
+ use mpp_mod, only: mpp_npes, mpp_pe, mpp_sync
+ use platform_mod, only: r8_kind
+ use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain
+ use block_control_mod, only: block_control_type, define_blocks
+ use fms_mod, only: fms_init, fms_end
+ use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
+ diag_send_complete, diag_manager_set_time_end, send_data, register_static_field
+ use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time
+
+
+ implicit none
+
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: layout(2) !< Layout
+ integer :: io_layout(2) !< Io layout
+ type(domain2d) :: Domain !< 2D domain
+ integer :: is !< Starting x compute index
+ integer :: ie !< Ending x compute index
+ integer :: js !< Starting y compute index
+ integer :: je !< Ending y compute index
+ type(time_type) :: Time !< Time of the simulation
+ type(time_type) :: Time_step !< Time of the simulation
+ real, dimension(:), allocatable :: x !< X axis data
+ integer :: id_x !< axis id for the x dimension
+ real, dimension(:), allocatable :: y !< Y axis_data
+ integer :: id_y !< axis id for the y dimension
+ real, dimension(:), allocatable :: z !< Z axis data
+ integer :: id_z !< axis id for the z dimension
+ real(kind=r8_kind), allocatable :: var(:,:,:) !< Dummy variable data
+ integer :: i, j !< For do loops
+ type(block_control_type) :: my_block !< Returns instantiated @ref block_control_type
+ logical :: message !< Flag for outputting debug message
+ integer :: isw !< Starting index for each thread in the x direction
+ integer :: iew !< Ending index for each thread in the x direction
+ integer :: jsw !< Starting index for each thread in the y direction
+ integer :: jew !< Ending index for each thread in the y direction
+ integer :: is1 !< Starting index for each thread in the x direction (1-based)
+ integer :: ie1 !< Ending index for each thread in the x direction (1-based)
+ integer :: js1 !< Starting index for each thread in the y direction (1-based)
+ integer :: je1 !< Ending index for each thread in the y direction (1-based)
+ integer :: id_var1 !< diag_field id for var in 1d
+ integer :: id_var2 !< diag_field id for var in lon/lat grid
+ integer :: id_var3 !< diag_field id for var in lon/lat/z grid
+ logical :: used !< .true. if the send_data call was sucessful
+
+ call fms_init
+ call set_calendar_type(JULIAN)
+ call diag_manager_init
+
+ nx = 96
+ ny = 96
+ nz = 5
+ layout = (/1, mpp_npes()/)
+ io_layout = (/1, 1/)
+
+ ! Set up the intial time
+ Time = set_date(2,1,1,0,0,0)
+
+ !< Create a lat/lon domain
+ call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain')
+ call mpp_define_io_domain(Domain, io_layout)
+ call mpp_get_compute_domain(Domain, is, ie, js, je)
+
+ ! Set up the data
+ allocate(x(nx), y(ny), z(nz))
+ allocate(var(is:ie, js:je, nz))
+ do i=1,nx
+ x(i) = i
+ enddo
+
+ do i=1,ny
+ y(i) = i
+ enddo
+
+ do i=1,nz
+ z(i) = i
+ enddo
+
+ !< Register the axis:
+ id_x = diag_axis_init('x', x, 'point_E', 'x', long_name='point_E', Domain2=Domain)
+ id_y = diag_axis_init('y', y, 'point_N', 'y', long_name='point_N', Domain2=Domain)
+ id_z = diag_axis_init('z', z, 'pressure', 'z', long_name='too much pressure')
+
+ !< Register the variables
+ id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x/), Time, 'Var in a lon domain', 'mullions')
+ id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_x, id_y/), Time, 'Var in a lon/lat domain', 'mullions')
+ id_var3 = register_diag_field ('ocn_mod', 'var3', (/id_x, id_y, id_z/), Time, &
+ 'Var in a lon/lat/z domain', 'mullions')
+
+ call diag_manager_set_time_end(set_date(2,1,2,0,0,0))
+
+ !< Divide the domain further into blocks
+ call define_blocks ('testing_model', my_block, is, ie, js, je, kpts=0, &
+ nx_block=1, ny_block=4, message=message)
+
+ Time_step = set_time (3600,0) !< 1 hour
+ do j = 1, 23 !simulated time
+ Time = set_date(2,1,1,j,0,0)
+ var = real(j, kind=r8_kind) !< Set the data
+!$OMP parallel do default(shared) private(i, isw, iew, jsw, jew) schedule (dynamic,1)
+ do i = 1, 4
+ isw = my_block%ibs(i)
+ jsw = my_block%jbs(i)
+ iew = my_block%ibe(i)
+ jew = my_block%jbe(i)
+
+ !--- indices for 1-based arrays ---
+ is1 = isw-is+1
+ ie1 = iew-is+1
+ js1 = jsw-js+1
+ je1 = jew-js+1
+
+ used=send_data(id_var1, var(is1:ie1, 1, 1), time, is_in=is1, ie_in=ie1)
+ used=send_data(id_var2, var(is1:ie1, js1:je1, 1), time, is_in=is1, js_in=js1, &
+ ie_in=ie1, je_in=je1)
+ used=send_data(id_var3, var(is1:ie1, js1:je1, :), time, is_in=is1, js_in=js1, &
+ ie_in=ie1, je_in=je1, ks_in=1, ke_in=nz)
+ enddo
+ call diag_send_complete(Time_step)
+ enddo
+
+ call diag_manager_end(Time)
+ call fms_end
+end program test_diag_openmp
\ No newline at end of file
From b1a2fa2ed20d46ee37deec14659f3c743602e618 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 31 Jul 2023 12:33:05 -0400
Subject: [PATCH 115/168] fix: modern diag reproduce old diag_field_not_found
behaviour (#1301)
---
diag_manager/fms_diag_object.F90 | 26 +++++++++++++++-----------
1 file changed, 15 insertions(+), 11 deletions(-)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 88424dfcd5..76015ae4c4 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -163,7 +163,8 @@ end subroutine fms_diag_object_end
!> @brief Registers a field.
!! @description This to avoid having duplicate code in each of the _scalar, _array and _static register calls
-!! @return field index for subsequent call to send_data.
+!! @return field index to be used in subsequent calls to send_data or DIAG_FIELD_NOT_FOUND if the field is not
+!! in the diag_table.yaml
integer function fms_register_diag_field_obj &
(this, modname, varname, axes, init_time, &
longname, units, missing_value, varRange, mask_variant, standname, &
@@ -206,8 +207,8 @@ integer function fms_register_diag_field_obj &
#else
diag_field_indices = find_diag_field(varname, modname)
if (diag_field_indices(1) .eq. diag_null) then
- !< The field was not found in the table, so return diag_null
- fms_register_diag_field_obj = diag_null
+ !< The field was not found in the table, so return DIAG_FIELD_NOT_FOUND
+ fms_register_diag_field_obj = DIAG_FIELD_NOT_FOUND
deallocate(diag_field_indices)
return
endif
@@ -280,8 +281,9 @@ integer function fms_register_diag_field_obj &
#endif
end function fms_register_diag_field_obj
- !> @brief Registers a scalar field
- !! @return field index for subsequent call to send_data.
+!> @brief Registers a scalar field
+!! @return field index to be used in subsequent calls to send_data or DIAG_FIELD_NOT_FOUND if the field is not
+!! in the diag_table.yaml
INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, init_time, &
& long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,&
& area, volume, realm)
@@ -300,7 +302,7 @@ INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, in
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
#ifndef use_yaml
-fms_register_diag_field_scalar=diag_null
+fms_register_diag_field_scalar=DIAG_FIELD_NOT_FOUND
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
fms_register_diag_field_scalar = this%register(&
@@ -311,8 +313,9 @@ INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, in
#endif
end function fms_register_diag_field_scalar
- !> @brief Registers an array field
- !> @return field index for subsequent call to send_data.
+!> @brief Registers an array field
+!! @return field index to be used in subsequent calls to send_data or DIAG_FIELD_NOT_FOUND if the field is not
+!! in the diag_table.yaml
INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, axes, init_time, &
& long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,&
& do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
@@ -340,7 +343,7 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
#ifndef use_yaml
-fms_register_diag_field_array=diag_null
+fms_register_diag_field_array=DIAG_FIELD_NOT_FOUND
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
fms_register_diag_field_array = this%register( &
@@ -352,7 +355,8 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax
end function fms_register_diag_field_array
!> @brief Return field index for subsequent call to send_data.
-!! @return field index for subsequent call to send_data.
+!! @return field index to be used in subsequent calls to send_data or DIAG_FIELD_NOT_FOUND if the field is not
+!! in the diag_table.yaml
INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, long_name, units,&
& missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,&
& tile_count, area, volume, realm)
@@ -382,7 +386,7 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes,
!! modeling_realm attribute
#ifndef use_yaml
-fms_register_static_field=diag_null
+fms_register_static_field=DIAG_FIELD_NOT_FOUND
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
!TODO The register_static_field interface does not have the capabiliy to register a variable as a "scalar"
From 9662f18563442c0d65e15d83273b0a49979a2050 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 1 Aug 2023 13:18:41 -0400
Subject: [PATCH 116/168] feat: modern diag write buffer set up (#1311)
---
diag_manager/fms_diag_axis_object.F90 | 11 +++++++
diag_manager/fms_diag_file_object.F90 | 17 +++++++++-
diag_manager/fms_diag_object.F90 | 10 ++++++
diag_manager/fms_diag_output_buffer.F90 | 43 +++++++++++++++++++++++++
4 files changed, 80 insertions(+), 1 deletion(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 61555b52e6..8ae2a325b9 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -118,6 +118,7 @@ module fms_diag_axis_object_mod
real(kind=r4_kind), allocatable, private :: zbounds(:) !< Bounds of the Z axis
contains
procedure :: fill_subaxis
+ procedure :: axis_length
END TYPE fmsDiagSubAxis_type
!> @brief Type to hold the diurnal axis
@@ -755,6 +756,16 @@ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id,
endif
end subroutine fill_subaxis
+ !> @brief Get the axis length of a subaxis
+ !> @return the axis length
+ function axis_length(this) &
+ result(res)
+ class(fmsDiagSubAxis_type) , INTENT(IN) :: this !< diag_sub_axis obj
+ integer :: res
+
+ res = this%ending_index - this%starting_index + 1
+ end function
+
!> @brief Get the ntiles in a domain
!> @return the number of tiles in a domain
function get_ntiles(this) &
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 62f01f7fe0..51a3396eb5 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -88,14 +88,16 @@ module fms_diag_file_object_mod
integer, allocatable :: num_registered_fields !< The number of fields registered
!! to the file
integer, dimension(:), allocatable :: axis_ids !< Array of axis ids in the file
- integer, dimension(:), allocatable :: buffer_ids !< array of buffer ids associated with the file
integer :: number_of_axis !< Number of axis in the file
+ integer, dimension(:), allocatable :: buffer_ids !< array of buffer ids associated with the file
+ integer :: number_of_buffers !< Number of buffers that have been added to the file
logical :: time_ops !< .True. if file contains variables that are time_min, time_max, time_average or time_sum
integer :: unlim_dimension_level !< The unlimited dimension level currently being written
logical :: is_static !< .True. if the frequency is -1
contains
procedure, public :: add_field_and_yaml_id
+ procedure, public :: add_buffer_id
procedure, public :: is_field_registered
procedure, public :: init_diurnal_axis
procedure, public :: has_file_metadata_from_model
@@ -210,13 +212,16 @@ logical function fms_diag_files_object_init (files_array)
obj%diag_yaml_file => diag_yaml%diag_files(i)
obj%id = i
allocate(obj%field_ids(diag_yaml%diag_files(i)%size_file_varlist()))
+ allocate(obj%buffer_ids(diag_yaml%diag_files(i)%size_file_varlist()))
allocate(obj%yaml_ids(diag_yaml%diag_files(i)%size_file_varlist()))
allocate(obj%field_registered(diag_yaml%diag_files(i)%size_file_varlist()))
!! Initialize the integer arrays
obj%field_ids = DIAG_NOT_REGISTERED
obj%yaml_ids = DIAG_NOT_REGISTERED
+ obj%buffer_ids = DIAG_NOT_REGISTERED
obj%field_registered = .FALSE.
obj%num_registered_fields = 0
+ obj%number_of_buffers = 0
!> These will be set in a set_file_domain
obj%type_of_domain = NO_DOMAIN
@@ -287,6 +292,16 @@ subroutine add_field_and_yaml_id (this, new_field_id, yaml_id)
endif
end subroutine add_field_and_yaml_id
+!> \brief Adds a buffer_id to the file object
+subroutine add_buffer_id (this, buffer_id)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ integer, intent(in) :: buffer_id !< Buffer id to add to the file
+
+ this%number_of_buffers = this%number_of_buffers + 1
+ this%buffer_ids(this%number_of_buffers) = buffer_id
+
+end subroutine add_buffer_id
+
!> \brief Initializes a diurnal axis for a fileobj
!! \note This is going to be called for every variable in the file, if the variable is not a diurnal variable
!! it will do nothing. It only defined a diurnal axis once.
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 76015ae4c4..08d324f615 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -225,6 +225,10 @@ integer function fms_register_diag_field_obj &
!> Initialize buffer_ids of this field with the diag_field_indices(diag_field_indices)
!! of the sorted variable list
fieldptr%buffer_ids = get_diag_field_ids(diag_field_indices)
+ do i = 1, size(fieldptr%buffer_ids)
+ call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_field_id(this%registered_variables)
+ call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_yaml_id(diag_field_indices(i))
+ enddo
!> Allocate and initialize member buffer_allocated of this field
allocate(fieldptr%buffer_allocated(size(diag_field_indices)))
@@ -244,6 +248,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
+ call fileptr%add_buffer_id(fieldptr%buffer_ids(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i), &
@@ -255,6 +260,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
+ call fileptr%add_buffer_id(fieldptr%buffer_ids(i))
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i), &
@@ -265,6 +271,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
+ call fileptr%add_buffer_id(fieldptr%buffer_ids(i))
call fileptr%add_start_time(init_time, this%current_model_time)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
@@ -272,6 +279,7 @@ integer function fms_register_diag_field_obj &
do i = 1, size(file_ids)
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
+ call fileptr%add_buffer_id(fieldptr%buffer_ids(i))
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
endif
@@ -891,6 +899,8 @@ integer function fms_get_axis_length(this, axis_id)
select type (axis => this%diag_axis(axis_id)%axis)
type is (fmsDiagFullAxis_type)
fms_get_axis_length = axis%axis_length()
+ type is (fmsDiagSubAxis_type)
+ fms_get_axis_length = axis%axis_length()
end select
#endif
end function fms_get_axis_length
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 5b3d267dfd..c2a29fcedd 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -62,10 +62,16 @@ module fms_diag_output_buffer_mod
type :: fmsDiagOutputBufferContainer_type
class(fmsDiagOutputBuffer_class), allocatable :: diag_buffer_obj !< any 0-5d buffer object
integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
+ integer :: field_id !< The id of the field the buffer belongs to
+ integer :: yaml_id !< The id of the yaml id the buffer belongs to
contains
procedure :: add_axis_ids
procedure :: get_axis_ids
+ procedure :: set_field_id
+ procedure :: get_field_id
+ procedure :: set_yaml_id
+ procedure :: get_yaml_id
end type
!> Scalar buffer type to extend fmsDiagBufferContainer_type
@@ -1455,5 +1461,42 @@ function get_axis_ids(this) &
endif
end function
+!> @brief Get the field id of the buffer
+!! @return the field id of the buffer
+function get_field_id(this) &
+ result(res)
+
+ class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< Buffer object
+ integer :: res
+
+ res = this%field_id
+end function get_field_id
+
+!> @brief set the field id of the buffer
+subroutine set_field_id(this, field_id)
+ class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object
+ integer, intent(in) :: field_id !< field id of the buffer
+
+ this%field_id = field_id
+end subroutine set_field_id
+
+!> @brief set the field id of the buffer
+subroutine set_yaml_id(this, yaml_id)
+ class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object
+ integer, intent(in) :: yaml_id !< yaml id of the buffer
+
+ this%yaml_id = yaml_id
+end subroutine set_yaml_id
+
+!> @brief Get the yaml id of the buffer
+!! @return the yaml id of the buffer
+function get_yaml_id(this) &
+ result(res)
+
+ class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< Buffer object
+ integer :: res
+
+ res = this%yaml_id
+end function get_yaml_id
#endif
end module fms_diag_output_buffer_mod
From 502dbacaaab2f5c027ed65cefb0e5c8dd514dcf9 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 7 Aug 2023 12:55:35 -0400
Subject: [PATCH 117/168] feat: modern diag fix and add calls to
allocate_diag_field_output_buffers (#1314)
---
diag_manager/fms_diag_field_object.F90 | 39 +++++---------------
diag_manager/fms_diag_file_object.F90 | 1 -
diag_manager/fms_diag_object.F90 | 47 ++++++++++++++++---------
diag_manager/fms_diag_output_buffer.F90 | 23 ++++++------
diag_manager/fms_diag_yaml.F90 | 2 +-
5 files changed, 51 insertions(+), 61 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 3127e5c588..ff4734ab32 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -75,7 +75,7 @@ module fms_diag_field_object_mod
!! been allocated
logical, allocatable, private :: math_needs_to_be_done !< If true, do math
!! functions. False when done.
- logical, allocatable, dimension(:) :: buffer_allocated !< True if a buffer pointed by
+ logical, allocatable :: buffer_allocated !< True if a buffer pointed by
!! the corresponding index in
!! buffer_ids(:) is allocated.
contains
@@ -146,6 +146,7 @@ module fms_diag_field_object_mod
procedure :: get_missing_value
procedure :: get_data_RANGE
procedure :: get_axis_id
+ procedure :: get_data_buffer
procedure :: dump_field_obj
procedure :: get_domain
procedure :: get_type_of_domain
@@ -629,7 +630,8 @@ end function diag_obj_is_registered
function diag_obj_is_static (this) result (rslt)
class(fmsDiagField_type), intent(in) :: this
logical :: rslt
- rslt = this%static
+ rslt = .false.
+ if (allocated(this%static)) rslt = this%static
end function diag_obj_is_static
!> @brief Determine if the field is a scalar
@@ -1276,38 +1278,13 @@ function get_data_buffer (this) &
else
rslt => null()
endif
-! select type (db => this%data_buffer)
-! type is (real(kind=r4_kind))
-! allocate (real(kind=r4_kind) :: rslt(size(this%data_buffer,1), &
-! size(this%data_buffer,2), &
-! size(this%data_buffer,3), &
-! size(this%data_buffer,4) ))
-! rslt = this%data_buffer
-! type is (real(kind=r8_kind))
-! allocate (real(kind=r8_kind) :: rslt(size(this%data_buffer,1), &
-! size(this%data_buffer,2), &
-! size(this%data_buffer,3), &
-! size(this%data_buffer,4) ))
-! rslt = this%data_buffer
-! type is (integer(kind=i4_kind))
-! allocate (integer(kind=i4_kind) :: rslt(size(this%data_buffer,1), &
-! size(this%data_buffer,2), &
-! size(this%data_buffer,3), &
-! size(this%data_buffer,4) ))
-! rslt = this%data_buffer
-! type is (integer(kind=i8_kind))
-! allocate (integer(kind=i8_kind) :: rslt(size(this%data_buffer,1), &
-! size(this%data_buffer,2), &
-! size(this%data_buffer,3), &
-! size(this%data_buffer,4) ))
-! rslt = this%data_buffer
-! end select
end function get_data_buffer
!> Gets the flag telling if the math functions need to be done
!! \return Copy of math_needs_to_be_done flag
pure logical function get_math_needs_to_be_done(this)
class (fmsDiagField_type), intent(in) :: this !< diag object
- get_math_needs_to_be_done = this%math_needs_to_be_done
+ get_math_needs_to_be_done = .false.
+ if (allocated(this%math_needs_to_be_done)) get_math_needs_to_be_done = this%math_needs_to_be_done
end function get_math_needs_to_be_done
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!! Allocation checks
@@ -1494,10 +1471,10 @@ function get_default_missing_value(var_type) &
select case(var_type)
case (r4)
- allocate(integer(kind=r4_kind) :: rslt)
+ allocate(real(kind=r4_kind) :: rslt)
rslt = real(CMOR_MISSING_VALUE, kind=r4_kind)
case (r8)
- allocate(integer(kind=r8_kind) :: rslt)
+ allocate(real(kind=r8_kind) :: rslt)
rslt = real(CMOR_MISSING_VALUE, kind=r8_kind)
case default
end select
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 51a3396eb5..5a277971e6 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -760,7 +760,6 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id, buffer_id, output
this%axis_ids = diag_null
endif
endif
- return
type is (fmsDiagFile_type)
do i = 1, size(var_axis_ids)
axis_found = .false.
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 08d324f615..46099be45c 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -231,7 +231,6 @@ integer function fms_register_diag_field_obj &
enddo
!> Allocate and initialize member buffer_allocated of this field
- allocate(fieldptr%buffer_allocated(size(diag_field_indices)))
fieldptr%buffer_allocated = .false.
!> Register the data for the field
@@ -575,6 +574,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is
return
else
!!TODO: Loop through fields and do averages/math functions
+
+ call this%allocate_diag_field_output_buffers(field_data, diag_field_id)
do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids)
buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(i)
@@ -662,9 +663,9 @@ subroutine fms_diag_send_complete(this, time_step)
diag_field => this%FMS_diag_fields(file_field_ids(ifield))
!> Check if math needs to be done
- ! math = diag_field%get_math_needs_to_be_done()
- math = .false. !TODO: replace this with real thing
+ math = diag_field%get_math_needs_to_be_done()
calling_math: if (math) then
+ call this%allocate_diag_field_output_buffers(diag_field%get_data_buffer(), file_field_ids(ifield))
!!TODO: call math functions !!
endif calling_math
!> Clean up, clean up, everybody everywhere
@@ -1004,9 +1005,12 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
class(DiagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields
integer, allocatable :: axis_ids(:) !< Pointer to indices of axes of the field variable
integer :: var_type !< Stores type of the field data (r4, r8, i4, i8, and string) represented as an integer.
- real :: missing_value !< Fill value to initialize output buffers
+ class(*), allocatable :: missing_value !< Missing value to initialize the data to
character(len=128), allocatable :: var_name !< Field name to initialize output buffers
logical :: is_scalar !< Flag indicating that the variable is a scalar
+ integer :: yaml_id
+
+ if (this%FMS_diag_fields(field_id)%buffer_allocated) return
! Determine the type of the field data
var_type = get_var_type(field_data(1, 1, 1, 1))
@@ -1015,12 +1019,14 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
var_name = this%Fms_diag_fields(field_id)%get_varname()
! Get missing value for the field
+ !TODO class (*) is weird missing_value = this%FMS_diag_fields(field_id)%get_missing_value(var_type)
+ !!should work ...
if (this%FMS_diag_fields(field_id)%has_missing_value()) then
select type (my_type => this%FMS_diag_fields(field_id)%get_missing_value(var_type))
type is (real(kind=r4_kind))
- missing_value = my_type
+ missing_value = real(my_type, kind=r4_kind)
type is (real(kind=r8_kind))
- missing_value = real(my_type)
+ missing_value = real(my_type, kind=r8_kind)
class default
call mpp_error( FATAL, 'fms_diag_object_mod:allocate_diag_field_output_buffers Invalid type')
end select
@@ -1036,10 +1042,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
endif
! Determine dimensions of the field
- is_scalar = .True.
- if (this%FMS_diag_fields(field_id)%has_axis_ids()) then
- is_scalar = .False.
- endif
+ is_scalar = this%FMS_diag_fields(field_id)%is_scalar()
! Loop over a number of fields/buffers where this variable occurs
do i = 1, size(this%FMS_diag_fields(field_id)%buffer_ids)
@@ -1051,16 +1054,23 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
ndims = size(axis_ids)
endif
- ptr_diag_field_yaml => diag_yaml%get_diag_field_from_id(buffer_id)
+ yaml_id = this%FMS_diag_output_buffers(buffer_id)%get_yaml_id()
+
+ ptr_diag_field_yaml => diag_yaml%diag_fields(yaml_id)
num_diurnal_samples = ptr_diag_field_yaml%get_n_diurnal() !< Get number of diurnal samples
! If diurnal axis exists, fill lengths of axes.
if (num_diurnal_samples .ne. 0) then
allocate(axes_length(ndims + 1)) !< Include extra length for the diurnal axis
- do j = 1, ndims
- axes_length(j) = this%fms_get_axis_length(axis_ids(j))
- enddo
- !TODO This is going to require more work for when we have subRegion variables
+ else
+ allocate(axes_length(ndims))
+ endif
+
+ do j = 1, ndims
+ axes_length(j) = this%fms_get_axis_length(axis_ids(j))
+ enddo
+
+ if (num_diurnal_samples .ne. 0) then
axes_length(ndims + 1) = num_diurnal_samples
ndims = ndims + 1 !< Add one more dimension for the diurnal axis
endif
@@ -1069,7 +1079,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
! outputBuffer0d_type, outputBuffer1d_type, outputBuffer2d_type, outputBuffer3d_type,
! outputBuffer4d_type or outputBuffer5d_type.
if (.not. allocated(this%FMS_diag_output_buffers(buffer_id)%diag_buffer_obj)) then
- this%FMS_diag_output_buffers(buffer_id) = fms_diag_output_buffer_create_container(ndims)
+ call fms_diag_output_buffer_create_container(ndims, this%FMS_diag_output_buffers(buffer_id))
end if
ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id)%diag_buffer_obj
@@ -1108,7 +1118,12 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
class default
call mpp_error( FATAL, 'allocate_diag_field_output_buffers: invalid buffer type')
end select
+
+ if (allocated(axis_ids)) deallocate(axis_ids)
+ deallocate(axes_length)
enddo
+
+ this%FMS_diag_fields(field_id)%buffer_allocated = .true.
#else
call mpp_error( FATAL, "allocate_diag_field_output_buffers: "//&
"you can not use the modern diag manager without compiling with -Duse_yaml")
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index c2a29fcedd..3603bb4321 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -174,33 +174,32 @@ end function fms_diag_output_buffer_init
!> Creates a container type encapsulating a new buffer object for the given dimensions.
!! The buffer object will still need to be allocated to a type via allocate_buffer() before use.
!> @result A fmsDiagBufferContainer_type that holds a bufferNd_type, where N is buff_dims
-function fms_diag_output_buffer_create_container(buff_dims) &
-result(rslt)
- integer, intent(in) :: buff_dims !< dimensions
- type(fmsDiagOutputBufferContainer_type), allocatable :: rslt
+subroutine fms_diag_output_buffer_create_container(buff_dims, buffer_obj)
+ integer, intent(in) :: buff_dims !< dimensions
+ type(fmsDiagOutputBufferContainer_type), intent(inout) :: buffer_obj
+
character(len=5) :: dim_output !< string to output buff_dims on error
- allocate(rslt)
select case (buff_dims)
case (0)
- allocate(outputBuffer0d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer0d_type :: buffer_obj%diag_buffer_obj)
case (1)
- allocate(outputBuffer1d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer1d_type :: buffer_obj%diag_buffer_obj)
case (2)
- allocate(outputBuffer2d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer2d_type :: buffer_obj%diag_buffer_obj)
case (3)
- allocate(outputBuffer3d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer3d_type :: buffer_obj%diag_buffer_obj)
case (4)
- allocate(outputBuffer4d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer4d_type :: buffer_obj%diag_buffer_obj)
case (5)
- allocate(outputBuffer5d_type :: rslt%diag_buffer_obj)
+ allocate(outputBuffer5d_type :: buffer_obj%diag_buffer_obj)
case default
write( dim_output, *) buff_dims
dim_output = adjustl(dim_output)
call mpp_error(FATAL, 'fms_diag_buffer_create_container: invalid number of dimensions given:' // dim_output //&
'. Must be 0-5')
end select
-end function fms_diag_output_buffer_create_container
+end subroutine fms_diag_output_buffer_create_container
!!--------generic routines for any fmsDiagBuffer_class objects
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 85be393ea6..723fbf2b17 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -226,7 +226,7 @@ module fms_diag_yaml_mod
character(len=:), allocatable, private :: diag_title !< Experiment name
integer, private, dimension (basedate_size) :: diag_basedate !< basedate array
type(diagYamlFiles_type), allocatable, public, dimension (:) :: diag_files!< History file info
- type(diagYamlFilesVar_type), allocatable, private, dimension (:) :: diag_fields !< Diag fields info
+ type(diagYamlFilesVar_type), allocatable, public, dimension (:) :: diag_fields !< Diag fields info
contains
procedure :: size_diag_files
From 7d5d9420c130cd9a565c52f09d644a704066d83d Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 11 Aug 2023 05:29:10 -0400
Subject: [PATCH 118/168] feat: modern_diag add calls to write_data (#1320)
---
diag_manager/Makefile.am | 2 +-
diag_manager/fms_diag_file_object.F90 | 38 ++++++-
diag_manager/fms_diag_object.F90 | 4 +-
diag_manager/fms_diag_output_buffer.F90 | 113 ++++++++++++++++++-
test_fms/diag_manager/test_flexible_time.F90 | 18 ++-
5 files changed, 164 insertions(+), 11 deletions(-)
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 8554ba144a..0079d0b1b5 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -88,7 +88,7 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD
fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT) \
fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \
fms_diag_fieldbuff_update_mod.$(FC_MODEXT)
-fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
+fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
MODFILES = \
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 5a277971e6..84c3f3980e 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -45,7 +45,7 @@ module fms_diag_file_object_mod
fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, &
fmsDiagDiurnalAxis_type, create_new_z_subaxis
use fms_diag_field_object_mod, only: fmsDiagField_type
-use fms_diag_output_buffer_mod, only: fmsDiagOutputBufferContainer_type
+use fms_diag_output_buffer_mod, only: fmsDiagOutputBufferContainer_type, fmsDiagOutputBuffer_class
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, &
uppercase, lowercase
@@ -161,6 +161,7 @@ module fms_diag_file_object_mod
procedure :: open_diag_file
procedure :: write_global_metadata
procedure :: write_time_metadata
+ procedure :: write_field_data
procedure :: write_axis_metadata
procedure :: write_field_metadata
procedure :: write_axis_data
@@ -1119,6 +1120,41 @@ subroutine write_time_metadata(this)
end subroutine write_time_metadata
+!> \brief Write out the field data to the file
+subroutine write_field_data(this, field_obj, buffer_obj)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The diag file object to write to
+ type(fmsDiagField_type), intent(in), target :: field_obj(:) !< The field object to write from
+ type(fmsDiagOutputBufferContainer_type), intent(in), target :: buffer_obj(:) !< The buffer object with the data
+
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
+ class(FmsNetcdfFile_t), pointer :: fileobj !< Fileobj to write to
+ integer :: i !< For do loops
+ integer :: field_id !< The id of the field writing the data from
+
+ diag_file => this%FMS_diag_file
+ fileobj => diag_file%fileobj
+
+ !TODO This may be offloaded in the future
+ if (diag_file%is_static) then
+ !< Here the file is static so there is no need for the unlimited dimension
+ !! as a variables are static
+ do i = 1, diag_file%number_of_buffers
+ call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fileobj)
+ enddo
+ else
+ do i = 1, diag_file%number_of_buffers
+ field_id = buffer_obj(diag_file%buffer_ids(i))%get_field_id()
+ if (field_obj(field_id)%is_static()) then
+ !< If the variable is static, only write it the first time
+ if (diag_file%unlim_dimension_level .eq. 1) call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fileobj)
+ else
+ call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fileobj, unlim_dim_level=diag_file%unlim_dimension_level)
+ endif
+ enddo
+ endif
+
+end subroutine write_field_data
+
!> \brief Determine if it is time to close the file
!! \return .True. if it is time to close the file
logical function is_time_to_close_file (this, time_step)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 46099be45c..5915a604e0 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -227,7 +227,7 @@ integer function fms_register_diag_field_obj &
fieldptr%buffer_ids = get_diag_field_ids(diag_field_indices)
do i = 1, size(fieldptr%buffer_ids)
call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_field_id(this%registered_variables)
- call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_yaml_id(diag_field_indices(i))
+ call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_yaml_id(fieldptr%buffer_ids(i))
enddo
!> Allocate and initialize member buffer_allocated of this field
@@ -719,7 +719,7 @@ subroutine fms_diag_do_io(this, is_end_of_run)
if (diag_file%is_time_to_write(model_time)) then
call diag_file%increase_unlim_dimension_level()
call diag_file%write_time_data()
- !TODO call diag_file%add_variable_data()
+ call diag_file%write_field_data(this%FMS_diag_fields, this%FMS_diag_output_buffers)
call diag_file%update_next_write(model_time)
call diag_file%update_current_new_file_freq_index(model_time)
if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file()
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 3603bb4321..3f2e1db095 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -24,18 +24,19 @@
!! buffer0-5d types extend fmsDiagBuffer_class, and upon allocation
!! are added to the module's buffer_lists depending on it's dimension
module fms_diag_output_buffer_mod
-
+#ifdef use_yaml
use platform_mod
use iso_c_binding
use time_manager_mod, only: time_type
use mpp_mod, only: mpp_error, FATAL
use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8
+use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t
+use fms_diag_yaml_mod, only: diag_yaml
implicit none
private
-#ifdef use_yaml
!> @brief Object that holds buffered data and other diagnostics
!! Abstract to ensure use through its extensions(buffer0-5d types)
type, abstract :: fmsDiagOutputBuffer_class
@@ -72,6 +73,11 @@ module fms_diag_output_buffer_mod
procedure :: get_field_id
procedure :: set_yaml_id
procedure :: get_yaml_id
+ procedure :: write_buffer
+ !! These are needed because otherwise the write_data calls will go into the wrong interface
+ procedure :: write_buffer_wrapper_netcdf
+ procedure :: write_buffer_wrapper_domain
+ procedure :: write_buffer_wrapper_u
end type
!> Scalar buffer type to extend fmsDiagBufferContainer_type
@@ -1497,5 +1503,108 @@ function get_yaml_id(this) &
res = this%yaml_id
end function get_yaml_id
+
+!> @brief Write the buffer to the file
+subroutine write_buffer(this, fileobj, unlim_dim_level)
+ class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write
+ class(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to
+ integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+
+ select type(fileobj)
+ type is (FmsNetcdfFile_t)
+ call this%write_buffer_wrapper_netcdf(fileobj, unlim_dim_level=unlim_dim_level)
+ type is (FmsNetcdfDomainFile_t)
+ call this%write_buffer_wrapper_domain(fileobj, unlim_dim_level=unlim_dim_level)
+ type is (FmsNetcdfUnstructuredDomainFile_t)
+ call this%write_buffer_wrapper_u(fileobj, unlim_dim_level=unlim_dim_level)
+ class default
+ call mpp_error(FATAL, "The file "//trim(fileobj%path)//" is not one of the accepted types"//&
+ " only FmsNetcdfFile_t, FmsNetcdfDomainFile_t, and FmsNetcdfUnstructuredDomainFile_t are accepted.")
+ end select
+end subroutine write_buffer
+
+!> @brief Write the buffer to the FmsNetcdfFile_t fileobj
+subroutine write_buffer_wrapper_netcdf(this, fileobj, unlim_dim_level)
+ class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write
+ type(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to
+ integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+
+ character(len=:), allocatable :: varname !< name of the variable
+
+ varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
+ select type(buffer_obj=>this%diag_buffer_obj)
+ type is (outputBuffer0d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer1d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer2d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer3d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer4d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer5d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ class default
+ call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//&
+ " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.")
+ end select
+end subroutine write_buffer_wrapper_netcdf
+
+!> @brief Write the buffer to the FmsNetcdfDomainFile_t fileobj
+subroutine write_buffer_wrapper_domain(this, fileobj, unlim_dim_level)
+ class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write
+ type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< fileobj to write to
+ integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+
+ character(len=:), allocatable :: varname !< name of the variable
+
+ varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
+ select type(buffer_obj=>this%diag_buffer_obj)
+ type is (outputBuffer0d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer1d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer2d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer3d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer4d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer5d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ class default
+ call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//&
+ " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.")
+ end select
+end subroutine write_buffer_wrapper_domain
+
+!> @brief Write the buffer to the FmsNetcdfUnstructuredDomainFile_t fileobj
+subroutine write_buffer_wrapper_u(this, fileobj, unlim_dim_level)
+ class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write
+ type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fileobj !< fileobj to write to
+ integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+
+ character(len=:), allocatable :: varname !< name of the variable
+
+ varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
+ select type(buffer_obj=>this%diag_buffer_obj)
+ type is (outputBuffer0d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer1d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer2d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer3d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer4d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ type is (outputBuffer5d_type)
+ call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
+ class default
+ call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//&
+ " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.")
+ end select
+end subroutine write_buffer_wrapper_u
#endif
end module fms_diag_output_buffer_mod
diff --git a/test_fms/diag_manager/test_flexible_time.F90 b/test_fms/diag_manager/test_flexible_time.F90
index a3a78a5f8f..2dd881177d 100644
--- a/test_fms/diag_manager/test_flexible_time.F90
+++ b/test_fms/diag_manager/test_flexible_time.F90
@@ -21,15 +21,19 @@
program test_flexible_time
use fms_mod, only: fms_init, fms_end
use time_manager_mod, only: set_date, time_type, increment_date, set_calendar_type, &
- JULIAN, set_time
+ JULIAN, set_time, operator(+)
use diag_manager_mod, only: diag_manager_init, diag_axis_init, register_diag_field, &
- diag_manager_set_time_end, diag_send_complete, diag_manager_end
+ diag_manager_set_time_end, diag_send_complete, diag_manager_end, &
+ send_data
use mpp_mod, only: FATAL, mpp_error
+use platform_mod, only: r8_kind
implicit none
+real(kind=r8_kind) :: var_data(2) !< Dummy data
+logical :: used !< .True. if send_data was sucessful
type(time_type) :: Time !< Time of the simulation
-type(time_type) :: Start_Time !< Start time of the simulation
+type(time_type) :: Time_step !< Start time of the simulation
type(time_type) :: End_Time !< End Time of the simulation
integer :: i
integer :: id_z, id_var
@@ -39,18 +43,22 @@ program test_flexible_time
call diag_manager_init
!< Starting time of the simulation
-Start_Time = set_date(2,1,1,3,0,0) !02/01/01 hour 3
+Time = set_date(2,1,1,3,0,0) !02/01/01 hour 3
!< Set up a dummy variable
id_z = diag_axis_init('z', (/1. ,2. /), 'point_Z', 'z', long_name='point_Z')
-id_var = register_diag_field ('atm_mod', 'var1', (/id_z/), Start_Time, 'Var not domain decomposed', 'mullions')
+id_var = register_diag_field ('atm_mod', 'var1', (/id_z/), Time, 'Var not domain decomposed', 'mullions')
!< Set up the end of the simulation (i.e 2 days long)
End_Time = set_date(2,1,3,3,0,0)
call diag_manager_set_time_end(End_Time)
!< Set up the simulation
+Time_step = set_time (3600,0) !< 1 hour
do i=1,48
+ var_data = real(i, kind=r8_kind)
+ Time = Time + Time_step
+ used = send_data(id_var, var_data, Time)
call diag_send_complete(set_time(3600,0))
enddo
From 1d794097582274b07a3c83e9c8665ad0bca843d8 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 11 Aug 2023 13:48:37 -0400
Subject: [PATCH 119/168] feat: modern_diag_manager add fms_diag_do_reduction
(#1321)
---
CMakeLists.txt | 1 +
diag_manager/Makefile.am | 7 +-
diag_manager/diag_manager.F90 | 21 ++-
diag_manager/fms_diag_axis_object.F90 | 18 +++
diag_manager/fms_diag_field_object.F90 | 3 +-
diag_manager/fms_diag_object.F90 | 168 ++++++++++----------
diag_manager/fms_diag_reduction_methods.F90 | 129 +++++++++++++++
7 files changed, 255 insertions(+), 92 deletions(-)
create mode 100644 diag_manager/fms_diag_reduction_methods.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index e975010fdb..a0eba12a0b 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -145,6 +145,7 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_elem_weight_procs.F90
diag_manager/fms_diag_fieldbuff_update.F90
diag_manager/fms_diag_bbox.F90
+ diag_manager/fms_diag_reduction_methods.F90
drifters/cloud_interpolator.F90
drifters/drifters.F90
drifters/drifters_comm.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 0079d0b1b5..b682c39410 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -59,6 +59,7 @@ libdiag_manager_la_SOURCES = \
fms_diag_elem_weight_procs.F90 \
fms_diag_fieldbuff_update.F90 \
fms_diag_bbox.F90 \
+ fms_diag_reduction_methods.F90 \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh
@@ -73,7 +74,8 @@ diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEX
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_time_utils_mod.$(FC_MODEXT) \
- fms_diag_output_buffer_mod.$(FC_MODEXT)
+ fms_diag_output_buffer_mod.$(FC_MODEXT) \
+ fms_diag_reduction_methods_mod.$(FC_MODEXT)
fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_axis_object_mod.$(FC_MODEXT)
fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
@@ -89,6 +91,8 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD
fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \
fms_diag_fieldbuff_update_mod.$(FC_MODEXT)
fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+fms_diag_reduction_methods_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT) \
+ diag_data_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
MODFILES = \
@@ -121,6 +125,7 @@ MODFILES = \
fms_diag_bbox_mod.$(FC_MODEXT) \
fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \
fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \
+ fms_diag_reduction_methods_mod.$(FC_MODEXT) \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 7908c55e66..ef2c0392a1 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -1621,6 +1621,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
endif
END FUNCTION send_data_3d
!> @return true if send is successful
+!TODO documentation, seperate the old and new
LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, &
& mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
INTEGER, INTENT(in) :: diag_field_id
@@ -1629,7 +1630,7 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
TYPE (time_type), INTENT(in), OPTIONAL :: time
INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask
- CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask
+ CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: rmask
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
REAL :: weight1
@@ -1664,6 +1665,9 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
CHARACTER(len=128) :: error_string, error_string1
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field
+ class(*), pointer, dimension(:,:,:,:) :: field_remap !< 4d remapped pointer
+ logical, pointer, dimension(:,:,:,:) :: mask_remap !< 4d remapped pointer
+ class(*), pointer, dimension(:,:,:,:) :: rmask_remap !< 4d remapped pointer
REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask
REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! Set up array lengths for remapping
- field_modern => null()
+ field_remap => null()
+ mask_remap => null()
+ rmask_remap => null()
ie = SIZE(field,1)
je = SIZE(field,2)
ke = SIZE(field,3)
- field_modern(1:ie,1:je,1:ke,1:1) => field
+ field_remap(1:ie,1:je,1:ke,1:1) => field
+ if (present(mask)) mask_remap(1:ie,1:je,1:ke,1:1) => mask
+ if (present(rmask)) rmask_remap(1:ie,1:je,1:ke,1:1) => rmask
endif
SELECT TYPE (field)
TYPE IS (real(kind=r4_kind))
@@ -1722,9 +1730,10 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
END SELECT
! Split old and modern2023 here
modern_if: iF (use_modern_diag) then
- send_data_3d = fms_diag_object%fms_diag_accept_data(diag_field_id, field_modern, time, is_in, js_in, ks_in, &
- & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
- nullify (field_modern)
+ diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, &
+ time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
+ err_msg)
+ nullify (field_remap)
elSE ! modern_if
! oor_mask is only used for checking out of range values.
ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 8ae2a325b9..d9cf39c848 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -119,6 +119,8 @@ module fms_diag_axis_object_mod
contains
procedure :: fill_subaxis
procedure :: axis_length
+ procedure :: get_starting_index
+ procedure :: get_ending_index
END TYPE fmsDiagSubAxis_type
!> @brief Type to hold the diurnal axis
@@ -766,6 +768,22 @@ function axis_length(this) &
res = this%ending_index - this%starting_index + 1
end function
+ !> @brief Accesses its member starting_index
+ !! @return a copy of the starting_index
+ function get_starting_index(this) result(indx)
+ class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object
+ integer :: indx !< Result to return
+ indx = this%starting_index
+ end function get_starting_index
+
+ !> @brief Accesses its member ending_index
+ !! @return a copy of the ending_index
+ function get_ending_index(this) result(indx)
+ class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object
+ integer :: indx !< Result to return
+ indx = this%ending_index
+ end function get_ending_index
+
!> @brief Get the ntiles in a domain
!> @return the number of tiles in a domain
function get_ntiles(this) &
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index ff4734ab32..9592e39978 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -680,7 +680,8 @@ pure function get_mask_variant (this) &
result(rslt)
class (fmsDiagField_type), intent(in) :: this !< diag object
logical :: rslt
- rslt = this%mask_variant
+ rslt = .false.
+ if (allocated(this%mask_variant)) rslt = this%mask_variant
end function get_mask_variant
!> @brief Gets local
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 5915a604e0..208be4b2f4 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -36,6 +36,7 @@ module fms_diag_object_mod
&parse_compress_att, get_axis_id_from_name
use fms_diag_output_buffer_mod
use fms_mod, only: fms_error_handler
+use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask, set_weight
use constants_mod, only: SECONDS_PER_DAY
#endif
#if defined(_OPENMP)
@@ -83,6 +84,7 @@ module fms_diag_object_mod
procedure :: fms_diag_accept_data
procedure :: fms_diag_send_complete
procedure :: fms_diag_do_io
+ procedure :: fms_diag_do_reduction
procedure :: fms_diag_field_add_cell_measures
procedure :: allocate_diag_field_output_buffers
procedure :: fms_diag_compare_window
@@ -486,52 +488,72 @@ end function fms_diag_axis_init
!! multithreaded case.
!! \note If some of the diag manager is offloaded in the future, then it should be treated similarly
!! to the multi-threaded option for processing later
-logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is_in, js_in, ks_in, &
- mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
- class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
- INTEGER, INTENT(in) :: diag_field_id !< The ID of the input diagnostic field
- CLASS(*), DIMENSION(:,:,:,:), INTENT(in) :: field_data !< The data for the input diagnostic
- CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight used for averaging
- TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current time
- INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in !< Indicies for the variable
- LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask !< The location of the mask
- CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask !< The masking values
- CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< An error message returned
- integer :: is, js, ks !< Starting indicies of the field_data
- integer :: ie, je, ke !< Ending indicied of the field_data
- integer :: n1, n2, n3 !< Size of the 3 indicies of the field data
- integer :: omp_num_threads !< Number of openmp threads
- integer :: omp_level !< The openmp active level
- logical :: buffer_the_data !< True if the user selects to buffer the data and run the calculations
- !! later. \note This is experimental
- !TODO logical, allocatable, dimension(:,:,:) :: oor_mask !< Out of range mask
- integer :: sample !< Index along the diurnal time axis
- integer :: day !< Number of days
- integer :: second !< Number of seconds
- integer :: tick !< Number of ticks representing fractional second
- integer :: buffer_id !< Index of a buffer
- !TODO: logical :: phys_window
- character(len=128) :: error_string !< Store error text
- integer :: i !< For looping
- logical :: data_buffer_is_allocated !< .true. if the data buffer is allocated
+logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rmask, &
+ time, is_in, js_in, ks_in, &
+ ie_in, je_in, ke_in, weight, err_msg)
+ class(fmsDiagObject_type),TARGET, INTENT(inout) :: this !< Diaj_obj to fill
+ INTEGER, INTENT(in) :: diag_field_id !< The ID of the diag field
+ CLASS(*), DIMENSION(:,:,:,:), INTENT(in) :: field_data !< The data for the diag_field
+ LOGICAL, DIMENSION(:,:,:,:), pointer, INTENT(in) :: mask !< Logical mask indicating the grid
+ !! points to mask (null if no mask)
+ CLASS(*), DIMENSION(:,:,:,:), pointer, INTENT(in) :: rmask !< real mask indicating the grid
+ !! points to mask (null if no mask)
+ CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight used for averaging
+ TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current time
+ INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in !< Starting indices
+ INTEGER, INTENT(in), OPTIONAL :: ie_in, je_in, ke_in !< Ending indices
+ CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< An error message returned
+
+ integer :: is, js, ks !< Starting indicies of the field_data
+ integer :: ie, je, ke !< Ending indicies of the field_data
+ integer :: n1, n2, n3 !< Size of the 3 indicies of the field data
+ integer :: omp_num_threads !< Number of openmp threads
+ integer :: omp_level !< The openmp active level
+ logical :: buffer_the_data !< True if the user selects to buffer the data and run
+ !! the calculationslater. \note This is experimental
+ character(len=128) :: error_string !< Store error text
+ logical :: data_buffer_is_allocated !< .true. if the data buffer is allocated
+ character(len=128) :: field_info !< String holding info about the field to append to the
+ !! error message
+ logical, allocatable, dimension(:,:,:,:) :: oor_mask !< Out of range mask
+ real(kind=r8_kind) :: field_weight !< Weight to use when averaging (it will be converted
+ !! based on the type of field_data when doing the math)
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
- class(diagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields
+ field_info = " Check send data call for field:"//trim(this%FMS_diag_fields(diag_field_id)%get_varname())
- !TODO: weight is for time averaging where each time level may have a different weight
- ! call real_copy_set()
+ !< Check if time should be present for this field
+ if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) &
+ call mpp_error(FATAL, "Time must be present if the field is not static. "//trim(field_info))
- !TODO: oor_mask is only used for checking out of range values.
- ! call init_mask_3d()
+ !< Set the field_weight. If "weight" is not present it will be set to 1.0_r8_kind
+ field_weight = set_weight(weight)
- !TODO: Check improper combinations of is, ie, js, and je.
- ! if (check_indices_order()) deallocate(oor_mask)
+ !< Check that the indices are present in the correct combination
+ error_string = check_indices_order(is_in, ie_in, js_in, je_in)
+ if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
-!> Does the user want to push off calculations until send_diag_complete?
+ !< If the field has `mask_variant=.true.`, check that mask OR rmask are present
+ if (this%FMS_diag_fields(diag_field_id)%is_mask_variant()) then
+ if (.not. associated(mask) .and. .not. associated(rmask)) call mpp_error(FATAL, &
+ "The field was registered with mask_variant, but mask or rmask are not present in the send_data call. "//&
+ trim(field_info))
+ endif
+
+ !< Check that mask and rmask are not both present
+ if (associated(mask) .and. associated(rmask)) call mpp_error(FATAL, &
+ "mask and rmask are both present in the send_data call. "//&
+ trim(field_info))
+
+ !< Create the oor_mask based on the "mask" and "rmask" arguments
+ oor_mask = init_mask(rmask, mask, field_data)
+
+ !> Does the user want to push off calculations until send_diag_complete?
buffer_the_data = .false.
-!> initialize the number of threads and level to be 0
+
+ !> initialize the number of threads and level to be 0
omp_num_threads = 0
omp_level = 0
#if defined(_OPENMP)
@@ -539,9 +561,10 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is
omp_level = omp_get_level()
buffer_the_data = (omp_num_threads > 1 .AND. omp_level > 0)
#endif
-!If this is true, buffer data
+
+ !If this is true, buffer data
main_if: if (buffer_the_data) then
-!> Calculate the i,j,k start and end
+ !> Calculate the i,j,k start and end
! If is, js, or ks not present default them to 1
is = 1
js = 1
@@ -568,60 +591,19 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is
call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.)
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.)
!$omp end critical
+ !TODO Save the field_weight and the oor_mask to use later in the calculations
call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data,&
is, js, ks, ie, je, ke)
fms_diag_accept_data = .TRUE.
return
else
-!!TODO: Loop through fields and do averages/math functions
-
call this%allocate_diag_field_output_buffers(field_data, diag_field_id)
- do i = 1, size(this%FMS_diag_fields(diag_field_id)%buffer_ids)
- buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(i)
-
- !!TODO: Check if the field is a physics window
- !! phys_window = fms_diag_compare_window()
-
- !!TODO: Get local start and end indices on 3 axes for regional output
-
- !> Compute the diurnal index
- sample = 1
- if (present(time)) then
- call get_time(time, second, day, tick) !< Current time in days and seconds
- ptr_diag_field_yaml => diag_yaml%get_diag_field_from_id(buffer_id)
- sample = floor((second + real(tick) / get_ticks_per_second()) &
- & * ptr_diag_field_yaml%get_n_diurnal() / SECONDS_PER_DAY) + 1
- end if
-
- !!TODO: Get the vertical layer start and end indices
-
- !!TODO: Initialize output time for fields output every time step
-
- !< Check if time should be present for this field
- if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) then
- write(error_string, '(a,"/",a)') trim(this%FMS_diag_fields(diag_field_id)%get_modname()),&
- & trim(this%FMS_diag_fields(diag_field_id)%diag_field(i)%get_var_outname())
- if (fms_error_handler('fms_diag_object_mod::fms_diag_accept_data', 'module/output_name: '&
- &//trim(error_string)//', time must be present for nonstatic field', err_msg)) then
- !!TODO: deallocate local pointers/allocatables if needed
- return
- end if
- end if
-
- !!TODO: Is it time to output for this field? CAREFUL ABOUT > vs >= HERE
- !--- The fields send out within openmp parallel region will be written out in
- !--- diag_send_complete.
-
- !!TODO: Is check to bounds of current field necessary?
-
- !!TODO: Take care of submitted field data
-
- enddo
+ fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, &
+ time, is, js, ks, ie, je, ke)
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.)
- fms_diag_accept_data = .TRUE.
return
end if main_if
-!> Return false if nothing is done
+ !> Return false if nothing is done
fms_diag_accept_data = .FALSE.
return
#endif
@@ -734,6 +716,24 @@ subroutine fms_diag_do_io(this, is_end_of_run)
#endif
end subroutine fms_diag_do_io
+ !> @brief Computes average, min, max, rms error, etc.
+ !! based on the specified reduction method for the field.
+ !> @return .True. if no error occurs.
+logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, &
+ time, is_in, js_in, ks_in, ie_in, je_in, ke_in)
+ class(fmsDiagObject_type), intent(in), target :: this !< Diag Object
+ class(*), intent(in) :: field_data(:,:,:,:) !< Field data
+ integer, intent(in) :: diag_field_id !< ID of the input field
+ logical, intent(in), target :: oor_mask(:,:,:,:) !< mask
+ real(kind=r8_kind), intent(in) :: weight !< Must be a updated weight
+ type(time_type), intent(in), optional :: time !< Current time
+ integer, intent(in), optional :: is_in, js_in, ks_in !< Starting indices of the variable
+ integer, intent(in), optional :: ie_in, je_in, ke_in !< Ending indices of the variable
+
+ !TODO Everything
+ fms_diag_do_reduction = .true.
+end function fms_diag_do_reduction
+
!> @brief Adds the diag ids of the Area and or Volume of the diag_field_object
subroutine fms_diag_field_add_cell_measures(this, diag_field_id, area, volume)
class(fmsDiagObject_type), intent (inout) :: this !< The diag object
diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90
new file mode 100644
index 0000000000..8962638c04
--- /dev/null
+++ b/diag_manager/fms_diag_reduction_methods.F90
@@ -0,0 +1,129 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @defgroup fms_diag_reduction_methods_mod fms_diag_reduction_methods_mod
+!> @ingroup diag_manager
+!! @brief fms_diag_reduction_methods_mod contains routines that are meant to be used for
+!! error checking and setting up to do the reduction methods
+
+!> @file
+!> @brief File for @ref fms_diag_reduction_methods_mod
+
+!> @addtogroup fms_diag_reduction_methods_mod
+!> @{
+module fms_diag_reduction_methods_mod
+ use platform_mod, only: r8_kind, r4_kind
+ implicit none
+ private
+
+ public :: check_indices_order, init_mask, set_weight
+
+ contains
+
+ !> @brief Checks improper combinations of is, ie, js, and je.
+ !! @return The error message, empty string if no errors were found
+ !> @note accept_data works in either one or another of two modes.
+ !! 1. Input field is a window (e.g. FMS physics)
+ !! 2. Input field includes halo data
+ !! It cannot handle a window of data that has halos.
+ !! (A field with no windows or halos can be thought of as a special case of either mode.)
+ !! The logic for indexing is quite different for these two modes, but is not clearly separated.
+ !! If both the beggining and ending indices are present, then field is assumed to have halos.
+ !! If only beggining indices are present, then field is assumed to be a window.
+ !> @par
+ !! There are a number of ways a user could mess up this logic, depending on the combination
+ !! of presence/absence of is,ie,js,je. The checks below should catch improper combinations.
+ pure function check_indices_order(is_in, ie_in, js_in, je_in) &
+ result(error_msg)
+ integer, intent(in), optional :: is_in, ie_in, js_in, je_in !< Indices passed to fms_diag_accept_data()
+ character(len=128) :: error_msg !< An error message used only for testing purpose!!!
+
+ error_msg = ""
+ IF ( PRESENT(ie_in) ) THEN
+ IF ( .NOT.PRESENT(is_in) ) THEN
+ error_msg = 'ie_in present without is_in'
+ return
+ END IF
+ IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN
+ error_msg = 'is_in and ie_in present, but js_in present without je_in'
+ return
+ END IF
+ END IF
+
+ IF ( PRESENT(je_in) ) THEN
+ IF ( .NOT.PRESENT(js_in) ) THEN
+ error_msg = 'je_in present without js_in'
+ return
+ END IF
+ IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN
+ error_msg = 'js_in and je_in present, but is_in present without ie_in'
+ return
+ END IF
+ END IF
+ end function check_indices_order
+
+ !> @brief Sets the logical mask based on mask or rmask
+ !> @return logical mask
+ function init_mask(rmask, mask, field) &
+ result(oor_mask)
+ LOGICAL, DIMENSION(:,:,:,:), pointer, INTENT(in) :: mask !< The location of the mask
+ CLASS(*), DIMENSION(:,:,:,:), pointer, INTENT(in) :: rmask !< The masking values
+ CLASS(*), DIMENSION(:,:,:,:), intent(in) :: field !< Field_data
+
+ logical, allocatable, dimension(:,:,:,:) :: oor_mask !< mask
+
+ ALLOCATE(oor_mask(SIZE(field, 1), SIZE(field, 2), SIZE(field, 3), SIZE(field, 4)))
+ oor_mask = .true.
+
+ if (associated(mask)) then
+ oor_mask = mask
+ elseif (associated(rmask)) then
+ select type (rmask)
+ type is (real(kind=r8_kind))
+ WHERE (rmask < 0.5_r8_kind) oor_mask = .FALSE.
+ type is (real(kind=r4_kind))
+ WHERE (rmask < 0.5_r4_kind) oor_mask = .FALSE.
+ end select
+ endif
+
+ end function init_mask
+
+ !> @brief Sets the weight based on the weight passed into send_data (1.0_r8_kind if the weight is not passed in)
+ !! The weight will be saved as an r8 and converted to r4 as needed
+ !! @return weight to use when averaging
+ pure function set_weight(weight) &
+ result(out_weight)
+ CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight use when averaging
+
+ real(kind=r8_kind) :: out_weight
+
+ out_weight = 1.0_r8_kind
+ if (present(weight)) then
+ select type(weight)
+ type is (real(kind=r8_kind))
+ out_weight = real(weight, kind = r8_kind)
+ type is (real(kind=r4_kind))
+ out_Weight = real(weight, kind = r8_kind)
+ end select
+ endif
+ end function set_weight
+
+end module fms_diag_reduction_methods_mod
+!> @}
+! close documentation grouping
\ No newline at end of file
From 4d36e269016958cf758b0e79f93235a536c0e4d1 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 15 Aug 2023 07:42:03 -0400
Subject: [PATCH 120/168] fix: Modern diag manager refactor buffers (#1332)
---
diag_manager/fms_diag_file_object.F90 | 6 +-
diag_manager/fms_diag_object.F90 | 68 +-
diag_manager/fms_diag_output_buffer.F90 | 1610 +++-----------------
test_fms/diag_manager/test_diag_buffer.F90 | 295 ++--
4 files changed, 351 insertions(+), 1628 deletions(-)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 84c3f3980e..665a6f1683 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -45,7 +45,7 @@ module fms_diag_file_object_mod
fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, &
fmsDiagDiurnalAxis_type, create_new_z_subaxis
use fms_diag_field_object_mod, only: fmsDiagField_type
-use fms_diag_output_buffer_mod, only: fmsDiagOutputBufferContainer_type, fmsDiagOutputBuffer_class
+use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_type
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, &
uppercase, lowercase
@@ -714,7 +714,7 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id, buffer_id, output
integer, intent(in) :: yaml_id !< Yaml id of the field section for
!! this var
integer, intent(in) :: buffer_id !< ID of the buffer
- type(fmsDiagOutputBufferContainer_type), intent(inout) :: output_buffers(:) !< Array of output buffers
+ type(fmsDiagOutputBuffer_type), intent(inout) :: output_buffers(:) !< Array of output buffers
type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry
@@ -1124,7 +1124,7 @@ end subroutine write_time_metadata
subroutine write_field_data(this, field_obj, buffer_obj)
class(fmsDiagFileContainer_type), intent(in), target :: this !< The diag file object to write to
type(fmsDiagField_type), intent(in), target :: field_obj(:) !< The field object to write from
- type(fmsDiagOutputBufferContainer_type), intent(in), target :: buffer_obj(:) !< The buffer object with the data
+ type(fmsDiagOutputBuffer_type), intent(in), target :: buffer_obj(:) !< The buffer object with the data
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
class(FmsNetcdfFile_t), pointer :: fileobj !< Fileobj to write to
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 208be4b2f4..789b6e55e6 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -54,7 +54,7 @@ module fms_diag_object_mod
!TODO: Remove FMS prefix from variables in this type
class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files
class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields
- type(fmsDiagOutputBufferContainer_type), allocatable :: FMS_diag_output_buffers(:) !< array of output buffer objects
+ type(fmsDiagOutputBuffer_type), allocatable :: FMS_diag_output_buffers(:) !< array of output buffer objects
!! one for each variable in the diag_table.yaml
integer, private :: registered_buffers = 0 !< number of registered buffers, per dimension
class(fmsDiagAxisContainer_type), allocatable :: diag_axis(:) !< Array of diag_axis
@@ -150,9 +150,7 @@ subroutine fms_diag_object_end (this, time)
call this%fms_diag_do_io(is_end_of_run=.true.)
!TODO: Deallocate diag object arrays and clean up all memory
do i=1, size(this%FMS_diag_output_buffers)
- if(allocated(this%FMS_diag_output_buffers(i)%diag_buffer_obj)) then
- call this%FMS_diag_output_buffers(i)%diag_buffer_obj%flush_buffer()
- endif
+ call this%FMS_diag_output_buffers(i)%flush_buffer()
enddo
deallocate(this%FMS_diag_output_buffers)
this%axes_initialized = fms_diag_axis_object_end(this%diag_axis)
@@ -851,11 +849,11 @@ function get_diag_buffer(this, bufferid) &
result(rslt)
class(fmsDiagObject_type), intent(in) :: this
integer, intent(in) :: bufferid
- class(fmsDiagOutputBuffer_class),allocatable:: rslt
+ class(fmsDiagOutputBuffer_type),allocatable:: rslt
if( (bufferid .gt. UBOUND(this%FMS_diag_output_buffers, 1)) .or. &
(bufferid .lt. LBOUND(this%FMS_diag_output_buffers, 1))) &
call mpp_error(FATAL, 'get_diag_bufer: invalid bufferid given')
- rslt = this%FMS_diag_output_buffers(bufferid)%diag_buffer_obj
+ rslt = this%FMS_diag_output_buffers(bufferid)
end function
#endif
@@ -999,9 +997,9 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
integer :: ndims !< Number of dimensions in the input field data
integer :: buffer_id !< Buffer index of FMS_diag_buffers
integer :: num_diurnal_samples !< Number of diurnal samples from diag_yaml
- integer, allocatable :: axes_length(:) !< Length of each axis
+ integer :: axes_length(5) !< Length of each axis
integer :: i, j !< For looping
- class(fmsDiagOutputBuffer_class), pointer :: ptr_diag_buffer_obj !< Pointer to the buffer class
+ class(fmsDiagOutputBuffer_type), pointer :: ptr_diag_buffer_obj !< Pointer to the buffer class
class(DiagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields
integer, allocatable :: axis_ids(:) !< Pointer to indices of axes of the field variable
integer :: var_type !< Stores type of the field data (r4, r8, i4, i8, and string) represented as an integer.
@@ -1059,13 +1057,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
ptr_diag_field_yaml => diag_yaml%diag_fields(yaml_id)
num_diurnal_samples = ptr_diag_field_yaml%get_n_diurnal() !< Get number of diurnal samples
- ! If diurnal axis exists, fill lengths of axes.
- if (num_diurnal_samples .ne. 0) then
- allocate(axes_length(ndims + 1)) !< Include extra length for the diurnal axis
- else
- allocate(axes_length(ndims))
- endif
-
+ axes_length = 1
do j = 1, ndims
axes_length(j) = this%fms_get_axis_length(axis_ids(j))
enddo
@@ -1075,52 +1067,12 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
ndims = ndims + 1 !< Add one more dimension for the diurnal axis
endif
- ! Allocates diag_buffer_obj to the correct outputBuffer type based on the dimension:
- ! outputBuffer0d_type, outputBuffer1d_type, outputBuffer2d_type, outputBuffer3d_type,
- ! outputBuffer4d_type or outputBuffer5d_type.
- if (.not. allocated(this%FMS_diag_output_buffers(buffer_id)%diag_buffer_obj)) then
- call fms_diag_output_buffer_create_container(ndims, this%FMS_diag_output_buffers(buffer_id))
- end if
-
- ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id)%diag_buffer_obj
-
- select type (ptr_diag_buffer_obj)
- type is (outputBuffer0d_type) !< Scalar buffer
- if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
- call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), & !< If scalar field variable
- this%FMS_diag_fields(field_id)%get_varname())
- call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
- type is (outputBuffer1d_type) !< 1D buffer
- if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
- call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1), &
- this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
- call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
- type is (outputBuffer2d_type) !< 2D buffer
- if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
- call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:2), &
+ ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id)
+ call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), ndims, axes_length(1:5), &
this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
- call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
- type is (outputBuffer3d_type) !< 3D buffer
- if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
- call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:3), &
- this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
- call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
- type is (outputBuffer4d_type) !< 4D buffer
- if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
- call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:4), &
- this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
- call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
- type is (outputBuffer5d_type) !< 5D buffer
- if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back
- call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:5), &
- this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
- call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
- class default
- call mpp_error( FATAL, 'allocate_diag_field_output_buffers: invalid buffer type')
- end select
+ call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
if (allocated(axis_ids)) deallocate(axis_ids)
- deallocate(axes_length)
enddo
this%FMS_diag_fields(field_id)%buffer_allocated = .true.
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 3f2e1db095..7c2e706908 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -37,34 +37,20 @@ module fms_diag_output_buffer_mod
private
-!> @brief Object that holds buffered data and other diagnostics
-!! Abstract to ensure use through its extensions(buffer0-5d types)
-type, abstract :: fmsDiagOutputBuffer_class
- integer, allocatable, private :: buffer_id !< index in buffer list
- integer, allocatable, public :: num_elements(:) !< used in time-averaging
- class(*), allocatable, public :: count_0d(:) !< used in time-averaging along with
- !! counter which is stored in the child types (bufferNd)
- integer(i4_kind), public :: buffer_type ! holds an allocated buffer0-5d object
-type :: fmsDiagOutputBufferContainer_type
- class(fmsDiagOutputBuffer_class), allocatable :: diag_buffer_obj !< any 0-5d buffer object
- integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
- integer :: field_id !< The id of the field the buffer belongs to
- integer :: yaml_id !< The id of the yaml id the buffer belongs to
+type :: fmsDiagOutputBuffer_type
+ integer :: buffer_id !< index in buffer list
+ integer(i4_kind) :: buffer_type !< set to allocated data type & kind value, one of i4,i8,r4,r8
+ class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array
+ integer :: ndim !< Number of dimensions for each variable
+ integer, allocatable :: buffer_dims(:) !< holds the size of each dimension in the buffer
+ class(*), allocatable :: counter(:,:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
+ integer, allocatable :: num_elements(:) !< used in time-averaging
+ class(*), allocatable :: count_0d(:) !< used in time-averaging along with
+ !! counter which is stored in the child types (bufferNd)
+ integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
+ integer :: field_id !< The id of the field the buffer belongs to
+ integer :: yaml_id !< The id of the yaml id the buffer belongs to
contains
procedure :: add_axis_ids
@@ -78,89 +64,18 @@ module fms_diag_output_buffer_mod
procedure :: write_buffer_wrapper_netcdf
procedure :: write_buffer_wrapper_domain
procedure :: write_buffer_wrapper_u
-end type
-
-!> Scalar buffer type to extend fmsDiagBufferContainer_type
-type, extends(fmsDiagOutputBuffer_class) :: outputBuffer0d_type
- class(*), allocatable :: buffer(:) !< "scalar" numeric buffer value
- !! will only be allocated to hold 1 value
- class(*), allocatable :: counter(:) !< (x,y,z, time-of-day) used in the time averaging functions
- contains
- procedure :: allocate_buffer => allocate_buffer_0d
- procedure :: initialize_buffer => initialize_buffer_0d
- procedure :: add_to_buffer => add_to_buffer_0d
- procedure :: get_buffer => get_0d
-
-end type outputBuffer0d_type
-
-!> 1D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagOutputBuffer_class) :: outputBuffer1d_type
- class(*), allocatable :: buffer(:) !< 1D numeric data array
- class(*), allocatable :: counter(:) !< (x,y,z, time-of-day) used in the time averaging functions
- contains
- procedure :: allocate_buffer => allocate_buffer_1d
- procedure :: initialize_buffer => initialize_buffer_1d
- procedure :: add_to_buffer => add_to_buffer_1d
- procedure :: get_buffer => get_1d
-end type outputBuffer1d_type
-
-!> 2D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagOutputBuffer_class) :: outputBuffer2d_type
- class(*), allocatable :: buffer(:,:) !< 2D numeric data array
- class(*), allocatable :: counter(:,:) !< (x,y,z, time-of-day) used in the time averaging functions
- contains
- procedure :: allocate_buffer => allocate_buffer_2d
- procedure :: initialize_buffer => initialize_buffer_2d
- procedure :: add_to_buffer => add_to_buffer_2d
- procedure :: get_buffer => get_2d
-end type outputBuffer2d_type
-
-!> 3D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagOutputBuffer_class) :: outputBuffer3d_type
- class(*), allocatable :: buffer(:,:,:) !< 3D numeric data array
- class(*), allocatable :: counter(:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
- contains
- procedure :: allocate_buffer => allocate_buffer_3d
- procedure :: initialize_buffer => initialize_buffer_3d
- procedure :: add_to_buffer => add_to_buffer_3d
- procedure :: get_buffer => get_3d
-end type outputBuffer3d_type
-
-!> 4D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagOutputBuffer_class) :: outputBuffer4d_type
- class(*), allocatable :: buffer(:,:,:,:) !< 4D numeric data array
- class(*), allocatable :: counter(:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
- contains
- procedure :: allocate_buffer => allocate_buffer_4d
- procedure :: initialize_buffer => initialize_buffer_4d
- procedure :: add_to_buffer => add_to_buffer_4d
- procedure :: get_buffer => get_4d
-end type outputBuffer4d_type
+ procedure :: allocate_buffer
+ procedure :: initialize_buffer
+ procedure :: get_buffer
+ procedure :: flush_buffer
-!> 5D buffer type to extend fmsDiagBuffer_class
-type, extends(fmsDiagOutputBuffer_class) :: outputBuffer5d_type
- class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array
- class(*), allocatable :: counter(:,:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
- contains
- procedure :: allocate_buffer => allocate_buffer_5d
- procedure :: initialize_buffer => initialize_buffer_5d
- procedure :: add_to_buffer => add_to_buffer_5d
- procedure :: get_buffer => get_5d
-end type outputBuffer5d_type
+end type fmsDiagOutputBuffer_type
! public types
-public :: outputBuffer0d_type
-public :: outputBuffer1d_type
-public :: outputBuffer2d_type
-public :: outputBuffer3d_type
-public :: outputBuffer4d_type
-public :: outputBuffer5d_type
-public :: fmsDiagOutputBuffer_class
-public :: fmsDiagOutputBufferContainer_type
+public :: fmsDiagOutputBuffer_type
! public routines
public :: fms_diag_output_buffer_init
-public :: fms_diag_output_buffer_create_container
contains
@@ -169,963 +84,159 @@ module fms_diag_output_buffer_mod
!> Initializes a list of diag buffers
!> @returns true if allocation is successfull
logical function fms_diag_output_buffer_init(buffobjs, buff_list_size)
- type(fmsDiagOutputBufferContainer_type), allocatable, intent(out) :: buffobjs(:) !< an array of buffer container types
- !! to allocate
- integer, intent(in) :: buff_list_size !< size of buffer array to allocate
+ type(fmsDiagOutputBuffer_type), allocatable, intent(out) :: buffobjs(:) !< an array of buffer container types
+ !! to allocate
+ integer, intent(in) :: buff_list_size !< size of buffer array to allocate
+
if (allocated(buffobjs)) call mpp_error(FATAL,'fms_diag_buffer_init: passed in buffobjs array is already allocated')
allocate(buffobjs(buff_list_size))
fms_diag_output_buffer_init = allocated(buffobjs)
end function fms_diag_output_buffer_init
-!> Creates a container type encapsulating a new buffer object for the given dimensions.
-!! The buffer object will still need to be allocated to a type via allocate_buffer() before use.
-!> @result A fmsDiagBufferContainer_type that holds a bufferNd_type, where N is buff_dims
-subroutine fms_diag_output_buffer_create_container(buff_dims, buffer_obj)
- integer, intent(in) :: buff_dims !< dimensions
- type(fmsDiagOutputBufferContainer_type), intent(inout) :: buffer_obj
-
- character(len=5) :: dim_output !< string to output buff_dims on error
-
- select case (buff_dims)
- case (0)
- allocate(outputBuffer0d_type :: buffer_obj%diag_buffer_obj)
- case (1)
- allocate(outputBuffer1d_type :: buffer_obj%diag_buffer_obj)
- case (2)
- allocate(outputBuffer2d_type :: buffer_obj%diag_buffer_obj)
- case (3)
- allocate(outputBuffer3d_type :: buffer_obj%diag_buffer_obj)
- case (4)
- allocate(outputBuffer4d_type :: buffer_obj%diag_buffer_obj)
- case (5)
- allocate(outputBuffer5d_type :: buffer_obj%diag_buffer_obj)
- case default
- write( dim_output, *) buff_dims
- dim_output = adjustl(dim_output)
- call mpp_error(FATAL, 'fms_diag_buffer_create_container: invalid number of dimensions given:' // dim_output //&
- '. Must be 0-5')
- end select
-end subroutine fms_diag_output_buffer_create_container
-
!!--------generic routines for any fmsDiagBuffer_class objects
-!> Setter for buffer_id for any buffer objects
-subroutine set_buffer_id(this, id)
- class(fmsDiagOutputBuffer_class), intent(inout) :: this !< buffer object to set id for
- integer, intent(in) :: id !< positive integer id to set
- if (.not.allocated(this%buffer_id) ) allocate(this%buffer_id)
- this%buffer_id = id
-end subroutine set_buffer_id
-
-!> Remaps 0-5d data buffer from the given object onto a 5d array pointer.
-!> @returns a 5D remapped buffer, with 1:1 for any added dimensions.
-function remap_buffer(buffobj, field_name, has_diurnal_axis)
- class(fmsDiagOutputBuffer_class), target, intent(inout) :: buffobj !< any dimension buffer object
- class(*), pointer :: remap_buffer(:,:,:,:,:)
- character(len=*), intent(in) :: field_name !< name of field for error output
- logical, intent(in) :: has_diurnal_axis !< true if the buffer has diurnal axis
-
- ! get num dimensions from type extension
- select type (buffobj)
- type is (outputBuffer0d_type)
- if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
- "for field:" // field_name)
- remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:1) => buffobj%buffer
- type is (outputBuffer1d_type)
- if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
- "for field:" // field_name)
- remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:1) => buffobj%buffer(1:size(buffobj%buffer,1))
- type is (outputBuffer2d_type)
- if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
- "for field:" // field_name)
- if (has_diurnal_axis) then
- remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:size(buffobj%buffer,2)) => buffobj%buffer(:,:)
- else
- remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:1, 1:1, 1:1) => buffobj%buffer(:,:)
- end if
- type is (outputBuffer3d_type)
- if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
- "for field:" // field_name)
- if (has_diurnal_axis) then
- remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:1, 1:1, &
- 1:size(buffobj%buffer,3)) => buffobj%buffer(:,:,:)
- else
- remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), &
- 1:size(buffobj%buffer,3), 1:1, 1:1) => buffobj%buffer(:,:,:)
- end if
- type is (outputBuffer4d_type)
- if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
- "for field:" // field_name)
- if (has_diurnal_axis) then
- remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
- 1:1, 1:size(buffobj%buffer,4)) => buffobj%buffer(:,:,:,:)
- else
- remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
- 1:size(buffobj%buffer,4), 1:1) => buffobj%buffer(:,:,:,:)
- end if
- type is (outputBuffer5d_type)
- if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // &
- "for field:" // field_name)
- remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), &
- 1:size(buffobj%buffer,4), 1:size(buffobj%buffer,5)) => buffobj%buffer(:,:,:,:,:)
- class default
- call mpp_error( FATAL, 'remap_buffer_pointer: invalid buffer type for remapping')
- end select
-
-end function remap_buffer
-
-!> Deallocates data fields from a buffer object.
-subroutine flush_buffer(this)
- class(fmsDiagOutputBuffer_class), intent(inout) :: this !< any buffer object
- select type (this)
- type is (outputBuffer0d_type)
- if (allocated(this%buffer)) deallocate(this%buffer)
- if (allocated(this%counter)) deallocate(this%counter)
- type is (outputBuffer1d_type)
- if (allocated(this%buffer)) deallocate(this%buffer)
- if (allocated(this%counter)) deallocate(this%counter)
- type is (outputBuffer2d_type)
- if (allocated(this%buffer)) deallocate(this%buffer)
- if (allocated(this%counter)) deallocate(this%counter)
- type is (outputBuffer3d_type)
- if (allocated(this%buffer)) deallocate(this%buffer)
- if (allocated(this%counter)) deallocate(this%counter)
- type is (outputBuffer4d_type)
- if (allocated(this%buffer)) deallocate(this%buffer)
- if (allocated(this%counter)) deallocate(this%counter)
- type is (outputBuffer5d_type)
- if (allocated(this%buffer)) deallocate(this%buffer)
- if (allocated(this%counter)) deallocate(this%counter)
- end select
- if (allocated(this%buffer_id)) deallocate(this%buffer_id)
- if (allocated(this%count_0d)) deallocate(this%count_0d)
- if (allocated(this%num_elements)) deallocate(this%num_elements)
- if (allocated(this%buffer_dims)) deallocate(this%buffer_dims)
-end subroutine flush_buffer
-
-!! -----------Type-specific routines for buffer0-5d
-
-!> Allocates scalar buffer data to the given buff_type.
-subroutine allocate_buffer_0d(this, buff_type, field_name, diurnal_samples)
- class(outputBuffer0d_type), intent(inout), target :: this !< scalar buffer object
- class(*),intent(in) :: buff_type !< allocates to the given type, value does not matter
- character(len=*), intent(in) :: field_name !< field name for error output
- integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
- integer :: n_samples !< number of diurnal samples, defaults to 1
-
- if(present(diurnal_samples)) then
- n_samples = diurnal_samples
- else
- n_samples = 1
- endif
-
- if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_0d: buffer already allocated for field:"// &
- field_name)
- select type (buff_type)
- type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: this%buffer(1))
- allocate(integer(kind=i4_kind) :: this%counter(1))
- allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0_i4_kind
- this%count_0d = 0_i4_kind
- this%buffer_type = i4
- type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: this%buffer(1))
- allocate(integer(kind=i8_kind) :: this%counter(1))
- allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0_i8_kind
- this%count_0d = 0_i8_kind
- this%buffer_type = i8
- type is (real(kind=r4_kind))
- allocate(real(kind=r4_kind) :: this%buffer(1))
- allocate(real(kind=r4_kind) :: this%counter(1))
- allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r4_kind
- this%count_0d = 0.0_r4_kind
- this%buffer_type = r4
- type is (real(kind=r8_kind))
- allocate(real(kind=r8_kind) :: this%buffer(1))
- allocate(real(kind=r8_kind) :: this%counter(1))
- allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r8_kind
- this%count_0d = 0.0_r8_kind
- this%buffer_type = r8
- class default
- call mpp_error("allocate_buffer_0d", &
- "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
- "for field:" // field_name, &
- FATAL)
- end select
-
- allocate(this%num_elements(n_samples))
- allocate(this%buffer_dims(1))
- this%num_elements = 0
- this%buffer_dims(1) = 1
-
-end subroutine allocate_buffer_0d
-
-!> Allocates 1D buffer data to given buff_type.
-subroutine allocate_buffer_1d(this, buff_type, buff_size, field_name, diurnal_samples)
- class(outputBuffer1d_type), intent(inout), target :: this !< scalar buffer object
- class(*),intent(in) :: buff_type !< allocates to the type of buff_type
- integer, intent(in) :: buff_size !< dimension bounds
- character(len=*), intent(in) :: field_name !< field name for error output
- integer, intent(in), optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
- integer :: n_samples !< number of diurnal samples, defaults to 1
-
- if(present(diurnal_samples)) then
- n_samples = diurnal_samples
- else
- n_samples = 1
- endif
-
- if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_1d: buffer already allocated for field:" // &
- field_name)
- select type (buff_type)
- type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: this%buffer(buff_size))
- allocate(integer(kind=i4_kind) :: this%counter(buff_size))
- allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0_i4_kind
- this%count_0d = 0_i4_kind
- this%buffer_type = i4
- type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: this%buffer(buff_size))
- allocate(integer(kind=i8_kind) :: this%counter(buff_size))
- allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0_i8_kind
- this%count_0d = 0_i8_kind
- this%buffer_type = i8
- type is (real(kind=r4_kind))
- allocate(real(kind=r4_kind) :: this%buffer(buff_size))
- allocate(real(kind=r4_kind) :: this%count_0d(buff_size))
- allocate(real(kind=r4_kind) :: this%counter(n_samples))
- this%counter = 0.0_r4_kind
- this%count_0d = 0.0_r4_kind
- this%buffer_type = r4
- type is (real(kind=r8_kind))
- allocate(real(kind=r8_kind) :: this%buffer(buff_size))
- allocate(real(kind=r8_kind) :: this%count_0d(buff_size))
- allocate(real(kind=r8_kind) :: this%counter(n_samples))
- this%counter = 0.0_r8_kind
- this%count_0d = 0.0_r8_kind
- this%buffer_type = r8
- class default
- call mpp_error("allocate_buffer_1d", &
- "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4 " // &
- "for field:" // field_name, &
- FATAL)
- end select
-
- allocate(this%num_elements(n_samples))
- allocate(this%buffer_dims(1))
- this%num_elements = 0
- this%count_0d = 0
- this%buffer_dims(1) = buff_size
-
-end subroutine allocate_buffer_1d
-
-!> Allocates a 2D buffer to given buff_type.
-subroutine allocate_buffer_2d(this, buff_type, buff_sizes, field_name, diurnal_samples)
- class(outputBuffer2d_type), intent(inout), target :: this !< 2D buffer object
- class(*),intent(in) :: buff_type !< allocates to the type of buff_type
- integer, intent(in) :: buff_sizes(2) !< dimension sizes
- integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
- integer :: n_samples !< number of diurnal samples, defaults to 1
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(present(diurnal_samples)) then
- n_samples = diurnal_samples
- else
- n_samples = 1
- endif
-
- if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_2d: buffer already allocated for field: " // &
- field_name)
- select type (buff_type)
- type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
- allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
- allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0_i4_kind
- this%count_0d = 0_i4_kind
- this%buffer_type = i4
- type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
- allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
- allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0_i8_kind
- this%count_0d = 0_i8_kind
- this%buffer_type = i8
- type is (real(kind=r4_kind))
- allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
- allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
- allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r4_kind
- this%count_0d = 0.0_r4_kind
- this%buffer_type = r4
- type is (real(kind=r8_kind))
- allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1), buff_sizes(2)))
- allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1), buff_sizes(2)))
- allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r8_kind
- this%count_0d = 0.0_r8_kind
- this%buffer_type = r8
- class default
- call mpp_error("allocate_buffer_1d", &
- "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
- "for field:" // field_name, &
- FATAL)
- end select
- allocate(this%num_elements(n_samples))
- allocate(this%buffer_dims(2))
- this%num_elements = 0
- this%buffer_dims(1) = buff_sizes(1)
- this%buffer_dims(2) = buff_sizes(2)
-
-end subroutine allocate_buffer_2d
-
-!> Allocates a 3D buffer to given buff_type.
-subroutine allocate_buffer_3d(this, buff_type, buff_sizes, field_name, diurnal_samples)
- class(outputBuffer3d_type), intent(inout), target :: this !< 3D buffer object
- class(*),intent(in) :: buff_type !< allocates to the type of buff_type
- integer, intent(in) :: buff_sizes(3) !< dimension sizes
- integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
- integer :: n_samples !< number of diurnal samples, defaults to 1
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(present(diurnal_samples)) then
- n_samples = diurnal_samples
- else
- n_samples = 1
- endif
-
- if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_3d: buffer already allocated for field" // &
- field_name)
- select type (buff_type)
- type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
- allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3)))
- allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0_i4_kind
- this%count_0d = 0_i4_kind
- this%buffer_type = i4
- type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
- allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3)))
- allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0_i8_kind
- this%count_0d = 0_i8_kind
- this%buffer_type = i8
- type is (real(kind=r4_kind))
- allocate(real(kind=r4_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
- allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3)))
- allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r4_kind
- this%count_0d = 0.0_r4_kind
- this%buffer_type = r4
- type is (real(kind=r8_kind))
- allocate(real(kind=r8_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
- allocate(real(kind=r8_kind) :: this%counter( buff_sizes(1),buff_sizes(2), buff_sizes(3)))
- allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r8_kind
- this%count_0d = 0.0_r8_kind
- this%buffer_type = r8
- class default
- call mpp_error("allocate_buffer_3d", &
- "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
- "for field:" // field_name, FATAL)
- end select
-
- allocate(this%num_elements(n_samples))
- this%num_elements = 0
- this%count_0d = 0
- allocate(this%buffer_dims(3))
- this%buffer_dims(1) = buff_sizes(1)
- this%buffer_dims(2) = buff_sizes(2)
- this%buffer_dims(3) = buff_sizes(3)
-
-end subroutine allocate_buffer_3d
-
-!> Allocates a 4D buffer to given buff_type.
-subroutine allocate_buffer_4d(this, buff_type, buff_sizes, field_name, diurnal_samples)
- class(outputBuffer4d_type), intent(inout), target :: this !< 4D buffer object
- class(*),intent(in) :: buff_type !< allocates to the type of buff_type
- integer, intent(in) :: buff_sizes(4) !< dimension buff_sizes
- character(len=*), intent(in) :: field_name !< field name for error output
- integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
- integer :: n_samples !< number of diurnal samples, defaults to 1
-
- if(present(diurnal_samples)) then
- n_samples = diurnal_samples
- else
- n_samples = 1
- endif
-
- if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_4d: buffer already allocated for field:" // &
- field_name)
-
- select type (buff_type)
- type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
- allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
- allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0_i4_kind
- this%count_0d = 0_i4_kind
- this%buffer_type = i4
- type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
- allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
- allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0_i8_kind
- this%count_0d = 0_i8_kind
- this%buffer_type = i8
- type is (real(kind=r4_kind))
- allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
- allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
- allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r4_kind
- this%count_0d = 0.0_r4_kind
- this%buffer_type = r4
- type is (real(kind=r8_kind))
- allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
- allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
- allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r8_kind
- this%count_0d = 0.0_r8_kind
- this%buffer_type = r8
- class default
- call mpp_error("allocate_buffer_4d", &
- "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
- "for field:" // field_name, FATAL)
- end select
-
- allocate(this%num_elements(n_samples))
- this%num_elements = 0
- this%count_0d = 0
- allocate(this%buffer_dims(4))
- this%buffer_dims(1) = buff_sizes(1)
- this%buffer_dims(2) = buff_sizes(2)
- this%buffer_dims(3) = buff_sizes(3)
- this%buffer_dims(4) = buff_sizes(4)
-
-end subroutine allocate_buffer_4d
-
-!> Allocates a 5D buffer to given buff_type.
-subroutine allocate_buffer_5d(this, buff_type, buff_sizes, field_name, diurnal_samples)
- class(outputBuffer5d_type), intent(inout), target :: this !< 5D buffer object
- class(*),intent(in) :: buff_type !< allocates to the type of buff_type
- integer, intent(in) :: buff_sizes(5) !< dimension buff_sizes
- character(len=*), intent(in) :: field_name !< field name for error output
- integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml
- integer :: n_samples !< number of diurnal samples, defaults to 1
-
- if(present(diurnal_samples)) then
- n_samples = diurnal_samples
- else
- n_samples = 1
- endif
-
- if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_5d: buffer already allocated for field:" // &
- field_name)
- select type (buff_type)
- type is (integer(kind=i4_kind))
- allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0_i4_kind
- this%count_0d = 0_i4_kind
- this%buffer_type = i4
- type is (integer(kind=i8_kind))
- allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0_i8_kind
- this%count_0d = 0_i8_kind
- this%buffer_type = i8
- type is (real(kind=r4_kind))
- allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r4_kind
- this%count_0d = 0.0_r4_kind
- this%buffer_type = r4
- type is (real(kind=r8_kind))
- allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
- this%counter = 0.0_r8_kind
- this%count_0d = 0.0_r8_kind
- this%buffer_type = r8
- class default
- call mpp_error("allocate_buffer_5d", &
- "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
- "for field:" // field_name, FATAL)
- end select
- allocate(this%num_elements(n_samples))
- this%num_elements = 0
- this%count_0d = 0
- allocate(this%buffer_dims(5))
- this%buffer_dims(1) = buff_sizes(1)
- this%buffer_dims(2) = buff_sizes(2)
- this%buffer_dims(3) = buff_sizes(3)
- this%buffer_dims(4) = buff_sizes(4)
- this%buffer_dims(5) = buff_sizes(5)
-end subroutine allocate_buffer_5d
-
-!> Get routine for scalar buffers.
-!! Sets the buff_out argument to the integer or real value currently stored in the buffer.
-subroutine get_0d (this, buff_out, field_name)
- class(outputBuffer0d_type), intent(in) :: this !< 0d allocated buffer object
- class(*), allocatable, intent(out) :: buff_out !< output of copied buffer data
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_0d(get_buffer): buffer not yet allocated for field:' &
- & // field_name)
- select type (buff=>this%buffer)
- type is (real(r4_kind))
- allocate(real(r4_kind) :: buff_out)
- buff_out = buff(1)
- type is (real(r8_kind))
- allocate(real(r8_kind) :: buff_out)
- buff_out = buff(1)
- type is (integer(i4_kind))
- allocate(integer(i4_kind) :: buff_out)
- buff_out = buff(1)
- type is (integer(i8_kind))
- allocate(integer(i8_kind) :: buff_out)
- buff_out = buff(1)
- class default
- call mpp_error(FATAL, "get_0d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
- field_name)
- end select
-end subroutine
-
-!> Get routine for 1D buffers.
-!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
-subroutine get_1d (this, buff_out, field_name)
- class(outputBuffer1d_type), intent(in) :: this !< 1d allocated buffer object
- class(*), allocatable, intent(out) :: buff_out(:) !< output of copied buffer data
- !! must be the same size as the allocated buffer
- integer(i4_kind) :: buff_size !< size for allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_0d(get_buffer): buffer not yet allocated for field:' &
- & // field_name)
- buff_size = size(this%buffer,1)
-
- select type (buff=>this%buffer)
- type is (real(r4_kind))
- allocate(real(r4_kind) :: buff_out(buff_size))
- buff_out = buff
- type is (real(r8_kind))
- allocate(real(r8_kind) :: buff_out(buff_size))
- buff_out = buff
- type is (integer(i4_kind))
- allocate(integer(i4_kind) :: buff_out(buff_size))
- buff_out = buff
- type is (integer(i8_kind))
- allocate(integer(i8_kind) :: buff_out(buff_size))
- buff_out = buff
- class default
- call mpp_error(FATAL, "get_1d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
- "field name: "// field_name)
- end select
-end subroutine
-
-!> Get routine for 2D buffers.
-!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
-subroutine get_2d (this, buff_out, field_name)
- class(outputBuffer2d_type), intent(in) :: this !< 2d allocated buffer object
- class(*), allocatable, intent(out) :: buff_out(:,:) !< output of copied buffer data
- !! must be the same size as the allocated buffer
- integer(i4_kind) :: buff_size(2) !< sizes for allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_2d(get_buffer): buffer not yet allocated for field:' &
- & // field_name)
- buff_size(1) = size(this%buffer,1)
- buff_size(2) = size(this%buffer,2)
-
- select type (buff=>this%buffer)
- type is (real(r4_kind))
- allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2)))
- buff_out = buff
- type is (real(r8_kind))
- allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2)))
- buff_out = buff
- type is (integer(i4_kind))
- allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2)))
- buff_out = buff
- type is (integer(i8_kind))
- allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2)))
- buff_out = buff
- class default
- call mpp_error(FATAL, "get_2d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
- "field name: "// field_name)
-
- end select
-end subroutine
-
-!> Get routine for 3D buffers.
-!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
-subroutine get_3d (this, buff_out, field_name)
- class(outputBuffer3d_type), intent(in) :: this !< 3d allocated buffer object
- class(*), allocatable, intent(out) :: buff_out(:,:,:) !< output of copied buffer data
- !! must be the same size as the allocated buffer
- integer(i4_kind) :: buff_size(3)!< sizes for allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_3d(get_buffer): buffer not yet allocated for field:' &
- & // field_name)
- buff_size(1) = size(this%buffer,1)
- buff_size(2) = size(this%buffer,2)
- buff_size(3) = size(this%buffer,3)
-
- select type (buff=>this%buffer)
- type is (real(r4_kind))
- allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3)))
- buff_out = buff
- type is (real(r8_kind))
- allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3)))
- buff_out = buff
- type is (integer(i4_kind))
- allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3)))
- buff_out = buff
- type is (integer(i8_kind))
- allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3)))
- buff_out = buff
- class default
- call mpp_error(FATAL, "get_3d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
- "field name: "// field_name)
- end select
-end subroutine
-
-!> Get routine for 4D buffers.
-!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
-subroutine get_4d (this, buff_out, field_name)
- class(outputBuffer4d_type), intent(in) :: this !< 4d allocated buffer object
- class(*), allocatable, intent(out) :: buff_out(:,:,:,:) !< output of copied buffer data
- !! must be the same size as the allocated buffer
- integer(i4_kind) :: buff_size(4)!< sizes for allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_4d(get_buffer): buffer not yet allocated for field:' &
- & // field_name)
- buff_size(1) = size(this%buffer,1)
- buff_size(2) = size(this%buffer,2)
- buff_size(3) = size(this%buffer,3)
- buff_size(4) = size(this%buffer,4)
-
- select type (buff=>this%buffer)
- type is (real(r4_kind))
- allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4)))
- buff_out = buff
- type is (real(r8_kind))
- allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4)))
- buff_out = buff
- type is (integer(i4_kind))
- allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4)))
- buff_out = buff
- type is (integer(i8_kind))
- allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4)))
- buff_out = buff
- class default
- call mpp_error(FATAL, "get_4d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
- "field name: "// field_name)
- end select
-end subroutine
-
-!> Get routine for 5D buffers.
-!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
-subroutine get_5d (this, buff_out, field_name)
- class(outputBuffer5d_type), intent(in) :: this !< 5d allocated buffer object
- class(*), allocatable, intent(out) :: buff_out(:,:,:,:,:) !< output of copied buffer data
- !! must be the same size as the allocated buffer
- integer(i4_kind) :: buff_size(5)!< sizes for allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_5d: buffer not yet allocated for field:' &
- & // field_name)
- buff_size(1) = size(this%buffer,1)
- buff_size(2) = size(this%buffer,2)
- buff_size(3) = size(this%buffer,3)
- buff_size(4) = size(this%buffer,4)
- buff_size(5) = size(this%buffer,5)
-
- select type (buff=>this%buffer)
- type is (real(r4_kind))
- allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
- buff_out = buff
- type is (real(r8_kind))
- allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
- buff_out = buff
- type is (integer(i4_kind))
- allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
- buff_out = buff
- type is (integer(i8_kind))
- allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
- buff_out = buff
- class default
- call mpp_error(FATAL, "get_5d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // &
- "field name: "// field_name)
- end select
-end subroutine
-
-!> @brief Initializes a buffer to a given fill value.
-subroutine initialize_buffer_0d (this, fillval, field_name)
- class(outputBuffer0d_type), intent(inout) :: this !< scalar buffer object
- class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_0d: field:'// field_name // &
- 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
- select type(buff => this%buffer)
- type is(real(r8_kind))
- select type(fillval)
- type is(real(r8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(r8_kind)' // &
- ' for field' // field_name )
- end select
- type is(real(r4_kind))
- select type(fillval)
- type is(real(r4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(r4_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i8_kind))
- select type(fillval)
- type is(integer(i8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(i8_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i4_kind))
- select type(fillval)
- type is(integer(i4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(i4_kind)' // &
- ' for field' // field_name )
- end select
- class default
- call mpp_error(FATAL, 'initialize buffer_0d: buffer allocated to invalid data type, this shouldnt happen')
- end select
-
-end subroutine initialize_buffer_0d
-
-!> @brief Initializes a buffer to a given fill value.
-subroutine initialize_buffer_1d (this, fillval, field_name)
- class(outputBuffer1d_type), intent(inout) :: this !< 1D buffer object
- class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_1d: field:'// field_name // &
- 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
- ! have to check fill value and buffer types match
- select type(buff => this%buffer)
- type is(real(r8_kind))
- select type(fillval)
- type is(real(r8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(r8_kind)' // &
- ' for field' // field_name )
- end select
- type is(real(r4_kind))
- select type(fillval)
- type is(real(r4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(r4_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i8_kind))
- select type(fillval)
- type is(integer(i8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(i8_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i4_kind))
- select type(fillval)
- type is(integer(i4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(i4_kind)' // &
- ' for field' // field_name )
- end select
- class default
- call mpp_error(FATAL, 'initialize buffer_1d: buffer allocated to invalid data type, this shouldnt happen')
- end select
-
-end subroutine initialize_buffer_1d
-
-!> @brief Initializes a buffer to a given fill value.
-subroutine initialize_buffer_2d (this, fillval, field_name)
- class(outputBuffer2d_type), intent(inout) :: this !< 2D buffer object
- class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this
- character(len=*), intent(in) :: field_name !< field name for error output
-
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_2d: field:'// field_name // &
- 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
- ! have to check fill value and buffer types match
- select type(buff => this%buffer)
- type is(real(r8_kind))
- select type(fillval)
- type is(real(r8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(r8_kind)' // &
- ' for field' // field_name )
- end select
- type is(real(r4_kind))
- select type(fillval)
- type is(real(r4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(r4_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i8_kind))
- select type(fillval)
- type is(integer(i8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(i8_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i4_kind))
- select type(fillval)
- type is(integer(i4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(i4_kind)' // &
- ' for field' // field_name )
- end select
- class default
- call mpp_error(FATAL, 'initialize buffer_2d: buffer allocated to invalid data type, this shouldnt happen')
- end select
-
-end subroutine initialize_buffer_2d
+!> Setter for buffer_id for any buffer objects
+subroutine set_buffer_id(this, id)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to set id for
+ integer, intent(in) :: id !< positive integer id to set
-!> @brief Initializes a buffer to a given fill value.
-subroutine initialize_buffer_3d (this, fillval, field_name)
- class(outputBuffer3d_type), intent(inout) :: this !< 3D buffer object
- class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this
- character(len=*), intent(in) :: field_name !< field name for error output
+ this%buffer_id = id
+end subroutine set_buffer_id
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_3d: field:'// field_name // &
- 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
- ! have to check fill value and buffer types match
- select type(buff => this%buffer)
- type is(real(r8_kind))
- select type(fillval)
- type is(real(r8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(r8_kind)' // &
- ' for field' // field_name )
- end select
- type is(real(r4_kind))
- select type(fillval)
- type is(real(r4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(r4_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i8_kind))
- select type(fillval)
- type is(integer(i8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(i8_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i4_kind))
- select type(fillval)
- type is(integer(i4_kind))
- buff = fillval
+!> Deallocates data fields from a buffer object.
+subroutine flush_buffer(this)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< any buffer object
+
+ this%buffer_id = diag_null
+ this%buffer_type = diag_null
+ this%ndim = diag_null
+ this%field_id = diag_null
+ this%yaml_id = diag_null
+ if (allocated(this%buffer)) deallocate(this%buffer)
+ if (allocated(this%buffer_dims)) deallocate(this%buffer_dims)
+ if (allocated(this%counter)) deallocate(this%counter)
+ if (allocated(this%num_elements)) deallocate(this%num_elements)
+ if (allocated(this%count_0d)) deallocate(this%count_0d)
+ if (allocated(this%axis_ids)) deallocate(this%axis_ids)
+end subroutine flush_buffer
+
+!> Allocates a 5D buffer to given buff_type.
+subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurnal_samples)
+ class(fmsDiagOutputBuffer_type), intent(inout), target :: this !< 5D buffer object
+ class(*), intent(in) :: buff_type !< allocates to the type of buff_type
+ integer, intent(in) :: ndim !< Number of dimension
+ integer, intent(in) :: buff_sizes(5) !< dimension buff_sizes
+ character(len=*), intent(in) :: field_name !< field name for error output
+ integer, optional, intent(in) :: diurnal_samples !< number of diurnal samples
+
+ integer :: n_samples !< number of diurnal samples, defaults to 1
+
+ if(present(diurnal_samples)) then
+ n_samples = diurnal_samples
+ else
+ n_samples = 1
+ endif
+
+ this%ndim =ndim
+ if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer: buffer already allocated for field:" // &
+ field_name)
+ select type (buff_type)
+ type is (integer(kind=i4_kind))
+ allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
+ this%counter = 0_i4_kind
+ this%count_0d = 0_i4_kind
+ this%buffer_type = i4
+ type is (integer(kind=i8_kind))
+ allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
+ this%counter = 0_i8_kind
+ this%count_0d = 0_i8_kind
+ this%buffer_type = i8
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
+ this%counter = 0.0_r4_kind
+ this%count_0d = 0.0_r4_kind
+ this%buffer_type = r4
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ & buff_sizes(5)))
+ allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
+ this%counter = 0.0_r8_kind
+ this%count_0d = 0.0_r8_kind
+ this%buffer_type = r8
class default
- call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(i4_kind)' // &
- ' for field' // field_name )
- end select
- class default
- call mpp_error(FATAL, 'initialize buffer_3d: buffer allocated to invalid data type, this shouldnt happen')
+ call mpp_error("allocate_buffer", &
+ "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
+ "for field:" // field_name, FATAL)
end select
+ allocate(this%num_elements(n_samples))
+ this%num_elements = 0
+ this%count_0d = 0
+ allocate(this%buffer_dims(5))
+ this%buffer_dims(1) = buff_sizes(1)
+ this%buffer_dims(2) = buff_sizes(2)
+ this%buffer_dims(3) = buff_sizes(3)
+ this%buffer_dims(4) = buff_sizes(4)
+ this%buffer_dims(5) = buff_sizes(5)
+end subroutine allocate_buffer
-end subroutine initialize_buffer_3d
+!> Get routine for 5D buffers.
+!! Sets the buff_out argument to the integer or real array currently stored in the buffer.
+subroutine get_buffer (this, buff_out, field_name)
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< 5d allocated buffer object
+ class(*), allocatable, intent(out) :: buff_out(:,:,:,:,:) !< output of copied buffer data
+ !! must be the same size as the allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
-!> @brief Initializes a buffer to a given fill value.
-subroutine initialize_buffer_4d (this, fillval, field_name)
- class(outputBuffer4d_type), intent(inout) :: this !< allocated 4D buffer object
- class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this
- character(len=*), intent(in) :: field_name !< field name for error output
+ integer(i4_kind) :: buff_size(5)!< sizes for allocated buffer
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_4d: field:'// field_name // &
- 'buffer not yet allocated, allocate_buffer() must be called on this object first.')
- ! have to check fill value and buffer types match
- select type(buff => this%buffer)
- type is(real(r8_kind))
- select type(fillval)
- type is(real(r8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(r8_kind)' // &
- ' for field' // field_name )
- end select
- type is(real(r4_kind))
- select type(fillval)
- type is(real(r4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(r4_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i8_kind))
- select type(fillval)
- type is(integer(i8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(i8_kind)' // &
- ' for field' // field_name )
- end select
- type is(integer(i4_kind))
- select type(fillval)
- type is(integer(i4_kind))
- buff = fillval
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_buffer: buffer not yet allocated for field:' &
+ & // field_name)
+ buff_size(1) = size(this%buffer,1)
+ buff_size(2) = size(this%buffer,2)
+ buff_size(3) = size(this%buffer,3)
+ buff_size(4) = size(this%buffer,4)
+ buff_size(5) = size(this%buffer,5)
+
+ select type (buff=>this%buffer)
+ type is (real(r4_kind))
+ allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
+ buff_out = buff
+ type is (real(r8_kind))
+ allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
+ buff_out = buff
+ type is (integer(i4_kind))
+ allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
+ buff_out = buff
+ type is (integer(i8_kind))
+ allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5)))
+ buff_out = buff
class default
- call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(i4_kind)' // &
- ' for field' // field_name )
- end select
- class default
- call mpp_error(FATAL, 'initialize buffer_4d: buffer allocated to invalid data type, this shouldnt happen')
+ call mpp_error(FATAL, "get_buffer: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)."&
+ //"field name: "// field_name)
end select
-
-end subroutine initialize_buffer_4d
+end subroutine
!> @brief Initializes a buffer to a given fill value.
-subroutine initialize_buffer_5d (this, fillval, field_name)
- class(outputBuffer5d_type), intent(inout) :: this !< allocated 5D buffer object
- class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this
- character(len=*), intent(in) :: field_name !< field name for error output
+subroutine initialize_buffer (this, fillval, field_name)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< allocated 5D buffer object
+ class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer
+ character(len=*), intent(in) :: field_name !< field name for error output
- if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_5d: field:'// field_name // &
+ if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer: field:'// field_name // &
'buffer not yet allocated, allocate_buffer() must be called on this object first.')
! have to check fill value and buffer types match
select type(buff => this%buffer)
@@ -1134,7 +245,7 @@ subroutine initialize_buffer_5d (this, fillval, field_name)
type is(real(r8_kind))
buff = fillval
class default
- call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(r8_kind)' // &
+ call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(r8_kind)' // &
' for field' // field_name )
end select
type is(real(r4_kind))
@@ -1142,7 +253,7 @@ subroutine initialize_buffer_5d (this, fillval, field_name)
type is(real(r4_kind))
buff = fillval
class default
- call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(r4_kind)' // &
+ call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(r4_kind)' // &
' for field' // field_name )
end select
type is(integer(i8_kind))
@@ -1150,7 +261,7 @@ subroutine initialize_buffer_5d (this, fillval, field_name)
type is(integer(i8_kind))
buff = fillval
class default
- call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(i8_kind)' // &
+ call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(i8_kind)' // &
' for field' // field_name )
end select
type is(integer(i4_kind))
@@ -1158,294 +269,19 @@ subroutine initialize_buffer_5d (this, fillval, field_name)
type is(integer(i4_kind))
buff = fillval
class default
- call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(i4_kind)' // &
+ call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(i4_kind)' // &
' for field' // field_name )
end select
class default
call mpp_error(FATAL, 'initialize buffer_5d: buffer allocated to invalid data type, this shouldnt happen')
end select
-end subroutine initialize_buffer_5d
-
-!> @brief Add values to 0d buffer.
-!! This will just call the init routine since there's only one value.
-!! @note input_data must match allocated type of buffer object.
-subroutine add_to_buffer_0d(this, input_data, field_name)
- class(outputBuffer0d_type), intent(inout) :: this !< allocated scalar buffer object
- class(*), intent(in) :: input_data !< data to copy into buffer
- character(len=*), intent(in) :: field_name !< field name for error output
- if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_0d: buffer not yet allocated for field:'// &
- field_name)
- call this%initialize_buffer(input_data, field_name)
-end subroutine add_to_buffer_0d
-
-!> @brief Copy values ( from 1 to size(input_data)) into a 1d buffer object.
-!! @note input_data must match allocated type of buffer object.
-subroutine add_to_buffer_1d(this, input_data, field_name)
- class(outputBuffer1d_type), intent(inout) :: this !< allocated 1d buffer object
- class(*), intent(in) :: input_data(:) !< data to copy into the buffer
- integer :: n !< number of elements in input data
- logical :: type_error !< set to true if mismatch between input_data and allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
- type_error = .false.
- if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_1d: buffer not yet allocated for field:' // &
- field_name)
- n = SIZE(input_data)
- if( n .gt. SIZE(this%buffer)) call mpp_error( FATAL,"add_to_buffer_1d: input data larger than allocated buffer " // &
- "for field: "// field_name)
- ! have to check both types for assignment
- select type( buffer => this%buffer )
- type is(integer(i4_kind))
- select type(input_data)
- type is(integer(i4_kind))
- buffer(1:n) = input_data(1:n)
- class default
- type_error = .true.
- end select
- type is(integer(i8_kind))
- select type(input_data)
- type is(integer(i8_kind))
- buffer(1:n) = input_data(1:n)
- class default
- type_error = .true.
- end select
- type is(real(r4_kind))
- select type(input_data)
- type is(real(r4_kind))
- buffer(1:n) = input_data(1:n)
- class default
- type_error = .true.
- end select
- type is(real(r8_kind))
- select type(input_data)
- type is(real(r8_kind))
- buffer(1:n) = input_data(1:n)
- class default
- type_error = .true.
- end select
- end select
- if( type_error ) call mpp_error (FATAL,'add_to_buffer_1d: mismatch between allocated buffer and input data types'// &
- ' for field:' // field_name)
-end subroutine add_to_buffer_1d
-
-!> @brief Copy values ( from 1 to size(input_data)) into a 2d buffer object.
-!! @note input_data must match allocated type of buffer object.
-subroutine add_to_buffer_2d(this, input_data, field_name)
- class(outputBuffer2d_type), intent(inout) :: this !< allocated 2d buffer object
- class(*), intent(in) :: input_data(:,:) !< 2d data array to copy into buffer
- integer :: n1, n2 !< number of elements per dimension
- logical :: type_error !< set to true if mismatch between input_data and allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
- type_error = .false.
- if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_2d: buffer not yet allocated for field:' // &
- field_name)
- n1 = SIZE(input_data, 1)
- n2 = SIZE(input_data, 2)
- if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2)) then
- call mpp_error( FATAL,"add_to_buffer_2d: input data larger than allocated buffer")
- endif
- ! have to check both types for assignment
- select type( buffer => this%buffer )
- type is(integer(i4_kind))
- select type(input_data)
- type is(integer(i4_kind))
- buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2)
- class default
- type_error = .true.
- end select
- type is(integer(i8_kind))
- select type(input_data)
- type is(integer(i8_kind))
- buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2)
- class default
- type_error = .true.
- end select
- type is(real(r4_kind))
- select type(input_data)
- type is(real(r4_kind))
- buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2)
- class default
- type_error = .true.
- end select
- type is(real(r8_kind))
- select type(input_data)
- type is(real(r8_kind))
- buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2)
- class default
- type_error = .true.
- end select
- end select
- if( type_error ) call mpp_error (FATAL,'add_to_buffer_1d: mismatch between allocated buffer and input data types'//&
- ' for field:'// field_name)
-end subroutine add_to_buffer_2d
-
-!> @brief Copy values ( from 1 to size(input_data)) into a 3d buffer object.
-!! @note input_data must match allocated type of buffer object.
-subroutine add_to_buffer_3d(this, input_data, field_name)
- class(outputBuffer3d_type), intent(inout) :: this !< allocated 3d buffer object
- class(*), intent(in) :: input_data(:,:,:)!< 3d data array to copy into buffer
- integer :: n1, n2, n3 !< number of elements per dimension
- logical :: type_error !< set to true if mismatch between input_data and allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
- type_error = .false.
- if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_3d: buffer not yet allocated for field:'//&
- field_name)
- n1 = SIZE(input_data, 1)
- n2 = SIZE(input_data, 2)
- n3 = SIZE(input_data, 3)
- if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2) .or. &
- n3 .gt. SIZE(this%buffer, 3)) then
- call mpp_error( FATAL,"add_to_buffer_3d: input data larger than allocated buffer for field:"//field_name)
- endif
- ! have to check both types for assignment
- select type( buffer => this%buffer )
- type is(integer(i4_kind))
- select type(input_data)
- type is(integer(i4_kind))
- buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3)
- class default
- type_error = .true.
- end select
- type is(integer(i8_kind))
- select type(input_data)
- type is(integer(i8_kind))
- buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3)
- class default
- type_error = .true.
- end select
- type is(real(r4_kind))
- select type(input_data)
- type is(real(r4_kind))
- buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3)
- class default
- type_error = .true.
- end select
- type is(real(r8_kind))
- select type(input_data)
- type is(real(r8_kind))
- buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3)
- class default
- type_error = .true.
- end select
- end select
- if( type_error ) call mpp_error (FATAL,'add_to_buffer_3d: mismatch between allocated buffer and input data types'//&
- ' for field:'//field_name)
-end subroutine add_to_buffer_3d
-
-!> @brief Copy values ( from 1 to size(input_data)) into a 4d buffer object.
-!! @note input_data must match allocated type of buffer object.
-subroutine add_to_buffer_4d(this, input_data, field_name)
- class(outputBuffer4d_type), intent(inout) :: this !< allocated 4d buffer object
- class(*), intent(in) :: input_data(:,:,:,:) !< 4d data to copy into buffer
- integer :: n1, n2, n3, n4!< number of elements per dimension
- logical :: type_error !< set to true if mismatch between input_data and allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
- type_error = .false.
- if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_4d: buffer not yet allocated for field:'// &
- field_name)
- n1 = SIZE(input_data, 1)
- n2 = SIZE(input_data, 2)
- n3 = SIZE(input_data, 3)
- n4 = SIZE(input_data, 4)
- if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2) .or. &
- n3 .gt. SIZE(this%buffer, 3) .or. n4 .gt. SIZE(this%buffer, 4)) then
- call mpp_error( FATAL,"add_to_buffer_4d: input data larger than allocated buffer for field:"//field_name)
- endif
- ! have to check both types for assignment
- select type( buffer => this%buffer )
- type is(integer(i4_kind))
- select type(input_data)
- type is(integer(i4_kind))
- buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4)
- class default
- type_error = .true.
- end select
- type is(integer(i8_kind))
- select type(input_data)
- type is(integer(i8_kind))
- buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4)
- class default
- type_error = .true.
- end select
- type is(real(r4_kind))
- select type(input_data)
- type is(real(r4_kind))
- buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4)
- class default
- type_error = .true.
- end select
- type is(real(r8_kind))
- select type(input_data)
- type is(real(r8_kind))
- buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4)
- class default
- type_error = .true.
- end select
- end select
- if( type_error ) call mpp_error (FATAL,'add_to_buffer_4d: mismatch between allocated buffer and input data types'// &
- ' for field:' //field_name)
-end subroutine add_to_buffer_4d
-
-!> @brief Copy values (from 1 to size(input_data)) into a 5d buffer object.
-!! @note input_data must match allocated type of buffer object.
-subroutine add_to_buffer_5d(this, input_data, field_name)
- class(outputBuffer5d_type), intent(inout) :: this !< allocated 5d buffer object
- class(*), intent(in) :: input_data(:,:,:,:,:) !< 5d data to copy into buffer
- integer :: n1, n2, n3, n4, n5 !< number of elements per dimension
- logical :: type_error !< set to true if mismatch between input_data and allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
- type_error = .false.
- if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_5d: buffer not yet allocated for field:'// &
- field_name)
- n1 = SIZE(input_data, 1)
- n2 = SIZE(input_data, 2)
- n3 = SIZE(input_data, 3)
- n4 = SIZE(input_data, 4)
- n5 = SIZE(input_data, 5)
- if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2) .or. &
- n3 .gt. SIZE(this%buffer, 3) .or. n4 .gt. SIZE(this%buffer, 4) .or. &
- n5 .gt. SIZE(this%buffer, 5)) then
- call mpp_error( FATAL,"add_to_buffer_4d: input data larger than allocated buffer for field:"//field_name)
- endif
- ! have to check both types for assignment
- select type( buffer => this%buffer )
- type is(integer(i4_kind))
- select type(input_data)
- type is(integer(i4_kind))
- buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5)
- class default
- type_error = .true.
- end select
- type is(integer(i8_kind))
- select type(input_data)
- type is(integer(i8_kind))
- buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5)
- class default
- type_error = .true.
- end select
- type is(real(r4_kind))
- select type(input_data)
- type is(real(r4_kind))
- buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5)
- class default
- type_error = .true.
- end select
- type is(real(r8_kind))
- select type(input_data)
- type is(real(r8_kind))
- buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5)
- class default
- type_error = .true.
- end select
- end select
- if( type_error ) call mpp_error (FATAL,'add_to_buffer_5d: mismatch between allocated buffer and input data types'//&
- 'for field:'// field_name)
-end subroutine add_to_buffer_5d
+end subroutine initialize_buffer
!> @brief Adds the axis ids to the buffer object
subroutine add_axis_ids(this, axis_ids)
- class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object
- integer, intent(in) :: axis_ids(:) !< Axis ids to add
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ integer, intent(in) :: axis_ids(:) !< Axis ids to add
this%axis_ids = axis_ids
end subroutine
@@ -1455,7 +291,7 @@ subroutine add_axis_ids(this, axis_ids)
function get_axis_ids(this) &
result(res)
- class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
integer, allocatable :: res(:)
if (allocated(this%axis_ids)) then
@@ -1470,8 +306,7 @@ function get_axis_ids(this) &
!! @return the field id of the buffer
function get_field_id(this) &
result(res)
-
- class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< Buffer object
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object
integer :: res
res = this%field_id
@@ -1479,16 +314,16 @@ end function get_field_id
!> @brief set the field id of the buffer
subroutine set_field_id(this, field_id)
- class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object
- integer, intent(in) :: field_id !< field id of the buffer
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ integer, intent(in) :: field_id !< field id of the buffer
this%field_id = field_id
end subroutine set_field_id
!> @brief set the field id of the buffer
subroutine set_yaml_id(this, yaml_id)
- class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object
- integer, intent(in) :: yaml_id !< yaml id of the buffer
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ integer, intent(in) :: yaml_id !< yaml id of the buffer
this%yaml_id = yaml_id
end subroutine set_yaml_id
@@ -1498,7 +333,7 @@ end subroutine set_yaml_id
function get_yaml_id(this) &
result(res)
- class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< Buffer object
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object
integer :: res
res = this%yaml_id
@@ -1506,9 +341,9 @@ end function get_yaml_id
!> @brief Write the buffer to the file
subroutine write_buffer(this, fileobj, unlim_dim_level)
- class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write
- class(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to
- integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
+ class(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to
+ integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
select type(fileobj)
type is (FmsNetcdfFile_t)
@@ -1525,85 +360,76 @@ end subroutine write_buffer
!> @brief Write the buffer to the FmsNetcdfFile_t fileobj
subroutine write_buffer_wrapper_netcdf(this, fileobj, unlim_dim_level)
- class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write
- type(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to
- integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
+ type(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to
+ integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
character(len=:), allocatable :: varname !< name of the variable
varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
- select type(buffer_obj=>this%diag_buffer_obj)
- type is (outputBuffer0d_type)
- call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level)
- type is (outputBuffer1d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer2d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer3d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer4d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer5d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- class default
- call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//&
- " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.")
+ select case(this%ndim)
+ case (0)
+ call write_data(fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ case (1)
+ call write_data(fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ case (2)
+ call write_data(fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
+ case (3)
+ call write_data(fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
+ case (4)
+ call write_data(fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
+ case (5)
+ call write_data(fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_netcdf
!> @brief Write the buffer to the FmsNetcdfDomainFile_t fileobj
subroutine write_buffer_wrapper_domain(this, fileobj, unlim_dim_level)
- class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write
- type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< fileobj to write to
- integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
+ type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< fileobj to write to
+ integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
character(len=:), allocatable :: varname !< name of the variable
varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
- select type(buffer_obj=>this%diag_buffer_obj)
- type is (outputBuffer0d_type)
- call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level)
- type is (outputBuffer1d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer2d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer3d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer4d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer5d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- class default
- call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//&
- " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.")
+ select case(this%ndim)
+ case (0)
+ call write_data(fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ case (1)
+ call write_data(fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ case (2)
+ call write_data(fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
+ case (3)
+ call write_data(fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
+ case (4)
+ call write_data(fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
+ case (5)
+ call write_data(fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_domain
!> @brief Write the buffer to the FmsNetcdfUnstructuredDomainFile_t fileobj
subroutine write_buffer_wrapper_u(this, fileobj, unlim_dim_level)
- class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write
- type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fileobj !< fileobj to write to
- integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
+ type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fileobj !< fileobj to write to
+ integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
character(len=:), allocatable :: varname !< name of the variable
varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
- select type(buffer_obj=>this%diag_buffer_obj)
- type is (outputBuffer0d_type)
- call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level)
- type is (outputBuffer1d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer2d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer3d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer4d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- type is (outputBuffer5d_type)
- call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level)
- class default
- call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//&
- " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.")
+ select case(this%ndim)
+ case (0)
+ call write_data(fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ case (1)
+ call write_data(fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ case (2)
+ call write_data(fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
+ case (3)
+ call write_data(fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
+ case (4)
+ call write_data(fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
+ case (5)
+ call write_data(fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_u
#endif
diff --git a/test_fms/diag_manager/test_diag_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90
index c9dc7374e0..e339e9055e 100644
--- a/test_fms/diag_manager/test_diag_buffer.F90
+++ b/test_fms/diag_manager/test_diag_buffer.F90
@@ -1,189 +1,134 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This program tests the output buffer functionality
program test_diag_buffer
#ifdef use_yaml
- use fms_diag_output_buffer_mod
- use platform_mod
- use diag_data_mod, only: i4, i8, r4, r8
+ use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_type
+ use platform_mod, only: r8_kind, r4_kind, i8_kind, i4_kind
+ use fms_mod, only: string, fms_init, fms_end
+ use mpp_mod, only: mpp_error, FATAL
+ use diag_data_mod, only: i4, i8, r4, r8
implicit none
- type(outputBuffer0d_type) :: buffobj0(10)
- type(outputBuffer1d_type) :: buffobj1
- type(outputBuffer2d_type) :: buffobj2
- type(outputBuffer3d_type) :: buffobj3
- type(outputBuffer4d_type) :: buffobj4
- type(outputBuffer5d_type) :: buffobj5
- class(*),allocatable :: p_val, p_data1(:), p_data2(:,:)
- real(r8_kind) :: r8_data
- real(r4_kind) :: r4_data
- integer(i8_kind) :: i8_data
- integer(i4_kind) :: i4_data
- integer :: buff_id
- class(*), pointer :: remap_buffer_out(:,:,:,:,:)
- integer :: i
- real(4) :: arr(9)
- real(4), allocatable :: arr1d(:)
- class(*), allocatable :: arr2d(:,:)
- integer(8), allocatable :: i8arr2d(:,:)
- real(8), allocatable :: r8val
- class(*), allocatable :: arr3d(:,:,:), arr4d(:,:,:,:), arr5d(:,:,:,:,:)
- integer(8), allocatable :: i8arr3d(:,:,:), i8arr4d(:,:,:,:), i8arr5d(:,:,:,:,:)
- logical :: test_5d = .true.
- character(len=4) :: fname = 'test'
-
- !! 0d
- ! allocate some buffers
- do i=1, 10
- call buffobj0(i)%allocate_buffer(r8_data, fname)
- call buffobj0(i)%initialize_buffer( real(i, kind=r8_kind) , fname)
- end do
- ! add some values
- call buffobj0(5)%add_to_buffer(real(-1, kind=r8_kind), fname)
- ! get the buffer data
- !allocate(real(8) :: p_val)
- !allocate(r8val)
- call buffobj0(5)%get_buffer(p_val, fname)
- select type(p_val)
- type is(real(r8_kind))
- print *, p_val
- r8val = p_val
- end select
- ! get the 5d remapped buffer data
- remap_buffer_out => buffobj0(5)%remap_buffer(fname, .false.)
- ! check output from object and remapped buffer
- print *, r8val
- call print_5d(remap_buffer_out)
- do i=1, 10
- call buffobj0(i)%flush_buffer()
- enddo
-
- !! 1d
- ! allocate a buffer to the given type and get it's id
- call buffobj1%allocate_buffer(r4_data, 10, fname)
- !! init to given value
- call buffobj1%initialize_buffer( real(0.1, kind=r4_kind), fname )
- !! add some values to the buffer
- arr = 4.0
- call buffobj1%add_to_buffer(arr, fname)
- !! get the buffer
- allocate(real(8) :: p_data1(10))
- allocate(arr1d(10))
- call buffobj1%get_buffer(p_data1, fname)
- select type(p_data1)
- type is(real(4))
- print *, p_data1
- arr1d = p_data1
- end select
- !! get the remapped buffer
- remap_buffer_out => buffobj1%remap_buffer(fname, .false.)
- !! check output
- print *, arr1d
- call print_5d(remap_buffer_out)
- call buffobj1%flush_buffer()
- print *, '********** 2d **********'
-
- !! 2d
- ! allocate a buffer to the given type and get it's id
- call buffobj2%allocate_buffer(i4_data, (/ 5, 10 /), fname )
- !!! init to given value
- call buffobj2%initialize_buffer( int(2, kind=i4_kind), fname )
- !! set some values in the buffer
- allocate(integer(4) :: arr2d(5,10))
- arr2d = 1
- call buffobj2%add_to_buffer(arr2d, fname)
- !!! get the buffer
- call buffobj2%get_buffer(arr2d, fname)
- !!! get the remapped buffer
- remap_buffer_out => buffobj2%remap_buffer(fname, .false.)
- !!! check output
- select type(arr2d)
- type is(integer(i4_kind))
- print *, arr2d
- end select
- call print_5d(remap_buffer_out)
- call buffobj2%flush_buffer()
-
- !! 3d
- ! allocate a buffer to the given type and get it's id
- call buffobj3%allocate_buffer(i8_data, (/ 2, 2, 2/), fname )
- !! init to given value
- call buffobj3%initialize_buffer( int(3, kind=i8_kind), fname )
- !! set some values in the buffer
- allocate(i8arr3d(2,2,2))
- i8arr3d = 6
- call buffobj3%add_to_buffer(i8arr3d, fname)
- !! get the buffer
- call buffobj3%get_buffer(arr3d, fname)
- !! get the remapped buffer
- remap_buffer_out => buffobj3%remap_buffer(fname, .false.)
- !! check output
- select type (arr3d)
- type is(integer(i8_kind))
- print *, arr3d
- end select
- call print_5d(remap_buffer_out)
- call buffobj3%flush_buffer()
+ type(fmsDiagOutputBuffer_type) :: buffobj(6) !< Dummy output buffers
+ integer :: buff_sizes(5) !< Size of the buffer for each dimension
+ class(*),allocatable :: p_val(:,:,:,:,:) !< Dummy variable to get the data
+ integer :: i, j !< For do loops
+ real(r8_kind) :: r8_data !< Dummy r8 data
+ real(r4_kind) :: r4_data !< Dummy r4 data
+ integer(i8_kind) :: i8_data !< Dummy i8 data
+ integer(i4_kind) :: i4_data !< Dummy i4 data
+ character(len=4) :: fname = 'test' !< Dummy name for error messages
- !! 4d
- ! allocate a buffer to the given type and get it's id
- call buffobj4%allocate_buffer(i8_data, (/ 2, 2, 2, 2/), fname)
- !! init to given value
- call buffobj4%initialize_buffer( int(4, kind=i8_kind), fname )
- !! set some values in the buffer
- allocate(i8arr4d(2,2,2,2))
- i8arr4d = 8
- call buffobj4%add_to_buffer(i8arr4d, fname)
- !! get the buffer
- call buffobj4%get_buffer(arr4d, fname)
- !! get the remapped buffer
- remap_buffer_out => buffobj4%remap_buffer(fname, .false.)
- !! check output
- select type (arr4d)
- type is(integer(i8_kind))
- print *, arr4d
- end select
- call print_5d(remap_buffer_out)
- call buffobj4%flush_buffer()
+ call fms_init
- !! 5d
- call buffobj5%allocate_buffer(i8_data, (/ 2, 2, 2, 2, 2/), fname )
- !! init to given value
- call buffobj5%initialize_buffer( int(5, kind=i8_kind), fname )
- !! get the remapped buffer
- remap_buffer_out => buffobj5%remap_buffer(fname, .false.)
- !! set some values in the buffer
- allocate(i8arr5d(2,2,2,2,2))
- i8arr5d = 10
- call buffobj5%add_to_buffer(i8arr5d, fname)
- !! get the buffer
- call buffobj5%get_buffer(arr5d, fname)
- !! check output
- select type (arr4d)
- type is(integer(i8_kind))
- print *, arr4d
- end select
- call print_5d(remap_buffer_out)
- call buffobj5%flush_buffer()
-
- contains
-
- ! just prints polymorphic data types
- subroutine print_5d(val)
- class(*), intent(in) :: val(:,:,:,:,:)
+ !< Test the r8_buffer
+ buff_sizes = 1
+ do i=0, 5
+ if (i < 5) buff_sizes(i+1) = i+5
+ call buffobj(i+1)%allocate_buffer(r8_data, i, buff_sizes, fname)
+ call buffobj(i+1)%initialize_buffer( real(i, kind=r8_kind) , fname)
+ call buffobj(i+1)%get_buffer(p_val, fname)
+ select type(p_val)
+ type is (real(kind=r8_kind))
+ if (any(p_val .ne. real(i, kind=r8_kind))) &
+ call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
+ do j = 1, 5
+ if (size(p_val, j) .ne. buff_sizes(j)) &
+ call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not allocated to the correct size")
+ enddo
+ class default
+ call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not allocated to the correct type")
+ end select
+ deallocate(p_val)
+ call buffobj(i+1)%flush_buffer()
+ end do
- select type (val)
- type is (real(r4_kind))
- print *, "5d:", val
- type is (real(r8_kind))
- print *, "5d:", val
- type is (integer(i4_kind))
- print *, "5d:",val
- type is (integer(i8_kind))
- print *, "5d:",val
- end select
- end subroutine
+ !< Test the r4_buffer
+ buff_sizes = 1
+ do i=0, 5
+ if (i < 5) buff_sizes(i+1) = i+5
+ call buffobj(i+1)%allocate_buffer(r4_data, i, buff_sizes, fname)
+ call buffobj(i+1)%initialize_buffer( real(i, kind=r4_kind) , fname)
+ call buffobj(i+1)%get_buffer(p_val, fname)
+ select type(p_val)
+ type is (real(kind=r4_kind))
+ if (any(p_val .ne. real(i, kind=r4_kind))) &
+ call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
+ do j = 1, 5
+ if (size(p_val, j) .ne. buff_sizes(j)) &
+ call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not allocated to the correct size")
+ enddo
+ class default
+ call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not allocated to the correct type")
+ end select
+ deallocate(p_val)
+ call buffobj(i+1)%flush_buffer()
+ end do
+ !< Test the i8_buffer
+ buff_sizes = 1
+ do i=0, 5
+ if (i < 5) buff_sizes(i+1) = i+5
+ call buffobj(i+1)%allocate_buffer(i8_data, i, buff_sizes, fname)
+ call buffobj(i+1)%initialize_buffer( int(i, kind=i8_kind) , fname)
+ call buffobj(i+1)%get_buffer(p_val, fname)
+ select type(p_val)
+ type is (integer(kind=i8_kind))
+ if (any(p_val .ne. int(i, kind=i8_kind))) &
+ call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
+ do j = 1, 5
+ if (size(p_val, j) .ne. buff_sizes(j)) &
+ call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not allocated to the correct size")
+ enddo
+ class default
+ call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not allocated to the correct type")
+ end select
+ deallocate(p_val)
+ call buffobj(i+1)%flush_buffer()
+ end do
+ !< Test the i4_buffer
+ buff_sizes = 1
+ do i=0, 5
+ if (i < 5) buff_sizes(i+1) = i+5
+ call buffobj(i+1)%allocate_buffer(i4_data, i, buff_sizes, fname)
+ call buffobj(i+1)%initialize_buffer( int(i, kind=i4_kind) , fname)
+ call buffobj(i+1)%get_buffer(p_val, fname)
+ select type(p_val)
+ type is (integer(kind=i4_kind))
+ if (any(p_val .ne. int(i, kind=i4_kind))) &
+ call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
+ do j = 1, 5
+ if (size(p_val, j) .ne. buff_sizes(j)) &
+ call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not allocated to the correct size")
+ enddo
+ class default
+ call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not allocated to the correct type")
+ end select
+ deallocate(p_val)
+ call buffobj(i+1)%flush_buffer()
+ end do
+ call fms_end()
#endif
end program
From 56b48a94ef78fdced4dd3d83534c861e555e4241 Mon Sep 17 00:00:00 2001
From: Caitlyn McAllister <65364559+mcallic2@users.noreply.github.com>
Date: Tue, 15 Aug 2023 13:07:29 -0400
Subject: [PATCH 121/168] fix: changes all fms2 fileobj instances to
fms2io_fileobj (#1333)
---
diag_manager/fms_diag_axis_object.F90 | 77 ++++++-------
diag_manager/fms_diag_field_object.F90 | 58 +++++-----
diag_manager/fms_diag_file_object.F90 | 144 ++++++++++++------------
diag_manager/fms_diag_output_buffer.F90 | 68 +++++------
4 files changed, 175 insertions(+), 172 deletions(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index d9cf39c848..14a54387bc 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -291,9 +291,9 @@ subroutine add_axis_attribute(this, att_name, att_value)
end subroutine add_axis_attribute
!> @brief Write the axis meta data to an open fileobj
- subroutine write_axis_metadata(this, fileobj, edges_in_file, parent_axis)
+ subroutine write_axis_metadata(this, fms2io_fileobj, edges_in_file, parent_axis)
class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj
- class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write the data to
logical, INTENT(IN) :: edges_in_file !< .True. if the edges to this axis are
!! already in the file
class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis !< If the axis is a subaxis, axis object
@@ -330,64 +330,65 @@ subroutine write_axis_metadata(this, fileobj, edges_in_file, parent_axis)
endif
type_of_domain = NO_DOMAIN !< All subaxes are treated as non-domain decomposed (each rank writes it own file)
type is (fmsDiagDiurnalAxis_type)
- call this%write_diurnal_metadata(fileobj)
+ call this%write_diurnal_metadata(fms2io_fileobj)
return
end select
!< Add the axis as a dimension in the netcdf file based on the type of axis_domain and the fileobj type
- select type (fileobj)
+ select type (fms2io_fileobj)
!< The register_field calls need to be inside the select type block so that it can go inside the correct
!! register_field interface
type is (FmsNetcdfFile_t)
!< Here the axis is not domain decomposed (i.e z_axis)
- call register_axis(fileobj, axis_name, axis_length)
- call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
+ call register_axis(fms2io_fileobj, axis_name, axis_length)
+ call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
type is (FmsNetcdfDomainFile_t)
select case (type_of_domain)
case (NO_DOMAIN)
- !< Here the fileobj is domain decomposed, but the axis is not
+ !< Here the fms2io_fileobj is domain decomposed, but the axis is not
!! Domain decomposed fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
- call register_axis(fileobj, axis_name, axis_length)
- call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
+ call register_axis(fms2io_fileobj, axis_name, axis_length)
+ call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
case (TWO_D_DOMAIN)
!< Here the axis is domain decomposed
- call register_axis(fileobj, axis_name, diag_axis%cart_name, domain_position=diag_axis%domain_position)
- call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
+ call register_axis(fms2io_fileobj, axis_name, diag_axis%cart_name, domain_position=diag_axis%domain_position)
+ call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
end select
type is (FmsNetcdfUnstructuredDomainFile_t)
select case (type_of_domain)
case (UG_DOMAIN)
!< Here the axis is in a unstructured domain
- call register_axis(fileobj, axis_name)
- call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
+ call register_axis(fms2io_fileobj, axis_name)
+ call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
case default
- !< Here the fileobj is in the unstructured domain, but the axis is not
+ !< Here the fms2io_fileobj is in the unstructured domain, but the axis is not
!< Unstructured domain fileobjs can have axis that are not domain decomposed (i.e "Z" axis)
- call register_axis(fileobj, axis_name, axis_length)
- call register_field(fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
+ call register_axis(fms2io_fileobj, axis_name, axis_length)
+ call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
end select
end select
!< Write its metadata
- call register_variable_attribute(fileobj, axis_name, "long_name", diag_axis%long_name, &
+ call register_variable_attribute(fms2io_fileobj, axis_name, "long_name", diag_axis%long_name, &
str_len=len_trim(diag_axis%long_name))
if (diag_axis%cart_name .NE. "N") &
- call register_variable_attribute(fileobj, axis_name, "axis", diag_axis%cart_name, str_len=1)
+ call register_variable_attribute(fms2io_fileobj, axis_name, "axis", diag_axis%cart_name, str_len=1)
if (trim(diag_axis%units) .NE. "none") &
- call register_variable_attribute(fileobj, axis_name, "units", diag_axis%units, str_len=len_trim(diag_axis%units))
+ call register_variable_attribute(fms2io_fileobj, axis_name, "units", diag_axis%units, &
+ str_len=len_trim(diag_axis%units))
select case (diag_axis%direction)
case (direction_up)
- call register_variable_attribute(fileobj, axis_name, "positive", "up", str_len=2)
+ call register_variable_attribute(fms2io_fileobj, axis_name, "positive", "up", str_len=2)
case (direction_down)
- call register_variable_attribute(fileobj, axis_name, "positive", "down", str_len=4)
+ call register_variable_attribute(fms2io_fileobj, axis_name, "positive", "down", str_len=4)
end select
!< Ignore the edges attribute, if the edges are already in the file or if it is subaxis
if (.not. edges_in_file .and. allocated(diag_axis%edges_name) .and. .not. is_subaxis) then
- call register_variable_attribute(fileobj, axis_name, "edges", diag_axis%edges_name, &
+ call register_variable_attribute(fms2io_fileobj, axis_name, "edges", diag_axis%edges_name, &
str_len=len_trim(diag_axis%edges_name))
endif
@@ -395,20 +396,20 @@ subroutine write_axis_metadata(this, fileobj, edges_in_file, parent_axis)
do i = 1, diag_axis%num_attributes
select type (att_value => diag_axis%attributes(i)%att_value)
type is (character(len=*))
- call register_variable_attribute(fileobj, axis_name, diag_axis%attributes(i)%att_name, trim(att_value(1)), &
- str_len=len_trim(att_value(1)))
+ call register_variable_attribute(fms2io_fileobj, axis_name, diag_axis%attributes(i)%att_name, &
+ trim(att_value(1)), str_len=len_trim(att_value(1)))
class default
- call register_variable_attribute(fileobj, axis_name, diag_axis%attributes(i)%att_name, att_value)
+ call register_variable_attribute(fms2io_fileobj, axis_name, diag_axis%attributes(i)%att_name, att_value)
end select
enddo
endif
end subroutine write_axis_metadata
- !> @brief Write the axis data to an open fileobj
- subroutine write_axis_data(this, fileobj, parent_axis)
+ !> @brief Write the axis data to an open fms2io_fileobj
+ subroutine write_axis_data(this, fms2io_fileobj, parent_axis)
class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj
- class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write the data to
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write the data to
class(fmsDiagAxis_type), OPTIONAL, target, INTENT(IN) :: parent_axis !< The parent axis if this is a subaxis
integer :: i !< Starting index of a sub_axis
@@ -417,7 +418,7 @@ subroutine write_axis_data(this, fileobj, parent_axis)
select type(this)
type is (fmsDiagFullAxis_type)
call this%get_global_io_domain(global_io_index)
- call write_data(fileobj, this%axis_name, this%axis_data(global_io_index(1):global_io_index(2)))
+ call write_data(fms2io_fileobj, this%axis_name, this%axis_data(global_io_index(1):global_io_index(2)))
type is (fmsDiagSubAxis_type)
i = this%starting_index
j = this%ending_index
@@ -425,11 +426,11 @@ subroutine write_axis_data(this, fileobj, parent_axis)
if (present(parent_axis)) then
select type(parent_axis)
type is (fmsDiagFullAxis_type)
- call write_data(fileobj, this%subaxis_name, parent_axis%axis_data(i:j))
+ call write_data(fms2io_fileobj, this%subaxis_name, parent_axis%axis_data(i:j))
end select
endif
type is (fmsDiagDiurnalAxis_type)
- call write_data(fileobj, this%axis_name, this%diurnal_data)
+ call write_data(fms2io_fileobj, this%axis_name, this%diurnal_data)
end select
end subroutine write_axis_data
@@ -1263,18 +1264,18 @@ pure function get_diurnal_axis_samples(this) &
end function get_diurnal_axis_samples
!< @brief Writes out the metadata for a diurnal axis
- subroutine write_diurnal_metadata(this, fileobj)
+ subroutine write_diurnal_metadata(this, fms2io_fileobj)
class(fmsDiagDiurnalAxis_type), intent(in) :: this !< Diurnal axis Object
- class(FmsNetcdfFile_t), intent(inout) :: fileobj !< Fms2_io fileobj to write the data to
+ class(FmsNetcdfFile_t), intent(inout) :: fms2io_fileobj !< Fms2_io fileobj to write the data to
- call register_axis(fileobj, this%axis_name, size(this%diurnal_data))
- call register_field(fileobj, this%axis_name, pack_size_str, (/trim(this%axis_name)/))
- call register_variable_attribute(fileobj, this%axis_name, "units", &
+ call register_axis(fms2io_fileobj, this%axis_name, size(this%diurnal_data))
+ call register_field(fms2io_fileobj, this%axis_name, pack_size_str, (/trim(this%axis_name)/))
+ call register_variable_attribute(fms2io_fileobj, this%axis_name, "units", &
&trim(this%units), str_len=len_trim(this%units))
- call register_variable_attribute(fileobj, this%axis_name, "long_name", &
+ call register_variable_attribute(fms2io_fileobj, this%axis_name, "long_name", &
&trim(this%long_name), str_len=len_trim(this%long_name))
if (this%edges_id .ne. diag_null) &
- call register_variable_attribute(fileobj, this%axis_name, "edges", &
+ call register_variable_attribute(fms2io_fileobj, this%axis_name, "edges", &
&trim(this%edges_name), str_len=len_trim(this%edges_name))
end subroutine write_diurnal_metadata
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 9592e39978..08292df80f 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -1105,27 +1105,27 @@ end subroutine get_dimnames
!> @brief Wrapper for the register_field call. The select types are needed so that the code can go
!! in the correct interface
-subroutine register_field_wrap(fileobj, varname, vartype, dimensions)
- class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write to
+subroutine register_field_wrap(fms2io_fileobj, varname, vartype, dimensions)
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write to
character(len=*), INTENT(IN) :: varname !< Name of the variable
character(len=*), INTENT(IN) :: vartype !< The type of the variable
character(len=*), optional, INTENT(IN) :: dimensions(:) !< The dimension names of the field
- select type(fileobj)
+ select type(fms2io_fileobj)
type is (FmsNetcdfFile_t)
- call register_field(fileobj, varname, vartype, dimensions)
+ call register_field(fms2io_fileobj, varname, vartype, dimensions)
type is (FmsNetcdfDomainFile_t)
- call register_field(fileobj, varname, vartype, dimensions)
+ call register_field(fms2io_fileobj, varname, vartype, dimensions)
type is (FmsNetcdfUnstructuredDomainFile_t)
- call register_field(fileobj, varname, vartype, dimensions)
+ call register_field(fms2io_fileobj, varname, vartype, dimensions)
end select
end subroutine register_field_wrap
!> @brief Write the field's metadata to the file
-subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unlim_dimname, is_regional, &
+subroutine write_field_metadata(this, fms2io_fileobj, file_id, yaml_id, diag_axis, unlim_dimname, is_regional, &
cell_measures)
class (fmsDiagField_type), target, intent(inout) :: this !< diag field
- class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write to
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write to
integer, intent(in) :: file_id !< File id of the file to write to
integer, intent(in) :: yaml_id !< Yaml id of the yaml entry of this field
class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
@@ -1147,50 +1147,50 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
if (allocated(this%axis_ids)) then
call this%get_dimnames(diag_axis, field_yaml, unlim_dimname, dimnames, is_regional)
- call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml), dimnames)
+ call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml), dimnames)
else
if (this%is_static()) then
- call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml))
+ call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml))
else
!< In this case, the scalar variable is a function of time, so we need to pass in the
!! unlimited dimension as a dimension
- call register_field_wrap(fileobj, var_name, this%get_var_skind(field_yaml), (/unlim_dimname/))
+ call register_field_wrap(fms2io_fileobj, var_name, this%get_var_skind(field_yaml), (/unlim_dimname/))
endif
endif
long_name = this%get_longname_to_write(field_yaml)
- call register_variable_attribute(fileobj, var_name, "long_name", long_name, str_len=len_trim(long_name))
+ call register_variable_attribute(fms2io_fileobj, var_name, "long_name", long_name, str_len=len_trim(long_name))
units = this%get_units()
if (units .ne. diag_null_string) &
- call register_variable_attribute(fileobj, var_name, "units", units, str_len=len_trim(units))
+ call register_variable_attribute(fms2io_fileobj, var_name, "units", units, str_len=len_trim(units))
if (this%has_missing_value()) then
- call register_variable_attribute(fileobj, var_name, "missing_value", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "missing_value", &
this%get_missing_value(field_yaml%get_var_kind()))
- call register_variable_attribute(fileobj, var_name, "_FillValue", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "_FillValue", &
this%get_missing_value(field_yaml%get_var_kind()))
else
- call register_variable_attribute(fileobj, var_name, "missing_value", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "missing_value", &
get_default_missing_value(field_yaml%get_var_kind()))
- call register_variable_attribute(fileobj, var_name, "_FillValue", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "_FillValue", &
get_default_missing_value(field_yaml%get_var_kind()))
endif
if (this%has_data_RANGE()) then
- call register_variable_attribute(fileobj, var_name, "valid_range", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "valid_range", &
this%get_data_range(field_yaml%get_var_kind()))
endif
if (this%has_interp_method()) then
- call register_variable_attribute(fileobj, var_name, "interp_method", this%get_interp_method(), &
+ call register_variable_attribute(fms2io_fileobj, var_name, "interp_method", this%get_interp_method(), &
str_len=len_trim(this%get_interp_method()))
endif
if (.not. this%static) then
select case (field_yaml%get_var_reduction())
case (time_average, time_max, time_min, time_diurnal, time_power, time_rms, time_sum)
- call register_variable_attribute(fileobj, var_name, "time_avg_info", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "time_avg_info", &
trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT', &
str_len=len(trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT'))
end select
@@ -1200,34 +1200,34 @@ subroutine write_field_metadata(this, fileobj, file_id, yaml_id, diag_axis, unli
!< Check if any of the attributes defined via a "diag_field_add_attribute" call
!! are the cell_methods, if so add to the "cell_methods" variable:
do i = 1, this%num_attributes
- call this%attributes(i)%write_metadata(fileobj, var_name, &
+ call this%attributes(i)%write_metadata(fms2io_fileobj, var_name, &
cell_methods=cell_methods)
enddo
!< Append the time cell methods based on the variable's reduction
call this%append_time_cell_methods(cell_methods, field_yaml)
if (trim(cell_methods) .ne. "") &
- call register_variable_attribute(fileobj, var_name, "cell_methods", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "cell_methods", &
trim(adjustl(cell_methods)), str_len=len_trim(adjustl(cell_methods)))
!< Write out the cell_measures attribute (i.e Area, Volume)
!! The diag field ids for the Area and Volume are sent in the register call
!! This was defined in file object and passed in here
if (trim(cell_measures) .ne. "") &
- call register_variable_attribute(fileobj, var_name, "cell_measures", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "cell_measures", &
trim(adjustl(cell_measures)), str_len=len_trim(adjustl(cell_measures)))
!< Write out the standard_name (this was defined in the register call)
if (this%has_standname()) &
- call register_variable_attribute(fileobj, var_name, "standard_name", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "standard_name", &
trim(this%get_standname()), str_len=len_trim(this%get_standname()))
- call this%write_coordinate_attribute(fileobj, var_name, diag_axis)
+ call this%write_coordinate_attribute(fms2io_fileobj, var_name, diag_axis)
if (field_yaml%has_var_attributes()) then
yaml_field_attributes = field_yaml%get_var_attributes()
do i = 1, size(yaml_field_attributes,1)
- call register_variable_attribute(fileobj, var_name, trim(yaml_field_attributes(i,1)), &
+ call register_variable_attribute(fms2io_fileobj, var_name, trim(yaml_field_attributes(i,1)), &
trim(yaml_field_attributes(i,2)), str_len=len_trim(yaml_field_attributes(i,2)))
enddo
deallocate(yaml_field_attributes)
@@ -1236,9 +1236,9 @@ end subroutine write_field_metadata
!> @brief Writes the coordinate attribute of a field if any of the field's axis has an
!! auxiliary axis
-subroutine write_coordinate_attribute (this, fileobj, var_name, diag_axis)
+subroutine write_coordinate_attribute (this, fms2io_fileobj, var_name, diag_axis)
CLASS(fmsDiagField_type), intent(in) :: this !< The field object
- class(FmsNetcdfFile_t), INTENT(INOUT) :: fileobj !< Fms2_io fileobj to write to
+ class(FmsNetcdfFile_t), INTENT(INOUT) :: fms2io_fileobj!< Fms2_io fileobj to write to
character(len=*), intent(in) :: var_name !< Variable name
class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
@@ -1262,7 +1262,7 @@ subroutine write_coordinate_attribute (this, fileobj, var_name, diag_axis)
if (trim(aux_coord) .eq. "") return
- call register_variable_attribute(fileobj, var_name, "coordinates", &
+ call register_variable_attribute(fms2io_fileobj, var_name, "coordinates", &
trim(adjustl(aux_coord)), str_len=len_trim(adjustl(aux_coord)))
end subroutine write_coordinate_attribute
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 665a6f1683..e2c05da68f 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -72,7 +72,7 @@ module fms_diag_file_object_mod
TYPE(time_type) :: next_close !< Time to close the file
logical :: is_file_open !< .True. if the file is opened
- class(FmsNetcdfFile_t), allocatable :: fileobj !< fms2_io file object for this history file
+ class(FmsNetcdfFile_t), allocatable :: fms2io_fileobj !< fms2_io file object for this history file
type(diagYamlFiles_type), pointer :: diag_yaml_file => null() !< Pointer to the diag_yaml_file data
integer :: type_of_domain !< The type of domain to use to open the file
!! NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, SUB_REGIONAL
@@ -376,7 +376,7 @@ end function has_file_metadata_from_model
!! \return .True. if fileobj exists .False. if fileobj has not been set
pure logical function has_fileobj (this)
class(fmsDiagFile_type), intent(in) :: this !< The file object
- has_fileobj = allocated(this%fileobj)
+ has_fileobj = allocated(this%fms2io_fileobj)
end function has_fileobj
!> \brief Logical function to determine if the variable diag_yaml_file has been allocated or associated
@@ -842,7 +842,7 @@ subroutine dump_file_obj(this, unit_num)
write( unit_num, *)'next_next_output', date_to_string(this%next_next_output)
write( unit_num, *)'next_close', date_to_string(this%next_close)
- if( allocated(this%fileobj)) write( unit_num, *)'fileobj path', this%fileobj%path
+ if( allocated(this%fms2io_fileobj)) write( unit_num, *)'fileobj path', this%fms2io_fileobj%path
write( unit_num, *)'type_of_domain', this%type_of_domain
if( allocated(this%file_metadata_from_model)) write( unit_num, *) 'file_metadata_from_model', &
@@ -919,22 +919,22 @@ subroutine open_diag_file(this, time_step, file_is_opened)
if (diag_file%is_file_open) return
is_regional = .false.
- !< Figure out what fileobj to use!
- if (.not. allocated(diag_file%fileobj)) then
+ !< Figure out what fms2io_fileobj to use!
+ if (.not. allocated(diag_file%fms2io_fileobj)) then
select type (diag_file)
type is (subRegionalFile_type)
!< In this case each PE is going to write its own file
- allocate(FmsNetcdfFile_t :: diag_file%fileobj)
+ allocate(FmsNetcdfFile_t :: diag_file%fms2io_fileobj)
is_regional = .true.
type is (fmsDiagFile_type)
- !< Use the type_of_domain to get the correct fileobj
+ !< Use the type_of_domain to get the correct fms2io_fileobj
select case (diag_file%type_of_domain)
case (NO_DOMAIN)
- allocate(FmsNetcdfFile_t :: diag_file%fileobj)
+ allocate(FmsNetcdfFile_t :: diag_file%fms2io_fileobj)
case (TWO_D_DOMAIN)
- allocate(FmsNetcdfDomainFile_t :: diag_file%fileobj)
+ allocate(FmsNetcdfDomainFile_t :: diag_file%fms2io_fileobj)
case (UG_DOMAIN)
- allocate(FmsNetcdfUnstructuredDomainFile_t :: diag_file%fileobj)
+ allocate(FmsNetcdfUnstructuredDomainFile_t :: diag_file%fms2io_fileobj)
end select
end select
endif
@@ -984,29 +984,29 @@ subroutine open_diag_file(this, time_step, file_is_opened)
endif
!< Open the file!
- select type (fileobj => diag_file%fileobj)
+ select type (fms2io_fileobj => diag_file%fms2io_fileobj)
type is (FmsNetcdfFile_t)
if (is_regional) then
- if (.not. open_file(fileobj, file_name, "overwrite", pelist=(/mpp_pe()/))) &
+ if (.not. open_file(fms2io_fileobj, file_name, "overwrite", pelist=(/mpp_pe()/))) &
&call mpp_error(FATAL, "Error opening the file:"//file_name)
- call register_global_attribute(fileobj, "is_subregional", "True", str_len=4)
+ call register_global_attribute(fms2io_fileobj, "is_subregional", "True", str_len=4)
else
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
- if (.not. open_file(fileobj, file_name, "overwrite", pelist=pes)) &
+ if (.not. open_file(fms2io_fileobj, file_name, "overwrite", pelist=pes)) &
&call mpp_error(FATAL, "Error opening the file:"//file_name)
endif
type is (FmsNetcdfDomainFile_t)
select type (domain)
type is (diagDomain2d_t)
- if (.not. open_file(fileobj, file_name, "overwrite", domain%Domain2)) &
+ if (.not. open_file(fms2io_fileobj, file_name, "overwrite", domain%Domain2)) &
&call mpp_error(FATAL, "Error opening the file:"//file_name)
end select
type is (FmsNetcdfUnstructuredDomainFile_t)
select type (domain)
type is (diagDomainUg_t)
- if (.not. open_file(fileobj, file_name, "overwrite", domain%DomainUG)) &
+ if (.not. open_file(fms2io_fileobj, file_name, "overwrite", domain%DomainUG)) &
&call mpp_error(FATAL, "Error opening the file:"//file_name)
end select
end select
@@ -1021,19 +1021,19 @@ end subroutine open_diag_file
subroutine write_global_metadata(this)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
- class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to
integer :: i !< For do loops
character (len=MAX_STR_LEN), allocatable :: yaml_file_attributes(:,:) !< Global attributes defined in the yaml
type(diagYamlFiles_type), pointer :: diag_file_yaml !< The diag_file yaml
diag_file_yaml => this%FMS_diag_file%diag_yaml_file
- fileobj => this%FMS_diag_file%fileobj
+ fms2io_fileobj => this%FMS_diag_file%fms2io_fileobj
if (diag_file_yaml%has_file_global_meta()) then
yaml_file_attributes = diag_file_yaml%get_file_global_meta()
do i = 1, size(yaml_file_attributes,1)
- call register_global_attribute(fileobj, trim(yaml_file_attributes(i,1)), &
+ call register_global_attribute(fms2io_fileobj, trim(yaml_file_attributes(i,1)), &
trim(yaml_file_attributes(i,2)), str_len=len_trim(yaml_file_attributes(i,2)))
enddo
deallocate(yaml_file_attributes)
@@ -1041,18 +1041,18 @@ subroutine write_global_metadata(this)
end subroutine write_global_metadata
!< @brief Writes a variable's metadata in the netcdf file
-subroutine write_var_metadata(fileobj, variable_name, dimensions, long_name, units)
- class(FmsNetcdfFile_t), intent(inout) :: fileobj !< The file object to write into
+subroutine write_var_metadata(fms2io_fileobj, variable_name, dimensions, long_name, units)
+ class(FmsNetcdfFile_t), intent(inout) :: fms2io_fileobj !< The file object to write into
character(len=*) , intent(in) :: variable_name !< The name of the time variables
character(len=*) , intent(in) :: dimensions(:) !< The dimensions of the variable
character(len=*) , intent(in) :: long_name !< The long_name of the variable
character(len=*) , intent(in) :: units !< The units of the variable
- call register_field(fileobj, variable_name, pack_size_str, dimensions)
- call register_variable_attribute(fileobj, variable_name, "long_name", &
+ call register_field(fms2io_fileobj, variable_name, pack_size_str, dimensions)
+ call register_variable_attribute(fms2io_fileobj, variable_name, "long_name", &
trim(long_name), str_len=len_trim(long_name))
if (trim(units) .ne. no_units) &
- call register_variable_attribute(fileobj, variable_name, "units", &
+ call register_variable_attribute(fms2io_fileobj, variable_name, "units", &
trim(units), str_len=len_trim(units))
end subroutine write_var_metadata
@@ -1061,7 +1061,7 @@ subroutine write_time_metadata(this)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
- class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to
character(len=50) :: time_units_str !< Time units written as a string
character(len=50) :: calendar !< The calendar name
@@ -1069,10 +1069,10 @@ subroutine write_time_metadata(this)
character(len=50) :: dimensions(2) !< Array of dimensions names for the variable
diag_file => this%FMS_diag_file
- fileobj => diag_file%fileobj
+ fms2io_fileobj => diag_file%fms2io_fileobj
time_var_name = diag_file%get_file_unlimdim()
- call register_axis(fileobj, time_var_name, unlimited)
+ call register_axis(fms2io_fileobj, time_var_name, unlimited)
WRITE(time_units_str, 11) &
TRIM(time_unit_list(diag_file%get_file_timeunit())), get_base_year(),&
@@ -1082,39 +1082,39 @@ subroutine write_time_metadata(this)
dimensions(1) = "nv"
dimensions(2) = trim(time_var_name)
- call write_var_metadata(fileobj, time_var_name, dimensions(2:2), &
+ call write_var_metadata(fms2io_fileobj, time_var_name, dimensions(2:2), &
time_var_name, time_units_str)
!< Add additional variables to the time variable
- call register_variable_attribute(fileobj, time_var_name, "axis", "T", str_len=1 )
+ call register_variable_attribute(fms2io_fileobj, time_var_name, "axis", "T", str_len=1 )
!TODO no need to have both attributes, probably?
calendar = valid_calendar_types(get_calendar_type())
- call register_variable_attribute(fileobj, time_var_name, "calendar_type", &
+ call register_variable_attribute(fms2io_fileobj, time_var_name, "calendar_type", &
uppercase(trim(calendar)), str_len=len_trim(calendar))
- call register_variable_attribute(fileobj, time_var_name, "calendar", &
+ call register_variable_attribute(fms2io_fileobj, time_var_name, "calendar", &
lowercase(trim(calendar)), str_len=len_trim(calendar))
if (diag_file%time_ops) then
- call register_variable_attribute(fileobj, time_var_name, "bounds", &
+ call register_variable_attribute(fms2io_fileobj, time_var_name, "bounds", &
trim(time_var_name)//"_bnds", str_len=len_trim(time_var_name//"_bnds"))
!< Write out the "average_*" variables metadata
- call write_var_metadata(fileobj, avg_name//"_T1", dimensions(2:2), &
+ call write_var_metadata(fms2io_fileobj, avg_name//"_T1", dimensions(2:2), &
"Start time for average period", time_units_str)
- call write_var_metadata(fileobj, avg_name//"_T2", dimensions(2:2), &
+ call write_var_metadata(fms2io_fileobj, avg_name//"_T2", dimensions(2:2), &
"End time for average period", time_units_str)
- call write_var_metadata(fileobj, avg_name//"_DT", dimensions(2:2), &
+ call write_var_metadata(fms2io_fileobj, avg_name//"_DT", dimensions(2:2), &
"Length of average period", time_unit_list(diag_file%get_file_timeunit()))
!< It is possible that the "nv" "axis" was registered via "diag_axis_init" call
!! so only adding it if it doesn't exist already
- if ( .not. dimension_exists(fileobj, "nv")) then
- call register_axis(fileobj, "nv", 2) !< Time bounds need a vertex number
- call write_var_metadata(fileobj, "nv", dimensions(1:1), &
+ if ( .not. dimension_exists(fms2io_fileobj, "nv")) then
+ call register_axis(fms2io_fileobj, "nv", 2) !< Time bounds need a vertex number
+ call write_var_metadata(fms2io_fileobj, "nv", dimensions(1:1), &
"vertex number", no_units)
endif
- call write_var_metadata(fileobj, time_var_name//"_bnds", dimensions, &
+ call write_var_metadata(fms2io_fileobj, time_var_name//"_bnds", dimensions, &
trim(time_var_name)//" axis boundaries", time_units_str)
endif
@@ -1127,28 +1127,30 @@ subroutine write_field_data(this, field_obj, buffer_obj)
type(fmsDiagOutputBuffer_type), intent(in), target :: buffer_obj(:) !< The buffer object with the data
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
- class(FmsNetcdfFile_t), pointer :: fileobj !< Fileobj to write to
+ class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< Fileobj to write to
integer :: i !< For do loops
integer :: field_id !< The id of the field writing the data from
diag_file => this%FMS_diag_file
- fileobj => diag_file%fileobj
+ fms2io_fileobj => diag_file%fms2io_fileobj
!TODO This may be offloaded in the future
if (diag_file%is_static) then
!< Here the file is static so there is no need for the unlimited dimension
!! as a variables are static
do i = 1, diag_file%number_of_buffers
- call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fileobj)
+ call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj)
enddo
else
do i = 1, diag_file%number_of_buffers
field_id = buffer_obj(diag_file%buffer_ids(i))%get_field_id()
if (field_obj(field_id)%is_static()) then
!< If the variable is static, only write it the first time
- if (diag_file%unlim_dimension_level .eq. 1) call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fileobj)
+ if (diag_file%unlim_dimension_level .eq. 1) &
+ call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj)
else
- call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fileobj, unlim_dim_level=diag_file%unlim_dimension_level)
+ call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj, &
+ unlim_dim_level=diag_file%unlim_dimension_level)
endif
enddo
endif
@@ -1204,7 +1206,7 @@ subroutine write_time_data(this)
real :: dif !< The time as a real number
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
- class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to
TYPE(time_type) :: middle_time !< The middle time of the averaging period
real :: T1 !< The beginning time of the averaging period
@@ -1212,7 +1214,7 @@ subroutine write_time_data(this)
real :: DT !< The difference between the ending and beginning time of the averaging period
diag_file => this%FMS_diag_file
- fileobj => diag_file%fileobj
+ fms2io_fileobj => diag_file%fms2io_fileobj
if (diag_file%time_ops) then
middle_time = (diag_file%last_output+diag_file%next_output)/2
@@ -1221,7 +1223,7 @@ subroutine write_time_data(this)
dif = get_date_dif(diag_file%next_output, get_base_time(), diag_file%get_file_timeunit())
endif
- call write_data(fileobj, diag_file%get_file_unlimdim(), dif, &
+ call write_data(fms2io_fileobj, diag_file%get_file_unlimdim(), dif, &
unlim_dim_level=diag_file%unlim_dimension_level)
if (diag_file%time_ops) then
@@ -1229,14 +1231,14 @@ subroutine write_time_data(this)
T2 = get_date_dif(diag_file%next_output, get_base_time(), diag_file%get_file_timeunit())
DT = T2 - T1
- call write_data(fileobj, avg_name//"_T1", T1, unlim_dim_level=diag_file%unlim_dimension_level)
- call write_data(fileobj, avg_name//"_T2", T2, unlim_dim_level=diag_file%unlim_dimension_level)
- call write_data(fileobj, avg_name//"_DT", DT, unlim_dim_level=diag_file%unlim_dimension_level)
- call write_data(fileobj, trim(diag_file%get_file_unlimdim())//"_bnds", &
+ call write_data(fms2io_fileobj, avg_name//"_T1", T1, unlim_dim_level=diag_file%unlim_dimension_level)
+ call write_data(fms2io_fileobj, avg_name//"_T2", T2, unlim_dim_level=diag_file%unlim_dimension_level)
+ call write_data(fms2io_fileobj, avg_name//"_DT", DT, unlim_dim_level=diag_file%unlim_dimension_level)
+ call write_data(fms2io_fileobj, trim(diag_file%get_file_unlimdim())//"_bnds", &
(/T1, T2/), unlim_dim_level=diag_file%unlim_dimension_level)
if (diag_file%unlim_dimension_level .eq. 1) then
- call write_data(fileobj, "nv", (/1, 2/))
+ call write_data(fms2io_fileobj, "nv", (/1, 2/))
endif
endif
@@ -1313,7 +1315,7 @@ subroutine write_axis_metadata(this, diag_axis)
class(fmsDiagAxisContainer_type), intent(in), target :: diag_axis(:) !< Diag_axis object
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
- class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to
integer :: i,k !< For do loops
integer :: parent_axis_id !< Id of the parent_axis
integer :: structured_ids(2) !< Ids of the uncompress axis
@@ -1323,7 +1325,7 @@ subroutine write_axis_metadata(this, diag_axis)
logical :: edges_in_file !< .true. if the edges are already in the file
diag_file => this%FMS_diag_file
- fileobj => diag_file%fileobj
+ fms2io_fileobj => diag_file%fms2io_fileobj
do i = 1, diag_file%number_of_axis
edges_in_file = .false.
@@ -1336,20 +1338,20 @@ subroutine write_axis_metadata(this, diag_axis)
if (any(diag_file%axis_ids(1:diag_file%number_of_axis) .eq. edges_id)) then
edges_in_file = .true.
else
- call diag_axis(edges_id)%axis%write_axis_metadata(fileobj, .true.)
+ call diag_axis(edges_id)%axis%write_axis_metadata(fms2io_fileobj, .true.)
endif
endif
if (parent_axis_id .eq. DIAG_NULL) then
- call axis_ptr%axis%write_axis_metadata(fileobj, edges_in_file)
+ call axis_ptr%axis%write_axis_metadata(fms2io_fileobj, edges_in_file)
else
- call axis_ptr%axis%write_axis_metadata(fileobj, edges_in_file, diag_axis(parent_axis_id)%axis)
+ call axis_ptr%axis%write_axis_metadata(fms2io_fileobj, edges_in_file, diag_axis(parent_axis_id)%axis)
endif
if (axis_ptr%axis%is_unstructured_grid()) then
structured_ids = axis_ptr%axis%get_structured_axis()
do k = 1, size(structured_ids)
- call diag_axis(structured_ids(k))%axis%write_axis_metadata(fileobj, .false.)
+ call diag_axis(structured_ids(k))%axis%write_axis_metadata(fms2io_fileobj, .false.)
enddo
endif
@@ -1363,7 +1365,7 @@ subroutine write_field_metadata(this, diag_field, diag_axis)
class(fmsDiagField_type) , intent(inout), target :: diag_field(:) !<
class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
- class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
class(fmsDiagField_type), pointer :: field_ptr !< diag_field(diag_file%field_ids(i)), for convenience
@@ -1374,7 +1376,7 @@ subroutine write_field_metadata(this, diag_field, diag_axis)
is_regional = this%is_regional()
diag_file => this%FMS_diag_file
- fileobj => diag_file%fileobj
+ fms2io_fileobj => diag_file%fms2io_fileobj
do i = 1, size(diag_file%field_ids)
if (.not. diag_file%field_registered(i)) cycle !TODO do something else here
@@ -1391,7 +1393,7 @@ subroutine write_field_metadata(this, diag_field, diag_axis)
cell_measures = trim(cell_measures)//" volume: "//diag_field(field_ptr%get_volume())%get_varname(to_write=.true.)
endif
- call field_ptr%write_field_metadata(fileobj, diag_file%id, diag_file%yaml_ids(i), diag_axis, &
+ call field_ptr%write_field_metadata(fms2io_fileobj, diag_file%id, diag_file%yaml_ids(i), diag_axis, &
this%FMS_diag_file%get_file_unlimdim(), is_regional, cell_measures)
enddo
@@ -1403,28 +1405,28 @@ subroutine write_axis_data(this, diag_axis)
class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Diag_axis object
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
- class(FmsNetcdfFile_t), pointer :: fileobj !< The fileobj to write to
+ class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< The fileobj to write to
integer :: i, k !< For do loops
integer :: j !< diag_file%axis_ids(i) (for less typing)
integer :: parent_axis_id !< Id of the parent_axis
integer :: structured_ids(2) !< Ids of the uncompress axis
diag_file => this%FMS_diag_file
- fileobj => diag_file%fileobj
+ fms2io_fileobj => diag_file%fms2io_fileobj
do i = 1, diag_file%number_of_axis
j = diag_file%axis_ids(i)
parent_axis_id = diag_axis(j)%axis%get_parent_axis_id()
if (parent_axis_id .eq. DIAG_NULL) then
- call diag_axis(j)%axis%write_axis_data(fileobj)
+ call diag_axis(j)%axis%write_axis_data(fms2io_fileobj)
else
- call diag_axis(j)%axis%write_axis_data(fileobj, diag_axis(parent_axis_id)%axis)
+ call diag_axis(j)%axis%write_axis_data(fms2io_fileobj, diag_axis(parent_axis_id)%axis)
endif
if (diag_axis(j)%axis%is_unstructured_grid()) then
structured_ids = diag_axis(j)%axis%get_structured_axis()
do k = 1, size(structured_ids)
- call diag_axis(structured_ids(k))%axis%write_axis_data(fileobj)
+ call diag_axis(structured_ids(k))%axis%write_axis_data(fms2io_fileobj)
enddo
endif
enddo
@@ -1439,16 +1441,16 @@ subroutine close_diag_file(this)
!< The select types are needed here because otherwise the code will go to the
!! wrong close_file routine and things will not close propertly
- select type( fileobj => this%FMS_diag_file%fileobj)
+ select type( fms2io_fileobj => this%FMS_diag_file%fms2io_fileobj)
type is (FmsNetcdfDomainFile_t)
- call close_file(fileobj)
+ call close_file(fms2io_fileobj)
type is (FmsNetcdfFile_t)
- call close_file(fileobj)
+ call close_file(fms2io_fileobj)
type is (FmsNetcdfUnstructuredDomainFile_t)
- call close_file(fileobj)
+ call close_file(fms2io_fileobj)
end select
- !< Reset the unlimited dimension level back to 0, in case the fileobj is re-used
+ !< Reset the unlimited dimension level back to 0, in case the fms2io_fileobj is re-used
this%FMS_diag_file%unlim_dimension_level = 0
this%FMS_diag_file%is_file_open = .false.
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 7c2e706908..f23d6ea3d7 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -340,28 +340,28 @@ function get_yaml_id(this) &
end function get_yaml_id
!> @brief Write the buffer to the file
-subroutine write_buffer(this, fileobj, unlim_dim_level)
+subroutine write_buffer(this, fms2io_fileobj, unlim_dim_level)
class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
- class(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to
+ class(FmsNetcdfFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
- select type(fileobj)
+ select type(fms2io_fileobj)
type is (FmsNetcdfFile_t)
- call this%write_buffer_wrapper_netcdf(fileobj, unlim_dim_level=unlim_dim_level)
+ call this%write_buffer_wrapper_netcdf(fms2io_fileobj, unlim_dim_level=unlim_dim_level)
type is (FmsNetcdfDomainFile_t)
- call this%write_buffer_wrapper_domain(fileobj, unlim_dim_level=unlim_dim_level)
+ call this%write_buffer_wrapper_domain(fms2io_fileobj, unlim_dim_level=unlim_dim_level)
type is (FmsNetcdfUnstructuredDomainFile_t)
- call this%write_buffer_wrapper_u(fileobj, unlim_dim_level=unlim_dim_level)
+ call this%write_buffer_wrapper_u(fms2io_fileobj, unlim_dim_level=unlim_dim_level)
class default
- call mpp_error(FATAL, "The file "//trim(fileobj%path)//" is not one of the accepted types"//&
+ call mpp_error(FATAL, "The file "//trim(fms2io_fileobj%path)//" is not one of the accepted types"//&
" only FmsNetcdfFile_t, FmsNetcdfDomainFile_t, and FmsNetcdfUnstructuredDomainFile_t are accepted.")
end select
end subroutine write_buffer
-!> @brief Write the buffer to the FmsNetcdfFile_t fileobj
-subroutine write_buffer_wrapper_netcdf(this, fileobj, unlim_dim_level)
+!> @brief Write the buffer to the FmsNetcdfFile_t fms2io_fileobj
+subroutine write_buffer_wrapper_netcdf(this, fms2io_fileobj, unlim_dim_level)
class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
- type(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to
+ type(FmsNetcdfFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
character(len=:), allocatable :: varname !< name of the variable
@@ -369,24 +369,24 @@ subroutine write_buffer_wrapper_netcdf(this, fileobj, unlim_dim_level)
varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
select case(this%ndim)
case (0)
- call write_data(fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (1)
- call write_data(fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (2)
- call write_data(fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
case (3)
- call write_data(fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
case (4)
- call write_data(fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
case (5)
- call write_data(fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_netcdf
-!> @brief Write the buffer to the FmsNetcdfDomainFile_t fileobj
-subroutine write_buffer_wrapper_domain(this, fileobj, unlim_dim_level)
+!> @brief Write the buffer to the FmsNetcdfDomainFile_t fms2io_fileobj
+subroutine write_buffer_wrapper_domain(this, fms2io_fileobj, unlim_dim_level)
class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
- type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< fileobj to write to
+ type(FmsNetcdfDomainFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
character(len=:), allocatable :: varname !< name of the variable
@@ -394,24 +394,24 @@ subroutine write_buffer_wrapper_domain(this, fileobj, unlim_dim_level)
varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
select case(this%ndim)
case (0)
- call write_data(fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (1)
- call write_data(fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (2)
- call write_data(fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
case (3)
- call write_data(fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
case (4)
- call write_data(fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
case (5)
- call write_data(fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_domain
-!> @brief Write the buffer to the FmsNetcdfUnstructuredDomainFile_t fileobj
-subroutine write_buffer_wrapper_u(this, fileobj, unlim_dim_level)
+!> @brief Write the buffer to the FmsNetcdfUnstructuredDomainFile_t fms2io_fileobj
+subroutine write_buffer_wrapper_u(this, fms2io_fileobj, unlim_dim_level)
class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
- type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fileobj !< fileobj to write to
+ type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
character(len=:), allocatable :: varname !< name of the variable
@@ -419,17 +419,17 @@ subroutine write_buffer_wrapper_u(this, fileobj, unlim_dim_level)
varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
select case(this%ndim)
case (0)
- call write_data(fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (1)
- call write_data(fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (2)
- call write_data(fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
case (3)
- call write_data(fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
case (4)
- call write_data(fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
case (5)
- call write_data(fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_u
#endif
From 19034cd8c0f77bf53a55ffb3b7d3db9794968a34 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 16 Aug 2023 11:26:56 -0400
Subject: [PATCH 122/168] test: modern diag manager add reduction method tests
(#1335)
---
test_fms/diag_manager/Makefile.am | 20 +-
test_fms/diag_manager/check_time_max.F90 | 209 +++++++++++
test_fms/diag_manager/check_time_min.F90 | 209 +++++++++++
test_fms/diag_manager/check_time_none.F90 | 209 +++++++++++
test_fms/diag_manager/test_diag_manager2.sh | 33 +-
test_fms/diag_manager/test_dm_openmp.F90 | 149 --------
.../diag_manager/test_reduction_methods.F90 | 343 ++++++++++++++++++
test_fms/diag_manager/test_time_max.sh | 132 +++++++
test_fms/diag_manager/test_time_min.sh | 132 +++++++
test_fms/diag_manager/test_time_none.sh | 132 +++++++
test_fms/diag_manager/testing_utils.F90 | 53 +++
11 files changed, 1433 insertions(+), 188 deletions(-)
create mode 100644 test_fms/diag_manager/check_time_max.F90
create mode 100644 test_fms/diag_manager/check_time_min.F90
create mode 100644 test_fms/diag_manager/check_time_none.F90
delete mode 100644 test_fms/diag_manager/test_dm_openmp.F90
create mode 100644 test_fms/diag_manager/test_reduction_methods.F90
create mode 100755 test_fms/diag_manager/test_time_max.sh
create mode 100755 test_fms/diag_manager/test_time_min.sh
create mode 100755 test_fms/diag_manager/test_time_none.sh
create mode 100644 test_fms/diag_manager/testing_utils.F90
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index bfe3814a5d..de682cc7ee 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -29,9 +29,9 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
# Build this test program.
check_PROGRAMS = test_diag_manager test_diag_manager_time \
- test_diag_update_buffer test_diag_dlinked_list \
- test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer test_flexible_time \
- test_dm_openmp
+ test_diag_dlinked_list test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
+ test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
+ check_time_min check_time_max
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -43,17 +43,22 @@ test_diag_ocean_SOURCES = test_diag_ocean.F90
test_modern_diag_SOURCES = test_modern_diag.F90
test_diag_buffer_SOURCES= test_diag_buffer.F90
test_flexible_time_SOURCES = test_flexible_time.F90
-test_dm_openmp_SOURCES = test_dm_openmp.F90
+test_reduction_methods_SOURCES = testing_utils.F90 test_reduction_methods.F90
+check_time_none_SOURCES = testing_utils.F90 check_time_none.F90
+check_time_min_SOURCES = testing_utils.F90 check_time_min.F90
+check_time_max_SOURCES = testing_utils.F90 check_time_max.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
$(abs_top_srcdir)/test_fms/tap-driver.sh
# Run the test.
-TESTS = test_diag_manager2.sh
+TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh
+
+testing_utils.mod: testing_utils.$(OBJEXT)
# Copy over other needed files to the srcdir
-EXTRA_DIST = input.nml_base diagTables test_diag_manager2.sh check_crashes.sh
+EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh
if USING_YAML
skipflag=""
@@ -63,4 +68,5 @@ endif
TESTS_ENVIRONMENT = skipflag=${skipflag}
-CLEANFILES = input.nml *.nc *.out diag_table *-files/* *.dpi *.spi *.dyn *.spl
+CLEANFILES = *.yaml input.nml *.nc *.out diag_table* *-files/* *.dpi *.spi *.dyn *.spl *.mod
+
diff --git a/test_fms/diag_manager/check_time_max.F90 b/test_fms/diag_manager/check_time_max.F90
new file mode 100644
index 0000000000..b8e82f3472
--- /dev/null
+++ b/test_fms/diag_manager/check_time_max.F90
@@ -0,0 +1,209 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Checks the output file after running test_reduction_methods using the "max" reduction method
+program check_time_max
+ use fms_mod, only: fms_init, fms_end, string
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file
+ use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file
+ use platform_mod, only: r4_kind, r8_kind
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
+ type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
+ real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the 4th dimension
+ integer :: i !< For looping
+ integer :: io_status !< Io status after reading the namelist
+ logical :: use_mask !< .true. if using masks
+
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+
+ namelist / test_reduction_methods_nml / test_case, mask_case
+
+ call fms_init()
+
+ read (input_nml_file, test_reduction_methods_nml, iostat=io_status)
+
+ select case(mask_case)
+ case (no_mask)
+ use_mask = .false.
+ case (logical_mask, real_mask)
+ use_mask = .true.
+ end select
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+
+ if (.not. open_file(fileobj, "test_max.nc", "read")) &
+ call mpp_error(FATAL, "unable to open file")
+
+ if (.not. open_file(fileobj1, "test_max_regional.nc.0004", "read")) &
+ call mpp_error(FATAL, "unable to open file")
+
+ if (.not. open_file(fileobj2, "test_max_regional.nc.0005", "read")) &
+ call mpp_error(FATAL, "unable to open file")
+
+ cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw)
+
+ do i = 1, 8
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var0_max - time_level:", string(i)
+ call read_data(fileobj, "var0_max", cdata_out(1:1,1,1,1), unlim_dim_level=i) !eyeroll
+ call check_data_0d(cdata_out(1,1,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var1_max - time_level:", string(i)
+ call read_data(fileobj, "var1_max", cdata_out(:,1,1,1), unlim_dim_level=i)
+ call check_data_1d(cdata_out(:,1,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var2_max - time_level:", string(i)
+ call read_data(fileobj, "var2_max", cdata_out(:,:,1,1), unlim_dim_level=i)
+ call check_data_2d(cdata_out(:,:,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_max - time_level:", string(i)
+ call read_data(fileobj, "var3_max", cdata_out(:,:,:,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_Z_max - time_level:", string(i)
+ call read_data(fileobj, "var3_Z_max", cdata_out(:,:,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_max in the first regional file- time_level:", string(i)
+ call read_data(fileobj1, "var3_max", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_max in the second regional file- time_level:", string(i)
+ call read_data(fileobj2, "var3_max", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1)
+ enddo
+
+ call fms_end()
+
+contains
+
+ !> @brief Check that the 0d data read in is correct
+ subroutine check_data_0d(buffer, time_level)
+ real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ buffer_exp = real(1000_r8_kind+10_r8_kind+1_r8_kind + &
+ real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+
+ if (abs(buffer - buffer_exp) > 0) then
+ print *, mpp_pe(), time_level, buffer, buffer_exp
+ call mpp_error(FATAL, "Check_time_max::check_data_0d:: Data is not correct")
+ endif
+ end subroutine check_data_0d
+
+ !> @brief Check that the 1d data read in is correct
+ subroutine check_data_1d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer ii, j, k, l !< For looping
+
+ do ii = 1, size(buffer, 1)
+ buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+10_r8_kind+1_r8_kind + &
+ real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii) - buffer_exp) > 0) then
+ print *, mpp_pe(), ii, buffer(ii), buffer_exp
+ call mpp_error(FATAL, "Check_time_max::check_data_1d:: Data is not correct")
+ endif
+ enddo
+ end subroutine check_data_1d
+
+ !> @brief Check that the 2d data read in is correct
+ subroutine check_data_2d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer ii, j, k, l !< For looping
+
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+ &
+ 10_r8_kind*real(j, kind=r8_kind)+1_r8_kind + &
+ real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j) - buffer_exp) > 0) then
+ print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp
+ call mpp_error(FATAL, "Check_time_max::check_data_2d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ end subroutine check_data_2d
+
+ !> @brief Check that the 3d data read in is correct
+ subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ logical, intent(in) :: is_regional !< .True. if the variable is subregional
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer, optional, intent(in) :: nx_offset !< Offset in the x direction
+ integer, optional, intent(in) :: ny_offset !< Offset in the y direction
+ integer, optional, intent(in) :: nz_offset !< Offset in the z direction
+
+ integer :: ii, j, k, l !< For looping
+ integer :: nx_oset !< Offset in the x direction (local variable)
+ integer :: ny_oset !< Offset in the y direction (local variable)
+ integer :: nz_oset !< Offset in the z direction (local variable)
+
+ nx_oset = 0
+ if (present(nx_offset)) nx_oset = nx_offset
+
+ ny_oset = 0
+ if (present(ny_offset)) ny_oset = ny_offset
+
+ nz_oset = 0
+ if (present(nz_offset)) nz_oset = nz_offset
+
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do k = 1, size(buffer, 3)
+ buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000_r8_kind + &
+ 10_r8_kind*real(j+ny_oset, kind=r8_kind) + &
+ 1_r8_kind*real(k+nz_oset, kind=r8_kind) + &
+ real(6*time_level, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j, k) - buffer_exp) > 0) then
+ print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp
+ call mpp_error(FATAL, "Check_time_max::check_data_3d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_3d
+end program
\ No newline at end of file
diff --git a/test_fms/diag_manager/check_time_min.F90 b/test_fms/diag_manager/check_time_min.F90
new file mode 100644
index 0000000000..f0d8f8029d
--- /dev/null
+++ b/test_fms/diag_manager/check_time_min.F90
@@ -0,0 +1,209 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Checks the output file after running test_reduction_methods using the "min" reduction method
+program check_time_min
+ use fms_mod, only: fms_init, fms_end, string
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file
+ use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file
+ use platform_mod, only: r4_kind, r8_kind
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
+ type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
+ real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the 4th dimension
+ integer :: i !< For looping
+ integer :: io_status !< Io status after reading the namelist
+ logical :: use_mask !< .true. if using masks
+
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+
+ namelist / test_reduction_methods_nml / test_case, mask_case
+
+ call fms_init()
+
+ read (input_nml_file, test_reduction_methods_nml, iostat=io_status)
+
+ select case(mask_case)
+ case (no_mask)
+ use_mask = .false.
+ case (logical_mask, real_mask)
+ use_mask = .true.
+ end select
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+
+ if (.not. open_file(fileobj, "test_min.nc", "read")) &
+ call mpp_error(FATAL, "unable to open file")
+
+ if (.not. open_file(fileobj1, "test_min_regional.nc.0004", "read")) &
+ call mpp_error(FATAL, "unable to open file")
+
+ if (.not. open_file(fileobj2, "test_min_regional.nc.0005", "read")) &
+ call mpp_error(FATAL, "unable to open file")
+
+ cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw)
+
+ do i = 1, 8
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var0_min - time_level:", string(i)
+ call read_data(fileobj, "var0_min", cdata_out(1:1,1,1,1), unlim_dim_level=i) !eyeroll
+ call check_data_0d(cdata_out(1,1,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var1_min - time_level:", string(i)
+ call read_data(fileobj, "var1_min", cdata_out(:,1,1,1), unlim_dim_level=i)
+ call check_data_1d(cdata_out(:,1,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var2_min - time_level:", string(i)
+ call read_data(fileobj, "var2_min", cdata_out(:,:,1,1), unlim_dim_level=i)
+ call check_data_2d(cdata_out(:,:,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_min - time_level:", string(i)
+ call read_data(fileobj, "var3_min", cdata_out(:,:,:,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_Z_min - time_level:", string(i)
+ call read_data(fileobj, "var3_Z_min", cdata_out(:,:,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_min in the first regional file- time_level:", string(i)
+ call read_data(fileobj1, "var3_min", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_min in the second regional file- time_level:", string(i)
+ call read_data(fileobj2, "var3_min", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1)
+ enddo
+
+ call fms_end()
+
+contains
+
+ !> @brief Check that the 0d data read in is correct
+ subroutine check_data_0d(buffer, time_level)
+ real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ buffer_exp = real(1000_r8_kind+10_r8_kind+1_r8_kind + &
+ real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+
+ if (abs(buffer - buffer_exp) > 0) then
+ print *, mpp_pe(), time_level, buffer, buffer_exp
+ call mpp_error(FATAL, "Check_time_min::check_data_0d:: Data is not correct")
+ endif
+ end subroutine check_data_0d
+
+ !> @brief Check that the 1d data read in is correct
+ subroutine check_data_1d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer ii, j, k, l !< For looping
+
+ do ii = 1, size(buffer, 1)
+ buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+10_r8_kind+1_r8_kind + &
+ real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii) - buffer_exp) > 0) then
+ print *, mpp_pe(), ii, buffer(ii), buffer_exp
+ call mpp_error(FATAL, "Check_time_min::check_data_1d:: Data is not correct")
+ endif
+ enddo
+ end subroutine check_data_1d
+
+ !> @brief Check that the 2d data read in is correct
+ subroutine check_data_2d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer ii, j, k, l !< For looping
+
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+ &
+ 10_r8_kind*real(j, kind=r8_kind)+1_r8_kind + &
+ real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j) - buffer_exp) > 0) then
+ print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp
+ call mpp_error(FATAL, "Check_time_min::check_data_2d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ end subroutine check_data_2d
+
+ !> @brief Check that the 3d data read in is correct
+ subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ logical, intent(in) :: is_regional !< .True. if the variable is subregional
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer, optional, intent(in) :: nx_offset !< Offset in the x direction
+ integer, optional, intent(in) :: ny_offset !< Offset in the y direction
+ integer, optional, intent(in) :: nz_offset !< Offset in the z direction
+
+ integer :: ii, j, k, l !< For looping
+ integer :: nx_oset !< Offset in the x direction (local variable)
+ integer :: ny_oset !< Offset in the y direction (local variable)
+ integer :: nz_oset !< Offset in the z direction (local variable)
+
+ nx_oset = 0
+ if (present(nx_offset)) nx_oset = nx_offset
+
+ ny_oset = 0
+ if (present(ny_offset)) ny_oset = ny_offset
+
+ nz_oset = 0
+ if (present(nz_offset)) nz_oset = nz_offset
+
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do k = 1, size(buffer, 3)
+ buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000_r8_kind + &
+ 10_r8_kind*real(j+ny_oset, kind=r8_kind) + &
+ 1_r8_kind*real(k+nz_oset, kind=r8_kind) + &
+ real(6*(time_level-1)+1, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j, k) - buffer_exp) > 0) then
+ print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp
+ call mpp_error(FATAL, "Check_time_min::check_data_3d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_3d
+end program
\ No newline at end of file
diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90
new file mode 100644
index 0000000000..11844448c0
--- /dev/null
+++ b/test_fms/diag_manager/check_time_none.F90
@@ -0,0 +1,209 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Checks the output file after running test_reduction_methods using the "none" reduction method
+program check_time_none
+ use fms_mod, only: fms_init, fms_end, string
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file
+ use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file
+ use platform_mod, only: r4_kind, r8_kind
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
+ type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
+ real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the 4th dimension
+ integer :: i !< For looping
+ integer :: io_status !< Io status after reading the namelist
+ logical :: use_mask !< .true. if using masks
+
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+
+ namelist / test_reduction_methods_nml / test_case, mask_case
+
+ call fms_init()
+
+ read (input_nml_file, test_reduction_methods_nml, iostat=io_status)
+
+ select case(mask_case)
+ case (no_mask)
+ use_mask = .false.
+ case (logical_mask, real_mask)
+ use_mask = .true.
+ end select
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+
+ if (.not. open_file(fileobj, "test_none.nc", "read")) &
+ call mpp_error(FATAL, "unable to open file")
+
+ if (.not. open_file(fileobj1, "test_none_regional.nc.0004", "read")) &
+ call mpp_error(FATAL, "unable to open file")
+
+ if (.not. open_file(fileobj2, "test_none_regional.nc.0005", "read")) &
+ call mpp_error(FATAL, "unable to open file")
+
+ cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw)
+
+ do i = 1, 8
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var0_none - time_level:", string(i)
+ call read_data(fileobj, "var0_none", cdata_out(1:1,1,1,1), unlim_dim_level=i) !eyeroll
+ call check_data_0d(cdata_out(1,1,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var1_none - time_level:", string(i)
+ call read_data(fileobj, "var1_none", cdata_out(:,1,1,1), unlim_dim_level=i)
+ call check_data_1d(cdata_out(:,1,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var2_none - time_level:", string(i)
+ call read_data(fileobj, "var2_none", cdata_out(:,:,1,1), unlim_dim_level=i)
+ call check_data_2d(cdata_out(:,:,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_none - time_level:", string(i)
+ call read_data(fileobj, "var3_none", cdata_out(:,:,:,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_Z - time_level:", string(i)
+ call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_none in the first regional file- time_level:", string(i)
+ call read_data(fileobj1, "var3_none", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_none in the second regional file- time_level:", string(i)
+ call read_data(fileobj2, "var3_none", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1)
+ enddo
+
+ call fms_end()
+
+contains
+
+ !> @brief Check that the 0d data read in is correct
+ subroutine check_data_0d(buffer, time_level)
+ real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ buffer_exp = real(1000_r8_kind+10_r8_kind+1_r8_kind + &
+ real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+
+ if (abs(buffer - buffer_exp) > 0) then
+ print *, mpp_pe(), time_level, buffer_exp
+ call mpp_error(FATAL, "Check_time_none::check_data_0d:: Data is not correct")
+ endif
+ end subroutine check_data_0d
+
+ !> @brief Check that the 1d data read in is correct
+ subroutine check_data_1d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer ii, j, k, l !< For looping
+
+ do ii = 1, size(buffer, 1)
+ buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+10_r8_kind+1_r8_kind + &
+ real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii) - buffer_exp) > 0) then
+ print *, mpp_pe(), ii, buffer(ii), buffer_exp
+ call mpp_error(FATAL, "Check_time_none::check_data_1d:: Data is not correct")
+ endif
+ enddo
+ end subroutine check_data_1d
+
+ !> @brief Check that the 2d data read in is correct
+ subroutine check_data_2d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer ii, j, k, l !< For looping
+
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ buffer_exp = real(real(ii, kind=r8_kind)* 1000_r8_kind+ &
+ 10_r8_kind*real(j, kind=r8_kind)+1_r8_kind + &
+ real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j) - buffer_exp) > 0) then
+ print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp
+ call mpp_error(FATAL, "Check_time_none::check_data_2d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ end subroutine check_data_2d
+
+ !> @brief Check that the 3d data read in is correct
+ subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ logical, intent(in) :: is_regional !< .True. if the variable is subregional
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer, optional, intent(in) :: nx_offset !< Offset in the x direction
+ integer, optional, intent(in) :: ny_offset !< Offset in the y direction
+ integer, optional, intent(in) :: nz_offset !< Offset in the z direction
+
+ integer :: ii, j, k, l !< For looping
+ integer :: nx_oset !< Offset in the x direction (local variable)
+ integer :: ny_oset !< Offset in the y direction (local variable)
+ integer :: nz_oset !< Offset in the z direction (local variable)
+
+ nx_oset = 0
+ if (present(nx_offset)) nx_oset = nx_offset
+
+ ny_oset = 0
+ if (present(ny_offset)) ny_oset = ny_offset
+
+ nz_oset = 0
+ if (present(nz_offset)) nz_oset = nz_offset
+
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do k = 1, size(buffer, 3)
+ buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000_r8_kind + &
+ 10_r8_kind*real(j+ny_oset, kind=r8_kind) + &
+ 1_r8_kind*real(k+nz_oset, kind=r8_kind) + &
+ real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j, k) - buffer_exp) > 0) then
+ print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp
+ call mpp_error(FATAL, "Check_time_none::check_data_3d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_3d
+end program
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 1fc8c1e3c1..813e225156 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -478,7 +478,6 @@ test_diag_manager
"test_diag_manager_mod", "sst", "sst", "ocn_end%4yr%2mo%2dy%2hr", "all", .true., "none", 2
_EOF
-my_test_count=25
rm -f input.nml && touch input.nml
test_expect_success "wildcard filenames (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager_time
@@ -505,7 +504,7 @@ test_expect_success "diurnal test (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager_time
'
setup_test
-my_test_count=26
+my_test_count=`expr $my_test_count + 1`
test_expect_success "Test the diag update_buffer (test $my_test_count)" '
mpirun -n 1 ../test_diag_update_buffer
'
@@ -866,36 +865,6 @@ printf "&diag_manager_nml \n use_modern_diag = .false. \n use_clock_average = .t
mpirun -n 1 ../test_flexible_time
'
-printf "&diag_manager_nml \n use_modern_diag = .true. \n /" | cat > input.nml
-cat <<_EOF > diag_table.yaml
-title: test_diag_manager
-base_date: 2 1 1 0 0 0
-diag_files:
-- file_name: file_openmp_test
- freq: 1 hours
- time_units: hours
- unlimdim: time
- varlist:
- - module: ocn_mod
- var_name: var1
- reduction: none
- kind: r4
- - module: ocn_mod
- var_name: var2
- reduction: none
- kind: r4
- - module: ocn_mod
- var_name: var3
- reduction: none
- kind: r4
-_EOF
-
-export OMP_NUM_THREADS=2
-my_test_count=`expr $my_test_count + 1`
- test_expect_success "Test the modern diag manager end to end but it uses the openmp stuff(test $my_test_count)" '
- mpirun -n 6 ../test_dm_openmp
- '
-export OMP_NUM_THREADS=1
else
my_test_count=`expr $my_test_count + 1`
test_expect_failure "test modern diag manager failure when compiled without -Duse-yaml flag (test $my_test_count)" '
diff --git a/test_fms/diag_manager/test_dm_openmp.F90 b/test_fms/diag_manager/test_dm_openmp.F90
deleted file mode 100644
index 99ca790aac..0000000000
--- a/test_fms/diag_manager/test_dm_openmp.F90
+++ /dev/null
@@ -1,149 +0,0 @@
-!***********************************************************************
-!* 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 .
-!***********************************************************************
-
-!> @brief This programs tests the modern diag_manager
-
-program test_diag_openmp
- use omp_lib
- use mpp_mod, only: mpp_npes, mpp_pe, mpp_sync
- use platform_mod, only: r8_kind
- use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain
- use block_control_mod, only: block_control_type, define_blocks
- use fms_mod, only: fms_init, fms_end
- use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
- diag_send_complete, diag_manager_set_time_end, send_data, register_static_field
- use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time
-
-
- implicit none
-
- integer :: nx !< Number of points in the x direction
- integer :: ny !< Number of points in the y direction
- integer :: nz !< Number of points in the z direction
- integer :: layout(2) !< Layout
- integer :: io_layout(2) !< Io layout
- type(domain2d) :: Domain !< 2D domain
- integer :: is !< Starting x compute index
- integer :: ie !< Ending x compute index
- integer :: js !< Starting y compute index
- integer :: je !< Ending y compute index
- type(time_type) :: Time !< Time of the simulation
- type(time_type) :: Time_step !< Time of the simulation
- real, dimension(:), allocatable :: x !< X axis data
- integer :: id_x !< axis id for the x dimension
- real, dimension(:), allocatable :: y !< Y axis_data
- integer :: id_y !< axis id for the y dimension
- real, dimension(:), allocatable :: z !< Z axis data
- integer :: id_z !< axis id for the z dimension
- real(kind=r8_kind), allocatable :: var(:,:,:) !< Dummy variable data
- integer :: i, j !< For do loops
- type(block_control_type) :: my_block !< Returns instantiated @ref block_control_type
- logical :: message !< Flag for outputting debug message
- integer :: isw !< Starting index for each thread in the x direction
- integer :: iew !< Ending index for each thread in the x direction
- integer :: jsw !< Starting index for each thread in the y direction
- integer :: jew !< Ending index for each thread in the y direction
- integer :: is1 !< Starting index for each thread in the x direction (1-based)
- integer :: ie1 !< Ending index for each thread in the x direction (1-based)
- integer :: js1 !< Starting index for each thread in the y direction (1-based)
- integer :: je1 !< Ending index for each thread in the y direction (1-based)
- integer :: id_var1 !< diag_field id for var in 1d
- integer :: id_var2 !< diag_field id for var in lon/lat grid
- integer :: id_var3 !< diag_field id for var in lon/lat/z grid
- logical :: used !< .true. if the send_data call was sucessful
-
- call fms_init
- call set_calendar_type(JULIAN)
- call diag_manager_init
-
- nx = 96
- ny = 96
- nz = 5
- layout = (/1, mpp_npes()/)
- io_layout = (/1, 1/)
-
- ! Set up the intial time
- Time = set_date(2,1,1,0,0,0)
-
- !< Create a lat/lon domain
- call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain')
- call mpp_define_io_domain(Domain, io_layout)
- call mpp_get_compute_domain(Domain, is, ie, js, je)
-
- ! Set up the data
- allocate(x(nx), y(ny), z(nz))
- allocate(var(is:ie, js:je, nz))
- do i=1,nx
- x(i) = i
- enddo
-
- do i=1,ny
- y(i) = i
- enddo
-
- do i=1,nz
- z(i) = i
- enddo
-
- !< Register the axis:
- id_x = diag_axis_init('x', x, 'point_E', 'x', long_name='point_E', Domain2=Domain)
- id_y = diag_axis_init('y', y, 'point_N', 'y', long_name='point_N', Domain2=Domain)
- id_z = diag_axis_init('z', z, 'pressure', 'z', long_name='too much pressure')
-
- !< Register the variables
- id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x/), Time, 'Var in a lon domain', 'mullions')
- id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_x, id_y/), Time, 'Var in a lon/lat domain', 'mullions')
- id_var3 = register_diag_field ('ocn_mod', 'var3', (/id_x, id_y, id_z/), Time, &
- 'Var in a lon/lat/z domain', 'mullions')
-
- call diag_manager_set_time_end(set_date(2,1,2,0,0,0))
-
- !< Divide the domain further into blocks
- call define_blocks ('testing_model', my_block, is, ie, js, je, kpts=0, &
- nx_block=1, ny_block=4, message=message)
-
- Time_step = set_time (3600,0) !< 1 hour
- do j = 1, 23 !simulated time
- Time = set_date(2,1,1,j,0,0)
- var = real(j, kind=r8_kind) !< Set the data
-!$OMP parallel do default(shared) private(i, isw, iew, jsw, jew) schedule (dynamic,1)
- do i = 1, 4
- isw = my_block%ibs(i)
- jsw = my_block%jbs(i)
- iew = my_block%ibe(i)
- jew = my_block%jbe(i)
-
- !--- indices for 1-based arrays ---
- is1 = isw-is+1
- ie1 = iew-is+1
- js1 = jsw-js+1
- je1 = jew-js+1
-
- used=send_data(id_var1, var(is1:ie1, 1, 1), time, is_in=is1, ie_in=ie1)
- used=send_data(id_var2, var(is1:ie1, js1:je1, 1), time, is_in=is1, js_in=js1, &
- ie_in=ie1, je_in=je1)
- used=send_data(id_var3, var(is1:ie1, js1:je1, :), time, is_in=is1, js_in=js1, &
- ie_in=ie1, je_in=je1, ks_in=1, ke_in=nz)
- enddo
- call diag_send_complete(Time_step)
- enddo
-
- call diag_manager_end(Time)
- call fms_end
-end program test_diag_openmp
\ No newline at end of file
diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90
new file mode 100644
index 0000000000..3f85a043f0
--- /dev/null
+++ b/test_fms/diag_manager/test_reduction_methods.F90
@@ -0,0 +1,343 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief General program to test the different possible reduction methods
+program test_reduction_methods
+ use fms_mod, only: fms_init, fms_end
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+ use platform_mod, only: r8_kind
+ use block_control_mod, only: block_control_type, define_blocks
+ use mpp_mod, only: mpp_sync, FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast, input_nml_file
+ use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+)
+ use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
+ diag_send_complete, diag_manager_set_time_end, send_data
+ use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain, &
+ mpp_get_data_domain
+
+ implicit none
+
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the 4th dimension
+ integer :: layout(2) !< Layout
+ integer :: io_layout(2) !< Io layout
+ type(domain2d) :: Domain !< 2D domain
+ integer :: isc, isd !< Starting x compute, data domain index
+ integer :: iec, ied !< Ending x compute, data domain index
+ integer :: jsc, jsd !< Starting y compute, data domaine index
+ integer :: jec, jed !< Ending y compute, data domain index
+ integer :: nhalox !< Number of halos in x
+ integer :: nhaloy !< Number of halos in y
+ real(kind=r8_kind), allocatable :: cdata(:,:,:,:) !< Data in the compute domain
+ real(kind=r8_kind), allocatable :: ddata(:,:,:,:) !< Data in the data domain
+ real(kind=r8_kind), allocatable :: crmask(:,:,:,:) !< Mask in the compute domain
+ real(kind=r8_kind), allocatable :: drmask(:,:,:,:) !< Mask in the data domain
+ logical, allocatable :: clmask(:,:,:,:) !< Logical mask in the compute domain
+ logical, allocatable :: dlmask(:,:,:,:) !< Logical mask in the data domain
+ type(time_type) :: Time !< Time of the simulation
+ type(time_type) :: Time_step !< Time of the simulation
+ integer :: ntimes !< Number of times
+ integer :: id_x !< axis id for the x dimension
+ integer :: id_y !< axis id for the y dimension
+ integer :: id_z !< axis id for the z dimension
+ integer :: id_w !< axis id for the w dimension
+ integer :: id_var0 !< diag_field id for 0d var
+ integer :: id_var1 !< diag_field id for 1d var
+ integer :: id_var2 !< diag_field id for 2d var
+ integer :: id_var3 !< diag_field id for 3d var
+ integer :: id_var4 !< diag_field id for 4d var
+ integer :: io_status !< Status after reading the namelist
+ type(block_control_type) :: my_block !< Returns instantiated @ref block_control_type
+ logical :: message !< Flag for outputting debug message
+ integer :: isd1 !< Starting x data domain index (1-based)
+ integer :: ied1 !< Ending x data domain index (1-based)
+ integer :: jsd1 !< Starting y data domain index (1-based)
+ integer :: jed1 !< Ending y data domain index (1-based)
+ integer :: isw !< Starting index for each thread in the x direction
+ integer :: iew !< Ending index for each thread in the x direction
+ integer :: jsw !< Starting index for each thread in the y direction
+ integer :: jew !< Ending index for each thread in the y direction
+ integer :: is1 !< Starting index for each thread in the x direction (1-based)
+ integer :: ie1 !< Ending index for each thread in the x direction (1-based)
+ integer :: js1 !< Starting index for each thread in the y direction (1-based)
+ integer :: je1 !< Ending index for each thread in the y direction (1-based)
+ integer :: iblock !< For looping through the blocks
+ integer :: i !< For do loops
+ logical :: used !< Dummy argument to send_data
+ real(kind=r8_kind) :: missing_value !< Missing value to use
+
+ !< Configuration parameters
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+
+ namelist / test_reduction_methods_nml / test_case, mask_case
+
+ call fms_init
+ call set_calendar_type(JULIAN)
+ call diag_manager_init
+
+ read (input_nml_file, test_reduction_methods_nml, iostat=io_status)
+ if (io_status > 0) call mpp_error(FATAL,'=>test_modern_diag: Error reading input.nml')
+
+ Time = set_date(2,1,1,0,0,0)
+ Time_step = set_time (3600,0) !< 1 hour
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+ layout = (/1, mpp_npes()/)
+ io_layout = (/1, 1/)
+ nhalox = 2
+ nhaloy = 2
+ ntimes = 48
+
+ !< Create a lat/lon domain
+ call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain', xhalo=nhalox, yhalo=nhaloy)
+ call mpp_define_io_domain(Domain, io_layout)
+ call mpp_get_compute_domain(Domain, isc, iec, jsc, jec)
+ call mpp_get_data_domain(Domain, isd, ied, jsd, jed)
+
+ cdata = allocate_buffer(isc, iec, jsc, jec, nz, nw)
+ call init_buffer(cdata, isc, iec, jsc, jec, 0)
+
+ select case (test_case)
+ case (test_normal)
+ if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the normal send_data calls"
+ case (test_halos)
+ if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the send_data calls with halos"
+ ddata = allocate_buffer(isd, ied, jsd, jed, nz, nw)
+ call init_buffer(ddata, isc, iec, jsc, jec, 2) !< The halos never get set
+ case (test_openmp)
+ if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the send_data calls with openmp blocks"
+ call define_blocks ('testing_model', my_block, isc, iec, jsc, jec, kpts=0, &
+ nx_block=1, ny_block=4, message=message)
+ end select
+
+ select case (mask_case)
+ case (logical_mask)
+ clmask = allocate_logical_mask(isc, iec, jsc, jec, nz, nw)
+ if (mpp_pe() .eq. 0) clmask(isc, jsc, 1, 1) = .False.
+
+ if (test_case .eq. test_halos) then
+ dlmask = allocate_logical_mask(isd, ied, jsd, jed, nz, nw)
+ if (mpp_pe() .eq. 0) dlmask(1+nhalox, 1+nhaloy, 1, 1) = .False.
+ endif
+ case (real_mask)
+ crmask = allocate_real_mask(isc, iec, jsc, jec, nz, nw)
+ if (mpp_pe() .eq. 0) crmask(isc, jsc, 1, 1) = 0_r8_kind
+
+ if (test_case .eq. test_halos) then
+ drmask = allocate_real_mask(isd, ied, jsd, jed, nz, nw)
+ if (mpp_pe() .eq. 0) drmask(1+nhalox, 1+nhaloy, 1, 1) = 0_r8_kind
+ endif
+ end select
+
+ !< Register the axis
+ id_x = diag_axis_init('x', real((/ (i, i = 1,nx) /), kind=r8_kind), 'point_E', 'x', long_name='point_E', &
+ Domain2=Domain)
+ id_y = diag_axis_init('y', real((/ (i, i = 1,ny) /), kind=r8_kind), 'point_N', 'y', long_name='point_N', &
+ Domain2=Domain)
+ id_z = diag_axis_init('z', real((/ (i, i = 1,nz) /), kind=r8_kind), 'point_Z', 'z', long_name='point_Z')
+ id_w = diag_axis_init('w', real((/ (i, i = 1,nw) /), kind=r8_kind), 'point_W', 'n', long_name='point_W')
+
+ missing_value = -666._r8_kind
+ !< Register the fields
+ id_var0 = register_diag_field ('ocn_mod', 'var0', Time, 'Var0d', &
+ 'mullions', missing_value = missing_value)
+ id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x/), Time, 'Var1d', &
+ 'mullions', missing_value = missing_value)
+ id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_x, id_y/), Time, 'Var2d', &
+ 'mullions', missing_value = missing_value)
+ id_var3 = register_diag_field ('ocn_mod', 'var3', (/id_x, id_y, id_z/), Time, 'Var3d', &
+ 'mullions', missing_value = missing_value)
+ id_var4 = register_diag_field ('ocn_mod', 'var4', (/id_x, id_y, id_z, id_w/), Time, 'Var4d', &
+ 'mullions', missing_value = missing_value)
+
+ !< Get the data domain indices (1 based)
+ isd1 = isc-isd+1
+ jsd1 = jsc-jsd+1
+ ied1 = isd1 + iec-isc
+ jed1 = jsd1 + jec-jsc
+
+ call diag_manager_set_time_end(set_date(2,1,3,0,0,0))
+ do i = 1, ntimes
+ Time = Time + Time_step
+
+ call set_buffer(cdata, i)
+ used = send_data(id_var0, cdata(1,1,1,1), Time)
+
+ select case(test_case)
+ case (test_normal)
+ select case (mask_case)
+ case (no_mask)
+ used = send_data(id_var1, cdata(:,1,1,1), Time)
+ used = send_data(id_var2, cdata(:,:,1,1), Time)
+ used = send_data(id_var3, cdata(:,:,:,1), Time)
+ case (real_mask)
+ used = send_data(id_var1, cdata(:,1,1,1), Time, rmask=crmask(:,1,1,1))
+ used = send_data(id_var2, cdata(:,:,1,1), Time, rmask=crmask(:,:,1,1))
+ used = send_data(id_var3, cdata(:,:,:,1), Time, rmask=crmask(:,:,:,1))
+ case (logical_mask)
+ used = send_data(id_var1, cdata(:,1,1,1), Time, mask=clmask(:,1,1,1))
+ used = send_data(id_var2, cdata(:,:,1,1), Time, mask=clmask(:,:,1,1))
+ used = send_data(id_var3, cdata(:,:,:,1), Time, mask=clmask(:,:,:,1))
+ end select
+ case (test_halos)
+ call set_buffer(ddata, i)
+ select case (mask_case)
+ case (no_mask)
+ used = send_data(id_var1, cdata(:,1,1,1), Time)
+ used = send_data(id_var2, ddata(:,:,1,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1)
+ used = send_data(id_var3, ddata(:,:,:,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1)
+ case (real_mask)
+ used = send_data(id_var1, cdata(:,1,1,1), Time, &
+ rmask=crmask(:,1,1,1))
+ used = send_data(id_var2, ddata(:,:,1,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ rmask=drmask(:,:,1,1))
+ used = send_data(id_var3, ddata(:,:,:,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ rmask=drmask(:,:,:,1))
+ case (logical_mask)
+ used = send_data(id_var1, cdata(:,1,1,1), Time, &
+ mask=clmask(:,1,1,1))
+ used = send_data(id_var2, ddata(:,:,1,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ mask=dlmask(:,:,1,1))
+ used = send_data(id_var3, ddata(:,:,:,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ mask=dlmask(:,:,:,1))
+ end select
+ case (test_openmp)
+!$OMP parallel do default(shared) private(iblock, isw, iew, jsw, jew, is1, ie1, js1, je1)
+ do iblock=1, 4
+ isw = my_block%ibs(iblock)
+ jsw = my_block%jbs(iblock)
+ iew = my_block%ibe(iblock)
+ jew = my_block%jbe(iblock)
+
+ !--- indices for 1-based arrays ---
+ is1 = isw-isc+1
+ ie1 = iew-isc+1
+ js1 = jsw-jsc+1
+ je1 = jew-jsc+1
+
+ select case (mask_case)
+ case (no_mask)
+ used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1)
+ used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1)
+ used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1)
+ case (real_mask)
+ used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1, &
+ rmask=crmask(is1:ie1, 1, 1, 1))
+ used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, &
+ rmask=crmask(is1:ie1, js1:je1, 1, 1))
+ used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, &
+ rmask=crmask(is1:ie1, js1:je1, :, 1))
+ case (logical_mask)
+ used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1, &
+ mask=clmask(is1:ie1, 1, 1, 1))
+ used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, &
+ mask=clmask(is1:ie1, js1:je1, 1, 1))
+ used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, &
+ mask=clmask(is1:ie1, js1:je1, :, 1))
+ end select
+ enddo
+ end select
+
+ call diag_send_complete(Time_step)
+ enddo
+
+ call diag_manager_end(Time)
+
+ call fms_end
+
+ contains
+
+ !> @brief Allocate the logical mask based on the starting/ending indices
+ !! @return logical mask initiliazed to .True.
+ function allocate_logical_mask(is, ie, js, je, k, l) &
+ result(buffer)
+ integer, intent(in) :: is !< Starting x index
+ integer, intent(in) :: ie !< Ending x index
+ integer, intent(in) :: js !< Starting y index
+ integer, intent(in) :: je !< Ending y index
+ integer, intent(in) :: k !< Number of points in the 4th dimension
+ integer, intent(in) :: l !< Number of points in the 5th dimension
+
+ logical, allocatable :: buffer(:,:,:,:)
+
+ allocate(buffer(is:ie, js:je, 1:k, 1:l))
+ buffer = .True.
+ end function allocate_logical_mask
+
+ !> @brief Allocate the real mask based on the starting/ending indices
+ !! @returnreal mask initiliazed to 1_r8_kind
+ function allocate_real_mask(is, ie, js, je, k, l) &
+ result(buffer)
+ integer, intent(in) :: is !< Starting x index
+ integer, intent(in) :: ie !< Ending x index
+ integer, intent(in) :: js !< Starting y index
+ integer, intent(in) :: je !< Ending y index
+ integer, intent(in) :: k !< Number of points in the 4th dimension
+ integer, intent(in) :: l !< Number of points in the 5th dimension
+ real(kind=r8_kind), allocatable :: buffer(:,:,:,:)
+
+ allocate(buffer(is:ie, js:je, 1:k, 1:l))
+ buffer = 1.0_r8_kind
+ end function allocate_real_mask
+
+ !> @brief initiliazed the buffer based on the starting/ending indices
+ subroutine init_buffer(buffer, is, ie, js, je, nhalo)
+ real(kind=r8_kind), intent(inout) :: buffer(:,:,:,:) !< output buffer
+ integer, intent(in) :: is !< Starting x index
+ integer, intent(in) :: ie !< Ending x index
+ integer, intent(in) :: js !< Starting y index
+ integer, intent(in) :: je !< Ending y index
+ integer, intent(in) :: nhalo !< Number of halos
+
+ integer :: ii, j, k, l
+
+ do ii = is, ie
+ do j = js, je
+ do k = 1, size(buffer, 3)
+ do l = 1, size(buffer,4)
+ buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = real(ii, kind=r8_kind)* 1000_r8_kind + &
+ real(j, kind=r8_kind)* 10_r8_kind + &
+ real(k, kind=r8_kind)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ end subroutine init_buffer
+
+ !> @brief Set the buffer based on the time_index
+ subroutine set_buffer(buffer, time_index)
+ real(kind=r8_kind), intent(inout) :: buffer(:,:,:,:) !< Output buffer
+ integer, intent(in) :: time_index !< Time index
+
+ buffer = nint(buffer) + real(time_index, kind=r8_kind)/100_r8_kind
+
+ end subroutine set_buffer
+
+end program test_reduction_methods
diff --git a/test_fms/diag_manager/test_time_max.sh b/test_fms/diag_manager/test_time_max.sh
new file mode 100755
index 0000000000..5a35179b2f
--- /dev/null
+++ b/test_fms/diag_manager/test_time_max.sh
@@ -0,0 +1,132 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true.
+cat <<_EOF > diag_table
+test_max
+2 1 1 0 0 0
+
+"test_max", 6, "hours", 1, "hours", "time"
+"test_max_regional", 6, "hours", 1, "hours", "time"
+
+"ocn_mod", "var0", "var0_max", "test_max", "all", "max", "none", 2
+"ocn_mod", "var1", "var1_max", "test_max", "all", "max", "none", 2
+"ocn_mod", "var2", "var2_max", "test_max", "all", "max", "none", 2
+"ocn_mod", "var3", "var3_max", "test_max", "all", "max", "none", 2
+
+"ocn_mod", "var3", "var3_Z", "test_max", "all", "max", "-1 -1 -1 -1 2. 3.", 2
+
+"ocn_mod", "var3", "var3_max", "test_max_regional", "all", "max", "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL
+_EOF
+
+my_test_count=1
+printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "max" reduction method (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "max" reduction method (test $my_test_count)" '
+ mpirun -n 1 ../check_time_max
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "max" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "max" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_max
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "max" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "max" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_max
+'
+
+export OMP_NUM_THREADS=2
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "max" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "max" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 1 ../check_time_max
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "max" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "max" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_max
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "max" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "max" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_max
+'
+export OMP_NUM_THREADS=1
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "max" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "max" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 1 ../check_time_max
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "max" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "max" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_max
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "max" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "max" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_max
+'
+fi
+test_done
\ No newline at end of file
diff --git a/test_fms/diag_manager/test_time_min.sh b/test_fms/diag_manager/test_time_min.sh
new file mode 100755
index 0000000000..7049dc6abb
--- /dev/null
+++ b/test_fms/diag_manager/test_time_min.sh
@@ -0,0 +1,132 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true.
+cat <<_EOF > diag_table
+test_min
+2 1 1 0 0 0
+
+"test_min", 6, "hours", 1, "hours", "time"
+"test_min_regional", 6, "hours", 1, "hours", "time"
+
+"ocn_mod", "var0", "var0_min", "test_min", "all", "min", "none", 2
+"ocn_mod", "var1", "var1_min", "test_min", "all", "min", "none", 2
+"ocn_mod", "var2", "var2_min", "test_min", "all", "min", "none", 2
+"ocn_mod", "var3", "var3_min", "test_min", "all", "min", "none", 2
+
+"ocn_mod", "var3", "var3_Z", "test_min", "all", "min", "-1 -1 -1 -1 2. 3.", 2
+
+"ocn_mod", "var3", "var3_min", "test_min_regional", "all", "min", "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL
+_EOF
+
+my_test_count=1
+printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "min" reduction method (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "min" reduction method (test $my_test_count)" '
+ mpirun -n 1 ../check_time_min
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "min" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "min" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_min
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "min" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "min" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_min
+'
+
+export OMP_NUM_THREADS=2
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "min" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "min" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 1 ../check_time_min
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "min" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "min" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_min
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "min" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "min" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_min
+'
+export OMP_NUM_THREADS=1
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "min" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "min" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 1 ../check_time_min
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "min" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "min" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_min
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "min" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "min" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_min
+'
+fi
+test_done
\ No newline at end of file
diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh
new file mode 100755
index 0000000000..0de41c9f1b
--- /dev/null
+++ b/test_fms/diag_manager/test_time_none.sh
@@ -0,0 +1,132 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true.
+cat <<_EOF > diag_table
+test_none
+2 1 1 0 0 0
+
+"test_none", 6, "hours", 1, "hours", "time"
+"test_none_regional", 6, "hours", 1, "hours", "time"
+
+"ocn_mod", "var0", "var0_none", "test_none", "all", .false., "none", 2
+"ocn_mod", "var1", "var1_none", "test_none", "all", .false., "none", 2
+"ocn_mod", "var2", "var2_none", "test_none", "all", .false., "none", 2
+"ocn_mod", "var3", "var3_none", "test_none", "all", .false., "none", 2
+
+"ocn_mod", "var3", "var3_Z", "test_none", "all", .false., "-1 -1 -1 -1 2. 3.", 2
+
+"ocn_mod", "var3", "var3_none", "test_none_regional", "all", .false., "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL
+_EOF
+
+my_test_count=1
+printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method (test $my_test_count)" '
+ mpirun -n 1 ../check_time_none
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_none
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_none
+'
+
+export OMP_NUM_THREADS=2
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 1 ../check_time_none
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_none
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_none
+'
+export OMP_NUM_THREADS=1
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 1 ../check_time_none
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_none
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_none
+'
+fi
+test_done
\ No newline at end of file
diff --git a/test_fms/diag_manager/testing_utils.F90 b/test_fms/diag_manager/testing_utils.F90
new file mode 100644
index 0000000000..45530fcc3e
--- /dev/null
+++ b/test_fms/diag_manager/testing_utils.F90
@@ -0,0 +1,53 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Utilities used in multiple test
+module testing_utils
+ use platform_mod, only: r8_kind
+ private
+
+ public :: allocate_buffer
+ public :: test_normal, test_openmp, test_halos
+ public :: no_mask, logical_mask, real_mask
+
+ integer, parameter :: test_normal = 0 !< sending a buffer in the compute domain
+ integer, parameter :: test_openmp = 1 !< sending a buffer in the compute domain but with blocking
+ integer, parameter :: test_halos = 2 !< sending a buffer in the data domain (i.e with halos)
+ integer, parameter :: no_mask = 0 !< Not using a mask
+ integer, parameter :: logical_mask = 1 !< Using a logical mask
+ integer, parameter :: real_mask = 2 !< Using a real mask
+
+ contains
+
+ !> @brief Allocate the output buffer based on the starting/ending indices
+ !! @return output buffer set to -999_r8_kind
+ function allocate_buffer(is, ie, js, je, k, l) &
+ result(buffer)
+ integer, intent(in) :: is !< Starting x index
+ integer, intent(in) :: ie !< Ending x index
+ integer, intent(in) :: js !< Starting y index
+ integer, intent(in) :: je !< Ending y index
+ integer, intent(in) :: k !< Number of points in the 4th dimension
+ integer, intent(in) :: l !< Number of points in the 5th dimension
+ real(kind=r8_kind), allocatable :: buffer(:,:,:,:)
+
+ allocate(buffer(is:ie, js:je, 1:k, 1:l))
+ buffer = -999_r8_kind
+ end function allocate_buffer
+end module
From 5c2b0c90866a28b75251a3a9bed89f7dfd99cb8d Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 24 Aug 2023 14:26:30 -0400
Subject: [PATCH 123/168] feat: modern diag implement time_none reduction
(#1347)
---
diag_manager/Makefile.am | 21 +-
diag_manager/diag_manager.F90 | 67 +++++-
diag_manager/fms_diag_axis_object.F90 | 139 +++++++----
diag_manager/fms_diag_bbox.F90 | 207 +++++++++++++++-
diag_manager/fms_diag_object.F90 | 227 +++++++++++++++---
diag_manager/fms_diag_output_buffer.F90 | 35 +++
diag_manager/fms_diag_reduction_methods.F90 | 20 +-
.../include/fms_diag_reduction_methods.inc | 53 ++++
.../include/fms_diag_reduction_methods_r4.fh | 35 +++
.../include/fms_diag_reduction_methods_r8.fh | 35 +++
test_fms/diag_manager/check_time_max.F90 | 2 +
test_fms/diag_manager/check_time_min.F90 | 2 +
test_fms/diag_manager/check_time_none.F90 | 12 +-
test_fms/diag_manager/test_time_none.sh | 91 ++++---
14 files changed, 799 insertions(+), 147 deletions(-)
create mode 100644 diag_manager/include/fms_diag_reduction_methods.inc
create mode 100644 diag_manager/include/fms_diag_reduction_methods_r4.fh
create mode 100644 diag_manager/include/fms_diag_reduction_methods_r8.fh
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index b682c39410..8ad1e5a191 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -61,7 +61,10 @@ libdiag_manager_la_SOURCES = \
fms_diag_bbox.F90 \
fms_diag_reduction_methods.F90 \
include/fms_diag_fieldbuff_update.inc \
- include/fms_diag_fieldbuff_update.fh
+ include/fms_diag_fieldbuff_update.fh \
+ include/fms_diag_reduction_methods.inc \
+ include/fms_diag_reduction_methods_r4.fh \
+ include/fms_diag_reduction_methods_r8.fh
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
@@ -75,7 +78,8 @@ fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_output_buffer_mod.$(FC_MODEXT) \
- fms_diag_reduction_methods_mod.$(FC_MODEXT)
+ fms_diag_reduction_methods_mod.$(FC_MODEXT) \
+ fms_diag_bbox_mod.$(FC_MODEXT)
fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_axis_object_mod.$(FC_MODEXT)
fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
@@ -83,6 +87,12 @@ fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
diag_grid_mod.$(FC_MODEXT)
+fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT)
+fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
+fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT)
+fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
+ fms_diag_outfield_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \
+ fms_diag_bbox_mod.$(FC_MODEXT)
diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \
diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) \
@@ -90,7 +100,8 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD
fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT) \
fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \
fms_diag_fieldbuff_update_mod.$(FC_MODEXT)
-fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT)
+fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
+ fms_diag_reduction_methods_mod.$(FC_MODEXT)
fms_diag_reduction_methods_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT) \
diag_data_mod.$(FC_MODEXT)
@@ -127,7 +138,9 @@ MODFILES = \
fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \
fms_diag_reduction_methods_mod.$(FC_MODEXT) \
include/fms_diag_fieldbuff_update.inc \
- include/fms_diag_fieldbuff_update.fh
+ include/fms_diag_fieldbuff_update.fh \
+ include/fms_diag_reduction_methods_r4.fh \
+ include/fms_diag_reduction_methods_r8.fh
nodist_include_HEADERS = $(MODFILES)
BUILT_SOURCES = $(MODFILES)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index ef2c0392a1..c1bf80dd1a 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -1665,9 +1665,9 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
CHARACTER(len=128) :: error_string, error_string1
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field
- class(*), pointer, dimension(:,:,:,:) :: field_remap !< 4d remapped pointer
- logical, pointer, dimension(:,:,:,:) :: mask_remap !< 4d remapped pointer
- class(*), pointer, dimension(:,:,:,:) :: rmask_remap !< 4d remapped pointer
+ class(*), allocatable, dimension(:,:,:,:) :: field_remap !< 4d remapped array
+ logical, allocatable, dimension(:,:,:,:) :: mask_remap !< 4d remapped array
+ class(*), allocatable, dimension(:,:,:,:) :: rmask_remap !< 4d remapped array
REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask
REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! null() !< i8 4d remapped pointer
+=======
+ character(len=:), allocatable :: field_name !< Name of the field
+
+>>>>>>> 07ff0679 (Implement time_none (#1347))
! If diag_field_id is < 0 it means that this field is not registered, simply return
IF ( diag_field_id <= 0 ) THEN
diag_send_data = .FALSE.
@@ -1708,15 +1713,8 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN
END IF
if (use_modern_diag) then !> Set up array lengths for remapping
- field_remap => null()
- mask_remap => null()
- rmask_remap => null()
- ie = SIZE(field,1)
- je = SIZE(field,2)
- ke = SIZE(field,3)
- field_remap(1:ie,1:je,1:ke,1:1) => field
- if (present(mask)) mask_remap(1:ie,1:je,1:ke,1:1) => mask
- if (present(rmask)) rmask_remap(1:ie,1:je,1:ke,1:1) => rmask
+
+
endif
SELECT TYPE (field)
TYPE IS (real(kind=r4_kind))
@@ -1730,10 +1728,19 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
END SELECT
! Split old and modern2023 here
modern_if: iF (use_modern_diag) then
+ field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id)
+ field_remap = copy_3d_to_4d(field, trim(field_name)//"'s data")
+ if (present(rmask)) rmask_remap = copy_3d_to_4d(rmask, trim(field_name)//"'s mask")
+ if (present(mask)) then
+ allocate(mask_remap(1:size(mask,1), 1:size(mask,2), 1:size(mask,3), 1))
+ mask_remap(:,:,:,1) = mask
+ endif
diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, &
time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
err_msg)
- nullify (field_remap)
+ deallocate (field_remap)
+ if (allocated(mask_remap)) deallocate(mask_remap)
+ if (allocated(rmask_remap)) deallocate(rmask_remap)
elSE ! modern_if
! oor_mask is only used for checking out of range values.
ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status)
@@ -4474,6 +4481,40 @@ SUBROUTINE diag_field_add_cell_measures(diag_field_id, area, volume)
END IF
END SUBROUTINE diag_field_add_cell_measures
+ !> @brief Copies a 3d buffer to a 4d buffer
+ !> @return a 4d buffer
+ function copy_3d_to_4d(data_in, field_name) &
+ result(data_out)
+ class (*), intent(in) :: data_in(:,:,:) !< Data to copy
+ character(len=*), intent(in) :: field_name !< Name of the field copying (for error messages)
+ class (*), allocatable :: data_out(:,:,:,:)
+
+ !TODO this should be extended to integers
+ select type(data_in)
+ type is (real(kind=r8_kind))
+ allocate(real(kind=r8_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1))
+ select type (data_out)
+ type is (real(kind=r8_kind))
+ data_out(:,:,:,1) = data_in
+ class default
+ call mpp_error(FATAL, "The copy of "//trim(field_name)//&
+ " was not allocated to the correct type (r8_kind). This shouldn't have happened")
+ end select
+ type is (real(kind=r4_kind))
+ allocate(real(kind=r4_kind) :: data_out(1:size(data_in,1), 1:size(data_in,2), 1:size(data_in,3), 1))
+ select type (data_out)
+ type is (real(kind=r4_kind))
+ data_out(:,:,:,1) = data_in
+ class default
+ call mpp_error(FATAL, "The copy of "//trim(field_name)//&
+ " was not allocated to the correct type (r4_kind). This shouldn't have happened")
+ end select
+ class default
+ call mpp_error(FATAL, "The data for "//trim(field_name)//&
+ &" is not a valid type. Currently only r4 and r8 are supported")
+ end select
+ end function copy_3d_to_4d
+
END MODULE diag_manager_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 14a54387bc..8f22f7d2db 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -115,12 +115,14 @@ module fms_diag_axis_object_mod
INTEGER , private :: ending_index !< Ending index of the subaxis relative to the
!! parent axis
INTEGER , private :: parent_axis_id !< Id of the parent_axis
+ INTEGER , private :: compute_idx(2) !< Starting and ending index of the compute domain
real(kind=r4_kind), allocatable, private :: zbounds(:) !< Bounds of the Z axis
contains
procedure :: fill_subaxis
procedure :: axis_length
procedure :: get_starting_index
procedure :: get_ending_index
+ procedure :: get_compute_indices
END TYPE fmsDiagSubAxis_type
!> @brief Type to hold the diurnal axis
@@ -665,7 +667,7 @@ subroutine get_indices(this, compute_idx, corners_indices, starting_index, endin
ending_index = diag_null
!< If the compute domain of the current PE is outisde of the range of sub_axis, return
- if (compute_idx(1) > subregion_start .and. compute_idx(2) > subregion_start) return
+ if (compute_idx(1) < subregion_start .and. compute_idx(2) < subregion_start) return
if (compute_idx(1) > subregion_end .and. compute_idx(2) > subregion_end) return
need_to_define_axis = .true.
@@ -738,13 +740,16 @@ end subroutine get_compute_domain
!!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Fills in the information needed to define a subaxis
- subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, zbounds)
+ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, compute_idx, &
+ zbounds)
class(fmsDiagSubAxis_type) , INTENT(INOUT) :: this !< diag_sub_axis obj
integer , intent(in) :: starting_index !< Starting index of the subRegion for the PE
integer , intent(in) :: ending_index !< Ending index of the subRegion for the PE
integer , intent(in) :: axis_id !< Axis id to assign to the subaxis
- integer , intent(in) :: parent_id !< The id of the parent axis, the subaxis belongs to
+ integer , intent(in) :: parent_id !< The id of the parent axis the subaxis belongs to
character(len=*) , intent(in) :: parent_axis_name !< Name of the parent_axis
+ integer , intent(in) :: compute_idx(2) !< Starting and ending index of
+ !! the axis's compute domain
real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the z-axis
this%axis_id = axis_id
@@ -752,6 +757,7 @@ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id,
this%ending_index = ending_index
this%parent_axis_id = parent_id
this%subaxis_name = trim(parent_axis_name)//"_sub01"
+ this%compute_idx = compute_idx
if (present(zbounds)) then
allocate(this%zbounds(2))
@@ -785,6 +791,14 @@ function get_ending_index(this) result(indx)
indx = this%ending_index
end function get_ending_index
+ !> @brief Accesses its member compute_indices
+ !! @return a copy of the ending_index
+ function get_compute_indices(this) result(indx)
+ class(fmsDiagSubAxis_type), intent(in) :: this !< diag_sub_axis object
+ integer :: indx(2) !< Result to return
+ indx = this%compute_idx
+ end function get_compute_indices
+
!> @brief Get the ntiles in a domain
!> @return the number of tiles in a domain
function get_ntiles(this) &
@@ -1022,8 +1036,9 @@ subroutine define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_
!< If the PE's compute is not inside the subRegion, define a null subaxis and go to the next axis
if (.not. need_to_define_axis) then
+ compute_idx = diag_null
call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- diag_null, diag_null)
+ diag_null, diag_null, compute_idx)
cycle
endif
@@ -1031,7 +1046,7 @@ subroutine define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_
write_on_this_pe = .true.
call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- starting_index, ending_index)
+ starting_index, ending_index, compute_idx)
end select
enddo
@@ -1047,15 +1062,19 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_
logical, intent(out) :: write_on_this_pe !< .true. if the subregion
!! is on this PE
- real :: lat(2) !< Starting and ending lattiude of the subRegion
- real :: lon(2) !< Starting and ending longitude or the subRegion
- integer :: lat_indices(2) !< Starting and ending latitude indices of the subRegion
- integer :: lon_indices(2) !< Starting and ending longitude indices of the subRegion
- integer :: compute_idx(2) !< Compute domain of the current axis
- integer :: starting_index !< Starting index of the subRegion for the current PE
- integer :: ending_index !< Ending index of the subRegion for the current PE
- logical :: need_to_define_axis !< .true. if it is needed to define the subaxis
- integer :: i !< For do loops
+ real :: lat(2) !< Starting and ending lattiude of the subRegion
+ real :: lon(2) !< Starting and ending longitude or the subRegion
+ integer :: lat_indices(2) !< Starting and ending latitude indices of the subRegion
+ integer :: lon_indices(2) !< Starting and ending longitude indices of the subRegion
+ integer :: compute_idx(2) !< Compute domain of the current axis
+ integer :: starting_index(2) !< Starting index of the subRegion for the current PE for the "x" and "y"
+ !! direction
+ integer :: ending_index(2) !< Ending index of the subRegion for the current PE for the "x" and "y" direction
+ logical :: need_to_define_axis(2) !< .true. if it is needed to define the subaxis for the "x" and "y" direction
+ integer :: i !< For do loops
+ integer :: parent_axis_ids(2) !< The axis id of the parent axis for the "x" and "y" direction
+ logical :: is_x_y_axis !< .true. if the axis is x or y
+ integer :: compute_idx_2(2, 2) !< Starting and ending indices of the compute domain for the "x" and "y" direction
!< Get the rectangular coordinates of the subRegion
!! If the subRegion is not rectangular, the points outside of the subRegion will be masked
@@ -1076,29 +1095,24 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_
select_axis_type: select type (parent_axis => diag_axis(axis_ids(i))%axis)
type is (fmsDiagFullAxis_type)
!< Get the PEs compute domain
- call parent_axis%get_compute_domain(compute_idx, need_to_define_axis)
+ call parent_axis%get_compute_domain(compute_idx, is_x_y_axis)
!< If this is not a "X" or "Y" axis go to the next axis
- if (.not. need_to_define_axis) cycle
+ if (.not. is_x_y_axis) cycle
!< Determine if the PE's compute domain is inside the subRegion
!! If it is get the starting and ending indices for that PE
if (parent_axis%cart_name .eq. "X") then
- call parent_axis%get_indices(compute_idx, lon_indices, starting_index, ending_index, &
- need_to_define_axis)
+ call parent_axis%get_indices(compute_idx, lon_indices, starting_index(1), ending_index(1), &
+ need_to_define_axis(1))
+ parent_axis_ids(1) = axis_ids(i)
+ compute_idx_2(1,:) = compute_idx
else if (parent_axis%cart_name .eq. "Y") then
- call parent_axis%get_indices(compute_idx, lat_indices, starting_index, ending_index, &
- need_to_define_axis)
+ call parent_axis%get_indices(compute_idx, lat_indices, starting_index(2), ending_index(2), &
+ need_to_define_axis(2))
+ parent_axis_ids(2) = axis_ids(i)
+ compute_idx_2(2,:) = compute_idx
endif
-
- !< If the PE's compute is not inside the subRegion move to the next axis
- if (.not. need_to_define_axis) cycle
-
- !< If it made it to this point, the current PE is in the subRegion!
- write_on_this_pe = .true.
-
- call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- starting_index, ending_index)
end select select_axis_type
enddo loop_over_axis_ids
else if_is_cube_sphere
@@ -1106,46 +1120,62 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_
select type (parent_axis => diag_axis(axis_ids(i))%axis)
type is (fmsDiagFullAxis_type)
!< Get the PEs compute domain
- call parent_axis%get_compute_domain(compute_idx, need_to_define_axis)
+ call parent_axis%get_compute_domain(compute_idx, is_x_y_axis)
!< If this is not a "X" or "Y" axis go to the next axis
- if (.not. need_to_define_axis) cycle
+ if (.not. is_x_y_axis) cycle
!< Get the starting and ending indices of the subregion relative to the global grid
if (parent_axis%cart_name .eq. "X") then
select type(adata=>parent_axis%axis_data)
- type is (real)
- lon_indices(1) = nearest_index(lon(1), adata)
- lon_indices(2) = nearest_index(lon(2), adata) + 1
+ type is (real(kind=r8_kind))
+ lon_indices(1) = nearest_index(real(lon(1), kind=r8_kind), adata)
+ lon_indices(2) = nearest_index(real(lon(2), kind=r8_kind), adata) + 1
+ type is (real(kind=r4_kind))
+ lon_indices(1) = nearest_index(real(lon(1), kind=r4_kind), adata)
+ lon_indices(2) = nearest_index(real(lon(2), kind=r4_kind), adata) + 1
end select
- call parent_axis%get_indices(compute_idx, lon_indices, starting_index, ending_index, &
- need_to_define_axis)
+ call parent_axis%get_indices(compute_idx, lon_indices, starting_index(1), ending_index(1), &
+ need_to_define_axis(1))
+ parent_axis_ids(1) = axis_ids(i)
+ compute_idx_2(1,:) = compute_idx
else if (parent_axis%cart_name .eq. "Y") then
select type(adata=>parent_axis%axis_data)
- type is (real)
- lat_indices(1) = nearest_index(lat(1), adata)
- lat_indices(2) = nearest_index(lat(2), adata) + 1
+ type is (real(kind=r8_kind))
+ lat_indices(1) = nearest_index(real(lat(1), kind=r8_kind), adata)
+ lat_indices(2) = nearest_index(real(lat(2), kind=r8_kind), adata) + 1
+ type is (real(kind=r4_kind))
+ lat_indices(1) = nearest_index(real(lat(1), kind=r4_kind), adata)
+ lat_indices(2) = nearest_index(real(lat(2), kind=r4_kind), adata) + 1
end select
- call parent_axis%get_indices(compute_idx, lat_indices, starting_index, ending_index, &
- need_to_define_axis)
+ call parent_axis%get_indices(compute_idx, lat_indices, starting_index(2), ending_index(2), &
+ need_to_define_axis(2))
+ parent_axis_ids(2) = axis_ids(i)
+ compute_idx_2(2,:) = compute_idx
endif
-
- !< If the PE's compute is not inside the subRegion move to the next axis
- if (.not. need_to_define_axis) cycle
-
- !< If it made it to this point, the current PE is in the subRegion!
- write_on_this_pe = .true.
-
- call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- starting_index, ending_index)
end select
enddo loop_over_axis_ids2
endif if_is_cube_sphere
+
+ !< If the PE's compute is not inside the subRegion move to the next axis
+ if (any(.not. need_to_define_axis )) return
+
+ !< If it made it to this point, the current PE is in the subRegion!
+ write_on_this_pe = .true.
+
+ do i = 1, size(parent_axis_ids)
+ select type (parent_axis => diag_axis(parent_axis_ids(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ call define_new_axis(diag_axis, parent_axis, naxis, parent_axis_ids(i), &
+ starting_index(i), ending_index(i), compute_idx_2(i,:))
+ end select
+ enddo
+
end subroutine define_subaxis_latlon
!> @brief Creates a new subaxis and fills it will all the information it needs
subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
- starting_index, ending_index, new_axis_id, zbounds)
+ starting_index, ending_index, compute_idx, new_axis_id, zbounds)
class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
class(fmsDiagFullAxis_type), intent(inout) :: parent_axis !< The parent axis
@@ -1154,6 +1184,8 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
integer, intent(in) :: parent_id !< Id of the parent axis
integer, intent(in) :: starting_index !< PE's Starting index
integer, intent(in) :: ending_index !< PE's Ending index
+ integer, intent(in) :: compute_idx(2) !< Starting and ending index of
+ !! the axis's compute domain
integer, optional, intent(out) :: new_axis_id !< Axis id of the axis this is creating
real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the Z axis
@@ -1171,7 +1203,7 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
select type (sub_axis => diag_axis(naxis)%axis)
type is (fmsDiagSubAxis_type)
call sub_axis%fill_subaxis(starting_index, ending_index, naxis, parent_id, &
- parent_axis%axis_name, zbounds)
+ parent_axis%axis_name, compute_idx, zbounds)
end select
end subroutine define_new_axis
@@ -1333,7 +1365,8 @@ subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_ax
end select
call define_new_axis(diag_axis, parent_axis, naxis, parent_axis%axis_id, &
- &subaxis_indices(1), subaxis_indices(2), subaxis_id, zbounds)
+ &subaxis_indices(1), subaxis_indices(2), (/lbound(zaxis_data,1), ubound(zaxis_data,1)/), &
+ &subaxis_id, zbounds)
var_axis_ids(i) = subaxis_id
return
endif
diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90
index 956dabd31c..fb05d2b998 100644
--- a/diag_manager/fms_diag_bbox.F90
+++ b/diag_manager/fms_diag_bbox.F90
@@ -30,7 +30,7 @@
!> @{
MODULE fms_diag_bbox_mod
- USE fms_mod, ONLY: error_mesg, FATAL, fms_error_handler
+ USE fms_mod, ONLY: error_mesg, FATAL, fms_error_handler, string
implicit none
@@ -39,24 +39,30 @@ MODULE fms_diag_bbox_mod
!! array index bounds of the spatial component a diag_manager field output
!! buffer array.
TYPE, public :: fmsDiagIbounds_type
- PRIVATE
INTEGER :: imin !< Lower i bound.
INTEGER :: imax !< Upper i bound.
INTEGER :: jmin !< Lower j bound.
INTEGER :: jmax !< Upper j bound.
INTEGER :: kmin !< Lower k bound.
INTEGER :: kmax !< Upper k bound.
+ logical :: has_halos !< .True. if the buffer has halos
+ integer :: nhalo_I !< Number of halos in i
+ integer :: nhalo_J !< Number of halos in j
contains
procedure :: reset => reset_bounds
procedure :: reset_bounds_from_array_4D
procedure :: reset_bounds_from_array_5D
procedure :: update_bounds
+ procedure :: set_bounds
+ procedure :: rebase_input
+ procedure :: rebase_output
procedure :: get_imin
procedure :: get_imax
procedure :: get_jmin
procedure :: get_jmax
procedure :: get_kmin
procedure :: get_kmax
+ procedure :: update_index
END TYPE fmsDiagIbounds_type
!> @brief Data structure holding starting and ending indices in the I, J, and
@@ -81,10 +87,52 @@ MODULE fms_diag_bbox_mod
procedure :: get_fje
end type fmsDiagBoundsHalos_type
- public :: recondition_indices
+ public :: recondition_indices, determine_if_block_is_in_region
+
+ integer, parameter :: xdimension = 1 !< Parameter defining the x dimension
+ integer, parameter :: ydimension = 2 !< Parameter defining the y dimension
+ integer, parameter :: zdimension = 3 !< Parameter defininf the z dimension
CONTAINS
+!> @brief The PEs grid points are divided further into "blocks". This function determines if a block
+! has data for a given subregion and dimension
+!! @return .true. if the a subergion is inside a block
+logical pure function determine_if_block_is_in_region(subregion_start, subregion_end, bounds, dim)
+ integer, intent(in) :: subregion_start !< Begining of the subregion
+ integer, intent(in) :: subregion_end !< Ending of the subregion
+ type(fmsDiagIbounds_type), intent(in) :: bounds !< Starting and ending of the subregion
+ integer, intent(in) :: dim !< Dimension to check
+
+ integer :: block_start !< Begining index of the block
+ integer :: block_end !< Ending index of the block
+
+ determine_if_block_is_in_region = .true.
+ select case (dim)
+ case (xdimension)
+ block_start = bounds%imin
+ block_end = bounds%imax
+ case (ydimension)
+ block_start = bounds%jmin
+ block_end = bounds%jmax
+ case (zdimension)
+ block_start = bounds%kmin
+ block_end = bounds%kmax
+ end select
+
+ if (block_start < subregion_start .and. block_end < subregion_start) then
+ determine_if_block_is_in_region = .false.
+ return
+ endif
+
+ if (block_start > subregion_end .and. block_end > subregion_end) then
+ determine_if_block_is_in_region = .false.
+ return
+ endif
+
+ determine_if_block_is_in_region = .true.
+end function determine_if_block_is_in_region
+
!> @brief Gets imin of fmsDiagIbounds_type
!! @return copy of integer member imin
pure integer function get_imin (this) result(rslt)
@@ -128,6 +176,41 @@ pure integer function get_kmax (this) result(rslt)
rslt = this%kmax
end function get_kmax
+ !> @brief Updates the starting and ending index of a given dimension
+ subroutine update_index(this, starting_index, ending_index, dim, ignore_halos)
+ class (fmsDiagIbounds_type), intent(inout) :: this !< The bounding box to update
+ integer, intent(in) :: starting_index !< Starting index to update to
+ integer, intent(in) :: ending_index !< Ending index to update to
+ integer, intent(in) :: dim !< Dimension to update
+ logical, intent(in) :: ignore_halos !< If .true. halos will be ignored
+ !! i.e output buffers can ignore halos as
+ !! they do not get updates. The indices of the
+ !! Input buffers need to add the number of halos
+ !! so math is done only on the compute domain
+
+ integer :: nhalox !< Number of halos in x
+ integer :: nhaloy !< Number of halos in y
+
+ if (ignore_halos) then
+ nhalox = 0
+ nhaloy = 0
+ else
+ nhalox= this%nhalo_I
+ nhaloy= this%nhalo_J
+ endif
+ select case(dim)
+ case (xdimension)
+ this%imin = starting_index + nhalox
+ this%imax = ending_index + nhalox
+ case (ydimension)
+ this%jmin = starting_index + nhaloy
+ this%jmax = ending_index + nhaloy
+ case (zdimension)
+ this%kmin = starting_index
+ this%kmax = ending_index
+ end select
+ end subroutine
+
!> @brief Gets the halo size of fmsDiagBoundsHalos_type in the I dimension
!! @return copy of integer member hi
pure integer function get_hi (this) result(rslt)
@@ -202,11 +285,68 @@ SUBROUTINE update_bounds(this, lower_i, upper_i, lower_j, upper_j, lower_k, uppe
this%kmax = MAX(this%kmax, upper_k)
END SUBROUTINE update_bounds
+ !> @brief Sets the bounds of a bounding region
+ !! @return empty string if sucessful or error message if unsucessful
+ function set_bounds(this, field_data, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k, has_halos) &
+ result(error_msg)
+ CLASS (fmsDiagIbounds_type), intent(inout) :: this !< The bounding box of the field
+ class(*), intent(in) :: field_data(:,:,:,:) !< Field data
+ INTEGER, INTENT(in) :: lower_i !< Lower i bound.
+ INTEGER, INTENT(in) :: upper_i !< Upper i bound.
+ INTEGER, INTENT(in) :: lower_j !< Lower j bound.
+ INTEGER, INTENT(in) :: upper_j !< Upper j bound.
+ INTEGER, INTENT(in) :: lower_k !< Lower k bound.
+ INTEGER, INTENT(in) :: upper_k !< Upper k bound.
+ LOGICAL, INTENT(in) :: has_halos !< .true. if the field has halos
+
+ character(len=150) :: error_msg !< Error message to output
+
+ integer :: nhalos_2 !< 2 times the number of halo points
+ integer :: nhalox !< Number of halos in x
+ integer :: nhaloy !< Number of halos in y
+
+ error_msg = ""
+ this%kmin = lower_k
+ this%kmax = upper_k
+ this%has_halos = has_halos
+ this%nhalo_I = 0
+ this%nhalo_J = 0
+ if (has_halos) then
+ !upper_i-lower_i+1 is the size of the compute domain
+ !ubound(field_data,1) is the size of the data domain
+ nhalos_2 = ubound(field_data,1)-(upper_i-lower_i+1)
+ if (mod(nhalos_2, 2) .ne. 0) then
+ error_msg = "There are non-symmetric halos in the first dimension"
+ return
+ endif
+ nhalox = nhalos_2/2
+ this%nhalo_I = nhalox
+
+ nhalos_2 = ubound(field_data,2)-(upper_j-lower_j + 1)
+ if (mod(nhalos_2, 2) .ne. 0) then
+ error_msg = "There are non-symmetric halos in the second dimension"
+ return
+ endif
+ nhaloy = nhalos_2/2
+ this%nhalo_J = nhaloy
+
+ this%imin = 1 + nhalox
+ this%imax = ubound(field_data,1) - nhalox
+ this%jmin = 1 + nhaloy
+ this%jmax = ubound(field_data,2) - nhaloy
+ else
+ this%imin = lower_i
+ this%imax = upper_i
+ this%jmin = lower_j
+ this%jmax = upper_j
+ endif
+
+ end function set_bounds
!> @brief Reset the instance bounding box with the bounds determined from the
!! first three dimensions of the 5D "array" argument
SUBROUTINE reset_bounds_from_array_4D(this, array)
CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box.
- REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array.
+ class(*), INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array.
this%imin = LBOUND(array,1)
this%imax = UBOUND(array,1)
this%jmin = LBOUND(array,2)
@@ -319,6 +459,65 @@ function recondition_indices(indices, field, is_in, js_in, ks_in, &
indices%fje = fje
end function recondition_indices
+ !> @brief Rebase the ouput bounds for a given dimension based on the starting and ending indices of
+ !! a subregion. This is for when blocking is used.
+ subroutine rebase_output(bounds_out, starting, ending, dim)
+ CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_out !< Bounds to rebase
+ integer, intent(in) :: starting !< Starting index of the dimension
+ integer, intent(in) :: ending !< Ending index of the dimension
+ integer, intent(in) :: dim !< Dimension to update
+
+ !> The starting index is going to be either "starting" if only a section of the
+ !! block is in the subregion or bounds_out%[]min if the whole section of the block is in the
+ !! subregion. The -starting+1 s needed so that indices start as 1 since the output buffer has
+ !! indices 1:size of a subregion
+
+ !> The ending index is going to be either bounds_out%[]max if the whole section of the block
+ !! is in the subregion or bounds_out%[]min + size of the subregion if only a section of the
+ !! block is in the susbregion
+ select case (dim)
+ case (xdimension)
+ bounds_out%imin = max(starting, bounds_out%imin)-starting+1
+ bounds_out%imax = min(bounds_out%imax, bounds_out%imin + ending-starting)
+ case (ydimension)
+ bounds_out%jmin = max(starting, bounds_out%jmin)-starting+1
+ bounds_out%jmax = min(bounds_out%jmax, bounds_out%jmin + ending-starting)
+ case (zdimension)
+ bounds_out%kmin =max(starting, bounds_out%kmin)-starting+1
+ bounds_out%kmax = min(bounds_out%kmax, bounds_out%kmin + ending-starting)
+ end select
+ end subroutine
+
+ !> @brief Rebase the input bounds for a given dimension based on the starting and ending indices
+ !! of a subregion. This is for when blocking is used
+ subroutine rebase_input(bounds_in, bounds, starting, ending, dim)
+ CLASS (fmsDiagIbounds_type), INTENT(inout) :: bounds_in !< Bounds to rebase
+ CLASS (fmsDiagIbounds_type), INTENT(in) :: bounds !< Original indices (i.e is_in, ie_in,
+ !! passed into diag_manager)
+ integer, intent(in) :: starting !< Starting index of the dimension
+ integer, intent(in) :: ending !< Ending index of the dimension
+ integer, intent(in) :: dim !< Dimension to update
+
+ !> The starting index is going to be either "starting" if only a section of the
+ !! block is in the subregion or starting-bounds%imin+1 if the whole section of the block is in the
+ !! subregion.
+
+ !> The ending index is going to be either bounds_out%[]max if the whole section of the block
+ !! is in the subregion or bounds%[]min + size of the subregion if only a section of the
+ !! block is in the susbregion
+ select case (dim)
+ case (xdimension)
+ bounds_in%imin = min(abs(starting-bounds%imin+1), starting)
+ bounds_in%imax = min(bounds_in%imax, (bounds_in%imin + ending-starting))
+ case (ydimension)
+ bounds_in%jmin = min(abs(starting-bounds%jmin+1), starting)
+ bounds_in%jmax = min(bounds_in%jmax, (bounds_in%jmin + ending-starting))
+ case (zdimension)
+ bounds_in%kmin = min(abs(starting-bounds%kmin+1), starting)
+ bounds_in%kmax = min(bounds_in%kmax, (bounds_in%kmin + ending-starting))
+ end select
+ end subroutine
+
END MODULE fms_diag_bbox_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 789b6e55e6..907f0c6613 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -20,7 +20,9 @@ module fms_diag_object_mod
use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
&DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, &
- &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered
+ &get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered, &
+ &time_none, time_max, time_min, time_sum, time_average, time_diurnal, &
+ &time_power, time_rms
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
& OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
@@ -39,6 +41,7 @@ module fms_diag_object_mod
use fms_diag_reduction_methods_mod, only: check_indices_order, init_mask, set_weight
use constants_mod, only: SECONDS_PER_DAY
#endif
+USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type, determine_if_block_is_in_region
#if defined(_OPENMP)
use omp_lib
#endif
@@ -80,6 +83,7 @@ module fms_diag_object_mod
procedure :: fms_get_domain2d
procedure :: fms_get_axis_length
procedure :: fms_get_diag_field_id_from_name
+ procedure :: fms_get_field_name_from_id
procedure :: fms_get_axis_name_from_id
procedure :: fms_diag_accept_data
procedure :: fms_diag_send_complete
@@ -492,9 +496,9 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
class(fmsDiagObject_type),TARGET, INTENT(inout) :: this !< Diaj_obj to fill
INTEGER, INTENT(in) :: diag_field_id !< The ID of the diag field
CLASS(*), DIMENSION(:,:,:,:), INTENT(in) :: field_data !< The data for the diag_field
- LOGICAL, DIMENSION(:,:,:,:), pointer, INTENT(in) :: mask !< Logical mask indicating the grid
+ LOGICAL, allocatable, INTENT(in) :: mask(:,:,:,:) !< Logical mask indicating the grid
!! points to mask (null if no mask)
- CLASS(*), DIMENSION(:,:,:,:), pointer, INTENT(in) :: rmask !< real mask indicating the grid
+ CLASS(*), allocatable, INTENT(in) :: rmask(:,:,:,:)!< real mask indicating the grid
!! points to mask (null if no mask)
CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight used for averaging
TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current time
@@ -504,7 +508,6 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
integer :: is, js, ks !< Starting indicies of the field_data
integer :: ie, je, ke !< Ending indicies of the field_data
- integer :: n1, n2, n3 !< Size of the 3 indicies of the field data
integer :: omp_num_threads !< Number of openmp threads
integer :: omp_level !< The openmp active level
logical :: buffer_the_data !< True if the user selects to buffer the data and run
@@ -516,7 +519,9 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
logical, allocatable, dimension(:,:,:,:) :: oor_mask !< Out of range mask
real(kind=r8_kind) :: field_weight !< Weight to use when averaging (it will be converted
!! based on the type of field_data when doing the math)
-
+ type(fmsDiagIbounds_type) :: bounds !< Bounds (starting ending indices) for the field
+ logical :: has_halos !< .True. if field_data contains halos
+ logical :: using_blocking !< .True. if field_data is passed in blocks
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
@@ -533,15 +538,23 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
error_string = check_indices_order(is_in, ie_in, js_in, je_in)
if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
+ using_blocking = .false.
+ if ((present(is_in) .and. .not. present(ie_in)) .or. (present(js_in) .and. .not. present(je_in))) &
+ using_blocking = .true.
+
+ has_halos = .false.
+ if ((present(is_in) .and. present(ie_in)) .or. (present(js_in) .and. present(je_in))) &
+ has_halos = .true.
+
!< If the field has `mask_variant=.true.`, check that mask OR rmask are present
if (this%FMS_diag_fields(diag_field_id)%is_mask_variant()) then
- if (.not. associated(mask) .and. .not. associated(rmask)) call mpp_error(FATAL, &
+ if (.not. allocated(mask) .and. .not. allocated(rmask)) call mpp_error(FATAL, &
"The field was registered with mask_variant, but mask or rmask are not present in the send_data call. "//&
trim(field_info))
endif
!< Check that mask and rmask are not both present
- if (associated(mask) .and. associated(rmask)) call mpp_error(FATAL, &
+ if (allocated(mask) .and. allocated(rmask)) call mpp_error(FATAL, &
"mask and rmask are both present in the send_data call. "//&
trim(field_info))
@@ -560,26 +573,23 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
buffer_the_data = (omp_num_threads > 1 .AND. omp_level > 0)
#endif
+ !> Calculate the i,j,k start and end
+ ! If is, js, or ks not present default them to 1
+ is = 1
+ js = 1
+ ks = 1
+ IF ( PRESENT(is_in) ) is = is_in
+ IF ( PRESENT(js_in) ) js = js_in
+ IF ( PRESENT(ks_in) ) ks = ks_in
+ ie = is+SIZE(field_data, 1)-1
+ je = js+SIZE(field_data, 2)-1
+ ke = ks+SIZE(field_data, 3)-1
+ IF ( PRESENT(ie_in) ) ie = ie_in
+ IF ( PRESENT(je_in) ) je = je_in
+ IF ( PRESENT(ke_in) ) ke = ke_in
+
!If this is true, buffer data
main_if: if (buffer_the_data) then
- !> Calculate the i,j,k start and end
- ! If is, js, or ks not present default them to 1
- is = 1
- js = 1
- ks = 1
- IF ( PRESENT(is_in) ) is = is_in
- IF ( PRESENT(js_in) ) js = js_in
- IF ( PRESENT(ks_in) ) ks = ks_in
- n1 = SIZE(field_data, 1)
- n2 = SIZE(field_data, 2)
- n3 = SIZE(field_data, 3)
- ie = is+n1-1
- je = js+n2-1
- ke = ks+n3-1
- IF ( PRESENT(ie_in) ) ie = ie_in
- IF ( PRESENT(je_in) ) je = je_in
- IF ( PRESENT(ke_in) ) ke = ke_in
-
!> Only 1 thread allocates the output buffer and sets set_math_needs_to_be_done
!$omp critical
if (.not. this%FMS_diag_fields(diag_field_id)%is_data_buffer_allocated()) then
@@ -595,9 +605,13 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
fms_diag_accept_data = .TRUE.
return
else
+ error_string = bounds%set_bounds(field_data, is, ie, js, je, ks, ke, has_halos)
+ if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
+
call this%allocate_diag_field_output_buffers(field_data, diag_field_id)
- fms_diag_accept_data = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, &
- time, is, js, ks, ie, je, ke)
+ error_string = this%fms_diag_do_reduction(field_data, diag_field_id, oor_mask, field_weight, &
+ bounds, using_blocking, Time=Time)
+ if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.)
return
end if main_if
@@ -714,22 +728,141 @@ subroutine fms_diag_do_io(this, is_end_of_run)
#endif
end subroutine fms_diag_do_io
- !> @brief Computes average, min, max, rms error, etc.
- !! based on the specified reduction method for the field.
- !> @return .True. if no error occurs.
-logical function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, &
- time, is_in, js_in, ks_in, ie_in, je_in, ke_in)
+!> @brief Computes average, min, max, rms error, etc.
+!! based on the specified reduction method for the field.
+!> @return Empty string if successful, error message if it fails
+function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, &
+ bounds, using_blocking, time) &
+ result(error_msg)
class(fmsDiagObject_type), intent(in), target :: this !< Diag Object
class(*), intent(in) :: field_data(:,:,:,:) !< Field data
integer, intent(in) :: diag_field_id !< ID of the input field
logical, intent(in), target :: oor_mask(:,:,:,:) !< mask
real(kind=r8_kind), intent(in) :: weight !< Must be a updated weight
+ type(fmsDiagIbounds_type), intent(in) :: bounds !< Bounds for the field
+ logical, intent(in) :: using_blocking !< .True. if field data is passed
+ !! in blocks
type(time_type), intent(in), optional :: time !< Current time
- integer, intent(in), optional :: is_in, js_in, ks_in !< Starting indices of the variable
- integer, intent(in), optional :: ie_in, je_in, ke_in !< Ending indices of the variable
- !TODO Everything
- fms_diag_do_reduction = .true.
+ character(len=50) :: error_msg !< Error message to check
+ !TODO Mostly everything
+#ifdef use_yaml
+ type(fmsDiagField_type), pointer :: field_ptr !< Pointer to the field's object
+ type(fmsDiagOutputBuffer_type), pointer :: buffer_ptr !< Pointer to the field's buffer
+ class(fmsDiagFileContainer_type), pointer :: file_ptr !< Pointer to the field's file
+ type(diagYamlFilesVar_type), pointer :: field_yaml_ptr !< Pointer to the field's yaml
+
+ integer :: reduction_method !< Integer representing a reduction method
+ integer :: ids !< For looping through buffer ids
+ integer :: buffer_id !< Id of the buffer
+ integer :: file_id !< File id
+ integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
+ logical :: is_subregional !< .True. if the buffer is subregional
+ logical :: reduced_k_range !< .True. is the field is only outputing a section
+ !! of the z dimension
+ type(fmsDiagIbounds_type) :: bounds_in !< Starting and ending indices of the input field_data
+ type(fmsDiagIbounds_type) :: bounds_out !< Starting and ending indices of the output buffer
+ integer :: i !< For looping through axid ids
+ integer :: sindex !< Starting index of a subregion
+ integer :: eindex !< Ending index of a subregion
+ integer :: compute_idx(2) !< Starting and Ending of the compute domain
+ character(len=1) :: cart_axis !< Cartesian axis of the axis
+ logical :: block_in_subregion !< .True. if the current block is part of the subregion
+ integer :: starting !< Starting index of the subregion relative to the compute domain
+ integer :: ending !< Ending index of the subregion relative to the compute domain
+
+ !TODO mostly everything
+ field_ptr => this%FMS_diag_fields(diag_field_id)
+ buffer_loop: do ids = 1, size(field_ptr%buffer_ids)
+ error_msg = ""
+ buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(ids)
+ file_id = this%FMS_diag_fields(diag_field_id)%file_ids(ids)
+
+ !< Gather all the objects needed for the buffer
+ field_yaml_ptr => field_ptr%diag_field(ids)
+ buffer_ptr => this%FMS_diag_output_buffers(buffer_id)
+ file_ptr => this%FMS_diag_files(file_id)
+
+ !< Go away if the file is a subregional file and the current PE does not have any data for it
+ if (.not. file_ptr%writing_on_this_pe()) cycle
+
+ bounds_out = bounds
+ if (.not. using_blocking) then
+ !< Set output bounds to start at 1:size(buffer_ptr%buffer)
+ call bounds_out%reset_bounds_from_array_4D(buffer_ptr%buffer(:,:,:,:,1))
+ endif
+
+ bounds_in = bounds
+ if (.not. bounds%has_halos) then
+ !< If field_data does not contain halos, set bounds_in to start at 1:size(field_data)
+ call bounds_in%reset_bounds_from_array_4D(field_data)
+ endif
+
+ is_subregional = file_ptr%is_regional()
+ reduced_k_range = field_yaml_ptr%has_var_zbounds()
+
+ !< Reset the bounds based on the reduced k range and subregional
+ is_subregional_reduced_k_range: if (is_subregional .or. reduced_k_range) then
+ axis_ids = buffer_ptr%get_axis_ids()
+ block_in_subregion = .true.
+ axis_loops: do i = 1, size(axis_ids)
+ !< Move on if the block does not have any data for the subregion
+ if (.not. block_in_subregion) cycle
+
+ select type (diag_axis => this%diag_axis(axis_ids(i))%axis)
+ type is (fmsDiagSubAxis_type)
+ sindex = diag_axis%get_starting_index()
+ eindex = diag_axis%get_ending_index()
+ compute_idx = diag_axis%get_compute_indices()
+ starting=sindex-compute_idx(1)+1
+ ending=eindex-compute_idx(1)+1
+ if (using_blocking) then
+ block_in_subregion = determine_if_block_is_in_region(starting, ending, bounds, i)
+ if (.not. block_in_subregion) cycle
+
+ !< Set bounds_in so that you can the correct section of the data for the block (starting at 1)
+ call bounds_in%rebase_input(bounds, starting, ending, i)
+
+ !< Set bounds_out to be the correct section relative to the block starting and ending indices
+ call bounds_out%rebase_output(starting, ending, i)
+ else
+ !< Set bounds_in so that only the subregion section of the data will be used (starting at 1)
+ call bounds_in%update_index(starting, ending, i, .false.)
+
+ !< Set bounds_out to 1:size(subregion) for the PE
+ call bounds_out%update_index(1, ending-starting+1, i, .true.)
+ endif
+ end select
+ enddo axis_loops
+ deallocate(axis_ids)
+ !< Move on to the next buffer if the block does not have any data for the subregion
+ if (.not. block_in_subregion) cycle
+ endif is_subregional_reduced_k_range
+
+ !< Determine the reduction method for the buffer
+ reduction_method = field_yaml_ptr%get_var_reduction()
+ select case(reduction_method)
+ case (time_none)
+ error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, bounds_in, bounds_out)
+ if (trim(error_msg) .ne. "") then
+ return
+ endif
+ case (time_min)
+ case (time_max)
+ case (time_sum)
+ case (time_average)
+ case (time_power)
+ case (time_rms)
+ case (time_diurnal)
+ case default
+ error_msg = "The reduction method is not supported. "//&
+ "Only none, min, max, sum, average, power, rms, and diurnal are supported."
+ end select
+ enddo buffer_loop
+#else
+ error_msg = ""
+ CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#endif
end function fms_diag_do_reduction
!> @brief Adds the diag ids of the Area and or Volume of the diag_field_object
@@ -807,6 +940,21 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value)
#endif
end subroutine fms_diag_axis_add_attribute
+!> \brief Gets the field_name from the diag_field
+!> \returns a copy of the field_name
+function fms_get_field_name_from_id (this, field_id) &
+ result(field_name)
+
+ class(fmsDiagObject_type), intent (in) :: this !< The diag object, the caller
+ integer, intent (in) :: field_id !< Field id to get the name for
+ character(len=:), allocatable :: field_name
+#ifndef use_yaml
+ CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
+ field_name = this%FMS_diag_fields(field_id)%get_varname()
+#endif
+end function fms_get_field_name_from_id
+
!> \brief Gets the diag field ID from the module name and field name.
!> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered
FUNCTION fms_get_diag_field_id_from_name(this, module_name, field_name) &
@@ -1006,7 +1154,8 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
class(*), allocatable :: missing_value !< Missing value to initialize the data to
character(len=128), allocatable :: var_name !< Field name to initialize output buffers
logical :: is_scalar !< Flag indicating that the variable is a scalar
- integer :: yaml_id
+ integer :: yaml_id !< Yaml id for the buffer
+ integer :: file_id !< File id for the buffer
if (this%FMS_diag_fields(field_id)%buffer_allocated) return
@@ -1045,6 +1194,10 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
! Loop over a number of fields/buffers where this variable occurs
do i = 1, size(this%FMS_diag_fields(field_id)%buffer_ids)
buffer_id = this%FMS_diag_fields(field_id)%buffer_ids(i)
+ file_id = this%FMS_diag_fields(field_id)%file_ids(i)
+
+ !< Go away if the file is a subregional file and the current PE does not have any data for it
+ if (.not. this%FMS_diag_files(file_id)%writing_on_this_pe()) cycle
ndims = 0
if (.not. is_scalar) then
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index f23d6ea3d7..6c284812cd 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -32,6 +32,8 @@ module fms_diag_output_buffer_mod
use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8
use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t
use fms_diag_yaml_mod, only: diag_yaml
+use fms_diag_bbox_mod, only: fmsDiagIbounds_type
+use fms_diag_reduction_methods_mod, only: do_time_none
implicit none
@@ -68,6 +70,7 @@ module fms_diag_output_buffer_mod
procedure :: initialize_buffer
procedure :: get_buffer
procedure :: flush_buffer
+ procedure :: do_time_none_wrapper
end type fmsDiagOutputBuffer_type
@@ -432,5 +435,37 @@ subroutine write_buffer_wrapper_u(this, fms2io_fileobj, unlim_dim_level)
call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_u
+
+!> @brief Does the time_none reduction method on the buffer object
+!! @return Error message if the math was not successful
+function do_time_none_wrapper(this, field_data, mask, bounds_in, bounds_out) &
+ result(err_msg)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
+ class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
+ type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in
+ type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer
+ logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
+ character(len=50) :: err_msg
+
+ !TODO This does not need to be done for every time step
+ !TODO This will be expanded for integers
+ err_msg = ""
+ select type (output_buffer => this%buffer)
+ type is (real(kind=r8_kind))
+ select type (field_data)
+ type is (real(kind=r8_kind))
+ call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out)
+ class default
+ err_msg="the output buffer and the buffer send in are not of the same type (r8_kind)"
+ end select
+ type is (real(kind=r4_kind))
+ select type (field_data)
+ type is (real(kind=r4_kind))
+ call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out)
+ class default
+ err_msg="the output buffer and the buffer send in are not of the same type (r4_kind)"
+ end select
+ end select
+end function do_time_none_wrapper
#endif
end module fms_diag_output_buffer_mod
diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90
index 8962638c04..fa4a7b9fcd 100644
--- a/diag_manager/fms_diag_reduction_methods.F90
+++ b/diag_manager/fms_diag_reduction_methods.F90
@@ -29,10 +29,19 @@
!> @{
module fms_diag_reduction_methods_mod
use platform_mod, only: r8_kind, r4_kind
+ use fms_diag_bbox_mod, only: fmsDiagIbounds_type
+ use mpp_mod
implicit none
private
public :: check_indices_order, init_mask, set_weight
+ public :: do_time_none
+
+ !> @brief Does the time_none reduction method. See include/fms_diag_reduction_methods.inc
+ !TODO This needs to be extended to integers
+ interface do_time_none
+ module procedure do_time_none_r4, do_time_none_r8
+ end interface do_time_none
contains
@@ -82,8 +91,8 @@ end function check_indices_order
!> @return logical mask
function init_mask(rmask, mask, field) &
result(oor_mask)
- LOGICAL, DIMENSION(:,:,:,:), pointer, INTENT(in) :: mask !< The location of the mask
- CLASS(*), DIMENSION(:,:,:,:), pointer, INTENT(in) :: rmask !< The masking values
+ LOGICAL, DIMENSION(:,:,:,:), allocatable, INTENT(in) :: mask !< The location of the mask
+ CLASS(*), DIMENSION(:,:,:,:), allocatable, INTENT(in) :: rmask !< The masking values
CLASS(*), DIMENSION(:,:,:,:), intent(in) :: field !< Field_data
logical, allocatable, dimension(:,:,:,:) :: oor_mask !< mask
@@ -91,9 +100,9 @@ function init_mask(rmask, mask, field) &
ALLOCATE(oor_mask(SIZE(field, 1), SIZE(field, 2), SIZE(field, 3), SIZE(field, 4)))
oor_mask = .true.
- if (associated(mask)) then
+ if (allocated(mask)) then
oor_mask = mask
- elseif (associated(rmask)) then
+ elseif (allocated(rmask)) then
select type (rmask)
type is (real(kind=r8_kind))
WHERE (rmask < 0.5_r8_kind) oor_mask = .FALSE.
@@ -124,6 +133,9 @@ pure function set_weight(weight) &
endif
end function set_weight
+#include "fms_diag_reduction_methods_r4.fh"
+#include "fms_diag_reduction_methods_r8.fh"
+
end module fms_diag_reduction_methods_mod
!> @}
! close documentation grouping
\ No newline at end of file
diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc
new file mode 100644
index 0000000000..0d6633285b
--- /dev/null
+++ b/diag_manager/include/fms_diag_reduction_methods.inc
@@ -0,0 +1,53 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Do the time_none reduction method (i.e copy the correct portion of the input data)
+subroutine DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out)
+ real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
+ real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
+ logical, intent(in) :: mask(:,:,:,:) !< mask
+ type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion
+ !! of the input buffer
+ type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion
+ !! of the output buffer
+
+ integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for
+ !! the input buffer
+ integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for
+ !! the output buffer
+
+ is_out = bounds_out%get_imin()
+ ie_out = bounds_out%get_imax()
+ js_out = bounds_out%get_jmin()
+ je_out = bounds_out%get_jmax()
+ ks_out = bounds_out%get_kmin()
+ ke_out = bounds_out%get_kmax()
+
+ is_in = bounds_in%get_imin()
+ ie_in = bounds_in%get_imax()
+ js_in = bounds_in%get_jmin()
+ je_in = bounds_in%get_jmax()
+ ks_in = bounds_in%get_kmin()
+ ke_in = bounds_in%get_kmax()
+
+ where (mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)) &
+ data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = &
+ data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)
+
+end subroutine DO_TIME_NONE_
\ No newline at end of file
diff --git a/diag_manager/include/fms_diag_reduction_methods_r4.fh b/diag_manager/include/fms_diag_reduction_methods_r4.fh
new file mode 100644
index 0000000000..922972cce3
--- /dev/null
+++ b/diag_manager/include/fms_diag_reduction_methods_r4.fh
@@ -0,0 +1,35 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @file
+!> @brief Imports the time reduction methods routines from other include files used
+!! in @ref diag_manager_mod
+
+!> @addtogroup diag_manager_mod
+!> @{
+
+#undef FMS_TRM_KIND_
+#define FMS_TRM_KIND_ r4_kind
+
+#undef DO_TIME_NONE_
+#define DO_TIME_NONE_ do_time_none_r4
+
+#include "fms_diag_reduction_methods.inc"
+
+!> @}
+! close documentation grouping
\ No newline at end of file
diff --git a/diag_manager/include/fms_diag_reduction_methods_r8.fh b/diag_manager/include/fms_diag_reduction_methods_r8.fh
new file mode 100644
index 0000000000..25c3031a22
--- /dev/null
+++ b/diag_manager/include/fms_diag_reduction_methods_r8.fh
@@ -0,0 +1,35 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @file
+!> @brief Imports the time reduction methods routines from other include files used
+!! in @ref diag_manager_mod
+
+!> @addtogroup diag_manager_mod
+!> @{
+
+#undef FMS_TRM_KIND_
+#define FMS_TRM_KIND_ r8_kind
+
+#undef DO_TIME_NONE_
+#define DO_TIME_NONE_ do_time_none_r8
+
+#include "fms_diag_reduction_methods.inc"
+
+!> @}
+! close documentation grouping
\ No newline at end of file
diff --git a/test_fms/diag_manager/check_time_max.F90 b/test_fms/diag_manager/check_time_max.F90
index b8e82f3472..e579bada4f 100644
--- a/test_fms/diag_manager/check_time_max.F90
+++ b/test_fms/diag_manager/check_time_max.F90
@@ -25,6 +25,8 @@ program check_time_max
use platform_mod, only: r4_kind, r8_kind
use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+ implicit none
+
type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
diff --git a/test_fms/diag_manager/check_time_min.F90 b/test_fms/diag_manager/check_time_min.F90
index f0d8f8029d..cb1406070c 100644
--- a/test_fms/diag_manager/check_time_min.F90
+++ b/test_fms/diag_manager/check_time_min.F90
@@ -25,6 +25,8 @@ program check_time_min
use platform_mod, only: r4_kind, r8_kind
use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+ implicit none
+
type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90
index 11844448c0..f703469078 100644
--- a/test_fms/diag_manager/check_time_none.F90
+++ b/test_fms/diag_manager/check_time_none.F90
@@ -25,6 +25,8 @@ program check_time_none
use platform_mod, only: r4_kind, r8_kind
use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+ implicit none
+
type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
@@ -58,20 +60,20 @@ program check_time_none
nw = 2
if (.not. open_file(fileobj, "test_none.nc", "read")) &
- call mpp_error(FATAL, "unable to open file")
+ call mpp_error(FATAL, "unable to open test_none.nc")
if (.not. open_file(fileobj1, "test_none_regional.nc.0004", "read")) &
- call mpp_error(FATAL, "unable to open file")
+ call mpp_error(FATAL, "unable to open test_none_regional.nc.0004")
if (.not. open_file(fileobj2, "test_none_regional.nc.0005", "read")) &
- call mpp_error(FATAL, "unable to open file")
+ call mpp_error(FATAL, "unable to open test_none_regional.nc.0005")
cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw)
do i = 1, 8
cdata_out = -999_r4_kind
print *, "Checking answers for var0_none - time_level:", string(i)
- call read_data(fileobj, "var0_none", cdata_out(1:1,1,1,1), unlim_dim_level=i) !eyeroll
+ call read_data(fileobj, "var0_none", cdata_out(1,1,1,1), unlim_dim_level=i)
call check_data_0d(cdata_out(1,1,1,1), i)
cdata_out = -999_r4_kind
@@ -120,7 +122,7 @@ subroutine check_data_0d(buffer, time_level)
real(time_level*6, kind=r8_kind)/100_r8_kind, kind=r4_kind)
if (abs(buffer - buffer_exp) > 0) then
- print *, mpp_pe(), time_level, buffer_exp
+ print *, mpp_pe(), time_level, buffer_exp, buffer
call mpp_error(FATAL, "Check_time_none::check_data_0d:: Data is not correct")
endif
end subroutine check_data_0d
diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh
index 0de41c9f1b..7e2597ee87 100755
--- a/test_fms/diag_manager/test_time_none.sh
+++ b/test_fms/diag_manager/test_time_none.sh
@@ -28,26 +28,62 @@ if [ -z "${skipflag}" ]; then
# create and enter directory for in/output files
output_dir
-#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true.
-cat <<_EOF > diag_table
-test_none
-2 1 1 0 0 0
-
-"test_none", 6, "hours", 1, "hours", "time"
-"test_none_regional", 6, "hours", 1, "hours", "time"
-
-"ocn_mod", "var0", "var0_none", "test_none", "all", .false., "none", 2
-"ocn_mod", "var1", "var1_none", "test_none", "all", .false., "none", 2
-"ocn_mod", "var2", "var2_none", "test_none", "all", .false., "none", 2
-"ocn_mod", "var3", "var3_none", "test_none", "all", .false., "none", 2
-
-"ocn_mod", "var3", "var3_Z", "test_none", "all", .false., "-1 -1 -1 -1 2. 3.", 2
-
-"ocn_mod", "var3", "var3_none", "test_none_regional", "all", .false., "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL
+cat <<_EOF > diag_table.yaml
+title: test_none
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_none
+ freq: 6 hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: ocn_mod
+ var_name: var0
+ output_name: var0_none
+ reduction: none
+ kind: r4
+ - module: ocn_mod
+ var_name: var1
+ output_name: var1_none
+ reduction: none
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ output_name: var2_none
+ reduction: none
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_none
+ reduction: none
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_Z
+ reduction: none
+ zbounds: 2. 3.
+ kind: r4
+- file_name: test_none_regional
+ freq: 6 hours
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: latlon
+ corner1: 78. 78.
+ corner2: 78. 78.
+ corner3: 81. 81.
+ corner4: 81. 81.
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_none
+ reduction: none
+ zbounds: 2. 3.
+ kind: r4
_EOF
my_test_count=1
-printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -56,7 +92,7 @@ test_expect_success "Checking answers for the "none" reduction method (test $my_
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method, logical mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -65,7 +101,7 @@ test_expect_success "Checking answers for the "none" reduction method, logical m
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method, real mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -73,9 +109,10 @@ test_expect_success "Checking answers for the "none" reduction method, real mask
mpirun -n 1 ../check_time_none
'
-export OMP_NUM_THREADS=2
+TODO this needs to be set back to 2, once the set_math_needs_to_be_done=.true. portion of the code is implemented
+export OMP_NUM_THREADS=1
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method with openmp (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -84,7 +121,7 @@ test_expect_success "Checking answers for the "none" reduction method with openm
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method with openmp, logical mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -93,7 +130,7 @@ test_expect_success "Checking answers for the "none" reduction method with openm
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method with openmp, real mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -103,7 +140,7 @@ test_expect_success "Checking answers for the "none" reduction method with openm
export OMP_NUM_THREADS=1
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method with halo output (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -112,7 +149,7 @@ test_expect_success "Checking answers for the "none" reduction method with halo
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method with halo output with logical mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -121,7 +158,7 @@ test_expect_success "Checking answers for the "none" reduction method with halo
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method with halo output with real mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -129,4 +166,4 @@ test_expect_success "Checking answers for the "none" reduction method with halo
mpirun -n 1 ../check_time_none
'
fi
-test_done
\ No newline at end of file
+test_done
From 86f8ad4bc787591d71625a211cd26bf105c1a257 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 8 Sep 2023 09:13:21 -0400
Subject: [PATCH 124/168] feat: modern_diag_manager update output_buffer_obj
(#1354)
---
diag_manager/Makefile.am | 2 +-
diag_manager/fms_diag_file_object.F90 | 21 +++-
diag_manager/fms_diag_object.F90 | 69 ++++++-----
diag_manager/fms_diag_output_buffer.F90 | 109 ++++++++++++------
.../include/fms_diag_reduction_methods.inc | 8 +-
test_fms/diag_manager/test_diag_buffer.F90 | 18 +--
6 files changed, 139 insertions(+), 88 deletions(-)
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 8ad1e5a191..7e1172c6f8 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -101,7 +101,7 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD
fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \
fms_diag_fieldbuff_update_mod.$(FC_MODEXT)
fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
- fms_diag_reduction_methods_mod.$(FC_MODEXT)
+ fms_diag_reduction_methods_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
fms_diag_reduction_methods_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT) \
diag_data_mod.$(FC_MODEXT)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index e2c05da68f..b33b9d0431 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -67,6 +67,10 @@ module fms_diag_file_object_mod
TYPE(time_type) :: next_output !< Time of the next write
TYPE(time_type) :: next_next_output !< Time of the next next write
TYPE(time_type) :: no_more_data !< Time to stop receiving data for this file
+ logical :: done_writing_data!< Set to .True. if finished writing data
+ !! This is be initialized to .false. and set to true for
+ !! static files after the first write and for
+ !! files that are using the file_duration functionality
!< This will be used when using the new_file_freq keys in the diag_table.yaml
TYPE(time_type) :: next_close !< Time to close the file
@@ -129,6 +133,7 @@ module fms_diag_file_object_mod
procedure, public :: get_file_duration_units
procedure, public :: get_file_varlist
procedure, public :: get_file_global_meta
+ procedure, public :: is_done_writing_data
procedure, public :: has_file_fname
procedure, public :: has_file_frequnit
procedure, public :: has_file_freq
@@ -233,6 +238,7 @@ logical function fms_diag_files_object_init (files_array)
obj%number_of_axis = 0
!> Set the start_time of the file to the base_time and set up the *_output variables
+ obj%done_writing_data = .false.
obj%start_time = get_base_time()
obj%last_output = get_base_time()
obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit())
@@ -559,6 +565,14 @@ pure function get_file_global_meta (this) result(res)
res = this%diag_yaml_file%get_file_global_meta()
end function get_file_global_meta
+!> \brief Determines if done writing data
+!! \return .True. if done writing data
+pure function is_done_writing_data (this) result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
+ logical :: res
+ res = this%done_writing_data
+end function is_done_writing_data
+
!> \brief Checks if file_fname is allocated in the yaml object
!! \return true if file_fname is allocated
pure function has_file_fname (this) result(res)
@@ -1122,9 +1136,9 @@ end subroutine write_time_metadata
!> \brief Write out the field data to the file
subroutine write_field_data(this, field_obj, buffer_obj)
- class(fmsDiagFileContainer_type), intent(in), target :: this !< The diag file object to write to
- type(fmsDiagField_type), intent(in), target :: field_obj(:) !< The field object to write from
- type(fmsDiagOutputBuffer_type), intent(in), target :: buffer_obj(:) !< The buffer object with the data
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The diag file object to write to
+ type(fmsDiagField_type), intent(in), target :: field_obj(:) !< The field object to write from
+ type(fmsDiagOutputBuffer_type), intent(inout), target :: buffer_obj(:) !< The buffer object with the data
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< Fileobj to write to
@@ -1261,6 +1275,7 @@ subroutine update_current_new_file_freq_index(this, time_step)
diag_file%get_file_duration_units())
else
!< At this point you are done writing data
+ diag_file%done_writing_data = .true.
diag_file%no_more_data = diag_time_inc(diag_file%no_more_data, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
diag_file%next_output = diag_file%no_more_data
diag_file%next_next_output = diag_file%no_more_data
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 907f0c6613..0a3953a8bb 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -22,7 +22,7 @@ module fms_diag_object_mod
&DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, &
&get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered, &
&time_none, time_max, time_min, time_sum, time_average, time_diurnal, &
- &time_power, time_rms
+ &time_power, time_rms, r8
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
& OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
@@ -199,8 +199,9 @@ integer function fms_register_diag_field_obj &
LOGICAL, OPTIONAL, INTENT(in) :: static !< True if the variable is static
#ifdef use_yaml
- class (fmsDiagFile_type), pointer :: fileptr => null() !< Pointer to the diag_file
- class (fmsDiagField_type), pointer :: fieldptr => null() !< Pointer to the diag_field
+ class (fmsDiagFile_type), pointer :: fileptr !< Pointer to the diag_file
+ class (fmsDiagField_type), pointer :: fieldptr !< Pointer to the diag_field
+ class (fmsDiagOutputBuffer_type), pointer :: bufferptr !< Pointer to the output buffer
integer, allocatable :: file_ids(:) !< The file IDs for this variable
integer :: i !< For do loops
integer, allocatable :: diag_field_indices(:) !< indices where the field was found in the yaml
@@ -225,13 +226,17 @@ integer function fms_register_diag_field_obj &
!> Use pointers for convenience
fieldptr => this%FMS_diag_fields(this%registered_variables)
+!> Get the file IDs from the field indicies from the yaml
+ file_ids = get_diag_files_id(diag_field_indices)
+ call fieldptr%set_file_ids(file_ids)
!> Initialize buffer_ids of this field with the diag_field_indices(diag_field_indices)
!! of the sorted variable list
fieldptr%buffer_ids = get_diag_field_ids(diag_field_indices)
do i = 1, size(fieldptr%buffer_ids)
- call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_field_id(this%registered_variables)
- call this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))%set_yaml_id(fieldptr%buffer_ids(i))
+ bufferptr => this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))
+ call bufferptr%set_field_id(this%registered_variables)
+ call bufferptr%set_yaml_id(fieldptr%buffer_ids(i))
enddo
!> Allocate and initialize member buffer_allocated of this field
@@ -243,9 +248,7 @@ integer function fms_register_diag_field_obj &
mask_variant= mask_variant, standname=standname, do_not_log=do_not_log, err_msg=err_msg, &
interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
static=static)
-!> Get the file IDs from the field indicies from the yaml
- file_ids = get_diag_files_id(diag_field_indices)
- call fieldptr%set_file_ids(file_ids)
+
!> Add the axis information, initial time, and field IDs to the files
if (present(axes) .and. present(init_time)) then
do i = 1, size(file_ids)
@@ -734,7 +737,7 @@ end subroutine fms_diag_do_io
function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight, &
bounds, using_blocking, time) &
result(error_msg)
- class(fmsDiagObject_type), intent(in), target :: this !< Diag Object
+ class(fmsDiagObject_type), intent(inout), target:: this !< Diag Object
class(*), intent(in) :: field_data(:,:,:,:) !< Field data
integer, intent(in) :: diag_field_id !< ID of the input field
logical, intent(in), target :: oor_mask(:,:,:,:) !< mask
@@ -770,9 +773,22 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
logical :: block_in_subregion !< .True. if the current block is part of the subregion
integer :: starting !< Starting index of the subregion relative to the compute domain
integer :: ending !< Ending index of the subregion relative to the compute domain
+ real(kind=r8_kind) :: missing_value !< Missing_value for data points that are masked
+ !! This will obtained as r8 and converted to the right type as
+ !! needed. This is to avoid yet another select type ...
!TODO mostly everything
field_ptr => this%FMS_diag_fields(diag_field_id)
+ if (field_ptr%has_missing_value()) then
+ select type (missing_val => field_ptr%get_missing_value(r8))
+ type is (real(kind=r8_kind))
+ missing_value = missing_val
+ class default
+ call mpp_error(FATAl, "The missing value for the field:"//trim(field_ptr%get_varname())//&
+ &" was not allocated to the correct type. This shouldn't have happened")
+ end select
+ endif
+
buffer_loop: do ids = 1, size(field_ptr%buffer_ids)
error_msg = ""
buffer_id = this%FMS_diag_fields(diag_field_id)%buffer_ids(ids)
@@ -786,6 +802,9 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
!< Go away if the file is a subregional file and the current PE does not have any data for it
if (.not. file_ptr%writing_on_this_pe()) cycle
+ !< Go away if finished doing math for this buffer
+ if (buffer_ptr%is_done_with_math()) cycle
+
bounds_out = bounds
if (.not. using_blocking) then
!< Set output bounds to start at 1:size(buffer_ptr%buffer)
@@ -843,7 +862,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
reduction_method = field_yaml_ptr%get_var_reduction()
select case(reduction_method)
case (time_none)
- error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, bounds_in, bounds_out)
+ error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, bounds_in, bounds_out, missing_value)
if (trim(error_msg) .ne. "") then
return
endif
@@ -858,6 +877,10 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
error_msg = "The reduction method is not supported. "//&
"Only none, min, max, sum, average, power, rms, and diurnal are supported."
end select
+
+ if (field_ptr%is_static() .or. file_ptr%FMS_diag_file%is_done_writing_data()) then
+ call buffer_ptr%set_done_with_math()
+ endif
enddo buffer_loop
#else
error_msg = ""
@@ -1151,7 +1174,6 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
class(DiagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields
integer, allocatable :: axis_ids(:) !< Pointer to indices of axes of the field variable
integer :: var_type !< Stores type of the field data (r4, r8, i4, i8, and string) represented as an integer.
- class(*), allocatable :: missing_value !< Missing value to initialize the data to
character(len=128), allocatable :: var_name !< Field name to initialize output buffers
logical :: is_scalar !< Flag indicating that the variable is a scalar
integer :: yaml_id !< Yaml id for the buffer
@@ -1165,29 +1187,6 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
! Get variable/field name
var_name = this%Fms_diag_fields(field_id)%get_varname()
- ! Get missing value for the field
- !TODO class (*) is weird missing_value = this%FMS_diag_fields(field_id)%get_missing_value(var_type)
- !!should work ...
- if (this%FMS_diag_fields(field_id)%has_missing_value()) then
- select type (my_type => this%FMS_diag_fields(field_id)%get_missing_value(var_type))
- type is (real(kind=r4_kind))
- missing_value = real(my_type, kind=r4_kind)
- type is (real(kind=r8_kind))
- missing_value = real(my_type, kind=r8_kind)
- class default
- call mpp_error( FATAL, 'fms_diag_object_mod:allocate_diag_field_output_buffers Invalid type')
- end select
- else
- select type (my_type => get_default_missing_value(var_type))
- type is (real(kind=r4_kind))
- missing_value = real(my_type, kind=r4_kind)
- type is (real(kind=r8_kind))
- missing_value = real(my_type, kind=r8_kind)
- class default
- call mpp_error( FATAL, 'fms_diag_object_mod:allocate_diag_field_output_buffers Invalid type')
- end select
- endif
-
! Determine dimensions of the field
is_scalar = this%FMS_diag_fields(field_id)%is_scalar()
@@ -1223,7 +1222,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id)
call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), ndims, axes_length(1:5), &
this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
- call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name)
+ call ptr_diag_buffer_obj%initialize_buffer(ptr_diag_field_yaml%get_var_reduction(), var_name)
if (allocated(axis_ids)) deallocate(axis_ids)
enddo
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 6c284812cd..e17d9ec909 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -27,13 +27,15 @@ module fms_diag_output_buffer_mod
#ifdef use_yaml
use platform_mod
use iso_c_binding
-use time_manager_mod, only: time_type
+use time_manager_mod, only: time_type, operator(==)
use mpp_mod, only: mpp_error, FATAL
-use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8
+use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8, get_base_time, MIN_VALUE, MAX_VALUE, EMPTY, &
+ time_min, time_max
use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t
use fms_diag_yaml_mod, only: diag_yaml
use fms_diag_bbox_mod, only: fmsDiagIbounds_type
use fms_diag_reduction_methods_mod, only: do_time_none
+use fms_diag_time_utils_mod, only: diag_time_inc
implicit none
@@ -53,6 +55,7 @@ module fms_diag_output_buffer_mod
integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
integer :: field_id !< The id of the field the buffer belongs to
integer :: yaml_id !< The id of the yaml id the buffer belongs to
+ logical :: done_with_math !< .True. if done doing the math
contains
procedure :: add_axis_ids
@@ -61,6 +64,8 @@ module fms_diag_output_buffer_mod
procedure :: get_field_id
procedure :: set_yaml_id
procedure :: get_yaml_id
+ procedure :: is_done_with_math
+ procedure :: set_done_with_math
procedure :: write_buffer
!! These are needed because otherwise the write_data calls will go into the wrong interface
procedure :: write_buffer_wrapper_netcdf
@@ -188,6 +193,7 @@ subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurna
allocate(this%num_elements(n_samples))
this%num_elements = 0
this%count_0d = 0
+ this%done_with_math = .false.
allocate(this%buffer_dims(5))
this%buffer_dims(1) = buff_sizes(1)
this%buffer_dims(2) = buff_sizes(2)
@@ -233,47 +239,51 @@ subroutine get_buffer (this, buff_out, field_name)
end select
end subroutine
-!> @brief Initializes a buffer to a given fill value.
-subroutine initialize_buffer (this, fillval, field_name)
- class(fmsDiagOutputBuffer_type), intent(inout) :: this !< allocated 5D buffer object
- class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer
- character(len=*), intent(in) :: field_name !< field name for error output
+!> @brief Initializes a buffer based on the reduction method
+subroutine initialize_buffer (this, reduction_method, field_name)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< allocated 5D buffer object
+ integer, intent(in) :: reduction_method !< The reduction method for the field
+ character(len=*), intent(in) :: field_name !< field name for error output
if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer: field:'// field_name // &
'buffer not yet allocated, allocate_buffer() must be called on this object first.')
- ! have to check fill value and buffer types match
+
select type(buff => this%buffer)
type is(real(r8_kind))
- select type(fillval)
- type is(real(r8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(r8_kind)' // &
- ' for field' // field_name )
+ select case (reduction_method)
+ case (time_min)
+ buff = real(MIN_VALUE, kind=r8_kind)
+ case (time_max)
+ buff = real(MAX_VALUE, kind=r8_kind)
+ case default
+ buff = real(EMPTY, kind=r8_kind)
end select
type is(real(r4_kind))
- select type(fillval)
- type is(real(r4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(r4_kind)' // &
- ' for field' // field_name )
+ select case (reduction_method)
+ case (time_min)
+ buff = real(MIN_VALUE, kind=r4_kind)
+ case (time_max)
+ buff = real(MAX_VALUE, kind=r4_kind)
+ case default
+ buff = real(EMPTY, kind=r4_kind)
end select
type is(integer(i8_kind))
- select type(fillval)
- type is(integer(i8_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(i8_kind)' // &
- ' for field' // field_name )
+ select case (reduction_method)
+ case (time_min)
+ buff = int(MIN_VALUE, kind=i8_kind)
+ case (time_max)
+ buff = int(MAX_VALUE, kind=i8_kind)
+ case default
+ buff = int(EMPTY, kind=i8_kind)
end select
type is(integer(i4_kind))
- select type(fillval)
- type is(integer(i4_kind))
- buff = fillval
- class default
- call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(i4_kind)' // &
- ' for field' // field_name )
+ select case (reduction_method)
+ case (time_min)
+ buff = int(MIN_VALUE, kind=i4_kind)
+ case (time_max)
+ buff = int(MAX_VALUE, kind=i4_kind)
+ case default
+ buff = int(EMPTY, kind=i4_kind)
end select
class default
call mpp_error(FATAL, 'initialize buffer_5d: buffer allocated to invalid data type, this shouldnt happen')
@@ -331,6 +341,24 @@ subroutine set_yaml_id(this, yaml_id)
this%yaml_id = yaml_id
end subroutine set_yaml_id
+!> @brief Determine if finished with math
+!! @return this%done_with_math
+function is_done_with_math(this) &
+ result(res)
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object
+ logical :: res
+
+ res = this%done_with_math
+end function is_done_with_math
+
+!> @brief Set done_with_math to .true.
+subroutine set_done_with_math(this)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ integer :: res
+
+ this%done_with_math = .true.
+end subroutine set_done_with_math
+
!> @brief Get the yaml id of the buffer
!! @return the yaml id of the buffer
function get_yaml_id(this) &
@@ -344,9 +372,9 @@ end function get_yaml_id
!> @brief Write the buffer to the file
subroutine write_buffer(this, fms2io_fileobj, unlim_dim_level)
- class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
- class(FmsNetcdfFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
- integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
+ class(FmsNetcdfFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
+ integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
select type(fms2io_fileobj)
type is (FmsNetcdfFile_t)
@@ -359,6 +387,10 @@ subroutine write_buffer(this, fms2io_fileobj, unlim_dim_level)
call mpp_error(FATAL, "The file "//trim(fms2io_fileobj%path)//" is not one of the accepted types"//&
" only FmsNetcdfFile_t, FmsNetcdfDomainFile_t, and FmsNetcdfUnstructuredDomainFile_t are accepted.")
end select
+
+ call this%initialize_buffer(diag_yaml%diag_fields(this%yaml_id)%get_var_reduction(), &
+ diag_yaml%diag_fields(this%yaml_id)%get_var_outname())
+ !TODO Set the counters back to 0
end subroutine write_buffer
!> @brief Write the buffer to the FmsNetcdfFile_t fms2io_fileobj
@@ -438,13 +470,14 @@ end subroutine write_buffer_wrapper_u
!> @brief Does the time_none reduction method on the buffer object
!! @return Error message if the math was not successful
-function do_time_none_wrapper(this, field_data, mask, bounds_in, bounds_out) &
+function do_time_none_wrapper(this, field_data, mask, bounds_in, bounds_out, missing_value) &
result(err_msg)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in
type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer
logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
+ real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
character(len=50) :: err_msg
!TODO This does not need to be done for every time step
@@ -454,14 +487,14 @@ function do_time_none_wrapper(this, field_data, mask, bounds_in, bounds_out) &
type is (real(kind=r8_kind))
select type (field_data)
type is (real(kind=r8_kind))
- call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out)
+ call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out, missing_value)
class default
err_msg="the output buffer and the buffer send in are not of the same type (r8_kind)"
end select
type is (real(kind=r4_kind))
select type (field_data)
type is (real(kind=r4_kind))
- call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out)
+ call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out, real(missing_value, kind=r4_kind))
class default
err_msg="the output buffer and the buffer send in are not of the same type (r4_kind)"
end select
diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc
index 0d6633285b..ddb6b8c926 100644
--- a/diag_manager/include/fms_diag_reduction_methods.inc
+++ b/diag_manager/include/fms_diag_reduction_methods.inc
@@ -18,7 +18,7 @@
!***********************************************************************
!> @brief Do the time_none reduction method (i.e copy the correct portion of the input data)
-subroutine DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out)
+subroutine DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out, missing_value)
real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
logical, intent(in) :: mask(:,:,:,:) !< mask
@@ -26,6 +26,7 @@ subroutine DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out)
!! of the input buffer
type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion
!! of the output buffer
+ real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked
integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for
!! the input buffer
@@ -46,8 +47,11 @@ subroutine DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out)
ks_in = bounds_in%get_kmin()
ke_in = bounds_in%get_kmax()
- where (mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)) &
+ where (mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :))
data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = &
data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)
+ elsewhere
+ data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = missing_value
+ end where
end subroutine DO_TIME_NONE_
\ No newline at end of file
diff --git a/test_fms/diag_manager/test_diag_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90
index e339e9055e..bdaaa10c9d 100644
--- a/test_fms/diag_manager/test_diag_buffer.F90
+++ b/test_fms/diag_manager/test_diag_buffer.F90
@@ -25,7 +25,7 @@ program test_diag_buffer
use platform_mod, only: r8_kind, r4_kind, i8_kind, i4_kind
use fms_mod, only: string, fms_init, fms_end
use mpp_mod, only: mpp_error, FATAL
- use diag_data_mod, only: i4, i8, r4, r8
+ use diag_data_mod, only: i4, i8, r4, r8, time_none, EMPTY
implicit none
@@ -46,11 +46,11 @@ program test_diag_buffer
do i=0, 5
if (i < 5) buff_sizes(i+1) = i+5
call buffobj(i+1)%allocate_buffer(r8_data, i, buff_sizes, fname)
- call buffobj(i+1)%initialize_buffer( real(i, kind=r8_kind) , fname)
+ call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
type is (real(kind=r8_kind))
- if (any(p_val .ne. real(i, kind=r8_kind))) &
+ if (any(p_val .ne. real(EMPTY, kind=r8_kind))) &
call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
do j = 1, 5
if (size(p_val, j) .ne. buff_sizes(j)) &
@@ -68,11 +68,11 @@ program test_diag_buffer
do i=0, 5
if (i < 5) buff_sizes(i+1) = i+5
call buffobj(i+1)%allocate_buffer(r4_data, i, buff_sizes, fname)
- call buffobj(i+1)%initialize_buffer( real(i, kind=r4_kind) , fname)
+ call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
type is (real(kind=r4_kind))
- if (any(p_val .ne. real(i, kind=r4_kind))) &
+ if (any(p_val .ne. real(EMPTY, kind=r4_kind))) &
call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
do j = 1, 5
if (size(p_val, j) .ne. buff_sizes(j)) &
@@ -90,11 +90,11 @@ program test_diag_buffer
do i=0, 5
if (i < 5) buff_sizes(i+1) = i+5
call buffobj(i+1)%allocate_buffer(i8_data, i, buff_sizes, fname)
- call buffobj(i+1)%initialize_buffer( int(i, kind=i8_kind) , fname)
+ call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
type is (integer(kind=i8_kind))
- if (any(p_val .ne. int(i, kind=i8_kind))) &
+ if (any(p_val .ne. int(EMPTY, kind=i8_kind))) &
call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
do j = 1, 5
if (size(p_val, j) .ne. buff_sizes(j)) &
@@ -112,11 +112,11 @@ program test_diag_buffer
do i=0, 5
if (i < 5) buff_sizes(i+1) = i+5
call buffobj(i+1)%allocate_buffer(i4_data, i, buff_sizes, fname)
- call buffobj(i+1)%initialize_buffer( int(i, kind=i4_kind) , fname)
+ call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
type is (integer(kind=i4_kind))
- if (any(p_val .ne. int(i, kind=i4_kind))) &
+ if (any(p_val .ne. int(EMPTY, kind=i4_kind))) &
call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
do j = 1, 5
if (size(p_val, j) .ne. buff_sizes(j)) &
From 67a340539ea1db43b1f011d4a405eee526b0d09e Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Fri, 8 Sep 2023 09:31:53 -0400
Subject: [PATCH 125/168] feat: modern diag change type of buffer counter
(#1315)
---
diag_manager/fms_diag_output_buffer.F90 | 28 ++++++++++++-------------
1 file changed, 14 insertions(+), 14 deletions(-)
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index e17d9ec909..9a3ffdf469 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -48,9 +48,9 @@ module fms_diag_output_buffer_mod
class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array
integer :: ndim !< Number of dimensions for each variable
integer, allocatable :: buffer_dims(:) !< holds the size of each dimension in the buffer
- class(*), allocatable :: counter(:,:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
+ real(r8_kind), allocatable :: counter(:,:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
integer, allocatable :: num_elements(:) !< used in time-averaging
- class(*), allocatable :: count_0d(:) !< used in time-averaging along with
+ real(r8_kind), allocatable :: count_0d(:) !< used in time-averaging along with
!! counter which is stored in the child types (bufferNd)
integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
integer :: field_id !< The id of the field the buffer belongs to
@@ -152,36 +152,36 @@ subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurna
type is (integer(kind=i4_kind))
allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ allocate(this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(integer(kind=i4_kind) :: this%count_0d(n_samples))
- this%counter = 0_i4_kind
- this%count_0d = 0_i4_kind
+ allocate(this%count_0d(n_samples))
+ this%counter = 0.0_r4_kind
+ this%count_0d = 0.0_r4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ allocate(this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(integer(kind=i8_kind) :: this%count_0d(n_samples))
- this%counter = 0_i8_kind
- this%count_0d = 0_i8_kind
+ allocate(this%count_0d(n_samples))
+ this%counter = 0.0_r8_kind
+ this%count_0d = 0.0_r8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ allocate(this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(real(kind=r4_kind) :: this%count_0d(n_samples))
+ allocate(this%count_0d(n_samples))
this%counter = 0.0_r4_kind
this%count_0d = 0.0_r4_kind
this%buffer_type = r4
type is (real(kind=r8_kind))
allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
+ allocate(this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(real(kind=r8_kind) :: this%count_0d(n_samples))
+ allocate(this%count_0d(n_samples))
this%counter = 0.0_r8_kind
this%count_0d = 0.0_r8_kind
this%buffer_type = r8
From 2a6da6809ff8c01167ede66969c66e0e7ac528cd Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 13 Sep 2023 13:39:52 -0400
Subject: [PATCH 126/168] feat: Modern diag manager input buffer obj (#1362)
---
CMakeLists.txt | 1 +
diag_manager/Makefile.am | 8 +-
diag_manager/fms_diag_bbox.F90 | 4 +
diag_manager/fms_diag_field_object.F90 | 165 ++++++--------
diag_manager/fms_diag_file_object.F90 | 5 +-
diag_manager/fms_diag_input_buffer.F90 | 206 ++++++++++++++++++
diag_manager/fms_diag_object.F90 | 16 +-
.../diag_manager/test_reduction_methods.F90 | 16 +-
test_fms/diag_manager/test_time_none.sh | 3 +-
9 files changed, 313 insertions(+), 111 deletions(-)
create mode 100644 diag_manager/fms_diag_input_buffer.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index a0eba12a0b..f5aa2b4a2d 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -140,6 +140,7 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_object_container.F90
diag_manager/fms_diag_buffer.F90
diag_manager/fms_diag_output_buffer.F90
+ diag_manager/fms_diag_input_buffer.F90
diag_manager/fms_diag_time_reduction.F90
diag_manager/fms_diag_outfield.F90
diag_manager/fms_diag_elem_weight_procs.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 7e1172c6f8..9bf6e5af1f 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -54,6 +54,7 @@ libdiag_manager_la_SOURCES = \
fms_diag_object_container.F90 \
fms_diag_dlinked_list.F90 \
fms_diag_output_buffer.F90 \
+ fms_diag_input_buffer.F90 \
fms_diag_time_reduction.F90 \
fms_diag_outfield.F90 \
fms_diag_elem_weight_procs.F90 \
@@ -79,9 +80,11 @@ fms_diag_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_file_objec
fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_output_buffer_mod.$(FC_MODEXT) \
fms_diag_reduction_methods_mod.$(FC_MODEXT) \
- fms_diag_bbox_mod.$(FC_MODEXT)
+ fms_diag_bbox_mod.$(FC_MODEXT) \
+ fms_diag_input_buffer_mod.$(FC_MODEXT)
+fms_diag_input_buffer_mod.$(FC_MODEXT): fms_diag_axis_object_mod.$(FC_MODEXT)
fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
- fms_diag_axis_object_mod.$(FC_MODEXT)
+ fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_input_buffer_mod.$(FC_MODEXT)
fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT)
fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
@@ -130,6 +133,7 @@ MODFILES = \
fms_diag_dlinked_list_mod.$(FC_MODEXT) \
fms_diag_object_container_mod.$(FC_MODEXT) \
fms_diag_output_buffer_mod.$(FC_MODEXT) \
+ fms_diag_input_buffer_mod.$(FC_MODEXT) \
diag_manager_mod.$(FC_MODEXT) \
fms_diag_time_reduction_mod.$(FC_MODEXT) \
fms_diag_outfield_mod.$(FC_MODEXT) \
diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90
index fb05d2b998..81c0a33d51 100644
--- a/diag_manager/fms_diag_bbox.F90
+++ b/diag_manager/fms_diag_bbox.F90
@@ -353,6 +353,10 @@ SUBROUTINE reset_bounds_from_array_4D(this, array)
this%jmax = UBOUND(array,2)
this%kmin = LBOUND(array,3)
this%kmax = UBOUND(array,3)
+
+ this%has_halos = .false.
+ this%nhalo_I = 0
+ this%nhalo_J = 0
END SUBROUTINE reset_bounds_from_array_4D
!> @brief Reset the instance bounding box with the bounds determined from the
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 08292df80f..58b830d36c 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -23,6 +23,7 @@ module fms_diag_field_object_mod
use time_manager_mod, ONLY: time_type
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, register_field, &
register_variable_attribute
+use fms_diag_input_buffer_mod, only: fmsDiagInputBuffer_t
!!!set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
!!! & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
!!! & get_ticks_per_second
@@ -70,7 +71,8 @@ module fms_diag_field_object_mod
integer, allocatable, private :: area, volume !< The Area and Volume
class(*), allocatable, private :: missing_value !< The missing fill value
class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data
- class(*), allocatable, dimension(:,:,:,:), private :: data_buffer !< Buffer for field data
+ type(fmsDiagInputBuffer_t), allocatable :: input_data_buffer !< Input buffer object for when buffering
+ !! data
logical, allocatable, private :: data_buffer_is_allocated !< True if the buffer has
!! been allocated
logical, allocatable, private :: math_needs_to_be_done !< If true, do math
@@ -124,7 +126,7 @@ module fms_diag_field_object_mod
procedure :: has_volume
procedure :: has_missing_value
procedure :: has_data_RANGE
- procedure :: has_data_buffer
+ procedure :: has_input_data_buffer
! Get functions
procedure :: get_attributes
procedure :: get_static
@@ -147,6 +149,8 @@ module fms_diag_field_object_mod
procedure :: get_data_RANGE
procedure :: get_axis_id
procedure :: get_data_buffer
+ procedure :: get_mask
+ procedure :: get_weight
procedure :: dump_field_obj
procedure :: get_domain
procedure :: get_type_of_domain
@@ -388,42 +392,23 @@ subroutine set_vartype(objin , var)
end subroutine set_vartype
!> @brief Adds the input data to the buffered data.
-subroutine set_data_buffer (this, input_data, is, js, ks, ie, je, ke)
- class (fmsDiagField_type) , intent(inout):: this !< The field object
- class(*), dimension(:,:,:,:), intent(in) :: input_data !< The input array
- integer :: is, js, ks !< Starting indicies of the field_data relative to the global domain
- integer :: ie, je, ke !< Ending indicies of the field_data relative to the global domain
-
+subroutine set_data_buffer (this, input_data, mask, weight, is, js, ks, ie, je, ke)
+ class (fmsDiagField_type) , intent(inout):: this !< The field object
+ class(*), intent(in) :: input_data(:,:,:,:) !< The input array
+ logical, intent(in) :: mask(:,:,:,:) !< The field mask
+ real(kind=r8_kind), intent(in) :: weight !< The field weight
+ integer, intent(in) :: is, js, ks !< Starting indicies of the field_data relative
+ !! to the compute domain (1 based)
+ integer, intent(in) :: ie, je, ke !< Ending indicies of the field_data relative
+ !! to the compute domain (1 based)
+
+ character(len=128) :: err_msg !< Error msg
if (.not.this%data_buffer_is_allocated) &
call mpp_error ("set_data_buffer", "The data buffer for the field "//trim(this%varname)//" was unable to be "//&
"allocated.", FATAL)
+ err_msg = this%input_data_buffer%set_input_buffer_object(input_data, weight, mask, is, js, ks, ie, je, ke)
+ if (trim(err_msg) .ne. "") call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg))
-!> Buffer a copy of the data
- select type (input_data)
- type is (real(kind=r4_kind))
- select type (db => this%data_buffer)
- type is (real(kind=r4_kind))
- db(is:ie, js:je, ks:ke, :) = input_data
- end select
- type is (real(kind=r8_kind))
- select type (db => this%data_buffer)
- type is (real(kind=r8_kind))
- db(is:ie, js:je, ks:ke, :) = input_data
- end select
- type is (integer(kind=i4_kind))
- select type (db => this%data_buffer)
- type is (integer(kind=i4_kind))
- db(is:ie, js:je, ks:ke, :) = input_data
- end select
- type is (integer(kind=i8_kind))
- select type (db => this%data_buffer)
- type is (integer(kind=i8_kind))
- db(is:ie, js:je, ks:ke, :) = input_data
- end select
- class default
- call mpp_error ("set_data_buffer", "The data input to set_data_buffer for "//&
- trim(this%varname)//" does not match the buffer for the field object", FATAL)
- end select
end subroutine set_data_buffer
!> Allocates the global data buffer for a given field using a single thread. Returns true when the
!! buffer is allocated
@@ -431,55 +416,18 @@ logical function allocate_data_buffer(this, input_data, diag_axis)
class (fmsDiagField_type), target, intent(inout):: this !< The field object
class(*), dimension(:,:,:,:), intent(in) :: input_data !< The input array
class(fmsDiagAxisContainer_type),intent(in) :: diag_axis(:) !< Array of diag_axis
- integer :: naxes !< The number of axes in the field
- integer, parameter :: ndims = 4
- integer, dimension (ndims) :: length !< The length of an axis
- integer :: a !< For looping through axes
- integer, pointer :: axis_id !< The axis ID
-
-!! Use the axis to get the size
-!> Initialize the axis lengths to 1. Any dimension that does not have an axis will have a length
-!! of 1.
- length = 1
- naxes = size(this%axis_ids)
- axis_loop: do a = 1,naxes
- axis_id => this%axis_ids(a)
- select type (axis => diag_axis(axis_id)%axis)
- type is (fmsDiagFullAxis_type)
- length(a) = axis%axis_length()
- end select
- enddo axis_loop
- select type (input_data)
- type is (real(r4_kind))
- if (.not.allocated(this%data_buffer)) allocate(real(kind=r4_kind) :: this%data_buffer( &
- length(1),&
- length(2),&
- length(3),&
- length(4)))
- type is (real(r8_kind))
- if (.not.allocated(this%data_buffer)) allocate(real(kind=r8_kind) :: this%data_buffer( &
- length(1),&
- length(2),&
- length(3),&
- length(4)))
- type is (integer(i4_kind))
- if (.not.allocated(this%data_buffer)) allocate(integer(kind=i4_kind) :: this%data_buffer( &
- length(1),&
- length(2),&
- length(3),&
- length(4)))
- type is (integer(i8_kind))
- if (.not.allocated(this%data_buffer)) allocate(integer(kind=i8_kind) :: this%data_buffer( &
- length(1),&
- length(2),&
- length(3),&
- length(4)))
- class default
- call mpp_error ("allocate_data_buffer","The data input to set_data_buffer for "//&
- trim(this%varname)//" is not a supported type", FATAL)
- end select
- allocate_data_buffer = allocated(this%data_buffer)
+ character(len=128) :: err_msg !< Error msg
+ err_msg = ""
+
+ allocate(this%input_data_buffer)
+ err_msg = this%input_data_buffer%init(input_data, this%axis_ids, diag_axis)
+ if (trim(err_msg) .ne. "") then
+ call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg))
+ return
+ endif
+
+ allocate_data_buffer = .true.
end function allocate_data_buffer
!> Sets the flag saying that the math functions need to be done
subroutine set_math_needs_to_be_done (this, math_needs_to_be_done)
@@ -1270,16 +1218,45 @@ end subroutine write_coordinate_attribute
!> @brief Gets a fields data buffer
!! @return a pointer to the data buffer
function get_data_buffer (this) &
-result(rslt)
+ result(rslt)
class (fmsDiagField_type), target, intent(in) :: this !< diag field
class(*),dimension(:,:,:,:), pointer :: rslt !< The field's data buffer
- if (allocated(this%data_buffer)) then
- rslt => this%data_buffer
- else
- rslt => null()
- endif
+ if (.not. this%data_buffer_is_allocated) &
+ call mpp_error(FATAL, "The input data buffer for the field:"&
+ //trim(this%varname)//" was never allocated.")
+
+ rslt => this%input_data_buffer%get_buffer()
end function get_data_buffer
+
+!> @brief Gets a fields mask buffer
+!! @return a pointer to the mask buffer
+function get_mask (this) &
+ result(rslt)
+ class (fmsDiagField_type), target, intent(in) :: this !< diag field
+ logical, dimension(:,:,:,:), pointer :: rslt
+
+ if (.not. this%data_buffer_is_allocated) &
+ call mpp_error(FATAL, "The input data buffer for the field:"&
+ //trim(this%varname)//" was never allocated.")
+
+ rslt => this%input_data_buffer%get_mask()
+end function get_mask
+
+!> @brief Gets a fields weight buffer
+!! @return a pointer to the weight buffer
+function get_weight (this) &
+ result(rslt)
+ class (fmsDiagField_type), target, intent(in) :: this !< diag field
+ type(real(kind=r8_kind)), pointer :: rslt
+
+ if (.not. this%data_buffer_is_allocated) &
+ call mpp_error(FATAL, "The input data buffer for the field:"&
+ //trim(this%varname)//" was never allocated.")
+
+ rslt => this%input_data_buffer%get_weight()
+end function get_weight
+
!> Gets the flag telling if the math functions need to be done
!! \return Copy of math_needs_to_be_done flag
pure logical function get_math_needs_to_be_done(this)
@@ -1442,12 +1419,14 @@ pure logical function has_data_RANGE (this)
class (fmsDiagField_type), intent(in) :: this !< diag object
has_data_RANGE = allocated(this%data_RANGE)
end function has_data_RANGE
-!> @brief Checks if obj%data_buffer is allocated
-!! @return true if obj%data_buffer is allocated
-pure logical function has_data_buffer (this)
+
+!> @brief Checks if obj%input_data_buffer is allocated
+!! @return true if obj%input_data_buffer is allocated
+pure logical function has_input_data_buffer (this)
class (fmsDiagField_type), intent(in) :: this !< diag object
- has_data_buffer = allocated(this%data_buffer)
-end function has_data_buffer
+ has_input_data_buffer = allocated(this%input_data_buffer)
+end function has_input_data_buffer
+
!> @brief Add a attribute to the diag_obj using the diag_field_id
subroutine diag_field_add_attribute(this, att_name, att_value)
class (fmsDiagField_type), intent (inout) :: this !< The field object
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index b33b9d0431..687f609252 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -67,10 +67,7 @@ module fms_diag_file_object_mod
TYPE(time_type) :: next_output !< Time of the next write
TYPE(time_type) :: next_next_output !< Time of the next next write
TYPE(time_type) :: no_more_data !< Time to stop receiving data for this file
- logical :: done_writing_data!< Set to .True. if finished writing data
- !! This is be initialized to .false. and set to true for
- !! static files after the first write and for
- !! files that are using the file_duration functionality
+ logical :: done_writing_data!< .True. if finished writing data
!< This will be used when using the new_file_freq keys in the diag_table.yaml
TYPE(time_type) :: next_close !< Time to close the file
diff --git a/diag_manager/fms_diag_input_buffer.F90 b/diag_manager/fms_diag_input_buffer.F90
new file mode 100644
index 0000000000..1428a229c7
--- /dev/null
+++ b/diag_manager/fms_diag_input_buffer.F90
@@ -0,0 +1,206 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @defgroup fms_diag_input_buffer_mod fms_diag_input_buffer_mod
+!> @ingroup diag_manager
+!! @brief
+!> @addtogroup fms_diag_input_buffer_mod
+!> @{
+module fms_diag_input_buffer_mod
+#ifdef use_yaml
+ use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind
+ use fms_diag_axis_object_mod, only: fmsDiagAxisContainer_type, fmsDiagFullAxis_type
+ implicit NONE
+ private
+
+ !> @brief Type to hold the information needed for the input buffer
+ !! This is used when set_math_needs_to_be_done = .true. (i.e calling send_data
+ !! from an openmp region with multiple threads)
+ type fmsDiagInputBuffer_t
+ logical :: initialized !< .True. if the input buffer has been initialized
+ class(*), allocatable :: buffer(:,:,:,:) !< Input data passed in send_data
+ logical, allocatable :: mask(:,:,:,:) !< Mask passed in send_data
+ real(kind=r8_kind) :: weight !< Weight passed in send_data
+
+ contains
+ procedure :: get_buffer
+ procedure :: get_mask
+ procedure :: get_weight
+ procedure :: init => init_input_buffer_object
+ procedure :: set_input_buffer_object
+ procedure :: is_initialized
+ end type fmsDiagInputBuffer_t
+
+ public :: fmsDiagInputBuffer_t
+
+ contains
+
+ !> @brief Get the buffer from the input buffer object
+ !! @return a pointer to the buffer
+ function get_buffer(this) &
+ result(buffer)
+ class(fmsDiagInputBuffer_t), target, intent(in) :: this !< input buffer object
+ class(*), pointer :: buffer(:,:,:,:)
+
+ buffer => this%buffer
+ end function get_buffer
+
+ !> @brief Get the mask from the input buffer object
+ !! @return a pointer to the mask
+ function get_mask(this) &
+ result(mask)
+ class(fmsDiagInputBuffer_t), target, intent(in) :: this !< input buffer object
+ logical, pointer :: mask(:,:,:,:)
+
+ mask => this%mask
+ end function get_mask
+
+ !> @brief Get the weight from the input buffer object
+ !! @return a pointer to the weight
+ function get_weight(this) &
+ result(weight)
+ class(fmsDiagInputBuffer_t), target, intent(in) :: this !< input buffer object
+ real(kind=r8_kind), pointer :: weight
+
+ weight => this%weight
+ end function get_weight
+
+ !> @brief Initiliazes an input data buffer
+ !! @return Error message if something went wrong
+ function init_input_buffer_object(this, input_data, axis_ids, diag_axis) &
+ result(err_msg)
+ class(fmsDiagInputBuffer_t), intent(out) :: this !< input buffer object
+ class(*), intent(in) :: input_data(:,:,:,:) !< input data
+ integer, target, intent(in) :: axis_ids(:) !< axis ids for the field
+ class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Array of diag_axis
+ character(len=128) :: err_msg
+
+ integer :: naxes !< The number of axes in the field
+ integer, parameter :: ndims = 4 !< Number of dimensions
+ integer :: length(ndims) !< The length of an axis
+ integer :: a !< For looping through axes
+ integer, pointer :: axis_id !< The axis ID
+
+ err_msg = ""
+
+ !! Use the axis to get the size
+ !> Initialize the axis lengths to 1. Any dimension that does not have an axis will have a length
+ !! of 1.
+ length = 1
+ naxes = size(axis_ids)
+ axis_loop: do a = 1,naxes
+ axis_id => axis_ids(a)
+ select type (axis => diag_axis(axis_id)%axis)
+ type is (fmsDiagFullAxis_type)
+ length(a) = axis%axis_length()
+ end select
+ enddo axis_loop
+
+ allocate(this%mask(length(1), length(2), length(3), length(4)))
+ select type (input_data)
+ type is (real(r4_kind))
+ allocate(real(kind=r4_kind) :: this%buffer(length(1), length(2), length(3), length(4)))
+ type is (real(r8_kind))
+ allocate(real(kind=r8_kind) :: this%buffer(length(1), length(2), length(3), length(4)))
+ type is (integer(i4_kind))
+ allocate(integer(kind=i4_kind) :: this%buffer(length(1), length(2), length(3), length(4)))
+ type is (integer(i8_kind))
+ allocate(integer(kind=i4_kind) :: this%buffer(length(1), length(2), length(3), length(4)))
+ class default
+ err_msg = "The data input is not one of the supported types."&
+ "Only r4, r8, i4, and i8 types are supported."
+ end select
+
+ this%weight = 1.0_r8_kind
+ this%initialized = .true.
+ end function init_input_buffer_object
+
+ !> @brief Sets the members of the input buffer object
+ !! @return Error message if something went wrong
+ function set_input_buffer_object(this, input_data, weight, mask, is, js, ks, ie, je, ke) &
+ result(err_msg)
+
+ class(fmsDiagInputBuffer_t), intent(inout) :: this !< input buffer object
+ class(*), intent(in) :: input_data(:,:,:,:) !< Field data
+ real(kind=r8_kind), intent(in) :: weight !< Weight for the field
+ logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
+ integer, intent(in) :: is, js, ks !< Starting index for each of the dimension
+ integer, intent(in) :: ie, je, ke !< Ending index for each of the dimensions
+
+ character(len=128) :: err_msg
+ err_msg = ""
+
+ if (.not. this%initialized) then
+ err_msg = "The data buffer was never initiliazed. This shouldn't happen."
+ return
+ endif
+
+ this%mask(is:ie, js:je, ks:ke, :) = mask
+ this%weight = weight
+
+ select type (input_data)
+ type is (real(kind=r4_kind))
+ select type (db => this%buffer)
+ type is (real(kind=r4_kind))
+ db(is:ie, js:je, ks:ke, :) = input_data
+ class default
+ err_msg = "The data buffer was not allocated to the correct type (r4_kind). This shouldn't happen"
+ return
+ end select
+ type is (real(kind=r8_kind))
+ select type (db => this%buffer)
+ type is (real(kind=r8_kind))
+ db(is:ie, js:je, ks:ke, :) = input_data
+ class default
+ err_msg = "The data buffer was not allocated to the correct type (r8_kind). This shouldn't happen"
+ return
+ end select
+ type is (integer(kind=i4_kind))
+ select type (db => this%buffer)
+ type is (integer(kind=i4_kind))
+ db(is:ie, js:je, ks:ke, :) = input_data
+ class default
+ err_msg = "The data buffer was not allocated to the correct type (i4_kind). This shouldn't happen"
+ return
+ end select
+ type is (integer(kind=i8_kind))
+ select type (db => this%buffer)
+ type is (integer(kind=i8_kind))
+ db(is:ie, js:je, ks:ke, :) = input_data
+ class default
+ err_msg = "The data buffer was not allocated to the correct type (i8_kind). This shouldn't happen"
+ return
+ end select
+ end select
+ end function set_input_buffer_object
+
+ !> @brief Determine if an input buffer is initialized
+ !! @return .true. if the input buffer is initialized
+ pure logical function is_initialized(this)
+ class(fmsDiagInputBuffer_t), intent(in) :: this !< input buffer object
+
+ is_initialized = .false.
+ if (this%initialized) then
+ is_initialized = .true.
+ else
+ if (allocated(this%buffer)) is_initialized = .true.
+ endif
+ end function is_initialized
+#endif
+end module fms_diag_input_buffer_mod
+!> @}
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 0a3953a8bb..d846c97afa 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -602,8 +602,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.)
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.)
!$omp end critical
- !TODO Save the field_weight and the oor_mask to use later in the calculations
- call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data,&
+ call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, oor_mask, field_weight, &
is, js, ks, ie, je, ke)
fms_diag_accept_data = .TRUE.
return
@@ -643,6 +642,9 @@ subroutine fms_diag_send_complete(this, time_step)
logical :: math !< True if the math functions need to be called using the data buffer,
!! False if the math functions were done in accept_data
integer, dimension(:), allocatable :: file_field_ids !< Array of field IDs for a file
+ class(*), pointer :: input_data_buffer(:,:,:,:)
+ character(len=128) :: error_string
+ type(fmsDiagIbounds_type) :: bounds
!< Update the current model time by adding the time_step
this%current_model_time = this%current_model_time + time_step
@@ -662,8 +664,14 @@ subroutine fms_diag_send_complete(this, time_step)
!> Check if math needs to be done
math = diag_field%get_math_needs_to_be_done()
calling_math: if (math) then
- call this%allocate_diag_field_output_buffers(diag_field%get_data_buffer(), file_field_ids(ifield))
- !!TODO: call math functions !!
+ input_data_buffer => diag_field%get_data_buffer()
+ call bounds%reset_bounds_from_array_4D(input_data_buffer)
+ call this%allocate_diag_field_output_buffers(input_data_buffer, file_field_ids(ifield))
+ error_string = this%fms_diag_do_reduction(input_data_buffer, file_field_ids(ifield), &
+ diag_field%get_mask(), diag_field%get_weight(), &
+ bounds, .False., Time=this%current_model_time)
+ if (trim(error_string) .ne. "") call mpp_error(FATAL, "Field:"//trim(diag_field%get_varname()//&
+ " -"//trim(error_string)))
endif calling_math
!> Clean up, clean up, everybody everywhere
if (associated(diag_field)) nullify(diag_field)
diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90
index 3f85a043f0..5b57051065 100644
--- a/test_fms/diag_manager/test_reduction_methods.F90
+++ b/test_fms/diag_manager/test_reduction_methods.F90
@@ -228,6 +228,16 @@ program test_reduction_methods
mask=dlmask(:,:,:,1))
end select
case (test_openmp)
+ select case(mask_case)
+ case (no_mask)
+ used=send_data(id_var1, cdata(:, 1, 1, 1), time)
+ case (logical_mask)
+ used=send_data(id_var1, cdata(:, 1, 1, 1), time, &
+ mask=clmask(:, 1, 1, 1))
+ case (real_mask)
+ used=send_data(id_var1, cdata(:, 1, 1, 1), time, &
+ rmask=crmask(:, 1, 1, 1))
+ end select
!$OMP parallel do default(shared) private(iblock, isw, iew, jsw, jew, is1, ie1, js1, je1)
do iblock=1, 4
isw = my_block%ibs(iblock)
@@ -243,19 +253,14 @@ program test_reduction_methods
select case (mask_case)
case (no_mask)
- used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1)
used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1)
used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1)
case (real_mask)
- used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1, &
- rmask=crmask(is1:ie1, 1, 1, 1))
used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, &
rmask=crmask(is1:ie1, js1:je1, 1, 1))
used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, &
rmask=crmask(is1:ie1, js1:je1, :, 1))
case (logical_mask)
- used=send_data(id_var1, cdata(is1:ie1, 1, 1, 1), time, is_in=is1, ie_in=ie1, &
- mask=clmask(is1:ie1, 1, 1, 1))
used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, &
mask=clmask(is1:ie1, js1:je1, 1, 1))
used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, &
@@ -263,7 +268,6 @@ program test_reduction_methods
end select
enddo
end select
-
call diag_send_complete(Time_step)
enddo
diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh
index 7e2597ee87..e9e444c5fb 100755
--- a/test_fms/diag_manager/test_time_none.sh
+++ b/test_fms/diag_manager/test_time_none.sh
@@ -109,8 +109,7 @@ test_expect_success "Checking answers for the "none" reduction method, real mask
mpirun -n 1 ../check_time_none
'
-TODO this needs to be set back to 2, once the set_math_needs_to_be_done=.true. portion of the code is implemented
-export OMP_NUM_THREADS=1
+export OMP_NUM_THREADS=2
my_test_count=`expr $my_test_count + 1`
printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "none" reduction method with openmp (test $my_test_count)" '
From a89540e4a086f38ef734266674bd19d287b6356c Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 19 Sep 2023 12:57:48 -0400
Subject: [PATCH 127/168] feat: Modern_diag_manager add time_min/max reductions
(#1367)
---
diag_manager/fms_diag_field_object.F90 | 9 +
diag_manager/fms_diag_object.F90 | 24 ++-
diag_manager/fms_diag_output_buffer.F90 | 85 ++++++++-
diag_manager/fms_diag_reduction_methods.F90 | 14 +-
.../include/fms_diag_reduction_methods.inc | 161 +++++++++++++++++-
.../include/fms_diag_reduction_methods_r4.fh | 6 +
.../include/fms_diag_reduction_methods_r8.fh | 6 +
test_fms/diag_manager/check_time_max.F90 | 2 +-
test_fms/diag_manager/check_time_min.F90 | 2 +-
test_fms/diag_manager/test_time_max.sh | 89 +++++++---
test_fms/diag_manager/test_time_min.sh | 85 ++++++---
11 files changed, 415 insertions(+), 68 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 58b830d36c..1eb0221e94 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -96,6 +96,7 @@ module fms_diag_field_object_mod
procedure :: set_math_needs_to_be_done => set_math_needs_to_be_done
procedure :: add_attribute => diag_field_add_attribute
procedure :: vartype_inq => what_is_vartype
+ procedure :: set_mask_variant
! Check functions
procedure :: is_static => diag_obj_is_static
procedure :: is_scalar
@@ -436,6 +437,14 @@ subroutine set_math_needs_to_be_done (this, math_needs_to_be_done)
this%math_needs_to_be_done = math_needs_to_be_done
end subroutine set_math_needs_to_be_done
+!> @brief Set the mask_variant to .true.
+subroutine set_mask_variant(this, is_masked)
+ class (fmsDiagField_type) , intent(inout):: this !< The diag field object
+ logical, intent (in) :: is_masked !< .True. if the field is masked
+
+ this%mask_variant = is_masked
+end subroutine set_mask_variant
+
!> @brief Sets the flag saying that the data buffer is allocated
subroutine set_data_buffer_is_allocated (this, data_buffer_is_allocated)
class (fmsDiagField_type) , intent(inout) :: this !< The field object
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index d846c97afa..10c8514479 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -554,6 +554,9 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
if (.not. allocated(mask) .and. .not. allocated(rmask)) call mpp_error(FATAL, &
"The field was registered with mask_variant, but mask or rmask are not present in the send_data call. "//&
trim(field_info))
+ else
+ if (allocated(mask) .or. allocated(rmask)) &
+ call this%FMS_diag_fields(diag_field_id)%set_mask_variant(.True.)
endif
!< Check that mask and rmask are not both present
@@ -795,6 +798,14 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
call mpp_error(FATAl, "The missing value for the field:"//trim(field_ptr%get_varname())//&
&" was not allocated to the correct type. This shouldn't have happened")
end select
+ else
+ select type (missing_val => get_default_missing_value(r8))
+ type is (real(kind=r8_kind))
+ missing_value = missing_val
+ class default
+ call mpp_error(FATAl, "The missing value for the field:"//trim(field_ptr%get_varname())//&
+ &" was not allocated to the correct type. This shouldn't have happened")
+ end select
endif
buffer_loop: do ids = 1, size(field_ptr%buffer_ids)
@@ -870,12 +881,23 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
reduction_method = field_yaml_ptr%get_var_reduction()
select case(reduction_method)
case (time_none)
- error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, bounds_in, bounds_out, missing_value)
+ error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ bounds_in, bounds_out, missing_value)
if (trim(error_msg) .ne. "") then
return
endif
case (time_min)
+ error_msg = buffer_ptr%do_time_min_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ bounds_in, bounds_out, missing_value)
+ if (trim(error_msg) .ne. "") then
+ return
+ endif
case (time_max)
+ error_msg = buffer_ptr%do_time_max_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ bounds_in, bounds_out, missing_value)
+ if (trim(error_msg) .ne. "") then
+ return
+ endif
case (time_sum)
case (time_average)
case (time_power)
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 9a3ffdf469..b2c54f1387 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -34,7 +34,7 @@ module fms_diag_output_buffer_mod
use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t
use fms_diag_yaml_mod, only: diag_yaml
use fms_diag_bbox_mod, only: fmsDiagIbounds_type
-use fms_diag_reduction_methods_mod, only: do_time_none
+use fms_diag_reduction_methods_mod, only: do_time_none, do_time_min, do_time_max
use fms_diag_time_utils_mod, only: diag_time_inc
implicit none
@@ -76,6 +76,8 @@ module fms_diag_output_buffer_mod
procedure :: get_buffer
procedure :: flush_buffer
procedure :: do_time_none_wrapper
+ procedure :: do_time_min_wrapper
+ procedure :: do_time_max_wrapper
end type fmsDiagOutputBuffer_type
@@ -470,35 +472,104 @@ end subroutine write_buffer_wrapper_u
!> @brief Does the time_none reduction method on the buffer object
!! @return Error message if the math was not successful
-function do_time_none_wrapper(this, field_data, mask, bounds_in, bounds_out, missing_value) &
+function do_time_none_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) &
result(err_msg)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in
type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer
logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
+ logical, intent(in) :: is_masked !< .True. if the field has a mask
real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
character(len=50) :: err_msg
- !TODO This does not need to be done for every time step
!TODO This will be expanded for integers
err_msg = ""
select type (output_buffer => this%buffer)
type is (real(kind=r8_kind))
select type (field_data)
type is (real(kind=r8_kind))
- call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out, missing_value)
+ call do_time_none(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, missing_value)
class default
- err_msg="the output buffer and the buffer send in are not of the same type (r8_kind)"
+ err_msg="do_time_none_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)"
end select
type is (real(kind=r4_kind))
select type (field_data)
type is (real(kind=r4_kind))
- call do_time_none(output_buffer, field_data, mask, bounds_in, bounds_out, real(missing_value, kind=r4_kind))
+ call do_time_none(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, &
+ real(missing_value, kind=r4_kind))
class default
- err_msg="the output buffer and the buffer send in are not of the same type (r4_kind)"
+ err_msg="do_time_none_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)"
end select
end select
end function do_time_none_wrapper
+
+!> @brief Does the time_min reduction method on the buffer object
+!! @return Error message if the math was not successful
+function do_time_min_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) &
+ result(err_msg)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
+ class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
+ type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in
+ type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer
+ logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
+ logical, intent(in) :: is_masked !< .True. if the field has a mask
+ real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
+ character(len=50) :: err_msg
+
+ !TODO This will be expanded for integers
+ err_msg = ""
+ select type (output_buffer => this%buffer)
+ type is (real(kind=r8_kind))
+ select type (field_data)
+ type is (real(kind=r8_kind))
+ call do_time_min(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, missing_value)
+ class default
+ err_msg="do_time_min_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)"
+ end select
+ type is (real(kind=r4_kind))
+ select type (field_data)
+ type is (real(kind=r4_kind))
+ call do_time_min(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, &
+ real(missing_value, kind=r4_kind))
+ class default
+ err_msg="do_time_min_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)"
+ end select
+ end select
+end function do_time_min_wrapper
+
+!> @brief Does the time_min reduction method on the buffer object
+!! @return Error message if the math was not successful
+function do_time_max_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) &
+ result(err_msg)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
+ class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
+ type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in
+ type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer
+ logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
+ logical, intent(in) :: is_masked !< .True. if the field has a mask
+ real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
+ character(len=50) :: err_msg
+
+ !TODO This will be expanded for integers
+ err_msg = ""
+ select type (output_buffer => this%buffer)
+ type is (real(kind=r8_kind))
+ select type (field_data)
+ type is (real(kind=r8_kind))
+ call do_time_max(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, missing_value)
+ class default
+ err_msg="do_time_max_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)"
+ end select
+ type is (real(kind=r4_kind))
+ select type (field_data)
+ type is (real(kind=r4_kind))
+ call do_time_max(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, &
+ real(missing_value, kind=r4_kind))
+ class default
+ err_msg="do_time_max_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)"
+ end select
+ end select
+end function do_time_max_wrapper
#endif
end module fms_diag_output_buffer_mod
diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90
index fa4a7b9fcd..c48f9b21cd 100644
--- a/diag_manager/fms_diag_reduction_methods.F90
+++ b/diag_manager/fms_diag_reduction_methods.F90
@@ -35,7 +35,7 @@ module fms_diag_reduction_methods_mod
private
public :: check_indices_order, init_mask, set_weight
- public :: do_time_none
+ public :: do_time_none, do_time_min, do_time_max
!> @brief Does the time_none reduction method. See include/fms_diag_reduction_methods.inc
!TODO This needs to be extended to integers
@@ -43,6 +43,18 @@ module fms_diag_reduction_methods_mod
module procedure do_time_none_r4, do_time_none_r8
end interface do_time_none
+ !> @brief Does the time_min reduction method. See include/fms_diag_reduction_methods.inc
+ !TODO This needs to be extended to integers
+ interface do_time_min
+ module procedure do_time_min_r4, do_time_min_r8
+ end interface do_time_min
+
+ !> @brief Does the time_max reduction method. See include/fms_diag_reduction_methods.inc
+ !TODO This needs to be extended to integers
+ interface do_time_max
+ module procedure do_time_max_r4, do_time_max_r8
+ end interface do_time_max
+
contains
!> @brief Checks improper combinations of is, ie, js, and je.
diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc
index ddb6b8c926..72332d650e 100644
--- a/diag_manager/include/fms_diag_reduction_methods.inc
+++ b/diag_manager/include/fms_diag_reduction_methods.inc
@@ -18,10 +18,11 @@
!***********************************************************************
!> @brief Do the time_none reduction method (i.e copy the correct portion of the input data)
-subroutine DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out, missing_value)
+subroutine DO_TIME_NONE_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value)
real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
logical, intent(in) :: mask(:,:,:,:) !< mask
+ logical, intent(in) :: is_masked !< .True. if the field is using a mask
type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion
!! of the input buffer
type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion
@@ -47,11 +48,157 @@ subroutine DO_TIME_NONE_ (data_out, data_in, mask, bounds_in, bounds_out, missin
ks_in = bounds_in%get_kmin()
ke_in = bounds_in%get_kmax()
- where (mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :))
+ if (is_masked) then
+ where (mask(is_in:ie_in, js_in:je_in, ks_in:ke_in, :))
+ data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = &
+ data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)
+ elsewhere
+ data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = missing_value
+ end where
+ else
data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = &
- data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)
- elsewhere
- data_out(is_out:ie_out, js_out:je_out, ks_out:ke_out, :, 1) = missing_value
- end where
+ data_in(is_in:ie_in, js_in:je_in, ks_in:ke_in, :)
+ endif
-end subroutine DO_TIME_NONE_
\ No newline at end of file
+end subroutine DO_TIME_NONE_
+
+!> @brief Do the time_min reduction method (i.e maintain the minimum value of the averaging time)
+subroutine DO_TIME_MIN_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value)
+ real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
+ real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
+ logical, intent(in) :: mask(:,:,:,:) !< mask
+ logical, intent(in) :: is_masked !< .True. if the field is using a mask
+ type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion
+ !! of the input buffer
+ type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion
+ !! of the output buffer
+ real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked
+
+ integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for
+ !! the input buffer
+ integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for
+ !! the output buffer
+
+ integer :: i, j, k, l !< For looping
+
+ is_out = bounds_out%get_imin()
+ ie_out = bounds_out%get_imax()
+ js_out = bounds_out%get_jmin()
+ je_out = bounds_out%get_jmax()
+ ks_out = bounds_out%get_kmin()
+ ke_out = bounds_out%get_kmax()
+
+ is_in = bounds_in%get_imin()
+ ie_in = bounds_in%get_imax()
+ js_in = bounds_in%get_jmin()
+ je_in = bounds_in%get_jmax()
+ ks_in = bounds_in%get_kmin()
+ ke_in = bounds_in%get_kmax()
+
+ !> Seperated this loops for performance. If is_masked = .false. (i.e "mask" and "rmask" were never passed in)
+ !! then mask will always be .True. so the if (mask) is redudant.
+ if (is_masked) then
+ do l = 0, size(data_out, 4) - 1
+ do k = 0, ke_out - ks_out
+ do j = 0, je_out - js_out
+ do i = 0, ie_out - is_out
+ if (mask(is_in + i, js_in + j, ks_in + k, l + 1)) then
+ if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .gt. &
+ data_in(is_in + i, js_in + j, ks_in + k, l + 1) ) then
+ data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = &
+ data_in(is_in +i, js_in + j, ks_in + k, l + 1)
+ endif
+ else
+ data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = missing_value
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ else
+ do l = 0, size(data_out, 4) - 1
+ do k = 0, ke_out - ks_out
+ do j = 0, je_out - js_out
+ do i = 0, ie_out - is_out
+ if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .gt. &
+ data_in(is_in + i, js_in + j, ks_in + k, l + 1) ) then
+ data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = &
+ data_in(is_in +i, js_in + j, ks_in + k, l + 1)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+end subroutine DO_TIME_MIN_
+
+!> @brief Do the time_max reduction method (i.e maintain the maximum value of the averaging time)
+subroutine DO_TIME_MAX_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value)
+ real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
+ real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
+ logical, intent(in) :: mask(:,:,:,:) !< mask
+ logical, intent(in) :: is_masked !< .True. if the field is using a mask
+ type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion
+ !! of the input buffer
+ type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion
+ !! of the output buffer
+ real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked
+
+ integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for
+ !! the input buffer
+ integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for
+ !! the output buffer
+
+ integer :: i, j, k, l !< For looping
+
+ is_out = bounds_out%get_imin()
+ ie_out = bounds_out%get_imax()
+ js_out = bounds_out%get_jmin()
+ je_out = bounds_out%get_jmax()
+ ks_out = bounds_out%get_kmin()
+ ke_out = bounds_out%get_kmax()
+
+ is_in = bounds_in%get_imin()
+ ie_in = bounds_in%get_imax()
+ js_in = bounds_in%get_jmin()
+ je_in = bounds_in%get_jmax()
+ ks_in = bounds_in%get_kmin()
+ ke_in = bounds_in%get_kmax()
+
+ !> Seperated this loops for performance. If is_masked = .false. (i.e "mask" and "rmask" were never passed in)
+ !! then mask will always be .True. so the if (mask) is redudant.
+ if (is_masked) then
+ do l = 0, size(data_out, 4) - 1
+ do k = 0, ke_out - ks_out
+ do j = 0, je_out - js_out
+ do i = 0, ie_out - is_out
+ if (mask(is_in + i, js_in + j, ks_in + k, l + 1)) then
+ if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .lt. &
+ data_in(is_in + i, js_in + j, ks_in + k, l + 1) ) then
+ data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = &
+ data_in(is_in +i, js_in + j, ks_in + k, l + 1)
+ endif
+ else
+ data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = missing_value
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ else
+ do l = 0, size(data_out, 4) - 1
+ do k = 0, ke_out - ks_out
+ do j = 0, je_out - js_out
+ do i = 0, ie_out - is_out
+ if (data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) .lt. &
+ data_in(is_in + i, js_in + j, ks_in + k, l + 1) ) then
+ data_out(is_out + i, js_out + j, ks_out + k, l + 1, 1) = &
+ data_in(is_in +i, js_in + j, ks_in + k, l + 1)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+end subroutine DO_TIME_MAX_
\ No newline at end of file
diff --git a/diag_manager/include/fms_diag_reduction_methods_r4.fh b/diag_manager/include/fms_diag_reduction_methods_r4.fh
index 922972cce3..c3bc29296a 100644
--- a/diag_manager/include/fms_diag_reduction_methods_r4.fh
+++ b/diag_manager/include/fms_diag_reduction_methods_r4.fh
@@ -29,6 +29,12 @@
#undef DO_TIME_NONE_
#define DO_TIME_NONE_ do_time_none_r4
+#undef DO_TIME_MIN_
+#define DO_TIME_MIN_ do_time_min_r4
+
+#undef DO_TIME_MAX_
+#define DO_TIME_MAX_ do_time_max_r4
+
#include "fms_diag_reduction_methods.inc"
!> @}
diff --git a/diag_manager/include/fms_diag_reduction_methods_r8.fh b/diag_manager/include/fms_diag_reduction_methods_r8.fh
index 25c3031a22..a3e3d68376 100644
--- a/diag_manager/include/fms_diag_reduction_methods_r8.fh
+++ b/diag_manager/include/fms_diag_reduction_methods_r8.fh
@@ -29,6 +29,12 @@
#undef DO_TIME_NONE_
#define DO_TIME_NONE_ do_time_none_r8
+#undef DO_TIME_MIN_
+#define DO_TIME_MIN_ do_time_min_r8
+
+#undef DO_TIME_MAX_
+#define DO_TIME_MAX_ do_time_max_r8
+
#include "fms_diag_reduction_methods.inc"
!> @}
diff --git a/test_fms/diag_manager/check_time_max.F90 b/test_fms/diag_manager/check_time_max.F90
index e579bada4f..51e888541c 100644
--- a/test_fms/diag_manager/check_time_max.F90
+++ b/test_fms/diag_manager/check_time_max.F90
@@ -73,7 +73,7 @@ program check_time_max
do i = 1, 8
cdata_out = -999_r4_kind
print *, "Checking answers for var0_max - time_level:", string(i)
- call read_data(fileobj, "var0_max", cdata_out(1:1,1,1,1), unlim_dim_level=i) !eyeroll
+ call read_data(fileobj, "var0_max", cdata_out(1,1,1,1), unlim_dim_level=i)
call check_data_0d(cdata_out(1,1,1,1), i)
cdata_out = -999_r4_kind
diff --git a/test_fms/diag_manager/check_time_min.F90 b/test_fms/diag_manager/check_time_min.F90
index cb1406070c..e56e344144 100644
--- a/test_fms/diag_manager/check_time_min.F90
+++ b/test_fms/diag_manager/check_time_min.F90
@@ -73,7 +73,7 @@ program check_time_min
do i = 1, 8
cdata_out = -999_r4_kind
print *, "Checking answers for var0_min - time_level:", string(i)
- call read_data(fileobj, "var0_min", cdata_out(1:1,1,1,1), unlim_dim_level=i) !eyeroll
+ call read_data(fileobj, "var0_min", cdata_out(1,1,1,1), unlim_dim_level=i)
call check_data_0d(cdata_out(1,1,1,1), i)
cdata_out = -999_r4_kind
diff --git a/test_fms/diag_manager/test_time_max.sh b/test_fms/diag_manager/test_time_max.sh
index 5a35179b2f..b9a62b4d74 100755
--- a/test_fms/diag_manager/test_time_max.sh
+++ b/test_fms/diag_manager/test_time_max.sh
@@ -29,25 +29,62 @@ if [ -z "${skipflag}" ]; then
output_dir
#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true.
-cat <<_EOF > diag_table
-test_max
-2 1 1 0 0 0
-
-"test_max", 6, "hours", 1, "hours", "time"
-"test_max_regional", 6, "hours", 1, "hours", "time"
-
-"ocn_mod", "var0", "var0_max", "test_max", "all", "max", "none", 2
-"ocn_mod", "var1", "var1_max", "test_max", "all", "max", "none", 2
-"ocn_mod", "var2", "var2_max", "test_max", "all", "max", "none", 2
-"ocn_mod", "var3", "var3_max", "test_max", "all", "max", "none", 2
-
-"ocn_mod", "var3", "var3_Z", "test_max", "all", "max", "-1 -1 -1 -1 2. 3.", 2
-
-"ocn_mod", "var3", "var3_max", "test_max_regional", "all", "max", "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL
+cat <<_EOF > diag_table.yaml
+title: test_max
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_max
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var0
+ output_name: var0_max
+ reduction: max
+ kind: r4
+ - module: ocn_mod
+ var_name: var1
+ output_name: var1_max
+ reduction: max
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ output_name: var2_max
+ reduction: max
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_max
+ reduction: max
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_Z_max
+ reduction: max
+ zbounds: 2. 3.
+ kind: r4
+- file_name: test_max_regional
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: latlon
+ corner1: 78. 78.
+ corner2: 78. 78.
+ corner3: 81. 81.
+ corner4: 81. 81.
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_max
+ reduction: max
+ zbounds: 2. 3.
+ kind: r4
_EOF
my_test_count=1
-printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -56,7 +93,7 @@ test_expect_success "Checking answers for the "max" reduction method (test $my_t
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method, logical mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -65,7 +102,7 @@ test_expect_success "Checking answers for the "max" reduction method, logical ma
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method, real mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -73,9 +110,9 @@ test_expect_success "Checking answers for the "max" reduction method, real mask
mpirun -n 1 ../check_time_max
'
-export OMP_NUM_THREADS=2
+export OMP_NUM_THREADS=1
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method with openmp (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -84,7 +121,7 @@ test_expect_success "Checking answers for the "max" reduction method with openmp
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method with openmp, logical mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -93,17 +130,17 @@ test_expect_success "Checking answers for the "max" reduction method with openmp
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method with openmp, real mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
test_expect_success "Checking answers for the "max" reduction method with openmp, real mask (test $my_test_count)" '
mpirun -n 1 ../check_time_max
'
-export OMP_NUM_THREADS=1
+export OMP_NUM_THREADS=2
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method with halo output (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -112,7 +149,7 @@ test_expect_success "Checking answers for the "max" reduction method with halo o
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method with halo output with logical mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -121,7 +158,7 @@ test_expect_success "Checking answers for the "max" reduction method with halo o
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method with halo output with real mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
diff --git a/test_fms/diag_manager/test_time_min.sh b/test_fms/diag_manager/test_time_min.sh
index 7049dc6abb..f0305d15a0 100755
--- a/test_fms/diag_manager/test_time_min.sh
+++ b/test_fms/diag_manager/test_time_min.sh
@@ -29,25 +29,62 @@ if [ -z "${skipflag}" ]; then
output_dir
#TODO replace with yaml diag_table and set diag_manager_nml::use_modern_diag=.true.
-cat <<_EOF > diag_table
-test_min
-2 1 1 0 0 0
-
-"test_min", 6, "hours", 1, "hours", "time"
-"test_min_regional", 6, "hours", 1, "hours", "time"
-
-"ocn_mod", "var0", "var0_min", "test_min", "all", "min", "none", 2
-"ocn_mod", "var1", "var1_min", "test_min", "all", "min", "none", 2
-"ocn_mod", "var2", "var2_min", "test_min", "all", "min", "none", 2
-"ocn_mod", "var3", "var3_min", "test_min", "all", "min", "none", 2
-
-"ocn_mod", "var3", "var3_Z", "test_min", "all", "min", "-1 -1 -1 -1 2. 3.", 2
-
-"ocn_mod", "var3", "var3_min", "test_min_regional", "all", "min", "78. 81. 78. 81. 2. 3.", 2 #chosen by MKL
+cat <<_EOF > diag_table.yaml
+title: test_min
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_min
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var0
+ output_name: var0_min
+ reduction: min
+ kind: r4
+ - module: ocn_mod
+ var_name: var1
+ output_name: var1_min
+ reduction: min
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ output_name: var2_min
+ reduction: min
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_min
+ reduction: min
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_Z_min
+ reduction: min
+ zbounds: 2. 3.
+ kind: r4
+- file_name: test_min_regional
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: latlon
+ corner1: 78. 78.
+ corner2: 78. 78.
+ corner3: 81. 81.
+ corner4: 81. 81.
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_min
+ reduction: min
+ zbounds: 2. 3.
+ kind: r4
_EOF
my_test_count=1
-printf "&test_reduction_methods_nml \n test_case = 0 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml
test_expect_success "Running diag_manager with "min" reduction method (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -56,7 +93,7 @@ test_expect_success "Checking answers for the "min" reduction method (test $my_t
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "min" reduction method, logical mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -65,7 +102,7 @@ test_expect_success "Checking answers for the "min" reduction method, logical ma
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "min" reduction method, real mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -75,7 +112,7 @@ test_expect_success "Checking answers for the "min" reduction method, real mask
export OMP_NUM_THREADS=2
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "min" reduction method with openmp (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -84,7 +121,7 @@ test_expect_success "Checking answers for the "min" reduction method with openmp
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "min" reduction method with openmp, logical mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -93,7 +130,7 @@ test_expect_success "Checking answers for the "min" reduction method with openmp
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "min" reduction method with openmp, real mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -103,7 +140,7 @@ test_expect_success "Checking answers for the "min" reduction method with openmp
export OMP_NUM_THREADS=1
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "min" reduction method with halo output (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -112,7 +149,7 @@ test_expect_success "Checking answers for the "min" reduction method with halo o
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "min" reduction method with halo output with logical mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
@@ -121,7 +158,7 @@ test_expect_success "Checking answers for the "min" reduction method with halo o
'
my_test_count=`expr $my_test_count + 1`
-printf "&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "min" reduction method with halo output with real mask (test $my_test_count)" '
mpirun -n 6 ../test_reduction_methods
'
From 3335b7dd5e9bb69e889e9a93f3d65b18defb17f1 Mon Sep 17 00:00:00 2001
From: Caitlyn McAllister <65364559+mcallic2@users.noreply.github.com>
Date: Wed, 27 Sep 2023 13:01:01 -0400
Subject: [PATCH 128/168] feat: changes `fileobj` to `yaml_fileobj` (#1334)
---
diag_manager/fms_diag_yaml.F90 | 58 ++++++++++++++++++----------------
1 file changed, 30 insertions(+), 28 deletions(-)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 723fbf2b17..d7229840b7 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -489,10 +489,10 @@ subroutine diag_yaml_object_end()
end subroutine diag_yaml_object_end
!> @brief Fills in a diagYamlFiles_type with the contents of a file block in diag_table.yaml
-subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
+subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, yaml_fileobj)
integer, intent(in) :: diag_yaml_id !< Id of the diag_table.yaml
integer, intent(in) :: diag_file_id !< Id of the file block to read
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to read the contents into
+ type(diagYamlFiles_type), intent(inout) :: yaml_fileobj !< diagYamlFiles_type obj to read the contents into
integer :: nsubregion !< Flag indicating of there any regions (0 or 1)
integer :: sub_region_id(1) !< Id of the sub_region block
@@ -505,28 +505,29 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
character(len=:), ALLOCATABLE :: grid_type !< grid_type as it is read in from the yaml
character(len=:), ALLOCATABLE :: buffer !< buffer to store any *_units as it is read from the yaml
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", yaml_fileobj%file_fname)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq", buffer)
- call parse_key(fileobj%file_fname, buffer, fileobj%file_freq, fileobj%file_frequnit, "freq")
+ call parse_key(yaml_fileobj%file_fname, buffer, yaml_fileobj%file_freq, yaml_fileobj%file_frequnit, "freq")
deallocate(buffer)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", fileobj%file_unlimdim)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "unlimdim", yaml_fileobj%file_unlimdim)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "time_units", buffer)
- call set_file_time_units(fileobj, buffer)
+ call set_file_time_units(yaml_fileobj, buffer)
deallocate(buffer)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "new_file_freq", buffer, is_optional=.true.)
- call parse_key(fileobj%file_fname, buffer, fileobj%file_new_file_freq, fileobj%file_new_file_freq_units, &
- "new_file_freq")
+ call parse_key(yaml_fileobj%file_fname, buffer, yaml_fileobj%file_new_file_freq, &
+ yaml_fileobj%file_new_file_freq_units, "new_file_freq")
deallocate(buffer)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "filename_time", buffer, is_optional=.true.)
- call set_filename_time(fileobj, buffer)
+ call set_filename_time(yaml_fileobj, buffer)
deallocate(buffer)
- call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", fileobj%file_start_time, is_optional=.true.)
+ call diag_get_value_from_key(diag_yaml_id, diag_file_id, "start_time", &
+ yaml_fileobj%file_start_time, is_optional=.true.)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_duration", buffer, is_optional=.true.)
- call parse_key(fileobj%file_fname, buffer, fileobj%file_duration, fileobj%file_duration_units, &
+ call parse_key(yaml_fileobj%file_fname, buffer, yaml_fileobj%file_duration, yaml_fileobj%file_duration_units, &
"file_duration")
nsubregion = 0
@@ -534,11 +535,12 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
if (nsubregion .eq. 1) then
call get_block_ids(diag_yaml_id, "sub_region", sub_region_id, parent_block_id=diag_file_id)
call diag_get_value_from_key(diag_yaml_id, sub_region_id(1), "grid_type", grid_type)
- call get_sub_region(diag_yaml_id, sub_region_id(1), fileobj%file_sub_region, grid_type, fileobj%file_fname)
+ call get_sub_region(diag_yaml_id, sub_region_id(1), yaml_fileobj%file_sub_region, grid_type, &
+ yaml_fileobj%file_fname)
elseif (nsubregion .eq. 0) then
- fileobj%file_sub_region%grid_type = null_gridtype
+ yaml_fileobj%file_sub_region%grid_type = null_gridtype
else
- call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//" has multiple region blocks")
+ call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(yaml_fileobj%file_fname)//" has multiple region blocks")
endif
natt = 0
@@ -549,14 +551,14 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj)
allocate(key_ids(nkeys))
call get_key_ids(diag_yaml_id, global_att_id(1), key_ids)
- allocate(fileobj%file_global_meta(nkeys, 2))
+ allocate(yaml_fileobj%file_global_meta(nkeys, 2))
do j = 1, nkeys
- call get_key_name(diag_yaml_id, key_ids(j), fileobj%file_global_meta(j, 1))
- call get_key_value(diag_yaml_id, key_ids(j), fileobj%file_global_meta(j, 2))
+ call get_key_name(diag_yaml_id, key_ids(j), yaml_fileobj%file_global_meta(j, 1))
+ call get_key_value(diag_yaml_id, key_ids(j), yaml_fileobj%file_global_meta(j, 2))
enddo
deallocate(key_ids)
elseif (natt .ne. 0) then
- call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(fileobj%file_fname)//&
+ call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(yaml_fileobj%file_fname)//&
&" has multiple global_meta blocks")
endif
@@ -753,31 +755,31 @@ subroutine parse_key(filename, buffer, file_freq, file_frequnit, var)
end subroutine parse_key
!> @brief This checks if the time unit in a diag file is valid and sets the integer equivalent
-subroutine set_file_time_units (fileobj, file_timeunit)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to checK
+subroutine set_file_time_units (yaml_fileobj, file_timeunit)
+ type(diagYamlFiles_type), intent(inout) :: yaml_fileobj !< diagYamlFiles_type obj to checK
character(len=*), intent(in) :: file_timeunit !< file_timeunit as it is read from the diag_table
- fileobj%file_timeunit = set_valid_time_units(file_timeunit, "timeunit for file:"//trim(fileobj%file_fname))
+ yaml_fileobj%file_timeunit = set_valid_time_units(file_timeunit, "timeunit for file:"//trim(yaml_fileobj%file_fname))
end subroutine set_file_time_units
!> @brief This checks if the filename_time in a diag file is correct and sets the integer equivalent
-subroutine set_filename_time(fileobj, filename_time)
- type(diagYamlFiles_type), intent(inout) :: fileobj !< diagYamlFiles_type obj to check
+subroutine set_filename_time(yaml_fileobj, filename_time)
+ type(diagYamlFiles_type), intent(inout) :: yaml_fileobj !< diagYamlFiles_type obj to check
character(len=*), intent(in) :: filename_time !< filename_time as it is read from the yaml
select case (trim(filename_time))
case ("")
- fileobj%filename_time = middle_time !< This is the default
+ yaml_fileobj%filename_time = middle_time !< This is the default
case ("begin")
- fileobj%filename_time = begin_time
+ yaml_fileobj%filename_time = begin_time
case ("middle")
- fileobj%filename_time = middle_time
+ yaml_fileobj%filename_time = middle_time
case ("end")
- fileobj%filename_time = end_time
+ yaml_fileobj%filename_time = end_time
case default
call mpp_error(FATAL, trim(filename_time)//" is an invalid filename_time &
&The acceptable values are begin, middle, and end. &
- &Check your entry for file "//trim(fileobj%file_fname))
+ &Check your entry for file "//trim(yaml_fileobj%file_fname))
end select
end subroutine set_filename_time
From 911edb07580a6a4cd1e53e2fe553d47a8e444edc Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Wed, 11 Oct 2023 12:15:17 -0400
Subject: [PATCH 129/168] feat: modern diag add time_sum reduction (#1375)
---
diag_manager/diag_data.F90 | 12 +-
diag_manager/diag_manager.F90 | 61 +++-
diag_manager/fms_diag_object.F90 | 7 +-
diag_manager/fms_diag_output_buffer.F90 | 71 +++--
diag_manager/fms_diag_reduction_methods.F90 | 9 +-
.../include/fms_diag_reduction_methods.inc | 97 ++++++-
.../include/fms_diag_reduction_methods_r4.fh | 3 +
.../include/fms_diag_reduction_methods_r8.fh | 3 +
test_fms/diag_manager/Makefile.am | 8 +-
test_fms/diag_manager/check_time_sum.F90 | 264 ++++++++++++++++++
test_fms/diag_manager/test_time_sum.sh | 166 +++++++++++
11 files changed, 655 insertions(+), 46 deletions(-)
create mode 100644 test_fms/diag_manager/check_time_sum.F90
create mode 100755 test_fms/diag_manager/test_time_sum.sh
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 4e8b774afc..c601c877a9 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -107,7 +107,7 @@ MODULE diag_data_mod
!! to indicate to use the full axis instead of a sub-axis
INTEGER, PARAMETER :: GLO_REG_VAL_ALT = -1 !< Alternate value used in the region specification of the
!! diag_table to indicate to use the full axis instead of a sub-axis
- REAL, PARAMETER :: CMOR_MISSING_VALUE = 1.0e20 !< CMOR standard missing value
+ REAL(r8_kind), PARAMETER :: CMOR_MISSING_VALUE = 1.0e20 !< CMOR standard missing value
INTEGER, PARAMETER :: DIAG_FIELD_NOT_FOUND = -1 !< Return value for a diag_field that isn't found in the diag_table
INTEGER, PARAMETER :: latlon_gridtype = 1
INTEGER, PARAMETER :: index_gridtype = 2
@@ -390,9 +390,13 @@ MODULE diag_data_mod
!! the default behavior will do the average between day1 hour3 to day2 hour3
!
- REAL :: FILL_VALUE = NF_FILL_REAL !< Fill value used. Value will be NF90_FILL_REAL if using the
+#ifdef use_netCDF
+ REAL(r8_kind) :: FILL_VALUE = NF_FILL_REAL !< Fill value used. Value will be NF90_FILL_REAL if using the
!! netCDF module, otherwise will be 9.9692099683868690e+36.
! from file /usr/local/include/netcdf.inc
+#else
+ REAL(r8_kind) :: FILL_VALUE = 9.9692099683868690e+36
+#endif
!! @note `pack_size` and `pack_size_str` are set in diag_manager_init depending on how FMS was compiled
!! if FMS was compiled with default reals as 64bit, it will be set to 1 and "double",
@@ -405,8 +409,8 @@ MODULE diag_data_mod
!! set to "double" or "float"
!
- REAL :: EMPTY = 0.0
- REAL :: MAX_VALUE, MIN_VALUE
+ REAL(r8_kind) :: EMPTY = 0.0
+ REAL(r8_kind) :: MAX_VALUE, MIN_VALUE
!
TYPE(time_type) :: diag_init_time !< Time diag_manager_init called. If init_time not included in
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index c1bf80dd1a..5b5357b514 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -1443,7 +1443,7 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg)
TYPE(time_type), INTENT(in), OPTIONAL :: time
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
- REAL :: field_out(1, 1, 1) !< Local copy of field
+ CLASS(*), allocatable :: field_out(:, :, :) !< Local copy of field
! If diag_field_id is < 0 it means that this field is not registered, simply return
IF ( diag_field_id <= 0 ) THEN
@@ -1454,9 +1454,23 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg)
! First copy the data to a three d array with last element 1
SELECT TYPE (field)
TYPE IS (real(kind=r4_kind))
- field_out(1, 1, 1) = field
+ allocate(real(r4_kind) :: field_out(1,1,1))
+ select type(field_out)
+ type is (real(r4_kind))
+ field_out(1, 1, 1) = field
+ class default
+ call error_mesg('diag_manager_mod::send_data_0d', &
+ & 'Error allocating field out as real(r4_kind)', FATAL)
+ end select
TYPE IS (real(kind=r8_kind))
- field_out(1, 1, 1) = real(field)
+ allocate(real(r8_kind) :: field_out(1,1,1))
+ select type(field_out)
+ type is (real(r8_kind))
+ field_out(1, 1, 1) = field
+ class default
+ call error_mesg('diag_manager_mod::send_data_0d', &
+ & 'Error allocating field out as real(r8_kind)', FATAL)
+ end select
CLASS DEFAULT
CALL error_mesg ('diag_manager_mod::send_data_0d',&
& 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
@@ -1476,7 +1490,7 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie
LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
- REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out !< Local copy of field
+ CLASS(*), ALLOCATABLE :: field_out(:,:,:) !< Local copy of field
LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out !< Local copy of mask
! If diag_field_id is < 0 it means that this field is not registered, simply return
@@ -1486,11 +1500,26 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie
END IF
! First copy the data to a three d array with last element 1
+ ! type checking done in diag_send_data
SELECT TYPE (field)
TYPE IS (real(kind=r4_kind))
- field_out(:, 1, 1) = field
+ allocate(real(r4_kind) :: field_out(SIZE(field),1,1))
+ select type(field_out)
+ type is (real(r4_kind))
+ field_out(:, 1, 1) = field
+ class default
+ call error_mesg('diag_manager_mod::send_data_1d', &
+ & 'Error allocating field out as real(r4_kind)', FATAL)
+ end select
TYPE IS (real(kind=r8_kind))
- field_out(:, 1, 1) = real(field)
+ allocate(real(r8_kind) :: field_out(SIZE(field),1,1))
+ select type(field_out)
+ type is (real(r8_kind))
+ field_out(:, 1, 1) = field
+ class default
+ call error_mesg('diag_manager_mod::send_data_1d', &
+ & 'Error allocating field out as real(r8_kind)', FATAL)
+ end select
CLASS DEFAULT
CALL error_mesg ('diag_manager_mod::send_data_1d',&
& 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
@@ -1545,7 +1574,7 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, &
CLASS(*), INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
- REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out !< Local copy of field
+ CLASS(*), ALLOCATABLE :: field_out(:,:,:) !< Local copy of field
LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out !< Local copy of mask
! If diag_field_id is < 0 it means that this field is not registered, simply return
@@ -1557,9 +1586,23 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, &
! First copy the data to a three d array with last element 1
SELECT TYPE (field)
TYPE IS (real(kind=r4_kind))
- field_out(:, :, 1) = field
+ allocate(real(r4_kind) :: field_out(SIZE(field,1),SIZE(field,2),1))
+ select type(field_out)
+ type is (real(r4_kind))
+ field_out(:, :, 1) = field
+ class default
+ call error_mesg('diag_manager_mod::send_data_2d', &
+ & 'Error allocating field out as real(r4_kind)', FATAL)
+ end select
TYPE IS (real(kind=r8_kind))
- field_out(:, :, 1) = real(field)
+ allocate(real(r8_kind) :: field_out(SIZE(field,1),SIZE(field,2),1))
+ select type(field_out)
+ type is (real(r8_kind))
+ field_out(:, :, 1) = field
+ class default
+ call error_mesg('diag_manager_mod::send_data_2d', &
+ & 'Error allocating field out as real(r8_kind)', FATAL)
+ end select
CLASS DEFAULT
CALL error_mesg ('diag_manager_mod::send_data_2d',&
& 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 10c8514479..894d8023d8 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -517,7 +517,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
!! the calculationslater. \note This is experimental
character(len=128) :: error_string !< Store error text
logical :: data_buffer_is_allocated !< .true. if the data buffer is allocated
- character(len=128) :: field_info !< String holding info about the field to append to the
+ character(len=256) :: field_info !< String holding info about the field to append to the
!! error message
logical, allocatable, dimension(:,:,:,:) :: oor_mask !< Out of range mask
real(kind=r8_kind) :: field_weight !< Weight to use when averaging (it will be converted
@@ -899,6 +899,11 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
return
endif
case (time_sum)
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ bounds_in, bounds_out, missing_value)
+ if (trim(error_msg) .ne. "") then
+ return
+ endif
case (time_average)
case (time_power)
case (time_rms)
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index b2c54f1387..b8da2b3a62 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -34,7 +34,7 @@ module fms_diag_output_buffer_mod
use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t
use fms_diag_yaml_mod, only: diag_yaml
use fms_diag_bbox_mod, only: fmsDiagIbounds_type
-use fms_diag_reduction_methods_mod, only: do_time_none, do_time_min, do_time_max
+use fms_diag_reduction_methods_mod, only: do_time_none, do_time_min, do_time_max, do_time_sum_update
use fms_diag_time_utils_mod, only: diag_time_inc
implicit none
@@ -48,10 +48,8 @@ module fms_diag_output_buffer_mod
class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array
integer :: ndim !< Number of dimensions for each variable
integer, allocatable :: buffer_dims(:) !< holds the size of each dimension in the buffer
- real(r8_kind), allocatable :: counter(:,:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions
+ real(r8_kind) :: weight_sum !< (x,y,z, time-of-day) used in the time averaging functions
integer, allocatable :: num_elements(:) !< used in time-averaging
- real(r8_kind), allocatable :: count_0d(:) !< used in time-averaging along with
- !! counter which is stored in the child types (bufferNd)
integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
integer :: field_id !< The id of the field the buffer belongs to
integer :: yaml_id !< The id of the yaml id the buffer belongs to
@@ -78,6 +76,7 @@ module fms_diag_output_buffer_mod
procedure :: do_time_none_wrapper
procedure :: do_time_min_wrapper
procedure :: do_time_max_wrapper
+ procedure :: do_time_sum_wrapper
end type fmsDiagOutputBuffer_type
@@ -124,9 +123,7 @@ subroutine flush_buffer(this)
this%yaml_id = diag_null
if (allocated(this%buffer)) deallocate(this%buffer)
if (allocated(this%buffer_dims)) deallocate(this%buffer_dims)
- if (allocated(this%counter)) deallocate(this%counter)
if (allocated(this%num_elements)) deallocate(this%num_elements)
- if (allocated(this%count_0d)) deallocate(this%count_0d)
if (allocated(this%axis_ids)) deallocate(this%axis_ids)
end subroutine flush_buffer
@@ -154,38 +151,22 @@ subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurna
type is (integer(kind=i4_kind))
allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(this%count_0d(n_samples))
- this%counter = 0.0_r4_kind
- this%count_0d = 0.0_r4_kind
+ this%weight_sum = 0.0_r4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(this%count_0d(n_samples))
- this%counter = 0.0_r8_kind
- this%count_0d = 0.0_r8_kind
+ this%weight_sum = 0.0_r8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(this%count_0d(n_samples))
- this%counter = 0.0_r4_kind
- this%count_0d = 0.0_r4_kind
+ this%weight_sum = 0.0_r4_kind
this%buffer_type = r4
type is (real(kind=r8_kind))
allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& buff_sizes(5)))
- allocate(this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
- allocate(this%count_0d(n_samples))
- this%counter = 0.0_r8_kind
- this%count_0d = 0.0_r8_kind
+ this%weight_sum = 0.0_r8_kind
this%buffer_type = r8
class default
call mpp_error("allocate_buffer", &
@@ -194,7 +175,6 @@ subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurna
end select
allocate(this%num_elements(n_samples))
this%num_elements = 0
- this%count_0d = 0
this%done_with_math = .false.
allocate(this%buffer_dims(5))
this%buffer_dims(1) = buff_sizes(1)
@@ -571,5 +551,42 @@ function do_time_max_wrapper(this, field_data, mask, is_masked, bounds_in, bound
end select
end select
end function do_time_max_wrapper
+
+!> @brief Does the time_sum reduction method on the buffer object
+!! @return Error message if the math was not successful
+function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) &
+ result(err_msg)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
+ class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
+ type(fmsDiagIbounds_type), intent(in) :: bounds_in !< Indicies for the buffer passed in
+ type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer
+ logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
+ logical, intent(in) :: is_masked !< .True. if the field has a mask
+ real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
+ character(len=50) :: err_msg
+
+ !TODO This will be expanded for integers
+ err_msg = ""
+ select type (output_buffer => this%buffer)
+ type is (real(kind=r8_kind))
+ select type (field_data)
+ type is (real(kind=r8_kind))
+ call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, &
+ bounds_in, bounds_out, missing_value)
+ class default
+ err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)"
+ end select
+ type is (real(kind=r4_kind))
+ select type (field_data)
+ type is (real(kind=r4_kind))
+ call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, bounds_in, bounds_out, &
+ real(missing_value, kind=r4_kind))
+ class default
+ err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)"
+ end select
+ class default
+ err_msg="do_time_sum_wrapper::the output buffer is not a valid type, must be real(r8_kind) or real(r4_kind)"
+ end select
+end function do_time_sum_wrapper
#endif
end module fms_diag_output_buffer_mod
diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90
index c48f9b21cd..c3d939b0f6 100644
--- a/diag_manager/fms_diag_reduction_methods.F90
+++ b/diag_manager/fms_diag_reduction_methods.F90
@@ -35,7 +35,7 @@ module fms_diag_reduction_methods_mod
private
public :: check_indices_order, init_mask, set_weight
- public :: do_time_none, do_time_min, do_time_max
+ public :: do_time_none, do_time_min, do_time_max, do_time_sum_update
!> @brief Does the time_none reduction method. See include/fms_diag_reduction_methods.inc
!TODO This needs to be extended to integers
@@ -55,6 +55,13 @@ module fms_diag_reduction_methods_mod
module procedure do_time_max_r4, do_time_max_r8
end interface do_time_max
+ !> @brief Sum update updates the buffer for any reductions that involve summation
+ !! (ie. time_sum, avg, rms, pow)
+ !!TODO This needs to be extended to integers
+ interface do_time_sum_update
+ module procedure do_time_sum_update_r4, do_time_sum_update_r8
+ end interface
+
contains
!> @brief Checks improper combinations of is, ie, js, and je.
diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc
index 72332d650e..c847817724 100644
--- a/diag_manager/include/fms_diag_reduction_methods.inc
+++ b/diag_manager/include/fms_diag_reduction_methods.inc
@@ -17,6 +17,11 @@
!* License along with FMS. If not, see .
!***********************************************************************
+! for any debug prints
+#ifndef DEBUG_REDUCT
+#define DEBUG_REDUCT .true.
+#endif
+
!> @brief Do the time_none reduction method (i.e copy the correct portion of the input data)
subroutine DO_TIME_NONE_ (data_out, data_in, mask, is_masked, bounds_in, bounds_out, missing_value)
real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
@@ -201,4 +206,94 @@ subroutine DO_TIME_MAX_ (data_out, data_in, mask, is_masked, bounds_in, bounds_o
enddo
enddo
endif
-end subroutine DO_TIME_MAX_
\ No newline at end of file
+end subroutine DO_TIME_MAX_
+
+!> Update the output buffer for reductions that involve summation (sum, avg, rms, pow).
+!! Elements of the running field output buffer (data_out) are set with the following:
+!!
+!! buffer(l) = buffer(l) + (weight * field(l)) ^ pow
+!!
+!! Where l are the indices passed in through the bounds_in/out
+subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, bounds_in, bounds_out, &
+ missing_value, weight, pow)
+ real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
+ real(r8_kind), intent(inout) :: weight_sum !< Sum of weights from the output buffer object
+ real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
+ logical, intent(in) :: mask(:,:,:,:) !< mask
+ logical, intent(in) :: is_masked !< .True. if the field is using a mask
+ type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion
+ !! of the input buffer
+ type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion
+ !! of the output buffer
+ real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked
+ real(r8_kind),optional, intent(in) :: weight !< Weight applied to data_in before added to data_out
+ !! used for weighted averages, default 1.0
+ real(FMS_TRM_KIND_),optional, intent(in) :: pow !< Used for pow reduction, adds field^pow to buffer
+
+ integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for
+ !! the input buffer
+ integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for
+ !! the output buffer
+ integer :: i, j, k, l !< For looping
+ real(FMS_TRM_KIND_) :: weight_loc, pow_loc !< local copies of optional arguments
+ integer, parameter :: kindl = FMS_TRM_KIND_ !< real kind size as set by macro
+
+ if(present(weight)) then
+ weight_loc = weight
+ else
+ weight_loc = 1.0_kindl
+ endif
+
+ if(present(pow)) then
+ pow_loc = weight
+ else
+ pow_loc = 1.0_kindl
+ endif
+
+ ! update with given weight for average before write
+ weight_sum = weight_sum + weight_loc
+
+ is_out = bounds_out%get_imin()
+ ie_out = bounds_out%get_imax()
+ js_out = bounds_out%get_jmin()
+ je_out = bounds_out%get_jmax()
+ ks_out = bounds_out%get_kmin()
+ ke_out = bounds_out%get_kmax()
+
+ is_in = bounds_in%get_imin()
+ ie_in = bounds_in%get_imax()
+ js_in = bounds_in%get_jmin()
+ je_in = bounds_in%get_jmax()
+ ks_in = bounds_in%get_kmin()
+ ke_in = bounds_in%get_kmax()
+
+ !> Seperated this loops for performance. If is_masked = .false. (i.e "mask" and "rmask" were never passed in)
+ !! then mask will always be .True. so the if (mask) is redudant.
+ ! TODO check if performance gain by not doing weight and pow if not needed
+ if (is_masked) then
+ do k = 0, ke_out - ks_out
+ do j = 0, je_out - js_out
+ do i = 0, ie_out - is_out
+ where (mask(is_in + i, js_in + j, ks_in + k, :))
+ data_out(is_out + i, js_out + j, ks_out + k, :, 1) = &
+ data_out(is_out + i, js_out + j, ks_out + k, :, 1) &
+ + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_loc) ** pow_loc
+ elsewhere
+ data_out(is_out + i, js_out + j, ks_out + k, :, 1) = missing_value
+ endwhere
+ enddo
+ enddo
+ enddo
+ else
+ ! doesn't need to loop through l if no mask, just sums the 1d slices
+ do k = 0, ke_out - ks_out
+ do j = 0, je_out - js_out
+ do i = 0, ie_out - is_out
+ data_out(is_out + i, js_out + j, ks_out + k, :, 1) = &
+ data_out(is_out + i, js_out + j, ks_out + k, :, 1) &
+ + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_loc) ** pow_loc
+ enddo
+ enddo
+ enddo
+ endif
+end subroutine DO_TIME_SUM_UPDATE_
diff --git a/diag_manager/include/fms_diag_reduction_methods_r4.fh b/diag_manager/include/fms_diag_reduction_methods_r4.fh
index c3bc29296a..a3c499b12e 100644
--- a/diag_manager/include/fms_diag_reduction_methods_r4.fh
+++ b/diag_manager/include/fms_diag_reduction_methods_r4.fh
@@ -35,6 +35,9 @@
#undef DO_TIME_MAX_
#define DO_TIME_MAX_ do_time_max_r4
+#undef DO_TIME_SUM_UPDATE_
+#define DO_TIME_SUM_UPDATE_ do_time_sum_update_r4
+
#include "fms_diag_reduction_methods.inc"
!> @}
diff --git a/diag_manager/include/fms_diag_reduction_methods_r8.fh b/diag_manager/include/fms_diag_reduction_methods_r8.fh
index a3e3d68376..d550293113 100644
--- a/diag_manager/include/fms_diag_reduction_methods_r8.fh
+++ b/diag_manager/include/fms_diag_reduction_methods_r8.fh
@@ -35,6 +35,9 @@
#undef DO_TIME_MAX_
#define DO_TIME_MAX_ do_time_max_r8
+#undef DO_TIME_SUM_UPDATE_
+#define DO_TIME_SUM_UPDATE_ do_time_sum_update_r8
+
#include "fms_diag_reduction_methods.inc"
!> @}
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index de682cc7ee..35c0aa3198 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -31,7 +31,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_diag_dlinked_list test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
- check_time_min check_time_max
+ check_time_min check_time_max check_time_sum
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -47,18 +47,20 @@ test_reduction_methods_SOURCES = testing_utils.F90 test_reduction_methods.F90
check_time_none_SOURCES = testing_utils.F90 check_time_none.F90
check_time_min_SOURCES = testing_utils.F90 check_time_min.F90
check_time_max_SOURCES = testing_utils.F90 check_time_max.F90
+check_time_sum_SOURCES = testing_utils.F90 check_time_sum.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
$(abs_top_srcdir)/test_fms/tap-driver.sh
# Run the test.
-TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh
+TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh
testing_utils.mod: testing_utils.$(OBJEXT)
# Copy over other needed files to the srcdir
-EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh
+EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \
+ test_time_sum.sh
if USING_YAML
skipflag=""
diff --git a/test_fms/diag_manager/check_time_sum.F90 b/test_fms/diag_manager/check_time_sum.F90
new file mode 100644
index 0000000000..03d38f21a2
--- /dev/null
+++ b/test_fms/diag_manager/check_time_sum.F90
@@ -0,0 +1,264 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Checks the output file after running test_reduction_methods using the "time_sum" reduction method
+program check_time_sum
+ use fms_mod, only: fms_init, fms_end, string
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file
+ use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file
+ use platform_mod, only: r4_kind, r8_kind
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+
+ implicit none
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
+ type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
+ real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the 4th dimension
+ integer :: ti !< For looping through time levels
+ integer :: io_status !< Io status after reading the namelist
+ logical :: use_mask !< .true. if using masks
+ integer, parameter :: file_freq = 6 !< file frequency as set in diag_table.yaml
+
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+ integer, parameter :: kindl = KIND(0.0) !< compile-time default kind size
+
+ namelist / test_reduction_methods_nml / test_case, mask_case
+
+ call fms_init()
+
+ read (input_nml_file, test_reduction_methods_nml, iostat=io_status)
+
+ select case(mask_case)
+ case (no_mask)
+ use_mask = .false.
+ case (logical_mask, real_mask)
+ use_mask = .true.
+ end select
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+
+ if (.not. open_file(fileobj, "test_sum.nc", "read")) &
+ call mpp_error(FATAL, "unable to open test_sum.nc")
+
+ if (.not. open_file(fileobj1, "test_sum_regional.nc.0004", "read")) &
+ call mpp_error(FATAL, "unable to open test_sum_regional.nc.0004")
+
+ if (.not. open_file(fileobj2, "test_sum_regional.nc.0005", "read")) &
+ call mpp_error(FATAL, "unable to open test_sum_regional.nc.0005")
+
+ cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw)
+
+ do ti = 1, 8
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var0_sum - time_level:", string(ti)
+ call read_data(fileobj, "var0_sum", cdata_out(1,1,1,1), unlim_dim_level=ti)
+ call check_data_0d(cdata_out(1,1,1,1), ti)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var1_sum - time_level:", string(ti)
+ call read_data(fileobj, "var1_sum", cdata_out(:,1,1,1), unlim_dim_level=ti)
+ call check_data_1d(cdata_out(:,1,1,1), ti)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var2_sum - time_level:", string(ti)
+ call read_data(fileobj, "var2_sum", cdata_out(:,:,1,1), unlim_dim_level=ti)
+ call check_data_2d(cdata_out(:,:,1,1), ti)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_sum - time_level:", string(ti)
+ call read_data(fileobj, "var3_sum", cdata_out(:,:,:,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(:,:,:,1), ti, .false.)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_Z - time_level:", string(ti)
+ call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(:,:,1:2,1), ti, .true., nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_sum in the first regional file- time_level:", string(ti)
+ call read_data(fileobj1, "var3_sum", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(1:4,1:3,1:2,1), ti, .true., nx_offset=77, ny_offset=77, nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_sum in the second regional file- time_level:", string(ti)
+ call read_data(fileobj2, "var3_sum", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(1:4,1:1,1:2,1), ti, .true., nx_offset=77, ny_offset=80, nz_offset=1)
+ enddo
+
+ call fms_end()
+
+contains
+
+ ! sent data set to:
+ ! buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = real(ii, kind=r8_kind)* 1000_r8_kind + &
+ ! real(j, kind=r8_kind)* 10_r8_kind + &
+ ! real(k, kind=r8_kind)
+ ! + time_index/100
+ !> @brief Check that the 0d data read in is correct
+ subroutine check_data_0d(buffer, time_level)
+ real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer :: i, step_sum = 0 !< sum of time step increments to use in generating reference data
+
+ ! sums integers for decimal part of field input
+ ! ie. level 1 = 1+2+..+6
+ ! 2 = 7+8+..+12
+ step_sum = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_sum = step_sum + i
+ enddo
+
+ ! 0d answer is:
+ ! (1011 * frequency sum'd over )
+ ! + ( 1/100 * sum of time step increments )
+ buffer_exp = real((1000.0_r8_kind+10.0_r8_kind+1.0_r8_kind) * file_freq + &
+ real(step_sum,r8_kind)/100.0_r8_kind, kind=r4_kind)
+
+ if (abs(buffer - buffer_exp) > 0.0) then
+ print *, mpp_pe(), time_level, buffer_exp, buffer
+ call mpp_error(FATAL, "Check_time_sum::check_data_0d:: Data is not correct")
+ endif
+ end subroutine check_data_0d
+
+ !> @brief Check that the 1d data read in is correct
+ subroutine check_data_1d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer :: step_sum !< sum of time step increments to use in generating reference data
+ integer :: ii, i, j, k, l !< For looping
+ integer :: n
+
+ step_sum = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_sum = step_sum + i
+ enddo
+
+ ! 1d answer is
+ ! ((i * 1000 + 11) * frequency) + (sum of time steps)
+ do ii = 1, size(buffer, 1)
+ buffer_exp = 0.0
+ ! fails with both precisions
+ !do n=(time_level-1)*file_freq+1, time_level*file_freq
+ ! buffer_exp = real(buffer_exp + 1000.0_r8_kind * ii + 11.0_r8_kind + (n/100.0_r8_kind), r4_kind)
+ !enddo
+ ! passes with r8 defaults, fails with r4
+ buffer_exp = real( &
+ file_freq * (real(ii, kind=r8_kind)*1000.0_r8_kind +10.0_r8_kind+1.0_r8_kind) + &
+ real(step_sum, kind=r8_kind)/100.0_r8_kind &
+ , kind=r4_kind)
+
+ if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii) - buffer_exp) > 0.0) then
+ print *, "i:", ii, "read in:", buffer(ii), "expected:", buffer_exp, "sum of time steps:", step_sum
+ print *, "diff:", abs(buffer(ii) - buffer_exp)
+ call mpp_error(FATAL, "Check_time_sum::check_data_1d:: Data is not correct")
+ endif
+ enddo
+ end subroutine check_data_1d
+
+ !> @brief Check that the 2d data read in is correct
+ subroutine check_data_2d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer :: ii,i, j, k, l !< For looping
+ integer :: step_sum !< sum of time step increments to use in generating reference data
+
+ step_sum = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_sum = step_sum + i
+ enddo
+
+ ! 2d answer is
+ ! ((i * 1000 + j * 10 + 1) * frequency) + (sum of time steps)
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ buffer_exp = real(real(ii, kind=r8_kind)* 6000.0_kindl+ &
+ 60.0_kindl*real(j, kind=r8_kind)+6.0_kindl + &
+ real(step_sum, kind=r8_kind)/100_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j) - buffer_exp) > 0.0) then
+ print *, mpp_pe(), ii, j, buffer(ii, j), buffer_exp
+ call mpp_error(FATAL, "Check_time_sum::check_data_2d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ end subroutine check_data_2d
+
+ !> @brief Check that the 3d data read in is correct
+ subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ logical, intent(in) :: is_regional !< .True. if the variable is subregional
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer, optional, intent(in) :: nx_offset !< Offset in the x direction
+ integer, optional, intent(in) :: ny_offset !< Offset in the y direction
+ integer, optional, intent(in) :: nz_offset !< Offset in the z direction
+
+ integer :: ii, i, j, k, l !< For looping
+ integer :: nx_oset !< Offset in the x direction (local variable)
+ integer :: ny_oset !< Offset in the y direction (local variable)
+ integer :: nz_oset !< Offset in the z direction (local variable)
+ integer :: step_sum!< sum of time step increments to use in generating reference data
+
+ step_sum = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_sum = step_sum + i
+ enddo
+
+ nx_oset = 0
+ if (present(nx_offset)) nx_oset = nx_offset
+
+ ny_oset = 0
+ if (present(ny_offset)) ny_oset = ny_offset
+
+ nz_oset = 0
+ if (present(nz_offset)) nz_oset = nz_offset
+
+ ! 3d answer is
+ ! ((i * 1000 + j * 10 + k) * frequency) + (sum of time steps)
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do k = 1, size(buffer, 3)
+ buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 6000.0_kindl + &
+ 60.0_kindl*real(j+ny_oset, kind=r8_kind) + &
+ 6.0_kindl*real(k+nz_oset, kind=r8_kind) + &
+ real(step_sum, kind=r8_kind)/100.0_kindl, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j, k) - buffer_exp) > 0.0) then
+ print *, mpp_pe(), ii, j, k, buffer(ii, j, k), buffer_exp
+ call mpp_error(FATAL, "Check_time_sum::check_data_3d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_3d
+end program
diff --git a/test_fms/diag_manager/test_time_sum.sh b/test_fms/diag_manager/test_time_sum.sh
new file mode 100755
index 0000000000..18f923cbb4
--- /dev/null
+++ b/test_fms/diag_manager/test_time_sum.sh
@@ -0,0 +1,166 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+cat <<_EOF > diag_table.yaml
+title: test_sum
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_sum
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var0
+ output_name: var0_sum
+ reduction: sum
+ kind: r4
+ - module: ocn_mod
+ var_name: var1
+ output_name: var1_sum
+ reduction: sum
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ output_name: var2_sum
+ reduction: sum
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_sum
+ reduction: sum
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_Z
+ reduction: sum
+ zbounds: 2. 3.
+ kind: r4
+- file_name: test_sum_regional
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: latlon
+ corner1: 78. 78.
+ corner2: 78. 78.
+ corner3: 81. 81.
+ corner4: 81. 81.
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_sum
+ reduction: sum
+ zbounds: 2. 3.
+ kind: r4
+_EOF
+
+my_test_count=1
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "sum" reduction method (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "sum" reduction method (test $my_test_count)" '
+ mpirun -n 1 ../check_time_sum
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "sum" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "sum" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_sum
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "sum" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "sum" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_sum
+'
+
+export OMP_NUM_THREADS=1
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "sum" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "sum" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 1 ../check_time_sum
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "sum" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "sum" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_sum
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "sum" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "sum" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_sum
+'
+export OMP_NUM_THREADS=2
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "sum" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "sum" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 1 ../check_time_sum
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "sum" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "sum" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_sum
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "sum" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "sum" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_sum
+'
+fi
+test_done
From 35d4e866cf99202d60bb1c3bb36f433d0bc51fa9 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Wed, 15 Nov 2023 13:11:53 -0500
Subject: [PATCH 130/168] fix: diag_send_complete loops and add get_file_ids
(#1407)
---
diag_manager/fms_diag_field_object.F90 | 8 ++++
diag_manager/fms_diag_object.F90 | 66 ++++++++++++++------------
2 files changed, 43 insertions(+), 31 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 1eb0221e94..ffecfc650a 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -164,6 +164,7 @@ module fms_diag_field_object_mod
procedure :: get_math_needs_to_be_done
procedure :: add_area_volume
procedure :: append_time_cell_methods
+ procedure :: get_file_ids
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagField_type) :: null_ob
@@ -1639,5 +1640,12 @@ function get_starting_compute_domain(axis_ids, diag_axis) &
enddo axis_loop
end function get_starting_compute_domain
+!> Get list of field ids
+pure function get_file_ids(this)
+ class(fmsDiagField_type), intent(in) :: this
+ integer, allocatable :: get_file_ids(:) !< Ids of the FMS_diag_files the variable
+ get_file_ids = this%file_ids
+end function
+
#endif
end module fms_diag_field_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 894d8023d8..ea651e725f 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -46,6 +46,7 @@ module fms_diag_object_mod
use omp_lib
#endif
use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d
+use fms_string_utils_mod, only: string
use platform_mod
implicit none
private
@@ -648,43 +649,46 @@ subroutine fms_diag_send_complete(this, time_step)
class(*), pointer :: input_data_buffer(:,:,:,:)
character(len=128) :: error_string
type(fmsDiagIbounds_type) :: bounds
+ integer, dimension(:), allocatable :: file_ids !< Array of file IDs for a field
+ logical, parameter :: DEBUG_SC = .true. !< turn on output for debugging
!< Update the current model time by adding the time_step
this%current_model_time = this%current_model_time + time_step
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! In the future, this may be parallelized for offloading
- file_loop: do ifile = 1, size(this%FMS_diag_files)
- diag_file => this%FMS_diag_files(ifile)
- field_outer_if: if (size(diag_file%FMS_diag_file%get_field_ids()) .ge. 1) then
- allocate (file_field_ids(size(diag_file%FMS_diag_file%get_field_ids() )))
- file_field_ids = diag_file%FMS_diag_file%get_field_ids()
- field_loop: do ifield = 1, size(file_field_ids)
- ! If the field is not registered go away
- if (.not. diag_file%FMS_diag_file%is_field_registered(ifield)) cycle
-
- diag_field => this%FMS_diag_fields(file_field_ids(ifield))
- !> Check if math needs to be done
- math = diag_field%get_math_needs_to_be_done()
- calling_math: if (math) then
- input_data_buffer => diag_field%get_data_buffer()
- call bounds%reset_bounds_from_array_4D(input_data_buffer)
- call this%allocate_diag_field_output_buffers(input_data_buffer, file_field_ids(ifield))
- error_string = this%fms_diag_do_reduction(input_data_buffer, file_field_ids(ifield), &
- diag_field%get_mask(), diag_field%get_weight(), &
- bounds, .False., Time=this%current_model_time)
- if (trim(error_string) .ne. "") call mpp_error(FATAL, "Field:"//trim(diag_field%get_varname()//&
- " -"//trim(error_string)))
- endif calling_math
- !> Clean up, clean up, everybody everywhere
- if (associated(diag_field)) nullify(diag_field)
- enddo field_loop
- !> Clean up, clean up, everybody do your share
- if (allocated(file_field_ids)) deallocate(file_field_ids)
- endif field_outer_if
- enddo file_loop
-
- call this%fms_diag_do_io()
+ ! loop through each field
+ field_loop: do ifield = 1, size(this%FMS_diag_fields)
+ diag_field => this%FMS_diag_fields(ifield)
+ if(.not. diag_field%is_registered()) cycle
+ if(DEBUG_SC) call mpp_error(NOTE, "fms_diag_send_complete:: var: "//diag_field%get_varname())
+ ! get files the field is in
+ allocate (file_ids(size(diag_field%get_file_ids() )))
+ file_ids = diag_field%get_file_ids()
+ math = diag_field%get_math_needs_to_be_done()
+ ! if doing math loop through each file for given field
+ doing_math: if (size(file_ids) .ge. 1 .and. math) then
+ ! Check if buffer alloc'd
+ has_input_buff: if (diag_field%has_input_data_buffer()) then
+ input_data_buffer => diag_field%get_data_buffer()
+ ! reset bounds, allocate output buffer, and update it with reduction
+ call bounds%reset_bounds_from_array_4D(input_data_buffer)
+ call this%allocate_diag_field_output_buffers(input_data_buffer, ifield)
+ error_string = this%fms_diag_do_reduction(input_data_buffer, ifield, &
+ diag_field%get_mask(), diag_field%get_weight(), &
+ bounds, .False., Time=this%current_model_time)
+ if (trim(error_string) .ne. "") call mpp_error(FATAL, "Field:"//trim(diag_field%get_varname()//&
+ " -"//trim(error_string)))
+ else
+ call mpp_error(FATAL, "diag_send_complete:: no input buffer allocated for field"//diag_field%get_longname())
+ endif has_input_buff
+ endif doing_math
+ !> Clean up, clean up, everybody do your share
+ if (allocated(file_ids)) deallocate(file_ids)
+ if (associated(diag_field)) nullify(diag_field)
+ enddo field_loop
+
+call this%fms_diag_do_io()
#endif
end subroutine fms_diag_send_complete
From cb5f8abdbf00e3b8eb6846a163d35a28322544fa Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Mon, 20 Nov 2023 10:14:54 -0500
Subject: [PATCH 131/168] fix: move mask from input buffer object to field
object (#1411)
---
diag_manager/fms_diag_field_object.F90 | 77 ++++++++++++++++++++------
diag_manager/fms_diag_input_buffer.F90 | 16 +-----
diag_manager/fms_diag_object.F90 | 6 +-
3 files changed, 67 insertions(+), 32 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index ffecfc650a..e723ce8410 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -80,6 +80,7 @@ module fms_diag_field_object_mod
logical, allocatable :: buffer_allocated !< True if a buffer pointed by
!! the corresponding index in
!! buffer_ids(:) is allocated.
+ logical, allocatable :: mask(:,:,:,:) !< Mask passed in send_data
contains
! procedure :: send_data => fms_send_data !!TODO
! Get ID functions
@@ -165,6 +166,8 @@ module fms_diag_field_object_mod
procedure :: add_area_volume
procedure :: append_time_cell_methods
procedure :: get_file_ids
+ procedure :: set_mask
+ procedure :: allocate_mask
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagField_type) :: null_ob
@@ -394,10 +397,9 @@ subroutine set_vartype(objin , var)
end subroutine set_vartype
!> @brief Adds the input data to the buffered data.
-subroutine set_data_buffer (this, input_data, mask, weight, is, js, ks, ie, je, ke)
+subroutine set_data_buffer (this, input_data, weight, is, js, ks, ie, je, ke)
class (fmsDiagField_type) , intent(inout):: this !< The field object
class(*), intent(in) :: input_data(:,:,:,:) !< The input array
- logical, intent(in) :: mask(:,:,:,:) !< The field mask
real(kind=r8_kind), intent(in) :: weight !< The field weight
integer, intent(in) :: is, js, ks !< Starting indicies of the field_data relative
!! to the compute domain (1 based)
@@ -408,7 +410,7 @@ subroutine set_data_buffer (this, input_data, mask, weight, is, js, ks, ie, je,
if (.not.this%data_buffer_is_allocated) &
call mpp_error ("set_data_buffer", "The data buffer for the field "//trim(this%varname)//" was unable to be "//&
"allocated.", FATAL)
- err_msg = this%input_data_buffer%set_input_buffer_object(input_data, weight, mask, is, js, ks, ie, je, ke)
+ err_msg = this%input_data_buffer%set_input_buffer_object(input_data, weight, is, js, ks, ie, je, ke)
if (trim(err_msg) .ne. "") call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg))
end subroutine set_data_buffer
@@ -1239,19 +1241,6 @@ function get_data_buffer (this) &
rslt => this%input_data_buffer%get_buffer()
end function get_data_buffer
-!> @brief Gets a fields mask buffer
-!! @return a pointer to the mask buffer
-function get_mask (this) &
- result(rslt)
- class (fmsDiagField_type), target, intent(in) :: this !< diag field
- logical, dimension(:,:,:,:), pointer :: rslt
-
- if (.not. this%data_buffer_is_allocated) &
- call mpp_error(FATAL, "The input data buffer for the field:"&
- //trim(this%varname)//" was never allocated.")
-
- rslt => this%input_data_buffer%get_mask()
-end function get_mask
!> @brief Gets a fields weight buffer
!! @return a pointer to the weight buffer
@@ -1647,5 +1636,61 @@ pure function get_file_ids(this)
get_file_ids = this%file_ids
end function
+!> @brief Get the mask from the input buffer object
+!! @return a pointer to the mask
+function get_mask(this)
+ class(fmsDiagField_type), target, intent(in) :: this !< input buffer object
+ logical, pointer :: get_mask(:,:,:,:)
+ get_mask => this%mask
+end function get_mask
+
+!> @brief If in openmp region, omp_axis should be provided in order to allocate to the given axis lengths.
+!! Otherwise mask will be allocated to the size of mask_in
+subroutine allocate_mask(this, mask_in, omp_axis)
+ class(fmsDiagField_type), target, intent(inout) :: this !< input buffer object
+ logical, intent(in) :: mask_in(:,:,:,:)
+ class(fmsDiagAxisContainer_type), intent(in), optional :: omp_axis(:) !< true if calling from omp region
+ integer :: axis_num, length(4)
+ integer, pointer :: id_num
+ if(allocated(this%mask)) then
+ call mpp_error(NOTE,"set_mask:: mask already allocated for field"//this%longname)
+ deallocate(this%mask)
+ endif
+ ! if not omp just allocate to whatever is given
+ if(.not. present(omp_axis)) then
+ allocate(this%mask(size(mask_in,1), size(mask_in,2), size(mask_in,3), &
+ size(mask_in,4)))
+ ! otherwise loop through axis and get sizes
+ else
+ length = 1
+ do axis_num=1, size(this%axis_ids)
+ id_num => this%axis_ids(axis_num)
+ select type(axis => omp_axis(id_num)%axis)
+ type is (fmsDiagFullAxis_type)
+ length(axis_num) = axis%axis_length()
+ end select
+ enddo
+ allocate(this%mask(length(1), length(2), length(3), length(4)))
+ endif
+end subroutine allocate_mask
+
+!> Sets previously allocated mask to mask_in at given index ranges
+subroutine set_mask(this, mask_in, is, js, ks, ie, je, ke)
+ class(fmsDiagField_type), intent(inout) :: this
+ logical, intent(in) :: mask_in(:,:,:,:)
+ integer, optional, intent(in) :: is, js, ks, ie, je, ke
+ if(present(is)) then
+ if(is .lt. lbound(this%mask,1) .or. ie .gt. ubound(this%mask,1) .or. &
+ js .lt. lbound(this%mask,2) .or. je .gt. ubound(this%mask,2) .or. &
+ ks .lt. lbound(this%mask,3) .or. ke .gt. ubound(this%mask,3)) then
+ print *, mpp_pe(), "alloc'd", SHAPE(this%mask), "passed:", is,ie,js,je,ks,ke
+ call mpp_error(FATAL,"set_mask:: given indices out of bounds for allocated mask")
+ endif
+ this%mask(is:ie, js:je, ks:ke, :) = mask_in
+ else
+ this%mask = mask_in
+ endif
+end subroutine set_mask
+
#endif
end module fms_diag_field_object_mod
diff --git a/diag_manager/fms_diag_input_buffer.F90 b/diag_manager/fms_diag_input_buffer.F90
index 1428a229c7..12257734ce 100644
--- a/diag_manager/fms_diag_input_buffer.F90
+++ b/diag_manager/fms_diag_input_buffer.F90
@@ -34,12 +34,10 @@ module fms_diag_input_buffer_mod
type fmsDiagInputBuffer_t
logical :: initialized !< .True. if the input buffer has been initialized
class(*), allocatable :: buffer(:,:,:,:) !< Input data passed in send_data
- logical, allocatable :: mask(:,:,:,:) !< Mask passed in send_data
real(kind=r8_kind) :: weight !< Weight passed in send_data
contains
procedure :: get_buffer
- procedure :: get_mask
procedure :: get_weight
procedure :: init => init_input_buffer_object
procedure :: set_input_buffer_object
@@ -60,15 +58,6 @@ function get_buffer(this) &
buffer => this%buffer
end function get_buffer
- !> @brief Get the mask from the input buffer object
- !! @return a pointer to the mask
- function get_mask(this) &
- result(mask)
- class(fmsDiagInputBuffer_t), target, intent(in) :: this !< input buffer object
- logical, pointer :: mask(:,:,:,:)
-
- mask => this%mask
- end function get_mask
!> @brief Get the weight from the input buffer object
!! @return a pointer to the weight
@@ -111,7 +100,6 @@ function init_input_buffer_object(this, input_data, axis_ids, diag_axis) &
end select
enddo axis_loop
- allocate(this%mask(length(1), length(2), length(3), length(4)))
select type (input_data)
type is (real(r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(length(1), length(2), length(3), length(4)))
@@ -132,13 +120,12 @@ end function init_input_buffer_object
!> @brief Sets the members of the input buffer object
!! @return Error message if something went wrong
- function set_input_buffer_object(this, input_data, weight, mask, is, js, ks, ie, je, ke) &
+ function set_input_buffer_object(this, input_data, weight, is, js, ks, ie, je, ke) &
result(err_msg)
class(fmsDiagInputBuffer_t), intent(inout) :: this !< input buffer object
class(*), intent(in) :: input_data(:,:,:,:) !< Field data
real(kind=r8_kind), intent(in) :: weight !< Weight for the field
- logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
integer, intent(in) :: is, js, ks !< Starting index for each of the dimension
integer, intent(in) :: ie, je, ke !< Ending index for each of the dimensions
@@ -150,7 +137,6 @@ function set_input_buffer_object(this, input_data, weight, mask, is, js, ks, ie,
return
endif
- this%mask(is:ie, js:je, ks:ke, :) = mask
this%weight = weight
select type (input_data)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index ea651e725f..d92d6a9cf2 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -602,12 +602,14 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
if (.not. this%FMS_diag_fields(diag_field_id)%is_data_buffer_allocated()) then
data_buffer_is_allocated = &
this%FMS_diag_fields(diag_field_id)%allocate_data_buffer(field_data, this%diag_axis)
+ call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask, this%diag_axis)
endif
call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.)
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.)
!$omp end critical
- call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, oor_mask, field_weight, &
+ call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, field_weight, &
is, js, ks, ie, je, ke)
+ call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask, is, js, ks, ie, je, ke)
fms_diag_accept_data = .TRUE.
return
else
@@ -619,6 +621,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
bounds, using_blocking, Time=Time)
if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.)
+ call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask)
+ call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask)
return
end if main_if
!> Return false if nothing is done
From f6816c2f8c001732daf705090d30ccc072021540 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 20 Nov 2023 13:01:25 -0500
Subject: [PATCH 132/168] feat: Modern_diag_manager add send data 4d (#1402)
---
diag_manager/diag_manager.F90 | 52 +++++++++++++++++++
test_fms/diag_manager/check_time_max.F90 | 6 +++
test_fms/diag_manager/check_time_min.F90 | 6 +++
test_fms/diag_manager/check_time_none.F90 | 6 +++
test_fms/diag_manager/check_time_sum.F90 | 6 +++
.../diag_manager/test_reduction_methods.F90 | 24 +++++++--
test_fms/diag_manager/test_time_max.sh | 9 +++-
test_fms/diag_manager/test_time_min.sh | 5 ++
test_fms/diag_manager/test_time_none.sh | 5 ++
test_fms/diag_manager/test_time_sum.sh | 5 ++
10 files changed, 118 insertions(+), 6 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 5b5357b514..ed92efe1f0 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -343,6 +343,7 @@ MODULE diag_manager_mod
MODULE PROCEDURE send_data_1d
MODULE PROCEDURE send_data_2d
MODULE PROCEDURE send_data_3d
+ MODULE PROCEDURE send_data_4d
END INTERFACE
!> @brief Register a diagnostic field for a given module
@@ -3472,6 +3473,57 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
endIF modern_if
END FUNCTION diag_send_data
+ !> @brief Updates the output buffer for a field based on the data for current time step
+ !! @return true if send is successful
+ LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, &
+ & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
+ INTEGER, INTENT(in) :: diag_field_id !< The field id returned from the register call
+ CLASS(*), INTENT(in) :: field(:,:,:,:) !< The field data for the current time step
+ CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight to multiply the data by when averaging
+ TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current model time
+ INTEGER, INTENT(in), OPTIONAL :: is_in !< Starting i index of the data
+ INTEGER, INTENT(in), OPTIONAL :: js_in !< Starting j index of the data
+ INTEGER, INTENT(in), OPTIONAL :: ks_in !< Starting k index of the data
+ INTEGER, INTENT(in), OPTIONAL :: ie_in !< Ending i index of the data
+ INTEGER, INTENT(in), OPTIONAL :: je_in !< Ending j index of the data
+ INTEGER, INTENT(in), OPTIONAL :: ke_in !< Ending k index of the data
+ LOGICAL, INTENT(in), OPTIONAL :: mask(:,:,:,:) !< Logical mask indicating the points to not average
+ CLASS(*), INTENT(in), OPTIONAL :: rmask(:,:,:,:) !< Real mask indicating the points to not averafe
+ CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< If some errors occurs, send_data will return the
+ !! error message instead of crashing
+
+ class(*), allocatable :: rmask_local(:,:,:,:) !< Real version of the mask variable
+ logical, allocatable :: mask_local(:,:,:,:) !< Local version of the mask variable
+
+ ! If diag_field_id is < 0 it means that this field is not registered, simply return
+ IF ( diag_field_id <= 0 ) THEN
+ send_data_4d = .FALSE.
+ RETURN
+ ENDIF
+
+ if (.not. use_modern_diag) &
+ call mpp_error(FATAL, "Send_data_4d is only supported when diag_manager_nml::use_modern_diag=.true.")
+
+ !< The error checking is done in accept_data
+ if (present(mask)) mask_local = mask
+ if (present(rmask)) rmask_local = rmask
+
+ send_data_4d = fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, &
+ time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, &
+ err_msg)
+
+ if (present(err_msg)) then
+ if (err_msg .ne. "") then
+ call mpp_error(NOTE, trim(err_msg))
+ send_data_4d = .false.
+ return
+ endif
+ endif
+
+ if (allocated(rmask_local)) deallocate(rmask_local)
+ if (allocated(mask_local)) deallocate(mask_local)
+ end function send_data_4d
+
!> @return true if send is successful
LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask )
INTEGER, INTENT(in) :: id !< id od the diagnostic field
diff --git a/test_fms/diag_manager/check_time_max.F90 b/test_fms/diag_manager/check_time_max.F90
index 51e888541c..fd835ce4a3 100644
--- a/test_fms/diag_manager/check_time_max.F90
+++ b/test_fms/diag_manager/check_time_max.F90
@@ -91,6 +91,12 @@ program check_time_max
call read_data(fileobj, "var3_max", cdata_out(:,:,:,1), unlim_dim_level=i)
call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var4_max - time_level:", string(i)
+ call read_data(fileobj, "var4_max", cdata_out(:,:,:,:), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+ call check_data_3d(cdata_out(:,:,:,2), i, .false.)
+
cdata_out = -999_r4_kind
print *, "Checking answers for var3_Z_max - time_level:", string(i)
call read_data(fileobj, "var3_Z_max", cdata_out(:,:,1:2,1), unlim_dim_level=i)
diff --git a/test_fms/diag_manager/check_time_min.F90 b/test_fms/diag_manager/check_time_min.F90
index e56e344144..da2440a638 100644
--- a/test_fms/diag_manager/check_time_min.F90
+++ b/test_fms/diag_manager/check_time_min.F90
@@ -91,6 +91,12 @@ program check_time_min
call read_data(fileobj, "var3_min", cdata_out(:,:,:,1), unlim_dim_level=i)
call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var4_min - time_level:", string(i)
+ call read_data(fileobj, "var4_min", cdata_out(:,:,:,:), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+ call check_data_3d(cdata_out(:,:,:,2), i, .false.)
+
cdata_out = -999_r4_kind
print *, "Checking answers for var3_Z_min - time_level:", string(i)
call read_data(fileobj, "var3_Z_min", cdata_out(:,:,1:2,1), unlim_dim_level=i)
diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90
index f703469078..e0b3f73541 100644
--- a/test_fms/diag_manager/check_time_none.F90
+++ b/test_fms/diag_manager/check_time_none.F90
@@ -91,6 +91,12 @@ program check_time_none
call read_data(fileobj, "var3_none", cdata_out(:,:,:,1), unlim_dim_level=i)
call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var4_none - time_level:", string(i)
+ call read_data(fileobj, "var4_none", cdata_out(:,:,:,:), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+ call check_data_3d(cdata_out(:,:,:,2), i, .false.)
+
cdata_out = -999_r4_kind
print *, "Checking answers for var3_Z - time_level:", string(i)
call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=i)
diff --git a/test_fms/diag_manager/check_time_sum.F90 b/test_fms/diag_manager/check_time_sum.F90
index 03d38f21a2..463e1cea5f 100644
--- a/test_fms/diag_manager/check_time_sum.F90
+++ b/test_fms/diag_manager/check_time_sum.F90
@@ -93,6 +93,12 @@ program check_time_sum
call read_data(fileobj, "var3_sum", cdata_out(:,:,:,1), unlim_dim_level=ti)
call check_data_3d(cdata_out(:,:,:,1), ti, .false.)
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var4_sum - time_level:", string(ti)
+ call read_data(fileobj, "var4_sum", cdata_out(:,:,:,:), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(:,:,:,1), ti, .false.)
+ call check_data_3d(cdata_out(:,:,:,2), ti, .false.)
+
cdata_out = -999_r4_kind
print *, "Checking answers for var3_Z - time_level:", string(ti)
call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=ti)
diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90
index 5b57051065..d47d21895e 100644
--- a/test_fms/diag_manager/test_reduction_methods.F90
+++ b/test_fms/diag_manager/test_reduction_methods.F90
@@ -133,19 +133,19 @@ program test_reduction_methods
select case (mask_case)
case (logical_mask)
clmask = allocate_logical_mask(isc, iec, jsc, jec, nz, nw)
- if (mpp_pe() .eq. 0) clmask(isc, jsc, 1, 1) = .False.
+ if (mpp_pe() .eq. 0) clmask(isc, jsc, 1, :) = .False.
if (test_case .eq. test_halos) then
dlmask = allocate_logical_mask(isd, ied, jsd, jed, nz, nw)
- if (mpp_pe() .eq. 0) dlmask(1+nhalox, 1+nhaloy, 1, 1) = .False.
+ if (mpp_pe() .eq. 0) dlmask(1+nhalox, 1+nhaloy, 1, :) = .False.
endif
case (real_mask)
crmask = allocate_real_mask(isc, iec, jsc, jec, nz, nw)
- if (mpp_pe() .eq. 0) crmask(isc, jsc, 1, 1) = 0_r8_kind
+ if (mpp_pe() .eq. 0) crmask(isc, jsc, 1, :) = 0_r8_kind
if (test_case .eq. test_halos) then
drmask = allocate_real_mask(isd, ied, jsd, jed, nz, nw)
- if (mpp_pe() .eq. 0) drmask(1+nhalox, 1+nhaloy, 1, 1) = 0_r8_kind
+ if (mpp_pe() .eq. 0) drmask(1+nhalox, 1+nhaloy, 1, :) = 0_r8_kind
endif
end select
@@ -190,14 +190,17 @@ program test_reduction_methods
used = send_data(id_var1, cdata(:,1,1,1), Time)
used = send_data(id_var2, cdata(:,:,1,1), Time)
used = send_data(id_var3, cdata(:,:,:,1), Time)
+ used = send_data(id_var4, cdata(:,:,:,:), Time)
case (real_mask)
used = send_data(id_var1, cdata(:,1,1,1), Time, rmask=crmask(:,1,1,1))
used = send_data(id_var2, cdata(:,:,1,1), Time, rmask=crmask(:,:,1,1))
used = send_data(id_var3, cdata(:,:,:,1), Time, rmask=crmask(:,:,:,1))
+ used = send_data(id_var4, cdata(:,:,:,:), Time, rmask=crmask(:,:,:,:))
case (logical_mask)
used = send_data(id_var1, cdata(:,1,1,1), Time, mask=clmask(:,1,1,1))
used = send_data(id_var2, cdata(:,:,1,1), Time, mask=clmask(:,:,1,1))
used = send_data(id_var3, cdata(:,:,:,1), Time, mask=clmask(:,:,:,1))
+ used = send_data(id_var4, cdata(:,:,:,:), Time, mask=clmask(:,:,:,:))
end select
case (test_halos)
call set_buffer(ddata, i)
@@ -208,6 +211,8 @@ program test_reduction_methods
is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1)
used = send_data(id_var3, ddata(:,:,:,1), Time, &
is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1)
+ used = send_data(id_var4, ddata(:,:,:,:), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1)
case (real_mask)
used = send_data(id_var1, cdata(:,1,1,1), Time, &
rmask=crmask(:,1,1,1))
@@ -217,6 +222,9 @@ program test_reduction_methods
used = send_data(id_var3, ddata(:,:,:,1), Time, &
is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
rmask=drmask(:,:,:,1))
+ used = send_data(id_var4, ddata(:,:,:,:), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ rmask=drmask(:,:,:,:))
case (logical_mask)
used = send_data(id_var1, cdata(:,1,1,1), Time, &
mask=clmask(:,1,1,1))
@@ -226,6 +234,9 @@ program test_reduction_methods
used = send_data(id_var3, ddata(:,:,:,1), Time, &
is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
mask=dlmask(:,:,:,1))
+ used = send_data(id_var4, ddata(:,:,:,:), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ mask=dlmask(:,:,:,:))
end select
case (test_openmp)
select case(mask_case)
@@ -255,16 +266,21 @@ program test_reduction_methods
case (no_mask)
used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1)
used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1)
+ used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1)
case (real_mask)
used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, &
rmask=crmask(is1:ie1, js1:je1, 1, 1))
used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, &
rmask=crmask(is1:ie1, js1:je1, :, 1))
+ used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1, &
+ rmask=crmask(is1:ie1, js1:je1, :, :))
case (logical_mask)
used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, &
mask=clmask(is1:ie1, js1:je1, 1, 1))
used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, &
mask=clmask(is1:ie1, js1:je1, :, 1))
+ used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1, &
+ mask=clmask(is1:ie1, js1:je1, :, :))
end select
enddo
end select
diff --git a/test_fms/diag_manager/test_time_max.sh b/test_fms/diag_manager/test_time_max.sh
index b9a62b4d74..d2a0fd7cdc 100755
--- a/test_fms/diag_manager/test_time_max.sh
+++ b/test_fms/diag_manager/test_time_max.sh
@@ -58,6 +58,11 @@ diag_files:
output_name: var3_max
reduction: max
kind: r4
+ - module: ocn_mod
+ var_name: var4
+ output_name: var4_max
+ reduction: max
+ kind: r4
- module: ocn_mod
var_name: var3
output_name: var3_Z_max
@@ -110,7 +115,7 @@ test_expect_success "Checking answers for the "max" reduction method, real mask
mpirun -n 1 ../check_time_max
'
-export OMP_NUM_THREADS=1
+export OMP_NUM_THREADS=2
my_test_count=`expr $my_test_count + 1`
printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "max" reduction method with openmp (test $my_test_count)" '
@@ -137,7 +142,7 @@ test_expect_success "Running diag_manager with "max" reduction method with openm
test_expect_success "Checking answers for the "max" reduction method with openmp, real mask (test $my_test_count)" '
mpirun -n 1 ../check_time_max
'
-export OMP_NUM_THREADS=2
+export OMP_NUM_THREADS=1
my_test_count=`expr $my_test_count + 1`
printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
diff --git a/test_fms/diag_manager/test_time_min.sh b/test_fms/diag_manager/test_time_min.sh
index f0305d15a0..f2969d47c9 100755
--- a/test_fms/diag_manager/test_time_min.sh
+++ b/test_fms/diag_manager/test_time_min.sh
@@ -58,6 +58,11 @@ diag_files:
output_name: var3_min
reduction: min
kind: r4
+ - module: ocn_mod
+ var_name: var4
+ output_name: var4_min
+ reduction: min
+ kind: r4
- module: ocn_mod
var_name: var3
output_name: var3_Z_min
diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh
index e9e444c5fb..9840e0c0ac 100755
--- a/test_fms/diag_manager/test_time_none.sh
+++ b/test_fms/diag_manager/test_time_none.sh
@@ -57,6 +57,11 @@ diag_files:
output_name: var3_none
reduction: none
kind: r4
+ - module: ocn_mod
+ var_name: var4
+ output_name: var4_none
+ reduction: none
+ kind: r4
- module: ocn_mod
var_name: var3
output_name: var3_Z
diff --git a/test_fms/diag_manager/test_time_sum.sh b/test_fms/diag_manager/test_time_sum.sh
index 18f923cbb4..c7631217a4 100755
--- a/test_fms/diag_manager/test_time_sum.sh
+++ b/test_fms/diag_manager/test_time_sum.sh
@@ -55,6 +55,11 @@ diag_files:
output_name: var3_sum
reduction: sum
kind: r4
+ - module: ocn_mod
+ var_name: var4
+ output_name: var4_sum
+ reduction: sum
+ kind: r4
- module: ocn_mod
var_name: var3
output_name: var3_Z
From d1ec28273b4e99c33fc4f92459d8673f14fc0f62 Mon Sep 17 00:00:00 2001
From: rem1776
Date: Fri, 15 Dec 2023 13:35:52 -0500
Subject: [PATCH 133/168] fix build issues
---
test_fms/field_manager/Makefile.am | 6 ------
test_fms/tracer_manager/Makefile.am | 6 ------
2 files changed, 12 deletions(-)
diff --git a/test_fms/field_manager/Makefile.am b/test_fms/field_manager/Makefile.am
index 3353580ff0..78f6054cfd 100644
--- a/test_fms/field_manager/Makefile.am
+++ b/test_fms/field_manager/Makefile.am
@@ -39,12 +39,6 @@ test_field_table_read_SOURCES = test_field_table_read.F90
test_field_manager_r4_CPPFLAGS=-DTEST_FM_KIND_=4 -I$(MODDIR)
test_field_manager_r8_CPPFLAGS=-DTEST_FM_KIND_=8 -I$(MODDIR)
-if SKIP_PARSER_TESTS
-skipflag="skip"
-else
-skipflag=""
-endif
-
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(abs_top_srcdir)/test_fms/tap-driver.sh
TESTS_ENVIRONMENT= parser_skip=${skipflag}
diff --git a/test_fms/tracer_manager/Makefile.am b/test_fms/tracer_manager/Makefile.am
index f2a020b6fa..5246492de6 100644
--- a/test_fms/tracer_manager/Makefile.am
+++ b/test_fms/tracer_manager/Makefile.am
@@ -38,12 +38,6 @@ test_tracer_manager_r8_SOURCES = test_tracer_manager.F90
test_tracer_manager_r4_CPPFLAGS=-DTEST_TM_KIND_=4 -I$(MODDIR)
test_tracer_manager_r8_CPPFLAGS=-DTEST_TM_KIND_=8 -I$(MODDIR)
-if SKIP_PARSER_TESTS
-skipflag="skip"
-else
-skipflag=""
-endif
-
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(abs_top_srcdir)/test_fms/tap-driver.sh
TESTS_ENVIRONMENT= parser_skip=${skipflag}
From c1ad3a8cdb3beb41dedb935ff93827ffe9a5dbfd Mon Sep 17 00:00:00 2001
From: rem1776
Date: Fri, 15 Dec 2023 13:50:39 -0500
Subject: [PATCH 134/168] fix name used for makefile conditionals in tracer and
field manager tests
---
test_fms/field_manager/Makefile.am | 6 ++++++
test_fms/tracer_manager/Makefile.am | 6 ++++++
2 files changed, 12 insertions(+)
diff --git a/test_fms/field_manager/Makefile.am b/test_fms/field_manager/Makefile.am
index 78f6054cfd..01f10ed0dd 100644
--- a/test_fms/field_manager/Makefile.am
+++ b/test_fms/field_manager/Makefile.am
@@ -39,6 +39,12 @@ test_field_table_read_SOURCES = test_field_table_read.F90
test_field_manager_r4_CPPFLAGS=-DTEST_FM_KIND_=4 -I$(MODDIR)
test_field_manager_r8_CPPFLAGS=-DTEST_FM_KIND_=8 -I$(MODDIR)
+if USING_YAML
+skipflag="skip"
+else
+skipflag=""
+endif
+
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(abs_top_srcdir)/test_fms/tap-driver.sh
TESTS_ENVIRONMENT= parser_skip=${skipflag}
diff --git a/test_fms/tracer_manager/Makefile.am b/test_fms/tracer_manager/Makefile.am
index 5246492de6..747151344e 100644
--- a/test_fms/tracer_manager/Makefile.am
+++ b/test_fms/tracer_manager/Makefile.am
@@ -38,6 +38,12 @@ test_tracer_manager_r8_SOURCES = test_tracer_manager.F90
test_tracer_manager_r4_CPPFLAGS=-DTEST_TM_KIND_=4 -I$(MODDIR)
test_tracer_manager_r8_CPPFLAGS=-DTEST_TM_KIND_=8 -I$(MODDIR)
+if USING_YAML
+skipflag="skip"
+else
+skipflag=""
+endif
+
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(abs_top_srcdir)/test_fms/tap-driver.sh
TESTS_ENVIRONMENT= parser_skip=${skipflag}
From 2b300a85115ddf6eab32ce6d58ccf233869f617c Mon Sep 17 00:00:00 2001
From: rem1776
Date: Fri, 15 Dec 2023 13:59:54 -0500
Subject: [PATCH 135/168] fix: add missing imports from update diag code
---
diag_manager/diag_axis.F90 | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90
index d4cdf6b8df..9457651b84 100644
--- a/diag_manager/diag_axis.F90
+++ b/diag_manager/diag_axis.F90
@@ -39,7 +39,7 @@ MODULE diag_axis_mod
& fms_error_handler, FATAL, NOTE
USE diag_data_mod, ONLY: diag_axis_type, max_subaxes, max_axes,&
& max_num_axis_sets, max_axis_attributes, debug_diag_manager,&
- & first_send_data_call, diag_atttype, use_modern_diag, TWO_D_DOMAIN
+ & first_send_data_call, diag_atttype, use_modern_diag
use fms_diag_object_mod, only:fms_diag_object
#ifdef use_netCDF
USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR
From 1635f3e468773cf7b6959dc5bb735d28b800d6e8 Mon Sep 17 00:00:00 2001
From: rem1776
Date: Fri, 15 Dec 2023 14:59:25 -0500
Subject: [PATCH 136/168] fix conditionals in test scripts
---
test_fms/field_manager/test_field_manager2.sh | 2 +-
test_fms/tracer_manager/test_tracer_manager2.sh | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/test_fms/field_manager/test_field_manager2.sh b/test_fms/field_manager/test_field_manager2.sh
index a320afcf9a..d3a165b164 100755
--- a/test_fms/field_manager/test_field_manager2.sh
+++ b/test_fms/field_manager/test_field_manager2.sh
@@ -100,7 +100,7 @@ cat <<_EOF > input.nml
/
_EOF
-if [ ! -z $parser_skip ]; then
+if [ ! $parser_skip ]; then
test_expect_failure "field table read with use_field_table.yaml = .true. but not compiling with yaml" 'mpirun -n 1 ./test_field_table_read'
else
test_expect_success "field table read with use_field_table.yaml = .true." 'mpirun -n 1 ./test_field_table_read'
diff --git a/test_fms/tracer_manager/test_tracer_manager2.sh b/test_fms/tracer_manager/test_tracer_manager2.sh
index 2afc300b91..b35122fa3d 100755
--- a/test_fms/tracer_manager/test_tracer_manager2.sh
+++ b/test_fms/tracer_manager/test_tracer_manager2.sh
@@ -58,7 +58,7 @@ _EOF
test_expect_success "tracer_manager r4 with the legacy field table" 'mpirun -n 2 ./test_tracer_manager_r4'
test_expect_success "tracer_manager r8 with the legacy field table" 'mpirun -n 2 ./test_tracer_manager_r8'
-if [ -z $parser_skip ]; then
+if [ $parser_skip ]; then
rm -rf field_table
cat <<_EOF > input.nml
&field_manager_nml
From b9f76356659fe7370315676b035baddb18f88628 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Wed, 27 Dec 2023 11:25:38 -0500
Subject: [PATCH 137/168] feat: modern diag add time_average reduction method
and test (#1421)
---
diag_manager/diag_data.F90 | 12 +-
diag_manager/fms_diag_axis_object.F90 | 5 +-
diag_manager/fms_diag_field_object.F90 | 53 +++-
diag_manager/fms_diag_file_object.F90 | 18 ++
diag_manager/fms_diag_object.F90 | 74 ++++-
diag_manager/fms_diag_output_buffer.F90 | 84 +++++-
diag_manager/fms_diag_reduction_methods.F90 | 10 +-
.../include/fms_diag_reduction_methods.inc | 37 ++-
.../include/fms_diag_reduction_methods_r4.fh | 3 +
.../include/fms_diag_reduction_methods_r8.fh | 3 +
test_fms/diag_manager/Makefile.am | 8 +-
test_fms/diag_manager/check_time_avg.F90 | 270 ++++++++++++++++++
test_fms/diag_manager/test_diag_manager2.sh | 2 +-
test_fms/diag_manager/test_modern_diag.F90 | 2 +-
test_fms/diag_manager/test_time_avg.sh | 180 ++++++++++++
15 files changed, 725 insertions(+), 36 deletions(-)
create mode 100644 test_fms/diag_manager/check_time_avg.F90
create mode 100755 test_fms/diag_manager/test_time_avg.sh
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index c601c877a9..e6f566c61e 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -113,13 +113,13 @@ MODULE diag_data_mod
INTEGER, PARAMETER :: index_gridtype = 2
INTEGER, PARAMETER :: null_gridtype = DIAG_NULL
INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method
- INTEGER, PARAMETER :: time_average = 1 !< The reduction method is avera
- INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms
- INTEGER, PARAMETER :: time_max = 3 !< The reduction method is max
- INTEGER, PARAMETER :: time_min = 4 !< The reduction method is min
- INTEGER, PARAMETER :: time_sum = 5 !< The reudction method is sum
+ INTEGER, PARAMETER :: time_min = 1 !< The reduction method is min value
+ INTEGER, PARAMETER :: time_max = 2 !< The reduction method is max value
+ INTEGER, PARAMETER :: time_sum = 3 !< The reduction method is sum of values
+ INTEGER, PARAMETER :: time_average= 4 !< The reduction method is average of values
+ INTEGER, PARAMETER :: time_rms = 5 !< The reudction method is root mean square of values
INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal
- INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power
+ INTEGER, PARAMETER :: time_power = 7 !< The reduction method is average with exponents
CHARACTER(len=7) :: avg_name = 'average' !< Name of the average fields
CHARACTER(len=8) :: no_units = "NO UNITS"!< String indicating that the variable has no units
INTEGER, PARAMETER :: begin_time = 1 !< Use the begining of the time average bounds
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 8f22f7d2db..e74ccabeff 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -371,8 +371,9 @@ subroutine write_axis_metadata(this, fms2io_fileobj, edges_in_file, parent_axis)
end select
!< Write its metadata
- call register_variable_attribute(fms2io_fileobj, axis_name, "long_name", diag_axis%long_name, &
- str_len=len_trim(diag_axis%long_name))
+ if(allocated(diag_axis%long_name)) &
+ call register_variable_attribute(fms2io_fileobj, axis_name, "long_name", diag_axis%long_name, &
+ str_len=len_trim(diag_axis%long_name))
if (diag_axis%cart_name .NE. "N") &
call register_variable_attribute(fms2io_fileobj, axis_name, "axis", diag_axis%cart_name, str_len=1)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index e723ce8410..65fd44719b 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -81,6 +81,7 @@ module fms_diag_field_object_mod
!! the corresponding index in
!! buffer_ids(:) is allocated.
logical, allocatable :: mask(:,:,:,:) !< Mask passed in send_data
+ logical :: halo_present = .false. !< set if any halos are used
contains
! procedure :: send_data => fms_send_data !!TODO
! Get ID functions
@@ -168,6 +169,10 @@ module fms_diag_field_object_mod
procedure :: get_file_ids
procedure :: set_mask
procedure :: allocate_mask
+ procedure :: set_halo_present
+ procedure :: is_halo_present
+ procedure :: find_missing_value
+ procedure :: has_mask_allocated
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagField_type) :: null_ob
@@ -1652,10 +1657,6 @@ subroutine allocate_mask(this, mask_in, omp_axis)
class(fmsDiagAxisContainer_type), intent(in), optional :: omp_axis(:) !< true if calling from omp region
integer :: axis_num, length(4)
integer, pointer :: id_num
- if(allocated(this%mask)) then
- call mpp_error(NOTE,"set_mask:: mask already allocated for field"//this%longname)
- deallocate(this%mask)
- endif
! if not omp just allocate to whatever is given
if(.not. present(omp_axis)) then
allocate(this%mask(size(mask_in,1), size(mask_in,2), size(mask_in,3), &
@@ -1692,5 +1693,49 @@ subroutine set_mask(this, mask_in, is, js, ks, ie, je, ke)
endif
end subroutine set_mask
+!> sets halo_present to true
+subroutine set_halo_present(this)
+ class(fmsDiagField_type), intent(inout) :: this !< field object to modify
+ this%halo_present = .true.
+end subroutine set_halo_present
+
+!> Getter for halo_present
+pure function is_halo_present(this)
+ class(fmsDiagField_type), intent(in) :: this !< field object to get from
+ logical :: is_halo_present
+ is_halo_present = this%halo_present
+end function is_halo_present
+
+!> Helper routine to find and set the netcdf missing value for a field
+!! Always returns r8 due to reduction routine args
+!! casts up to r8 from given missing val or default if needed
+function find_missing_value(this, missing_val) &
+ result(res)
+ class(fmsDiagField_type), intent(in) :: this !< field object to get missing value for
+ class(*), allocatable, intent(out) :: missing_val !< outputted netcdf missing value (oriignal type)
+ real(r8_kind) :: res !< returned r8 copy of missing_val
+
+ if(this%has_missing_value()) then
+ missing_val = this%get_missing_value(this%get_vartype())
+ else
+ missing_val = get_default_missing_value(this%get_vartype())
+ endif
+
+ select type(missing_val)
+ type is (real(r8_kind))
+ res = missing_val
+ type is (real(r4_kind))
+ res = real(missing_val, r8_kind)
+ end select
+end function find_missing_value
+
+!> @returns allocation status of logical mask array
+!! this just indicates whether the mask array itself has been alloc'd
+!! this is different from @ref has_mask_variant, which is set earlier for whether a mask is being used at all
+pure logical function has_mask_allocated(this)
+ class(fmsDiagField_type),intent(in) :: this !< field object to check mask allocation for
+ has_mask_allocated = allocated(this%mask)
+end function has_mask_allocated
+
#endif
end module fms_diag_field_object_mod
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 687f609252..1aa5baf899 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -145,6 +145,8 @@ module fms_diag_file_object_mod
procedure, public :: has_file_varlist
procedure, public :: has_file_global_meta
procedure, public :: dump_file_obj
+ procedure, public :: get_buffer_ids
+ procedure, public :: get_number_of_buffers
end type fmsDiagFile_type
type, extends (fmsDiagFile_type) :: subRegionalFile_type
@@ -1475,5 +1477,21 @@ subroutine close_diag_file(this)
endif
end subroutine close_diag_file
+!> \brief Gets the buffer_id list from the file object
+pure function get_buffer_ids (this)
+ class(fmsDiagFile_type), intent(in) :: this !< The file object
+ integer, allocatable :: get_buffer_ids(:) !< returned buffer ids for this file
+
+ allocate(get_buffer_ids(this%number_of_buffers))
+ get_buffer_ids = this%buffer_ids
+end function get_buffer_ids
+
+!> Gets the stored number of buffers from the file object
+pure function get_number_of_buffers(this)
+ class(fmsDiagFile_type), intent(in) :: this !< file object
+ integer :: get_number_of_buffers !< returned number of buffers
+ get_number_of_buffers = this%number_of_buffers
+end function get_number_of_buffers
+
#endif
end module fms_diag_file_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index d92d6a9cf2..0d7cddf37e 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -238,6 +238,7 @@ integer function fms_register_diag_field_obj &
bufferptr => this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))
call bufferptr%set_field_id(this%registered_variables)
call bufferptr%set_yaml_id(fieldptr%buffer_ids(i))
+ call bufferptr%init_buffer_time(init_time)
enddo
!> Allocate and initialize member buffer_allocated of this field
@@ -538,6 +539,10 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
!< Set the field_weight. If "weight" is not present it will be set to 1.0_r8_kind
field_weight = set_weight(weight)
+ !< Set the variable type based off passed in field data
+ if(.not. this%FMS_diag_fields(diag_field_id)%has_vartype()) &
+ call this%FMS_diag_fields(diag_field_id)%set_type(field_data(1,1,1,1))
+
!< Check that the indices are present in the correct combination
error_string = check_indices_order(is_in, ie_in, js_in, je_in)
if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
@@ -550,6 +555,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
if ((present(is_in) .and. present(ie_in)) .or. (present(js_in) .and. present(je_in))) &
has_halos = .true.
+ if(has_halos) call this%FMS_diag_fields(diag_field_id)%set_halo_present()
+
!< If the field has `mask_variant=.true.`, check that mask OR rmask are present
if (this%FMS_diag_fields(diag_field_id)%is_mask_variant()) then
if (.not. allocated(mask) .and. .not. allocated(rmask)) call mpp_error(FATAL, &
@@ -602,7 +609,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
if (.not. this%FMS_diag_fields(diag_field_id)%is_data_buffer_allocated()) then
data_buffer_is_allocated = &
this%FMS_diag_fields(diag_field_id)%allocate_data_buffer(field_data, this%diag_axis)
- call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask, this%diag_axis)
+ if(.not. this%FMS_diag_fields(diag_field_id)%has_mask_allocated()) &
+ call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask, this%diag_axis)
endif
call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.)
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.)
@@ -621,7 +629,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
bounds, using_blocking, Time=Time)
if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.)
- call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask)
+ if(.not. this%FMS_diag_fields(diag_field_id)%has_mask_allocated()) &
+ call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask)
call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask)
return
end if main_if
@@ -654,7 +663,7 @@ subroutine fms_diag_send_complete(this, time_step)
character(len=128) :: error_string
type(fmsDiagIbounds_type) :: bounds
integer, dimension(:), allocatable :: file_ids !< Array of file IDs for a field
- logical, parameter :: DEBUG_SC = .true. !< turn on output for debugging
+ logical, parameter :: DEBUG_SC = .false. !< turn on output for debugging
!< Update the current model time by adding the time_step
this%current_model_time = this%current_model_time + time_step
@@ -699,6 +708,8 @@ end subroutine fms_diag_send_complete
!> @brief Loops through all the files, open the file, writes out axis and
!! variable metadata and data when necessary.
+!! TODO: passing in the saved mask from the field obj to diag_reduction_done_wrapper
+!! for performance
subroutine fms_diag_do_io(this, is_end_of_run)
class(fmsDiagObject_type), target, intent(inout) :: this !< The diag object
logical, optional, intent(in) :: is_end_of_run !< If .true. this is the end of the run,
@@ -706,11 +717,21 @@ subroutine fms_diag_do_io(this, is_end_of_run)
#ifdef use_yaml
integer :: i !< For do loops
class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience)
+ class(fmsDiagOutputBuffer_type), pointer :: diag_buff !< pointer to output buffers iterated in buff_loop
+ class(fmsDiagField_type), pointer :: diag_field !< pointer to output buffers iterated in buff_loop
+ class(DiagYamlFilesVar_type), pointer :: field_yaml !< Pointer to a field from yaml fields
TYPE (time_type), pointer :: model_time!< The current model time
-
+ integer, allocatable :: buff_ids(:) !< ids for output buffers to loop through
+ integer :: ibuff !< buffer index
logical :: file_is_opened_this_time_step !< True if the file was opened in this time_step
!! If true the metadata will need to be written
- logical :: force_write
+ logical :: force_write !< force the last write if at end of run
+ logical :: is_writing !< true if we are writing the actual field data (metadata is always written)
+ logical :: has_mask !< whether we have a mask
+ logical, parameter :: DEBUG_REDUCT = .false. !< enables debugging output
+ class(*), allocatable :: missing_val !< netcdf missing value for a given field
+ real(r8_kind) :: mval !< r8 copy of missing value
+ character(len=128) :: error_string !< outputted error string from reducti
force_write = .false.
if (present (is_end_of_run)) force_write = .true.
@@ -732,7 +753,38 @@ subroutine fms_diag_do_io(this, is_end_of_run)
call diag_file%write_axis_data(this%diag_axis)
endif
- if (diag_file%is_time_to_write(model_time)) then
+ is_writing = diag_file%is_time_to_write(model_time)
+
+ ! finish reduction method if its time to write
+ buff_reduct: if (is_writing) then
+ allocate(buff_ids(diag_file%FMS_diag_file%get_number_of_buffers()))
+ buff_ids = diag_file%FMS_diag_file%get_buffer_ids()
+ ! loop through the buffers and finish reduction if needed
+ buff_loop: do ibuff=1, SIZE(buff_ids)
+ diag_buff => this%FMS_diag_output_buffers(buff_ids(ibuff))
+ field_yaml => diag_yaml%get_diag_field_from_id(diag_buff%get_yaml_id())
+ diag_field => this%FMS_diag_fields(diag_buff%get_field_id())
+ ! sets missing value
+ mval = diag_field%find_missing_value(missing_val)
+ ! time_average and greater values all involve averaging so need to be "finished" before written
+ if( field_yaml%has_var_reduction()) then
+ if( field_yaml%get_var_reduction() .ge. time_average) then
+ if(DEBUG_REDUCT)call mpp_error(NOTE, "fms_diag_do_io:: finishing reduction for "//diag_field%get_longname())
+ has_mask = diag_field%has_mask_variant()
+ if(has_mask) has_mask = diag_field%get_mask_variant()
+ error_string = diag_buff%diag_reduction_done_wrapper( &
+ field_yaml%get_var_reduction(), &
+ mval, has_mask)
+ endif
+ endif
+ !endif
+ nullify(diag_buff)
+ nullify(field_yaml)
+ enddo buff_loop
+ deallocate(buff_ids)
+ endif buff_reduct
+
+ if (is_writing) then
call diag_file%increase_unlim_dimension_level()
call diag_file%write_time_data()
call diag_file%write_field_data(this%FMS_diag_fields, this%FMS_diag_output_buffers)
@@ -795,6 +847,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
real(kind=r8_kind) :: missing_value !< Missing_value for data points that are masked
!! This will obtained as r8 and converted to the right type as
!! needed. This is to avoid yet another select type ...
+ logical :: new_time !< .True. if this is a new time (i.e data has not be been
+ !! sent for this time)
!TODO mostly everything
field_ptr => this%FMS_diag_fields(diag_field_id)
@@ -908,11 +962,17 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
endif
case (time_sum)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
- bounds_in, bounds_out, missing_value)
+ bounds_in, bounds_out, missing_value, .true.)
if (trim(error_msg) .ne. "") then
return
endif
case (time_average)
+ new_time = buffer_ptr%update_buffer_time(time)
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ bounds_in, bounds_out, missing_value, new_time)
+ if (trim(error_msg) .ne. "") then
+ return
+ endif
case (time_power)
case (time_rms)
case (time_diurnal)
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index b8da2b3a62..eed366bee1 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -27,14 +27,14 @@ module fms_diag_output_buffer_mod
#ifdef use_yaml
use platform_mod
use iso_c_binding
-use time_manager_mod, only: time_type, operator(==)
-use mpp_mod, only: mpp_error, FATAL
+use time_manager_mod, only: time_type, operator(==), operator(>)
+use mpp_mod, only: mpp_error, FATAL, NOTE
use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8, get_base_time, MIN_VALUE, MAX_VALUE, EMPTY, &
time_min, time_max
use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t
use fms_diag_yaml_mod, only: diag_yaml
use fms_diag_bbox_mod, only: fmsDiagIbounds_type
-use fms_diag_reduction_methods_mod, only: do_time_none, do_time_min, do_time_max, do_time_sum_update
+use fms_diag_reduction_methods_mod, only: do_time_none, do_time_min, do_time_max, do_time_sum_update, time_update_done
use fms_diag_time_utils_mod, only: diag_time_inc
implicit none
@@ -54,6 +54,7 @@ module fms_diag_output_buffer_mod
integer :: field_id !< The id of the field the buffer belongs to
integer :: yaml_id !< The id of the yaml id the buffer belongs to
logical :: done_with_math !< .True. if done doing the math
+ type(time_type) :: time !< The last time the data was received
contains
procedure :: add_axis_ids
@@ -62,6 +63,8 @@ module fms_diag_output_buffer_mod
procedure :: get_field_id
procedure :: set_yaml_id
procedure :: get_yaml_id
+ procedure :: init_buffer_time
+ procedure :: update_buffer_time
procedure :: is_done_with_math
procedure :: set_done_with_math
procedure :: write_buffer
@@ -77,7 +80,8 @@ module fms_diag_output_buffer_mod
procedure :: do_time_min_wrapper
procedure :: do_time_max_wrapper
procedure :: do_time_sum_wrapper
-
+ procedure :: diag_reduction_done_wrapper
+ procedure :: get_buffer_dims
end type fmsDiagOutputBuffer_type
! public types
@@ -323,6 +327,35 @@ subroutine set_yaml_id(this, yaml_id)
this%yaml_id = yaml_id
end subroutine set_yaml_id
+!> @brief inits the buffer time for the buffer
+subroutine init_buffer_time(this, time)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ type(time_type), optional, intent(in) :: time !< time to add to the buffer
+
+ if (present(time)) then
+ this%time = time
+ else
+ this%time = get_base_time()
+ endif
+end subroutine init_buffer_time
+
+!> @brief Update the buffer time if it is a new time
+!! @return .true. if the buffer was updated
+function update_buffer_time(this, time) &
+ result(res)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ type(time_type), intent(in) :: time !< time to add to the buffer
+
+ logical :: res
+
+ if (time > this%time) then
+ this%time = time
+ res = .true.
+ else
+ res = .false.
+ endif
+end function
+
!> @brief Determine if finished with math
!! @return this%done_with_math
function is_done_with_math(this) &
@@ -554,7 +587,8 @@ end function do_time_max_wrapper
!> @brief Does the time_sum reduction method on the buffer object
!! @return Error message if the math was not successful
-function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value) &
+function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value, &
+ increase_counter) &
result(err_msg)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
@@ -563,6 +597,8 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
logical, intent(in) :: is_masked !< .True. if the field has a mask
real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
+ logical, intent(in) :: increase_counter !< .True. if data has not been received for
+ !! time, so the counter needs to be increased
character(len=50) :: err_msg
!TODO This will be expanded for integers
@@ -572,7 +608,7 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
select type (field_data)
type is (real(kind=r8_kind))
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, &
- bounds_in, bounds_out, missing_value)
+ bounds_in, bounds_out, missing_value, increase_counter)
class default
err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)"
end select
@@ -580,7 +616,7 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
select type (field_data)
type is (real(kind=r4_kind))
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, bounds_in, bounds_out, &
- real(missing_value, kind=r4_kind))
+ real(missing_value, kind=r4_kind), increase_counter)
class default
err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)"
end select
@@ -588,5 +624,39 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
err_msg="do_time_sum_wrapper::the output buffer is not a valid type, must be real(r8_kind) or real(r4_kind)"
end select
end function do_time_sum_wrapper
+
+!> Finishes calculations for any reductions that use an average (avg, rms, pow)
+!! TODO add mask and any other needed args for adjustment, and pass in the adjusted mask
+!! to time_update_done
+function diag_reduction_done_wrapper(this, reduction_method, missing_value, has_mask) & !! , has_halo, mask) &
+ result(err_msg)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Updated buffer object
+ integer, intent(in) :: reduction_method !< enumerated reduction type from diag_data
+ real(kind=r8_kind), intent(in) :: missing_value !< missing_value for masked data points
+ logical, intent(in) :: has_mask !< indicates if there was a mask used during buffer updates
+ character(len=51) :: err_msg !< error message to return, blank if sucessful
+
+ if(.not. allocated(this%buffer)) return
+
+ if(this%weight_sum .eq. 0.0_r8_kind) return
+
+ err_msg = ""
+ select type(buff => this%buffer)
+ type is (real(r8_kind))
+ call time_update_done(buff, this%weight_sum, reduction_method, missing_value, has_mask)
+ type is (real(r4_kind))
+ call time_update_done(buff, this%weight_sum, reduction_method, real(missing_value, r4_kind), has_mask)
+ end select
+ this%weight_sum = 0.0_r8_kind
+
+end function
+
+!> this leaves out the diurnal index cause its only used for tmp mask allocation
+pure function get_buffer_dims(this)
+ class(fmsDiagOutputBuffer_type), intent(in) :: this
+ integer :: get_buffer_dims(4)
+ get_buffer_dims = this%buffer_dims(1:4)
+end function
+
#endif
end module fms_diag_output_buffer_mod
diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90
index c3d939b0f6..801f6ba557 100644
--- a/diag_manager/fms_diag_reduction_methods.F90
+++ b/diag_manager/fms_diag_reduction_methods.F90
@@ -30,12 +30,13 @@
module fms_diag_reduction_methods_mod
use platform_mod, only: r8_kind, r4_kind
use fms_diag_bbox_mod, only: fmsDiagIbounds_type
+ use fms_string_utils_mod, only: string
use mpp_mod
implicit none
private
public :: check_indices_order, init_mask, set_weight
- public :: do_time_none, do_time_min, do_time_max, do_time_sum_update
+ public :: do_time_none, do_time_min, do_time_max, do_time_sum_update, time_update_done
!> @brief Does the time_none reduction method. See include/fms_diag_reduction_methods.inc
!TODO This needs to be extended to integers
@@ -62,6 +63,13 @@ module fms_diag_reduction_methods_mod
module procedure do_time_sum_update_r4, do_time_sum_update_r8
end interface
+ !> @brief Finishes a reduction that involves an average
+ !! (ie. time_avg, rms, pow)
+ !! This takes the average at the end of the time step
+ interface time_update_done
+ module procedure sum_update_done_r4, sum_update_done_r8
+ end interface
+
contains
!> @brief Checks improper combinations of is, ie, js, and je.
diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc
index c847817724..c443a945b4 100644
--- a/diag_manager/include/fms_diag_reduction_methods.inc
+++ b/diag_manager/include/fms_diag_reduction_methods.inc
@@ -19,7 +19,7 @@
! for any debug prints
#ifndef DEBUG_REDUCT
-#define DEBUG_REDUCT .true.
+#define DEBUG_REDUCT .false.
#endif
!> @brief Do the time_none reduction method (i.e copy the correct portion of the input data)
@@ -215,7 +215,7 @@ end subroutine DO_TIME_MAX_
!!
!! Where l are the indices passed in through the bounds_in/out
subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, bounds_in, bounds_out, &
- missing_value, weight, pow)
+ missing_value, increase_counter, weight, pow)
real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
real(r8_kind), intent(inout) :: weight_sum !< Sum of weights from the output buffer object
real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
@@ -226,6 +226,8 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion
!! of the output buffer
real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked
+ logical, intent(in) :: increase_counter !< .True. if data has not been received for
+ !! time, so the counter needs to be increased
real(r8_kind),optional, intent(in) :: weight !< Weight applied to data_in before added to data_out
!! used for weighted averages, default 1.0
real(FMS_TRM_KIND_),optional, intent(in) :: pow !< Used for pow reduction, adds field^pow to buffer
@@ -251,7 +253,7 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
endif
! update with given weight for average before write
- weight_sum = weight_sum + weight_loc
+ if (increase_counter) weight_sum = weight_sum + weight_loc
is_out = bounds_out%get_imin()
ie_out = bounds_out%get_imax()
@@ -289,7 +291,7 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
do k = 0, ke_out - ks_out
do j = 0, je_out - js_out
do i = 0, ie_out - is_out
- data_out(is_out + i, js_out + j, ks_out + k, :, 1) = &
+ data_out(is_out + i, js_out + j, ks_out + k, :, 1) = &
data_out(is_out + i, js_out + j, ks_out + k, :, 1) &
+ (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_loc) ** pow_loc
enddo
@@ -297,3 +299,30 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
enddo
endif
end subroutine DO_TIME_SUM_UPDATE_
+
+!> To be called with diag_send_complete, finishes reductions
+!! Just divides the buffer by the counter array(which is just the sum of the weights used in the buffer's reduction)
+!! TODO: change has_mask to an actual logical mask so we don't have to check for missing values
+subroutine SUM_UPDATE_DONE_(out_buffer_data, weight_sum, reduction_method, missing_val, has_mask)
+ real(FMS_TRM_KIND_), intent(inout) :: out_buffer_data(:,:,:,:,:) !< data buffer previously updated with
+ !! do_time_sum_update
+ real(r8_kind), intent(in) :: weight_sum !< sum of weights for averaging, provided via argument to send data
+ integer, intent(in) :: reduction_method !< which reduction method to use, should be time_avg
+ real(FMS_TRM_KIND_), intent(in) :: missing_val !< missing value for masked elements
+ logical, intent(in) :: has_mask !< indicates if mask is used so missing values can be skipped
+ !! TODO replace conditional in the `where` with passed in and ajusted mask from the original call
+ !logical, optional, intent(in) :: mask(:,:,:,:) !< logical mask from accept data call, if using one.
+ !logical :: has_mask !< whether or not mask is present
+
+ if ( has_mask ) then
+ where(out_buffer_data(:,:,:,:,1) .ne. missing_val)
+ out_buffer_data(:,:,:,:,1) = out_buffer_data(:,:,:,:,1) &
+ / weight_sum
+ endwhere
+ else !not mask variant
+ out_buffer_data(:,:,:,:,1) = out_buffer_data(:,:,:,:,1) &
+ / weight_sum
+ endif
+
+end subroutine
+
diff --git a/diag_manager/include/fms_diag_reduction_methods_r4.fh b/diag_manager/include/fms_diag_reduction_methods_r4.fh
index a3c499b12e..04a4f4f0ba 100644
--- a/diag_manager/include/fms_diag_reduction_methods_r4.fh
+++ b/diag_manager/include/fms_diag_reduction_methods_r4.fh
@@ -38,6 +38,9 @@
#undef DO_TIME_SUM_UPDATE_
#define DO_TIME_SUM_UPDATE_ do_time_sum_update_r4
+#undef SUM_UPDATE_DONE_
+#define SUM_UPDATE_DONE_ sum_update_done_r4
+
#include "fms_diag_reduction_methods.inc"
!> @}
diff --git a/diag_manager/include/fms_diag_reduction_methods_r8.fh b/diag_manager/include/fms_diag_reduction_methods_r8.fh
index d550293113..bff7f44ac2 100644
--- a/diag_manager/include/fms_diag_reduction_methods_r8.fh
+++ b/diag_manager/include/fms_diag_reduction_methods_r8.fh
@@ -38,6 +38,9 @@
#undef DO_TIME_SUM_UPDATE_
#define DO_TIME_SUM_UPDATE_ do_time_sum_update_r8
+#undef SUM_UPDATE_DONE_
+#define SUM_UPDATE_DONE_ sum_update_done_r8
+
#include "fms_diag_reduction_methods.inc"
!> @}
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 35c0aa3198..ea251f291f 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -31,7 +31,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_diag_dlinked_list test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
- check_time_min check_time_max check_time_sum
+ check_time_min check_time_max check_time_sum check_time_avg
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -48,19 +48,21 @@ check_time_none_SOURCES = testing_utils.F90 check_time_none.F90
check_time_min_SOURCES = testing_utils.F90 check_time_min.F90
check_time_max_SOURCES = testing_utils.F90 check_time_max.F90
check_time_sum_SOURCES = testing_utils.F90 check_time_sum.F90
+check_time_avg_SOURCES = testing_utils.F90 check_time_avg.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
$(abs_top_srcdir)/test_fms/tap-driver.sh
# Run the test.
-TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh
+TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh \
+ test_time_avg.sh
testing_utils.mod: testing_utils.$(OBJEXT)
# Copy over other needed files to the srcdir
EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \
- test_time_sum.sh
+ test_time_sum.sh test_time_avg.sh
if USING_YAML
skipflag=""
diff --git a/test_fms/diag_manager/check_time_avg.F90 b/test_fms/diag_manager/check_time_avg.F90
new file mode 100644
index 0000000000..6a1d527537
--- /dev/null
+++ b/test_fms/diag_manager/check_time_avg.F90
@@ -0,0 +1,270 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Checks the output file after running test_reduction_methods using the "time_avg" reduction method
+program check_time_avg
+ use fms_mod, only: fms_init, fms_end, string
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file
+ use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file
+ use platform_mod, only: r4_kind, r8_kind
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+
+ implicit none
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
+ type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
+ real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the 4th dimension
+ integer :: ti !< For looping through time levels
+ integer :: io_status !< Io status after reading the namelist
+ logical :: use_mask !< .true. if using masks
+ integer, parameter :: file_freq = 6 !< file frequency as set in diag_table.yaml
+
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+ integer, parameter :: kindl = KIND(0.0) !< compile-time default kind size
+
+ namelist / test_reduction_methods_nml / test_case, mask_case
+
+ call fms_init()
+
+ read (input_nml_file, test_reduction_methods_nml, iostat=io_status)
+
+ select case(mask_case)
+ case (no_mask)
+ use_mask = .false.
+ case (logical_mask, real_mask)
+ use_mask = .true.
+ end select
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+
+ if (.not. open_file(fileobj, "test_avg.nc", "read")) &
+ call mpp_error(FATAL, "unable to open test_avg.nc")
+
+ if (.not. open_file(fileobj1, "test_avg_regional.nc.0004", "read")) &
+ call mpp_error(FATAL, "unable to open test_avg_regional.nc.0004")
+
+ if (.not. open_file(fileobj2, "test_avg_regional.nc.0005", "read")) &
+ call mpp_error(FATAL, "unable to open test_avg_regional.nc.0005")
+
+ cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw)
+
+ do ti = 1, 8
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var0_avg - time_level:", string(ti)
+ call read_data(fileobj, "var0_avg", cdata_out(1,1,1,1), unlim_dim_level=ti)
+ call check_data_0d(cdata_out(1,1,1,1), ti)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var1_avg - time_level:", string(ti)
+ call read_data(fileobj, "var1_avg", cdata_out(:,1,1,1), unlim_dim_level=ti)
+ call check_data_1d(cdata_out(:,1,1,1), ti)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var2_avg - time_level:", string(ti)
+ call read_data(fileobj, "var2_avg", cdata_out(:,:,1,1), unlim_dim_level=ti)
+ call check_data_2d(cdata_out(:,:,1,1), ti)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_avg - time_level:", string(ti)
+ call read_data(fileobj, "var3_avg", cdata_out(:,:,:,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(:,:,:,1), ti, .false.)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var4_avg - time_level:", string(ti)
+ call read_data(fileobj, "var4_avg", cdata_out(:,:,:,:), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(:,:,:,1), ti, .false.)
+ call check_data_3d(cdata_out(:,:,:,2), ti, .false.)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_Z - time_level:", string(ti)
+ call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(:,:,1:2,1), ti, .true., nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_avg in the first regional file- time_level:", string(ti)
+ call read_data(fileobj1, "var3_avg", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(1:4,1:3,1:2,1), ti, .true., nx_offset=77, ny_offset=77, nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_avg in the second regional file- time_level:", string(ti)
+ call read_data(fileobj2, "var3_avg", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(1:4,1:1,1:2,1), ti, .true., nx_offset=77, ny_offset=80, nz_offset=1)
+ enddo
+
+ call fms_end()
+
+contains
+
+ ! sent data set to:
+ ! buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = real(ii, kind=r8_kind)* 1000_r8_kind + &
+ ! real(j, kind=r8_kind)* 10_r8_kind + &
+ ! real(k, kind=r8_kind)
+ ! + time_index/100
+ !> @brief Check that the 0d data read in is correct
+ subroutine check_data_0d(buffer, time_level)
+ real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer :: i, step_avg = 0 !< avg of time step increments to use in generating reference data
+
+ ! avgs integers for decimal part of field input
+ ! ie. level 1 = 1+2+..+6
+ ! 2 = 7+8+..+12
+ step_avg = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_avg = step_avg + i
+ enddo
+
+ ! 0d answer is:
+ ! (1011 * frequency avg'd over )
+ ! + ( 1/100 * avg of time step increments )
+ buffer_exp = real((1000.0_r8_kind+10.0_r8_kind+1.0_r8_kind) * file_freq + &
+ real(step_avg,r8_kind)/100.0_r8_kind, kind=r4_kind)
+ buffer_exp = buffer_exp / file_freq
+
+ if (abs(buffer - buffer_exp) > 0.0) print *, "answer not exact for 0d, time:", time_level, &
+ " diff:", abs(buffer-buffer_exp)
+
+ if (abs(buffer - buffer_exp) > 1.0e-4) then
+ print *, "time_level", time_level, "expected", buffer_exp, "read", buffer
+ call mpp_error(FATAL, "Check_time_avg::check_data_0d:: Data is not correct")
+ endif
+ end subroutine check_data_0d
+
+ !> @brief Check that the 1d data read in is correct
+ subroutine check_data_1d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer :: step_sum !< avg of time step increments to use in generating reference data
+ integer :: ii, i, j, k, l !< For looping
+ integer :: n
+
+ step_sum = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_sum = step_sum + i
+ enddo
+
+ ! 1d answer is
+ ! (((i * 1000 + 11) * frequency) + (sum of time steps)) / frequency
+ ! or
+ ! => (i * 1000 + 11) + (sum of time_steps/frequency/100)
+ do ii = 1, size(buffer, 1)
+ buffer_exp = real( &
+ (real(ii, kind=r8_kind)*1000.0_r8_kind +11.0_r8_kind) + &
+ (real(step_sum, kind=r8_kind)/file_freq/100.0_r8_kind) &
+ , kind=r4_kind)
+
+ if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii) - buffer_exp) > 0.0) then
+ print *, "i:", ii, "read in:", buffer(ii), "expected:", buffer_exp, "time level:", time_level
+ print *, "diff:", abs(buffer(ii) - buffer_exp)
+ call mpp_error(FATAL, "Check_time_avg::check_data_1d:: Data is not correct")
+ endif
+ enddo
+ end subroutine check_data_1d
+
+ !> @brief Check that the 2d data read in is correct
+ subroutine check_data_2d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer :: ii,i, j, k, l !< For looping
+ integer :: step_avg !< avg of time step increments to use in generating reference data
+
+ step_avg = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_avg = step_avg + i
+ enddo
+
+ ! 2d answer is
+ ! ((i * 1000 + j * 10 + 1) * frequency) + (avg of time steps)
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ buffer_exp = real(real(ii, kind=r8_kind)* 1000.0_kindl+ &
+ 10.0_kindl*real(j, kind=r8_kind)+1.0_kindl + &
+ real(step_avg, kind=r8_kind)/file_freq/100.0_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j) - buffer_exp) > 0.0) then
+ print *, "indices:", ii, j, "expected:", buffer_exp, "read in:",buffer(ii, j)
+ call mpp_error(FATAL, "Check_time_avg::check_data_2d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ end subroutine check_data_2d
+
+ !> @brief Check that the 3d data read in is correct
+ subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ logical, intent(in) :: is_regional !< .True. if the variable is subregional
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer, optional, intent(in) :: nx_offset !< Offset in the x direction
+ integer, optional, intent(in) :: ny_offset !< Offset in the y direction
+ integer, optional, intent(in) :: nz_offset !< Offset in the z direction
+
+ integer :: ii, i, j, k, l !< For looping
+ integer :: nx_oset !< Offset in the x direction (local variable)
+ integer :: ny_oset !< Offset in the y direction (local variable)
+ integer :: nz_oset !< Offset in the z direction (local variable)
+ integer :: step_avg!< avg of time step increments to use in generating reference data
+
+ step_avg = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_avg = step_avg + i
+ enddo
+
+ nx_oset = 0
+ if (present(nx_offset)) nx_oset = nx_offset
+
+ ny_oset = 0
+ if (present(ny_offset)) ny_oset = ny_offset
+
+ nz_oset = 0
+ if (present(nz_offset)) nz_oset = nz_offset
+
+ ! 3d answer is
+ ! ((i * 1000 + j * 10 + k) * frequency) + (avg of time steps)
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do k = 1, size(buffer, 3)
+ buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000.0_kindl + &
+ 10.0_kindl*real(j+ny_oset, kind=r8_kind) + &
+ 1.0_kindl*real(k+nz_oset, kind=r8_kind) + &
+ real(step_avg, kind=r8_kind)/file_freq/100.0_kindl, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j, k) - buffer_exp) > 0.0) then
+ print *, mpp_pe(),'indices:',ii, j, k, "read in:", buffer(ii, j, k), "expected:",buffer_exp
+ call mpp_error(FATAL, "Check_time_avg::check_data_3d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_3d
+end program
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 813e225156..449c3ed82f 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -713,7 +713,7 @@ diag_files:
var_name: var5
reduction: average
kind: r4
- - module: lnd_mod
+ - module: atm_mod
var_name: var7
reduction: average
kind: r4
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index 8205b8eee1..b39eb44594 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -248,7 +248,7 @@ subroutine allocate_dummy_data(var, lat_lon_domain, cube_sphere, lnd_domain, nz)
allocate(var%var4(is:ie, js:je, nz)) !< Variable in a 3D cube sphere domain
call mpp_get_UG_compute_domain(lnd_domain, size=nland)
- allocate(var%var5(nz)) !< Variable in the land unstructured domain
+ allocate(var%var5(nland)) !< Variable in the land unstructured domain
allocate(var%var6(nz)) !< 1D variable not domain decomposed
diff --git a/test_fms/diag_manager/test_time_avg.sh b/test_fms/diag_manager/test_time_avg.sh
new file mode 100755
index 0000000000..7c9752231c
--- /dev/null
+++ b/test_fms/diag_manager/test_time_avg.sh
@@ -0,0 +1,180 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+cat <<_EOF > diag_table.yaml
+title: test_avg
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_avg
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var0
+ output_name: var0_avg
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var1
+ output_name: var1_avg
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ output_name: var2_avg
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_avg
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var4
+ output_name: var4_avg
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_Z
+ reduction: average
+ zbounds: 2. 3.
+ kind: r4
+- file_name: test_avg_regional
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: latlon
+ corner1: 78. 78.
+ corner2: 78. 78.
+ corner3: 81. 81.
+ corner4: 81. 81.
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_avg
+ reduction: average
+ zbounds: 2. 3.
+ kind: r4
+_EOF
+
+# remove any existing files that would result in false passes during checks
+rm -f *.nc
+
+# tests with no mask, no openmp
+my_test_count=1
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "avg" reduction method (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "avg" reduction method (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "avg" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "avg" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "avg" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "avg" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+
+# openmp tests
+
+export OMP_NUM_THREADS=2
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "avg" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "avg" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "avg" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "avg" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "avg" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "avg" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+
+# halo output and mask tests
+
+export OMP_NUM_THREADS=1
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "avg" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "avg" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "avg" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "avg" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "avg" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "avg" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+fi
+test_done
From 180b8c355e9b42d9cafdc5b8f7a8ec97fa23875d Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 9 Jan 2024 12:06:32 -0500
Subject: [PATCH 138/168] fix: Modern_diag_manager Fix error messages + Fixes
for opemp (#1432)
---
diag_manager/diag_manager.F90 | 12 ++++----
diag_manager/fms_diag_field_object.F90 | 10 +++++--
diag_manager/fms_diag_file_object.F90 | 2 +-
diag_manager/fms_diag_object.F90 | 39 +++++++++++++++++---------
diag_manager/fms_diag_yaml.F90 | 8 ++++--
5 files changed, 45 insertions(+), 26 deletions(-)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index ed92efe1f0..f2c141573b 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -1773,8 +1773,8 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
! Split old and modern2023 here
modern_if: iF (use_modern_diag) then
field_name = fms_diag_object%fms_get_field_name_from_id(diag_field_id)
- field_remap = copy_3d_to_4d(field, trim(field_name)//"'s data")
- if (present(rmask)) rmask_remap = copy_3d_to_4d(rmask, trim(field_name)//"'s mask")
+ call copy_3d_to_4d(field, field_remap, trim(field_name)//"'s data")
+ if (present(rmask)) call copy_3d_to_4d(rmask, rmask_remap, trim(field_name)//"'s mask")
if (present(mask)) then
allocate(mask_remap(1:size(mask,1), 1:size(mask,2), 1:size(mask,3), 1))
mask_remap(:,:,:,1) = mask
@@ -4577,12 +4577,10 @@ SUBROUTINE diag_field_add_cell_measures(diag_field_id, area, volume)
END SUBROUTINE diag_field_add_cell_measures
!> @brief Copies a 3d buffer to a 4d buffer
- !> @return a 4d buffer
- function copy_3d_to_4d(data_in, field_name) &
- result(data_out)
+ subroutine copy_3d_to_4d(data_in, data_out, field_name)
class (*), intent(in) :: data_in(:,:,:) !< Data to copy
character(len=*), intent(in) :: field_name !< Name of the field copying (for error messages)
- class (*), allocatable :: data_out(:,:,:,:)
+ class (*), allocatable, intent(out) :: data_out(:,:,:,:) !< 4D version of the data
!TODO this should be extended to integers
select type(data_in)
@@ -4608,7 +4606,7 @@ function copy_3d_to_4d(data_in, field_name) &
call mpp_error(FATAL, "The data for "//trim(field_name)//&
&" is not a valid type. Currently only r4 and r8 are supported")
end select
- end function copy_3d_to_4d
+ end subroutine copy_3d_to_4d
END MODULE diag_manager_mod
!> @}
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 65fd44719b..380bcda31a 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -1676,15 +1676,21 @@ subroutine allocate_mask(this, mask_in, omp_axis)
end subroutine allocate_mask
!> Sets previously allocated mask to mask_in at given index ranges
-subroutine set_mask(this, mask_in, is, js, ks, ie, je, ke)
+subroutine set_mask(this, mask_in, field_info, is, js, ks, ie, je, ke)
class(fmsDiagField_type), intent(inout) :: this
logical, intent(in) :: mask_in(:,:,:,:)
+ character(len=*), intent(in) :: field_info !< Field info to add to error message
integer, optional, intent(in) :: is, js, ks, ie, je, ke
if(present(is)) then
if(is .lt. lbound(this%mask,1) .or. ie .gt. ubound(this%mask,1) .or. &
js .lt. lbound(this%mask,2) .or. je .gt. ubound(this%mask,2) .or. &
ks .lt. lbound(this%mask,3) .or. ke .gt. ubound(this%mask,3)) then
- print *, mpp_pe(), "alloc'd", SHAPE(this%mask), "passed:", is,ie,js,je,ks,ke
+ print *, "PE:", int2str(mpp_pe()), "The size of the mask is", &
+ SHAPE(this%mask), &
+ "But the indices passed in are is=", int2str(is), " ie=", int2str(ie),&
+ " js=", int2str(js), " je=", int2str(je), &
+ " ks=", int2str(ks), " ke=", int2str(ke), &
+ " ", trim(field_info)
call mpp_error(FATAL,"set_mask:: given indices out of bounds for allocated mask")
endif
this%mask(is:ie, js:je, ks:ke, :) = mask_in
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 1aa5baf899..211d5519c7 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -1483,7 +1483,7 @@ pure function get_buffer_ids (this)
integer, allocatable :: get_buffer_ids(:) !< returned buffer ids for this file
allocate(get_buffer_ids(this%number_of_buffers))
- get_buffer_ids = this%buffer_ids
+ get_buffer_ids = this%buffer_ids(1:this%number_of_buffers)
end function get_buffer_ids
!> Gets the stored number of buffers from the file object
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 0d7cddf37e..4d88d6a24d 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -530,7 +530,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
- field_info = " Check send data call for field:"//trim(this%FMS_diag_fields(diag_field_id)%get_varname())
+ field_info = " Check send data call for field:"//trim(this%FMS_diag_fields(diag_field_id)%get_varname())//&
+ " and module:"//trim(this%FMS_diag_fields(diag_field_id)%get_modname())
!< Check if time should be present for this field
if (.not.this%FMS_diag_fields(diag_field_id)%is_static() .and. .not.present(time)) &
@@ -539,10 +540,6 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
!< Set the field_weight. If "weight" is not present it will be set to 1.0_r8_kind
field_weight = set_weight(weight)
- !< Set the variable type based off passed in field data
- if(.not. this%FMS_diag_fields(diag_field_id)%has_vartype()) &
- call this%FMS_diag_fields(diag_field_id)%set_type(field_data(1,1,1,1))
-
!< Check that the indices are present in the correct combination
error_string = check_indices_order(is_in, ie_in, js_in, je_in)
if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
@@ -555,16 +552,11 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
if ((present(is_in) .and. present(ie_in)) .or. (present(js_in) .and. present(je_in))) &
has_halos = .true.
- if(has_halos) call this%FMS_diag_fields(diag_field_id)%set_halo_present()
-
!< If the field has `mask_variant=.true.`, check that mask OR rmask are present
if (this%FMS_diag_fields(diag_field_id)%is_mask_variant()) then
if (.not. allocated(mask) .and. .not. allocated(rmask)) call mpp_error(FATAL, &
"The field was registered with mask_variant, but mask or rmask are not present in the send_data call. "//&
trim(field_info))
- else
- if (allocated(mask) .or. allocated(rmask)) &
- call this%FMS_diag_fields(diag_field_id)%set_mask_variant(.True.)
endif
!< Check that mask and rmask are not both present
@@ -606,6 +598,17 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
main_if: if (buffer_the_data) then
!> Only 1 thread allocates the output buffer and sets set_math_needs_to_be_done
!$omp critical
+ !< These set_* calls need to be done inside an omp_critical to avoid any race conditions
+ !! and allocation issues
+ if(has_halos) call this%FMS_diag_fields(diag_field_id)%set_halo_present()
+
+ !< Set the variable type based off passed in field data
+ if(.not. this%FMS_diag_fields(diag_field_id)%has_vartype()) &
+ call this%FMS_diag_fields(diag_field_id)%set_type(field_data(1,1,1,1))
+
+ if (allocated(mask) .or. allocated(rmask)) &
+ call this%FMS_diag_fields(diag_field_id)%set_mask_variant(.True.)
+
if (.not. this%FMS_diag_fields(diag_field_id)%is_data_buffer_allocated()) then
data_buffer_is_allocated = &
this%FMS_diag_fields(diag_field_id)%allocate_data_buffer(field_data, this%diag_axis)
@@ -617,10 +620,21 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
!$omp end critical
call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, field_weight, &
is, js, ks, ie, je, ke)
- call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask, is, js, ks, ie, je, ke)
+ call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask, field_info, is, js, ks, ie, je, ke)
fms_diag_accept_data = .TRUE.
return
else
+ !< At this point if we are no longer in an openmp region or running with 1 thread
+ !! so it is safe to have these set_* calls
+ if(has_halos) call this%FMS_diag_fields(diag_field_id)%set_halo_present()
+
+ !< Set the variable type based off passed in field data
+ if(.not. this%FMS_diag_fields(diag_field_id)%has_vartype()) &
+ call this%FMS_diag_fields(diag_field_id)%set_type(field_data(1,1,1,1))
+
+ if (allocated(mask) .or. allocated(rmask)) &
+ call this%FMS_diag_fields(diag_field_id)%set_mask_variant(.True.)
+
error_string = bounds%set_bounds(field_data, is, ie, js, je, ks, ke, has_halos)
if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
@@ -631,7 +645,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.)
if(.not. this%FMS_diag_fields(diag_field_id)%has_mask_allocated()) &
call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask)
- call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask)
+ call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask, field_info)
return
end if main_if
!> Return false if nothing is done
@@ -757,7 +771,6 @@ subroutine fms_diag_do_io(this, is_end_of_run)
! finish reduction method if its time to write
buff_reduct: if (is_writing) then
- allocate(buff_ids(diag_file%FMS_diag_file%get_number_of_buffers()))
buff_ids = diag_file%FMS_diag_file%get_buffer_ids()
! loop through the buffers and finish reduction if needed
buff_loop: do ibuff=1, SIZE(buff_ids)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index d7229840b7..673a481a4e 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -39,7 +39,7 @@ module fms_diag_yaml_mod
get_block_ids, get_key_value, get_key_ids, get_key_name
use mpp_mod, only: mpp_error, FATAL, mpp_pe, mpp_root_pe, stdout
use, intrinsic :: iso_c_binding, only : c_ptr, c_null_char
-use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique
+use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique, string
use platform_mod, only: r4_kind, i4_kind
use fms_mod, only: lowercase
@@ -1444,10 +1444,12 @@ function get_diag_files_id(indices) &
& trim(filename)//c_null_char)
if (size(file_indices) .ne. 1) &
- & call mpp_error(FATAL, "get_diag_files_id: Error getting the correct number of file indices!")
+ & call mpp_error(FATAL, "get_diag_files_id: Error getting the correct number of file indices!"//&
+ " The diag file "//trim(filename)//" was defined "//string(size(file_indices))&
+ // " times")
if (file_indices(1) .eq. diag_null) &
- & call mpp_error(FATAL, "get_diag_files_id: Error finding the filename in the diag_files yaml")
+ & call mpp_error(FATAL, "get_diag_files_id: Error finding the file "//trim(filename)//" in the diag_files yaml")
!< Get the index of the file in the diag_yaml file
file_id(i) = file_list%diag_file_indices(file_indices(1))
From dbd4db9a046c98c7b0a9b17c2d0db4eeeda77fee Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Thu, 18 Jan 2024 11:42:01 -0500
Subject: [PATCH 139/168] docs: Adds the schema for the diag_table YAML (#1441)
---
diag_manager/schema.diag | 141 +++++++++++++++++++++++++++++++++++++++
1 file changed, 141 insertions(+)
create mode 100644 diag_manager/schema.diag
diff --git a/diag_manager/schema.diag b/diag_manager/schema.diag
new file mode 100644
index 0000000000..b232577ff9
--- /dev/null
+++ b/diag_manager/schema.diag
@@ -0,0 +1,141 @@
+{
+ "$schema": "http://json-schema.org/draft-04/schema#",
+ "type": "object",
+ "required": ["title", "base_date"],
+ "additionalProperties": false,
+ "properties": {
+ "title": {
+ "type": "string"
+ },
+ "base_date": {
+ "type": "string"
+ },
+ "diag_files": {
+ "type": "array",
+ "items": {
+ "type": "object",
+ "required": ["file_name", "freq", "time_units", "unlimdim"],
+ "additionalProperties": false,
+ "properties": {
+ "file_name": {
+ "type": "string"
+ },
+ "freq": {
+ "anyOf": [
+ {"type": "string"},
+ {"type": "number"}
+ ],
+ "pattern": "^-[1]{1,1} *[ seconds| minutes| hours| days| months| years]*|^0&|^[1-9]+ [seconds|minutes|hours|days|months|years]{1,1}"
+ },
+ "time_units": {
+ "type": "string",
+ "enum": ["seconds", "minutes", "hours", "days", "months", "years"]
+ },
+ "unlimdim": {
+ "type": "string"
+ },
+ "write_file": {
+ "type": "boolean"
+ },
+ "global_meta": {
+ },
+ "sub_region": {
+ "type": "array",
+ "minItems": 1,
+ "maxItems": 1,
+ "required": ["grid_type", "corner1", "corner2", "corner3", "corner4"],
+ "properties": {
+ "grid_type": {
+ "type": "string",
+ "enum": ["indices", "latlon"]
+ },
+ "corner1": {
+ "type": "array",
+ "minItems": 2,
+ "maxItems": 2,
+ "items": {
+ "type": "number"
+ }
+ },
+ "corner2": {
+ "type": "array",
+ "minItems": 2,
+ "maxItems": 2,
+ "items": {
+ "type": "number"
+ }
+ },
+ "corner3": {
+ "type": "array",
+ "minItems": 2,
+ "maxItems": 2,
+ "items": {
+ "type": "number"
+ }
+ },
+ "corner4": {
+ "type": "array",
+ "minItems": 2,
+ "maxItems": 2,
+ "items": {
+ "type": "number"
+ }
+ },
+ "tile": {
+ "type": "number"
+ }
+ }
+ },
+ "new_file_freq": {
+ "type": "string",
+ "pattern": "[0-9]{1,} [a-z]{1,}"
+ },
+ "start_time": {
+ "type": "string"
+ },
+ "file_duration": {
+ "type": "string"
+ },
+ "varlist": {
+ "type": "array",
+ "items": {
+ "type": "object",
+ "required": ["var_name", "reduction", "module", "kind"],
+ "additionalProperties": false,
+ "properties": {
+ "kind": {
+ "type": "string",
+ "enum": ["r4", "r8", "i4", "i8"]
+ },
+ "module": {
+ "type": "string"
+ },
+ "reduction": {
+ "type": "string",
+ "pattern": "^average$|^min$|^max$|^none$|^rms$|^sum$|^diurnal[1-9]+|^pow[1-9]+"
+ },
+ "var_name": {
+ "type": "string"
+ },
+ "write_var": {
+ "type": "boolean"
+ },
+ "output_name": {
+ "type": "string"
+ },
+ "long_name": {
+ "type": "string"
+ },
+ "attributes": {
+ },
+ "zbounds": {
+ "type": "string"
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
From 4996cb8f3e1fb36ade1b686a42de5c8f29d73d00 Mon Sep 17 00:00:00 2001
From: Tom Robinson <33458882+thomas-robinson@users.noreply.github.com>
Date: Thu, 18 Jan 2024 11:44:54 -0500
Subject: [PATCH 140/168] chore: Removes unused diag manager update files
(#1443)
---
CMakeLists.txt | 3 -
diag_manager/Makefile.am | 7 +-
diag_manager/fms_diag_dlinked_list.F90 | 341 ------------------
diag_manager/fms_diag_object_container.F90 | 294 ---------------
test_fms/diag_manager/Makefile.am | 3 +-
.../diag_manager/test_diag_dlinked_list.F90 | 225 ------------
test_fms/diag_manager/test_diag_manager2.sh | 6 -
.../test_diag_object_container.F90 | 238 ------------
8 files changed, 2 insertions(+), 1115 deletions(-)
delete mode 100644 diag_manager/fms_diag_dlinked_list.F90
delete mode 100644 diag_manager/fms_diag_object_container.F90
delete mode 100644 test_fms/diag_manager/test_diag_dlinked_list.F90
delete mode 100644 test_fms/diag_manager/test_diag_object_container.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index f5aa2b4a2d..4a6292027b 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -136,9 +136,6 @@ list(APPEND fms_fortran_src_files
diag_manager/fms_diag_file_object.F90
diag_manager/fms_diag_field_object.F90
diag_manager/fms_diag_axis_object.F90
- diag_manager/fms_diag_dlinked_list.F90
- diag_manager/fms_diag_object_container.F90
- diag_manager/fms_diag_buffer.F90
diag_manager/fms_diag_output_buffer.F90
diag_manager/fms_diag_input_buffer.F90
diag_manager/fms_diag_time_reduction.F90
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index 9bf6e5af1f..b55eb826a4 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -51,8 +51,6 @@ libdiag_manager_la_SOURCES = \
fms_diag_yaml.F90 \
fms_diag_object.F90 \
fms_diag_axis_object.F90 \
- fms_diag_object_container.F90 \
- fms_diag_dlinked_list.F90 \
fms_diag_output_buffer.F90 \
fms_diag_input_buffer.F90 \
fms_diag_time_reduction.F90 \
@@ -87,7 +85,6 @@ fms_diag_field_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml
fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_input_buffer_mod.$(FC_MODEXT)
fms_diag_file_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_field_object_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_output_buffer_mod.$(FC_MODEXT)
-fms_diag_object_container_mod.$(FC_MODEXT): fms_diag_object_mod.$(FC_MODEXT) fms_diag_dlinked_list_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
diag_grid_mod.$(FC_MODEXT)
fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT)
@@ -100,7 +97,7 @@ diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MOD
diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) fms_diag_file_object_mod.$(FC_MODEXT) \
fms_diag_yaml_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) \
- fms_diag_object_container_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT) \
+ fms_diag_axis_object_mod.$(FC_MODEXT) \
fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \
fms_diag_fieldbuff_update_mod.$(FC_MODEXT)
fms_diag_output_buffer_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_yaml_mod.$(FC_MODEXT) \
@@ -130,8 +127,6 @@ MODFILES = \
fms_diag_field_object_mod.$(FC_MODEXT) \
fms_diag_object_mod.$(FC_MODEXT) \
fms_diag_axis_object_mod.$(FC_MODEXT) \
- fms_diag_dlinked_list_mod.$(FC_MODEXT) \
- fms_diag_object_container_mod.$(FC_MODEXT) \
fms_diag_output_buffer_mod.$(FC_MODEXT) \
fms_diag_input_buffer_mod.$(FC_MODEXT) \
diag_manager_mod.$(FC_MODEXT) \
diff --git a/diag_manager/fms_diag_dlinked_list.F90 b/diag_manager/fms_diag_dlinked_list.F90
deleted file mode 100644
index c220ef62e2..0000000000
--- a/diag_manager/fms_diag_dlinked_list.F90
+++ /dev/null
@@ -1,341 +0,0 @@
-!***********************************************************************
-!* 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 .
-!***********************************************************************
-
-!> @defgroup fms_diag_dlinked_list_mod fms_diag_dlinked_list_mod
-!> @ingroup diag_manager
-!> @brief fms_diag_dlinked_list_mod defines a generic doubly linked
-!! list class and an iterator class for traversing the list.
-!!
-!> @author Miguel Zuniga
-!!
-!! fms_diag_dlinked_list_mod defines a generic doubly linked
-!! list class and an iterator class for traversing the list. It is
-!! generic in the sense that the elements or objects it contains are
-!! "class(*)" objects. If additional typecheking or psossibly a
-!! slightly different user interface is desired, consider creating
-!! a wrapper or another class with this one for a memeber element and
-!! procedures that are trivially implemeted by using this class.
-!!
-!! This version is roughly a fortran translation of the C++ doubly linked list
-!! class in the book ``Data Structures And Algorithm Analysis in C++", 3rd Edition,
-!! by Mark Allen Weiss.
-
-!> @file
-!> @brief File for @ref fms_diag_dlinked_list_mod
-!> @addtogroup fms_diag_dlinked_list_mod
-!> @{
-MODULE fms_diag_dlinked_list_mod
- USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE
- implicit none
-
- private
-
- !> The doubly-linked list node type.
- type, public:: FmsDlListNode_t
- private
- class(*), pointer :: data_ptr => null() !< The data pointed to by the node.
- type(FmsDlListNode_t), pointer :: next => null() !< A pointer to the previous node.
- type(FmsDlListNode_t), pointer :: prev => null() !< A pointer to the next node.
- end type FmsDlListNode_t
-
- !> Linked list iterator
- type, public :: FmsDllIterator_t
- private
- type(FmsDlListNode_t), pointer :: current=>null() !< A pointer to the current node.
- type(FmsDlListNode_t), pointer :: end =>null() !< A sentinel (non-data) node.
- contains
- procedure :: has_data => literator_has_data !< Function returns true if there is data in the iterator.
- procedure :: next => literator_next !< Function moves the iterator to the next data element. Used in
- !< conjunction with function has_data().
- procedure :: get => literator_data !< Function return a pointer to the current data. Used in conjunction
- !< with function has_data().
- procedure :: get_current_node_pointer => get_current_node_ptr !< Return the current node pointer.
- end type FmsDllIterator_t
-
- !> The doubly-linked list type. Besides the member functions, see the
- !! associated iterator class ( FmsDllIterator_t) for traversal, and note that
- !! the default constructor is overriden with an interface of the same name.
- type, public :: FmsDlList_t
- private
- type(FmsDlListNode_t), pointer :: head=>null() !< The sentinal (non-data) head node of the linked list. .
- type(FmsDlListNode_t), pointer :: tail=>null() !< The sentinel (non-data) tail node of the linked list.
- integer :: the_size !< The number of data elements in the linked list.
- contains
- procedure :: push_back => push_at_back
- procedure :: pop_back => pop_at_back
- procedure :: remove => remove_node
- procedure :: get_literator => get_forward_literator
- procedure :: size => get_size
- procedure :: is_empty => is_size_zero
- procedure :: clear => clear_all
- procedure :: initialize => linked_list_initializer
- final :: destructor
- procedure :: insert => insert_data
-
- end type FmsDlList_t
-
- interface FmsDlList_t
- module procedure :: linked_list_constructor
- end interface FmsDlList_t
-
- interface FmsDllIterator_t
- module procedure :: literator_constructor
- end interface FmsDllIterator_t
-
-contains
-
- !> @brief Insert data d in a new node to be placed in front of the
- !! target node t_nd.
- !! @return Returns an iterator that starts with the newly inserted node.
- function insert_data( this, t_nd, d ) result(liter)
- class(FmsDlList_t), intent(in out) :: this ! d
- !! Insert nd into list so that list section [prev node <--> target node ] looks like
- !! [prev node <--> new nd <--> target node]. The four pointers pointing to and/or
- !! from "new nd" need to be set. Therefore :
- !! a) The new nd's prev needs to be whatever was the targets prev:
- nd%prev => t_nd%prev
- !! b) New node nd's next is obviously the target node:
- nd%next => t_nd
- !! c) the next of the prev node needs to point to the new node nd:
- t_nd%prev%next => nd
- !! d) target node's prev needs to point to the new node :
- t_nd%prev => nd
- this%the_size = this%the_size + 1
- liter = FmsDllIterator_t(nd, this%tail)
- end function insert_data
-
- !> @brief Remove Node nd from the linked tree.
- !! @return Return the iterator that begins with the next node after nd, and ends with
- !! the list end node. Returns the list iterator if the node cannot be removed.
- function remove_node( this, nd ) result( litr)
- class(FmsDlList_t), intent(in out) :: this ! nd%next
- nd%next%prev => nd%prev
- deallocate(nd)
- this%the_size = this%the_size - 1
- else
- litr = this%get_literator()
- endif
- end function remove_node
-
-
- !> @brief Remove the tail (last data node) of the list.
- !! @return Returns an iterator to the remaining list.
- function pop_at_back (this ) result( liter )
- class(FmsDlList_t), intent(in out) :: this ! this%tail%prev
- liter = this%remove( nd )
- else
- liter = this%get_literator()
- endif
- end function pop_at_back
-
- !> @brief Push (insert) data at the end of the list
- !> @return Returns an iterator that starts at the tail of the list.
- function push_at_back( this, d ) result(litr)
- class(FmsDlList_t), intent(in out) :: this ! @brief Constructor for the linked list.
- !! @return Returns a newly allocated linked list instance.
- !! TODO: This function is not used since (observed on Intel compilers) with
- !! a finalize keyword on the destructor, when this function returns and ll
- !! goes out of scope, th allocations in initialized are undome
- !! whether ot not ll is declared a pointer or allocatable
- function linked_list_constructor () result (ll)
- type(FmsDlList_t), pointer :: ll !< The resultant linked list to be reutrned.
- allocate(ll)
- call ll%initialize()
- end function linked_list_constructor
-
- !> @brief Initializer for the linked list.
- !! @return Returns a newly allocated linked list instance.
- subroutine linked_list_initializer( this )
- class(FmsDlList_t), intent(inout) :: this ! this%tail
- this%tail%prev => this%head
- this%the_size = 0
- endif
- end subroutine linked_list_initializer
-
-
- !> @brief The list iterator constructor.
- !! @return Returns a newly allocated list iterator.
- function literator_constructor ( fnd, tnd ) result (litr)
- type (FmsDlListNode_t), pointer :: fnd
- !< The sentinal (non-data) "first node" of the iterator will be fnd
- type (FmsDlListNode_t), pointer :: tnd
- !< The sentinal (non-data) "last node" of the iterator will be tnd.
- type (FmsDllIterator_t), allocatable :: litr !< The resultant linked list to be reutrned.
- allocate(litr)
- litr%current => fnd
- litr%end => tnd
- end function literator_constructor
-
- !> @brief Getter for the size (the number of data elements) of the linked list.
- !! @return Returns the size of the lined list.
- function get_size (this) result (sz)
- class(FmsDlList_t), intent(in out) :: this
- ! @brief Determines if the size (number of data elements) of the list is zero.
-!! @return Returns true if there are zero (0) data elements in the list; false otherwise.
- function is_size_zero (this) result (r)
- class(FmsDlList_t), intent(in out) :: this
- ! @brief Create and return a new forward iterator for the list.
- !> @return Returns a forward iterator for the linked list.
- function get_forward_literator(this) result (litr)
- class(FmsDlList_t), intent(in) :: this ! @brief Determine if the iterator has data.
- !> @return Returns true iff the iterator has data.
- function literator_has_data( this ) result( r )
- class(FmsDllIterator_t), intent(in) :: this
- ! @brief Move the iterators current data node pointer to the next data node.
- !! @return Returns a status of 0 if succesful, -1 otherwise.
- function literator_next( this ) result( status )
- class(FmsDllIterator_t), intent(in out ) :: this
- integer :: status !< The returned status. Failure possible is if iterator does not have data.
- status = -1
- if(this%has_data() .eqv. .true.) then
- this%current => this%current%next
- status = 0
- endif
- end function literator_next
-
- !> @brief Get the current data object pointed to by the iterator.
- !! function does not allocate or assign the result if
- !! the user mistakenly called it without data present.
- !! @return Returns a pointer to the current data.
- function literator_data( this ) result( rd )
- class(FmsDllIterator_t), intent(in) :: this ! null()
- if (this%has_data() .eqv. .true.) then
- rd => this%current%data_ptr
- endif
- end function literator_data
-
- !> @brief Get the current data object pointed to by the iterator.
- !! function does not allocate or assign the result if
- !! the user mistakenly called it without data present.
- !! @return Returns a pointer to the current data.
- function get_current_node_ptr( this ) result( pn )
- class(FmsDllIterator_t), intent(in) :: this ! this%current
- end function get_current_node_ptr
-
- !> @brief Iterate over all the nodes and remove them. Also (by overridable default), it deallocates the
- !! client data associated with the nodes.
- subroutine clear_all( this, data_dealloc_flag)
- class(FmsDlList_t), intent(inout) :: this !null() !< A pointer to the data.
- logical :: data_dealloc_f !< Set to data_dealloc_flag if present, otherwise its .true.
- !
- data_dealloc_f = .true.
- if( PRESENT(data_dealloc_flag) ) then
- data_dealloc_f = data_dealloc_flag
- endif
- do while( this% the_size /= 0)
- nd => this%head%next
- pdata => nd%data_ptr
- iter = this%remove(nd)
- if(data_dealloc_f .eqv. .true.) then
- if (associated(pdata) .eqv. .false.) then
- call error_mesg ('fms_diag_dlinked_list', &
- 'In clear_all; linked node contains node with unassociated data pointer', &
- WARNING)
- else
- deallocate(pdata)
- endif
- endif
- end do
- end subroutine clear_all
-
- !> @brief A destructor that deallocates every node and each nodes data element. !Note
- !! that for the data elements to not be de-allocated, function clear() (or clear_all() )
- !! with the appropriate arguments must be called.
- subroutine destructor(this)
- type(FmsDlList_t) :: this !null()
- deallocate(this%tail)
- this%tail=>null()
- end subroutine destructor
-
-end module fms_diag_dlinked_list_mod
-!> @}
-! close documentation grouping
diff --git a/diag_manager/fms_diag_object_container.F90 b/diag_manager/fms_diag_object_container.F90
deleted file mode 100644
index cb582eb523..0000000000
--- a/diag_manager/fms_diag_object_container.F90
+++ /dev/null
@@ -1,294 +0,0 @@
-!***********************************************************************
-!* 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 .
-!***********************************************************************
-
-!> @defgroup fms_diag_object_container_mod fms_diag_object_container_mod
-!> @ingroup diag_manager
-!> @brief fms_diag_object_container_mod defines a container class and iterator class
-!! for inserting, removing and searching for fmsDiagField_type instances
-!!
-!> @author Miguel Zuniga
-!!
-!! fms_diag_object_container_mod defines a container for inserting, removing and
-!! searching for fmsDiagField_type instances. It also defined an iterator for
-!! the data in the container. The value returned by the fms_diag_object function get_id()
-!! is used for search key comparison.
-!!
-!! Most of the functions in class FmsDiagObjectContainer_t are simple wrappers over
-!! those of the underlying fms_doubly_linked_list_mod class. The find/search
-!! are a little more than that, and what FmsDiagObjectContainer_t provides over the
-!! underlying liked list is the search function, type checking, convenience, and a
-!! fixed user interface defined for the intended use.
-!!
-!> @file
-!> @brief File for @ref fms_diag_object_container_mod
-!> @addtogroup fms_diag_object_container_mod
-!> @{
-MODULE fms_diag_object_container_mod
-#ifdef use_yaml
- use fms_diag_field_object_mod, only: fmsDiagField_type
- USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE
-
- !! Since this version is based on the FDS linked list:
- use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t, FmsDlListNode_t
-
- implicit none
-
- private
-
- !> @brief A container of fmsDiagField_type instances providing insert, remove ,
- !! find/search, and size public member functions. Iterator is provided by
- !! the associated iterator class (see dig_obj_iterator class).
- !!
- !! This version does not enforce uniqueness of ID keys (I.e. it is not a set).
- !!
- type, public:: FmsDiagObjectContainer_t
- private
- TYPE (FmsDlList_t), pointer :: the_linked_list => null() !< This version based on the FDS linked_list.
- contains
- procedure :: insert => insert_diag_object
- procedure :: remove => remove_diag_object
- procedure :: find => find_diag_object
- procedure :: size => get_num_objects
- procedure :: iterator => get_iterator
- procedure :: initialize => container_initializer
- procedure :: clear => clear_all
- final :: destructor
- end type FmsDiagObjectContainer_t
-
-
- !> @brief Iterator used to traverse the objects of the container.
- type, public :: FmsDiagObjIterator_t
- private
- type(FmsDllIterator_t) :: liter !< This version based on the FDS linked_list (and its iterator).
- contains
- procedure :: has_data => literator_has_data !< Function returns true if there is data in the iterator.
- procedure :: next => literator_next !< Function moves the iterator to the next data element. Used in
- !< conjunction with function has_data().
- procedure :: get => literator_data !< Function return a pointer to the current data. Used in conjunction
- !< with function has_data().
- end type FmsDiagObjIterator_t
-
- interface FmsDiagObjIterator_t
- module procedure :: diag_obj_iterator_constructor
- end interface FmsDiagObjIterator_t
-
-
-contains
-
- !> @brief Returns an empty iterator if a diag object with this ID was not found.
- !! If the diag object was found, return an iterator with the current object being
- !! the found object, ad the last/anchor being the last/anchor of the container.
- !! Note that this routine can accept an optional iterator as input, which
- !! is useful for chaining searches, which may be needed if there are key duplicates.
- !! @return In iterator that starts from the inserted object.
- function find_diag_object (this, id , iiter) result (riter)
- class (FmsDiagObjectContainer_t), intent (in out) :: this
- ! riter%get()
- if(id == ptdo%get_id() ) then
- EXIT
- end if
- status = riter%next()
- end do
- end function find_diag_object
-
- !> @brief insert diagnostic object obj with given id.
- !! Objects are inserted at the back / end of the list
- !! This version of the container also enforces that the
- !! objects ID is equal the input id.
- !! @return A status of -1 if there was an error, and 0 otherwise.
- function insert_diag_object (this, id, obj) result (status)
- class (FmsDiagObjectContainer_t), intent (in out) :: this
- integer, intent (in) :: id !< The id of the object to insert.
- class(fmsDiagField_type) , intent (in out) :: obj !< The object to insert
- integer :: status !< The returned status. 0 for success.
- class(FmsDllIterator_t), allocatable :: tliter !< A temporary iterator.
-
- status = -1
- if ( id .ne. obj%get_id() ) then
- !!TODO: log error
- endif
- tliter = this%the_linked_list%push_back( obj )
- if(tliter%has_data() .eqv. .true. ) then
- status = 0
- endif
- end function
-
- !> @brief Remove and return the first object in the container with the corresponding id .
- !! Note that if the client code does not already have a reference to the object being
- !! removed, then the client may want to to use procedure find before using procedure remove.
- !! If procedure find is used, consider calling remove with the iterator returned from find.
- !! @return In iterator starting from the node that was following the removed node.
- function remove_diag_object (this, id, iiter ) result (riter)
- class (FmsDiagObjectContainer_t), intent (in out) :: this
- ! riter%liter%get_current_node_pointer()
- temp_liter = this%the_linked_list%remove( pn )
- riter = FmsDiagObjIterator_t(temp_liter)
- end function
-
- !> @brief Getter for the number of objects help in the container.
- !! @return Return the number of objects..
- function get_num_objects (this ) result (sz)
- class (FmsDiagObjectContainer_t), intent (in out) :: this
- !< The instance of the class that this function is bound to.
- integer :: sz !< The returned result - the number of objects in container.
- sz = this%the_linked_list%size()
- end function
-
-
- !> @brief Return an iterator for the objects in the container.
- !! @return An iterator for the objects in the container.
- function get_iterator (this) result (oliter)
- class (FmsDiagObjectContainer_t), intent (in) :: this
- ! @brief A consructor for a container's iterator.
- !! @return An for a container's iterator.
- function diag_obj_iterator_constructor( iliter ) result (diag_itr)
- class (FmsDllIterator_t), allocatable :: iliter
- !< An iterator. Normally the one that the container is based on.
- class (FmsDiagObjIterator_t), allocatable :: diag_itr !< The returned diag object iterator.
- allocate(diag_itr)
- diag_itr%liter = iliter;
- end function diag_obj_iterator_constructor
-
- !> @brief The default consructor for the container.
- !! @return Returns a container.
- function diag_object_container_constructor () result (doc)
- type(FmsDiagObjectContainer_t), allocatable :: doc !< The resultant container.
- allocate(doc)
- doc%the_linked_list => null()
- allocate(doc%the_linked_list)
- call doc%the_linked_list%initialize
- end function diag_object_container_constructor
-
- subroutine container_initializer( this )
- class(FmsDiagObjectContainer_t), intent(inout) :: this
- if( associated(this%the_linked_list) ) then
- call error_mesg('fms_diag_object_container:','container is already initialized', WARNING)
- else
- allocate(this%the_linked_list)
- call this%the_linked_list%initialize()
- endif
- end subroutine container_initializer
-
- !> @brief Determines if there is more data that can be accessed via the iterator.
- !> @return Returns true iff more data can be accessed via the iterator.
- function literator_has_data( this ) result( r )
- class(FmsDiagObjIterator_t), intent(in) :: this
- ! @brief Move the iterator to the next object.
- !! @return Returns a status 0 if sucessful, or -1 if failed.
- function literator_next( this ) result( status )
- class(FmsDiagObjIterator_t), intent(in out ) :: this
- ! @brief Get the current data the iterator is pointing to.
- !! Note the common use case is to call function has_data to decide if
- !! this function should be called (again).
- !! @return Returns a pointer to the current data.
- function literator_data( this ) result( rdo )
- class(FmsDiagObjIterator_t), intent(in) :: this
- ! null()
- gp => this%liter%get()
- select type(gp)
- type is (fmsDiagField_type) !! "type is", not the (polymorphic) "class is"
- rdo => gp
- class default
- call error_mesg ('fms_diag_object_container:', &
- 'In literator_data, data to be accessed is not of expected type.',FATAL)
- end select
- end function literator_data
-
- !> @brief Iterate over all the nodes and remove them. Also (by overridable default), it deallocates the
- !! client data associated with the nodes.
- subroutine clear_all( this, data_dealloc_flag )
- class(FmsDiagObjectContainer_t), intent(inout) :: this ! @brief A destructor that deallocates every node and each nodes data element. !Note
- !! that for the data elements to not be de-allocated, function clear() with the
- !! appropriate arguments must be called.
- subroutine destructor(this)
- type(FmsDiagObjectContainer_t) :: this
- !null()
- end subroutine destructor
-
-#endif
-end module fms_diag_object_container_mod
-!> @}
-! close documentation grouping
-
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index ea251f291f..951f815e1f 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -29,7 +29,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
# Build this test program.
check_PROGRAMS = test_diag_manager test_diag_manager_time \
- test_diag_dlinked_list test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
+ test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
check_time_min check_time_max check_time_sum check_time_avg
@@ -38,7 +38,6 @@ test_diag_manager_SOURCES = test_diag_manager.F90
test_diag_manager_time_SOURCES = test_diag_manager_time.F90
test_diag_update_buffer_SOURCES= test_diag_update_buffer.F90
test_diag_yaml_SOURCES = test_diag_yaml.F90
-test_diag_dlinked_list_SOURCES = test_diag_dlinked_list.F90
test_diag_ocean_SOURCES = test_diag_ocean.F90
test_modern_diag_SOURCES = test_modern_diag.F90
test_diag_buffer_SOURCES= test_diag_buffer.F90
diff --git a/test_fms/diag_manager/test_diag_dlinked_list.F90 b/test_fms/diag_manager/test_diag_dlinked_list.F90
deleted file mode 100644
index 5fbd4a8356..0000000000
--- a/test_fms/diag_manager/test_diag_dlinked_list.F90
+++ /dev/null
@@ -1,225 +0,0 @@
-!***********************************************************************
-!* 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 .
-!***********************************************************************
-
-!! fms_diag_dlinked_list_mod defines a generic doubly linked
-!! list class and an associated iterator class for traversing the list. It
-!! is generic in the sense that the elements or objects it contains are
-!! "class(*)" objects. Note the public interface functions and the lack
-!! of a search (or find) function as per the definition of a linked list.
-!! If a search function, additional type cheeking, or possibly a
-!! slightly different user interface is desired, then consider creating
-!! another iterator and another wrapper, or another class with this one for
-!! a member element and procedures that are trivially implemented by using
-!! this class. (See, for example, class FmsDiagObjectContainer_t and its
-!! associated iterator.
-!!
-!! This version is roughly a Fortran translation of the C++ doubly linked list
-!! class in the book ``Data Structures And Algorithm Analysis in C++",
-!! 3rd Edition, by Mark Allen Weiss.
-program test_diag_dlinked_list
- use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated
- use fms_mod, ONLY: error_mesg, FATAL,NOTE
- use fms_diag_object_mod, only : fmsDiagObject_type
- use fms_diag_dlinked_list_mod, only : FmsDlList_t, FmsDllIterator_t
-
- implicit none
-
- !> @brief This class is the type for the data to insert in the linked list.
- type TestDummy_t
- integer :: id = 0
- real :: weight = 1000
- end type TestDummy_t
-
- !!
- type (FmsDlList_t), allocatable :: list !< Instance of the linked list
- class(FmsDllIterator_t), allocatable :: iter !< An iterator for the list
- type (TestDummy_t), pointer:: p_td_obj !< A pointer to a test_dummy object
- class(*), pointer :: p_obj !< A pointer to a class(*) object
- integer, parameter :: num_objs = 40 !< Total number of objects tested
- integer :: full_id_sum !< Sum of all the possible object id values
- integer :: sum !< Temp sum of vaalues of id sets
- !!
- integer :: ierr !< An error flag
- logical :: test_passed !< Flag indicating if the test_passed
- !! These fields below used to initialize diag object data. TBD
- integer :: id
- !!
-
- call mpp_init(mpp_init_test_requests_allocated)
- call mpp_set_stack_size(145746)
-
- call error_mesg("test_diag_linked_list", "Starting tests",NOTE)
-
- test_passed = .true. !! will be set to false if there are any issues.
-
- !! Ids will initially be from 1 to num_objs, so :
- full_id_sum = (num_objs * (num_objs + 1)) / 2
-
- !! Create the list
- allocate(list)
- call list%initialize()
-
- if( list%size() /= 0) then
- test_passed = .false.
- call error_mesg("test_diag_linked_list", "list incorrect size. Expected 0 at start",FATAL)
- endif
-
- !! Initialize num_objs objects and insert into list one at a time.
- !! The loop iterator is same as id - created in order to facilitate
- !! some tests.
- do id = 1, num_objs
- !!Allocate on heap another test dummy object :
- allocate (p_td_obj)
- !! And set some of its dummy data :
- p_td_obj%id = id
- p_td_obj%weight = id + 1000
- !! And have the "Char(*) pointer also point to it:
- p_obj => p_td_obj
-
- !! Test insertion the common way :
- iter = list%push_back( p_obj)
- if(iter%has_data() .eqv. .false. ) then
- test_passed = .false.
- call error_mesg("test_diag_dlinked_list", "List push_back error.",FATAL)
- endif
-
- enddo
-
- if( list%size() /= num_objs) then
- test_passed = .false.
- call error_mesg("test_diag_dlinked_list", "List has incorrect size after inserts.",FATAL)
- endif
-
-
- !! Test iteration over the entire list :
- sum = 0
- sum = sum_ids_in_list ( list )
-
- if( sum /= full_id_sum) then
- test_passed = .false.
- call error_mesg("test_diag_dlinked_list", &
- &"Id sums via iteration over the list objects is not as expected",FATAL)
- endif
-
- if( list%size() /= num_objs) then
- test_passed = .false.
- call error_mesg("test_diag_dlinked_list", &
- &"The list size is not as expected post inserts.",FATAL)
- endif
-
- !! Test a removal from the back (id should be num_objs)
- p_obj => find_back_of_list( list)
- iter = list%pop_back()
- !! Note the client is resposible for managing memory of anything he explicitly
- !! removes from the list:
- deallocate(p_obj)
- sum = sum_ids_in_list ( list )
- if( sum /= full_id_sum - num_objs ) then
- test_passed = .false.
- call error_mesg("test_diag_dlinked_list", &
- &"Id sums via iteration over the list objects is not as expected",FATAL)
- endif
-
- !! Repeat - test removal from the back of list (should be (num_objs -1)).
- p_obj => find_back_of_list( list)
- iter = list%pop_back()
- !! Note the client is resposible for managing memory of anything he explicitly
- !! removes from the list:
- deallocate(p_obj)
- sum = sum_ids_in_list ( list )
- if( sum /= (full_id_sum - num_objs - (num_objs -1) )) then
- test_passed = .false.
- call error_mesg("test_diag_dlinked_list", &
- & "Id sums via iteration over the list objects is not as expected",FATAL)
- endif
-
- !! List.clear() is called by the destructor automatically, but for further testing
- !! we will use it to renove (and deallocate) the data nodes and associated data
- !! of the list.
- call list%clear()
- if( list%size() /= 0) then
- test_passed = .false.
- call error_mesg("test_diag_dlinked_list", &
- "List is incorrect size after clearing.",FATAL)
- endif
-
- !! Allocated objects are deallocated automatically, but one can aslo make the call.
- deallocate(list)
-
- call error_mesg('test_diag_dlinked_list', 'Test has finished',NOTE)
-
- call MPI_finalize(ierr)
-
-CONTAINS
-
- !> @brief Cast the "class(*) input data to the expected type.
- function get_typed_data( pci ) result( pdo )
- class(*), intent(in), pointer :: pci !< An input pointer to the class(*) data object.
- class(TestDummy_t), pointer :: pdo !< The resultant pointer to the expected underlying object type.
- !
- pdo => null()
- select type(pci)
- type is (TestDummy_t) !! "type is", not the (polymorphic) "class is"
- pdo => pci
- class default
- call error_mesg("test_diag_dlinked_list", &
- & "Data to access is not of expected type.",FATAL)
- end select
- end function get_typed_data
-
- !> Calcualte the sum of the ids.
- !! Exercises iteration over the list.
- function sum_ids_in_list (the_list) result (rsum)
- type (FmsDlList_t), intent(inout) , allocatable :: the_list !< The linked list instance
- integer :: rsum !< The resultant sum of ids
- class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list
- type (TestDummy_t), pointer:: p_td_obj => null() !< A pointer to a test_dummy object
- class(*), pointer :: p_obj => null() !< A pointer to a class(*) object
- integer :: ic_status !< A list insertion status.
- !!
- rsum = 0
- iter = the_list%get_literator()
- do while( iter%has_data() .eqv. .true.)
- p_obj => iter%get()
- p_td_obj => get_typed_data (p_obj )
- rsum = rsum + p_td_obj%id
- ic_status = iter%next()
- end do
- end function sum_ids_in_list
-
- !> Find the past object in list. This also is a kind of search function,
- !! so if the provided wrapper is not used, you have to write your own.
- !! @return a pointer the object at the end of the list, or null if none
- function find_back_of_list (the_list) result (pdo)
- type (FmsDlList_t), intent(inout) , allocatable ::the_list !< The linked list instance
- class(TestDummy_t), pointer :: pdo !< The resultant back of list,
- class(FmsDllIterator_t), allocatable :: iter !< An iterator over the list
- class(*), pointer :: p_obj => null() !< A pointer to a class(*) object
- integer :: ic_status !< A list insertion status.
- !!
- pdo=>null()
- iter = the_list%get_literator()
- do while( iter%has_data() .eqv. .true.)
- p_obj => iter%get()
- pdo => get_typed_data (p_obj )
- ic_status = iter%next()
- end do
- end function find_back_of_list
-
-end program test_diag_dlinked_list
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 449c3ed82f..1d5e8bf258 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -509,12 +509,6 @@ test_expect_success "Test the diag update_buffer (test $my_test_count)" '
mpirun -n 1 ../test_diag_update_buffer
'
-## uses some updated code but doesn't need flag
-my_test_count=`expr $my_test_count + 1`
-test_expect_success "test_diag_dlinked_list (test $my_test_count)" '
- mpirun -n 1 ../test_diag_dlinked_list
-'
-
## run tests that are ifdef'd out only if compiled with yaml
## otherwise just run the updated end to end to check for error
if [ -z "${skipflag}" ]; then
diff --git a/test_fms/diag_manager/test_diag_object_container.F90 b/test_fms/diag_manager/test_diag_object_container.F90
deleted file mode 100644
index b46b50bcc7..0000000000
--- a/test_fms/diag_manager/test_diag_object_container.F90
+++ /dev/null
@@ -1,238 +0,0 @@
-!***********************************************************************
-!* 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 .
-!***********************************************************************
-
-!> @brief This programs tests public member functions of the
-!! FmsDiagObjectContainer_t and FmsDiagObjIterator_t. As these two classes
-!! are largely wrappers to their underlying classes, it is also
-!! testing the underlying container and iterator classes. The container
-!! functions being tested are insert, remove, and size. The use of the iterators
-!! is also being tested.
-program test_diag_obj_container
- use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated
- use fms_mod, ONLY: error_mesg, FATAL,NOTE
-
- use fms_diag_object_mod, only : fmsDiagObject_type
- use fms_diag_object_container_mod, only : FmsDiagObjectContainer_t, FmsDiagObjIterator_t
- USE time_manager_mod, ONLY: time_type
-
- implicit none
- !!
- type (FmsDiagObjectContainer_t), allocatable :: container !< Instance of the container
- class(FmsDiagObjIterator_t), allocatable :: iter !< An iterator for the container
- type (fmsDiagObject_type), allocatable , target :: obj_vec(:) !< A vector of objects
- type (fmsDiagObject_type), pointer:: pobj !< A pointer to an object
- integer, parameter :: num_objs = 10 !< Total number of objects tested
- integer :: full_id_sum !< Sum of all the possible object id values
- integer :: sum !< Temp sum of vaalues of id sets
- !!
- integer :: ic_status !< A status flag returned from container functions
- integer :: ierr !< An error flag
- !!
- logical :: test_passed !< Flag indicating if the test_passed
- !! These fields below used to initialize diag object data. TBD
- integer :: id
- integer, dimension(2) :: axes
- TYPE(time_type) :: init_time
- !!type (diag_fields_type) :: diag_field
- character(:), allocatable :: mname, vname, mname_pre, vname_pre
- !!
-
-
- call mpp_init(mpp_init_test_requests_allocated)
- call mpp_set_stack_size(145746)
-
- call error_mesg('test_diag_object_container', 'Test has started',NOTE)
-
- test_passed = .true. !! will be set to false if there are any issues.
-
- !! Ids will initially be from 1 to num_objs, so :
- full_id_sum = (num_objs * (num_objs + 1)) / 2
-
- !!Create the container
- allocate(container)
- call container%initialize()
- !!In diag_manager, one module level container may be used instead of a local one like above.
-
-
- !! Allocate some test objects.
- !! NOTE: normally objects will be allocated one at a time with a stament like:
- !! allocate(pobj, source = fms_diag_object(argument list ))
- !! or via constructor like :
- !! pobj => fms_diag_object(argument list )
- !! Once the object ID is set, it should be inserted into the container and then the
- !! container will be considered the manager of that object and its memory (unless the object is removed).
- !! Since type fms_diag_obj doesn't have a proper constructor yet, well be lazy by making array of objects
- !! ( normal fixed size array the thing whose use we are replacing to begin with ) and consider these particular
- !! objects to not be managed by the container.
- allocate(obj_vec(num_objs))
-
- !! Initialize each object and isnert into container one at a time.
-
- if( container%size() /= 0) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Container incorrect size. Expected 0 at start',FATAL)
- endif
- mname_pre = "ATM"
- vname_pre = "xvar"
- do id = 1, num_objs
- call combine_str_int(mname_pre, id, mname)
- call combine_str_int(vname_pre, id, vname )
-
- pobj => obj_vec( id ) !!Note use of pointer to obj.
- call pobj%setID(id)
-
- call pobj%register ("test_mod", vname, axes, init_time, "a_long_name")
-
- !!Insert object into the container.
- ic_status = container%insert(pobj%get_id(), pobj)
- if(ic_status .ne. 0)then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Container Insertion error.',FATAL)
- endif
- enddo
-
- if( container%size() /= num_objs) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Container has incorrect size after inserts.',FATAL)
- endif
-
- !!Search the container for a an object of specified key
- iter = container%find(123)
- if ( iter%has_data() .eqv. .true. ) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Found in container unexpected object of id=123',FATAL)
- endif
-
- !!Again, search the container for a an object of specified key
- iter = container%find(4)
- if (iter%has_data() .neqv. .true. ) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Did not find expected container object of id=4',FATAL)
- endif
-
- !! Iterate over all the objects in the container;
- sum = 0
- iter = container%iterator()
- do while( iter%has_data() .eqv. .true.)
- pobj => iter%get() !!Note use of pointer and pointer assignment is preferred.
- id = pobj%get_id( )
- !! vname = pobj%get_varname() !! print ...
- sum = sum + id
- ic_status = iter%next()
- end do
-
- if( sum /= full_id_sum) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Id sums via iteration over the container objects is not as expected',FATAL)
- endif
-
- if( container%size() /= num_objs) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'The container size is not as expected post inserts.',FATAL)
- endif
-
-
- !! Test a removal ****
- iter = container%iterator()
- iter = container%remove( 4, iter )
- iter = container%find(4)
- !! Verify the removal , part 1:
- if ( iter%has_data() .eqv. .true.) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Found object of id = 4 after removing it',FATAL)
- endif
- !! Verify the removal , part 2 :
- if (container%size() /= (num_objs - 1)) then
- test_passed = .false.
- call error_mesg('test_diag_object_container','The_container%size() \= num_obj -1 after a removal ',FATAL)
- endif
-
- !! Verify the removal , part 3 :
- !! Iterate over all the objects in the container AFTER the removal of id=4 object;
- sum = 0
- iter = container%iterator()
- do while( iter%has_data() .eqv. .true.)
- pobj => iter%get() !!Note use of pointer and pointer assignment is preferred.
- id = pobj%get_id( )
- !! vname = pobj%get_varname() !! print ...
- sum = sum + id
- ic_status = iter%next()
- end do
- if( sum /= full_id_sum - 4) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Container incorrect id sums post removal of 4',FATAL)
- endif
- !! End test a removal ****
-
- !! Test find and access object in the container
- iter = container%find(7)
- if (iter%has_data() .neqv. .true. ) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Container did not find object of id=7',FATAL)
- endif
- !! Check the find results more :
- pobj => iter%get()
- if(pobj%get_id() /= 7) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Id of returned object was not 7 ',FATAL)
- endif
- !!TODO further access tests.
-
-
- !! Manually clear out the container.
- !! NOTE: In normal use this is NOT PERFORMED since with its finalize function, the container
- !! deallocates all pointers and data it manages. However, the client needs to take care of
- !! the diag objects the client has decided that the container should not manage.
- !! In this wierd test case, all the diag objects were originally from a vector (a container itself!)
- !! and not allocated on the heap one at a time, so this step is needed before program completion.
- do id = 1, num_objs
- iter = container%find(id)
- if ( iter%has_data() .eqv. .true.) then
- iter = container%remove( id, iter )
- endif
- end do
-
- if( container%size() /= 0) then
- test_passed = .false.
- call error_mesg('test_diag_object_container', 'Container is incorrect size after clearing.',FATAL)
- endif
-
- !! And the container has a finalize/destructor which will deallocate the list and data.
- deallocate(container)
-
- call error_mesg('test_diag_object_container', 'Test has finished',NOTE)
-
-call MPI_finalize(ierr)
-
-CONTAINS
-
-subroutine combine_str_int (str, num, rs)
- character(:), allocatable, intent (in):: str
- integer , intent (in) :: num
- character(:), allocatable, intent (out) :: rs
- character(len_trim(str) + 8) :: tmp
-
- write (tmp, "(A4,I4)") str,num
- tmp = trim(tmp)
- rs = tmp
-end subroutine combine_str_int
-
-end program test_diag_obj_container
-
-
From 799a68746ca9e2e1282038b846390a64d1b1a907 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 18 Jan 2024 12:50:25 -0500
Subject: [PATCH 141/168] fix: Modern Diag Manager changes for reproducibility
(#1435)
---
diag_manager/fms_diag_axis_object.F90 | 36 +++++++++++++++++--
diag_manager/fms_diag_field_object.F90 | 28 ++++++++++++++-
diag_manager/fms_diag_file_object.F90 | 34 ++++++++++++++++--
diag_manager/fms_diag_object.F90 | 13 +++++--
diag_manager/fms_diag_output_buffer.F90 | 21 +++++++++++
test_fms/diag_manager/check_time_avg.F90 | 6 ++++
test_fms/diag_manager/test_modern_diag.F90 | 4 +--
.../diag_manager/test_reduction_methods.F90 | 2 ++
test_fms/diag_manager/test_time_avg.sh | 4 +++
9 files changed, 137 insertions(+), 11 deletions(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index e74ccabeff..0a913dc604 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -171,6 +171,8 @@ module fms_diag_axis_object_mod
INTEGER , private :: domain_position !< The position in the doman (NORTH, EAST or CENTER)
integer, allocatable , private :: structured_ids(:) !< If the axis is in the unstructured grid,
!! this is the axis ids of the structured axis
+ CHARACTER(len=:), ALLOCATABLE, private :: set_name !< Name of the axis set. This is to distinguish
+ !! two axis with the same name
contains
@@ -184,6 +186,8 @@ module fms_diag_axis_object_mod
PROCEDURE :: get_global_io_domain
PROCEDURE :: get_aux
PROCEDURE :: has_aux
+ PROCEDURE :: get_set_name
+ PROCEDURE :: has_set_name
! TO DO:
! Get/has/is subroutines as needed
END TYPE fmsDiagFullAxis_type
@@ -270,6 +274,8 @@ subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name,
if (present(aux)) this%aux = trim(aux)
if (present(req)) this%req = trim(req)
+ this%set_name = ""
+ if (present(set_name)) this%set_name = trim(set_name)
this%nsubaxis = 0
this%num_attributes = 0
@@ -604,6 +610,27 @@ pure function has_aux(this) &
if (allocated(this%aux)) rslt = trim(this%aux) .ne. ""
end function has_aux
+ !> @brief Determine if an axis object has a set_name
+ !! @return .true. if an axis object has a set_name
+ pure function has_set_name(this) &
+ result(rslt)
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
+ logical :: rslt
+
+ rslt = .false.
+ if (allocated(this%set_name)) rslt = trim(this%set_name) .ne. ""
+ end function has_set_name
+
+ !> @brief Get the set name of an axis object
+ !! @return the set name of an axis object
+ pure function get_set_name(this) &
+ result(rslt)
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
+ character(len=:), allocatable :: rslt
+
+ rslt = this%set_name
+ end function get_set_name
+
!> @brief Get the auxiliary name of an axis object
!! @return the auxiliary name of an axis object
pure function get_aux(this) &
@@ -1263,11 +1290,12 @@ end function parse_compress_att
!< @brief Determine the axis id of a axis
!! @return Axis id
- pure function get_axis_id_from_name(axis_name, diag_axis, naxis) &
+ pure function get_axis_id_from_name(axis_name, diag_axis, naxis, set_name) &
result(axis_id)
class(fmsDiagAxisContainer_type), intent(in) :: diag_axis(:) !< Array of axis object
character(len=*), intent(in) :: axis_name !< Name of the axis
integer, intent(in) :: naxis !< Number of axis that have been registered
+ character(len=*), intent(in) :: set_name !< Name of the axis set
integer :: axis_id
integer :: i !< For do loops
@@ -1277,8 +1305,10 @@ pure function get_axis_id_from_name(axis_name, diag_axis, naxis) &
select type(axis => diag_axis(i)%axis)
type is (fmsDiagFullAxis_type)
if (trim(axis%axis_name) .eq. trim(axis_name)) then
- axis_id = i
- return
+ if (trim(axis%set_name) .eq. trim(set_name)) then
+ axis_id = i
+ return
+ endif
endif
end select
enddo
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 380bcda31a..6ff8a96e87 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -173,6 +173,8 @@ module fms_diag_field_object_mod
procedure :: is_halo_present
procedure :: find_missing_value
procedure :: has_mask_allocated
+ procedure :: is_variable_in_file
+ procedure :: get_field_file_name
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagField_type) :: null_ob
@@ -1011,7 +1013,7 @@ pure function get_longname_to_write(this, field_yaml) &
endif
if (rslt .eq. "") then !! If the long name is not defined in the yaml and in the register_diag_field
!! use the variable name
- rslt = field_yaml%get_var_outname()
+ rslt = field_yaml%get_var_varname()
endif
end function get_longname_to_write
@@ -1743,5 +1745,29 @@ pure logical function has_mask_allocated(this)
has_mask_allocated = allocated(this%mask)
end function has_mask_allocated
+!> @brief Determine if the variable is in the file
+!! @return .True. if the varibale is in the file
+pure function is_variable_in_file(this, file_id) &
+result(res)
+ class(fmsDiagField_type), intent(in) :: this !< field object to check
+ integer, intent(in) :: file_id !< File id to check
+ logical :: res
+
+ integer :: i
+
+ res = .false.
+ if (any(this%file_ids .eq. file_id)) res = .true.
+end function is_variable_in_file
+
+!> @brief Determine the name of the first file the variable is in
+!! @return filename
+function get_field_file_name(this) &
+ result(res)
+ class(fmsDiagField_type), intent(in) :: this !< Field object to query
+ character(len=:), allocatable :: res
+
+ res = this%diag_field(1)%get_var_fname()
+end function get_field_file_name
+
#endif
end module fms_diag_field_object_mod
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 211d5519c7..8255f15652 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -47,7 +47,7 @@ module fms_diag_file_object_mod
use fms_diag_field_object_mod, only: fmsDiagField_type
use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_type
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, &
- uppercase, lowercase
+ uppercase, lowercase, NOTE
implicit none
private
@@ -1162,6 +1162,13 @@ subroutine write_field_data(this, field_obj, buffer_obj)
if (diag_file%unlim_dimension_level .eq. 1) &
call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj)
else
+ if (.not. buffer_obj(diag_file%buffer_ids(i))%is_there_data_to_write()) then
+ ! Only print the error message once
+ if (diag_file%unlim_dimension_level .eq. 1) &
+ call mpp_error(NOTE, "Send data was never called. Writing fill values for variable "//&
+ field_obj(field_id)%get_varname()//" in mod "//field_obj(field_id)%get_modname())
+ cycle
+ endif
call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj, &
unlim_dim_level=diag_file%unlim_dimension_level)
endif
@@ -1386,6 +1393,8 @@ subroutine write_field_metadata(this, diag_field, diag_axis)
integer :: i !< For do loops
logical :: is_regional !< Flag indicating if the field is in a regional file
character(len=255) :: cell_measures !< cell_measures attributes for the field
+ logical :: need_associated_files !< .True. if the 'associated_files' global attribute is needed
+ character(len=255) :: associated_files !< Associated files attribute to add
is_regional = this%is_regional()
@@ -1396,19 +1405,38 @@ subroutine write_field_metadata(this, diag_field, diag_axis)
if (.not. diag_file%field_registered(i)) cycle !TODO do something else here
field_ptr => diag_field(diag_file%field_ids(i))
- !TODO I think if the area and the volume field are no in the same file, a global attribute containing the
- !the file that the fields are in needs to be added
cell_measures = ""
+ associated_files = ""
+ need_associated_files = .false.
if (field_ptr%has_area()) then
cell_measures = "area: "//diag_field(field_ptr%get_area())%get_varname(to_write=.true.)
+
+ !! Determine if the area field is already in the file. If it is not create the "associated_files" attribute
+ !! which contains the file name of the file the area field is in. This is needed for PP/fregrid.
+ if (.not. diag_field(field_ptr%get_area())%is_variable_in_file(diag_file%id)) then
+ need_associated_files = .true.
+ associated_files = "area: "//diag_field(field_ptr%get_area())%get_field_file_name()//".nc"
+ endif
endif
if (field_ptr%has_volume()) then
cell_measures = trim(cell_measures)//" volume: "//diag_field(field_ptr%get_volume())%get_varname(to_write=.true.)
+
+ !! Determine if the volume field is already in the file. If it is not create the "associated_files" attribute
+ !! which contains the file name of the file the volume field is in. This is needed for PP/fregrid.
+ if (.not. diag_field(field_ptr%get_volume())%is_variable_in_file(diag_file%id)) then
+ need_associated_files = .true.
+ associated_files = trim(associated_files)//&
+ " volume:"//diag_field(field_ptr%get_volume())%get_field_file_name()//".nc"
+ endif
endif
call field_ptr%write_field_metadata(fms2io_fileobj, diag_file%id, diag_file%yaml_ids(i), diag_axis, &
this%FMS_diag_file%get_file_unlimdim(), is_regional, cell_measures)
+
+ if (need_associated_files) &
+ call register_global_attribute(fms2io_fileobj, "associated_files", trim(ADJUSTL(associated_files)), &
+ str_len=len_trim(ADJUSTL(associated_files)))
enddo
end subroutine write_field_metadata
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 4d88d6a24d..8f513c1e66 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -775,8 +775,12 @@ subroutine fms_diag_do_io(this, is_end_of_run)
! loop through the buffers and finish reduction if needed
buff_loop: do ibuff=1, SIZE(buff_ids)
diag_buff => this%FMS_diag_output_buffers(buff_ids(ibuff))
- field_yaml => diag_yaml%get_diag_field_from_id(diag_buff%get_yaml_id())
+ field_yaml => diag_yaml%diag_fields(diag_buff%get_yaml_id())
diag_field => this%FMS_diag_fields(diag_buff%get_field_id())
+
+ ! Go away if there is no data to write
+ if (.not. diag_buff%is_there_data_to_write()) cycle
+
! sets missing value
mval = diag_field%find_missing_value(missing_val)
! time_average and greater values all involve averaging so need to be "finished" before written
@@ -899,6 +903,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
!< Go away if finished doing math for this buffer
if (buffer_ptr%is_done_with_math()) cycle
+ call buffer_ptr%set_send_data_called()
+
bounds_out = bounds
if (.not. using_blocking) then
!< Set output bounds to start at 1:size(buffer_ptr%buffer)
@@ -1045,6 +1051,7 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value)
class(*), intent(in) :: att_value(:) !< The attribute value to add
character(len=20) :: axis_names(2) !< Names of the uncompress axis
+ character(len=20) :: set_name !< Name of the axis set
integer :: uncmx_ids(2) !< Ids of the uncompress axis
integer :: j !< For do loops
#ifndef use_yaml
@@ -1067,8 +1074,10 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value)
!! and the ids of the axis and add it to the axis object so it can be written to netcdf files
!! that use this axis
axis_names = parse_compress_att(att_value)
+ set_name = ""
+ if (axis%has_set_name()) set_name = axis%get_set_name()
do j = 1, size(axis_names)
- uncmx_ids(j) = get_axis_id_from_name(axis_names(j), this%diag_axis, this%registered_axis)
+ uncmx_ids(j) = get_axis_id_from_name(axis_names(j), this%diag_axis, this%registered_axis, set_name)
if (uncmx_ids(j) .eq. diag_null) call mpp_error(FATAL, &
&"Error parsing the compress attribute for axis: "//trim(axis%get_axis_name())//&
&". Be sure that the axes in the compress attribute are registered")
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index eed366bee1..96163e30ae 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -54,6 +54,7 @@ module fms_diag_output_buffer_mod
integer :: field_id !< The id of the field the buffer belongs to
integer :: yaml_id !< The id of the yaml id the buffer belongs to
logical :: done_with_math !< .True. if done doing the math
+ logical :: send_data_called !< .True. if send_data has been called
type(time_type) :: time !< The last time the data was received
contains
@@ -65,6 +66,8 @@ module fms_diag_output_buffer_mod
procedure :: get_yaml_id
procedure :: init_buffer_time
procedure :: update_buffer_time
+ procedure :: is_there_data_to_write
+ procedure :: set_send_data_called
procedure :: is_done_with_math
procedure :: set_done_with_math
procedure :: write_buffer
@@ -180,6 +183,7 @@ subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurna
allocate(this%num_elements(n_samples))
this%num_elements = 0
this%done_with_math = .false.
+ this%send_data_called = .false.
allocate(this%buffer_dims(5))
this%buffer_dims(1) = buff_sizes(1)
this%buffer_dims(2) = buff_sizes(2)
@@ -658,5 +662,22 @@ pure function get_buffer_dims(this)
get_buffer_dims = this%buffer_dims(1:4)
end function
+!> @brief Determine if there is any data to write (i.e send_data has been called)
+!! @return .true. if there is data to write
+function is_there_data_to_write(this) &
+ result(res)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+
+ logical :: res
+
+ res = this%send_data_called
+end function
+
+!> @brief Sets send_data_called to .true.
+subroutine set_send_data_called(this)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+
+ this%send_data_called = .true.
+end subroutine set_send_data_called
#endif
end module fms_diag_output_buffer_mod
diff --git a/test_fms/diag_manager/check_time_avg.F90 b/test_fms/diag_manager/check_time_avg.F90
index 6a1d527537..e729619f77 100644
--- a/test_fms/diag_manager/check_time_avg.F90
+++ b/test_fms/diag_manager/check_time_avg.F90
@@ -78,6 +78,12 @@ program check_time_avg
call read_data(fileobj, "var0_avg", cdata_out(1,1,1,1), unlim_dim_level=ti)
call check_data_0d(cdata_out(1,1,1,1), ti)
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for IOnASphere - time_level:", string(ti)
+ call read_data(fileobj, "IOnASphere", cdata_out(1,1,1,1), unlim_dim_level=ti)
+ if (cdata_out(1,1,1,1) .ne. -666._r4_kind) &
+ call mpp_error(FATAL, "IOnASphere is not set to the expected value (_FillVal)")
+
cdata_out = -999_r4_kind
print *, "Checking answers for var1_avg - time_level:", string(ti)
call read_data(fileobj, "var1_avg", cdata_out(:,1,1,1), unlim_dim_level=ti)
diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90
index b39eb44594..f32b5c5dad 100644
--- a/test_fms/diag_manager/test_modern_diag.F90
+++ b/test_fms/diag_manager/test_modern_diag.F90
@@ -124,8 +124,8 @@ program test_modern_diag
Time = set_date(2,1,1,0,0,0)
! Register the diags axis
-id_x = diag_axis_init('x', x, 'point_E', 'x', long_name='point_E', Domain2=Domain)
-id_y = diag_axis_init('y', y, 'point_N', 'y', long_name='point_N', Domain2=Domain)
+id_x = diag_axis_init('x', x, 'point_E', 'x', long_name='point_E', Domain2=Domain, set_name="land")
+id_y = diag_axis_init('y', y, 'point_N', 'y', long_name='point_N', Domain2=Domain, set_name="land")
id_x3 = diag_axis_init('x3', x, 'point_E', 'x', Domain2=Domain_cube_sph)
id_y3 = diag_axis_init('y3', y, 'point_E', 'y', Domain2=Domain_cube_sph)
diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90
index d47d21895e..a3a20f909d 100644
--- a/test_fms/diag_manager/test_reduction_methods.F90
+++ b/test_fms/diag_manager/test_reduction_methods.F90
@@ -63,6 +63,7 @@ program test_reduction_methods
integer :: id_var2 !< diag_field id for 2d var
integer :: id_var3 !< diag_field id for 3d var
integer :: id_var4 !< diag_field id for 4d var
+ integer :: id_var999 !< diag_field id for a var that send_data is not called for
integer :: io_status !< Status after reading the namelist
type(block_control_type) :: my_block !< Returns instantiated @ref block_control_type
logical :: message !< Flag for outputting debug message
@@ -169,6 +170,7 @@ program test_reduction_methods
'mullions', missing_value = missing_value)
id_var4 = register_diag_field ('ocn_mod', 'var4', (/id_x, id_y, id_z, id_w/), Time, 'Var4d', &
'mullions', missing_value = missing_value)
+ id_var999 = register_diag_field ('ocn_mod', 'IOnASphere', Time, missing_value=missing_value)
!< Get the data domain indices (1 based)
isd1 = isc-isd+1
diff --git a/test_fms/diag_manager/test_time_avg.sh b/test_fms/diag_manager/test_time_avg.sh
index 7c9752231c..bc9c6601b9 100755
--- a/test_fms/diag_manager/test_time_avg.sh
+++ b/test_fms/diag_manager/test_time_avg.sh
@@ -66,6 +66,10 @@ diag_files:
reduction: average
zbounds: 2. 3.
kind: r4
+ - module: ocn_mod
+ var_name: IOnASphere
+ reduction: average
+ kind: r4
- file_name: test_avg_regional
time_units: hours
unlimdim: time
From 4243f7cc6d6549aa231f0c0de222140082771c8f Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Thu, 18 Jan 2024 13:50:11 -0500
Subject: [PATCH 142/168] feat: modern diag add pow and rms reductions (#1439)
---
diag_manager/fms_diag_object.F90 | 12 +
diag_manager/fms_diag_output_buffer.F90 | 9 +-
diag_manager/fms_diag_reduction_methods.F90 | 1 +
diag_manager/fms_diag_yaml.F90 | 4 +-
.../include/fms_diag_reduction_methods.inc | 19 +-
test_fms/diag_manager/Makefile.am | 8 +-
test_fms/diag_manager/check_time_pow.F90 | 245 ++++++++++++++++
test_fms/diag_manager/check_time_rms.F90 | 270 ++++++++++++++++++
.../diag_manager/test_reduction_methods.F90 | 15 +-
test_fms/diag_manager/test_time_pow.sh | 175 ++++++++++++
test_fms/diag_manager/test_time_rms.sh | 180 ++++++++++++
11 files changed, 922 insertions(+), 16 deletions(-)
create mode 100644 test_fms/diag_manager/check_time_pow.F90
create mode 100644 test_fms/diag_manager/check_time_rms.F90
create mode 100755 test_fms/diag_manager/test_time_pow.sh
create mode 100755 test_fms/diag_manager/test_time_rms.sh
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 8f513c1e66..a3edb2f9eb 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -993,7 +993,19 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
return
endif
case (time_power)
+ new_time = buffer_ptr%update_buffer_time(time)
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ bounds_in, bounds_out, missing_value, new_time, pow_value=field_yaml_ptr%get_pow_value())
+ if (trim(error_msg) .ne. "") then
+ return
+ endif
case (time_rms)
+ new_time = buffer_ptr%update_buffer_time(time)
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ bounds_in, bounds_out, missing_value, new_time, pow_value = 2)
+ if (trim(error_msg) .ne. "") then
+ return
+ endif
case (time_diurnal)
case default
error_msg = "The reduction method is not supported. "//&
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 96163e30ae..a4b39773ac 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -592,7 +592,7 @@ end function do_time_max_wrapper
!> @brief Does the time_sum reduction method on the buffer object
!! @return Error message if the math was not successful
function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value, &
- increase_counter) &
+ increase_counter, pow_value) &
result(err_msg)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
@@ -603,6 +603,9 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
logical, intent(in) :: increase_counter !< .True. if data has not been received for
!! time, so the counter needs to be increased
+ integer, optional, intent(in) :: pow_value !< power value, will calculate field_data^pow
+ !! before adding to buffer should only be
+ !! present if using pow reduction method
character(len=50) :: err_msg
!TODO This will be expanded for integers
@@ -612,7 +615,7 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
select type (field_data)
type is (real(kind=r8_kind))
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, &
- bounds_in, bounds_out, missing_value, increase_counter)
+ bounds_in, bounds_out, missing_value, increase_counter, pow=pow_value)
class default
err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)"
end select
@@ -620,7 +623,7 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
select type (field_data)
type is (real(kind=r4_kind))
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, bounds_in, bounds_out, &
- real(missing_value, kind=r4_kind), increase_counter)
+ real(missing_value, kind=r4_kind), increase_counter, pow=pow_value)
class default
err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)"
end select
diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90
index 801f6ba557..c2c26ee5f2 100644
--- a/diag_manager/fms_diag_reduction_methods.F90
+++ b/diag_manager/fms_diag_reduction_methods.F90
@@ -31,6 +31,7 @@ module fms_diag_reduction_methods_mod
use platform_mod, only: r8_kind, r4_kind
use fms_diag_bbox_mod, only: fmsDiagIbounds_type
use fms_string_utils_mod, only: string
+ use diag_data_mod, only: time_rms
use mpp_mod
implicit none
private
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 673a481a4e..b14b10103a 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -819,7 +819,7 @@ subroutine set_field_reduction(field, reduction_method)
pow_value = 0
ioerror = 0
if (index(reduction_method, "diurnal") .ne. 0) then
- READ (UNIT=reduction_method(8:LEN_TRIM(reduction_method)), FMT=*, IOSTAT=ioerror) n_diurnal
+ READ (reduction_method(8:LEN_TRIM(reduction_method)), FMT=*, IOSTAT=ioerror) n_diurnal
if (ioerror .ne. 0) &
call mpp_error(FATAL, "Error getting the number of diurnal samples from "//trim(reduction_method))
if (n_diurnal .le. 0) &
@@ -827,7 +827,7 @@ subroutine set_field_reduction(field, reduction_method)
& Check your entry for file:"//trim(field%var_varname)//" in file "//trim(field%var_fname))
field%var_reduction = time_diurnal
elseif (index(reduction_method, "pow") .ne. 0) then
- READ (UNIT=reduction_method(4:LEN_TRIM(reduction_method)), FMT=*, IOSTAT=ioerror) pow_value
+ READ (reduction_method(4:LEN_TRIM(reduction_method)), FMT=*, IOSTAT=ioerror) pow_value
if (ioerror .ne. 0) &
call mpp_error(FATAL, "Error getting the power value from "//trim(reduction_method))
if (pow_value .le. 0) &
diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc
index c443a945b4..4a2bed19e5 100644
--- a/diag_manager/include/fms_diag_reduction_methods.inc
+++ b/diag_manager/include/fms_diag_reduction_methods.inc
@@ -230,14 +230,16 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
!! time, so the counter needs to be increased
real(r8_kind),optional, intent(in) :: weight !< Weight applied to data_in before added to data_out
!! used for weighted averages, default 1.0
- real(FMS_TRM_KIND_),optional, intent(in) :: pow !< Used for pow reduction, adds field^pow to buffer
+ integer ,optional, intent(in) :: pow !< Used for pow(er) reduction,
+ !! calculates field_data^pow before adding to buffer
integer :: is_in, ie_in, js_in, je_in, ks_in, ke_in !< Starting and ending indices of each dimention for
!! the input buffer
integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for
!! the output buffer
integer :: i, j, k, l !< For looping
- real(FMS_TRM_KIND_) :: weight_loc, pow_loc !< local copies of optional arguments
+ real(FMS_TRM_KIND_) :: weight_loc !< local copy of optional weight
+ integer :: pow_loc !> local copy of optional pow value (set if using pow reduction)
integer, parameter :: kindl = FMS_TRM_KIND_ !< real kind size as set by macro
if(present(weight)) then
@@ -247,7 +249,7 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
endif
if(present(pow)) then
- pow_loc = weight
+ pow_loc = pow
else
pow_loc = 1.0_kindl
endif
@@ -307,7 +309,8 @@ subroutine SUM_UPDATE_DONE_(out_buffer_data, weight_sum, reduction_method, missi
real(FMS_TRM_KIND_), intent(inout) :: out_buffer_data(:,:,:,:,:) !< data buffer previously updated with
!! do_time_sum_update
real(r8_kind), intent(in) :: weight_sum !< sum of weights for averaging, provided via argument to send data
- integer, intent(in) :: reduction_method !< which reduction method to use, should be time_avg
+ integer, intent(in) :: reduction_method !< which reduction method to use
+ !! should always be one of time_avg, time_diurnal, or time_rms
real(FMS_TRM_KIND_), intent(in) :: missing_val !< missing value for masked elements
logical, intent(in) :: has_mask !< indicates if mask is used so missing values can be skipped
!! TODO replace conditional in the `where` with passed in and ajusted mask from the original call
@@ -324,5 +327,13 @@ subroutine SUM_UPDATE_DONE_(out_buffer_data, weight_sum, reduction_method, missi
/ weight_sum
endif
+ if(reduction_method .eq. time_rms .and. has_mask) then
+ where(out_buffer_data(:,:,:,:,1) .ne. missing_val)
+ out_buffer_data(:,:,:,:,1) = SQRT(out_buffer_data(:,:,:,:,1))
+ endwhere
+ else if(reduction_method .eq. time_rms) then
+ out_buffer_data(:,:,:,:,1) = SQRT(out_buffer_data(:,:,:,:,1))
+ endif
+
end subroutine
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 951f815e1f..56b1bd0573 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -31,7 +31,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
- check_time_min check_time_max check_time_sum check_time_avg
+ check_time_min check_time_max check_time_sum check_time_avg check_time_pow check_time_rms
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -48,6 +48,8 @@ check_time_min_SOURCES = testing_utils.F90 check_time_min.F90
check_time_max_SOURCES = testing_utils.F90 check_time_max.F90
check_time_sum_SOURCES = testing_utils.F90 check_time_sum.F90
check_time_avg_SOURCES = testing_utils.F90 check_time_avg.F90
+check_time_pow_SOURCES = testing_utils.F90 check_time_pow.F90
+check_time_rms_SOURCES = testing_utils.F90 check_time_rms.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
@@ -55,13 +57,13 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
# Run the test.
TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh \
- test_time_avg.sh
+ test_time_avg.sh test_time_pow.sh test_time_rms.sh
testing_utils.mod: testing_utils.$(OBJEXT)
# Copy over other needed files to the srcdir
EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \
- test_time_sum.sh test_time_avg.sh
+ test_time_sum.sh test_time_avg.sh test_time_pow.sh test_time_rms.sh
if USING_YAML
skipflag=""
diff --git a/test_fms/diag_manager/check_time_pow.F90 b/test_fms/diag_manager/check_time_pow.F90
new file mode 100644
index 0000000000..8c0f3d420a
--- /dev/null
+++ b/test_fms/diag_manager/check_time_pow.F90
@@ -0,0 +1,245 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Checks the output file after running test_reduction_methods using the "time_pow" reduction method
+!! Pow reductions are run with a different dataset to simplify checking
+!! Each element in sent arrays is just the sum of its indices
+program check_time_pow
+ use fms_mod, only: fms_init, fms_end, string
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file
+ use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file, NOTE
+ use platform_mod, only: r4_kind, r8_kind
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+
+ implicit none
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
+ type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
+ real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the 4th dimension
+ integer :: ti !< For looping through time levels
+ integer :: io_status !< Io status after reading the namelist
+ logical :: use_mask !< .true. if using masks
+ integer, parameter :: file_freq = 6 !< file frequency as set in diag_table.yaml
+ integer, parameter :: pow_value = 2 !< pow value as set in reduction method (ie. pow2)
+
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+ integer, parameter :: kindl = KIND(0.0) !< compile-time default kind size
+
+ namelist / test_reduction_methods_nml / test_case, mask_case
+
+ call fms_init()
+
+ read (input_nml_file, test_reduction_methods_nml, iostat=io_status)
+
+ select case(mask_case)
+ case (no_mask)
+ use_mask = .false.
+ case (logical_mask, real_mask)
+ use_mask = .true.
+ end select
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+
+ if (.not. open_file(fileobj, "test_pow.nc", "read")) &
+ call mpp_error(FATAL, "unable to open test_pow.nc")
+
+ if (.not. open_file(fileobj1, "test_pow_regional.nc.0004", "read")) &
+ call mpp_error(FATAL, "unable to open test_pow_regional.nc.0004")
+
+ if (.not. open_file(fileobj2, "test_pow_regional.nc.0005", "read")) &
+ call mpp_error(FATAL, "unable to open test_pow_regional.nc.0005")
+
+ cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw)
+
+ do ti = 1, 8
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var0_pow - time_level:", string(ti)
+ call read_data(fileobj, "var0_pow", cdata_out(1,1,1,1), unlim_dim_level=ti)
+ call check_data_0d(cdata_out(1,1,1,1), ti)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var1_pow - time_level:", string(ti)
+ call read_data(fileobj, "var1_pow", cdata_out(:,1,1,1), unlim_dim_level=ti)
+ call check_data_1d(cdata_out(:,1,1,1), ti)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var2_pow - time_level:", string(ti)
+ call read_data(fileobj, "var2_pow", cdata_out(:,:,1,1), unlim_dim_level=ti)
+ call check_data_2d(cdata_out(:,:,1,1), ti)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_pow - time_level:", string(ti)
+ call read_data(fileobj, "var3_pow", cdata_out(:,:,:,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(:,:,:,1), ti, .false.)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_Z - time_level:", string(ti)
+ call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(:,:,1:2,1), ti, .true., nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_pow in the first regional file- time_level:", string(ti)
+ call read_data(fileobj1, "var3_pow", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(1:4,1:3,1:2,1), ti, .true., nx_offset=77, ny_offset=77, nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_pow in the second regional file- time_level:", string(ti)
+ call read_data(fileobj2, "var3_pow", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(1:4,1:1,1:2,1), ti, .true., nx_offset=77, ny_offset=80, nz_offset=1)
+ enddo
+
+ call fms_end()
+
+contains
+
+ ! sent data set to:
+ ! buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = i + j + k + l
+ ! + time_index/100
+ ! sum of squares for 1..n can be calculated with:
+ ! P(n) = (n^3 / 3) + (n^2 / 2) + (n/6)
+ !> @brief Check that the 0d data read in is correct
+ subroutine check_data_0d(buffer, time_level)
+ real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer :: i, step_pow = 0 !< pow of time step increments to use in generating reference data
+
+ ! only one index(1,1,1,1) = sums to 4
+ buffer_exp = get_answer_from_index(4)
+
+ if (abs(buffer - buffer_exp) > 0.0) then
+ print *, "time_level", time_level, "expected", buffer_exp, "read", buffer
+ call mpp_error(FATAL, "Check_time_pow::check_data_0d:: Data is not correct")
+ endif
+ end subroutine check_data_0d
+
+ !> @brief Check that the 1d data read in is correct
+ subroutine check_data_1d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer :: step_sum !< pow of time step increments to use in generating reference data
+ integer :: ii, i, j, k, l !< For looping
+ integer :: n
+
+ ! 1d answer is
+ ! (((i * 1000 + 11) * frequency) + (sum of time steps)) / frequency
+ ! or
+ ! => (i * 1000 + 11) + (sum of time_steps/frequency/100)
+ do ii = 1, size(buffer, 1)
+ buffer_exp = get_answer_from_index(ii + 3)
+
+ if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii) - buffer_exp) > 0.0) then
+ print *, "i:", ii, "read in:", buffer(ii), "expected:", buffer_exp, "time level:", time_level
+ print *, "diff:", abs(buffer(ii) - buffer_exp)
+ call mpp_error(FATAL, "Check_time_pow::check_data_1d:: Data is not exact")
+ endif
+ enddo
+ end subroutine check_data_1d
+
+ !> @brief Check that the 2d data read in is correct
+ subroutine check_data_2d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer :: ii,i, j, k, l !< For looping
+ integer :: step_pow !< pow of time step increments to use in generating reference data
+
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ buffer_exp = get_answer_from_index(ii + j + 2)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j) - buffer_exp) > 0.0) then
+ print *, "indices:", ii, j, "expected:", buffer_exp, "read in:",buffer(ii, j)
+ call mpp_error(FATAL, "Check_time_pow::check_data_2d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ end subroutine check_data_2d
+
+ !> @brief Check that the 3d data read in is correct
+ subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ logical, intent(in) :: is_regional !< .True. if the variable is subregional
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer, optional, intent(in) :: nx_offset !< Offset in the x direction
+ integer, optional, intent(in) :: ny_offset !< Offset in the y direction
+ integer, optional, intent(in) :: nz_offset !< Offset in the z direction
+
+ integer :: ii, i, j, k, l !< For looping
+ integer :: nx_oset !< Offset in the x direction (local variable)
+ integer :: ny_oset !< Offset in the y direction (local variable)
+ integer :: nz_oset !< Offset in the z direction (local variable)
+ integer :: step_pow!< pow of time step increments to use in generating reference data
+
+ step_pow = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_pow = step_pow + i
+ enddo
+
+ nx_oset = 0
+ if (present(nx_offset)) nx_oset = nx_offset
+
+ ny_oset = 0
+ if (present(ny_offset)) ny_oset = ny_offset
+
+ nz_oset = 0
+ if (present(nz_offset)) nz_oset = nz_offset
+
+ ! 3d answer is
+ ! ((i * 1000 + j * 10 + k) * frequency) + (pow of time steps)
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do k = 1, size(buffer, 3)
+ buffer_exp = get_answer_from_index(ii + j + k + 1 + ny_oset + nx_oset + nz_oset)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j, k) - buffer_exp) > 0.0) then
+ print *, mpp_pe(),'indices:',ii, j, k, "read in:", buffer(ii, j, k), "expected:",buffer_exp
+ call mpp_error(FATAL, "Check_time_pow::check_data_3d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_3d
+
+ function get_answer_from_index(index_sum) &
+ result(answ)
+ integer, intent(in) :: index_sum !< sum of indices
+ real(r4_kind) :: answ
+ integer :: i
+ answ = 0
+ do i=1, file_freq
+ answ = answ + real(index_sum, r4_kind) ** 2.0
+ enddo
+ answ = answ / file_freq
+ end function
+
+end program
diff --git a/test_fms/diag_manager/check_time_rms.F90 b/test_fms/diag_manager/check_time_rms.F90
new file mode 100644
index 0000000000..5ac59845a0
--- /dev/null
+++ b/test_fms/diag_manager/check_time_rms.F90
@@ -0,0 +1,270 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Checks the output file after running test_reduction_methods using the "rms" reduction method
+program check_time_rms
+ use fms_mod, only: fms_init, fms_end, string
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file
+ use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file
+ use platform_mod, only: r4_kind, r8_kind
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+
+ implicit none
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
+ type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
+ real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the 4th dimension
+ integer :: i !< For looping
+ integer :: io_status !< Io status after reading the namelist
+ logical :: use_mask !< .true. if using masks
+ integer, parameter :: file_freq = 6
+ integer, parameter :: kindl = KIND(0.0)
+
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+
+ namelist / test_reduction_methods_nml / test_case, mask_case
+
+ call fms_init()
+
+ read (input_nml_file, test_reduction_methods_nml, iostat=io_status)
+
+ select case(mask_case)
+ case (no_mask)
+ use_mask = .false.
+ case (logical_mask, real_mask)
+ use_mask = .true.
+ end select
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+
+ if (.not. open_file(fileobj, "test_rms.nc", "read")) &
+ call mpp_error(FATAL, "unable to open test_rms.nc")
+
+ if (.not. open_file(fileobj1, "test_rms_regional.nc.0004", "read")) &
+ call mpp_error(FATAL, "unable to open test_rms_regional.nc.0004")
+
+ if (.not. open_file(fileobj2, "test_rms_regional.nc.0005", "read")) &
+ call mpp_error(FATAL, "unable to open test_rms_regional.nc.0005")
+
+ cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw)
+
+ do i = 1, 8
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var0_rms - time_level:", string(i)
+ call read_data(fileobj, "var0_rms", cdata_out(1,1,1,1), unlim_dim_level=i)
+ call check_data_0d(cdata_out(1,1,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var1_rms - time_level:", string(i)
+ call read_data(fileobj, "var1_rms", cdata_out(:,1,1,1), unlim_dim_level=i)
+ call check_data_1d(cdata_out(:,1,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var2_rms - time_level:", string(i)
+ call read_data(fileobj, "var2_rms", cdata_out(:,:,1,1), unlim_dim_level=i)
+ call check_data_2d(cdata_out(:,:,1,1), i)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_rms - time_level:", string(i)
+ call read_data(fileobj, "var3_rms", cdata_out(:,:,:,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var4_rms - time_level:", string(i)
+ call read_data(fileobj, "var4_rms", cdata_out(:,:,:,:), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,:,1), i, .false.)
+ call check_data_3d(cdata_out(:,:,:,2), i, .false.)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_Z - time_level:", string(i)
+ call read_data(fileobj, "var3_Z", cdata_out(:,:,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(:,:,1:2,1), i, .true., nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_rms in the first regional file- time_level:", string(i)
+ call read_data(fileobj1, "var3_rms", cdata_out(1:4,1:3,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(1:4,1:3,1:2,1), i, .true., nx_offset=77, ny_offset=77, nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_rms in the second regional file- time_level:", string(i)
+ call read_data(fileobj2, "var3_rms", cdata_out(1:4,1:1,1:2,1), unlim_dim_level=i)
+ call check_data_3d(cdata_out(1:4,1:1,1:2,1), i, .true., nx_offset=77, ny_offset=80, nz_offset=1)
+ enddo
+
+ call fms_end()
+
+contains
+
+ ! sent data set to:
+ ! buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = real(ii, kind=r8_kind)* 1000_r8_kind + &
+ ! real(j, kind=r8_kind)* 10_r8_kind + &
+ ! real(k, kind=r8_kind)
+ ! + time_index/100
+ !> @brief Check that the 0d data read in is correct
+ subroutine check_data_0d(buffer, time_level)
+ real(kind=r4_kind), intent(inout) :: buffer !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer :: i, step_avg = 0 !< avg of time step increments to use in generating reference data
+
+ ! avgs integers for decimal part of field input
+ ! ie. level 1 = 1+2+..+6
+ ! 2 = 7+8+..+12
+ step_avg = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_avg = step_avg + i
+ enddo
+
+ ! 0d answer is:
+ ! (1011 * frequency avg'd over )
+ ! + ( 1/100 * avg of time step increments )
+ buffer_exp = real((1000.0_r8_kind+10.0_r8_kind+1.0_r8_kind) * file_freq + &
+ real(step_avg,r8_kind)/100.0_r8_kind, kind=r4_kind)
+ buffer_exp = buffer_exp / file_freq
+
+ if (abs(buffer - buffer_exp) > 0.0) print *, "answer not exact for 0d, time:", time_level, &
+ " diff:", abs(buffer-buffer_exp)
+
+ if (abs(buffer - buffer_exp) > 1.0e-4) then
+ print *, "time_level", time_level, "expected", buffer_exp, "read", buffer
+ call mpp_error(FATAL, "Check_time_avg::check_data_0d:: Data is not correct")
+ endif
+ end subroutine check_data_0d
+
+ !> @brief Check that the 1d data read in is correct
+ subroutine check_data_1d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer :: step_sum !< avg of time step increments to use in generating reference data
+ integer :: ii, i, j, k, l !< For looping
+ integer :: n
+
+ step_sum = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_sum = step_sum + i
+ enddo
+
+ ! 1d answer is
+ ! (((i * 1000 + 11) * frequency) + (sum of time steps)) / frequency
+ ! or
+ ! => (i * 1000 + 11) + (sum of time_steps/frequency/100)
+ do ii = 1, size(buffer, 1)
+ buffer_exp = real( &
+ (real(ii, kind=r8_kind)*1000.0_r8_kind +11.0_r8_kind) + &
+ (real(step_sum, kind=r8_kind)/file_freq/100.0_r8_kind) &
+ , kind=r4_kind)
+
+ if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii) - buffer_exp) > 0.0) then
+ print *, "i:", ii, "read in:", buffer(ii), "expected:", buffer_exp, "time level:", time_level
+ print *, "diff:", abs(buffer(ii) - buffer_exp)
+ call mpp_error(FATAL, "Check_time_avg::check_data_1d:: Data is not correct")
+ endif
+ enddo
+ end subroutine check_data_1d
+
+ !> @brief Check that the 2d data read in is correct
+ subroutine check_data_2d(buffer, time_level)
+ real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer :: ii,i, j, k, l !< For looping
+ integer :: step_avg !< avg of time step increments to use in generating reference data
+
+ step_avg = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_avg = step_avg + i
+ enddo
+
+ ! 2d answer is
+ ! ((i * 1000 + j * 10 + 1) * frequency) + (avg of time steps)
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ buffer_exp = real(real(ii, kind=r8_kind)* 1000.0_kindl+ &
+ 10.0_kindl*real(j, kind=r8_kind)+1.0_kindl + &
+ real(step_avg, kind=r8_kind)/file_freq/100.0_r8_kind, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j) - buffer_exp) > 0.0) then
+ print *, "indices:", ii, j, "expected:", buffer_exp, "read in:",buffer(ii, j)
+ call mpp_error(FATAL, "Check_time_avg::check_data_2d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ end subroutine check_data_2d
+
+ !> @brief Check that the 3d data read in is correct
+ subroutine check_data_3d(buffer, time_level, is_regional, nx_offset, ny_offset, nz_offset)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ logical, intent(in) :: is_regional !< .True. if the variable is subregional
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer, optional, intent(in) :: nx_offset !< Offset in the x direction
+ integer, optional, intent(in) :: ny_offset !< Offset in the y direction
+ integer, optional, intent(in) :: nz_offset !< Offset in the z direction
+
+ integer :: ii, i, j, k, l !< For looping
+ integer :: nx_oset !< Offset in the x direction (local variable)
+ integer :: ny_oset !< Offset in the y direction (local variable)
+ integer :: nz_oset !< Offset in the z direction (local variable)
+ integer :: step_avg!< avg of time step increments to use in generating reference data
+
+ step_avg = 0
+ do i=(time_level-1)*file_freq+1, time_level*file_freq
+ step_avg = step_avg + i
+ enddo
+
+ nx_oset = 0
+ if (present(nx_offset)) nx_oset = nx_offset
+
+ ny_oset = 0
+ if (present(ny_offset)) ny_oset = ny_offset
+
+ nz_oset = 0
+ if (present(nz_offset)) nz_oset = nz_offset
+
+ ! 3d answer is
+ ! ((i * 1000 + j * 10 + k) * frequency) + (avg of time steps)
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do k = 1, size(buffer, 3)
+ buffer_exp = real(real(ii+nx_oset, kind=r8_kind)* 1000.0_kindl + &
+ 10.0_kindl*real(j+ny_oset, kind=r8_kind) + &
+ 1.0_kindl*real(k+nz_oset, kind=r8_kind) + &
+ real(step_avg, kind=r8_kind)/file_freq/100.0_kindl, kind=r4_kind)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j, k) - buffer_exp) > 0.0) then
+ print *, mpp_pe(),'indices:',ii, j, k, "read in:", buffer(ii, j, k), "expected:",buffer_exp
+ call mpp_error(FATAL, "Check_time_avg::check_data_3d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_3d
+end program
diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90
index a3a20f909d..0e7c18b8aa 100644
--- a/test_fms/diag_manager/test_reduction_methods.F90
+++ b/test_fms/diag_manager/test_reduction_methods.F90
@@ -87,8 +87,9 @@ program test_reduction_methods
!< Configuration parameters
integer :: test_case = test_normal !< Indicates which test case to run
integer :: mask_case = no_mask !< Indicates which masking option to run
+ logical :: use_pow_data = .false. !< uses simplified smaller dataset for the pow reduction to simplify checks
- namelist / test_reduction_methods_nml / test_case, mask_case
+ namelist / test_reduction_methods_nml / test_case, mask_case, use_pow_data
call fms_init
call set_calendar_type(JULIAN)
@@ -343,9 +344,14 @@ subroutine init_buffer(buffer, is, ie, js, je, nhalo)
do j = js, je
do k = 1, size(buffer, 3)
do l = 1, size(buffer,4)
- buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = real(ii, kind=r8_kind)* 1000_r8_kind + &
- real(j, kind=r8_kind)* 10_r8_kind + &
- real(k, kind=r8_kind)
+ if(.not. use_pow_data) then
+ buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = real(ii, kind=r8_kind)* 1000_r8_kind + &
+ real(j, kind=r8_kind)* 10_r8_kind + &
+ real(k, kind=r8_kind)
+ else
+ ! just sends the sum of indices for pow
+ buffer(ii-is+1+nhalo, j-js+1+nhalo, k, l) = ii + j + k + l
+ endif
enddo
enddo
enddo
@@ -358,6 +364,7 @@ subroutine set_buffer(buffer, time_index)
real(kind=r8_kind), intent(inout) :: buffer(:,:,:,:) !< Output buffer
integer, intent(in) :: time_index !< Time index
+ if(use_pow_data) return
buffer = nint(buffer) + real(time_index, kind=r8_kind)/100_r8_kind
end subroutine set_buffer
diff --git a/test_fms/diag_manager/test_time_pow.sh b/test_fms/diag_manager/test_time_pow.sh
new file mode 100755
index 0000000000..5e343de9bb
--- /dev/null
+++ b/test_fms/diag_manager/test_time_pow.sh
@@ -0,0 +1,175 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+cat <<_EOF > diag_table.yaml
+title: test_pow
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_pow
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var0
+ output_name: var0_pow
+ reduction: pow2
+ kind: r4
+ - module: ocn_mod
+ var_name: var1
+ output_name: var1_pow
+ reduction: pow2
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ output_name: var2_pow
+ reduction: pow2
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_pow
+ reduction: pow2
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_Z
+ reduction: pow2
+ zbounds: 2. 3.
+ kind: r4
+- file_name: test_pow_regional
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: latlon
+ corner1: 78. 78.
+ corner2: 78. 78.
+ corner3: 81. 81.
+ corner4: 81. 81.
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_pow
+ reduction: pow2
+ zbounds: 2. 3.
+ kind: r4
+_EOF
+
+# remove any existing files that would result in false passes during checks
+rm -f *.nc
+
+# tests with no mask, no openmp
+my_test_count=1
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n use_pow_data=.true. \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "pow" reduction method (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "pow" reduction method (test $my_test_count)" '
+ mpirun -n 1 ../check_time_pow
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n use_pow_data=.true.\n/" | cat > input.nml
+test_expect_success "Running diag_manager with "pow" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "pow" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_pow
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n use_pow_data=.true.\n/" | cat > input.nml
+test_expect_success "Running diag_manager with "pow" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "pow" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_pow
+'
+
+# openmp tests
+
+export OMP_NUM_THREADS=2
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n use_pow_data=.true.\n/" | cat > input.nml
+test_expect_success "Running diag_manager with "pow" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "pow" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 1 ../check_time_pow
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n use_pow_data=.true.\n/" | cat > input.nml
+test_expect_success "Running diag_manager with "pow" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "pow" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_pow
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n use_pow_data=.true.\n/" | cat > input.nml
+test_expect_success "Running diag_manager with "pow" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "pow" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_pow
+'
+
+# halo output and mask tests
+
+export OMP_NUM_THREADS=1
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n use_pow_data=.true.\n/" | cat > input.nml
+test_expect_success "Running diag_manager with "pow" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "pow" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 1 ../check_time_pow
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n use_pow_data=.true.\n/" | cat > input.nml
+test_expect_success "Running diag_manager with "pow" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "pow" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_pow
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n use_pow_data=.true.\n/" | cat > input.nml
+test_expect_success "Running diag_manager with "pow" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "pow" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_pow
+'
+fi
+test_done
diff --git a/test_fms/diag_manager/test_time_rms.sh b/test_fms/diag_manager/test_time_rms.sh
new file mode 100755
index 0000000000..8f3c526f77
--- /dev/null
+++ b/test_fms/diag_manager/test_time_rms.sh
@@ -0,0 +1,180 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+cat <<_EOF > diag_table.yaml
+title: test_rms
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_rms
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var0
+ output_name: var0_rms
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var1
+ output_name: var1_rms
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ output_name: var2_rms
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_rms
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var4
+ output_name: var4_rms
+ reduction: average
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_Z
+ reduction: average
+ zbounds: 2. 3.
+ kind: r4
+- file_name: test_rms_regional
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: latlon
+ corner1: 78. 78.
+ corner2: 78. 78.
+ corner3: 81. 81.
+ corner4: 81. 81.
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_rms
+ reduction: average
+ zbounds: 2. 3.
+ kind: r4
+_EOF
+
+# remove any existing files that would result in false passes during checks
+rm -f *.nc
+
+# tests with no mask, no openmp
+my_test_count=1
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 0 \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "rms" reduction method (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "rms" reduction method (test $my_test_count)" '
+ mpirun -n 1 ../check_time_rms
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "rms" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "rms" reduction method, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_rms
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n &test_reduction_methods_nml \n test_case = 0 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "rms" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "rms" reduction method, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_rms
+'
+
+# openmp tests
+
+export OMP_NUM_THREADS=2
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "rms" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "rms" reduction method with openmp (test $my_test_count)" '
+ mpirun -n 1 ../check_time_rms
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "rms" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "rms" reduction method with openmp, logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_rms
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "rms" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "rms" reduction method with openmp, real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_rms
+'
+
+# halo output and mask tests
+
+export OMP_NUM_THREADS=1
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "rms" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "rms" reduction method with halo output (test $my_test_count)" '
+ mpirun -n 1 ../check_time_rms
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "rms" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "rms" reduction method with halo output with logical mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_rms
+'
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n mask_case = 2 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "rms" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "rms" reduction method with halo output with real mask (test $my_test_count)" '
+ mpirun -n 1 ../check_time_rms
+'
+fi
+test_done
From 5228ba4951a0c35e24622a44532325a9dba4b0b1 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Thu, 18 Jan 2024 14:54:23 -0500
Subject: [PATCH 143/168] feat: modern diag add diurnal reduction (#1438)
---
diag_manager/fms_diag_field_object.F90 | 4 +-
diag_manager/fms_diag_file_object.F90 | 4 +-
diag_manager/fms_diag_object.F90 | 38 +-
diag_manager/fms_diag_output_buffer.F90 | 234 +++++++++---
diag_manager/fms_diag_reduction_methods.F90 | 2 +-
.../include/fms_diag_reduction_methods.inc | 52 ++-
test_fms/diag_manager/Makefile.am | 9 +-
test_fms/diag_manager/check_time_diurnal.F90 | 297 +++++++++++++++
test_fms/diag_manager/test_diag_buffer.F90 | 35 +-
test_fms/diag_manager/test_diag_diurnal.F90 | 353 ++++++++++++++++++
test_fms/diag_manager/test_diag_manager2.sh | 4 +-
test_fms/diag_manager/test_time_diurnal.sh | 138 +++++++
12 files changed, 1067 insertions(+), 103 deletions(-)
create mode 100644 test_fms/diag_manager/check_time_diurnal.F90
create mode 100644 test_fms/diag_manager/test_diag_diurnal.F90
create mode 100755 test_fms/diag_manager/test_time_diurnal.sh
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 6ff8a96e87..44958cefaa 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -1030,6 +1030,7 @@ subroutine get_dimnames(this, diag_axis, field_yaml, unlim_dimname, dimnames, is
integer :: i !< For do loops
integer :: naxis !< Number of axis for the field
class(fmsDiagAxisContainer_type), pointer :: axis_ptr !diag_axis(this%axis_ids(i), for convenience
+ character(len=23) :: diurnal_axis_name !< name of the diurnal axis
if (this%is_static()) then
naxis = size(this%axis_ids)
@@ -1062,7 +1063,8 @@ subroutine get_dimnames(this, diag_axis, field_yaml, unlim_dimname, dimnames, is
!< The second to last dimension is always the diurnal axis
if (field_yaml%has_n_diurnal()) then
- dimnames(naxis - 1) = 'time_of_day_'//int2str(field_yaml%get_n_diurnal())
+ WRITE (diurnal_axis_name,'(a,i2.2)') 'time_of_day_', field_yaml%get_n_diurnal()
+ dimnames(naxis - 1) = trim(diurnal_axis_name)
endif
!< The last dimension is always the unlimited dimensions
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 8255f15652..a69b8cabf1 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -1143,6 +1143,7 @@ subroutine write_field_data(this, field_obj, buffer_obj)
class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< Fileobj to write to
integer :: i !< For do loops
integer :: field_id !< The id of the field writing the data from
+ logical :: has_diurnal !< indicates if theres a diurnal axis to adjust for
diag_file => this%FMS_diag_file
fms2io_fileobj => diag_file%fms2io_fileobj
@@ -1162,6 +1163,7 @@ subroutine write_field_data(this, field_obj, buffer_obj)
if (diag_file%unlim_dimension_level .eq. 1) &
call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj)
else
+ has_diurnal = buffer_obj(diag_file%buffer_ids(i))%get_diurnal_sample_size() .gt. 1
if (.not. buffer_obj(diag_file%buffer_ids(i))%is_there_data_to_write()) then
! Only print the error message once
if (diag_file%unlim_dimension_level .eq. 1) &
@@ -1170,7 +1172,7 @@ subroutine write_field_data(this, field_obj, buffer_obj)
cycle
endif
call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj, &
- unlim_dim_level=diag_file%unlim_dimension_level)
+ unlim_dim_level=diag_file%unlim_dimension_level, is_diurnal=has_diurnal)
endif
enddo
endif
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index a3edb2f9eb..7ca2e5ee46 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -203,6 +203,7 @@ integer function fms_register_diag_field_obj &
class (fmsDiagFile_type), pointer :: fileptr !< Pointer to the diag_file
class (fmsDiagField_type), pointer :: fieldptr !< Pointer to the diag_field
class (fmsDiagOutputBuffer_type), pointer :: bufferptr !< Pointer to the output buffer
+ class (diagYamlFilesVar_type), pointer :: yamlfptr !< Pointer to yaml object to get the reduction method
integer, allocatable :: file_ids(:) !< The file IDs for this variable
integer :: i !< For do loops
integer, allocatable :: diag_field_indices(:) !< indices where the field was found in the yaml
@@ -238,6 +239,11 @@ integer function fms_register_diag_field_obj &
bufferptr => this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))
call bufferptr%set_field_id(this%registered_variables)
call bufferptr%set_yaml_id(fieldptr%buffer_ids(i))
+ ! check if diurnal reduction for this buffer and if so set the diurnal sample size
+ yamlfptr => diag_yaml%diag_fields(fieldptr%buffer_ids(i))
+ if( yamlfptr%get_var_reduction() .eq. time_diurnal) then
+ call bufferptr%set_diurnal_sample_size(yamlfptr%get_n_diurnal())
+ endif
call bufferptr%init_buffer_time(init_time)
enddo
@@ -847,7 +853,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
integer :: ids !< For looping through buffer ids
integer :: buffer_id !< Id of the buffer
integer :: file_id !< File id
- integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
+ integer, pointer :: axis_ids(:) !< Axis ids for the buffer
logical :: is_subregional !< .True. if the buffer is subregional
logical :: reduced_k_range !< .True. is the field is only outputing a section
!! of the z dimension
@@ -922,7 +928,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
!< Reset the bounds based on the reduced k range and subregional
is_subregional_reduced_k_range: if (is_subregional .or. reduced_k_range) then
- axis_ids = buffer_ptr%get_axis_ids()
+ call buffer_ptr%get_axis_ids(axis_ids)
block_in_subregion = .true.
axis_loops: do i = 1, size(axis_ids)
!< Move on if the block does not have any data for the subregion
@@ -953,7 +959,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
endif
end select
enddo axis_loops
- deallocate(axis_ids)
+ nullify(axis_ids)
!< Move on to the next buffer if the block does not have any data for the subregion
if (.not. block_in_subregion) cycle
endif is_subregional_reduced_k_range
@@ -1007,6 +1013,15 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
return
endif
case (time_diurnal)
+ if(.not. present(time)) call mpp_error(FATAL, &
+ "fms_diag_do_reduction:: time must be present when using diurnal reductions")
+ ! sets the diurnal index for reduction within the buffer object
+ call buffer_ptr%set_diurnal_section_index(time)
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ bounds_in, bounds_out, missing_value, .true.)
+ if (trim(error_msg) .ne. "") then
+ return
+ endif
case default
error_msg = "The reduction method is not supported. "//&
"Only none, min, max, sum, average, power, rms, and diurnal are supported."
@@ -1305,13 +1320,13 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
integer :: ndims !< Number of dimensions in the input field data
integer :: buffer_id !< Buffer index of FMS_diag_buffers
integer :: num_diurnal_samples !< Number of diurnal samples from diag_yaml
- integer :: axes_length(5) !< Length of each axis
+ integer :: axes_length(4) !< Length of each axis
integer :: i, j !< For looping
class(fmsDiagOutputBuffer_type), pointer :: ptr_diag_buffer_obj !< Pointer to the buffer class
class(DiagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields
- integer, allocatable :: axis_ids(:) !< Pointer to indices of axes of the field variable
+ integer, pointer :: axis_ids(:) !< Pointer to indices of axes of the field variable
integer :: var_type !< Stores type of the field data (r4, r8, i4, i8, and string) represented as an integer.
- character(len=128), allocatable :: var_name !< Field name to initialize output buffers
+ character(len=:), allocatable :: var_name !< Field name to initialize output buffers
logical :: is_scalar !< Flag indicating that the variable is a scalar
integer :: yaml_id !< Yaml id for the buffer
integer :: file_id !< File id for the buffer
@@ -1322,7 +1337,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
var_type = get_var_type(field_data(1, 1, 1, 1))
! Get variable/field name
- var_name = this%Fms_diag_fields(field_id)%get_varname()
+ var_name = this%FMS_diag_fields(field_id)%get_varname()
! Determine dimensions of the field
is_scalar = this%FMS_diag_fields(field_id)%is_scalar()
@@ -1337,7 +1352,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
ndims = 0
if (.not. is_scalar) then
- axis_ids = this%FMS_diag_output_buffers(buffer_id)%get_axis_ids()
+ call this%FMS_diag_output_buffers(buffer_id)%get_axis_ids(axis_ids)
ndims = size(axis_ids)
endif
@@ -1352,17 +1367,16 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
enddo
if (num_diurnal_samples .ne. 0) then
- axes_length(ndims + 1) = num_diurnal_samples
ndims = ndims + 1 !< Add one more dimension for the diurnal axis
endif
ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id)
- call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), ndims, axes_length(1:5), &
- this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples)
+ call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), ndims, axes_length(1:4), &
+ var_name, num_diurnal_samples)
call ptr_diag_buffer_obj%initialize_buffer(ptr_diag_field_yaml%get_var_reduction(), var_name)
- if (allocated(axis_ids)) deallocate(axis_ids)
enddo
+ nullify(axis_ids)
this%FMS_diag_fields(field_id)%buffer_allocated = .true.
#else
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index a4b39773ac..1ad9581868 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -27,7 +27,8 @@ module fms_diag_output_buffer_mod
#ifdef use_yaml
use platform_mod
use iso_c_binding
-use time_manager_mod, only: time_type, operator(==), operator(>)
+use time_manager_mod, only: time_type, operator(==), get_ticks_per_second, get_time, operator(>)
+use constants_mod, only: SECONDS_PER_DAY
use mpp_mod, only: mpp_error, FATAL, NOTE
use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8, get_base_time, MIN_VALUE, MAX_VALUE, EMPTY, &
time_min, time_max
@@ -54,6 +55,10 @@ module fms_diag_output_buffer_mod
integer :: field_id !< The id of the field the buffer belongs to
integer :: yaml_id !< The id of the yaml id the buffer belongs to
logical :: done_with_math !< .True. if done doing the math
+ integer :: diurnal_sample_size = -1 !< dirunal sample size as read in from the reduction method
+ !! ie. diurnal24 = sample size of 24
+ integer :: diurnal_section= -1 !< the diurnal section (ie 5th index) calculated from the current model
+ !! time and sample size if using a diurnal reduction
logical :: send_data_called !< .True. if send_data has been called
type(time_type) :: time !< The last time the data was received
@@ -85,6 +90,10 @@ module fms_diag_output_buffer_mod
procedure :: do_time_sum_wrapper
procedure :: diag_reduction_done_wrapper
procedure :: get_buffer_dims
+ procedure :: get_diurnal_sample_size
+ procedure :: set_diurnal_sample_size
+ procedure :: set_diurnal_section_index
+ procedure :: get_remapped_diurnal_data
end type fmsDiagOutputBuffer_type
! public types
@@ -139,17 +148,14 @@ subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurna
class(fmsDiagOutputBuffer_type), intent(inout), target :: this !< 5D buffer object
class(*), intent(in) :: buff_type !< allocates to the type of buff_type
integer, intent(in) :: ndim !< Number of dimension
- integer, intent(in) :: buff_sizes(5) !< dimension buff_sizes
+ integer, intent(in) :: buff_sizes(4) !< dimension buff_sizes
character(len=*), intent(in) :: field_name !< field name for error output
- integer, optional, intent(in) :: diurnal_samples !< number of diurnal samples
+ integer, intent(in) :: diurnal_samples !< number of diurnal samples
integer :: n_samples !< number of diurnal samples, defaults to 1
- if(present(diurnal_samples)) then
- n_samples = diurnal_samples
- else
- n_samples = 1
- endif
+ n_samples = MAX(1, diurnal_samples)
+ call this%set_diurnal_sample_size(n_samples)
this%ndim =ndim
if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer: buffer already allocated for field:" // &
@@ -157,22 +163,22 @@ subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurna
select type (buff_type)
type is (integer(kind=i4_kind))
allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
+ & n_samples))
this%weight_sum = 0.0_r4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
+ & n_samples))
this%weight_sum = 0.0_r8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
+ & n_samples))
this%weight_sum = 0.0_r4_kind
this%buffer_type = r4
type is (real(kind=r8_kind))
allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
- & buff_sizes(5)))
+ & n_samples))
this%weight_sum = 0.0_r8_kind
this%buffer_type = r8
class default
@@ -189,7 +195,7 @@ subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurna
this%buffer_dims(2) = buff_sizes(2)
this%buffer_dims(3) = buff_sizes(3)
this%buffer_dims(4) = buff_sizes(4)
- this%buffer_dims(5) = buff_sizes(5)
+ this%buffer_dims(5) = n_samples
end subroutine allocate_buffer
!> Get routine for 5D buffers.
@@ -291,19 +297,17 @@ subroutine add_axis_ids(this, axis_ids)
!> @brief Get the axis_ids for the buffer
!! @return Axis_ids, if the buffer doesn't have axis ids it returns diag_null
-function get_axis_ids(this) &
- result(res)
-
- class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
- integer, allocatable :: res(:)
+subroutine get_axis_ids(this, res)
+ class(fmsDiagOutputBuffer_type), target, intent(inout) :: this !< Buffer object
+ integer, pointer, intent(out) :: res(:)
if (allocated(this%axis_ids)) then
- res = this%axis_ids
+ res => this%axis_ids
else
allocate(res(1))
res = diag_null
endif
-end function
+end subroutine
!> @brief Get the field id of the buffer
!! @return the field id of the buffer
@@ -390,18 +394,20 @@ function get_yaml_id(this) &
end function get_yaml_id
!> @brief Write the buffer to the file
-subroutine write_buffer(this, fms2io_fileobj, unlim_dim_level)
+subroutine write_buffer(this, fms2io_fileobj, unlim_dim_level, is_diurnal)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
class(FmsNetcdfFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+ logical, optional, intent(in) :: is_diurnal !< should be set if using diurnal
+ !! reductions so buffer data can be remapped
select type(fms2io_fileobj)
type is (FmsNetcdfFile_t)
- call this%write_buffer_wrapper_netcdf(fms2io_fileobj, unlim_dim_level=unlim_dim_level)
+ call this%write_buffer_wrapper_netcdf(fms2io_fileobj, unlim_dim_level=unlim_dim_level, is_diurnal=is_diurnal)
type is (FmsNetcdfDomainFile_t)
- call this%write_buffer_wrapper_domain(fms2io_fileobj, unlim_dim_level=unlim_dim_level)
+ call this%write_buffer_wrapper_domain(fms2io_fileobj, unlim_dim_level=unlim_dim_level, is_diurnal=is_diurnal)
type is (FmsNetcdfUnstructuredDomainFile_t)
- call this%write_buffer_wrapper_u(fms2io_fileobj, unlim_dim_level=unlim_dim_level)
+ call this%write_buffer_wrapper_u(fms2io_fileobj, unlim_dim_level=unlim_dim_level, is_diurnal=is_diurnal)
class default
call mpp_error(FATAL, "The file "//trim(fms2io_fileobj%path)//" is not one of the accepted types"//&
" only FmsNetcdfFile_t, FmsNetcdfDomainFile_t, and FmsNetcdfUnstructuredDomainFile_t are accepted.")
@@ -413,77 +419,112 @@ subroutine write_buffer(this, fms2io_fileobj, unlim_dim_level)
end subroutine write_buffer
!> @brief Write the buffer to the FmsNetcdfFile_t fms2io_fileobj
-subroutine write_buffer_wrapper_netcdf(this, fms2io_fileobj, unlim_dim_level)
+subroutine write_buffer_wrapper_netcdf(this, fms2io_fileobj, unlim_dim_level, is_diurnal)
class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
type(FmsNetcdfFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
-
+ logical, optional, intent(in) :: is_diurnal !< should be set if using diurnal
+ !! reductions so buffer data can be remapped
character(len=:), allocatable :: varname !< name of the variable
+ logical :: using_diurnal !< local copy of is_diurnal if present
+ class(*), allocatable :: buff_ptr(:,:,:,:,:) !< pointer for buffer to write
+
+ using_diurnal = .false.
+ if( present(is_diurnal) ) using_diurnal = is_diurnal
+ if( using_diurnal ) then
+ call this%get_remapped_diurnal_data(buff_ptr)
+ else
+ buff_ptr = this%buffer
+ endif
varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
select case(this%ndim)
case (0)
- call write_data(fms2io_fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (1)
- call write_data(fms2io_fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (2)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
case (3)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
case (4)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
case (5)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_netcdf
!> @brief Write the buffer to the FmsNetcdfDomainFile_t fms2io_fileobj
-subroutine write_buffer_wrapper_domain(this, fms2io_fileobj, unlim_dim_level)
+subroutine write_buffer_wrapper_domain(this, fms2io_fileobj, unlim_dim_level, is_diurnal)
class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
type(FmsNetcdfDomainFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+ logical, optional, intent(in) :: is_diurnal !< should be set if using diurnal
+ !! reductions so buffer data can be remapped
character(len=:), allocatable :: varname !< name of the variable
+ logical :: using_diurnal !< local copy of is_diurnal if present
+ class(*), allocatable :: buff_ptr(:,:,:,:,:) !< pointer to buffer to write
+
+ using_diurnal = .false.
+ if( present(is_diurnal) ) using_diurnal = is_diurnal
+ if( using_diurnal ) then
+ call this%get_remapped_diurnal_data(buff_ptr)
+ else
+ buff_ptr = this%buffer
+ endif
varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
select case(this%ndim)
case (0)
- call write_data(fms2io_fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (1)
- call write_data(fms2io_fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (2)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
case (3)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
case (4)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
case (5)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_domain
!> @brief Write the buffer to the FmsNetcdfUnstructuredDomainFile_t fms2io_fileobj
-subroutine write_buffer_wrapper_u(this, fms2io_fileobj, unlim_dim_level)
+subroutine write_buffer_wrapper_u(this, fms2io_fileobj, unlim_dim_level, is_diurnal)
class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fms2io_fileobj !< fileobj to write to
integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension
+ logical, optional, intent(in) :: is_diurnal !< should be set if using diurnal
+ !! reductions so buffer data can be remapped
character(len=:), allocatable :: varname !< name of the variable
+ logical :: using_diurnal !< local copy of is_diurnal if present
+ class(*), allocatable :: buff_ptr(:,:,:,:,:) !< pointer for buffer to write
+
+ using_diurnal = .false.
+ if( present(is_diurnal) ) using_diurnal = is_diurnal
+ if( using_diurnal ) then
+ call this%get_remapped_diurnal_data(buff_ptr)
+ else
+ buff_ptr = this%buffer
+ endif
varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname()
select case(this%ndim)
case (0)
- call write_data(fms2io_fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(1,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (1)
- call write_data(fms2io_fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,1,1,1,1), unlim_dim_level=unlim_dim_level)
case (2)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,1,1,1), unlim_dim_level=unlim_dim_level)
case (3)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,1,1), unlim_dim_level=unlim_dim_level)
case (4)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,1), unlim_dim_level=unlim_dim_level)
case (5)
- call write_data(fms2io_fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
+ call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,:), unlim_dim_level=unlim_dim_level)
end select
end subroutine write_buffer_wrapper_u
@@ -506,7 +547,7 @@ function do_time_none_wrapper(this, field_data, mask, is_masked, bounds_in, boun
type is (real(kind=r8_kind))
select type (field_data)
type is (real(kind=r8_kind))
- call do_time_none(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, missing_value)
+ call do_time_none(output_buffer, field_data, mask, is_masked, bounds_in, bounds_out, missing_value)
class default
err_msg="do_time_none_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)"
end select
@@ -615,7 +656,8 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
select type (field_data)
type is (real(kind=r8_kind))
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, &
- bounds_in, bounds_out, missing_value, increase_counter, pow=pow_value)
+ bounds_in, bounds_out, missing_value, increase_counter, this%diurnal_section, &
+ pow=pow_value)
class default
err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)"
end select
@@ -623,7 +665,7 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
select type (field_data)
type is (real(kind=r4_kind))
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, bounds_in, bounds_out, &
- real(missing_value, kind=r4_kind), increase_counter, pow=pow_value)
+ real(missing_value, kind=r4_kind), increase_counter, this%diurnal_section, pow=pow_value)
class default
err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)"
end select
@@ -650,9 +692,10 @@ function diag_reduction_done_wrapper(this, reduction_method, missing_value, has_
err_msg = ""
select type(buff => this%buffer)
type is (real(r8_kind))
- call time_update_done(buff, this%weight_sum, reduction_method, missing_value, has_mask)
+ call time_update_done(buff, this%weight_sum, reduction_method, missing_value, has_mask, this%diurnal_sample_size)
type is (real(r4_kind))
- call time_update_done(buff, this%weight_sum, reduction_method, real(missing_value, r4_kind), has_mask)
+ call time_update_done(buff, this%weight_sum, reduction_method, real(missing_value, r4_kind), has_mask, &
+ this%diurnal_sample_size)
end select
this%weight_sum = 0.0_r8_kind
@@ -660,11 +703,98 @@ function diag_reduction_done_wrapper(this, reduction_method, missing_value, has_
!> this leaves out the diurnal index cause its only used for tmp mask allocation
pure function get_buffer_dims(this)
- class(fmsDiagOutputBuffer_type), intent(in) :: this
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to get from
integer :: get_buffer_dims(4)
get_buffer_dims = this%buffer_dims(1:4)
end function
+!> Get diurnal sample size (amount of diurnal sections)
+pure integer function get_diurnal_sample_size(this)
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to get from
+ get_diurnal_sample_size = this%diurnal_sample_size
+end function get_diurnal_sample_size
+
+!> Set diurnal sample size (amount of diurnal sections)
+subroutine set_diurnal_sample_size(this, sample_size)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to set sample size for
+ integer, intent(in) :: sample_size !< sample size to used to split daily
+ !! data into given amount of sections
+ this%diurnal_sample_size = sample_size
+end subroutine set_diurnal_sample_size
+
+!> Set diurnal section index based off the current time and previously set diurnal_samplesize
+!! Calculates which diurnal section of daily data the current time is in
+subroutine set_diurnal_section_index(this, time)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to set diurnal index for
+ type(time_type), intent(in) :: time !< current model time
+ integer :: seconds, days, ticks
+
+ if(this%diurnal_sample_size .lt. 0) call mpp_error(FATAL, "set_diurnal_section_index::"// &
+ " diurnal sample size must be set before trying to set diurnal index for send_data")
+
+ call get_time(time,seconds,days,ticks) ! get current date
+ ! calculates which diurnal section current time is in for a given amount of diurnal sections(<24)
+ this%diurnal_section = floor( (seconds+real(ticks)/get_ticks_per_second()) &
+ & * this%diurnal_sample_size/SECONDS_PER_DAY) + 1
+end subroutine set_diurnal_section_index
+
+!> Remaps the output buffer array when using the diurnal reduction
+!! moves the diurnal index to the left-most unused dimension for the io
+subroutine get_remapped_diurnal_data(this, res)
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< output buffer object
+ class(*), intent(out), allocatable :: res(:,:,:,:,:) !< resulting remapped data
+ integer :: last_dim !< last dimension thats used
+ integer :: ie, je, ke, ze, de !< ending indices for the new array
+ integer(i4_kind) :: buff_size(5)!< sizes for allocated buffer
+
+ ! last dim is number of dimensions - 1 for diurnal axis
+ last_dim = this%ndim - 1
+ ! get the bounds of the remapped output array based on # of dims
+ ke = 1; ze = 1; de = 1
+ select case(last_dim)
+ case (1)
+ ie = this%buffer_dims(1); je = this%buffer_dims(5)
+ case (2)
+ ie = this%buffer_dims(1); je = this%buffer_dims(2)
+ ke = this%buffer_dims(5)
+ case (3)
+ ie = this%buffer_dims(1); je = this%buffer_dims(2)
+ ke = this%buffer_dims(3); ze = this%buffer_dims(5)
+ case (4)
+ ! no need to remap if 4d
+ res = this%buffer
+ return
+ end select
+
+ select type(buff => this%buffer)
+ type is (real(r8_kind))
+ allocate(real(r8_kind) :: res(1:ie, 1:je, 1:ke, 1:ze, 1:de))
+ select type(res)
+ type is (real(r8_kind))
+ res(1:ie, 1:je, 1:ke, 1:ze, 1:de) = reshape(buff, SHAPE(res))
+ end select
+ type is (real(r4_kind))
+ allocate(real(r4_kind) :: res(1:ie, 1:je, 1:ke, 1:ze, 1:de))
+ select type(res)
+ type is (real(r4_kind))
+ res(1:ie, 1:je, 1:ke, 1:ze, 1:de) = reshape(buff, SHAPE(res))
+ end select
+ type is (integer(i8_kind))
+ allocate(integer(i8_kind) :: res(1:ie, 1:je, 1:ke, 1:ze, 1:de))
+ select type(res)
+ type is (integer(i8_kind))
+ res(1:ie, 1:je, 1:ke, 1:ze, 1:de) = reshape(buff, SHAPE(res))
+ end select
+ type is (integer(i4_kind))
+ allocate(integer(i4_kind) :: res(1:ie, 1:je, 1:ke, 1:ze, 1:de))
+ select type(res)
+ type is (integer(i4_kind))
+ res(1:ie, 1:je, 1:ke, 1:ze, 1:de) = reshape(buff, SHAPE(res))
+ end select
+ end select
+
+end subroutine get_remapped_diurnal_data
+
!> @brief Determine if there is any data to write (i.e send_data has been called)
!! @return .true. if there is data to write
function is_there_data_to_write(this) &
diff --git a/diag_manager/fms_diag_reduction_methods.F90 b/diag_manager/fms_diag_reduction_methods.F90
index c2c26ee5f2..86fe98aedf 100644
--- a/diag_manager/fms_diag_reduction_methods.F90
+++ b/diag_manager/fms_diag_reduction_methods.F90
@@ -31,7 +31,7 @@ module fms_diag_reduction_methods_mod
use platform_mod, only: r8_kind, r4_kind
use fms_diag_bbox_mod, only: fmsDiagIbounds_type
use fms_string_utils_mod, only: string
- use diag_data_mod, only: time_rms
+ use diag_data_mod, only: time_diurnal, time_rms
use mpp_mod
implicit none
private
diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc
index 4a2bed19e5..dff061fc58 100644
--- a/diag_manager/include/fms_diag_reduction_methods.inc
+++ b/diag_manager/include/fms_diag_reduction_methods.inc
@@ -215,7 +215,7 @@ end subroutine DO_TIME_MAX_
!!
!! Where l are the indices passed in through the bounds_in/out
subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, bounds_in, bounds_out, &
- missing_value, increase_counter, weight, pow)
+ missing_value, increase_counter, diurnal_section, weight, pow)
real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
real(r8_kind), intent(inout) :: weight_sum !< Sum of weights from the output buffer object
real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
@@ -228,8 +228,11 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked
logical, intent(in) :: increase_counter !< .True. if data has not been received for
!! time, so the counter needs to be increased
- real(r8_kind),optional, intent(in) :: weight !< Weight applied to data_in before added to data_out
- !! used for weighted averages, default 1.0
+ integer, intent(in) :: diurnal_section !< the diurnal "section" if doing a diurnal reduction
+ !! indicates which index to add data on 5th axis
+ !! if not doing a diurnal reduction, this should always =1
+ real(r8_kind),optional, intent(in) :: weight !< Weight applied to data_in before added to data_out
+ !! used for weighted averages, default 1.0
integer ,optional, intent(in) :: pow !< Used for pow(er) reduction,
!! calculates field_data^pow before adding to buffer
@@ -241,6 +244,8 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
real(FMS_TRM_KIND_) :: weight_loc !< local copy of optional weight
integer :: pow_loc !> local copy of optional pow value (set if using pow reduction)
integer, parameter :: kindl = FMS_TRM_KIND_ !< real kind size as set by macro
+ integer :: diurnal !< diurnal index to indicate which daily section is updated
+ !! will be 1 unless using a diurnal reduction
if(present(weight)) then
weight_loc = weight
@@ -254,6 +259,12 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
pow_loc = 1.0_kindl
endif
+ if(diurnal_section .lt. 0) then
+ diurnal = 1
+ else
+ diurnal = diurnal_section
+ endif
+
! update with given weight for average before write
if (increase_counter) weight_sum = weight_sum + weight_loc
@@ -279,11 +290,11 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
do j = 0, je_out - js_out
do i = 0, ie_out - is_out
where (mask(is_in + i, js_in + j, ks_in + k, :))
- data_out(is_out + i, js_out + j, ks_out + k, :, 1) = &
- data_out(is_out + i, js_out + j, ks_out + k, :, 1) &
+ data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
+ data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
+ (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_loc) ** pow_loc
elsewhere
- data_out(is_out + i, js_out + j, ks_out + k, :, 1) = missing_value
+ data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = missing_value
endwhere
enddo
enddo
@@ -293,8 +304,8 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
do k = 0, ke_out - ks_out
do j = 0, je_out - js_out
do i = 0, ie_out - is_out
- data_out(is_out + i, js_out + j, ks_out + k, :, 1) = &
- data_out(is_out + i, js_out + j, ks_out + k, :, 1) &
+ data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
+ data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
+ (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_loc) ** pow_loc
enddo
enddo
@@ -305,7 +316,7 @@ end subroutine DO_TIME_SUM_UPDATE_
!> To be called with diag_send_complete, finishes reductions
!! Just divides the buffer by the counter array(which is just the sum of the weights used in the buffer's reduction)
!! TODO: change has_mask to an actual logical mask so we don't have to check for missing values
-subroutine SUM_UPDATE_DONE_(out_buffer_data, weight_sum, reduction_method, missing_val, has_mask)
+subroutine SUM_UPDATE_DONE_(out_buffer_data, weight_sum, reduction_method, missing_val, has_mask, n_diurnal_samples)
real(FMS_TRM_KIND_), intent(inout) :: out_buffer_data(:,:,:,:,:) !< data buffer previously updated with
!! do_time_sum_update
real(r8_kind), intent(in) :: weight_sum !< sum of weights for averaging, provided via argument to send data
@@ -313,18 +324,31 @@ subroutine SUM_UPDATE_DONE_(out_buffer_data, weight_sum, reduction_method, missi
!! should always be one of time_avg, time_diurnal, or time_rms
real(FMS_TRM_KIND_), intent(in) :: missing_val !< missing value for masked elements
logical, intent(in) :: has_mask !< indicates if mask is used so missing values can be skipped
+ integer, optional, intent(in) :: n_diurnal_samples !< number of diurnal samples as set in reduction method
+ integer :: wsum !< local cp of weight_sum, only changed if using diurnal
!! TODO replace conditional in the `where` with passed in and ajusted mask from the original call
!logical, optional, intent(in) :: mask(:,:,:,:) !< logical mask from accept data call, if using one.
!logical :: has_mask !< whether or not mask is present
+ ! need to divide weight sum by amount of samples to get the actual
+ ! number of times that the diurnal section was incremented
+ ! legacy diag manager stored these weights explicitly, this doesn't so assumes uniformity in when data is sent
+ if(reduction_method .eq. time_diurnal) then
+ if(.not. present(n_diurnal_samples)) call mpp_error(FATAL, &
+ "SUM_UPDATE_DONE_ :: reduction method is diurnal but no sample size was given")
+ wsum = weight_sum / n_diurnal_samples
+ else
+ wsum = weight_sum
+ endif
+
if ( has_mask ) then
- where(out_buffer_data(:,:,:,:,1) .ne. missing_val)
- out_buffer_data(:,:,:,:,1) = out_buffer_data(:,:,:,:,1) &
- / weight_sum
+ where(out_buffer_data(:,:,:,:,:) .ne. missing_val)
+ out_buffer_data(:,:,:,:,:) = out_buffer_data(:,:,:,:,:) &
+ / wsum
endwhere
else !not mask variant
- out_buffer_data(:,:,:,:,1) = out_buffer_data(:,:,:,:,1) &
- / weight_sum
+ out_buffer_data(:,:,:,:,:) = out_buffer_data(:,:,:,:,:) &
+ / wsum
endif
if(reduction_method .eq. time_rms .and. has_mask) then
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 56b1bd0573..eaea80ead8 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -31,7 +31,8 @@ LDADD = $(top_builddir)/libFMS/libFMS.la
check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
- check_time_min check_time_max check_time_sum check_time_avg check_time_pow check_time_rms
+ check_time_min check_time_max check_time_sum check_time_avg test_diag_diurnal check_time_diurnal \
+ check_time_pow check_time_rms
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -43,11 +44,13 @@ test_modern_diag_SOURCES = test_modern_diag.F90
test_diag_buffer_SOURCES= test_diag_buffer.F90
test_flexible_time_SOURCES = test_flexible_time.F90
test_reduction_methods_SOURCES = testing_utils.F90 test_reduction_methods.F90
+test_diag_diurnal_SOURCES = testing_utils.F90 test_diag_diurnal.F90
check_time_none_SOURCES = testing_utils.F90 check_time_none.F90
check_time_min_SOURCES = testing_utils.F90 check_time_min.F90
check_time_max_SOURCES = testing_utils.F90 check_time_max.F90
check_time_sum_SOURCES = testing_utils.F90 check_time_sum.F90
check_time_avg_SOURCES = testing_utils.F90 check_time_avg.F90
+check_time_diurnal_SOURCES = testing_utils.F90 check_time_diurnal.F90
check_time_pow_SOURCES = testing_utils.F90 check_time_pow.F90
check_time_rms_SOURCES = testing_utils.F90 check_time_rms.F90
@@ -57,13 +60,13 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
# Run the test.
TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh \
- test_time_avg.sh test_time_pow.sh test_time_rms.sh
+ test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh
testing_utils.mod: testing_utils.$(OBJEXT)
# Copy over other needed files to the srcdir
EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \
- test_time_sum.sh test_time_avg.sh test_time_pow.sh test_time_rms.sh
+ test_time_sum.sh test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh
if USING_YAML
skipflag=""
diff --git a/test_fms/diag_manager/check_time_diurnal.F90 b/test_fms/diag_manager/check_time_diurnal.F90
new file mode 100644
index 0000000000..3302da0ff4
--- /dev/null
+++ b/test_fms/diag_manager/check_time_diurnal.F90
@@ -0,0 +1,297 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!! TODO more complicated cases and data
+!> @brief Checks the output file after running test_reduction_methods using the "time_diurnal" reduction method
+program check_time_diurnal
+ use fms_mod, only: fms_init, fms_end, string
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file
+ use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file, NOTE
+ use platform_mod, only: r4_kind, r8_kind
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+
+ implicit none
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ type(FmsNetcdfFile_t) :: fileobj1 !< FMS2 fileobj for subregional file 1
+ type(FmsNetcdfFile_t) :: fileobj2 !< FMS2 fileobj for subregional file 2
+ real(kind=r4_kind), allocatable :: cdata_out(:,:,:,:) !< Data in the compute domain
+ real(kind=r4_kind), allocatable :: cdata_out_5d(:,:,:,:,:) !< Data in the compute domain
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the w direction
+ integer :: nd !< Number of points in the diurnal axis
+ integer :: ti !< For looping through time levels
+ integer :: io_status !< Io status after reading the namelist
+ logical :: use_mask !< .true. if using masks
+ integer, parameter :: file_freq = 6 !< file frequency as set in diag_table.yaml
+
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+ integer, parameter :: kindl = KIND(0.0) !< compile-time default kind size
+ integer :: nmonths !< number of months the test ran for
+ namelist / test_diag_diurnal_nml / test_case, mask_case
+
+ call fms_init()
+
+ read (input_nml_file, test_diag_diurnal_nml, iostat=io_status)
+
+ select case(mask_case)
+ case (no_mask)
+ use_mask = .false.
+ case (logical_mask, real_mask)
+ use_mask = .true.
+ end select
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+ nmonths = 3
+ nd = 3 !< diurnal sample size
+
+ if (.not. open_file(fileobj, "test_diurnal.nc", "read")) &
+ call mpp_error(FATAL, "unable to open test_diurnal.nc")
+
+ if (.not. open_file(fileobj1, "test_diurnal_regional.nc.0004", "read")) &
+ call mpp_error(FATAL, "unable to open test_diurnal_regional.nc.0004")
+
+ if (.not. open_file(fileobj2, "test_diurnal_regional.nc.0005", "read")) &
+ call mpp_error(FATAL, "unable to open test_diurnal_regional.nc.0005")
+
+ !cdata_out = allocate_buffer(1, nx, 1, ny, nz, nd)
+ allocate(cdata_out(nx, ny, nz, nd))
+ allocate(cdata_out_5d(nx, ny, nz, nw, nd))
+
+ do ti = 1, nmonths
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var1 - time_level:", string(ti)
+ call read_data(fileobj, "var1", cdata_out(:,1:nd,1,1), unlim_dim_level=ti)
+ call check_data_1d(cdata_out(:,1:nd,1,1), ti, sample_size=nd)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var2 - time_level:", string(ti)
+ call read_data(fileobj, "var2", cdata_out(:,:,1:nd,1), unlim_dim_level=ti)
+ call check_data_2d(cdata_out(:,:,1:nd,1), ti, sample_size=nd)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3 - time_level:", string(ti)
+ call read_data(fileobj, "var3", cdata_out(:,:,:,:), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(:,:,:,:), ti, .false., sample_size=nd)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var4_diurnal - time_level:", string(ti)
+ call read_data(fileobj, "var4", cdata_out_5d, unlim_dim_level=ti)
+ call check_data_4d(cdata_out_5d(:,:,:,:,:), ti, .false., sample_size=nd)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_diurnal in the first regional file- time_level:", string(ti)
+ call read_data(fileobj1, "var3_diurnal", cdata_out(1:4,1:3,1:2,1:1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(1:4,1:3,1:2,1:1), ti, .true., sample_size=nd, nx_offset=77, ny_offset=77, nz_offset=1)
+
+ cdata_out = -999_r4_kind
+ print *, "Checking answers for var3_diurnal in the second regional file- time_level:", string(ti)
+ call read_data(fileobj2, "var3_diurnal", cdata_out(1:4,1:1,1:2,1:1), unlim_dim_level=ti)
+ call check_data_3d(cdata_out(1:4,1:1,1:2,1:1), ti, .true., sample_size=nd, nx_offset=77, ny_offset=80, nz_offset=1)
+ enddo
+
+ call fms_end()
+
+contains
+
+
+ !> @brief Check that the 2d data read in is correct
+ subroutine check_data_2d(buffer, time_level, sample_size)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:) !< Buffer read from the table (2d + the diurnal axis)
+ integer, intent(in) :: time_level !< Time level read in
+ integer, intent(in) :: sample_size !< diurnal sample size of variable to check
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+
+ integer :: ii,i, j, k, l, d!< For looping
+ integer :: step_avg !< avg of time step increments to use in generating reference data
+ integer :: d_index
+ real(r8_kind) :: hrly_sums(sample_size)
+
+ ! sum of hours in diurnal section
+ hrly_sums = 0
+ do i=1, 23
+ d_index = i / (24/sample_size) + 1
+ hrly_sums(d_index) = hrly_sums(d_index) + i
+ enddo
+ hrly_sums = hrly_sums / (24/sample_size)
+
+ ! 2d answer is the
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do d = 1, sample_size
+ buffer_exp = hrly_sums(d)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j, d) - buffer_exp) > 0.0) then
+ print *, "indices:", ii, j, d, "expected:", buffer_exp, "read in:",buffer(ii, j, d)
+ call mpp_error(FATAL, "Check_time_diurnal::check_data_2d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_2d
+
+ !> @brief Check that the 3d data read in is correct
+ subroutine check_data_3d(buffer, time_level, is_regional, sample_size, nx_offset, ny_offset, nz_offset)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ logical, intent(in) :: is_regional !< .True. if the variable is subregional
+ integer, intent(in) :: sample_size !< diurnal sample size
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer, optional, intent(in) :: nx_offset !< Offset in the x direction
+ integer, optional, intent(in) :: ny_offset !< Offset in the y direction
+ integer, optional, intent(in) :: nz_offset !< Offset in the z direction
+
+ integer :: ii, i, j, k, l, d!< For looping
+ integer :: nx_oset !< Offset in the x direction (local variable)
+ integer :: ny_oset !< Offset in the y direction (local variable)
+ integer :: nz_oset !< Offset in the z direction (local variable)
+ integer :: step_avg!< avg of time step increments to use in generating reference data
+ real(r8_kind) :: hrly_sums(24/sample_size) !< can i even do this (yes)
+ integer :: d_index !< diurnal index
+
+ ! data is just the hour it was sent at
+ ! sum of hours in each diurnal section
+ hrly_sums = 0
+ do i=1, 23
+ d_index = i / (24/sample_size) + 1
+ hrly_sums(d_index) = hrly_sums(d_index) + i
+ enddo
+ hrly_sums = hrly_sums / (24/sample_size)
+
+ nx_oset = 0
+ if (present(nx_offset)) nx_oset = nx_offset
+
+ ny_oset = 0
+ if (present(ny_offset)) ny_oset = ny_offset
+
+ nz_oset = 0
+ if (present(nz_offset)) nz_oset = nz_offset
+
+ ! 3d answer is
+ !
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do k = 1, size(buffer, 3)
+ do d=1, size(buffer, 4)
+ buffer_exp = hrly_sums(d)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. .not. is_regional) &
+ buffer_exp = -666_r4_kind
+ if (abs(buffer(ii, j, k, d) - buffer_exp) > 0.0) then
+ print *, mpp_pe(),'indices:',ii, j, k, d, "read in:", buffer(ii, j, k, d), "expected:",buffer_exp
+ call mpp_error(FATAL, "Check_time_diurnal::check_data_3d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_3d
+
+ !> @brief Check that the 1d data read in is correct
+ subroutine check_data_1d(buffer, time_level, sample_size)
+ real(kind=r4_kind), intent(in) :: buffer(:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ integer, intent(in) :: sample_size !< diurnal sample size of variable to check
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer :: ii,i, j, k, l, d!< For looping
+ integer :: step_avg !< avg of time step increments to use in generating reference data
+ integer :: d_index
+ real(r8_kind) :: hrly_sums(sample_size)
+
+ ! sum of hours in diurnal section
+ hrly_sums = 0
+ do i=1, 23
+ d_index = i / (24/sample_size) + 1
+ hrly_sums(d_index) = hrly_sums(d_index) + i
+ enddo
+ hrly_sums = hrly_sums / (24/sample_size)
+
+ do ii = 1, size(buffer, 1)
+ do d = 1, sample_size
+ buffer_exp = hrly_sums(d)
+ if (use_mask .and. ii .eq. 1) buffer_exp = -666_r4_kind
+ if (abs(buffer(ii,d) - buffer_exp) > 0.0) then
+ print *, "indices:", ii, d, "expected:", buffer_exp, "read in:",buffer(ii,d)
+ call mpp_error(FATAL, "Check_time_diurnal::check_data_1d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ end subroutine check_data_1d
+
+ !> @brief Check that the 4d data read in is correct
+ subroutine check_data_4d(buffer, time_level, is_regional, sample_size, nx_offset, ny_offset, nz_offset)
+ real(kind=r4_kind), intent(in) :: buffer(:,:,:,:,:) !< Buffer read from the table
+ integer, intent(in) :: time_level !< Time level read in
+ logical, intent(in) :: is_regional !< .True. if the variable is subregional
+ integer, intent(in) :: sample_size !< diurnal sample size
+ real(kind=r4_kind) :: buffer_exp !< Expected result
+ integer, optional, intent(in) :: nx_offset !< Offset in the x direction
+ integer, optional, intent(in) :: ny_offset !< Offset in the y direction
+ integer, optional, intent(in) :: nz_offset !< Offset in the z direction
+
+ integer :: ii, i, j, k, l, d, w!< For looping
+ integer :: nx_oset !< Offset in the x direction (local variable)
+ integer :: ny_oset !< Offset in the y direction (local variable)
+ integer :: nz_oset !< Offset in the z direction (local variable)
+ integer :: step_avg!< avg of time step increments to use in generating reference data
+ real(r8_kind) :: hrly_sums(24/sample_size) !< calculated hourly sums for each diurnal section
+ integer :: d_index !< diurnal index
+
+ ! data is just the hour it was sent at
+ ! sum of hours in each diurnal section
+ hrly_sums = 0
+ do i=1, 23
+ d_index = i / (24/sample_size) + 1
+ hrly_sums(d_index) = hrly_sums(d_index) + i
+ enddo
+ hrly_sums = hrly_sums / (24/sample_size)
+
+ nx_oset = 0
+ if (present(nx_offset)) nx_oset = nx_offset
+
+ ny_oset = 0
+ if (present(ny_offset)) ny_oset = ny_offset
+
+ nz_oset = 0
+ if (present(nz_offset)) nz_oset = nz_offset
+
+ do ii = 1, size(buffer, 1)
+ do j = 1, size(buffer, 2)
+ do k = 1, size(buffer, 3)
+ do w = 1, size(buffer, 4)
+ do d = 1, sample_size
+ buffer_exp = hrly_sums(d)
+ if (use_mask .and. ii .eq. 1 .and. j .eq. 1 .and. k .eq. 1 .and. &
+ .not. is_regional) then
+ buffer_exp = -666_r4_kind
+ endif
+ if (abs(buffer(ii, j, k, w, d) - buffer_exp) > 0.0) then
+ print *, mpp_pe(),'indices:',ii, j, k, w, d, "read in:", buffer(ii, j, k, w, d), "expected:",buffer_exp
+ call mpp_error(FATAL, "Check_time_diurnal::check_data_4d:: Data is not correct")
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ end subroutine check_data_4d
+end program
diff --git a/test_fms/diag_manager/test_diag_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90
index bdaaa10c9d..f20a3fa073 100644
--- a/test_fms/diag_manager/test_diag_buffer.F90
+++ b/test_fms/diag_manager/test_diag_buffer.F90
@@ -43,18 +43,19 @@ program test_diag_buffer
!< Test the r8_buffer
buff_sizes = 1
- do i=0, 5
- if (i < 5) buff_sizes(i+1) = i+5
- call buffobj(i+1)%allocate_buffer(r8_data, i, buff_sizes, fname)
+ do i=0, 4
+ buff_sizes(i+1) = i+5
+ call buffobj(i+1)%allocate_buffer(r8_data, i, buff_sizes, fname, 1)
call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
type is (real(kind=r8_kind))
if (any(p_val .ne. real(EMPTY, kind=r8_kind))) &
call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
- do j = 1, 5
- if (size(p_val, j) .ne. buff_sizes(j)) &
+ do j = 1, 4
+ if (size(p_val, j) .ne. buff_sizes(j)) then
call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not allocated to the correct size")
+ endif
enddo
class default
call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not allocated to the correct type")
@@ -65,16 +66,16 @@ program test_diag_buffer
!< Test the r4_buffer
buff_sizes = 1
- do i=0, 5
- if (i < 5) buff_sizes(i+1) = i+5
- call buffobj(i+1)%allocate_buffer(r4_data, i, buff_sizes, fname)
+ do i=0, 4
+ buff_sizes(i+1) = i+5
+ call buffobj(i+1)%allocate_buffer(r4_data, i, buff_sizes, fname, 1)
call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
type is (real(kind=r4_kind))
if (any(p_val .ne. real(EMPTY, kind=r4_kind))) &
call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
- do j = 1, 5
+ do j = 1, 4
if (size(p_val, j) .ne. buff_sizes(j)) &
call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not allocated to the correct size")
enddo
@@ -87,16 +88,16 @@ program test_diag_buffer
!< Test the i8_buffer
buff_sizes = 1
- do i=0, 5
- if (i < 5) buff_sizes(i+1) = i+5
- call buffobj(i+1)%allocate_buffer(i8_data, i, buff_sizes, fname)
+ do i=0, 4
+ buff_sizes(i+1) = i+5
+ call buffobj(i+1)%allocate_buffer(i8_data, i, buff_sizes, fname, 1)
call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
type is (integer(kind=i8_kind))
if (any(p_val .ne. int(EMPTY, kind=i8_kind))) &
call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
- do j = 1, 5
+ do j = 1, 4
if (size(p_val, j) .ne. buff_sizes(j)) &
call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not allocated to the correct size")
enddo
@@ -109,16 +110,16 @@ program test_diag_buffer
!< Test the i4_buffer
buff_sizes = 1
- do i=0, 5
- if (i < 5) buff_sizes(i+1) = i+5
- call buffobj(i+1)%allocate_buffer(i4_data, i, buff_sizes, fname)
+ do i=0, 4
+ buff_sizes(i+1) = i+5
+ call buffobj(i+1)%allocate_buffer(i4_data, i, buff_sizes, fname, 1)
call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
type is (integer(kind=i4_kind))
if (any(p_val .ne. int(EMPTY, kind=i4_kind))) &
call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value")
- do j = 1, 5
+ do j = 1, 4
if (size(p_val, j) .ne. buff_sizes(j)) &
call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not allocated to the correct size")
enddo
diff --git a/test_fms/diag_manager/test_diag_diurnal.F90 b/test_fms/diag_manager/test_diag_diurnal.F90
new file mode 100644
index 0000000000..127f52f747
--- /dev/null
+++ b/test_fms/diag_manager/test_diag_diurnal.F90
@@ -0,0 +1,353 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!! TODO send more complicated data than just the current hour
+
+!> @brief Program to test the diurnal reduction
+!! Similar to test_reduction_methods, but uses the variables and reductions
+!! from the test_diag_manager_time diurnal test (#25)
+program test_diag_diurnal
+ use fms_mod, only: fms_init, fms_end
+ use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
+ use platform_mod, only: r8_kind
+ use block_control_mod, only: block_control_type, define_blocks
+ use mpp_mod, only: mpp_sync, FATAL, mpp_error, mpp_npes, mpp_pe, mpp_root_pe, mpp_broadcast, input_nml_file
+ use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+), days_in_month, &
+ get_time
+ use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
+ diag_send_complete, diag_manager_set_time_end, send_data
+ use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain, &
+ mpp_get_data_domain
+
+ implicit none
+
+ integer :: nx !< Number of points in the x direction
+ integer :: ny !< Number of points in the y direction
+ integer :: nz !< Number of points in the z direction
+ integer :: nw !< Number of points in the 4th dimension
+ integer :: layout(2) !< Layout
+ integer :: io_layout(2) !< Io layout
+ type(domain2d) :: Domain !< 2D domain
+ integer :: isc, isd !< Starting x compute, data domain index
+ integer :: iec, ied !< Ending x compute, data domain index
+ integer :: jsc, jsd !< Starting y compute, data domaine index
+ integer :: jec, jed !< Ending y compute, data domain index
+ integer :: nhalox !< Number of halos in x
+ integer :: nhaloy !< Number of halos in y
+ integer :: nhours !< number of hours to send per time step
+ real(kind=r8_kind), allocatable :: cdata(:,:,:,:) !< Data in the compute domain
+ real(kind=r8_kind), allocatable :: ddata(:,:,:,:) !< Data in the data domain
+ real(kind=r8_kind), allocatable :: crmask(:,:,:,:) !< Mask in the compute domain
+ real(kind=r8_kind), allocatable :: drmask(:,:,:,:) !< Mask in the data domain
+ logical, allocatable :: clmask(:,:,:,:) !< Logical mask in the compute domain
+ logical, allocatable :: dlmask(:,:,:,:) !< Logical mask in the data domain
+ type(time_type) :: Time !< Time of the simulation
+ type(time_type) :: Time_step !< Time of the simulation
+ integer :: nmonths !< number of months to run for (submits ntimes per month)
+ integer :: ndays !< number of days in the month
+ integer :: id_x !< axis id for the x dimension
+ integer :: id_y !< axis id for the y dimension
+ integer :: id_z !< axis id for the z dimension
+ integer :: id_w !< axis id for the w dimension
+ integer :: id_var0 !< diag_field id for 0d var
+ integer :: id_var1 !< diag_field id for 1d var
+ integer :: id_var2 !< diag_field id for 2d var
+ integer :: id_var3 !< diag_field id for 3d var
+ integer :: id_var4 !< diag_field id for 4d var
+ integer :: io_status !< Status after reading the namelist
+ type(block_control_type) :: my_block !< Returns instantiated @ref block_control_type
+ logical :: message !< Flag for outputting debug message
+ integer :: isd1 !< Starting x data domain index (1-based)
+ integer :: ied1 !< Ending x data domain index (1-based)
+ integer :: jsd1 !< Starting y data domain index (1-based)
+ integer :: jed1 !< Ending y data domain index (1-based)
+ integer :: isw !< Starting index for each thread in the x direction
+ integer :: iew !< Ending index for each thread in the x direction
+ integer :: jsw !< Starting index for each thread in the y direction
+ integer :: jew !< Ending index for each thread in the y direction
+ integer :: is1 !< Starting index for each thread in the x direction (1-based)
+ integer :: ie1 !< Ending index for each thread in the x direction (1-based)
+ integer :: js1 !< Starting index for each thread in the y direction (1-based)
+ integer :: je1 !< Ending index for each thread in the y direction (1-based)
+ integer :: iblock !< For looping through the blocks
+ integer :: i !< For do loops
+ logical :: used !< Dummy argument to send_data
+ real(kind=r8_kind) :: missing_value !< Missing value to use
+ integer :: days_out, seconds_out
+ integer :: m, h, d !< to iterate through months, hours, and days
+
+ !< Configuration parameters
+ integer :: test_case = test_normal !< Indicates which test case to run
+ integer :: mask_case = no_mask !< Indicates which masking option to run
+
+ namelist / test_diag_diurnal_nml / test_case, mask_case
+
+ call fms_init
+ call set_calendar_type(JULIAN)
+ call diag_manager_init
+
+ read (input_nml_file, test_diag_diurnal_nml, iostat=io_status)
+ if (io_status > 0) call mpp_error(FATAL,'=>test_modern_diag: Error reading input.nml')
+
+ nx = 96
+ ny = 96
+ nz = 5
+ nw = 2
+ layout = (/1, mpp_npes()/)
+ io_layout = (/1, 1/)
+ nhalox = 2
+ nhaloy = 2
+ nmonths = 3
+
+ !< Create a lat/lon domain
+ call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain', xhalo=nhalox, yhalo=nhaloy)
+ call mpp_define_io_domain(Domain, io_layout)
+ call mpp_get_compute_domain(Domain, isc, iec, jsc, jec)
+ call mpp_get_data_domain(Domain, isd, ied, jsd, jed)
+
+ cdata = allocate_buffer(isc, iec, jsc, jec, nz, nw)
+
+ select case (test_case)
+ case (test_normal)
+ if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the normal send_data calls"
+ case (test_halos)
+ if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the send_data calls with halos"
+ ddata = allocate_buffer(isd, ied, jsd, jed, nz, nw)
+ case (test_openmp)
+ if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the send_data calls with openmp blocks"
+ call define_blocks ('testing_model', my_block, isc, iec, jsc, jec, kpts=0, &
+ nx_block=1, ny_block=4, message=message)
+ end select
+
+ select case (mask_case)
+ case (logical_mask)
+ clmask = allocate_logical_mask(isc, iec, jsc, jec, nz, nw)
+ if (mpp_pe() .eq. 0) clmask(isc, jsc, 1, :) = .False.
+
+ if (test_case .eq. test_halos) then
+ dlmask = allocate_logical_mask(isd, ied, jsd, jed, nz, nw)
+ if (mpp_pe() .eq. 0) dlmask(1+nhalox, 1+nhaloy, 1, :) = .False.
+ endif
+ case (real_mask)
+ crmask = allocate_real_mask(isc, iec, jsc, jec, nz, nw)
+ if (mpp_pe() .eq. 0) crmask(isc, jsc, 1, :) = 0_r8_kind
+
+ if (test_case .eq. test_halos) then
+ drmask = allocate_real_mask(isd, ied, jsd, jed, nz, nw)
+ if (mpp_pe() .eq. 0) drmask(1+nhalox, 1+nhaloy, 1, :) = 0_r8_kind
+ endif
+ end select
+
+
+ !< Get the data domain indices (1 based)
+ isd1 = isc-isd+1
+ jsd1 = jsc-jsd+1
+ ied1 = isd1 + iec-isc
+ jed1 = jsd1 + jec-jsc
+
+ !< set up end time
+ Time = set_date(2,1,1,0,0,0)
+ Time_step = set_time (3600,0) !< 1 hour
+ call diag_manager_set_time_end(set_date(2,nmonths+1,1,0,0,0))
+
+ !< Register the axis
+ id_x = diag_axis_init('x', real((/ (i, i = 1,nx) /), kind=r8_kind), 'point_E', 'x', long_name='point_E', &
+ Domain2=Domain)
+ id_y = diag_axis_init('y', real((/ (i, i = 1,ny) /), kind=r8_kind), 'point_N', 'y', long_name='point_N', &
+ Domain2=Domain)
+ id_z = diag_axis_init('z', real((/ (i, i = 1,nz) /), kind=r8_kind), 'point_Z', 'z', long_name='point_Z')
+ id_w = diag_axis_init('w', real((/ (i, i = 1,nw) /), kind=r8_kind), 'point_W', 'n', long_name='point_W')
+
+ missing_value = -666._r8_kind
+ !< Register the fields
+ id_var1 = register_diag_field ('ocn_mod', 'var1', (/id_x/), Time, 'var1', &
+ 'mullions', missing_value = missing_value)
+ id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_x, id_y/), Time, 'var2', &
+ 'mullions', missing_value = missing_value)
+ id_var3 = register_diag_field ('ocn_mod', 'var3', (/id_x, id_y, id_z/), Time, 'var3', &
+ 'mullions', missing_value = missing_value)
+ id_var4 = register_diag_field ('ocn_mod', 'var4', (/id_x, id_y, id_z, id_w/), Time, 'var4', &
+ 'mullions', missing_value = missing_value)
+
+ ! iterate through nmonths and each day, each hour
+ do m = 1, nmonths
+ Time = set_date(2,m,1)
+ ndays = days_in_month(Time)
+ print * , "days in month:", ndays
+ do d = 1, ndays
+ do h = 0, 23 ! hours
+ Time = set_date(2,m,d,hour=h)
+
+ call set_buffer(cdata, m, d, h)
+
+ select case(test_case)
+ case (test_normal)
+ select case (mask_case)
+ case (no_mask)
+ used = send_data(id_var1, cdata(:,1,1,1), Time)
+ used = send_data(id_var2, cdata(:,:,1,1), Time)
+ used = send_data(id_var3, cdata(:,:,:,1), Time)
+ used = send_data(id_var4, cdata(:,:,:,:), Time)
+ case (real_mask)
+ used = send_data(id_var1, cdata(:,1,1,1), Time, rmask=crmask(:,1,1,1))
+ used = send_data(id_var2, cdata(:,:,1,1), Time, rmask=crmask(:,:,1,1))
+ used = send_data(id_var3, cdata(:,:,:,1), Time, rmask=crmask(:,:,:,1))
+ used = send_data(id_var4, cdata(:,:,:,:), Time, rmask=crmask(:,:,:,:))
+ case (logical_mask)
+ used = send_data(id_var1, cdata(:,1,1,1), Time, mask=clmask(:,1,1,1))
+ used = send_data(id_var2, cdata(:,:,1,1), Time, mask=clmask(:,:,1,1))
+ used = send_data(id_var3, cdata(:,:,:,1), Time, mask=clmask(:,:,:,1))
+ used = send_data(id_var4, cdata(:,:,:,:), Time, mask=clmask(:,:,:,:))
+ end select
+ case (test_halos)
+ call set_buffer(ddata, m, d, h)
+ select case (mask_case)
+ case (no_mask)
+ used = send_data(id_var1, ddata(:,1,1,1), Time)
+ used = send_data(id_var2, ddata(:,:,1,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1)
+ used = send_data(id_var3, ddata(:,:,:,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1)
+ used = send_data(id_var4, ddata(:,:,:,:), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1)
+ case (real_mask)
+ used = send_data(id_var1, ddata(:,1,1,1), Time, &
+ rmask=drmask(:,1,1,1))
+ used = send_data(id_var2, ddata(:,:,1,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ rmask=drmask(:,:,1,1))
+ used = send_data(id_var3, ddata(:,:,:,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ rmask=drmask(:,:,:,1))
+ used = send_data(id_var4, ddata(:,:,:,:), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ rmask=drmask(:,:,:,:))
+ case (logical_mask)
+ used = send_data(id_var1, ddata(:,1,1,1), Time, &
+ mask=dlmask(:,1,1,1))
+ used = send_data(id_var2, ddata(:,:,1,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ mask=dlmask(:,:,1,1))
+ used = send_data(id_var3, ddata(:,:,:,1), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ mask=dlmask(:,:,:,1))
+ used = send_data(id_var4, ddata(:,:,:,:), Time, &
+ is_in=isd1, ie_in=ied1, js_in=jsd1, je_in=jed1, &
+ mask=dlmask(:,:,:,:))
+ end select
+ case (test_openmp)
+ select case(mask_case)
+ case (no_mask)
+ used=send_data(id_var1, cdata(:, 1, 1, 1), time)
+ case (logical_mask)
+ used=send_data(id_var1, cdata(:, 1, 1, 1), time, &
+ mask=clmask(:, 1, 1, 1))
+ case (real_mask)
+ used=send_data(id_var1, cdata(:, 1, 1, 1), time, &
+ rmask=crmask(:, 1, 1, 1))
+ end select
+!$OMP parallel do default(shared) private(iblock, isw, iew, jsw, jew, is1, ie1, js1, je1)
+ do iblock=1, 4
+ isw = my_block%ibs(iblock)
+ jsw = my_block%jbs(iblock)
+ iew = my_block%ibe(iblock)
+ jew = my_block%jbe(iblock)
+
+ !--- indices for 1-based arrays ---
+ is1 = isw-isc+1
+ ie1 = iew-isc+1
+ js1 = jsw-jsc+1
+ je1 = jew-jsc+1
+
+ select case (mask_case)
+ case (no_mask)
+ used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1)
+ used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1)
+ used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1)
+ case (real_mask)
+ used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, &
+ rmask=crmask(is1:ie1, js1:je1, 1, 1))
+ used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, &
+ rmask=crmask(is1:ie1, js1:je1, :, 1))
+ used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1, &
+ rmask=crmask(is1:ie1, js1:je1, :, :))
+ case (logical_mask)
+ used=send_data(id_var2, cdata(is1:ie1, js1:je1, 1, 1), time, is_in=is1, js_in=js1, &
+ mask=clmask(is1:ie1, js1:je1, 1, 1))
+ used=send_data(id_var3, cdata(is1:ie1, js1:je1, :, 1), time, is_in=is1, js_in=js1, &
+ mask=clmask(is1:ie1, js1:je1, :, 1))
+ used=send_data(id_var4, cdata(is1:ie1, js1:je1, :, :), time, is_in=is1, js_in=js1, &
+ mask=clmask(is1:ie1, js1:je1, :, :))
+ end select
+ enddo
+ end select
+ call diag_send_complete(Time_step)
+ enddo
+ enddo
+ enddo
+
+ call diag_manager_end(Time)
+
+ call fms_end
+
+ contains
+
+ !> @brief Allocate the logical mask based on the starting/ending indices
+ !! @return logical mask initiliazed to .True.
+ function allocate_logical_mask(is, ie, js, je, k, l) &
+ result(buffer)
+ integer, intent(in) :: is !< Starting x index
+ integer, intent(in) :: ie !< Ending x index
+ integer, intent(in) :: js !< Starting y index
+ integer, intent(in) :: je !< Ending y index
+ integer, intent(in) :: k !< Number of points in the 4th dimension
+ integer, intent(in) :: l !< Number of points in the 5th dimension
+
+ logical, allocatable :: buffer(:,:,:,:)
+
+ allocate(buffer(is:ie, js:je, 1:k, 1:l))
+ buffer = .True.
+ end function allocate_logical_mask
+
+ !> @brief Allocate the real mask based on the starting/ending indices
+ !! @returnreal mask initiliazed to 1_r8_kind
+ function allocate_real_mask(is, ie, js, je, k, l) &
+ result(buffer)
+ integer, intent(in) :: is !< Starting x index
+ integer, intent(in) :: ie !< Ending x index
+ integer, intent(in) :: js !< Starting y index
+ integer, intent(in) :: je !< Ending y index
+ integer, intent(in) :: k !< Number of points in the 4th dimension
+ integer, intent(in) :: l !< Number of points in the 5th dimension
+ real(kind=r8_kind), allocatable :: buffer(:,:,:,:)
+
+ allocate(buffer(is:ie, js:je, 1:k, 1:l))
+ buffer = 1.0_r8_kind
+ end function allocate_real_mask
+
+
+ !> @brief Set the buffer based on the time_index
+ subroutine set_buffer(buffer, month, day, hour)
+ real(kind=r8_kind), intent(inout) :: buffer(:,:,:,:) !< Output buffer
+ integer, intent(in) :: month, day, hour !< Time index
+
+ buffer = hour ! month * 10000 + day * 100 + hour
+
+ end subroutine set_buffer
+
+end program test_diag_diurnal
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 1d5e8bf258..af7d2cabab 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -495,8 +495,8 @@ test_diag_manager
"test_diurnal", 1, "hours", 1, "hours", "time"
#output variables
- "test_diag_manager_mod", "sst", "sst", "test_diurnal", "all", "diurnal3", "none", 2
- "test_diag_manager_mod", "ice", "ice", "test_diurnal", "all", "diurnal3", "none", 2
+ "test_diag_manager_mod", "sst", "sst", "test_diurnal", "all", "diurnal4", "none", 2
+ "test_diag_manager_mod", "ice", "ice", "test_diurnal", "all", "diurnal4", "none", 2
_EOF
my_test_count=`expr $my_test_count + 1`
diff --git a/test_fms/diag_manager/test_time_diurnal.sh b/test_fms/diag_manager/test_time_diurnal.sh
new file mode 100755
index 0000000000..adb4f74993
--- /dev/null
+++ b/test_fms/diag_manager/test_time_diurnal.sh
@@ -0,0 +1,138 @@
+#!/bin/sh
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+# tests the diurnal (daily average) reduction method
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+cat <<_EOF > diag_table.yaml
+title: test_diurnal
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_diurnal
+ time_units: hours
+ unlimdim: time
+ freq: 1 months
+ varlist:
+ - module: ocn_mod
+ var_name: var4
+ output_name: var4
+ reduction: diurnal3
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3
+ reduction: diurnal3
+ kind: r4
+ - module: ocn_mod
+ var_name: var2
+ output_name: var2
+ reduction: diurnal3
+ kind: r4
+ - module: ocn_mod
+ var_name: var1
+ output_name: var1
+ reduction: diurnal3
+ kind: r4
+- file_name: test_diurnal_regional
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: latlon
+ corner1: 78. 78.
+ corner2: 78. 78.
+ corner3: 81. 81.
+ corner4: 81. 81.
+ freq: 1 months
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_diurnal
+ reduction: diurnal3
+ zbounds: 2. 3.
+ kind: r4
+_EOF
+
+export OMP_NUM_THREADS=1
+
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n" > input.nml
+
+test_expect_success "monthly simple diurnal output" '
+ mpirun -n 6 ../test_diag_diurnal
+'
+
+test_expect_success "checking results for diurnal test simple" '
+ mpirun -n 6 ../check_time_diurnal
+'
+
+printf "&test_diag_diurnal_nml \n test_case=0 \n mask_case=1 \n / \n" >> input.nml
+
+test_expect_success "monthly diurnal output with logical mask" '
+ mpirun -n 6 ../test_diag_diurnal
+'
+test_expect_success "checking results for diurnal test with logical mask" '
+ mpirun -n 6 ../check_time_diurnal
+'
+
+printf "&test_diag_diurnal_nml \n test_case=0 \n mask_case=2 \n / \n" >> input.nml
+
+test_expect_success "monthly diurnal output with real mask" '
+ mpirun -n 6 ../test_diag_diurnal
+'
+test_expect_success "checking results for diurnal test with real mask" '
+ mpirun -n 6 ../check_time_diurnal
+'
+
+export OMP_NUM_THREADS=2
+
+printf "&test_diag_diurnal_nml \n test_case=1 \n / \n" >> input.nml
+
+test_expect_success "monthly diurnal output with openmp" '
+ mpirun -n 6 ../test_diag_diurnal
+'
+test_expect_success "checking results for diurnal test with openmp" '
+ mpirun -n 6 ../check_time_diurnal
+'
+
+printf "&test_diag_diurnal_nml \n test_case=1 \n mask_case=1 \n / \n" >> input.nml
+
+test_expect_success "monthly diurnal output with openmp and real mask" '
+ mpirun -n 6 ../test_diag_diurnal
+'
+test_expect_success "checking results for diurnal test with openmp and real mask" '
+ mpirun -n 6 ../check_time_diurnal
+'
+
+printf "&test_diag_diurnal_nml \n test_case=1 \n mask_case=2 \n / \n" >> input.nml
+
+test_expect_success "monthly diurnal output with openmp and logical mask" '
+ mpirun -n 6 ../test_diag_diurnal
+'
+test_expect_success "checking results for diurnal test with openmp and logical mask" '
+ mpirun -n 6 ../check_time_diurnal
+'
+
+fi
+
+test_done
From a69bbac339caf1f8154d9dd628930607a2201eb3 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 25 Jan 2024 12:26:19 -0500
Subject: [PATCH 144/168] fix: remove the lowercase when saving the filename in
the sorted list of files (#1448)
---
diag_manager/fms_diag_yaml.F90 | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index b14b10103a..b916ece615 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -414,8 +414,7 @@ subroutine diag_yaml_object_init(diag_subset_output)
call fill_in_diag_files(diag_yaml_id, diag_file_ids(i), diag_yaml%diag_files(file_count))
!> Save the file name in the file_list
- !! The diag_table is not case sensitive (so we are saving it as lowercase)
- file_list%file_name(file_count) = lowercase(trim(diag_yaml%diag_files(file_count)%file_fname)//c_null_char)
+ file_list%file_name(file_count) = trim(diag_yaml%diag_files(file_count)%file_fname)//c_null_char
file_list%diag_file_indices(file_count) = file_count
nvars = 0
From f11a5568920d15c583fc9466b3e6ca1ec831b2d7 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 9 Feb 2024 12:20:08 -0500
Subject: [PATCH 145/168] fix: diag_manager multiple subregional diagnostics in
the same file (#1450)
---
diag_manager/diag_data.F90 | 2 +
diag_manager/fms_diag_axis_object.F90 | 195 +++++++++++-------
diag_manager/fms_diag_file_object.F90 | 235 ++++++++++++++++++----
test_fms/diag_manager/check_time_none.F90 | 20 +-
4 files changed, 338 insertions(+), 114 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index e6f566c61e..c5a7539e37 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -126,6 +126,8 @@ MODULE diag_data_mod
INTEGER, PARAMETER :: middle_time = 2 !< Use the middle of the time average bounds
INTEGER, PARAMETER :: end_time = 3 !< Use the end of the time average bounds
INTEGER, PARAMETER :: MAX_STR_LEN = 255 !< Max length for a string
+ INTEGER, PARAMETER :: is_x_axis = 1 !< integer indicating that it is a x axis
+ INTEGER, PARAMETER :: is_y_axis = 2 !< integer indicating that it is a y axis
!> @}
!> @brief Contains the coordinates of the local domain to output.
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 0a913dc604..47bee8e7bd 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -37,7 +37,7 @@ module fms_diag_axis_object_mod
direction_down, direction_up, fmsDiagAttribute_type, max_axis_attributes, &
MAX_SUBAXES, DIAG_NULL, index_gridtype, latlon_gridtype, pack_size_str, &
get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute,&
- get_base_second
+ get_base_second, is_x_axis, is_y_axis
use mpp_mod, only: FATAL, mpp_error, uppercase, mpp_pe, mpp_root_pe, stdout
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, &
& register_axis, register_field, register_variable_attribute, write_data
@@ -51,8 +51,9 @@ module fms_diag_axis_object_mod
public :: fmsDiagAxis_type, fms_diag_axis_object_init, fms_diag_axis_object_end, &
& get_domain_and_domain_type, diagDomain_t, &
& DIAGDOMAIN2D_T, fmsDiagSubAxis_type, fmsDiagAxisContainer_type, fmsDiagFullAxis_type, DIAGDOMAINUG_T
- public :: define_new_axis, define_subaxis, parse_compress_att, get_axis_id_from_name, define_diurnal_axis, &
- & fmsDiagDiurnalAxis_type, create_new_z_subaxis
+ public :: define_new_axis, parse_compress_att, get_axis_id_from_name, define_diurnal_axis, &
+ & fmsDiagDiurnalAxis_type, create_new_z_subaxis, is_parent_axis, define_new_subaxis_latlon, &
+ & define_new_subaxis_index
!> @}
@@ -116,6 +117,7 @@ module fms_diag_axis_object_mod
!! parent axis
INTEGER , private :: parent_axis_id !< Id of the parent_axis
INTEGER , private :: compute_idx(2) !< Starting and ending index of the compute domain
+ INTEGER, allocatable, private :: global_idx(:) !< Starting and ending index of the global domain
real(kind=r4_kind), allocatable, private :: zbounds(:) !< Bounds of the Z axis
contains
procedure :: fill_subaxis
@@ -188,6 +190,7 @@ module fms_diag_axis_object_mod
PROCEDURE :: has_aux
PROCEDURE :: get_set_name
PROCEDURE :: has_set_name
+ PROCEDURE :: is_x_or_y_axis
! TO DO:
! Get/has/is subroutines as needed
END TYPE fmsDiagFullAxis_type
@@ -316,8 +319,12 @@ subroutine write_axis_metadata(this, fms2io_fileobj, edges_in_file, parent_axis)
integer :: type_of_domain !< The type of domain the current axis is in
logical :: is_subaxis !< .true. if the axis is a subaxis
+ logical :: needs_domain_decomposition !< .True. if the axis needs the domain decomposition attribute
+ !! (i.e for "X" and "Y" subaxis)
+ integer :: domain_decomposition(4) !< indices of the global (1:2) and compute (3:4) domain for a "X" and "Y" subaxis
is_subaxis = .false.
+ needs_domain_decomposition = .false.
select type(this)
type is (fmsDiagFullAxis_type)
@@ -329,6 +336,12 @@ subroutine write_axis_metadata(this, fms2io_fileobj, edges_in_file, parent_axis)
is_subaxis = .true.
axis_name => this%subaxis_name
axis_length = this%ending_index - this%starting_index + 1
+ if (allocated(this%global_idx)) then
+ needs_domain_decomposition = .true.
+ domain_decomposition(1:2) = this%global_idx
+ domain_decomposition(3) = this%starting_index
+ domain_decomposition(4) = this%ending_index
+ endif
!< Get all the other information from the parent axis (i.e the cart_name, units, etc)
if (present(parent_axis)) then
select type(parent_axis)
@@ -350,6 +363,10 @@ subroutine write_axis_metadata(this, fms2io_fileobj, edges_in_file, parent_axis)
!< Here the axis is not domain decomposed (i.e z_axis)
call register_axis(fms2io_fileobj, axis_name, axis_length)
call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/))
+ if (needs_domain_decomposition) then
+ call register_variable_attribute(fms2io_fileobj, axis_name, "domain_decomposition", &
+ domain_decomposition)
+ endif
type is (FmsNetcdfDomainFile_t)
select case (type_of_domain)
case (NO_DOMAIN)
@@ -621,6 +638,28 @@ pure function has_set_name(this) &
if (allocated(this%set_name)) rslt = trim(this%set_name) .ne. ""
end function has_set_name
+ !> @brief Determine if an axis object is an x or y axis
+ !! @return .true. if an axis object is an x or y axis, optionally return a flag indicating which it is
+ function is_x_or_y_axis(this, x_or_y) &
+ result(rslt)
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
+ integer, optional, intent(inout) :: x_or_y !< returns is_x_axis if it is a x axis
+ !! is_y_axis if it is a y axis
+ logical :: rslt
+
+ select case (trim(this%cart_name))
+ case ("X")
+ if (present(x_or_y)) x_or_y = is_x_axis
+ rslt = .true.
+ case ("Y")
+ if (present(x_or_y)) x_or_y = is_y_axis
+ rslt = .true.
+ case default
+ rslt = .false.
+ if (present(x_or_y)) x_or_y = diag_null
+ end select
+ end function is_x_or_y_axis
+
!> @brief Get the set name of an axis object
!! @return the set name of an axis object
pure function get_set_name(this) &
@@ -667,7 +706,7 @@ end subroutine set_edges
!> @brief Determine if the subRegion is in the current PE.
!! If it is, determine the starting and ending indices of the current PE that belong to the subRegion
subroutine get_indices(this, compute_idx, corners_indices, starting_index, ending_index, need_to_define_axis)
- class(fmsDiagFullAxis_type), intent(inout) :: this !< diag_axis obj
+ class(fmsDiagFullAxis_type), intent(in) :: this !< diag_axis obj
integer, intent(in) :: compute_idx(:) !< Current PE's compute domain
class(*), intent(in) :: corners_indices(:) !< The indices of the corners of the subRegion
integer, intent(out) :: starting_index !< Starting index of the subRegion
@@ -702,11 +741,11 @@ subroutine get_indices(this, compute_idx, corners_indices, starting_index, endin
if (compute_idx(1) >= subregion_start .and. compute_idx(2) >= subregion_end) then
!< In this case all the point of the current PE are inside the range of the sub_axis
starting_index = compute_idx(1)
- ending_index = compute_idx(2)
+ ending_index = subregion_end
else if (compute_idx(1) >= subregion_start .and. compute_idx(2) <= subregion_end) then
!< In this case all the points of the current PE are valid up to the end point
starting_index = compute_idx(1)
- ending_index = subregion_end
+ ending_index = compute_idx(2)
else if (compute_idx(1) <= subregion_start .and. compute_idx(2) <= subregion_end) then
!< In this case all the points of the current PE are valid starting with t subregion_start
starting_index = subregion_start
@@ -769,7 +808,7 @@ end subroutine get_compute_domain
!!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Fills in the information needed to define a subaxis
subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, compute_idx, &
- zbounds)
+ global_idx, zbounds)
class(fmsDiagSubAxis_type) , INTENT(INOUT) :: this !< diag_sub_axis obj
integer , intent(in) :: starting_index !< Starting index of the subRegion for the PE
integer , intent(in) :: ending_index !< Ending index of the subRegion for the PE
@@ -778,6 +817,8 @@ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id,
character(len=*) , intent(in) :: parent_axis_name !< Name of the parent_axis
integer , intent(in) :: compute_idx(2) !< Starting and ending index of
!! the axis's compute domain
+ integer, optional, intent(in) :: global_idx(2) !< Starting and ending index of
+ !! the axis's compute domain
real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the z-axis
this%axis_id = axis_id
@@ -788,9 +829,16 @@ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id,
this%compute_idx = compute_idx
if (present(zbounds)) then
+ ! This is needed to avoid duplicating z sub axis!
allocate(this%zbounds(2))
this%zbounds = zbounds
endif
+
+ if (present(global_idx)) then
+ ! This is needed for the "domain_decomposition" attribute which is needed for the combiner
+ allocate(this%global_idx(2))
+ this%global_idx = global_idx
+ endif
end subroutine fill_subaxis
!> @brief Get the axis length of a subaxis
@@ -1012,76 +1060,45 @@ subroutine get_domain_and_domain_type(diag_axis, axis_id, domain_type, domain, v
enddo
end subroutine get_domain_and_domain_type
- !> @brief Define a subaxis based on the subRegion defined by the yaml
- subroutine define_subaxis (diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe)
- class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
- integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
- integer, intent(inout) :: naxis !< Number of axis registered
- type(subRegion_type), intent(in) :: subRegion !< The subRegion definition from
- !! the yaml
- logical, intent(in) :: is_cube_sphere !< .true. if this is a cubesphere
- logical, intent(out) :: write_on_this_pe !< .true. if the subregion
- !! is on this PE
-
- select case(subRegion%grid_type)
- case (latlon_gridtype)
- call define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe)
- case (index_gridtype)
- call define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_this_pe)
- end select
- end subroutine define_subaxis
-
!> @brief Fill in the subaxis object for a subRegion defined by index
- subroutine define_subaxis_index(diag_axis, axis_ids, naxis, subRegion, write_on_this_pe)
+ subroutine define_new_subaxis_index(parent_axis, subRegion, diag_axis, naxis, is_x_or_y, write_on_this_pe)
class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
- integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
+ type(fmsDiagFullAxis_type), intent(inout) :: parent_axis !< axis object of the parent
integer, intent(inout) :: naxis !< Number of axis registered
type(subRegion_type), intent(in) :: subRegion !< SubRegion definition from the yaml
+ integer, intent(in) :: is_x_or_y !< Flag indicating if it is
+ !! a x or y axis
logical, intent(out) :: write_on_this_pe !< .true. if the subregion
!! is on this PE
- integer :: i !< For do loops
- integer :: compute_idx(2)
- integer :: starting_index, ending_index
- logical :: need_to_define_axis
- integer :: lat_indices(2), lon_indices(2)
+ integer :: compute_idx(2) !< Indices of the compute domain
+ integer :: global_idx(2) !< Indices of the "global" domain
+ integer :: starting_index !< starting index of the subregion
+ integer :: ending_index !< ending index of the subregion
+ call parent_axis%get_compute_domain(compute_idx, write_on_this_pe, tile_number=subRegion%tile)
+ if (.not. write_on_this_pe) return
- do i = 1, size(axis_ids)
- select type (parent_axis => diag_axis(axis_ids(i))%axis)
- type is (fmsDiagFullAxis_type)
- !< Get the PEs compute domain
- call parent_axis%get_compute_domain(compute_idx, need_to_define_axis, tile_number=subRegion%tile)
-
- !< If this is not a "X" or "Y" axis, go to the next axis
- if (.not. need_to_define_axis) then
- cycle
- endif
+ !< Determine if the PE's compute domain is inside the subRegion
+ !! If it is get the starting and ending indices for that PE
+ call parent_axis%get_indices(compute_idx, subRegion%corners(:,is_x_or_y), starting_index, ending_index, &
+ write_on_this_pe)
- !< Determine if the PE's compute domain is inside the subRegion
- !! If it is get the starting and ending indices for that PE
- call parent_axis%get_indices(compute_idx, subRegion%corners(:,i), starting_index, ending_index, &
- need_to_define_axis)
-
- !< If the PE's compute is not inside the subRegion, define a null subaxis and go to the next axis
- if (.not. need_to_define_axis) then
- compute_idx = diag_null
- call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- diag_null, diag_null, compute_idx)
- cycle
- endif
+ if (.not. write_on_this_pe) return
- !< If it made it to this point, the current PE is in the subRegion!
- write_on_this_pe = .true.
+ select type(corners=> subRegion%corners)
+ type is (integer(kind=i4_kind))
+ global_idx(1) = minval(corners(:,is_x_or_y))
+ global_idx(2) = maxval(corners(:,is_x_or_y))
+ end select
- call define_new_axis(diag_axis, parent_axis, naxis, axis_ids(i), &
- starting_index, ending_index, compute_idx)
- end select
- enddo
+ !< If it made it to this point, the current PE is in the subRegion!
+ call define_new_axis(diag_axis, parent_axis, naxis, parent_axis%axis_id, &
+ starting_index, ending_index, compute_idx, global_idx)
- end subroutine define_subaxis_index
+ end subroutine define_new_subaxis_index
!> @brief Fill in the subaxis object for a subRegion defined by lat lon
- subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe)
+ subroutine define_new_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_sphere, write_on_this_pe)
class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
integer, INTENT(in) :: axis_ids(:) !< Array of axes_ids
integer, intent(inout) :: naxis !< Number of axis registered
@@ -1103,6 +1120,11 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_
integer :: parent_axis_ids(2) !< The axis id of the parent axis for the "x" and "y" direction
logical :: is_x_y_axis !< .true. if the axis is x or y
integer :: compute_idx_2(2, 2) !< Starting and ending indices of the compute domain for the "x" and "y" direction
+ integer :: global_idx (2, 2) !< Starting and ending indices of the global domain for the "x" and "y" direction
+
+ write_on_this_pe = .false.
+ need_to_define_axis = .true.
+ parent_axis_ids = diag_null
!< Get the rectangular coordinates of the subRegion
!! If the subRegion is not rectangular, the points outside of the subRegion will be masked
@@ -1135,11 +1157,13 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_
need_to_define_axis(1))
parent_axis_ids(1) = axis_ids(i)
compute_idx_2(1,:) = compute_idx
+ global_idx(1,:) = lon_indices
else if (parent_axis%cart_name .eq. "Y") then
call parent_axis%get_indices(compute_idx, lat_indices, starting_index(2), ending_index(2), &
need_to_define_axis(2))
parent_axis_ids(2) = axis_ids(i)
compute_idx_2(2,:) = compute_idx
+ global_idx(2,:) = lat_indices
endif
end select select_axis_type
enddo loop_over_axis_ids
@@ -1158,28 +1182,30 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_
select type(adata=>parent_axis%axis_data)
type is (real(kind=r8_kind))
lon_indices(1) = nearest_index(real(lon(1), kind=r8_kind), adata)
- lon_indices(2) = nearest_index(real(lon(2), kind=r8_kind), adata) + 1
+ lon_indices(2) = nearest_index(real(lon(2), kind=r8_kind), adata)
type is (real(kind=r4_kind))
lon_indices(1) = nearest_index(real(lon(1), kind=r4_kind), adata)
- lon_indices(2) = nearest_index(real(lon(2), kind=r4_kind), adata) + 1
+ lon_indices(2) = nearest_index(real(lon(2), kind=r4_kind), adata)
end select
call parent_axis%get_indices(compute_idx, lon_indices, starting_index(1), ending_index(1), &
need_to_define_axis(1))
- parent_axis_ids(1) = axis_ids(i)
- compute_idx_2(1,:) = compute_idx
+ parent_axis_ids(1) = axis_ids(i)
+ compute_idx_2(1,:) = compute_idx
+ global_idx(1,:) = lon_indices
else if (parent_axis%cart_name .eq. "Y") then
select type(adata=>parent_axis%axis_data)
type is (real(kind=r8_kind))
lat_indices(1) = nearest_index(real(lat(1), kind=r8_kind), adata)
- lat_indices(2) = nearest_index(real(lat(2), kind=r8_kind), adata) + 1
+ lat_indices(2) = nearest_index(real(lat(2), kind=r8_kind), adata)
type is (real(kind=r4_kind))
lat_indices(1) = nearest_index(real(lat(1), kind=r4_kind), adata)
- lat_indices(2) = nearest_index(real(lat(2), kind=r4_kind), adata) + 1
+ lat_indices(2) = nearest_index(real(lat(2), kind=r4_kind), adata)
end select
call parent_axis%get_indices(compute_idx, lat_indices, starting_index(2), ending_index(2), &
need_to_define_axis(2))
parent_axis_ids(2) = axis_ids(i)
compute_idx_2(2,:) = compute_idx
+ global_idx(2,:) = lat_indices
endif
end select
enddo loop_over_axis_ids2
@@ -1192,18 +1218,19 @@ subroutine define_subaxis_latlon(diag_axis, axis_ids, naxis, subRegion, is_cube_
write_on_this_pe = .true.
do i = 1, size(parent_axis_ids)
+ if (parent_axis_ids(i) .eq. diag_null) cycle
select type (parent_axis => diag_axis(parent_axis_ids(i))%axis)
type is (fmsDiagFullAxis_type)
call define_new_axis(diag_axis, parent_axis, naxis, parent_axis_ids(i), &
- starting_index(i), ending_index(i), compute_idx_2(i,:))
+ starting_index(i), ending_index(i), compute_idx_2(i,:), global_idx(i,:))
end select
enddo
- end subroutine define_subaxis_latlon
+ end subroutine define_new_subaxis_latlon
!> @brief Creates a new subaxis and fills it will all the information it needs
subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
- starting_index, ending_index, compute_idx, new_axis_id, zbounds)
+ starting_index, ending_index, compute_idx, global_idx, new_axis_id, zbounds)
class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
class(fmsDiagFullAxis_type), intent(inout) :: parent_axis !< The parent axis
@@ -1214,6 +1241,8 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
integer, intent(in) :: ending_index !< PE's Ending index
integer, intent(in) :: compute_idx(2) !< Starting and ending index of
!! the axis's compute domain
+ integer, optional, intent(in) :: global_idx(2) !< Starting and ending index of
+ !! the axis's global domain
integer, optional, intent(out) :: new_axis_id !< Axis id of the axis this is creating
real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the Z axis
@@ -1231,7 +1260,7 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
select type (sub_axis => diag_axis(naxis)%axis)
type is (fmsDiagSubAxis_type)
call sub_axis%fill_subaxis(starting_index, ending_index, naxis, parent_id, &
- parent_axis%axis_name, compute_idx, zbounds)
+ parent_axis%axis_name, compute_idx, global_idx=global_idx, zbounds=zbounds)
end select
end subroutine define_new_axis
@@ -1397,7 +1426,7 @@ subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_ax
call define_new_axis(diag_axis, parent_axis, naxis, parent_axis%axis_id, &
&subaxis_indices(1), subaxis_indices(2), (/lbound(zaxis_data,1), ubound(zaxis_data,1)/), &
- &subaxis_id, zbounds)
+ &new_axis_id=subaxis_id, zbounds=zbounds)
var_axis_ids(i) = subaxis_id
return
endif
@@ -1405,6 +1434,24 @@ subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_ax
enddo
end subroutine
+
+ !> @brief Determine if the diag_axis(parent_axis_id) is the parent of diag_axis(axis_id)
+ !! @return .True. if diag_axis(parent_axis_id) is the parent of diag_axis(axis_id)
+ function is_parent_axis(axis_id, parent_axis_id, diag_axis) &
+ result(rslt)
+ integer, intent(in) :: axis_id !< Axis id to check
+ integer, intent(in) :: parent_axis_id !< Axis id of the parent to check
+ class(fmsDiagAxisContainer_type), target, intent(in) :: diag_axis(:) !< Array of diag_axis objects
+
+ logical :: rslt
+
+ rslt = .false.
+ select type(axis => diag_axis(axis_id)%axis)
+ type is (fmsDiagSubAxis_type)
+ if (axis%parent_axis_id .eq. parent_axis_id) rslt = .true.
+ end select
+ end function is_parent_axis
+
#endif
end module fms_diag_axis_object_mod
!> @}
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index a69b8cabf1..632c8a97d6 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -34,7 +34,7 @@ module fms_diag_file_object_mod
get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute, &
get_base_second, time_unit_list, time_average, time_rms, time_max, time_min, time_sum, &
time_diurnal, time_power, time_none, avg_name, no_units, pack_size_str, &
- middle_time, begin_time, end_time, MAX_STR_LEN
+ middle_time, begin_time, end_time, MAX_STR_LEN, index_gridtype, latlon_gridtype
use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date, get_calendar_type, &
VALID_CALENDAR_TYPES, operator(>=), date_to_string, &
OPERATOR(/), OPERATOR(+), operator(<)
@@ -42,8 +42,9 @@ module fms_diag_file_object_mod
use fms_diag_yaml_mod, only: diag_yaml, diagYamlObject_type, diagYamlFiles_type, subRegion_type, diagYamlFilesVar_type
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
fmsDiagAxisContainer_type, DIAGDOMAIN2D_T, DIAGDOMAINUG_T, &
- fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, &
- fmsDiagDiurnalAxis_type, create_new_z_subaxis
+ fmsDiagFullAxis_type, define_diurnal_axis, &
+ fmsDiagDiurnalAxis_type, create_new_z_subaxis, is_parent_axis, &
+ define_new_subaxis_latlon, define_new_subaxis_index, fmsDiagSubAxis_type
use fms_diag_field_object_mod, only: fmsDiagField_type
use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_type
use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, &
@@ -107,6 +108,11 @@ module fms_diag_file_object_mod
procedure, public :: set_domain_from_axis
procedure, public :: set_file_domain
procedure, public :: add_axes
+ procedure, public :: add_new_axis
+ procedure, public :: update_write_on_this_pe
+ procedure, public :: get_write_on_this_pe
+ procedure, public :: does_axis_exist
+ procedure, public :: define_new_subaxis
procedure, public :: add_start_time
procedure, public :: set_file_time_ops
procedure, public :: has_field_ids
@@ -122,6 +128,7 @@ module fms_diag_file_object_mod
procedure, public :: get_file_timeunit
procedure, public :: get_file_unlimdim
procedure, public :: get_file_sub_region
+ procedure, public :: get_file_sub_region_grid_type
procedure, public :: get_file_new_file_freq
procedure, public :: get_filename_time
procedure, public :: get_file_new_file_freq_units
@@ -205,7 +212,7 @@ logical function fms_diag_files_object_init (files_array)
type is (subRegionalFile_type)
allocate(obj%sub_axis_ids(max_axes))
obj%sub_axis_ids = diag_null
- obj%write_on_this_pe = .false.
+ obj%write_on_this_pe = .true.
obj%is_subaxis_defined = .false.
obj%number_of_axis = 0
end select
@@ -508,6 +515,19 @@ function get_file_sub_region (obj) result(res)
res = obj%diag_yaml_file%get_file_sub_region()
end function get_file_sub_region
+!< @brief Query for the subregion grid type (latlon or index)
+!! @return subregion grid type
+function get_file_sub_region_grid_type(this) &
+ result(res)
+ class(fmsDiagFile_type), intent(in) :: this !< Diag file object
+ integer :: res
+
+ type(subRegion_type) :: subregion !< Subregion type
+
+ subregion = this%diag_yaml_file%get_file_sub_region()
+ res = subregion%grid_type
+end function get_file_sub_region_grid_type
+
!> \brief Returns a copy of file_new_file_freq from the yaml object
!! \return Copy of file_new_file_freq
pure function get_file_new_file_freq (this) result(res)
@@ -735,10 +755,17 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id, buffer_id, output
logical :: is_cube_sphere !< Flag indicating if the file's domain is a cubesphere
logical :: axis_found !< Flag indicating that the axis was already to the file obj
integer, allocatable :: var_axis_ids(:) !< Array of the variable's axis ids
+ integer :: x_y_axis_id(2) !< Ids of the x and y axis
+ integer :: x_or_y !< integer indicating if the axis is x or y
+ logical :: is_x_or_y !< flag indicating if the axis is x or y
+ integer :: subregion_gridtype !< The type of the subregion (latlon or index)
+ logical :: write_on_this_pe !< Flag indicating if the current pe is in the subregion
is_cube_sphere = .false.
+ subregion_gridtype = this%get_file_sub_region_grid_type()
field_yaml => diag_yaml%get_diag_field_from_id(yaml_id)
+
!< Created a copy here, because if the variable has a z subaxis var_axis_ids will be modified in
!! `create_new_z_subaxis` to contain the id of the new z subaxis instead of the parent axis,
!! which will be added to the the list of axis in the file object (axis_ids is intent(in),
@@ -752,51 +779,181 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id, buffer_id, output
select type(this)
type is (subRegionalFile_type)
- if (.not. this%is_subaxis_defined) then
- if (associated(this%domain)) then
- if (this%domain%get_ntiles() .eq. 6) is_cube_sphere = .true.
- endif
+ if (associated(this%domain)) then
+ if (this%domain%get_ntiles() .eq. 6) is_cube_sphere = .true.
+ endif
+ if (.not. this%get_write_on_this_pe()) return
+ subaxis_defined: if (this%is_subaxis_defined) then
+ do i = 1, size(var_axis_ids)
+ select type (parent_axis => diag_axis(var_axis_ids(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ axis_found = .false.
+ is_x_or_y = parent_axis%is_x_or_y_axis()
+ do j = 1, this%number_of_axis
+ if (is_x_or_y) then
+ if(is_parent_axis(this%axis_ids(j), var_axis_ids(i), diag_axis)) then
+ axis_found = .true.
+ var_axis_ids(i) = this%axis_ids(j) !Set the var_axis_id to the sub axis_id
+ cycle
+ endif
+ elseif (var_axis_ids(i) .eq. this%axis_ids(j)) then
+ axis_found = .true.
+ endif
+ enddo
+
+ if (.not. axis_found) then
+ if (is_x_or_y) then
+ if (subregion_gridtype .eq. latlon_gridtype .and. is_cube_sphere) &
+ call mpp_error(FATAL, "If using the cube sphere and defining the subregion with latlon "//&
+ "the variable need to have the same x and y axis. Please check the variables in the file "//&
+ trim(this%get_file_fname())//" or use indices to define the subregion.")
+
+ select case (subregion_gridtype)
+ case (index_gridtype)
+ call define_new_subaxis_index(parent_axis, this%get_file_sub_region(), diag_axis, naxis, &
+ i, write_on_this_pe)
+ case (latlon_gridtype)
+ call define_new_subaxis_latlon(diag_axis, var_axis_ids(i:i), naxis, this%get_file_sub_region(), &
+ .false., write_on_this_pe)
+ end select
+ call this%update_write_on_this_pe(write_on_this_pe)
+ if (.not. this%get_write_on_this_pe()) cycle
+ call this%add_new_axis(naxis)
+ var_axis_ids(i) = naxis
+ else
+ call this%add_new_axis(var_axis_ids(i))
+ endif
+ endif
+ type is (fmsDiagSubAxis_type)
+ axis_found = this%does_axis_exist(var_axis_ids(i))
+ if (.not. axis_found) call this%add_new_axis(var_axis_ids(i))
+ end select
+ enddo
+ else
+ x_y_axis_id = diag_null
+ do i = 1, size(var_axis_ids)
+ select type (parent_axis => diag_axis(var_axis_ids(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ if (.not. parent_axis%is_x_or_y_axis(x_or_y)) then
+ axis_found = this%does_axis_exist(var_axis_ids(i))
+ if (.not. axis_found) call this%add_new_axis(var_axis_ids(i))
+ else
+ x_y_axis_id(x_or_y) = var_axis_ids(i)
+ endif
+ type is (fmsDiagSubAxis_type)
+ axis_found = this%does_axis_exist(var_axis_ids(i))
+ if (.not. axis_found) call this%add_new_axis(var_axis_ids(i))
+ end select
+ enddo
- call define_subaxis(diag_axis, var_axis_ids, naxis, this%get_file_sub_region(), &
- is_cube_sphere, this%write_on_this_pe)
+ call this%define_new_subaxis(var_axis_ids, x_y_axis_id, is_cube_sphere, diag_axis, naxis)
this%is_subaxis_defined = .true.
-
- !> add the axis to the list of axis in the file
- if (this%write_on_this_pe) then
- do i = 1, size(var_axis_ids)
- this%number_of_axis = this%number_of_axis + 1 !< This is the current number of axis in the file
- this%axis_ids(this%number_of_axis) = diag_axis(var_axis_ids(i))%axis%get_subaxes_id()
-
- !< Change the variable axis ids to the subaxis that was just created
- var_axis_ids(i) = this%axis_ids(this%number_of_axis)
- enddo
- else
- this%axis_ids = diag_null
- endif
- endif
+ endif subaxis_defined
type is (fmsDiagFile_type)
do i = 1, size(var_axis_ids)
- axis_found = .false.
- do j = 1, this%number_of_axis
- !> Check if the axis already exists, move on
- if (var_axis_ids(i) .eq. this%axis_ids(j)) then
- axis_found = .true.
- cycle
- endif
- enddo
-
- if (.not. axis_found) then
- !> If the axis does not exist add it to the list
- this%number_of_axis = this%number_of_axis + 1
- this%axis_ids(this%number_of_axis) = var_axis_ids(i)
- endif
+ axis_found = this%does_axis_exist(var_axis_ids(i))
+ if (.not. axis_found) call this%add_new_axis(var_axis_ids(i))
enddo
end select
-
!> Add the axis to the buffer object
call output_buffers(buffer_id)%add_axis_ids(var_axis_ids)
end subroutine add_axes
+!> @brief Adds a new axis the list of axis in the diag file object
+subroutine add_new_axis(this, var_axis_id)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ integer, intent(in) :: var_axis_id !< Axis id of the variable
+
+ this%number_of_axis = this%number_of_axis + 1
+ this%axis_ids(this%number_of_axis) = var_axis_id
+end subroutine add_new_axis
+
+!> @brief This updates write on this pe
+subroutine update_write_on_this_pe(this, write_on_this_pe)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ logical, intent(in) :: write_on_this_pe !< .True. if the current PE is in
+ !! subregion
+
+ select type (this)
+ type is (subRegionalFile_type)
+ if (this%write_on_this_pe) this%write_on_this_pe = write_on_this_pe
+ end select
+end subroutine update_write_on_this_pe
+
+!> @brief Query for the write_on_this_pe member of the diag file object
+!! @return the write_on_this_pe member of the diag file object
+function get_write_on_this_pe(this) &
+ result(rslt)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ logical :: rslt
+ rslt = .true.
+ select type (this)
+ type is (subRegionalFile_type)
+ rslt= this%write_on_this_pe
+ end select
+end function get_write_on_this_pe
+
+!< @brief Determine if an axis is already in the list of axis for a diag file
+!! @return .True. if the axis is already in the list of axis for a diag file
+function does_axis_exist(this, var_axis_id) &
+ result(rslt)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ integer, intent(in) :: var_axis_id !< Variable axis id to check
+
+ logical :: rslt
+ integer :: j !< For do loops
+
+ rslt = .false.
+ do j = 1, this%number_of_axis
+ !> Check if the axis already exists, move on
+ if (var_axis_id .eq. this%axis_ids(j)) then
+ rslt = .true.
+ return
+ endif
+ enddo
+end function
+
+!> @brief Define a new sub axis
+subroutine define_new_subaxis(this, var_axis_ids, x_y_axis_id, is_cube_sphere, diag_axis, naxis)
+ class(fmsDiagFile_type), intent(inout) :: this !< The file object
+ integer, INTENT(inout) :: var_axis_ids(:) !< Original variable axis ids
+ integer, INTENT(in) :: x_y_axis_id(:) !< The ids of the x and y axis
+ logical, intent(in) :: is_cube_sphere !< .True. if the axis is in the cubesphere
+ integer, intent(inout) :: naxis !< Number of axis current registered
+ class(fmsDiagAxisContainer_type), intent(inout) :: diag_axis(:) !< Diag_axis object
+
+ logical :: write_on_this_pe !< .True. if the current PE is in the subregion
+ integer :: i, j !< For do loop
+
+ select case (this%get_file_sub_region_grid_type())
+ case(latlon_gridtype)
+ call define_new_subaxis_latlon(diag_axis, x_y_axis_id, naxis, this%get_file_sub_region(), is_cube_sphere, &
+ write_on_this_pe)
+ call this%update_write_on_this_pe(write_on_this_pe)
+ if (.not. this%get_write_on_this_pe()) return
+ call this%add_new_axis(naxis)
+ call this%add_new_axis(naxis-1)
+ do j = 1, size(var_axis_ids)
+ if (x_y_axis_id(1) .eq. var_axis_ids(j)) var_axis_ids(j) = naxis - 1
+ if (x_y_axis_id(2) .eq. var_axis_ids(j)) var_axis_ids(j) = naxis
+ enddo
+ case (index_gridtype)
+ do i = 1, size(x_y_axis_id)
+ select type (parent_axis => diag_axis(x_y_axis_id(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ call define_new_subaxis_index(parent_axis, this%get_file_sub_region(), diag_axis, naxis, i, &
+ write_on_this_pe)
+ call this%update_write_on_this_pe(write_on_this_pe)
+ if (.not. this%get_write_on_this_pe()) return
+ call this%add_new_axis(naxis)
+ do j = 1, size(var_axis_ids)
+ if (x_y_axis_id(i) .eq. var_axis_ids(j)) var_axis_ids(j) = naxis
+ enddo
+ end select
+ enddo
+ end select
+end subroutine define_new_subaxis
+
!> @brief adds the start time to the fileobj
!! @note This should be called from the register field calls. It can be called multiple times (one for each variable)
!! So it needs to make sure that the start_time is the same for each variable. The initial value is the base_time
diff --git a/test_fms/diag_manager/check_time_none.F90 b/test_fms/diag_manager/check_time_none.F90
index e0b3f73541..3925aeaad8 100644
--- a/test_fms/diag_manager/check_time_none.F90
+++ b/test_fms/diag_manager/check_time_none.F90
@@ -20,7 +20,7 @@
!> @brief Checks the output file after running test_reduction_methods using the "none" reduction method
program check_time_none
use fms_mod, only: fms_init, fms_end, string
- use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file, get_dimension_size
use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe, input_nml_file
use platform_mod, only: r4_kind, r8_kind
use testing_utils, only: allocate_buffer, test_normal, test_openmp, test_halos, no_mask, logical_mask, real_mask
@@ -37,6 +37,7 @@ program check_time_none
integer :: nw !< Number of points in the 4th dimension
integer :: i !< For looping
integer :: io_status !< Io status after reading the namelist
+ integer :: dim_size !< dimension size as read from the file
logical :: use_mask !< .true. if using masks
integer :: test_case = test_normal !< Indicates which test case to run
@@ -68,6 +69,23 @@ program check_time_none
if (.not. open_file(fileobj2, "test_none_regional.nc.0005", "read")) &
call mpp_error(FATAL, "unable to open test_none_regional.nc.0005")
+ print *, "Checking the dimensions of the subaxis"
+ ! This is only done for the "none" reduction because the logic that determines the subaxis
+ ! size is independent of the reduction method
+ call get_dimension_size(fileobj1, "x_sub01", dim_size)
+ if (dim_size .ne. 4) call mpp_error(FATAL, "x_sub01 is not the correct size!")
+ call get_dimension_size(fileobj1, "y_sub01", dim_size)
+ if (dim_size .ne. 3) call mpp_error(FATAL, "y_sub01 is not the correct size!")
+ call get_dimension_size(fileobj1, "z_sub01", dim_size)
+ if (dim_size .ne. 2) call mpp_error(FATAL, "z_sub01 is not the correct size!")
+
+ call get_dimension_size(fileobj2, "x_sub01", dim_size)
+ if (dim_size .ne. 4) call mpp_error(FATAL, "x_sub01 is not the correct size!")
+ call get_dimension_size(fileobj2, "y_sub01", dim_size)
+ if (dim_size .ne. 1) call mpp_error(FATAL, "y_sub01 is not the correct size!")
+ call get_dimension_size(fileobj2, "z_sub01", dim_size)
+ if (dim_size .ne. 2) call mpp_error(FATAL, "z_sub01 is not the correct size!")
+
cdata_out = allocate_buffer(1, nx, 1, ny, nz, nw)
do i = 1, 8
From c1a8df811cc81e446d8598ac440cac0d772d63f7 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 9 Feb 2024 12:37:43 -0500
Subject: [PATCH 146/168] fix: correctly adds the associated_files attribute
and other reproducibility fixes (#1451)
---
diag_manager/fms_diag_axis_object.F90 | 11 +-
diag_manager/fms_diag_field_object.F90 | 33 +++++-
diag_manager/fms_diag_file_object.F90 | 17 ++-
diag_manager/fms_diag_object.F90 | 20 +++-
diag_manager/fms_diag_yaml.F90 | 11 +-
test_fms/diag_manager/Makefile.am | 8 +-
test_fms/diag_manager/test_cell_measures.F90 | 105 ++++++++++++++++++
test_fms/diag_manager/test_cell_measures.sh | 64 +++++++++++
test_fms/diag_manager/test_diag_diurnal.F90 | 13 ++-
.../diag_manager/test_reduction_methods.F90 | 1 +
10 files changed, 258 insertions(+), 25 deletions(-)
create mode 100644 test_fms/diag_manager/test_cell_measures.F90
create mode 100755 test_fms/diag_manager/test_cell_measures.sh
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 47bee8e7bd..933a4b387a 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -35,13 +35,13 @@ module fms_diag_axis_object_mod
use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind
use diag_data_mod, only: diag_atttype, max_axes, NO_DOMAIN, TWO_D_DOMAIN, UG_DOMAIN, &
direction_down, direction_up, fmsDiagAttribute_type, max_axis_attributes, &
- MAX_SUBAXES, DIAG_NULL, index_gridtype, latlon_gridtype, pack_size_str, &
+ DIAG_NULL, index_gridtype, latlon_gridtype, pack_size_str, &
get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute,&
get_base_second, is_x_axis, is_y_axis
use mpp_mod, only: FATAL, mpp_error, uppercase, mpp_pe, mpp_root_pe, stdout
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, &
& register_axis, register_field, register_variable_attribute, write_data
- use fms_diag_yaml_mod, only: subRegion_type, diag_yaml
+ use fms_diag_yaml_mod, only: subRegion_type, diag_yaml, MAX_SUBAXES
use diag_grid_mod, only: get_local_indices_cubesphere => get_local_indexes
use axis_utils2_mod, only: nearest_index
implicit none
@@ -153,7 +153,7 @@ module fms_diag_axis_object_mod
CLASS(*), ALLOCATABLE, private :: axis_data(:) !< Data of the axis
CHARACTER(len=:), ALLOCATABLE, private :: type_of_data !< The type of the axis_data ("float" or "double")
!< TO DO this can be a dlinked to avoid having limits
- integer , private :: subaxis(MAX_SUBAXES) !< Array of subaxis
+ integer, ALLOCATABLE, private :: subaxis(:) !< Array of subaxis
integer , private :: nsubaxis !< Number of subaxis
class(diagDomain_t),ALLOCATABLE, private :: axis_domain !< Domain
INTEGER , private :: type_of_domain !< The type of domain ("NO_DOMAIN", "TWO_D_DOMAIN",
@@ -280,6 +280,11 @@ subroutine register_diag_axis_obj(this, axis_name, axis_data, units, cart_name,
this%set_name = ""
if (present(set_name)) this%set_name = trim(set_name)
+ if (MAX_SUBAXES .gt. 0) then
+ allocate(this%subaxis(MAX_SUBAXES))
+ this%subaxis = diag_null
+ endif
+
this%nsubaxis = 0
this%num_attributes = 0
end subroutine register_diag_axis_obj
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 44958cefaa..cf3917785a 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -8,7 +8,7 @@ module fms_diag_field_object_mod
!! that contains all of the information of the variable. It is extended by a type that holds the
!! appropriate buffer for the data for manipulation.
#ifdef use_yaml
-use diag_data_mod, only: diag_null, CMOR_MISSING_VALUE, diag_null_string, MAX_STR_LEN
+use diag_data_mod, only: prepend_date, diag_null, CMOR_MISSING_VALUE, diag_null_string, MAX_STR_LEN
use diag_data_mod, only: r8, r4, i8, i4, string, null_type_int, NO_DOMAIN
use diag_data_mod, only: max_field_attributes, fmsDiagAttribute_type
use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, &
@@ -20,7 +20,7 @@ module fms_diag_field_object_mod
& find_diag_field, get_num_unique_fields, diag_yaml
use fms_diag_axis_object_mod, only: diagDomain_t, get_domain_and_domain_type, fmsDiagAxis_type, &
& fmsDiagAxisContainer_type, fmsDiagFullAxis_Type
-use time_manager_mod, ONLY: time_type
+use time_manager_mod, ONLY: time_type, get_date
use fms2_io_mod, only: FmsNetcdfFile_t, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t, register_field, &
register_variable_attribute
use fms_diag_input_buffer_mod, only: fmsDiagInputBuffer_t
@@ -175,6 +175,7 @@ module fms_diag_field_object_mod
procedure :: has_mask_allocated
procedure :: is_variable_in_file
procedure :: get_field_file_name
+ procedure :: generate_associated_files_att
end type fmsDiagField_type
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
type(fmsDiagField_type) :: null_ob
@@ -1771,5 +1772,33 @@ function get_field_file_name(this) &
res = this%diag_field(1)%get_var_fname()
end function get_field_file_name
+!> @brief Generate the associated files attribute
+subroutine generate_associated_files_att(this, att, start_time)
+ class(fmsDiagField_type) , intent(in) :: this !< diag_field_object for the area/volume field
+ character(len=*), intent(inout) :: att !< associated_files_att
+ type(time_type), intent(in) :: start_time !< The start_time for the field's file
+
+ character(len=:), allocatable :: field_name !< Name of the area/volume field
+ character(len=MAX_STR_LEN) :: file_name !< Name of the file the area/volume field is in!
+ character(len=128) :: start_date !< Start date to append to the begining of the filename
+
+ integer :: year, month, day, hour, minute, second
+ field_name = this%get_varname(to_write = .true.)
+
+ ! Check if the field is already in the associated files attribute (i.e the area can be associated with multiple
+ ! fields in the file, but it only needs to be added once)
+ if (index(att, field_name) .ne. 0) return
+
+ file_name = this%get_field_file_name()
+
+ if (prepend_date) then
+ call get_date(start_time, year, month, day, hour, minute, second)
+ write (start_date, '(1I20.4, 2I2.2)') year, month, day
+ file_name = TRIM(adjustl(start_date))//'.'//TRIM(file_name)
+ endif
+
+ att = trim(att)//" "//trim(field_name)//": "//trim(file_name)//".nc"
+end subroutine generate_associated_files_att
+
#endif
end module fms_diag_field_object_mod
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 632c8a97d6..8ea4d16bf5 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -1560,13 +1560,13 @@ subroutine write_field_metadata(this, diag_field, diag_axis)
diag_file => this%FMS_diag_file
fms2io_fileobj => diag_file%fms2io_fileobj
+ associated_files = ""
+ need_associated_files = .false.
do i = 1, size(diag_file%field_ids)
if (.not. diag_file%field_registered(i)) cycle !TODO do something else here
field_ptr => diag_field(diag_file%field_ids(i))
cell_measures = ""
- associated_files = ""
- need_associated_files = .false.
if (field_ptr%has_area()) then
cell_measures = "area: "//diag_field(field_ptr%get_area())%get_varname(to_write=.true.)
@@ -1574,7 +1574,7 @@ subroutine write_field_metadata(this, diag_field, diag_axis)
!! which contains the file name of the file the area field is in. This is needed for PP/fregrid.
if (.not. diag_field(field_ptr%get_area())%is_variable_in_file(diag_file%id)) then
need_associated_files = .true.
- associated_files = "area: "//diag_field(field_ptr%get_area())%get_field_file_name()//".nc"
+ call diag_field(field_ptr%get_area())%generate_associated_files_att(associated_files, diag_file%start_time)
endif
endif
@@ -1585,19 +1585,18 @@ subroutine write_field_metadata(this, diag_field, diag_axis)
!! which contains the file name of the file the volume field is in. This is needed for PP/fregrid.
if (.not. diag_field(field_ptr%get_volume())%is_variable_in_file(diag_file%id)) then
need_associated_files = .true.
- associated_files = trim(associated_files)//&
- " volume:"//diag_field(field_ptr%get_volume())%get_field_file_name()//".nc"
+ call diag_field(field_ptr%get_volume())%generate_associated_files_att(associated_files, diag_file%start_time)
endif
endif
call field_ptr%write_field_metadata(fms2io_fileobj, diag_file%id, diag_file%yaml_ids(i), diag_axis, &
this%FMS_diag_file%get_file_unlimdim(), is_regional, cell_measures)
-
- if (need_associated_files) &
- call register_global_attribute(fms2io_fileobj, "associated_files", trim(ADJUSTL(associated_files)), &
- str_len=len_trim(ADJUSTL(associated_files)))
enddo
+ if (need_associated_files) &
+ call register_global_attribute(fms2io_fileobj, "associated_files", trim(ADJUSTL(associated_files)), &
+ str_len=len_trim(ADJUSTL(associated_files)))
+
end subroutine write_field_metadata
!< @brief Writes the axis data for the file
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 7ca2e5ee46..adc9f52524 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -93,6 +93,7 @@ module fms_diag_object_mod
procedure :: fms_diag_field_add_cell_measures
procedure :: allocate_diag_field_output_buffers
procedure :: fms_diag_compare_window
+ procedure :: update_current_model_time
#ifdef use_yaml
procedure :: get_diag_buffer
#endif
@@ -604,6 +605,9 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
main_if: if (buffer_the_data) then
!> Only 1 thread allocates the output buffer and sets set_math_needs_to_be_done
!$omp critical
+
+ if (present(time)) call this%update_current_model_time(time)
+
!< These set_* calls need to be done inside an omp_critical to avoid any race conditions
!! and allocation issues
if(has_halos) call this%FMS_diag_fields(diag_field_id)%set_halo_present()
@@ -630,6 +634,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
fms_diag_accept_data = .TRUE.
return
else
+ if (present(time)) call this%update_current_model_time(time)
+
!< At this point if we are no longer in an openmp region or running with 1 thread
!! so it is safe to have these set_* calls
if(has_halos) call this%FMS_diag_fields(diag_field_id)%set_halo_present()
@@ -685,9 +691,6 @@ subroutine fms_diag_send_complete(this, time_step)
integer, dimension(:), allocatable :: file_ids !< Array of file IDs for a field
logical, parameter :: DEBUG_SC = .false. !< turn on output for debugging
- !< Update the current model time by adding the time_step
- this%current_model_time = this%current_model_time + time_step
-
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! In the future, this may be parallelized for offloading
! loop through each field
@@ -716,6 +719,7 @@ subroutine fms_diag_send_complete(this, time_step)
call mpp_error(FATAL, "diag_send_complete:: no input buffer allocated for field"//diag_field%get_longname())
endif has_input_buff
endif doing_math
+ call diag_field%set_math_needs_to_be_done(.False.)
!> Clean up, clean up, everybody do your share
if (allocated(file_ids)) deallocate(file_ids)
if (associated(diag_field)) nullify(diag_field)
@@ -1430,4 +1434,14 @@ function fms_diag_compare_window(this, field, field_id, &
"you can not use the modern diag manager without compiling with -Duse_yaml")
#endif
end function fms_diag_compare_window
+
+!> @brief Update the current model time in the diag object
+subroutine update_current_model_time(this, time)
+ class(fmsDiagObject_type), intent(inout) :: this !< Diag Object
+ type(time_type), intent(in) :: time !< Current diag manager time
+#ifdef use_yaml
+ if(time > this%current_model_time) this%current_model_time = time
+#endif
+end subroutine update_current_model_time
+
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index b916ece615..308243edfe 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -54,11 +54,14 @@ module fms_diag_yaml_mod
public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_id
public :: get_diag_field_ids
public :: dump_diag_yaml_obj
+public :: MAX_SUBAXES
!> @}
integer, parameter :: basedate_size = 6
integer, parameter :: NUM_SUB_REGION_ARRAY = 8
integer, parameter :: MAX_FREQ = 12
+integer :: MAX_SUBAXES = 0 !< Max number of subaxis, set in diag_yaml_object_init depending on
+ !! what is in the diag yaml
!> @brief type to hold an array of sorted diag_fiels
@@ -391,9 +394,13 @@ subroutine diag_yaml_object_init(diag_subset_output)
if(.not. write_file) ignore(i) = .true.
if (.not. ignore(i)) then
- actual_num_files = actual_num_files + 1
!< If ignoring the file, ignore the fields in that file too!
total_nvars = total_nvars + get_total_num_vars(diag_yaml_id, diag_file_ids(i))
+ if (total_nvars .ne. 0) then
+ actual_num_files = actual_num_files + 1
+ else
+ ignore(i) = .true.
+ endif
endif
enddo
@@ -532,6 +539,7 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, yaml_fileobj)
nsubregion = 0
nsubregion = get_num_blocks(diag_yaml_id, "sub_region", parent_block_id=diag_file_id)
if (nsubregion .eq. 1) then
+ MAX_SUBAXES = MAX_SUBAXES + 1
call get_block_ids(diag_yaml_id, "sub_region", sub_region_id, parent_block_id=diag_file_id)
call diag_get_value_from_key(diag_yaml_id, sub_region_id(1), "grid_type", grid_type)
call get_sub_region(diag_yaml_id, sub_region_id(1), yaml_fileobj%file_sub_region, grid_type, &
@@ -612,6 +620,7 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field)
!> Set the zbounds if they exist
field%var_zbounds = DIAG_NULL
call get_value_from_key(diag_file_id, var_id, "zbounds", field%var_zbounds, is_optional=.true.)
+ if (field%has_var_zbounds()) MAX_SUBAXES = MAX_SUBAXES + 1
end subroutine
!> @brief diag_manager wrapper to get_value_from_key to use for allocatable
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index eaea80ead8..6c77601f20 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -32,7 +32,7 @@ check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
check_time_min check_time_max check_time_sum check_time_avg test_diag_diurnal check_time_diurnal \
- check_time_pow check_time_rms
+ check_time_pow check_time_rms test_cell_measures
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -53,6 +53,7 @@ check_time_avg_SOURCES = testing_utils.F90 check_time_avg.F90
check_time_diurnal_SOURCES = testing_utils.F90 check_time_diurnal.F90
check_time_pow_SOURCES = testing_utils.F90 check_time_pow.F90
check_time_rms_SOURCES = testing_utils.F90 check_time_rms.F90
+test_cell_measures_SOURCES = test_cell_measures.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
@@ -60,13 +61,14 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
# Run the test.
TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh \
- test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh
+ test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh test_cell_measures.sh
testing_utils.mod: testing_utils.$(OBJEXT)
# Copy over other needed files to the srcdir
EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \
- test_time_sum.sh test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh
+ test_time_sum.sh test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh \
+ test_cell_measures.sh
if USING_YAML
skipflag=""
diff --git a/test_fms/diag_manager/test_cell_measures.F90 b/test_fms/diag_manager/test_cell_measures.F90
new file mode 100644
index 0000000000..c7b9b194fe
--- /dev/null
+++ b/test_fms/diag_manager/test_cell_measures.F90
@@ -0,0 +1,105 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This program tests the diag_manager with fields with cell measures (area, volume)
+program test_cell_measures
+ use fms_mod, only: fms_init, fms_end
+ use diag_manager_mod, only: diag_axis_init, register_static_field, diag_send_complete, send_data
+ use diag_manager_mod, only : register_diag_field
+ use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_manager_set_time_end
+ use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+)
+ use mpp_mod, only: mpp_error, FATAL
+ use fms2_io_mod
+ use platform_mod, only: r4_kind
+
+ implicit none
+
+ type(time_type) :: Time !< Time of the simulation
+ type(time_type) :: Time_step !< Time_step of the simulation
+ integer :: i !< For looping
+ integer :: id_axis1 !< Id of axis1
+ integer :: naxis1 !< Size of axis1
+ real(kind=r4_kind), allocatable :: axis1_data(:) !< Data for axis1
+ integer :: id_var1 !< Id of var1
+ real(kind=r4_kind), allocatable :: var1_data(:) !< Data for "var1"
+ real(kind=r4_kind), allocatable :: area_data(:) !< Data for the "area"
+ integer :: id_area !< Id of the "area" field
+ logical :: used !< Used for send_data call
+
+ naxis1 = 10
+ call fms_init()
+ call set_calendar_type(JULIAN)
+ call diag_manager_init()
+
+ Time = set_date(2,1,1,0,0,0)
+ Time_step = set_time (3600,0)
+ call diag_manager_set_time_end(set_date(2,1,2,0,0,0))
+
+ allocate(axis1_data(naxis1))
+ allocate(var1_data(naxis1))
+ allocate(area_data(naxis1))
+ do i = 1, naxis1
+ axis1_data = real(i, kind=r4_kind)
+ area_data = real(i/100, kind=r4_kind)
+ var1_data = real(i*10, kind=r4_kind)
+ enddo
+
+ id_axis1 = diag_axis_init('axis1', axis1_data, 'axis1', 'x')
+ id_area = register_static_field ('fun_mod', 'area', (/id_axis1/))
+ id_var1 = register_diag_field ('fun_mod', 'var1', (/id_axis1/), init_time=Time, area=id_area)
+
+ used = send_data(id_area, area_data)
+
+ do i = 1, 6
+ Time = Time + Time_step
+ call diag_send_complete(Time_step)
+ used = send_data(id_var1, var1_data, Time)
+ enddo
+ call diag_manager_end(Time)
+
+ call check_output()
+ call fms_end()
+
+ contains
+ subroutine check_output()
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2io fileobj
+ character(len=256) :: buffer !< Buffer to read stuff into
+
+ ! Check that the static_file.nc was created and it contains the area attribute
+ if (.not. open_file(fileobj, "static_file.nc", "read")) &
+ call mpp_error(FATAL, "static_file.nc was not created by the diag manager!")
+ if (.not. variable_exists(fileobj, "area")) &
+ call mpp_error(FATAL, "area is not in static_file.nc")
+ call close_file(fileobj)
+
+ ! Check that file1.nc exists, that it contains the associated files attribute and it is correct,
+ ! that the var1 exists and it contains the cell_measures attributes
+ if (.not. open_file(fileobj, "file1.nc", "read")) &
+ call mpp_error(FATAL, "file1.nc was not created by the diag manager!")
+
+ call get_global_attribute(fileobj, "associated_files", buffer)
+ if (trim(buffer) .ne. "area: static_file.nc") &
+ call mpp_error(FATAL, "The associated_files global attribute is not the expected result! "//trim(buffer))
+
+ call get_variable_attribute(fileobj, "var1", "cell_measures", buffer)
+ if (trim(buffer) .ne. "area: area") &
+ call mpp_error(FATAL, "The cell_measures attribute is not the expected result! "//trim(buffer))
+ call close_file(fileobj)
+ end subroutine check_output
+end program
diff --git a/test_fms/diag_manager/test_cell_measures.sh b/test_fms/diag_manager/test_cell_measures.sh
new file mode 100755
index 0000000000..c97216fdb4
--- /dev/null
+++ b/test_fms/diag_manager/test_cell_measures.sh
@@ -0,0 +1,64 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+cat <<_EOF > diag_table.yaml
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+
+diag_files:
+- file_name: static_file
+ freq: -1
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: fun_mod
+ var_name: area
+ reduction: none
+ kind: r4
+# Here file 1 does not have the "area" variable so the associated files attribute is expected
+- file_name: file1
+ freq: 6 hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: fun_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+_EOF
+
+# remove any existing files that would result in false passes during checks
+rm -f *.nc
+
+my_test_count=1
+printf "&diag_manager_nml \n use_modern_diag=.true. \n/" | cat > input.nml
+test_expect_success "Running diag_manager with fields with cell measures (area, volume) (test $my_test_count)" '
+ mpirun -n 1 ../test_cell_measures
+'
+fi
+test_done
diff --git a/test_fms/diag_manager/test_diag_diurnal.F90 b/test_fms/diag_manager/test_diag_diurnal.F90
index 127f52f747..5890cff294 100644
--- a/test_fms/diag_manager/test_diag_diurnal.F90
+++ b/test_fms/diag_manager/test_diag_diurnal.F90
@@ -49,7 +49,6 @@ program test_diag_diurnal
integer :: jec, jed !< Ending y compute, data domain index
integer :: nhalox !< Number of halos in x
integer :: nhaloy !< Number of halos in y
- integer :: nhours !< number of hours to send per time step
real(kind=r8_kind), allocatable :: cdata(:,:,:,:) !< Data in the compute domain
real(kind=r8_kind), allocatable :: ddata(:,:,:,:) !< Data in the data domain
real(kind=r8_kind), allocatable :: crmask(:,:,:,:) !< Mask in the compute domain
@@ -60,6 +59,7 @@ program test_diag_diurnal
type(time_type) :: Time_step !< Time of the simulation
integer :: nmonths !< number of months to run for (submits ntimes per month)
integer :: ndays !< number of days in the month
+ integer :: nhours !< number of hours in a day - 1
integer :: id_x !< axis id for the x dimension
integer :: id_y !< axis id for the y dimension
integer :: id_z !< axis id for the z dimension
@@ -113,6 +113,7 @@ program test_diag_diurnal
nhalox = 2
nhaloy = 2
nmonths = 3
+ nhours = 23 !< Number of hours in a day - 1
!< Create a lat/lon domain
call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain', xhalo=nhalox, yhalo=nhaloy)
@@ -185,12 +186,16 @@ program test_diag_diurnal
'mullions', missing_value = missing_value)
! iterate through nmonths and each day, each hour
- do m = 1, nmonths
+ do m = 1, nmonths + 1
Time = set_date(2,m,1)
ndays = days_in_month(Time)
- print * , "days in month:", ndays
+ if (m .eq. nmonths + 1) then
+ ! This it so that is can run till (2 4 1 0 0 0)
+ ndays = 1
+ nhours = 0
+ endif
do d = 1, ndays
- do h = 0, 23 ! hours
+ do h = 0, nhours ! hours
Time = set_date(2,m,d,hour=h)
call set_buffer(cdata, m, d, h)
diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90
index 0e7c18b8aa..df5102e761 100644
--- a/test_fms/diag_manager/test_reduction_methods.F90
+++ b/test_fms/diag_manager/test_reduction_methods.F90
@@ -288,6 +288,7 @@ program test_reduction_methods
enddo
end select
call diag_send_complete(Time_step)
+ call diag_send_complete(Time_step)
enddo
call diag_manager_end(Time)
From 66934eae49836f719c1d80a9459d7e8515fe4d8a Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 13 Feb 2024 10:57:58 -0500
Subject: [PATCH 147/168] fix: finish diag manager reduction methods at the
right time (#1459)
---
diag_manager/fms_diag_file_object.F90 | 64 +++++++++------
diag_manager/fms_diag_object.F90 | 102 ++++++++++++------------
diag_manager/fms_diag_output_buffer.F90 | 32 +++++++-
3 files changed, 120 insertions(+), 78 deletions(-)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 8ea4d16bf5..4a42fce005 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -184,6 +184,8 @@ module fms_diag_file_object_mod
procedure :: update_current_new_file_freq_index
procedure :: increase_unlim_dimension_level
procedure :: get_unlim_dimension_level
+ procedure :: get_next_output
+ procedure :: get_next_next_output
procedure :: close_diag_file
end type fmsDiagFileContainer_type
@@ -1293,13 +1295,11 @@ end subroutine write_time_metadata
!> \brief Write out the field data to the file
subroutine write_field_data(this, field_obj, buffer_obj)
class(fmsDiagFileContainer_type), intent(in), target :: this !< The diag file object to write to
- type(fmsDiagField_type), intent(in), target :: field_obj(:) !< The field object to write from
- type(fmsDiagOutputBuffer_type), intent(inout), target :: buffer_obj(:) !< The buffer object with the data
+ type(fmsDiagField_type), intent(in), target :: field_obj !< The field object to write from
+ type(fmsDiagOutputBuffer_type), intent(inout), target :: buffer_obj !< The buffer object with the data
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< Fileobj to write to
- integer :: i !< For do loops
- integer :: field_id !< The id of the field writing the data from
logical :: has_diurnal !< indicates if theres a diurnal axis to adjust for
diag_file => this%FMS_diag_file
@@ -1309,29 +1309,23 @@ subroutine write_field_data(this, field_obj, buffer_obj)
if (diag_file%is_static) then
!< Here the file is static so there is no need for the unlimited dimension
!! as a variables are static
- do i = 1, diag_file%number_of_buffers
- call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj)
- enddo
+ call buffer_obj%write_buffer(fms2io_fileobj)
else
- do i = 1, diag_file%number_of_buffers
- field_id = buffer_obj(diag_file%buffer_ids(i))%get_field_id()
- if (field_obj(field_id)%is_static()) then
- !< If the variable is static, only write it the first time
+ if (field_obj%is_static()) then
+ !< If the variable is static, only write it the first time
+ if (diag_file%unlim_dimension_level .eq. 1) &
+ call buffer_obj%write_buffer(fms2io_fileobj)
+ else
+ has_diurnal = buffer_obj%get_diurnal_sample_size() .gt. 1
+ if (.not. buffer_obj%is_there_data_to_write()) then
+ ! Only print the error message once
if (diag_file%unlim_dimension_level .eq. 1) &
- call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj)
- else
- has_diurnal = buffer_obj(diag_file%buffer_ids(i))%get_diurnal_sample_size() .gt. 1
- if (.not. buffer_obj(diag_file%buffer_ids(i))%is_there_data_to_write()) then
- ! Only print the error message once
- if (diag_file%unlim_dimension_level .eq. 1) &
- call mpp_error(NOTE, "Send data was never called. Writing fill values for variable "//&
- field_obj(field_id)%get_varname()//" in mod "//field_obj(field_id)%get_modname())
- cycle
- endif
- call buffer_obj(diag_file%buffer_ids(i))%write_buffer(fms2io_fileobj, &
- unlim_dim_level=diag_file%unlim_dimension_level, is_diurnal=has_diurnal)
+ call mpp_error(NOTE, "Send data was never called. Writing fill values for variable "//&
+ field_obj%get_varname()//" in mod "//field_obj%get_modname())
endif
- enddo
+ call buffer_obj%write_buffer(fms2io_fileobj, &
+ unlim_dim_level=diag_file%unlim_dimension_level, is_diurnal=has_diurnal)
+ endif
endif
end subroutine write_field_data
@@ -1354,7 +1348,7 @@ logical function is_time_to_write(this, time_step)
class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
TYPE(time_type), intent(in) :: time_step !< Current model step time
- if (time_step >= this%FMS_diag_file%next_output) then
+ if (time_step > this%FMS_diag_file%next_output) then
is_time_to_write = .true.
if (this%FMS_diag_file%is_static) return
if (time_step > this%FMS_diag_file%next_next_output) &
@@ -1489,6 +1483,26 @@ pure function get_unlim_dimension_level(this) &
res = this%FMS_diag_file%unlim_dimension_level
end function
+!> \brief Get the next_output for the file object
+!! \return The next_output
+pure function get_next_output(this) &
+result(res)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
+ type(time_type) :: res
+
+ res = this%FMS_diag_file%next_output
+end function get_next_output
+
+!> \brief Get the next_output for the file object
+!! \return The next_output
+pure function get_next_next_output(this) &
+result(res)
+ class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
+ type(time_type) :: res
+
+ res = this%FMS_diag_file%next_next_output
+end function get_next_next_output
+
!< @brief Writes the axis metadata for the file
subroutine write_axis_metadata(this, diag_axis)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index adc9f52524..2d93e5e2c9 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -153,7 +153,7 @@ subroutine fms_diag_object_end (this, time)
!TODO: loop through files and force write
if (.not. this%initialized) return
- call this%fms_diag_do_io(is_end_of_run=.true.)
+ call this%fms_diag_do_io(end_time=time)
!TODO: Deallocate diag object arrays and clean up all memory
do i=1, size(this%FMS_diag_output_buffers)
call this%FMS_diag_output_buffers(i)%flush_buffer()
@@ -233,23 +233,9 @@ integer function fms_register_diag_field_obj &
file_ids = get_diag_files_id(diag_field_indices)
call fieldptr%set_file_ids(file_ids)
-!> Initialize buffer_ids of this field with the diag_field_indices(diag_field_indices)
-!! of the sorted variable list
- fieldptr%buffer_ids = get_diag_field_ids(diag_field_indices)
- do i = 1, size(fieldptr%buffer_ids)
- bufferptr => this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))
- call bufferptr%set_field_id(this%registered_variables)
- call bufferptr%set_yaml_id(fieldptr%buffer_ids(i))
- ! check if diurnal reduction for this buffer and if so set the diurnal sample size
- yamlfptr => diag_yaml%diag_fields(fieldptr%buffer_ids(i))
- if( yamlfptr%get_var_reduction() .eq. time_diurnal) then
- call bufferptr%set_diurnal_sample_size(yamlfptr%get_n_diurnal())
- endif
- call bufferptr%init_buffer_time(init_time)
- enddo
-
!> Allocate and initialize member buffer_allocated of this field
fieldptr%buffer_allocated = .false.
+ fieldptr%buffer_ids = get_diag_field_ids(diag_field_indices)
!> Register the data for the field
call fieldptr%register(modname, varname, diag_field_indices, this%diag_axis, &
@@ -298,6 +284,22 @@ integer function fms_register_diag_field_obj &
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
endif
+
+ !> Initialize buffer_ids of this field with the diag_field_indices(diag_field_indices)
+!! of the sorted variable list
+ do i = 1, size(fieldptr%buffer_ids)
+ bufferptr => this%FMS_diag_output_buffers(fieldptr%buffer_ids(i))
+ call bufferptr%set_field_id(this%registered_variables)
+ call bufferptr%set_yaml_id(fieldptr%buffer_ids(i))
+ ! check if diurnal reduction for this buffer and if so set the diurnal sample size
+ yamlfptr => diag_yaml%diag_fields(fieldptr%buffer_ids(i))
+ if( yamlfptr%get_var_reduction() .eq. time_diurnal) then
+ call bufferptr%set_diurnal_sample_size(yamlfptr%get_n_diurnal())
+ endif
+ call bufferptr%init_buffer_time(init_time)
+ call bufferptr%set_next_output(this%FMS_diag_files(file_ids(i))%get_next_output())
+ enddo
+
nullify (fileptr)
nullify (fieldptr)
deallocate(diag_field_indices)
@@ -734,10 +736,9 @@ end subroutine fms_diag_send_complete
!! variable metadata and data when necessary.
!! TODO: passing in the saved mask from the field obj to diag_reduction_done_wrapper
!! for performance
-subroutine fms_diag_do_io(this, is_end_of_run)
+subroutine fms_diag_do_io(this, end_time)
class(fmsDiagObject_type), target, intent(inout) :: this !< The diag object
- logical, optional, intent(in) :: is_end_of_run !< If .true. this is the end of the run,
- !! so force write
+ type(time_type), optional, target, intent(in) :: end_time !< the model end_time
#ifdef use_yaml
integer :: i !< For do loops
class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience)
@@ -750,7 +751,7 @@ subroutine fms_diag_do_io(this, is_end_of_run)
logical :: file_is_opened_this_time_step !< True if the file was opened in this time_step
!! If true the metadata will need to be written
logical :: force_write !< force the last write if at end of run
- logical :: is_writing !< true if we are writing the actual field data (metadata is always written)
+ logical :: finish_writing !< true if finished writing for all the fields
logical :: has_mask !< whether we have a mask
logical, parameter :: DEBUG_REDUCT = .false. !< enables debugging output
class(*), allocatable :: missing_val !< netcdf missing value for a given field
@@ -758,9 +759,12 @@ subroutine fms_diag_do_io(this, is_end_of_run)
character(len=128) :: error_string !< outputted error string from reducti
force_write = .false.
- if (present (is_end_of_run)) force_write = .true.
-
- model_time => this%current_model_time
+ if (present (end_time)) then
+ force_write = .true.
+ model_time => end_time
+ else
+ model_time => this%current_model_time
+ endif
do i = 1, size(this%FMS_diag_files)
diag_file => this%FMS_diag_files(i)
@@ -775,22 +779,23 @@ subroutine fms_diag_do_io(this, is_end_of_run)
call diag_file%write_time_metadata()
call diag_file%write_field_metadata(this%FMS_diag_fields, this%diag_axis)
call diag_file%write_axis_data(this%diag_axis)
+ call diag_file%increase_unlim_dimension_level()
endif
- is_writing = diag_file%is_time_to_write(model_time)
+ finish_writing = diag_file%is_time_to_write(model_time)
! finish reduction method if its time to write
- buff_reduct: if (is_writing) then
- buff_ids = diag_file%FMS_diag_file%get_buffer_ids()
- ! loop through the buffers and finish reduction if needed
- buff_loop: do ibuff=1, SIZE(buff_ids)
- diag_buff => this%FMS_diag_output_buffers(buff_ids(ibuff))
- field_yaml => diag_yaml%diag_fields(diag_buff%get_yaml_id())
- diag_field => this%FMS_diag_fields(diag_buff%get_field_id())
+ buff_ids = diag_file%FMS_diag_file%get_buffer_ids()
+ ! loop through the buffers and finish reduction if needed
+ buff_loop: do ibuff=1, SIZE(buff_ids)
+ diag_buff => this%FMS_diag_output_buffers(buff_ids(ibuff))
+ field_yaml => diag_yaml%diag_fields(diag_buff%get_yaml_id())
+ diag_field => this%FMS_diag_fields(diag_buff%get_field_id())
- ! Go away if there is no data to write
- if (.not. diag_buff%is_there_data_to_write()) cycle
+ ! Go away if there is no data to write
+ if (.not. diag_buff%is_there_data_to_write()) cycle
+ if ( diag_buff%is_time_to_finish_reduction(end_time)) then
! sets missing value
mval = diag_field%find_missing_value(missing_val)
! time_average and greater values all involve averaging so need to be "finished" before written
@@ -801,28 +806,25 @@ subroutine fms_diag_do_io(this, is_end_of_run)
if(has_mask) has_mask = diag_field%get_mask_variant()
error_string = diag_buff%diag_reduction_done_wrapper( &
field_yaml%get_var_reduction(), &
- mval, has_mask)
+ mval, has_mask)
endif
endif
- !endif
- nullify(diag_buff)
- nullify(field_yaml)
- enddo buff_loop
- deallocate(buff_ids)
- endif buff_reduct
-
- if (is_writing) then
- call diag_file%increase_unlim_dimension_level()
+ call diag_file%write_field_data(diag_field, diag_buff)
+ call diag_buff%set_next_output(diag_file%get_next_next_output())
+ endif
+ nullify(diag_buff)
+ nullify(field_yaml)
+ enddo buff_loop
+ deallocate(buff_ids)
+
+ if (finish_writing) then
call diag_file%write_time_data()
- call diag_file%write_field_data(this%FMS_diag_fields, this%FMS_diag_output_buffers)
call diag_file%update_next_write(model_time)
call diag_file%update_current_new_file_freq_index(model_time)
+ call diag_file%increase_unlim_dimension_level()
if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file()
else if (force_write) then
- if (diag_file%get_unlim_dimension_level() .eq. 0) then
- call diag_file%increase_unlim_dimension_level()
- call diag_file%write_time_data()
- endif
+ call diag_file%write_time_data()
call diag_file%close_diag_file()
endif
enddo
@@ -970,6 +972,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
!< Determine the reduction method for the buffer
reduction_method = field_yaml_ptr%get_var_reduction()
+ if (present(time)) new_time = buffer_ptr%update_buffer_time(time)
select case(reduction_method)
case (time_none)
error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
@@ -996,21 +999,18 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
return
endif
case (time_average)
- new_time = buffer_ptr%update_buffer_time(time)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
bounds_in, bounds_out, missing_value, new_time)
if (trim(error_msg) .ne. "") then
return
endif
case (time_power)
- new_time = buffer_ptr%update_buffer_time(time)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
bounds_in, bounds_out, missing_value, new_time, pow_value=field_yaml_ptr%get_pow_value())
if (trim(error_msg) .ne. "") then
return
endif
case (time_rms)
- new_time = buffer_ptr%update_buffer_time(time)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
bounds_in, bounds_out, missing_value, new_time, pow_value = 2)
if (trim(error_msg) .ne. "") then
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 1ad9581868..ed37b7e923 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -27,9 +27,9 @@ module fms_diag_output_buffer_mod
#ifdef use_yaml
use platform_mod
use iso_c_binding
-use time_manager_mod, only: time_type, operator(==), get_ticks_per_second, get_time, operator(>)
+use time_manager_mod, only: time_type, operator(==), operator(>=), get_ticks_per_second, get_time, operator(>)
use constants_mod, only: SECONDS_PER_DAY
-use mpp_mod, only: mpp_error, FATAL, NOTE
+use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe, mpp_root_pe
use diag_data_mod, only: DIAG_NULL, DIAG_NOT_REGISTERED, i4, i8, r4, r8, get_base_time, MIN_VALUE, MAX_VALUE, EMPTY, &
time_min, time_max
use fms2_io_mod, only: FmsNetcdfFile_t, write_data, FmsNetcdfDomainFile_t, FmsNetcdfUnstructuredDomainFile_t
@@ -61,6 +61,7 @@ module fms_diag_output_buffer_mod
!! time and sample size if using a diurnal reduction
logical :: send_data_called !< .True. if send_data has been called
type(time_type) :: time !< The last time the data was received
+ type(time_type) :: next_output !< The next time to output the data
contains
procedure :: add_axis_ids
@@ -70,8 +71,10 @@ module fms_diag_output_buffer_mod
procedure :: set_yaml_id
procedure :: get_yaml_id
procedure :: init_buffer_time
+ procedure :: set_next_output
procedure :: update_buffer_time
procedure :: is_there_data_to_write
+ procedure :: is_time_to_finish_reduction
procedure :: set_send_data_called
procedure :: is_done_with_math
procedure :: set_done_with_math
@@ -347,6 +350,14 @@ subroutine init_buffer_time(this, time)
endif
end subroutine init_buffer_time
+!> @brief Sets the next output
+subroutine set_next_output(this, time)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ type(time_type), intent(in) :: time !< time to add to the buffer
+
+ this%next_output = time
+end subroutine set_next_output
+
!> @brief Update the buffer time if it is a new time
!! @return .true. if the buffer was updated
function update_buffer_time(this, time) &
@@ -806,6 +817,23 @@ function is_there_data_to_write(this) &
res = this%send_data_called
end function
+!> @brief Determine if it is time to finish the reduction method
+!! @return .true. if it is time to finish the reduction method
+function is_time_to_finish_reduction(this, end_time) &
+ result(res)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ type(time_type), optional, intent(in) :: end_time !< The time at the end of the run
+
+ logical :: res
+
+ res = .false.
+ if (this%time >= this%next_output) res = .true.
+
+ if (present(end_time)) then
+ if (end_time >= this%next_output) res = .true.
+ endif
+end function is_time_to_finish_reduction
+
!> @brief Sets send_data_called to .true.
subroutine set_send_data_called(this)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
From 6900a7a2fe964d0a54c789c960160df20edee4a8 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 22 Feb 2024 09:01:03 -0500
Subject: [PATCH 148/168] fix: diag manager support for multiple z subaxes and
for static variables and files (#1461)
---
diag_manager/fms_diag_axis_object.F90 | 27 +++-
diag_manager/fms_diag_file_object.F90 | 30 ++++-
diag_manager/fms_diag_object.F90 | 4 +-
diag_manager/fms_diag_output_buffer.F90 | 8 +-
test_fms/diag_manager/Makefile.am | 8 +-
test_fms/diag_manager/check_subregional.F90 | 139 ++++++++++++++++++++
test_fms/diag_manager/test_subregional.sh | 111 ++++++++++++++++
7 files changed, 311 insertions(+), 16 deletions(-)
create mode 100644 test_fms/diag_manager/check_subregional.F90
create mode 100755 test_fms/diag_manager/test_subregional.sh
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 933a4b387a..fe400b04cf 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -813,7 +813,7 @@ end subroutine get_compute_domain
!!!!!!!!!!!!!!!!!! SUB AXIS PROCEDURES !!!!!!!!!!!!!!!!!
!> @brief Fills in the information needed to define a subaxis
subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id, parent_axis_name, compute_idx, &
- global_idx, zbounds)
+ global_idx, zbounds, nz_subaxis)
class(fmsDiagSubAxis_type) , INTENT(INOUT) :: this !< diag_sub_axis obj
integer , intent(in) :: starting_index !< Starting index of the subRegion for the PE
integer , intent(in) :: ending_index !< Ending index of the subRegion for the PE
@@ -825,12 +825,21 @@ subroutine fill_subaxis(this, starting_index, ending_index, axis_id, parent_id,
integer, optional, intent(in) :: global_idx(2) !< Starting and ending index of
!! the axis's compute domain
real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the z-axis
+ integer, optional, intent(in) :: nz_subaxis !< The number of z subaxis that have been defined
+ !! in the file
+
+ integer :: nsubaxis !< The subaxis number in the axis name subXX
+ character(len=2) :: nsubaxis_char !< nsubaxis converted to a string
+
+ nsubaxis = 1
+ if (present(nz_subaxis)) nsubaxis = nz_subaxis
this%axis_id = axis_id
this%starting_index = starting_index
this%ending_index = ending_index
this%parent_axis_id = parent_id
- this%subaxis_name = trim(parent_axis_name)//"_sub01"
+ write(nsubaxis_char, '(i2.2)') nsubaxis
+ this%subaxis_name = trim(parent_axis_name)//"_sub"//nsubaxis_char
this%compute_idx = compute_idx
if (present(zbounds)) then
@@ -1235,7 +1244,8 @@ end subroutine define_new_subaxis_latlon
!> @brief Creates a new subaxis and fills it will all the information it needs
subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
- starting_index, ending_index, compute_idx, global_idx, new_axis_id, zbounds)
+ starting_index, ending_index, compute_idx, global_idx, new_axis_id, zbounds, &
+ nz_subaxis)
class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Diag_axis object
class(fmsDiagFullAxis_type), intent(inout) :: parent_axis !< The parent axis
@@ -1250,6 +1260,8 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
!! the axis's global domain
integer, optional, intent(out) :: new_axis_id !< Axis id of the axis this is creating
real(kind=r4_kind), optional, intent(in) :: zbounds(2) !< Bounds of the Z axis
+ integer, optional, intent(in) :: nz_subaxis !< The number of z subaxis that have
+ !! been defined in the file
naxis = naxis + 1 !< This is the axis id of the new axis!
@@ -1265,7 +1277,7 @@ subroutine define_new_axis(diag_axis, parent_axis, naxis, parent_id, &
select type (sub_axis => diag_axis(naxis)%axis)
type is (fmsDiagSubAxis_type)
call sub_axis%fill_subaxis(starting_index, ending_index, naxis, parent_id, &
- parent_axis%axis_name, compute_idx, global_idx=global_idx, zbounds=zbounds)
+ parent_axis%axis_name, compute_idx, global_idx=global_idx, zbounds=zbounds, nz_subaxis=nz_subaxis)
end select
end subroutine define_new_axis
@@ -1377,7 +1389,7 @@ subroutine write_diurnal_metadata(this, fms2io_fileobj)
end subroutine write_diurnal_metadata
!> @brief Creates a new z subaxis to use
- subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_axis_id, nfile_axis)
+ subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_axis_id, nfile_axis, nz_subaxis)
real(kind=r4_kind), intent(in) :: zbounds(2) !< Bounds of the Z axis
integer, intent(inout) :: var_axis_ids(:) !< The variable's axis_ids
class(fmsDiagAxisContainer_type), target, intent(inout) :: diag_axis(:) !< Array of diag_axis objects
@@ -1386,6 +1398,8 @@ subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_ax
integer, intent(inout) :: file_axis_id(:) !< The file's axis_ids
integer, intent(inout) :: nfile_axis !< Number of axis that have been
!! defined in file
+ integer, intent(inout) :: nz_subaxis !< The number of z subaxis currently
+ !! defined in the file
class(*), pointer :: zaxis_data(:) !< The data of the full zaxis
integer :: subaxis_indices(2) !< The starting and ending indices of the subaxis relative to the full
@@ -1429,9 +1443,10 @@ subroutine create_new_z_subaxis(zbounds, var_axis_ids, diag_axis, naxis, file_ax
subaxis_indices(2) = nearest_index(real(zbounds(2)), real(zaxis_data))
end select
+ nz_subaxis = nz_subaxis + 1
call define_new_axis(diag_axis, parent_axis, naxis, parent_axis%axis_id, &
&subaxis_indices(1), subaxis_indices(2), (/lbound(zaxis_data,1), ubound(zaxis_data,1)/), &
- &new_axis_id=subaxis_id, zbounds=zbounds)
+ &new_axis_id=subaxis_id, zbounds=zbounds, nz_subaxis=nz_subaxis)
var_axis_ids(i) = subaxis_id
return
endif
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 4a42fce005..0ce1e906c6 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -96,6 +96,7 @@ module fms_diag_file_object_mod
logical :: time_ops !< .True. if file contains variables that are time_min, time_max, time_average or time_sum
integer :: unlim_dimension_level !< The unlimited dimension level currently being written
logical :: is_static !< .True. if the frequency is -1
+ integer :: nz_subaxis !< The number of Z axis currently added to the file
contains
procedure, public :: add_field_and_yaml_id
@@ -270,6 +271,7 @@ logical function fms_diag_files_object_init (files_array)
obj%time_ops = .false.
obj%unlim_dimension_level = 0
obj%is_static = obj%get_file_freq() .eq. -1
+ obj%nz_subaxis = 0
nullify(obj)
enddo set_ids_loop
@@ -776,7 +778,7 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id, buffer_id, output
if (field_yaml%has_var_zbounds()) then
call create_new_z_subaxis(field_yaml%get_var_zbounds(), var_axis_ids, diag_axis, naxis, &
- this%axis_ids, this%number_of_axis)
+ this%axis_ids, this%number_of_axis, this%nz_subaxis)
endif
select type(this)
@@ -987,8 +989,15 @@ subroutine add_start_time(this, start_time, model_time)
if (this%has_file_new_file_freq()) then
this%next_close = diag_time_inc(this%start_time, this%get_file_new_file_freq(), &
this%get_file_new_file_freq_units())
- else
- this%next_close = diag_time_inc(this%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ else
+ if (this%is_static) then
+ ! If the file is static, set the close time to be equal to the start_time, so that it can be closed
+ ! after the first write!
+ this%next_close = this%start_time
+ this%next_next_output = diag_time_inc(this%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ else
+ this%next_close = diag_time_inc(this%start_time, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
+ endif
endif
if(this%has_file_duration()) then
@@ -1357,6 +1366,10 @@ logical function is_time_to_write(this, time_step)
&" needed by the file.")
else
is_time_to_write = .false.
+ if (this%FMS_diag_file%is_static) then
+ ! This is to ensure that static files get finished in the begining of the run
+ if (this%FMS_diag_file%unlim_dimension_level .eq. 1) is_time_to_write = .true.
+ endif
endif
end function is_time_to_write
@@ -1374,8 +1387,9 @@ logical function writing_on_this_pe(this)
end function
!> \brief Write out the time data to the file
-subroutine write_time_data(this)
+subroutine write_time_data(this, is_the_end)
class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
+ logical, optional, intent(in) :: is_the_end !< True if it is the end of the run
real :: dif !< The time as a real number
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
@@ -1389,6 +1403,11 @@ subroutine write_time_data(this)
diag_file => this%FMS_diag_file
fms2io_fileobj => diag_file%fms2io_fileobj
+ if (present(is_the_end)) then
+ ! If at the end of the run, do not do anything for the static files
+ if (is_the_end .and. diag_file%is_static) return
+ endif
+
if (diag_file%time_ops) then
middle_time = (diag_file%last_output+diag_file%next_output)/2
dif = get_date_dif(middle_time, get_base_time(), diag_file%get_file_timeunit())
@@ -1501,6 +1520,9 @@ pure function get_next_next_output(this) &
type(time_type) :: res
res = this%FMS_diag_file%next_next_output
+ if (this%FMS_diag_file%is_static) then
+ res = this%FMS_diag_file%no_more_data
+ endif
end function get_next_next_output
!< @brief Writes the axis metadata for the file
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 2d93e5e2c9..10b548d5d1 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -297,7 +297,7 @@ integer function fms_register_diag_field_obj &
call bufferptr%set_diurnal_sample_size(yamlfptr%get_n_diurnal())
endif
call bufferptr%init_buffer_time(init_time)
- call bufferptr%set_next_output(this%FMS_diag_files(file_ids(i))%get_next_output())
+ call bufferptr%set_next_output(this%FMS_diag_files(file_ids(i))%get_next_output(), fieldptr%is_static())
enddo
nullify (fileptr)
@@ -824,7 +824,7 @@ subroutine fms_diag_do_io(this, end_time)
call diag_file%increase_unlim_dimension_level()
if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file()
else if (force_write) then
- call diag_file%write_time_data()
+ call diag_file%write_time_data(is_the_end = .true.)
call diag_file%close_diag_file()
endif
enddo
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index ed37b7e923..5aa4171942 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -351,11 +351,17 @@ subroutine init_buffer_time(this, time)
end subroutine init_buffer_time
!> @brief Sets the next output
-subroutine set_next_output(this, time)
+subroutine set_next_output(this, time, is_static)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
type(time_type), intent(in) :: time !< time to add to the buffer
+ logical, optional, intent(in) :: is_static !< .True. if the field is static
this%next_output = time
+ if (present(is_static)) then
+ !< If the field is static set the next_output to be equal to time
+ !! this should only be used in the init, so next_output will be equal to the the init time
+ if (is_static) this%next_output = this%time
+ endif
end subroutine set_next_output
!> @brief Update the buffer time if it is a new time
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 6c77601f20..edd89bda02 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -32,7 +32,7 @@ check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
check_time_min check_time_max check_time_sum check_time_avg test_diag_diurnal check_time_diurnal \
- check_time_pow check_time_rms test_cell_measures
+ check_time_pow check_time_rms check_subregional test_cell_measures
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -54,6 +54,7 @@ check_time_diurnal_SOURCES = testing_utils.F90 check_time_diurnal.F90
check_time_pow_SOURCES = testing_utils.F90 check_time_pow.F90
check_time_rms_SOURCES = testing_utils.F90 check_time_rms.F90
test_cell_measures_SOURCES = test_cell_measures.F90
+check_subregional_SOURCES = check_subregional.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
@@ -61,14 +62,15 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
# Run the test.
TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh \
- test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh test_cell_measures.sh
+ test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh test_cell_measures.sh \
+ test_subregional.sh
testing_utils.mod: testing_utils.$(OBJEXT)
# Copy over other needed files to the srcdir
EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \
test_time_sum.sh test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh \
- test_cell_measures.sh
+ test_cell_measures.sh test_subregional.sh
if USING_YAML
skipflag=""
diff --git a/test_fms/diag_manager/check_subregional.F90 b/test_fms/diag_manager/check_subregional.F90
new file mode 100644
index 0000000000..3b93958cb9
--- /dev/null
+++ b/test_fms/diag_manager/check_subregional.F90
@@ -0,0 +1,139 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Checks the output file after running test_subregional
+program check_subregional
+ use fms_mod, only: fms_init, fms_end, string
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file, get_dimension_size
+ use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe
+ use platform_mod, only: r4_kind, r8_kind
+
+ implicit none
+
+ call fms_init()
+
+ call check_zsubaxis_file("test_subZaxis.nc")
+ ! The files are in the same subregion, one of them is defined using latlon and another one indices
+ call check_subregional_file("test_subregional.nc")
+ call check_subregional_file("test_subregional2.nc")
+
+ call fms_end()
+
+ contains
+
+ !> @brief Check dimension data
+ subroutine check_dims(err_msg, actual_data, expected_data)
+ character(len=*), intent(in) :: err_msg !< Error message to append
+ real, intent(in) :: actual_data(:) !< Dimension data from file
+ real, intent(in) :: expected_data(:) !< Expected data
+
+ integer :: i
+
+ do i = 1, size(actual_data)
+ if (actual_data(i) .ne. expected_data(i)) &
+ call mpp_error(FATAL, "The data is not expected for "//trim(err_msg))
+ enddo
+ end subroutine check_dims
+
+ !> @brief Check the data for the Z subaxis
+ subroutine check_zsubaxis_file(file_name)
+ character(len=*), intent(in) :: file_name !< Name of the file to check
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ integer :: dim_size !< dim_size as read in from the file
+ real, allocatable :: dims(:) !< dimension data as read in from the file
+ real, allocatable :: dims_exp(:) !< dimensions data expected
+
+ if (.not. open_file(fileobj, file_name, "read")) &
+ call mpp_error(FATAL, "unable to open "//trim(file_name))
+
+ call get_dimension_size(fileobj, "z_sub01", dim_size)
+ if (dim_size .ne. 3) call mpp_error(FATAL, "z_sub01 is not the correct size!")
+ allocate(dims(dim_size), dims_exp(dim_size))
+ call read_data(fileobj, "z_sub01", dims)
+ dims_exp = (/3., 4., 5. /)
+ call check_dims("z_sub01",dims, dims_exp)
+ deallocate(dims, dims_exp)
+
+ call get_dimension_size(fileobj, "z_sub02", dim_size)
+ if (dim_size .ne. 2) call mpp_error(FATAL, "z_sub02 is not the correct size!")
+ allocate(dims(dim_size), dims_exp(dim_size))
+ call read_data(fileobj, "z_sub02", dims)
+ dims_exp = (/2., 3./)
+ call check_dims("z_sub01",dims, dims_exp)
+ deallocate(dims, dims_exp)
+
+ call close_file(fileobj)
+
+ end subroutine check_zsubaxis_file
+
+ !> @brief Check the data for the subregional file
+ subroutine check_subregional_file(file_name)
+ character(len=*), intent(in) :: file_name !< Name of the file to check
+
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ integer :: dim_size !< dim_size as read in from the file
+ real, allocatable :: dims(:) !< dimension data as read in from the file
+ real, allocatable :: dims_exp(:) !< dimensions data expected
+
+ if (.not. open_file(fileobj, trim(file_name)//".0003", "read")) &
+ call mpp_error(FATAL, "unable to open "//trim(file_name))
+
+ call get_dimension_size(fileobj, "x_sub01", dim_size)
+ if (dim_size .ne. 6) call mpp_error(FATAL, "x_sub01 is not the correct size!")
+ allocate(dims(dim_size), dims_exp(dim_size))
+ call read_data(fileobj, "x_sub01", dims)
+ dims_exp = (/60., 61., 62., 63., 64., 65. /)
+ call check_dims("x_sub01",dims, dims_exp)
+ deallocate(dims, dims_exp)
+
+ call get_dimension_size(fileobj, "y_sub01", dim_size)
+ if (dim_size .ne. 5) call mpp_error(FATAL, "y_sub01 is not the correct size!")
+ allocate(dims(dim_size), dims_exp(dim_size))
+ call read_data(fileobj, "y_sub01", dims)
+ dims_exp = (/60., 61., 62., 63., 64./)
+ call check_dims("y_sub01",dims, dims_exp)
+ deallocate(dims, dims_exp)
+
+ call close_file(fileobj)
+
+ if (.not. open_file(fileobj, trim(file_name)//".0004", "read")) &
+ call mpp_error(FATAL, "unable to open "//trim(file_name))
+
+ call get_dimension_size(fileobj, "x_sub01", dim_size)
+ if (dim_size .ne. 6) call mpp_error(FATAL, "x_sub01 is not the correct size!")
+ allocate(dims(dim_size), dims_exp(dim_size))
+ call read_data(fileobj, "x_sub01", dims)
+ dims_exp = (/60., 61., 62., 63., 64., 65. /)
+ call check_dims("x_sub01",dims, dims_exp)
+ deallocate(dims, dims_exp)
+
+ call get_dimension_size(fileobj, "y_sub01", dim_size)
+ if (dim_size .ne. 1) call mpp_error(FATAL, "y_sub01 is not the correct size!")
+ allocate(dims(dim_size), dims_exp(dim_size))
+ call read_data(fileobj, "y_sub01", dims)
+ dims_exp = (/65./)
+ call check_dims("y_sub01",dims, dims_exp)
+ deallocate(dims, dims_exp)
+
+ call close_file(fileobj)
+
+ end subroutine check_subregional_file
+
+end program
diff --git a/test_fms/diag_manager/test_subregional.sh b/test_fms/diag_manager/test_subregional.sh
new file mode 100755
index 0000000000..41d43cc6c2
--- /dev/null
+++ b/test_fms/diag_manager/test_subregional.sh
@@ -0,0 +1,111 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+cat <<_EOF > diag_table.yaml
+title: test_subregional
+base_date: 2 1 1 0 0 0
+
+diag_files:
+# This is to test a file with multiple z axis
+- file_name: test_subZaxis
+ freq: 6 hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_Z1
+ reduction: none
+ kind: r4
+ zbounds: 2. 3.
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_Z2
+ reduction: none
+ kind: r4
+ zbounds: 3. 5.
+- file_name: test_subregional
+ freq: 6 hours
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: latlon
+ corner1: 60. 60.
+ corner2: 60. 65.
+ corner3: 65. 65.
+ corner4: 65. 60.
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_min
+ reduction: min
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_max
+ reduction: max
+ kind: r4
+- file_name: test_subregional2
+ freq: 6 hours
+ time_units: hours
+ unlimdim: time
+ sub_region:
+ - grid_type: index
+ corner1: 60 60
+ corner2: 60 65
+ corner3: 65 65
+ corner4: 65 60
+ tile: 1
+ varlist:
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_min
+ reduction: min
+ kind: r4
+ - module: ocn_mod
+ var_name: var3
+ output_name: var3_max
+ reduction: max
+ kind: r4
+_EOF
+
+# remove any existing files that would result in false passes during checks
+rm -f *.nc
+
+my_test_count=1
+printf "&diag_manager_nml \n use_modern_diag=.true. \n/" | cat > input.nml
+test_expect_success "Running diag_manager with different subregions (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+
+my_test_count=`expr $my_test_count + 1`
+test_expect_success "Checking results from diag_manager with different subregions (test $my_test_count)" '
+ mpirun -n 1 ../check_subregional
+'
+fi
+test_done
From 2202c1468b9abd1b4cf27492a86661dcd0f19e75 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Thu, 22 Feb 2024 15:22:12 -0500
Subject: [PATCH 149/168] fix: move type declaration and change type for nvhpc
(#1463)
---
diag_manager/fms_diag_axis_object.F90 | 14 +++++++-------
diag_manager/fms_diag_object.F90 | 2 +-
2 files changed, 8 insertions(+), 8 deletions(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index fe400b04cf..5a2e885666 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -83,15 +83,9 @@ module fms_diag_axis_object_mod
type(domainUG) :: DomainUG !< Domain of "U" axis
end type
- !> @brief Type to hold the diag_axis (either subaxis or a full axis)
- !> @ingroup diag_axis_object_mod
- type :: fmsDiagAxisContainer_type
- class(fmsDiagAxis_type), allocatable :: axis
- end type
-
!> @brief Type to hold the diagnostic axis description.
!> @ingroup diag_axis_object_mod
- TYPE fmsDiagAxis_type
+ TYPE :: fmsDiagAxis_type
INTEGER , private :: axis_id !< ID of the axis
contains
@@ -107,6 +101,12 @@ module fms_diag_axis_object_mod
procedure :: get_edges_id
END TYPE fmsDiagAxis_type
+ !> @brief Type to hold the diag_axis (either subaxis or a full axis)
+ !> @ingroup diag_axis_object_mod
+ type :: fmsDiagAxisContainer_type
+ class(fmsDiagAxis_type), allocatable :: axis
+ end type
+
!> @brief Type to hold the subaxis
!> @ingroup diag_axis_object_mod
TYPE, extends(fmsDiagAxis_type) :: fmsDiagSubAxis_type
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 10b548d5d1..34e5573f29 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -1176,7 +1176,7 @@ function get_diag_buffer(this, bufferid) &
result(rslt)
class(fmsDiagObject_type), intent(in) :: this
integer, intent(in) :: bufferid
- class(fmsDiagOutputBuffer_type),allocatable:: rslt
+ type(fmsDiagOutputBuffer_type),allocatable:: rslt
if( (bufferid .gt. UBOUND(this%FMS_diag_output_buffers, 1)) .or. &
(bufferid .lt. LBOUND(this%FMS_diag_output_buffers, 1))) &
call mpp_error(FATAL, 'get_diag_bufer: invalid bufferid given')
From 872191391bd052db10713cf5d9d620ac75f896cc Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 29 Feb 2024 07:34:45 -0500
Subject: [PATCH 150/168] fix: modern diag updates for the mask_variant=.true.
case (#1464)
---
diag_manager/diag_manager.F90 | 17 +--
diag_manager/fms_diag_field_object.F90 | 24 +++-
diag_manager/fms_diag_object.F90 | 57 +++++-----
diag_manager/fms_diag_output_buffer.F90 | 43 ++++---
.../include/fms_diag_reduction_methods.inc | 107 +++++++++++++-----
test_fms/diag_manager/Makefile.am | 9 +-
test_fms/diag_manager/check_var_masks.F90 | 78 +++++++++++++
test_fms/diag_manager/test_diag_buffer.F90 | 8 +-
test_fms/diag_manager/test_time_avg.sh | 11 ++
test_fms/diag_manager/test_var_masks.F90 | 87 ++++++++++++++
test_fms/diag_manager/test_var_masks.sh | 56 +++++++++
11 files changed, 402 insertions(+), 95 deletions(-)
create mode 100644 test_fms/diag_manager/check_var_masks.F90
create mode 100644 test_fms/diag_manager/test_var_masks.F90
create mode 100755 test_fms/diag_manager/test_var_masks.sh
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index f2c141573b..c440d5ec26 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -425,9 +425,9 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
- REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
- REAL, OPTIONAL, INTENT(in) :: range(2) !< Range to add a variable attribute
- LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< .True. if the mask changes over time
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
@@ -475,10 +475,9 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Longname to be added as a attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to be added as a attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute
- real, OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
- real, DIMENSION(2), OPTIONAL, INTENT(in) :: range !< Range to be added as a attribute
- LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has
- !! a mask variant
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
+ CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range !< Range to be added as a attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< .True. if the mask changes over time
LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged
CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
@@ -1721,12 +1720,8 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
REAL :: rmask_threshold !< Holds the values 0.5_r4_kind or 0.5_r8_kind, or related threhold values
!! needed to be passed to the math/buffer update functions.
-<<<<<<< HEAD
- class(*), pointer, dimension(:,:,:,:) :: field_modern => null() !< i8 4d remapped pointer
-=======
character(len=:), allocatable :: field_name !< Name of the field
->>>>>>> 07ff0679 (Implement time_none (#1347))
! If diag_field_id is < 0 it means that this field is not registered, simply return
IF ( diag_field_id <= 0 ) THEN
diag_send_data = .FALSE.
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index cf3917785a..4a22b9002a 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -47,7 +47,8 @@ module fms_diag_field_object_mod
logical, allocatable, private :: static !< true if this is a static var
logical, allocatable, private :: scalar !< .True. if the variable is a scalar
logical, allocatable, private :: registered !< true when registered
- logical, allocatable, private :: mask_variant !< If there is a mask variant
+ logical, allocatable, private :: mask_variant !< true if the mask changes over time
+ logical, allocatable, private :: var_is_masked !< true if the field is masked
logical, allocatable, private :: do_not_log !< .true. if no need to log the diag_field
logical, allocatable, private :: local !< If the output is local
integer, allocatable, private :: vartype !< the type of varaible
@@ -98,7 +99,8 @@ module fms_diag_field_object_mod
procedure :: set_math_needs_to_be_done => set_math_needs_to_be_done
procedure :: add_attribute => diag_field_add_attribute
procedure :: vartype_inq => what_is_vartype
- procedure :: set_mask_variant
+ procedure :: set_var_is_masked
+ procedure :: get_var_is_masked
! Check functions
procedure :: is_static => diag_obj_is_static
procedure :: is_scalar
@@ -349,8 +351,8 @@ subroutine fms_register_diag_field_obj &
this%volume = volume
endif
+ this%mask_variant = .false.
if (present(mask_variant)) then
- allocate(this%mask_variant)
this%mask_variant = mask_variant
endif
@@ -449,12 +451,22 @@ subroutine set_math_needs_to_be_done (this, math_needs_to_be_done)
end subroutine set_math_needs_to_be_done
!> @brief Set the mask_variant to .true.
-subroutine set_mask_variant(this, is_masked)
+subroutine set_var_is_masked(this, is_masked)
class (fmsDiagField_type) , intent(inout):: this !< The diag field object
logical, intent (in) :: is_masked !< .True. if the field is masked
- this%mask_variant = is_masked
-end subroutine set_mask_variant
+ this%var_is_masked = is_masked
+end subroutine set_var_is_masked
+
+!> @brief Queries a field for the var_is_masked variable
+!! @return var_is_masked
+function get_var_is_masked(this) &
+ result(rslt)
+ class (fmsDiagField_type) , intent(inout):: this !< The diag field object
+ logical :: rslt !< .True. if the field is masked
+
+ rslt = this%var_is_masked
+end function get_var_is_masked
!> @brief Sets the flag saying that the data buffer is allocated
subroutine set_data_buffer_is_allocated (this, data_buffer_is_allocated)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 34e5573f29..499543cc7f 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -186,7 +186,7 @@ integer function fms_register_diag_field_obj &
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standname !< The variables stanard name
class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a attribute
class(*), OPTIONAL, INTENT(in) :: varRANGE(2) !< Range to add as a attribute
- LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< .True. if mask changes over time
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged
CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Error message to be passed back up
CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
@@ -353,7 +353,7 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute
- LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< .True. if mask changes over time
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
@@ -394,8 +394,7 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes,
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name to be added as a attribute
CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to be added as a attribute
CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to be added as a attribute
- LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has
- !! a mask variant
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< .True. if mask changes over time
LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged
CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
@@ -618,8 +617,11 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
if(.not. this%FMS_diag_fields(diag_field_id)%has_vartype()) &
call this%FMS_diag_fields(diag_field_id)%set_type(field_data(1,1,1,1))
- if (allocated(mask) .or. allocated(rmask)) &
- call this%FMS_diag_fields(diag_field_id)%set_mask_variant(.True.)
+ if (allocated(mask) .or. allocated(rmask)) then
+ call this%FMS_diag_fields(diag_field_id)%set_var_is_masked(.True.)
+ else
+ call this%FMS_diag_fields(diag_field_id)%set_var_is_masked(.False.)
+ endif
if (.not. this%FMS_diag_fields(diag_field_id)%is_data_buffer_allocated()) then
data_buffer_is_allocated = &
@@ -646,8 +648,11 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
if(.not. this%FMS_diag_fields(diag_field_id)%has_vartype()) &
call this%FMS_diag_fields(diag_field_id)%set_type(field_data(1,1,1,1))
- if (allocated(mask) .or. allocated(rmask)) &
- call this%FMS_diag_fields(diag_field_id)%set_mask_variant(.True.)
+ if (allocated(mask) .or. allocated(rmask)) then
+ call this%FMS_diag_fields(diag_field_id)%set_var_is_masked(.True.)
+ else
+ call this%FMS_diag_fields(diag_field_id)%set_var_is_masked(.False.)
+ endif
error_string = bounds%set_bounds(field_data, is, ie, js, je, ks, ke, has_halos)
if (trim(error_string) .ne. "") call mpp_error(FATAL, trim(error_string)//". "//trim(field_info))
@@ -802,11 +807,9 @@ subroutine fms_diag_do_io(this, end_time)
if( field_yaml%has_var_reduction()) then
if( field_yaml%get_var_reduction() .ge. time_average) then
if(DEBUG_REDUCT)call mpp_error(NOTE, "fms_diag_do_io:: finishing reduction for "//diag_field%get_longname())
- has_mask = diag_field%has_mask_variant()
- if(has_mask) has_mask = diag_field%get_mask_variant()
error_string = diag_buff%diag_reduction_done_wrapper( &
field_yaml%get_var_reduction(), &
- mval, has_mask)
+ mval, diag_field%get_var_is_masked(), diag_field%get_mask_variant())
endif
endif
call diag_file%write_field_data(diag_field, diag_buff)
@@ -915,8 +918,6 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
!< Go away if finished doing math for this buffer
if (buffer_ptr%is_done_with_math()) cycle
- call buffer_ptr%set_send_data_called()
-
bounds_out = bounds
if (.not. using_blocking) then
!< Set output bounds to start at 1:size(buffer_ptr%buffer)
@@ -973,46 +974,48 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
!< Determine the reduction method for the buffer
reduction_method = field_yaml_ptr%get_var_reduction()
if (present(time)) new_time = buffer_ptr%update_buffer_time(time)
+ call buffer_ptr%set_send_data_called()
select case(reduction_method)
case (time_none)
- error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ error_msg = buffer_ptr%do_time_none_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
bounds_in, bounds_out, missing_value)
if (trim(error_msg) .ne. "") then
return
endif
case (time_min)
- error_msg = buffer_ptr%do_time_min_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ error_msg = buffer_ptr%do_time_min_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
bounds_in, bounds_out, missing_value)
if (trim(error_msg) .ne. "") then
return
endif
case (time_max)
- error_msg = buffer_ptr%do_time_max_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
+ error_msg = buffer_ptr%do_time_max_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
bounds_in, bounds_out, missing_value)
if (trim(error_msg) .ne. "") then
return
endif
case (time_sum)
- error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
- bounds_in, bounds_out, missing_value, .true.)
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time)
if (trim(error_msg) .ne. "") then
return
endif
case (time_average)
- error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
- bounds_in, bounds_out, missing_value, new_time)
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time)
if (trim(error_msg) .ne. "") then
return
endif
case (time_power)
- error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
- bounds_in, bounds_out, missing_value, new_time, pow_value=field_yaml_ptr%get_pow_value())
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time, &
+ pow_value=field_yaml_ptr%get_pow_value())
if (trim(error_msg) .ne. "") then
return
endif
case (time_rms)
- error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
- bounds_in, bounds_out, missing_value, new_time, pow_value = 2)
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time, pow_value = 2)
if (trim(error_msg) .ne. "") then
return
endif
@@ -1021,8 +1024,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
"fms_diag_do_reduction:: time must be present when using diurnal reductions")
! sets the diurnal index for reduction within the buffer object
call buffer_ptr%set_diurnal_section_index(time)
- error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_mask_variant(), &
- bounds_in, bounds_out, missing_value, .true.)
+ error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time)
if (trim(error_msg) .ne. "") then
return
endif
@@ -1376,7 +1379,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id)
ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id)
call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), ndims, axes_length(1:4), &
- var_name, num_diurnal_samples)
+ this%FMS_diag_fields(field_id)%get_mask_variant(), var_name, num_diurnal_samples)
call ptr_diag_buffer_obj%initialize_buffer(ptr_diag_field_yaml%get_var_reduction(), var_name)
enddo
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 5aa4171942..1328104f74 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -49,7 +49,9 @@ module fms_diag_output_buffer_mod
class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array
integer :: ndim !< Number of dimensions for each variable
integer, allocatable :: buffer_dims(:) !< holds the size of each dimension in the buffer
- real(r8_kind) :: weight_sum !< (x,y,z, time-of-day) used in the time averaging functions
+ real(r8_kind), allocatable :: weight_sum(:,:,:,:) !< Weight sum as an array
+ !! (this will be have a size of 1,1,1,1 when not using variable
+ !! masks!)
integer, allocatable :: num_elements(:) !< used in time-averaging
integer, allocatable :: axis_ids(:) !< Axis ids for the buffer
integer :: field_id !< The id of the field the buffer belongs to
@@ -144,14 +146,16 @@ subroutine flush_buffer(this)
if (allocated(this%buffer_dims)) deallocate(this%buffer_dims)
if (allocated(this%num_elements)) deallocate(this%num_elements)
if (allocated(this%axis_ids)) deallocate(this%axis_ids)
+ if (allocated(this%weight_sum)) deallocate(this%weight_sum)
end subroutine flush_buffer
!> Allocates a 5D buffer to given buff_type.
-subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurnal_samples)
+subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, mask_variant, field_name, diurnal_samples)
class(fmsDiagOutputBuffer_type), intent(inout), target :: this !< 5D buffer object
class(*), intent(in) :: buff_type !< allocates to the type of buff_type
integer, intent(in) :: ndim !< Number of dimension
integer, intent(in) :: buff_sizes(4) !< dimension buff_sizes
+ logical, intent(in) :: mask_variant !< Mask changes over time
character(len=*), intent(in) :: field_name !< field name for error output
integer, intent(in) :: diurnal_samples !< number of diurnal samples
@@ -167,28 +171,31 @@ subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurna
type is (integer(kind=i4_kind))
allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& n_samples))
- this%weight_sum = 0.0_r4_kind
this%buffer_type = i4
type is (integer(kind=i8_kind))
allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& n_samples))
- this%weight_sum = 0.0_r8_kind
this%buffer_type = i8
type is (real(kind=r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& n_samples))
- this%weight_sum = 0.0_r4_kind
this%buffer_type = r4
type is (real(kind=r8_kind))
allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), &
& n_samples))
- this%weight_sum = 0.0_r8_kind
this%buffer_type = r8
class default
call mpp_error("allocate_buffer", &
"The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // &
"for field:" // field_name, FATAL)
end select
+ if (mask_variant) then
+ allocate(this%weight_sum(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4)))
+ else
+ allocate(this%weight_sum(1,1,1,1))
+ endif
+ this%weight_sum = 0.0_r8_kind
+
allocate(this%num_elements(n_samples))
this%num_elements = 0
this%done_with_math = .false.
@@ -369,7 +376,7 @@ end subroutine set_next_output
function update_buffer_time(this, time) &
result(res)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
- type(time_type), intent(in) :: time !< time to add to the buffer
+ type(time_type), intent(in) :: time !< Current model time
logical :: res
@@ -378,6 +385,8 @@ function update_buffer_time(this, time) &
res = .true.
else
res = .false.
+ !< If this is the first time send_data has been called
+ if (.not. this%send_data_called) res = .true.
endif
end function
@@ -649,7 +658,7 @@ end function do_time_max_wrapper
!> @brief Does the time_sum reduction method on the buffer object
!! @return Error message if the math was not successful
-function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bounds_out, missing_value, &
+function do_time_sum_wrapper(this, field_data, mask, is_masked, mask_variant, bounds_in, bounds_out, missing_value, &
increase_counter, pow_value) &
result(err_msg)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
@@ -658,6 +667,7 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
type(fmsDiagIbounds_type), intent(in) :: bounds_out !< Indicies for the output buffer
logical, intent(in) :: mask(:,:,:,:) !< Mask for the field
logical, intent(in) :: is_masked !< .True. if the field has a mask
+ logical, intent(in) :: mask_variant !< .True. if the mask changes over time
real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
logical, intent(in) :: increase_counter !< .True. if data has not been received for
!! time, so the counter needs to be increased
@@ -672,7 +682,7 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
type is (real(kind=r8_kind))
select type (field_data)
type is (real(kind=r8_kind))
- call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, &
+ call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, mask_variant, &
bounds_in, bounds_out, missing_value, increase_counter, this%diurnal_section, &
pow=pow_value)
class default
@@ -681,8 +691,9 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, bounds_in, bound
type is (real(kind=r4_kind))
select type (field_data)
type is (real(kind=r4_kind))
- call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, bounds_in, bounds_out, &
- real(missing_value, kind=r4_kind), increase_counter, this%diurnal_section, pow=pow_value)
+ call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, mask_variant, &
+ bounds_in, bounds_out, real(missing_value, kind=r4_kind), increase_counter, &
+ this%diurnal_section, pow=pow_value)
class default
err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)"
end select
@@ -694,25 +705,25 @@ end function do_time_sum_wrapper
!> Finishes calculations for any reductions that use an average (avg, rms, pow)
!! TODO add mask and any other needed args for adjustment, and pass in the adjusted mask
!! to time_update_done
-function diag_reduction_done_wrapper(this, reduction_method, missing_value, has_mask) & !! , has_halo, mask) &
+function diag_reduction_done_wrapper(this, reduction_method, missing_value, has_mask, mask_variant) &
result(err_msg)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Updated buffer object
integer, intent(in) :: reduction_method !< enumerated reduction type from diag_data
real(kind=r8_kind), intent(in) :: missing_value !< missing_value for masked data points
logical, intent(in) :: has_mask !< indicates if there was a mask used during buffer updates
+ logical, intent(in) :: mask_variant !< Indicates if the mask changes over time
character(len=51) :: err_msg !< error message to return, blank if sucessful
if(.not. allocated(this%buffer)) return
- if(this%weight_sum .eq. 0.0_r8_kind) return
-
err_msg = ""
select type(buff => this%buffer)
type is (real(r8_kind))
- call time_update_done(buff, this%weight_sum, reduction_method, missing_value, has_mask, this%diurnal_sample_size)
+ call time_update_done(buff, this%weight_sum, reduction_method, missing_value, has_mask, mask_variant, &
+ this%diurnal_sample_size)
type is (real(r4_kind))
call time_update_done(buff, this%weight_sum, reduction_method, real(missing_value, r4_kind), has_mask, &
- this%diurnal_sample_size)
+ mask_variant, this%diurnal_sample_size)
end select
this%weight_sum = 0.0_r8_kind
diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc
index dff061fc58..870d196da7 100644
--- a/diag_manager/include/fms_diag_reduction_methods.inc
+++ b/diag_manager/include/fms_diag_reduction_methods.inc
@@ -214,13 +214,14 @@ end subroutine DO_TIME_MAX_
!! buffer(l) = buffer(l) + (weight * field(l)) ^ pow
!!
!! Where l are the indices passed in through the bounds_in/out
-subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, bounds_in, bounds_out, &
+subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, mask_variant, bounds_in, bounds_out, &
missing_value, increase_counter, diurnal_section, weight, pow)
real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
- real(r8_kind), intent(inout) :: weight_sum !< Sum of weights from the output buffer object
+ real(r8_kind), intent(inout) :: weight_sum(:,:,:,:) !< Sum of weights from the output buffer object
real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
logical, intent(in) :: mask(:,:,:,:) !< mask
logical, intent(in) :: is_masked !< .True. if the field is using a mask
+ logical, intent(in) :: mask_variant !< .True. if the mask changes over time
type(fmsDiagIbounds_type), intent(in) :: bounds_in !< indices indicating the correct portion
!! of the input buffer
type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion
@@ -241,18 +242,25 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for
!! the output buffer
integer :: i, j, k, l !< For looping
- real(FMS_TRM_KIND_) :: weight_loc !< local copy of optional weight
+ real(FMS_TRM_KIND_) :: counter_local !< counter to increase the counter by
+ real(FMS_TRM_KIND_) :: weight_scale !< local copy of optional weight
integer :: pow_loc !> local copy of optional pow value (set if using pow reduction)
integer, parameter :: kindl = FMS_TRM_KIND_ !< real kind size as set by macro
integer :: diurnal !< diurnal index to indicate which daily section is updated
!! will be 1 unless using a diurnal reduction
+ ! The counter and the weight are stored in different variables to avoid having
+ ! to do a if (increase_counter) inside a do loop
if(present(weight)) then
- weight_loc = weight
+ counter_local = weight
+ weight_scale = weight
else
- weight_loc = 1.0_kindl
+ counter_local = 1.0_kindl
+ weight_scale = 1.0_kindl
endif
+ if (.not. increase_counter) counter_local = 0.0_kindl
+
if(present(pow)) then
pow_loc = pow
else
@@ -265,9 +273,6 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
diurnal = diurnal_section
endif
- ! update with given weight for average before write
- if (increase_counter) weight_sum = weight_sum + weight_loc
-
is_out = bounds_out%get_imin()
ie_out = bounds_out%get_imax()
js_out = bounds_out%get_jmin()
@@ -286,27 +291,47 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, b
!! then mask will always be .True. so the if (mask) is redudant.
! TODO check if performance gain by not doing weight and pow if not needed
if (is_masked) then
- do k = 0, ke_out - ks_out
- do j = 0, je_out - js_out
- do i = 0, ie_out - is_out
- where (mask(is_in + i, js_in + j, ks_in + k, :))
- data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
+ if (mask_variant) then
+ ! Mask changes over time so the weight is an array
+ do k = 0, ke_out - ks_out
+ do j = 0, je_out - js_out
+ do i = 0, ie_out - is_out
+ where (mask(is_in + i, js_in + j, ks_in + k, :))
+ data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
- + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_loc) ** pow_loc
- elsewhere
- data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = missing_value
- endwhere
+ + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale) ** pow_loc
+ !Increase the weight sum for the grid point that was not masked
+ weight_sum(is_out + i, js_out + j, ks_out + k, :) = &
+ weight_sum(is_out + i, js_out + j, ks_out + k, :) + counter_local
+ endwhere
+ enddo
enddo
enddo
- enddo
+ else
+ weight_sum = weight_sum + counter_local
+ do k = 0, ke_out - ks_out
+ do j = 0, je_out - js_out
+ do i = 0, ie_out - is_out
+ where (mask(is_in + i, js_in + j, ks_in + k, :))
+ data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
+ data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
+ + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale) ** pow_loc
+ elsewhere
+ data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = missing_value
+ endwhere
+ enddo
+ enddo
+ enddo
+ endif
else
+ weight_sum = weight_sum + counter_local
! doesn't need to loop through l if no mask, just sums the 1d slices
do k = 0, ke_out - ks_out
do j = 0, je_out - js_out
do i = 0, ie_out - is_out
data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) = &
data_out(is_out + i, js_out + j, ks_out + k, :, diurnal) &
- + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_loc) ** pow_loc
+ + (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale) ** pow_loc
enddo
enddo
enddo
@@ -316,20 +341,26 @@ end subroutine DO_TIME_SUM_UPDATE_
!> To be called with diag_send_complete, finishes reductions
!! Just divides the buffer by the counter array(which is just the sum of the weights used in the buffer's reduction)
!! TODO: change has_mask to an actual logical mask so we don't have to check for missing values
-subroutine SUM_UPDATE_DONE_(out_buffer_data, weight_sum, reduction_method, missing_val, has_mask, n_diurnal_samples)
+subroutine SUM_UPDATE_DONE_(out_buffer_data, weight_sum, reduction_method, missing_val, has_mask, mask_variant, &
+ n_diurnal_samples)
real(FMS_TRM_KIND_), intent(inout) :: out_buffer_data(:,:,:,:,:) !< data buffer previously updated with
!! do_time_sum_update
- real(r8_kind), intent(in) :: weight_sum !< sum of weights for averaging, provided via argument to send data
+ real(r8_kind), intent(in) :: weight_sum(:,:,:,:) !< sum of weights for averaging,
+ !! provided via argument to send data
integer, intent(in) :: reduction_method !< which reduction method to use
!! should always be one of time_avg, time_diurnal, or time_rms
real(FMS_TRM_KIND_), intent(in) :: missing_val !< missing value for masked elements
logical, intent(in) :: has_mask !< indicates if mask is used so missing values can be skipped
+ logical, intent(in) :: mask_variant !< Indicates if the mask changes over time
integer, optional, intent(in) :: n_diurnal_samples !< number of diurnal samples as set in reduction method
- integer :: wsum !< local cp of weight_sum, only changed if using diurnal
+ integer, allocatable :: wsum(:,:,:,:) !< local cp of weight_sum, only changed if using diurnal
!! TODO replace conditional in the `where` with passed in and ajusted mask from the original call
!logical, optional, intent(in) :: mask(:,:,:,:) !< logical mask from accept data call, if using one.
!logical :: has_mask !< whether or not mask is present
+ integer :: i, j, k, l !< For do loops
+
+ allocate(wsum(size(weight_sum,1), size(weight_sum,3), size(weight_sum,3), size(weight_sum,4)))
! need to divide weight sum by amount of samples to get the actual
! number of times that the diurnal section was incremented
! legacy diag manager stored these weights explicitly, this doesn't so assumes uniformity in when data is sent
@@ -342,13 +373,33 @@ subroutine SUM_UPDATE_DONE_(out_buffer_data, weight_sum, reduction_method, missi
endif
if ( has_mask ) then
- where(out_buffer_data(:,:,:,:,:) .ne. missing_val)
- out_buffer_data(:,:,:,:,:) = out_buffer_data(:,:,:,:,:) &
- / wsum
- endwhere
- else !not mask variant
+ if (.not. mask_variant) then
+ ! The mask does not change over time so wsum is just an integer and it is the same value for all fields
+ where(out_buffer_data(:,:,:,:,:) .ne. missing_val)
+ out_buffer_data(:,:,:,:,:) = out_buffer_data(:,:,:,:,:) &
+ / wsum(1,1,1,1)
+ endwhere
+ else
+ ! The mask changes over time
+ do l = 1, size(out_buffer_data, 4)
+ do k = 1, size(out_buffer_data, 3)
+ do j = 1, size(out_buffer_data, 2)
+ do i = 1, size(out_buffer_data, 1)
+ if (wsum(i, j, k, l) .gt. 0) then
+ out_buffer_data(i,j,k,l,:) = out_buffer_data(i,j,k,l,:)/ wsum(i,j,k,l)
+ else
+ ! Data was never received
+ out_buffer_data(i,j,k,l,:) = missing_val
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ else
+ ! There is no mask!
out_buffer_data(:,:,:,:,:) = out_buffer_data(:,:,:,:,:) &
- / wsum
+ / wsum(1,1,1,1)
endif
if(reduction_method .eq. time_rms .and. has_mask) then
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index edd89bda02..fec4b82e1b 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -32,7 +32,8 @@ check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_diag_yaml test_diag_ocean test_modern_diag test_diag_buffer \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
check_time_min check_time_max check_time_sum check_time_avg test_diag_diurnal check_time_diurnal \
- check_time_pow check_time_rms check_subregional test_cell_measures
+ check_time_pow check_time_rms check_subregional test_cell_measures test_var_masks \
+ check_var_masks
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -55,6 +56,8 @@ check_time_pow_SOURCES = testing_utils.F90 check_time_pow.F90
check_time_rms_SOURCES = testing_utils.F90 check_time_rms.F90
test_cell_measures_SOURCES = test_cell_measures.F90
check_subregional_SOURCES = check_subregional.F90
+test_var_masks_SOURCES = test_var_masks.F90
+check_var_masks_SOURCES = check_var_masks.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
@@ -63,14 +66,14 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
# Run the test.
TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh \
test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh test_cell_measures.sh \
- test_subregional.sh
+ test_subregional.sh test_var_masks.sh
testing_utils.mod: testing_utils.$(OBJEXT)
# Copy over other needed files to the srcdir
EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \
test_time_sum.sh test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh \
- test_cell_measures.sh test_subregional.sh
+ test_cell_measures.sh test_subregional.sh test_var_masks.sh
if USING_YAML
skipflag=""
diff --git a/test_fms/diag_manager/check_var_masks.F90 b/test_fms/diag_manager/check_var_masks.F90
new file mode 100644
index 0000000000..d1d3b1772c
--- /dev/null
+++ b/test_fms/diag_manager/check_var_masks.F90
@@ -0,0 +1,78 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Checks the output for when running with a field that has a mask that changes
+!! over time
+program check_var_masks
+ use fms_mod, only: fms_init, fms_end
+ use mpp_mod
+ use fms2_io_mod
+
+ implicit none
+
+ type(FmsNetcdfFile_t) :: fileobj
+ integer :: ntimes
+ integer :: nx
+ integer :: ny
+ real, allocatable :: vardata(:,:)
+ real :: ans_var_mask
+ real :: ans_var
+ integer :: i, j
+
+ call fms_init()
+
+ if (.not. open_file(fileobj, "test_var_masks.nc", "read")) &
+ call mpp_error(FATAL, "unable to open test_var_masks.nc for reading")
+
+ call get_dimension_size(fileobj, "time", ntimes)
+ if (ntimes .ne. 1) call mpp_error(FATAL, "time is not the correct size!")
+
+ call get_dimension_size(fileobj, "x", nx)
+ if (nx .ne. 360) call mpp_error(FATAL, "x is not the correct size!")
+
+ call get_dimension_size(fileobj, "y", ny)
+ if (ny .ne. 180) call mpp_error(FATAL, "y is not the correct size!")
+
+ allocate(vardata(nx,ny))
+
+ ans_var_mask = 0.
+ ans_var = 0.
+ call read_data(fileobj, "ua", vardata)
+ do i = 1, 24
+ ans_var = ans_var + real(i)
+ if (mod(i,2) .ne. 0) ans_var_mask = ans_var_mask + real(i)
+ enddo
+ ans_var = ans_var / 24
+ ans_var_mask = ans_var_mask / 12
+
+ do i = 1, nx
+ do j = 1, ny
+ if (i .eq. 1 .and. j .eq. 1) then
+ if (vardata(i,j) .ne. ans_var_mask) &
+ call mpp_error(FATAL, "ua is not the expected result for the masked point")
+ else
+ if (vardata(i,j) .ne. ans_var) &
+ call mpp_error(FATAL, "ua is not the expected result")
+ endif
+ enddo
+ enddo
+
+ call close_file(fileobj)
+ call fms_end()
+end program check_var_masks
diff --git a/test_fms/diag_manager/test_diag_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90
index f20a3fa073..33bcbffcd1 100644
--- a/test_fms/diag_manager/test_diag_buffer.F90
+++ b/test_fms/diag_manager/test_diag_buffer.F90
@@ -45,7 +45,7 @@ program test_diag_buffer
buff_sizes = 1
do i=0, 4
buff_sizes(i+1) = i+5
- call buffobj(i+1)%allocate_buffer(r8_data, i, buff_sizes, fname, 1)
+ call buffobj(i+1)%allocate_buffer(r8_data, i, buff_sizes, .false., fname, 1)
call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
@@ -68,7 +68,7 @@ program test_diag_buffer
buff_sizes = 1
do i=0, 4
buff_sizes(i+1) = i+5
- call buffobj(i+1)%allocate_buffer(r4_data, i, buff_sizes, fname, 1)
+ call buffobj(i+1)%allocate_buffer(r4_data, i, buff_sizes, .false., fname, 1)
call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
@@ -90,7 +90,7 @@ program test_diag_buffer
buff_sizes = 1
do i=0, 4
buff_sizes(i+1) = i+5
- call buffobj(i+1)%allocate_buffer(i8_data, i, buff_sizes, fname, 1)
+ call buffobj(i+1)%allocate_buffer(i8_data, i, buff_sizes, .false., fname, 1)
call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
@@ -112,7 +112,7 @@ program test_diag_buffer
buff_sizes = 1
do i=0, 4
buff_sizes(i+1) = i+5
- call buffobj(i+1)%allocate_buffer(i4_data, i, buff_sizes, fname, 1)
+ call buffobj(i+1)%allocate_buffer(i4_data, i, buff_sizes, .false., fname, 1)
call buffobj(i+1)%initialize_buffer(time_none, fname)
call buffobj(i+1)%get_buffer(p_val, fname)
select type(p_val)
diff --git a/test_fms/diag_manager/test_time_avg.sh b/test_fms/diag_manager/test_time_avg.sh
index bc9c6601b9..3e80fcdc27 100755
--- a/test_fms/diag_manager/test_time_avg.sh
+++ b/test_fms/diag_manager/test_time_avg.sh
@@ -154,6 +154,17 @@ test_expect_success "Checking answers for the "avg" reduction method with openmp
export OMP_NUM_THREADS=1
+# This is the corner case where the number of openmp threads is 1 but the number of
+# atmosphere blocks is not set 1!
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 1 \n \n/" | cat > input.nml
+test_expect_success "Running diag_manager with "none" reduction method with blocking but no threads (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+test_expect_success "Checking answers for the "none" reduction method with blocking but no threads (test $my_test_count)" '
+ mpirun -n 1 ../check_time_avg
+'
+
my_test_count=`expr $my_test_count + 1`
printf "&diag_manager_nml \n use_modern_diag=.true. \n / \n&test_reduction_methods_nml \n test_case = 2 \n \n/" | cat > input.nml
test_expect_success "Running diag_manager with "avg" reduction method with halo output (test $my_test_count)" '
diff --git a/test_fms/diag_manager/test_var_masks.F90 b/test_fms/diag_manager/test_var_masks.F90
new file mode 100644
index 0000000000..d1030d236c
--- /dev/null
+++ b/test_fms/diag_manager/test_var_masks.F90
@@ -0,0 +1,87 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This programs tests fields that have a mask that changes over time
+!! It also tests the corner case where send_data is called twice for the same time
+program test_var_masks
+ use fms_mod, only: fms_init, fms_end
+ use diag_manager_mod
+ use mpp_mod
+ use mpp_domains_mod
+ use platform_mod, only: r8_kind, r4_kind
+ use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+)
+ use fms_diag_yaml_mod
+
+ implicit none
+
+ type(time_type) :: Time !< Time of the simulation
+ type(time_type) :: Time_step !< Time_step of the simulation
+ integer :: nx !< Number of x points
+ integer :: ny !< Number of y points
+ integer :: nz !< Number of z points
+ integer :: id_x !< Axis id for the x dimension
+ integer :: id_y !< Axis id for the y dimension
+ integer :: id_var1 !< Field id for 1 variable
+ logical :: used !< Dummy argument to send_data
+ real, allocatable :: x(:) !< X axis data
+ real, allocatable :: y(:) !< Y axis_data
+ real, allocatable :: var1_data(:,:) !< Data for variable 1
+ logical, allocatable :: var1_mask(:,:) !< Mask for variable 1
+ integer :: i !< For do loops
+
+ call fms_init
+ call set_calendar_type(JULIAN)
+ call diag_manager_init
+
+ nx = 360
+ ny = 180
+
+ allocate(x(nx), y(ny))
+ allocate(var1_data(nx,ny), var1_mask(nx,ny))
+ do i=1,nx
+ x(i) = i
+ enddo
+ do i=1,ny
+ y(i) = -91 + i
+ enddo
+
+ Time = set_date(2,1,1,0,0,0)
+ Time_step = set_time (3600,0) !< 1 hour
+
+ id_x = diag_axis_init('x', x, 'point_E', 'x', long_name='point_E')
+ id_y = diag_axis_init('y', y, 'point_N', 'y', long_name='point_N')
+
+ id_var1 = register_diag_field ('atmos', 'ua', (/id_x, id_y/), Time, missing_value=-999., mask_variant=.True.)
+
+ call diag_manager_set_time_end(set_date(2,1,2,0,0,0))
+ do i = 1, 24
+ Time = Time + Time_step
+
+ var1_mask = .True.
+ !< The first point is going to be asked every other hour
+ if (mod(i,2) .eq. 0) var1_mask(1,1) = .False.
+ var1_data = real(i)
+ used = send_data(id_var1, var1_data, Time, mask=var1_mask)
+
+ call diag_send_complete(Time_step)
+ enddo
+
+ call diag_manager_end(Time)
+ call fms_end
+end program test_var_masks
diff --git a/test_fms/diag_manager/test_var_masks.sh b/test_fms/diag_manager/test_var_masks.sh
new file mode 100755
index 0000000000..761fb345cf
--- /dev/null
+++ b/test_fms/diag_manager/test_var_masks.sh
@@ -0,0 +1,56 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+cat <<_EOF > diag_table.yaml
+title: test_var_masks
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_var_masks
+ freq: 1 days
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - module: atmos
+ var_name: ua
+ reduction: average
+ kind: r4
+_EOF
+
+# remove any existing files that would result in false passes during checks
+rm -f *.nc
+
+my_test_count=1
+printf "&diag_manager_nml \n use_modern_diag=.true. \n/" | cat > input.nml
+test_expect_success "Running diag_manager with a field with a variable mask (test $my_test_count)" '
+ mpirun -n 1 ../test_var_masks
+'
+test_expect_success "Checking answers for when diag_manager with a field with a variable mask (test $my_test_count)" '
+ mpirun -n 1 ../check_var_masks
+'
+fi
+test_done
From 409caeee2e77ce81ecbc78f8ba32b222385029d2 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 29 Feb 2024 07:36:54 -0500
Subject: [PATCH 151/168] feat!: modern diag manager: remove non-standard time
bounds (#1466)
* Removes the Average_* variables from the history files
* remove the time_avg_info variable attribute
---
diag_manager/fms_diag_field_object.F90 | 9 ---------
diag_manager/fms_diag_file_object.F90 | 13 -------------
2 files changed, 22 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 4a22b9002a..932c874dfb 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -1169,15 +1169,6 @@ subroutine write_field_metadata(this, fms2io_fileobj, file_id, yaml_id, diag_axi
str_len=len_trim(this%get_interp_method()))
endif
- if (.not. this%static) then
- select case (field_yaml%get_var_reduction())
- case (time_average, time_max, time_min, time_diurnal, time_power, time_rms, time_sum)
- call register_variable_attribute(fms2io_fileobj, var_name, "time_avg_info", &
- trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT', &
- str_len=len(trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT'))
- end select
- endif
-
cell_methods = ""
!< Check if any of the attributes defined via a "diag_field_add_attribute" call
!! are the cell_methods, if so add to the "cell_methods" variable:
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 0ce1e906c6..f433d3bcda 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -1280,14 +1280,6 @@ subroutine write_time_metadata(this)
call register_variable_attribute(fms2io_fileobj, time_var_name, "bounds", &
trim(time_var_name)//"_bnds", str_len=len_trim(time_var_name//"_bnds"))
- !< Write out the "average_*" variables metadata
- call write_var_metadata(fms2io_fileobj, avg_name//"_T1", dimensions(2:2), &
- "Start time for average period", time_units_str)
- call write_var_metadata(fms2io_fileobj, avg_name//"_T2", dimensions(2:2), &
- "End time for average period", time_units_str)
- call write_var_metadata(fms2io_fileobj, avg_name//"_DT", dimensions(2:2), &
- "Length of average period", time_unit_list(diag_file%get_file_timeunit()))
-
!< It is possible that the "nv" "axis" was registered via "diag_axis_init" call
!! so only adding it if it doesn't exist already
if ( .not. dimension_exists(fms2io_fileobj, "nv")) then
@@ -1398,7 +1390,6 @@ subroutine write_time_data(this, is_the_end)
real :: T1 !< The beginning time of the averaging period
real :: T2 !< The ending time of the averaging period
- real :: DT !< The difference between the ending and beginning time of the averaging period
diag_file => this%FMS_diag_file
fms2io_fileobj => diag_file%fms2io_fileobj
@@ -1421,11 +1412,7 @@ subroutine write_time_data(this, is_the_end)
if (diag_file%time_ops) then
T1 = get_date_dif(diag_file%last_output, get_base_time(), diag_file%get_file_timeunit())
T2 = get_date_dif(diag_file%next_output, get_base_time(), diag_file%get_file_timeunit())
- DT = T2 - T1
- call write_data(fms2io_fileobj, avg_name//"_T1", T1, unlim_dim_level=diag_file%unlim_dimension_level)
- call write_data(fms2io_fileobj, avg_name//"_T2", T2, unlim_dim_level=diag_file%unlim_dimension_level)
- call write_data(fms2io_fileobj, avg_name//"_DT", DT, unlim_dim_level=diag_file%unlim_dimension_level)
call write_data(fms2io_fileobj, trim(diag_file%get_file_unlimdim())//"_bnds", &
(/T1, T2/), unlim_dim_level=diag_file%unlim_dimension_level)
From 52a554bcade387910d5b0fb8ccf2b8e0c353cf0c Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 5 Mar 2024 16:46:01 -0500
Subject: [PATCH 152/168] Fix: Modern Diag Manager Subregional Corner
Diagnostics (#1470)
---
diag_manager/fms_diag_axis_object.F90 | 13 ++++
diag_manager/fms_diag_file_object.F90 | 1 +
test_fms/diag_manager/check_subregional.F90 | 69 ++++++++++++++++++-
.../diag_manager/test_reduction_methods.F90 | 21 +++++-
test_fms/diag_manager/test_subregional.sh | 61 ++++++++++++++++
5 files changed, 161 insertions(+), 4 deletions(-)
diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90
index 5a2e885666..a28d22b291 100644
--- a/diag_manager/fms_diag_axis_object.F90
+++ b/diag_manager/fms_diag_axis_object.F90
@@ -761,6 +761,19 @@ subroutine get_indices(this, compute_idx, corners_indices, starting_index, endin
ending_index = subregion_end
endif
+ if (this%domain_position .ne. CENTER) then
+ if (subregion_end - subregion_start + 1 .eq. 1) then
+ !< If your subregion consitsts of just 1 one, only include 1 PE
+ if (ending_index .eq. compute_idx(2)) need_to_define_axis = .false.
+ else
+ if (ending_index - starting_index + 1 .eq. 1) then
+ !< If the PEs section is only 1, only include 1 PE
+ if (starting_index .eq. compute_idx(2) .or. ending_index .eq. compute_idx(1)) &
+ need_to_define_axis = .false.
+ endif
+ endif
+ endif
+
end subroutine get_indices
!< Get the compute domain of the axis
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index f433d3bcda..534d993009 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -1542,6 +1542,7 @@ subroutine write_axis_metadata(this, diag_axis)
edges_in_file = .true.
else
call diag_axis(edges_id)%axis%write_axis_metadata(fms2io_fileobj, .true.)
+ call diag_file%add_new_axis(edges_id)
endif
endif
diff --git a/test_fms/diag_manager/check_subregional.F90 b/test_fms/diag_manager/check_subregional.F90
index 3b93958cb9..b683f8bf13 100644
--- a/test_fms/diag_manager/check_subregional.F90
+++ b/test_fms/diag_manager/check_subregional.F90
@@ -20,7 +20,7 @@
!> @brief Checks the output file after running test_subregional
program check_subregional
use fms_mod, only: fms_init, fms_end, string
- use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file, get_dimension_size
+ use fms2_io_mod, only: FmsNetcdfFile_t, read_data, close_file, open_file, get_dimension_size, file_exists
use mpp_mod, only: mpp_npes, mpp_error, FATAL, mpp_pe
use platform_mod, only: r4_kind, r8_kind
@@ -32,6 +32,7 @@ program check_subregional
! The files are in the same subregion, one of them is defined using latlon and another one indices
call check_subregional_file("test_subregional.nc")
call check_subregional_file("test_subregional2.nc")
+ call check_corner_files()
call fms_end()
@@ -136,4 +137,70 @@ subroutine check_subregional_file(file_name)
end subroutine check_subregional_file
+ !> @brief Check the data for the corner subregional files
+ subroutine check_corner_files()
+ type(FmsNetcdfFile_t) :: fileobj !< FMS2 fileobj
+ integer :: dim_size !< dim_size as read in from the file
+ real, allocatable :: dims(:) !< dimension data as read in from the file
+ real, allocatable :: dims_exp(:) !< dimensions data expected
+
+ !subregion:
+ !corner1: 17. 17.
+ !corner2: 17. 20.
+ !corner3: 20. 17.
+ !corner4: 20. 20.
+ ! In this case, lat 17 is shared between PE 0 and PE 1, but only PE 1 should have data
+ if (file_exists("test_corner1.nc.0000")) &
+ call mpp_error(FATAL, "test_corner1.nc.0000 should not exist!")
+
+ if (.not. open_file(fileobj, "test_corner1.nc.0001", "read")) &
+ call mpp_error(FATAL, "unable to open test_corner1.nc.0001")
+
+ call get_dimension_size(fileobj, "xc_sub01", dim_size)
+ if (dim_size .ne. 4) call mpp_error(FATAL, "xc_sub01 is not the correct size!")
+ call get_dimension_size(fileobj, "yc_sub01", dim_size)
+ if (dim_size .ne. 4) call mpp_error(FATAL, "yc_sub01 is not the correct size!")
+ call close_file(fileobj)
+
+ !subregion
+ !corner1: 17. 17.
+ !corner2: 20. 17.
+ !corner3: 17. 17.
+ !corner4: 20. 17.
+ ! In this case, lat 17 is shared between PE 0 and PE 1, but only PE 1 should have data
+ if (file_exists("test_corner2.nc.0000")) &
+ call mpp_error(FATAL, "test_corner2.nc.0000 should not exist!")
+
+ if (.not. open_file(fileobj, "test_corner2.nc.0001", "read")) &
+ call mpp_error(FATAL, "unable to open test_corner2.nc.0001")
+
+ call get_dimension_size(fileobj, "xc_sub01", dim_size)
+ if (dim_size .ne. 4) call mpp_error(FATAL, "xc_sub01 is not the correct size!")
+ call get_dimension_size(fileobj, "yc_sub01", dim_size)
+ if (dim_size .ne. 1) call mpp_error(FATAL, "yc_sub01 is not the correct size!")
+ call close_file(fileobj)
+
+ !subregion
+ ! In this case, lat 17 is shared between PE 0 and PE 1, but only PE 1 should have data
+ ! lat 33 is shared between PE 1 and PE 2, but only PE 1 should have data
+ !corner1: 17. 17.
+ !corner2: 20. 17.
+ !corner3: 17. 33.
+ !corner4: 20. 33.
+ if (file_exists("test_corner3.nc.0000")) &
+ call mpp_error(FATAL, "test_corner3.nc.0000 should not exist!")
+ if (file_exists("test_corner3.nc.0003")) &
+ call mpp_error(FATAL, "test_corner3.nc.0003 should not exist!")
+
+ if (.not. open_file(fileobj, "test_corner3.nc.0001", "read")) &
+ call mpp_error(FATAL, "unable to open test_corner3.nc.0001")
+
+ call get_dimension_size(fileobj, "xc_sub01", dim_size)
+ if (dim_size .ne. 4) call mpp_error(FATAL, "xc_sub01 is not the correct size!")
+ call get_dimension_size(fileobj, "yc_sub01", dim_size)
+ if (dim_size .ne. 17) call mpp_error(FATAL, "yc_sub01 is not the correct size!")
+ call close_file(fileobj)
+
+ end subroutine check_corner_files
+
end program
diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90
index df5102e761..8327121ae5 100644
--- a/test_fms/diag_manager/test_reduction_methods.F90
+++ b/test_fms/diag_manager/test_reduction_methods.F90
@@ -28,7 +28,7 @@ program test_reduction_methods
use diag_manager_mod, only: diag_manager_init, diag_manager_end, diag_axis_init, register_diag_field, &
diag_send_complete, diag_manager_set_time_end, send_data
use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain, &
- mpp_get_data_domain
+ mpp_get_data_domain, NORTH, EAST
implicit none
@@ -46,6 +46,7 @@ program test_reduction_methods
integer :: nhalox !< Number of halos in x
integer :: nhaloy !< Number of halos in y
real(kind=r8_kind), allocatable :: cdata(:,:,:,:) !< Data in the compute domain
+ real(kind=r8_kind), allocatable :: cdata_corner(:,:,:,:) !< Data in the compute domain
real(kind=r8_kind), allocatable :: ddata(:,:,:,:) !< Data in the data domain
real(kind=r8_kind), allocatable :: crmask(:,:,:,:) !< Mask in the compute domain
real(kind=r8_kind), allocatable :: drmask(:,:,:,:) !< Mask in the data domain
@@ -55,12 +56,15 @@ program test_reduction_methods
type(time_type) :: Time_step !< Time of the simulation
integer :: ntimes !< Number of times
integer :: id_x !< axis id for the x dimension
+ integer :: id_xc !< axis id for the x dimension (corner)
integer :: id_y !< axis id for the y dimension
+ integer :: id_yc !< axis id for the y dimension (corner)
integer :: id_z !< axis id for the z dimension
integer :: id_w !< axis id for the w dimension
integer :: id_var0 !< diag_field id for 0d var
integer :: id_var1 !< diag_field id for 1d var
integer :: id_var2 !< diag_field id for 2d var
+ integer :: id_var2c !< diag_field id for 2d var_corner
integer :: id_var3 !< diag_field id for 3d var
integer :: id_var4 !< diag_field id for 4d var
integer :: id_var999 !< diag_field id for a var that send_data is not called for
@@ -111,13 +115,15 @@ program test_reduction_methods
ntimes = 48
!< Create a lat/lon domain
- call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain', xhalo=nhalox, yhalo=nhaloy)
+ call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, name='2D domain', symmetry=.true., &
+ xhalo=nhalox, yhalo=nhaloy)
call mpp_define_io_domain(Domain, io_layout)
call mpp_get_compute_domain(Domain, isc, iec, jsc, jec)
call mpp_get_data_domain(Domain, isd, ied, jsd, jed)
-
cdata = allocate_buffer(isc, iec, jsc, jec, nz, nw)
+ cdata_corner = allocate_buffer(isc, iec+1, jsc, jec+1, nz, nw)
call init_buffer(cdata, isc, iec, jsc, jec, 0)
+ call init_buffer(cdata_corner, isc, iec+1, jsc, jec+1, 0)
select case (test_case)
case (test_normal)
@@ -154,8 +160,12 @@ program test_reduction_methods
!< Register the axis
id_x = diag_axis_init('x', real((/ (i, i = 1,nx) /), kind=r8_kind), 'point_E', 'x', long_name='point_E', &
Domain2=Domain)
+ id_xc = diag_axis_init('xc', real((/ (i, i = 1,nx+1) /), kind=r8_kind), 'point_E corner', 'x', &
+ long_name='point_E', Domain2=Domain, domain_position=EAST)
id_y = diag_axis_init('y', real((/ (i, i = 1,ny) /), kind=r8_kind), 'point_N', 'y', long_name='point_N', &
Domain2=Domain)
+ id_yc = diag_axis_init('yc', real((/ (i, i = 1,ny) /), kind=r8_kind), 'point_N corner', 'y', &
+ long_name='point_N', Domain2=Domain, domain_position=NORTH)
id_z = diag_axis_init('z', real((/ (i, i = 1,nz) /), kind=r8_kind), 'point_Z', 'z', long_name='point_Z')
id_w = diag_axis_init('w', real((/ (i, i = 1,nw) /), kind=r8_kind), 'point_W', 'n', long_name='point_W')
@@ -167,6 +177,8 @@ program test_reduction_methods
'mullions', missing_value = missing_value)
id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_x, id_y/), Time, 'Var2d', &
'mullions', missing_value = missing_value)
+ id_var2c = register_diag_field ('ocn_mod', 'var2c', (/id_xc, id_yc/), Time, 'Var2d corner', &
+ 'mullions', missing_value = missing_value)
id_var3 = register_diag_field ('ocn_mod', 'var3', (/id_x, id_y, id_z/), Time, 'Var3d', &
'mullions', missing_value = missing_value)
id_var4 = register_diag_field ('ocn_mod', 'var4', (/id_x, id_y, id_z, id_w/), Time, 'Var4d', &
@@ -184,6 +196,9 @@ program test_reduction_methods
Time = Time + Time_step
call set_buffer(cdata, i)
+ call set_buffer(cdata_corner, i)
+
+ used = send_data(id_var2c, cdata_corner(:,:,1,1), Time)
used = send_data(id_var0, cdata(1,1,1,1), Time)
select case(test_case)
diff --git a/test_fms/diag_manager/test_subregional.sh b/test_fms/diag_manager/test_subregional.sh
index 41d43cc6c2..dcb1f5e9da 100755
--- a/test_fms/diag_manager/test_subregional.sh
+++ b/test_fms/diag_manager/test_subregional.sh
@@ -103,9 +103,70 @@ test_expect_success "Running diag_manager with different subregions (test $my_te
mpirun -n 6 ../test_reduction_methods
'
+cat <<_EOF > diag_table.yaml
+title: test_corner_subregional
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_corner1
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var2c
+ output_name: var2c_avg
+ reduction: average
+ kind: r4
+ sub_region:
+ - grid_type: latlon
+ corner1: 17. 17.
+ corner2: 17. 20.
+ corner3: 20. 17.
+ corner4: 20. 20.
+- file_name: test_corner2
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var2c
+ output_name: var2c_avg
+ reduction: average
+ kind: r4
+ sub_region:
+ - grid_type: latlon
+ corner1: 17. 17.
+ corner2: 20. 17.
+ corner3: 17. 17.
+ corner4: 20. 17.
+- file_name: test_corner3
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var2c
+ output_name: var2c_avg
+ reduction: average
+ kind: r4
+ sub_region:
+ - grid_type: latlon
+ corner1: 17. 17.
+ corner2: 20. 17.
+ corner3: 17. 33.
+ corner4: 20. 33.
+_EOF
+
+my_test_count=`expr $my_test_count + 1`
+printf "&diag_manager_nml \n use_modern_diag=.true. \n/" | cat > input.nml
+test_expect_success "Running diag_manager with corner diagnotics (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+
my_test_count=`expr $my_test_count + 1`
test_expect_success "Checking results from diag_manager with different subregions (test $my_test_count)" '
mpirun -n 1 ../check_subregional
'
+
fi
test_done
From 92ee40ba4513b87d558e21fc93eb892b550fc53d Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 5 Mar 2024 16:56:53 -0500
Subject: [PATCH 153/168] Fix: Diag Manager Logic to add extra unlimited
dimension (#1472)
---
diag_manager/fms_diag_file_object.F90 | 20 ++++++++++++--------
diag_manager/fms_diag_object.F90 | 2 +-
2 files changed, 13 insertions(+), 9 deletions(-)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 534d993009..e20fb0e540 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -95,6 +95,7 @@ module fms_diag_file_object_mod
integer :: number_of_buffers !< Number of buffers that have been added to the file
logical :: time_ops !< .True. if file contains variables that are time_min, time_max, time_average or time_sum
integer :: unlim_dimension_level !< The unlimited dimension level currently being written
+ logical :: data_has_been_written !< .True. if data has been written for the current unlimited dimension level
logical :: is_static !< .True. if the frequency is -1
integer :: nz_subaxis !< The number of Z axis currently added to the file
@@ -1311,12 +1312,16 @@ subroutine write_field_data(this, field_obj, buffer_obj)
!< Here the file is static so there is no need for the unlimited dimension
!! as a variables are static
call buffer_obj%write_buffer(fms2io_fileobj)
+ diag_file%data_has_been_written = .true.
else
if (field_obj%is_static()) then
!< If the variable is static, only write it the first time
- if (diag_file%unlim_dimension_level .eq. 1) &
- call buffer_obj%write_buffer(fms2io_fileobj)
+ if (diag_file%unlim_dimension_level .eq. 1) then
+ call buffer_obj%write_buffer(fms2io_fileobj)
+ diag_file%data_has_been_written = .true.
+ endif
else
+ diag_file%data_has_been_written = .true.
has_diurnal = buffer_obj%get_diurnal_sample_size() .gt. 1
if (.not. buffer_obj%is_there_data_to_write()) then
! Only print the error message once
@@ -1379,9 +1384,8 @@ logical function writing_on_this_pe(this)
end function
!> \brief Write out the time data to the file
-subroutine write_time_data(this, is_the_end)
+subroutine write_time_data(this)
class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
- logical, optional, intent(in) :: is_the_end !< True if it is the end of the run
real :: dif !< The time as a real number
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
@@ -1394,10 +1398,9 @@ subroutine write_time_data(this, is_the_end)
diag_file => this%FMS_diag_file
fms2io_fileobj => diag_file%fms2io_fileobj
- if (present(is_the_end)) then
- ! If at the end of the run, do not do anything for the static files
- if (is_the_end .and. diag_file%is_static) return
- endif
+ !< If data has not been written for the current unlimited dimension
+ !! ignore this
+ if (.not. diag_file%data_has_been_written) return
if (diag_file%time_ops) then
middle_time = (diag_file%last_output+diag_file%next_output)/2
@@ -1477,6 +1480,7 @@ subroutine increase_unlim_dimension_level(this)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
this%FMS_diag_file%unlim_dimension_level = this%FMS_diag_file%unlim_dimension_level + 1
+ this%FMS_diag_file%data_has_been_written = .false.
end subroutine increase_unlim_dimension_level
!> \brief Get the unlimited dimension level that is in the file
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 499543cc7f..b27488ae96 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -827,7 +827,7 @@ subroutine fms_diag_do_io(this, end_time)
call diag_file%increase_unlim_dimension_level()
if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file()
else if (force_write) then
- call diag_file%write_time_data(is_the_end = .true.)
+ call diag_file%write_time_data()
call diag_file%close_diag_file()
endif
enddo
From 2cae720c9562f3937b3de5510fe76a9e1c783d91 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Wed, 6 Mar 2024 10:57:07 -0500
Subject: [PATCH 154/168] fix: modern diag manager input buffer (#1468)
---
diag_manager/fms_diag_field_object.F90 | 20 ++++++++++++++
diag_manager/fms_diag_input_buffer.F90 | 22 ++++++++++++++++
diag_manager/fms_diag_object.F90 | 36 +++++++++++++++++---------
3 files changed, 66 insertions(+), 12 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 932c874dfb..c89db16272 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -94,6 +94,8 @@ module fms_diag_field_object_mod
procedure :: set_type => set_vartype
procedure :: set_data_buffer => set_data_buffer
procedure :: set_data_buffer_is_allocated
+ procedure :: set_send_data_time
+ procedure :: get_send_data_time
procedure :: is_data_buffer_allocated
procedure :: allocate_data_buffer
procedure :: set_math_needs_to_be_done => set_math_needs_to_be_done
@@ -406,6 +408,24 @@ subroutine set_vartype(objin , var)
end select
end subroutine set_vartype
+!> @brief Sets the time send data was called last
+subroutine set_send_data_time (this, time)
+ class (fmsDiagField_type) , intent(inout):: this !< The field object
+ type(time_type), intent(in) :: time !< Current model time
+
+ call this%input_data_buffer%set_send_data_time(time)
+end subroutine set_send_data_time
+
+!> @brief Get the time send data was called last
+!! @result the time send data was called last
+function get_send_data_time(this) &
+ result(rslt)
+ class (fmsDiagField_type) , intent(in):: this !< The field object
+ type(time_type) :: rslt
+
+ rslt = this%input_data_buffer%get_send_data_time()
+end function get_send_data_time
+
!> @brief Adds the input data to the buffered data.
subroutine set_data_buffer (this, input_data, weight, is, js, ks, ie, je, ke)
class (fmsDiagField_type) , intent(inout):: this !< The field object
diff --git a/diag_manager/fms_diag_input_buffer.F90 b/diag_manager/fms_diag_input_buffer.F90
index 12257734ce..799278aad0 100644
--- a/diag_manager/fms_diag_input_buffer.F90
+++ b/diag_manager/fms_diag_input_buffer.F90
@@ -25,6 +25,7 @@ module fms_diag_input_buffer_mod
#ifdef use_yaml
use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind
use fms_diag_axis_object_mod, only: fmsDiagAxisContainer_type, fmsDiagFullAxis_type
+ use time_manager_mod, only: time_type
implicit NONE
private
@@ -35,12 +36,15 @@ module fms_diag_input_buffer_mod
logical :: initialized !< .True. if the input buffer has been initialized
class(*), allocatable :: buffer(:,:,:,:) !< Input data passed in send_data
real(kind=r8_kind) :: weight !< Weight passed in send_data
+ type(time_type) :: send_data_time !< The time send data was called last
contains
procedure :: get_buffer
procedure :: get_weight
procedure :: init => init_input_buffer_object
procedure :: set_input_buffer_object
+ procedure :: set_send_data_time
+ procedure :: get_send_data_time
procedure :: is_initialized
end type fmsDiagInputBuffer_t
@@ -118,6 +122,24 @@ function init_input_buffer_object(this, input_data, axis_ids, diag_axis) &
this%initialized = .true.
end function init_input_buffer_object
+ !> @brief Sets the time send data was called last
+ subroutine set_send_data_time(this, time)
+ class(fmsDiagInputBuffer_t), intent(inout) :: this !< input buffer object
+ type(time_type), intent(in) :: time !< The time send data was called
+
+ this%send_data_time = time
+ end subroutine set_send_data_time
+
+ !> @brief Get the time send data was called last
+ !! @result the time send data was called last
+ function get_send_data_time(this) &
+ result(rslt)
+ class(fmsDiagInputBuffer_t), intent(in) :: this !< input buffer object
+ type(time_type) :: rslt
+
+ rslt = this%send_data_time
+ end function get_send_data_time
+
!> @brief Sets the members of the input buffer object
!! @return Error message if something went wrong
function set_input_buffer_object(this, input_data, weight, is, js, ks, ie, je, ke) &
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index b27488ae96..363966de91 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -88,6 +88,7 @@ module fms_diag_object_mod
procedure :: fms_get_axis_name_from_id
procedure :: fms_diag_accept_data
procedure :: fms_diag_send_complete
+ procedure :: do_buffer_math
procedure :: fms_diag_do_io
procedure :: fms_diag_do_reduction
procedure :: fms_diag_field_add_cell_measures
@@ -153,6 +154,7 @@ subroutine fms_diag_object_end (this, time)
!TODO: loop through files and force write
if (.not. this%initialized) return
+ call this%do_buffer_math()
call this%fms_diag_do_io(end_time=time)
!TODO: Deallocate diag object arrays and clean up all memory
do i=1, size(this%FMS_diag_output_buffers)
@@ -538,6 +540,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
#ifndef use_yaml
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
#else
+
+ !TODO this%FMS_diag_fields(diag_field_id) should be a pointer!
field_info = " Check send data call for field:"//trim(this%FMS_diag_fields(diag_field_id)%get_varname())//&
" and module:"//trim(this%FMS_diag_fields(diag_field_id)%get_modname())
@@ -629,6 +633,7 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
if(.not. this%FMS_diag_fields(diag_field_id)%has_mask_allocated()) &
call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask, this%diag_axis)
endif
+ call this%FMS_diag_fields(diag_field_id)%set_send_data_time(time)
call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.)
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.)
!$omp end critical
@@ -672,20 +677,15 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
return
#endif
end function fms_diag_accept_data
-!! TODO: This entire routine
-!> @brief Loops through all the files, open the file, writes out axis and
-!! variable metadata and data when necessary.
-subroutine fms_diag_send_complete(this, time_step)
+
+!< @brief Do the math for all the buffers
+subroutine do_buffer_math(this)
class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object
- TYPE (time_type), INTENT(in) :: time_step !< The time_step
+#ifdef use_yaml
integer :: i !< For do loops
-
integer :: ifile !< For file loops
integer :: ifield !< For field loops
-#ifndef use_yaml
-CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
-#else
class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience
class(fmsDiagField_type), pointer :: diag_field !< Pointer to this%FMS_diag_files(i)%diag_field(j)
@@ -698,7 +698,7 @@ subroutine fms_diag_send_complete(this, time_step)
integer, dimension(:), allocatable :: file_ids !< Array of file IDs for a field
logical, parameter :: DEBUG_SC = .false. !< turn on output for debugging
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! In the future, this may be parallelized for offloading
! loop through each field
field_loop: do ifield = 1, size(this%FMS_diag_fields)
@@ -719,7 +719,7 @@ subroutine fms_diag_send_complete(this, time_step)
call this%allocate_diag_field_output_buffers(input_data_buffer, ifield)
error_string = this%fms_diag_do_reduction(input_data_buffer, ifield, &
diag_field%get_mask(), diag_field%get_weight(), &
- bounds, .False., Time=this%current_model_time)
+ bounds, .False., Time=diag_field%get_send_data_time())
if (trim(error_string) .ne. "") call mpp_error(FATAL, "Field:"//trim(diag_field%get_varname()//&
" -"//trim(error_string)))
else
@@ -731,8 +731,20 @@ subroutine fms_diag_send_complete(this, time_step)
if (allocated(file_ids)) deallocate(file_ids)
if (associated(diag_field)) nullify(diag_field)
enddo field_loop
+#endif
+end subroutine do_buffer_math
+
+!> @brief Loops through all the files, open the file, writes out axis and
+!! variable metadata and data when necessary.
+subroutine fms_diag_send_complete(this, time_step)
+ class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object
+ TYPE (time_type), INTENT(in) :: time_step !< The time_step
-call this%fms_diag_do_io()
+#ifndef use_yaml
+CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
+#else
+ call this%do_buffer_math()
+ call this%fms_diag_do_io()
#endif
end subroutine fms_diag_send_complete
From d7314d6453a55c616bd6e22bbdfa6c6e3e36c973 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 18 Mar 2024 15:12:19 -0400
Subject: [PATCH 155/168] fix: Modern_diag_manager multiple_send_data calls
option (#1478)
---
diag_manager/Makefile.am | 10 +-
diag_manager/diag_manager.F90 | 14 +-
diag_manager/fms_diag_field_object.F90 | 83 +++++++++-
diag_manager/fms_diag_file_object.F90 | 5 +-
diag_manager/fms_diag_input_buffer.F90 | 148 +++++++++++++++++-
diag_manager/fms_diag_object.F90 | 58 +++++--
diag_manager/fms_diag_output_buffer.F90 | 21 +--
.../include/fms_diag_input_buffer.inc | 61 ++++++++
.../include/fms_diag_input_buffer_r4.fh | 38 +++++
.../include/fms_diag_input_buffer_r8.fh | 38 +++++
.../include/fms_diag_reduction_methods.inc | 17 +-
test_fms/diag_manager/Makefile.am | 7 +-
.../diag_manager/test_multiple_send_data.F90 | 144 +++++++++++++++++
.../diag_manager/test_multiple_send_data.sh | 57 +++++++
14 files changed, 637 insertions(+), 64 deletions(-)
create mode 100644 diag_manager/include/fms_diag_input_buffer.inc
create mode 100644 diag_manager/include/fms_diag_input_buffer_r4.fh
create mode 100644 diag_manager/include/fms_diag_input_buffer_r8.fh
create mode 100644 test_fms/diag_manager/test_multiple_send_data.F90
create mode 100755 test_fms/diag_manager/test_multiple_send_data.sh
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index b55eb826a4..a90137d368 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -63,7 +63,10 @@ libdiag_manager_la_SOURCES = \
include/fms_diag_fieldbuff_update.fh \
include/fms_diag_reduction_methods.inc \
include/fms_diag_reduction_methods_r4.fh \
- include/fms_diag_reduction_methods_r8.fh
+ include/fms_diag_reduction_methods_r8.fh \
+ include/fms_diag_input_buffer.inc \
+ include/fms_diag_input_buffer_r4.fh \
+ include/fms_diag_input_buffer_r8.fh
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
@@ -139,7 +142,10 @@ MODFILES = \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh \
include/fms_diag_reduction_methods_r4.fh \
- include/fms_diag_reduction_methods_r8.fh
+ include/fms_diag_reduction_methods_r8.fh \
+ include/fms_diag_input_buffer.inc \
+ include/fms_diag_input_buffer_r4.fh \
+ include/fms_diag_input_buffer_r8.fh
nodist_include_HEADERS = $(MODFILES)
BUILT_SOURCES = $(MODFILES)
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index c440d5ec26..d546efb759 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -378,7 +378,7 @@ MODULE diag_manager_mod
!! @return field index for subsequent call to send_data.
INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, &
& long_name, units, missing_value, range, standard_name, do_not_log, err_msg,&
- & area, volume, realm)
+ & area, volume, realm, multiple_send_data)
CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
@@ -392,6 +392,8 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple times
+ !! for the same time
if (use_modern_diag) then
if( do_diag_field_log) then
@@ -406,7 +408,8 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
register_diag_field_scalar = fms_diag_object%fms_register_diag_field_scalar( &
& module_name, field_name, init_time, long_name=long_name, units=units, &
& missing_value=missing_value, var_range=range, standard_name=standard_name, &
- & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm)
+ & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm, &
+ multiple_send_data=multiple_send_data)
else
register_diag_field_scalar = register_diag_field_scalar_old(module_name, field_name, init_time, &
& long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, &
@@ -418,7 +421,7 @@ end function register_diag_field_scalar
!> @return field index for subsequent call to send_data.
INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_time, &
& long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
- & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
+ & do_not_log, err_msg, interp_method, tile_count, area, volume, realm, multiple_send_data)
CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis
@@ -440,6 +443,8 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple times
+ !! for the same time
if (use_modern_diag) then
if( do_diag_field_log) then
@@ -455,7 +460,8 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
& module_name, field_name, axes, init_time, long_name=long_name, &
& units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, &
& standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
- & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
+ & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
+ multiple_send_data=multiple_send_data)
else
register_diag_field_array = register_diag_field_array_old(module_name, field_name, axes, init_time, &
& long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, &
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index c89db16272..34e425eb9b 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -74,6 +74,8 @@ module fms_diag_field_object_mod
class(*), allocatable, private :: data_RANGE(:) !< The range of the variable data
type(fmsDiagInputBuffer_t), allocatable :: input_data_buffer !< Input buffer object for when buffering
!! data
+ logical, allocatable, private :: multiple_send_data!< .True. if send_data is called multiple
+ !! times for the same model time
logical, allocatable, private :: data_buffer_is_allocated !< True if the buffer has
!! been allocated
logical, allocatable, private :: math_needs_to_be_done !< If true, do math
@@ -93,6 +95,8 @@ module fms_diag_field_object_mod
procedure :: setID => set_diag_id
procedure :: set_type => set_vartype
procedure :: set_data_buffer => set_data_buffer
+ procedure :: prepare_data_buffer
+ procedure :: init_data_buffer
procedure :: set_data_buffer_is_allocated
procedure :: set_send_data_time
procedure :: get_send_data_time
@@ -165,6 +169,7 @@ module fms_diag_field_object_mod
procedure :: get_dimnames
procedure :: get_var_skind
procedure :: get_longname_to_write
+ procedure :: get_multiple_send_data
procedure :: write_field_metadata
procedure :: write_coordinate_attribute
procedure :: get_math_needs_to_be_done
@@ -193,6 +198,7 @@ module fms_diag_field_object_mod
public :: null_ob
public :: fms_diag_field_object_end
public :: get_default_missing_value
+public :: check_for_slices
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
CONTAINS
@@ -225,7 +231,8 @@ end function fms_diag_fields_object_init
subroutine fms_register_diag_field_obj &
(this, modname, varname, diag_field_indices, diag_axis, axes, &
longname, units, missing_value, varRange, mask_variant, standname, &
- do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static, &
+ multiple_send_data)
class(fmsDiagField_type), INTENT(inout) :: this !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: modname !< The module name
@@ -252,6 +259,8 @@ subroutine fms_register_diag_field_obj &
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
!! modeling_realm attribute
LOGICAL, OPTIONAL, INTENT(in) :: static !< Set to true if it is a static field
+ LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple
+ !! times for the same time
!> Fill in information from the register call
this%varname = trim(varname)
@@ -363,6 +372,12 @@ subroutine fms_register_diag_field_obj &
this%do_not_log = do_not_log
endif
+ if (present(multiple_send_data)) then
+ this%multiple_send_data = multiple_send_data
+ else
+ this%multiple_send_data = .false.
+ endif
+
!< Allocate space for any additional variable attributes
!< These will be fill out when calling `diag_field_add_attribute`
allocate(this%attributes(max_field_attributes))
@@ -426,10 +441,30 @@ function get_send_data_time(this) &
rslt = this%input_data_buffer%get_send_data_time()
end function get_send_data_time
+!> @brief Prepare the input_data_buffer to do the reduction method
+subroutine prepare_data_buffer(this)
+ class (fmsDiagField_type) , intent(inout):: this !< The field object
+
+ if (.not. this%multiple_send_data) return
+ if (this%mask_variant) return
+ call this%input_data_buffer%prepare_input_buffer_object(this%modname//":"//this%varname)
+end subroutine prepare_data_buffer
+
+!> @brief Initialize the input_data_buffer
+subroutine init_data_buffer(this)
+ class (fmsDiagField_type) , intent(inout):: this !< The field object
+
+ if (.not. this%multiple_send_data) return
+ if (this%mask_variant) return
+ call this%input_data_buffer%init_input_buffer_object()
+end subroutine init_data_buffer
+
!> @brief Adds the input data to the buffered data.
-subroutine set_data_buffer (this, input_data, weight, is, js, ks, ie, je, ke)
+subroutine set_data_buffer (this, input_data, mask, weight, is, js, ks, ie, je, ke)
class (fmsDiagField_type) , intent(inout):: this !< The field object
class(*), intent(in) :: input_data(:,:,:,:) !< The input array
+ logical, intent(in) :: mask(:,:,:,:) !< Mask that is passed into
+ !! send_data
real(kind=r8_kind), intent(in) :: weight !< The field weight
integer, intent(in) :: is, js, ks !< Starting indicies of the field_data relative
!! to the compute domain (1 based)
@@ -440,7 +475,13 @@ subroutine set_data_buffer (this, input_data, weight, is, js, ks, ie, je, ke)
if (.not.this%data_buffer_is_allocated) &
call mpp_error ("set_data_buffer", "The data buffer for the field "//trim(this%varname)//" was unable to be "//&
"allocated.", FATAL)
- err_msg = this%input_data_buffer%set_input_buffer_object(input_data, weight, is, js, ks, ie, je, ke)
+ if (this%multiple_send_data) then
+ err_msg = this%input_data_buffer%update_input_buffer_object(input_data, is, js, ks, ie, je, ke, &
+ mask, this%mask, this%mask_variant, this%var_is_masked)
+ else
+ this%mask(is:ie, js:je, ks:ke, :) = mask
+ err_msg = this%input_data_buffer%set_input_buffer_object(input_data, weight, is, js, ks, ie, je, ke)
+ endif
if (trim(err_msg) .ne. "") call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg))
end subroutine set_data_buffer
@@ -455,7 +496,7 @@ logical function allocate_data_buffer(this, input_data, diag_axis)
err_msg = ""
allocate(this%input_data_buffer)
- err_msg = this%input_data_buffer%init(input_data, this%axis_ids, diag_axis)
+ err_msg = this%input_data_buffer%allocate_input_buffer_object(input_data, this%axis_ids, diag_axis)
if (trim(err_msg) .ne. "") then
call mpp_error(FATAL, "Field:"//trim(this%varname)//" -"//trim(err_msg))
return
@@ -1028,6 +1069,15 @@ pure function get_var_skind(this, field_yaml) &
end function get_var_skind
+!> @brief Get the multiple_send_data member of the field object
+!! @return multiple_send_data of the field
+pure function get_multiple_send_data(this) &
+result(rslt)
+ class (fmsDiagField_type), intent(in) :: this !< diag field
+ logical :: rslt
+ rslt = this%multiple_send_data
+end function get_multiple_send_data
+
!> @brief Determine the long name to write for the field
!! @return Long name to write
pure function get_longname_to_write(this, field_yaml) &
@@ -1823,5 +1873,30 @@ subroutine generate_associated_files_att(this, att, start_time)
att = trim(att)//" "//trim(field_name)//": "//trim(file_name)//".nc"
end subroutine generate_associated_files_att
+!> @brief Determines if the compute domain has been divide further into slices (i.e openmp blocks)
+!! @return .True. if the compute domain has been divided furter into slices
+function check_for_slices(field, diag_axis, var_size) &
+ result(rslt)
+ type(fmsDiagField_type), intent(in) :: field !< Field object
+ type(fmsDiagAxisContainer_type), target, intent(in) :: diag_axis(:) !< Array of diag axis
+ integer, intent(in) :: var_size(:) !< The size of the buffer pass into send_data
+
+ logical :: rslt
+ integer :: i !< For do loops
+
+ if (.not. field%has_axis_ids()) then
+ rslt = .false.
+ return
+ endif
+ do i = 1, size(field%axis_ids)
+ select type (axis_obj => diag_axis(field%axis_ids(i))%axis)
+ type is (fmsDiagFullAxis_type)
+ if (axis_obj%axis_length() .ne. var_size(i)) then
+ rslt = .true.
+ return
+ endif
+ end select
+ enddo
+end function
#endif
end module fms_diag_field_object_mod
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index e20fb0e540..2ea70dfb8c 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -1399,8 +1399,9 @@ subroutine write_time_data(this)
fms2io_fileobj => diag_file%fms2io_fileobj
!< If data has not been written for the current unlimited dimension
- !! ignore this
- if (.not. diag_file%data_has_been_written) return
+ !! ignore this. The diag_file%unlim_dimension_level .ne. 1 is there to ensure
+ !! that at least one time level is written (this is needed for the combiner)
+ if (.not. diag_file%data_has_been_written .and. diag_file%unlim_dimension_level .ne. 1) return
if (diag_file%time_ops) then
middle_time = (diag_file%last_output+diag_file%next_output)/2
diff --git a/diag_manager/fms_diag_input_buffer.F90 b/diag_manager/fms_diag_input_buffer.F90
index 799278aad0..92952ecadc 100644
--- a/diag_manager/fms_diag_input_buffer.F90
+++ b/diag_manager/fms_diag_input_buffer.F90
@@ -26,23 +26,38 @@ module fms_diag_input_buffer_mod
use platform_mod, only: r8_kind, r4_kind, i4_kind, i8_kind
use fms_diag_axis_object_mod, only: fmsDiagAxisContainer_type, fmsDiagFullAxis_type
use time_manager_mod, only: time_type
+ use mpp_mod, only: mpp_error, FATAL
implicit NONE
private
+ !> @brief Appends the input_data_buffer and the mask (only when the mask is set to .True.)
+ interface append_data_buffer
+ module procedure append_data_buffer_r4, append_data_buffer_r8
+ end interface
+
+ !> @brief Sums the data in the input_data_buffer
+ interface sum_data_buffer
+ module procedure sum_data_buffer_r4, sum_data_buffer_r8
+ end interface
+
!> @brief Type to hold the information needed for the input buffer
!! This is used when set_math_needs_to_be_done = .true. (i.e calling send_data
!! from an openmp region with multiple threads)
type fmsDiagInputBuffer_t
logical :: initialized !< .True. if the input buffer has been initialized
class(*), allocatable :: buffer(:,:,:,:) !< Input data passed in send_data
+ integer, allocatable :: counter(:,:,:,:)!< Number of send_data calls for each point
real(kind=r8_kind) :: weight !< Weight passed in send_data
type(time_type) :: send_data_time !< The time send data was called last
contains
procedure :: get_buffer
procedure :: get_weight
- procedure :: init => init_input_buffer_object
+ procedure :: allocate_input_buffer_object
+ procedure :: init_input_buffer_object
procedure :: set_input_buffer_object
+ procedure :: update_input_buffer_object
+ procedure :: prepare_input_buffer_object
procedure :: set_send_data_time
procedure :: get_send_data_time
procedure :: is_initialized
@@ -75,7 +90,7 @@ end function get_weight
!> @brief Initiliazes an input data buffer
!! @return Error message if something went wrong
- function init_input_buffer_object(this, input_data, axis_ids, diag_axis) &
+ function allocate_input_buffer_object(this, input_data, axis_ids, diag_axis) &
result(err_msg)
class(fmsDiagInputBuffer_t), intent(out) :: this !< input buffer object
class(*), intent(in) :: input_data(:,:,:,:) !< input data
@@ -107,12 +122,16 @@ function init_input_buffer_object(this, input_data, axis_ids, diag_axis) &
select type (input_data)
type is (real(r4_kind))
allocate(real(kind=r4_kind) :: this%buffer(length(1), length(2), length(3), length(4)))
+ this%buffer = 0.0_r4_kind
type is (real(r8_kind))
allocate(real(kind=r8_kind) :: this%buffer(length(1), length(2), length(3), length(4)))
+ this%buffer = 0.0_r8_kind
type is (integer(i4_kind))
allocate(integer(kind=i4_kind) :: this%buffer(length(1), length(2), length(3), length(4)))
+ this%buffer = 0_i4_kind
type is (integer(i8_kind))
allocate(integer(kind=i4_kind) :: this%buffer(length(1), length(2), length(3), length(4)))
+ this%buffer = 0_i8_kind
class default
err_msg = "The data input is not one of the supported types."&
"Only r4, r8, i4, and i8 types are supported."
@@ -120,7 +139,22 @@ function init_input_buffer_object(this, input_data, axis_ids, diag_axis) &
this%weight = 1.0_r8_kind
this%initialized = .true.
- end function init_input_buffer_object
+ allocate(this%counter(length(1), length(2), length(3), length(4)))
+ this%counter = 0
+ end function allocate_input_buffer_object
+
+ !> @brief Initiliazes an input data buffer and the counter
+ subroutine init_input_buffer_object(this)
+ class(fmsDiagInputBuffer_t), intent(inout) :: this !< input buffer object
+
+ select type(buffer=>this%buffer)
+ type is (real(kind=r8_kind))
+ buffer = 0.0_r8_kind
+ type is (real(kind=r4_kind))
+ buffer = 0.0_r4_kind
+ end select
+ this%counter = 0
+ end subroutine init_input_buffer_object
!> @brief Sets the time send data was called last
subroutine set_send_data_time(this, time)
@@ -140,6 +174,110 @@ function get_send_data_time(this) &
rslt = this%send_data_time
end function get_send_data_time
+ !> @brief Updates the input data buffer object for the current send_data call
+ !! @return Error message (if an error occurs)
+ function update_input_buffer_object(this, input_data, is, js, ks, ie, je, ke, mask_in, mask_out, &
+ mask_variant, var_is_masked) &
+ result(err_msg)
+
+ class(fmsDiagInputBuffer_t), intent(inout) :: this !< input buffer object
+ class(*), intent(in) :: input_data(:,:,:,:) !< Field data
+ integer, intent(in) :: is, js, ks !< Starting index for each of the dimension
+ integer, intent(in) :: ie, je, ke !< Ending index for each of the dimensions
+ logical, intent(in) :: mask_in(:,:,:,:)
+ logical, intent(inout) :: mask_out(:,:,:,:)
+ logical, intent(in) :: mask_variant
+ logical, intent(in) :: var_is_masked
+
+ character(len=128) :: err_msg
+
+ if (mask_variant) then
+ err_msg = append_data_buffer_wrapper(mask_out(is:ie,js:je,ks:ke,:), mask_in, &
+ this%buffer(is:ie,js:je,ks:ke,:), input_data)
+ else
+ mask_out(is:ie,js:je,ks:ke,:) = mask_in
+ err_msg = sum_data_buffer_wrapper(mask_in, this%buffer(is:ie,js:je,ks:ke,:), input_data, &
+ this%counter(is:ie,js:je,ks:ke,:), &
+ var_is_masked)
+ endif
+
+ end function update_input_buffer_object
+
+ !> @brief Prepare the input data buffer to do the reduction methods (i.e divide by the number of times
+ !! send data has been called)
+ subroutine prepare_input_buffer_object(this, field_info)
+ class(fmsDiagInputBuffer_t), intent(inout) :: this !< input buffer object
+ character(len=*), intent(in) :: field_info !< Field info to append to error message
+
+ select type (input_data => this%buffer)
+ type is (real(kind=r4_kind))
+ input_data = input_data / this%counter(1,1,1,1)
+ type is (real(kind=r8_kind))
+ input_data = input_data / this%counter(1,1,1,1)
+ class default
+ call mpp_error(FATAL, "prepare_input_buffer_object::"//trim(field_info)//&
+ " has only been implemented for real variables. Contact developers.")
+ end select
+ end subroutine prepare_input_buffer_object
+
+ !> @brief Sums the data in the input_data_buffer
+ !! @return Error message (if an error occurs)
+ function sum_data_buffer_wrapper(mask, data_out, data_in, counter, var_is_masked) &
+ result(err_msg)
+
+ logical, intent(in) :: mask(:,:,:,:) !< Mask passed into send_data
+ class(*), intent(inout) :: data_out(:,:,:,:) !< Data currently saved in the input_data_buffer
+ class(*), intent(in) :: data_in(:,:,:,:) !< Data passed into send_data
+ integer, intent(inout) :: counter(:,:,:,:) !< Number of times data has been summed
+ logical, intent(in) :: var_is_masked !< .True. if the variable is masked
+
+ character(len=128) :: err_msg
+
+ err_msg = ""
+ select type(data_out)
+ type is (real(kind=r8_kind))
+ select type (data_in)
+ type is (real(kind=r8_kind))
+ call sum_data_buffer(mask, data_out, data_in, counter, var_is_masked)
+ end select
+ type is (real(kind=r4_kind))
+ select type (data_in)
+ type is (real(kind=r4_kind))
+ call sum_data_buffer(mask, data_out, data_in, counter, var_is_masked)
+ end select
+ class default
+ err_msg = "sum_data_buffer_wrapper:: has only been implemented for real. Contact developers"
+ end select
+ end function sum_data_buffer_wrapper
+
+ !> @brief Appends the input_data_buffer and the mask (only when the mask is set to .True.)
+ !! @return Error message (if an error occurs)
+ function append_data_buffer_wrapper(mask_out, mask_in, data_out, data_in) &
+ result(err_msg)
+ logical, intent(inout) :: mask_out(:,:,:,:) !< Mask currently in the input_data_buffer
+ logical, intent(in) :: mask_in(:,:,:,:) !< Mask passed in to send_data
+ class(*), intent(inout) :: data_out(:,:,:,:) !< Data currently in the input_data_buffer
+ class(*), intent(in) :: data_in(:,:,:,:) !< Data passed in to send_data
+
+ character(len=128) :: err_msg
+
+ err_msg = ""
+ select type(data_out)
+ type is (real(kind=r8_kind))
+ select type (data_in)
+ type is (real(kind=r8_kind))
+ call append_data_buffer(mask_out, mask_in, data_out, data_in)
+ end select
+ type is (real(kind=r4_kind))
+ select type (data_in)
+ type is (real(kind=r4_kind))
+ call append_data_buffer(mask_out, mask_in, data_out, data_in)
+ end select
+ class default
+ err_msg = "append_data_buffer:: has only been implemented for real. Contact developers"
+ end select
+ end function append_data_buffer_wrapper
+
!> @brief Sets the members of the input buffer object
!! @return Error message if something went wrong
function set_input_buffer_object(this, input_data, weight, is, js, ks, ie, je, ke) &
@@ -209,6 +347,10 @@ pure logical function is_initialized(this)
if (allocated(this%buffer)) is_initialized = .true.
endif
end function is_initialized
+
+#include "fms_diag_input_buffer_r4.fh"
+#include "fms_diag_input_buffer_r8.fh"
+
#endif
end module fms_diag_input_buffer_mod
!> @}
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 363966de91..7c8f279a9a 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -29,7 +29,8 @@ module fms_diag_object_mod
& get_ticks_per_second
#ifdef use_yaml
use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init
-use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init, get_default_missing_value
+use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init, get_default_missing_value, &
+ check_for_slices
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, find_diag_field, &
& get_diag_files_id, diag_yaml, get_diag_field_ids, DiagYamlFilesVar_type
use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, &
@@ -176,7 +177,8 @@ end subroutine fms_diag_object_end
integer function fms_register_diag_field_obj &
(this, modname, varname, axes, init_time, &
longname, units, missing_value, varRange, mask_variant, standname, &
- do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static)
+ do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static, &
+ multiple_send_data)
class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: modname !< The module name
@@ -201,6 +203,9 @@ integer function fms_register_diag_field_obj &
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the
!! modeling_realm attribute
LOGICAL, OPTIONAL, INTENT(in) :: static !< True if the variable is static
+ LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple
+ !! times for the same time
+
#ifdef use_yaml
class (fmsDiagFile_type), pointer :: fileptr !< Pointer to the diag_file
@@ -244,7 +249,7 @@ integer function fms_register_diag_field_obj &
axes=axes, longname=longname, units=units, missing_value=missing_value, varRange= varRange, &
mask_variant= mask_variant, standname=standname, do_not_log=do_not_log, err_msg=err_msg, &
interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
- static=static)
+ static=static, multiple_send_data=multiple_send_data)
!> Add the axis information, initial time, and field IDs to the files
if (present(axes) .and. present(init_time)) then
@@ -313,7 +318,7 @@ end function fms_register_diag_field_obj
!! in the diag_table.yaml
INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, init_time, &
& long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,&
- & area, volume, realm)
+ & area, volume, realm, multiple_send_data)
class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
@@ -328,6 +333,9 @@ INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, in
INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple times
+ !! for the same time
+
#ifndef use_yaml
fms_register_diag_field_scalar=DIAG_FIELD_NOT_FOUND
CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml")
@@ -336,7 +344,7 @@ INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, in
& module_name, field_name, init_time=init_time, &
& longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
- & area=area, volume=volume, realm=realm)
+ & area=area, volume=volume, realm=realm, multiple_send_data=multiple_send_data)
#endif
end function fms_register_diag_field_scalar
@@ -345,7 +353,8 @@ end function fms_register_diag_field_scalar
!! in the diag_table.yaml
INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, axes, init_time, &
& long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,&
- & do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
+ & do_not_log, err_msg, interp_method, tile_count, area, volume, realm, &
+ & multiple_send_data)
class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill
CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
@@ -368,6 +377,9 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax
INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute
+ LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple times
+ !! for the same time
+
#ifndef use_yaml
fms_register_diag_field_array=DIAG_FIELD_NOT_FOUND
@@ -377,7 +389,8 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax
& module_name, field_name, init_time=init_time, &
& axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, &
& mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, &
- & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm)
+ & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, &
+ & multiple_send_data=multiple_send_data)
#endif
end function fms_register_diag_field_array
@@ -606,6 +619,18 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
IF ( PRESENT(je_in) ) je = je_in
IF ( PRESENT(ke_in) ) ke = ke_in
+ if (.not. buffer_the_data .and. using_blocking) then
+ ! If running with only 1 thread and using blocking, check if the data was sent in blocks
+ ! if it is, then buffer the data
+ buffer_the_data = check_for_slices(this%FMS_diag_fields(diag_field_id), this%diag_axis, &
+ shape(field_data))
+ endif
+
+ !< If send data is called multiple times, buffer the data
+ !! This is so that the other reduction methods work and just averaging
+ if (this%FMS_diag_fields(diag_field_id)%get_multiple_send_data()) &
+ buffer_the_data = .true.
+
!If this is true, buffer data
main_if: if (buffer_the_data) then
!> Only 1 thread allocates the output buffer and sets set_math_needs_to_be_done
@@ -637,9 +662,8 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
call this%FMS_diag_fields(diag_field_id)%set_data_buffer_is_allocated(.TRUE.)
call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.)
!$omp end critical
- call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, field_weight, &
+ call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, oor_mask, field_weight, &
is, js, ks, ie, je, ke)
- call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask, field_info, is, js, ks, ie, je, ke)
fms_diag_accept_data = .TRUE.
return
else
@@ -713,6 +737,7 @@ subroutine do_buffer_math(this)
doing_math: if (size(file_ids) .ge. 1 .and. math) then
! Check if buffer alloc'd
has_input_buff: if (diag_field%has_input_data_buffer()) then
+ call diag_field%prepare_data_buffer()
input_data_buffer => diag_field%get_data_buffer()
! reset bounds, allocate output buffer, and update it with reduction
call bounds%reset_bounds_from_array_4D(input_data_buffer)
@@ -720,6 +745,7 @@ subroutine do_buffer_math(this)
error_string = this%fms_diag_do_reduction(input_data_buffer, ifield, &
diag_field%get_mask(), diag_field%get_weight(), &
bounds, .False., Time=diag_field%get_send_data_time())
+ call diag_field%init_data_buffer()
if (trim(error_string) .ne. "") call mpp_error(FATAL, "Field:"//trim(diag_field%get_varname()//&
" -"//trim(error_string)))
else
@@ -891,8 +917,6 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
real(kind=r8_kind) :: missing_value !< Missing_value for data points that are masked
!! This will obtained as r8 and converted to the right type as
!! needed. This is to avoid yet another select type ...
- logical :: new_time !< .True. if this is a new time (i.e data has not be been
- !! sent for this time)
!TODO mostly everything
field_ptr => this%FMS_diag_fields(diag_field_id)
@@ -985,7 +1009,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
!< Determine the reduction method for the buffer
reduction_method = field_yaml_ptr%get_var_reduction()
- if (present(time)) new_time = buffer_ptr%update_buffer_time(time)
+ if (present(time)) call buffer_ptr%update_buffer_time(time)
call buffer_ptr%set_send_data_called()
select case(reduction_method)
case (time_none)
@@ -1008,26 +1032,26 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
endif
case (time_sum)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time)
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value)
if (trim(error_msg) .ne. "") then
return
endif
case (time_average)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time)
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value)
if (trim(error_msg) .ne. "") then
return
endif
case (time_power)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time, &
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, &
pow_value=field_yaml_ptr%get_pow_value())
if (trim(error_msg) .ne. "") then
return
endif
case (time_rms)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time, pow_value = 2)
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, pow_value = 2)
if (trim(error_msg) .ne. "") then
return
endif
@@ -1037,7 +1061,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
! sets the diurnal index for reduction within the buffer object
call buffer_ptr%set_diurnal_section_index(time)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, new_time)
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value)
if (trim(error_msg) .ne. "") then
return
endif
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 1328104f74..1837dae81e 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -372,23 +372,14 @@ subroutine set_next_output(this, time, is_static)
end subroutine set_next_output
!> @brief Update the buffer time if it is a new time
-!! @return .true. if the buffer was updated
-function update_buffer_time(this, time) &
- result(res)
+subroutine update_buffer_time(this, time)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
type(time_type), intent(in) :: time !< Current model time
- logical :: res
-
if (time > this%time) then
this%time = time
- res = .true.
- else
- res = .false.
- !< If this is the first time send_data has been called
- if (.not. this%send_data_called) res = .true.
endif
-end function
+end subroutine update_buffer_time
!> @brief Determine if finished with math
!! @return this%done_with_math
@@ -659,7 +650,7 @@ end function do_time_max_wrapper
!> @brief Does the time_sum reduction method on the buffer object
!! @return Error message if the math was not successful
function do_time_sum_wrapper(this, field_data, mask, is_masked, mask_variant, bounds_in, bounds_out, missing_value, &
- increase_counter, pow_value) &
+ pow_value) &
result(err_msg)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
@@ -669,8 +660,6 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, mask_variant, bo
logical, intent(in) :: is_masked !< .True. if the field has a mask
logical, intent(in) :: mask_variant !< .True. if the mask changes over time
real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
- logical, intent(in) :: increase_counter !< .True. if data has not been received for
- !! time, so the counter needs to be increased
integer, optional, intent(in) :: pow_value !< power value, will calculate field_data^pow
!! before adding to buffer should only be
!! present if using pow reduction method
@@ -683,7 +672,7 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, mask_variant, bo
select type (field_data)
type is (real(kind=r8_kind))
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, mask_variant, &
- bounds_in, bounds_out, missing_value, increase_counter, this%diurnal_section, &
+ bounds_in, bounds_out, missing_value, this%diurnal_section, &
pow=pow_value)
class default
err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r8_kind)"
@@ -692,7 +681,7 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, mask_variant, bo
select type (field_data)
type is (real(kind=r4_kind))
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, mask_variant, &
- bounds_in, bounds_out, real(missing_value, kind=r4_kind), increase_counter, &
+ bounds_in, bounds_out, real(missing_value, kind=r4_kind), &
this%diurnal_section, pow=pow_value)
class default
err_msg="do_time_sum_wrapper::the output buffer and the buffer send in are not of the same type (r4_kind)"
diff --git a/diag_manager/include/fms_diag_input_buffer.inc b/diag_manager/include/fms_diag_input_buffer.inc
new file mode 100644
index 0000000000..7f699fc79d
--- /dev/null
+++ b/diag_manager/include/fms_diag_input_buffer.inc
@@ -0,0 +1,61 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief Appends the input_data_buffer and the mask (only when the mask is set to .True.)
+subroutine APPEND_DATA_BUFFER_(mask_out, mask_in, data_out, data_in)
+ logical, intent(inout) :: mask_out(:,:,:,:) !< Mask currently in the input_data_buffer
+ logical, intent(in) :: mask_in(:,:,:,:) !< Mask passed in to send_data
+ real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:) !< Data currently in the input_data_buffer
+ real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< Data passed in to send_data
+
+ integer :: i, j, k, l !< For looping through the input_data_buffer
+
+ do l = 1, size(data_out, 4)
+ do k = 1, size(data_out, 3)
+ do j = 1, size(data_out, 2)
+ do i = 1, size(data_out, 1)
+ if (mask_in(i,j,k,l)) then
+ mask_out(i,j,k,l) = .True.
+ data_out(i,j,k,l) = data_in(i,j,k,l)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+end subroutine APPEND_DATA_BUFFER_
+
+!> @brief Sums the data in the input_data_buffer
+subroutine SUM_DATA_BUFFER_(mask, data_out, data_in, counter, var_is_masked)
+ logical, intent(in) :: mask(:,:,:,:) !< Mask passed into send_data
+ real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:) !< Data currently saved in the input_data_buffer
+ real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< Data passed into send_data
+ integer, intent(inout) :: counter(:,:,:,:) !< Number of times data has been summed
+ logical, intent(in) :: var_is_masked !< .True. if the variable is masked
+
+ if (var_is_masked) then
+ where (mask)
+ data_out = data_out + data_in
+ endwhere
+ else
+ data_out = data_out + data_in
+ endif
+
+ counter = counter + 1
+end subroutine SUM_DATA_BUFFER_
\ No newline at end of file
diff --git a/diag_manager/include/fms_diag_input_buffer_r4.fh b/diag_manager/include/fms_diag_input_buffer_r4.fh
new file mode 100644
index 0000000000..9799cf9998
--- /dev/null
+++ b/diag_manager/include/fms_diag_input_buffer_r4.fh
@@ -0,0 +1,38 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @file
+!> @brief Imports the input buffer routines from other include files used
+!! in @ref diag_manager_mod
+
+!> @addtogroup diag_manager_mod
+!> @{
+
+#undef FMS_TRM_KIND_
+#define FMS_TRM_KIND_ r4_kind
+
+#undef APPEND_DATA_BUFFER_
+#define APPEND_DATA_BUFFER_ append_data_buffer_r4
+
+#undef SUM_DATA_BUFFER_
+#define SUM_DATA_BUFFER_ sum_data_buffer_r4
+
+#include "fms_diag_input_buffer.inc"
+
+!> @}
+! close documentation grouping
\ No newline at end of file
diff --git a/diag_manager/include/fms_diag_input_buffer_r8.fh b/diag_manager/include/fms_diag_input_buffer_r8.fh
new file mode 100644
index 0000000000..a77dfb15a5
--- /dev/null
+++ b/diag_manager/include/fms_diag_input_buffer_r8.fh
@@ -0,0 +1,38 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @file
+!> @brief Imports the input buffer routines from other include files used
+!! in @ref diag_manager_mod
+
+!> @addtogroup diag_manager_mod
+!> @{
+
+#undef FMS_TRM_KIND_
+#define FMS_TRM_KIND_ r8_kind
+
+#undef APPEND_DATA_BUFFER_
+#define APPEND_DATA_BUFFER_ append_data_buffer_r8
+
+#undef SUM_DATA_BUFFER_
+#define SUM_DATA_BUFFER_ sum_data_buffer_r8
+
+#include "fms_diag_input_buffer.inc"
+
+!> @}
+! close documentation grouping
\ No newline at end of file
diff --git a/diag_manager/include/fms_diag_reduction_methods.inc b/diag_manager/include/fms_diag_reduction_methods.inc
index 870d196da7..2c93d9ebe7 100644
--- a/diag_manager/include/fms_diag_reduction_methods.inc
+++ b/diag_manager/include/fms_diag_reduction_methods.inc
@@ -215,7 +215,7 @@ end subroutine DO_TIME_MAX_
!!
!! Where l are the indices passed in through the bounds_in/out
subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, mask_variant, bounds_in, bounds_out, &
- missing_value, increase_counter, diurnal_section, weight, pow)
+ missing_value, diurnal_section, weight, pow)
real(FMS_TRM_KIND_), intent(inout) :: data_out(:,:,:,:,:) !< output data
real(r8_kind), intent(inout) :: weight_sum(:,:,:,:) !< Sum of weights from the output buffer object
real(FMS_TRM_KIND_), intent(in) :: data_in(:,:,:,:) !< data to update the buffer with
@@ -227,8 +227,6 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, m
type(fmsDiagIbounds_type), intent(in) :: bounds_out !< indices indicating the correct portion
!! of the output buffer
real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked
- logical, intent(in) :: increase_counter !< .True. if data has not been received for
- !! time, so the counter needs to be increased
integer, intent(in) :: diurnal_section !< the diurnal "section" if doing a diurnal reduction
!! indicates which index to add data on 5th axis
!! if not doing a diurnal reduction, this should always =1
@@ -242,25 +240,18 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, m
integer :: is_out, ie_out, js_out, je_out, ks_out, ke_out !< Starting and ending indices of each dimention for
!! the output buffer
integer :: i, j, k, l !< For looping
- real(FMS_TRM_KIND_) :: counter_local !< counter to increase the counter by
real(FMS_TRM_KIND_) :: weight_scale !< local copy of optional weight
integer :: pow_loc !> local copy of optional pow value (set if using pow reduction)
integer, parameter :: kindl = FMS_TRM_KIND_ !< real kind size as set by macro
integer :: diurnal !< diurnal index to indicate which daily section is updated
!! will be 1 unless using a diurnal reduction
- ! The counter and the weight are stored in different variables to avoid having
- ! to do a if (increase_counter) inside a do loop
if(present(weight)) then
- counter_local = weight
weight_scale = weight
else
- counter_local = 1.0_kindl
weight_scale = 1.0_kindl
endif
- if (.not. increase_counter) counter_local = 0.0_kindl
-
if(present(pow)) then
pow_loc = pow
else
@@ -302,13 +293,13 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, m
+ (data_in(is_in +i, js_in + j, ks_in + k, :) * weight_scale) ** pow_loc
!Increase the weight sum for the grid point that was not masked
weight_sum(is_out + i, js_out + j, ks_out + k, :) = &
- weight_sum(is_out + i, js_out + j, ks_out + k, :) + counter_local
+ weight_sum(is_out + i, js_out + j, ks_out + k, :) + weight_scale
endwhere
enddo
enddo
enddo
else
- weight_sum = weight_sum + counter_local
+ weight_sum = weight_sum + weight_scale
do k = 0, ke_out - ks_out
do j = 0, je_out - js_out
do i = 0, ie_out - is_out
@@ -324,7 +315,7 @@ subroutine DO_TIME_SUM_UPDATE_(data_out, weight_sum, data_in, mask, is_masked, m
enddo
endif
else
- weight_sum = weight_sum + counter_local
+ weight_sum = weight_sum + weight_scale
! doesn't need to loop through l if no mask, just sums the 1d slices
do k = 0, ke_out - ks_out
do j = 0, je_out - js_out
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index fec4b82e1b..4eb3841f7f 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -33,7 +33,7 @@ check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
check_time_min check_time_max check_time_sum check_time_avg test_diag_diurnal check_time_diurnal \
check_time_pow check_time_rms check_subregional test_cell_measures test_var_masks \
- check_var_masks
+ check_var_masks test_multiple_send_data
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -58,6 +58,7 @@ test_cell_measures_SOURCES = test_cell_measures.F90
check_subregional_SOURCES = check_subregional.F90
test_var_masks_SOURCES = test_var_masks.F90
check_var_masks_SOURCES = check_var_masks.F90
+test_multiple_send_data_SOURCES = test_multiple_send_data.F90
TEST_EXTENSIONS = .sh
SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
@@ -66,14 +67,14 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \
# Run the test.
TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh \
test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh test_cell_measures.sh \
- test_subregional.sh test_var_masks.sh
+ test_subregional.sh test_var_masks.sh test_multiple_send_data.sh
testing_utils.mod: testing_utils.$(OBJEXT)
# Copy over other needed files to the srcdir
EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \
test_time_sum.sh test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh \
- test_cell_measures.sh test_subregional.sh test_var_masks.sh
+ test_cell_measures.sh test_subregional.sh test_var_masks.sh test_multiple_send_data.sh
if USING_YAML
skipflag=""
diff --git a/test_fms/diag_manager/test_multiple_send_data.F90 b/test_fms/diag_manager/test_multiple_send_data.F90
new file mode 100644
index 0000000000..d8df31b42f
--- /dev/null
+++ b/test_fms/diag_manager/test_multiple_send_data.F90
@@ -0,0 +1,144 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+
+!> @brief This programs tests fields that call send_data multiple times
+program test_multiple_send_data
+ use fms_mod, only: fms_init, fms_end
+ use diag_manager_mod
+ use mpp_mod
+ use mpp_domains_mod
+ use platform_mod, only: r8_kind, r4_kind
+ use time_manager_mod, only: time_type, set_calendar_type, set_date, JULIAN, set_time, OPERATOR(+)
+ use fms2_io_mod
+ use fms_diag_yaml_mod
+
+ implicit none
+
+ type(time_type) :: Time !< Time of the simulation
+ type(time_type) :: Time_step !< Time_step of the simulation
+ integer :: nx !< Number of x points
+ integer :: ny !< Number of y points
+ integer :: nz !< Number of z points
+ integer :: id_x !< Axis id for the x dimension
+ integer :: id_y !< Axis id for the y dimension
+ integer :: id_var1 !< Field id for 1st variable
+ integer :: id_var2 !< Field id for 2nd variable
+ logical :: used !< Dummy argument to send_data
+ real, allocatable :: x(:) !< X axis data
+ real, allocatable :: y(:) !< Y axis_data
+ real, allocatable :: var1_data(:,:) !< Data for variable 1
+ logical, allocatable :: var1_mask(:,:) !< Mask for variable 1
+ integer :: i !< For do loops
+
+ call fms_init
+ call set_calendar_type(JULIAN)
+ call diag_manager_init
+
+ nx = 360
+ ny = 180
+
+ allocate(x(nx), y(ny))
+ allocate(var1_data(nx,ny), var1_mask(nx,ny))
+ do i=1,nx
+ x(i) = i
+ enddo
+ do i=1,ny
+ y(i) = -91 + i
+ enddo
+
+ Time = set_date(2,1,1,0,0,0)
+ Time_step = set_time (3600,0) !< 1 hour
+
+ id_x = diag_axis_init('x', x, 'point_E', 'x', long_name='point_E')
+ id_y = diag_axis_init('y', y, 'point_N', 'y', long_name='point_N')
+
+ ! id_var1 is using diag manager similarly to how the `rv_ice` and `rv_T` in the river code
+ id_var1 = register_diag_field ('atmos', 'ua', (/id_x, id_y/), Time, missing_value=-999., mask_variant=.True., &
+ multiple_send_data=.True.)
+
+ ! id_var2 is using diag manager similarly to way it is used in the vert_diff module code
+ id_var2 = register_diag_field ('atmos', 'va', (/id_x, id_y/), Time, missing_value=-999., &
+ multiple_send_data=.True.)
+
+ call diag_manager_set_time_end(set_date(2,1,2,0,0,0))
+ do i = 1, 24
+ Time = Time + Time_step
+
+ var1_data = real(i)
+
+ var1_mask = .False.
+ ! Only count the data for the (:,1) section of the grid on this send_data call
+ var1_mask(:,1) = .True.
+ used = send_data(id_var1, var1_data, Time, mask=var1_mask)
+
+ var1_mask = .False.
+ ! Only count the data for the (:,2:) section of the grid on this send_data call
+ var1_mask(:,2:) = .True.
+ used = send_data(id_var1, var1_data, Time, mask=var1_mask)
+
+ used = send_data(id_var2, var1_data, Time)
+ used = send_data(id_var2, var1_data, Time)
+ call diag_send_complete(Time_step)
+ enddo
+
+ call diag_manager_end(Time)
+ call check_answers()
+ call fms_end
+
+ contains
+ subroutine check_answers()
+ type(FmsNetcdfFile_t) :: fileobj
+ integer :: ntimes
+ integer :: nx
+ integer :: ny
+ real, allocatable :: vardata(:,:)
+ real :: ans_var
+ integer :: i, j
+
+ if (.not. open_file(fileobj, "test_multiple_sends.nc", "read")) &
+ call mpp_error(FATAL, "unable to open test_var_masks.nc for reading")
+
+ call get_dimension_size(fileobj, "time", ntimes)
+ if (ntimes .ne. 1) call mpp_error(FATAL, "time is not the correct size!")
+
+ call get_dimension_size(fileobj, "x", nx)
+ if (nx .ne. 360) call mpp_error(FATAL, "x is not the correct size!")
+
+ call get_dimension_size(fileobj, "y", ny)
+ if (ny .ne. 180) call mpp_error(FATAL, "y is not the correct size!")
+
+ allocate(vardata(nx,ny))
+
+ ans_var = 0.
+ do i = 1, 24
+ ans_var = ans_var + real(i)
+ enddo
+ ans_var = ans_var / 24
+
+ call read_data(fileobj, "ua", vardata)
+ if (any(vardata .ne. ans_var)) &
+ call mpp_error(FATAL, "ua is not the expected result")
+
+ call read_data(fileobj, "va", vardata)
+ if (any(vardata .ne. ans_var)) &
+ call mpp_error(FATAL, "va is not the expected result")
+
+ call close_file(fileobj)
+ end subroutine check_answers
+end program test_multiple_send_data
\ No newline at end of file
diff --git a/test_fms/diag_manager/test_multiple_send_data.sh b/test_fms/diag_manager/test_multiple_send_data.sh
new file mode 100755
index 0000000000..1240e1d414
--- /dev/null
+++ b/test_fms/diag_manager/test_multiple_send_data.sh
@@ -0,0 +1,57 @@
+#!/bin/sh
+
+#***********************************************************************
+#* 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 .
+#***********************************************************************
+
+# Set common test settings.
+. ../test-lib.sh
+
+if [ -z "${skipflag}" ]; then
+# create and enter directory for in/output files
+output_dir
+
+cat <<_EOF > diag_table.yaml
+title: test_multiple_sends
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_multiple_sends
+ time_units: hours
+ unlimdim: time
+ freq: 1 days
+ varlist:
+ - module: atmos
+ var_name: ua
+ reduction: average
+ kind: r4
+ - module: atmos
+ var_name: va
+ reduction: average
+ kind: r4
+_EOF
+
+# remove any existing files that would result in false passes during checks
+rm -f *.nc
+
+my_test_count=1
+printf "&diag_manager_nml \n use_modern_diag=.true. \n/" | cat > input.nml
+test_expect_success "Running diag_manager with fields that call send_data multiple times for the same time (test $my_test_count)" '
+ mpirun -n 1 ../test_multiple_send_data
+'
+fi
+test_done
From 0d0c8acfc75a26491f6eebac955749a6f9ea1077 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Mon, 18 Mar 2024 15:17:06 -0400
Subject: [PATCH 156/168] fix: diag_manager hack for when starting with 2/29
and outputting yearly data (#1479)
---
diag_manager/fms_diag_time_utils.F90 | 17 +++++++++++++++++
1 file changed, 17 insertions(+)
diff --git a/diag_manager/fms_diag_time_utils.F90 b/diag_manager/fms_diag_time_utils.F90
index efcf4690f9..9bc306b562 100644
--- a/diag_manager/fms_diag_time_utils.F90
+++ b/diag_manager/fms_diag_time_utils.F90
@@ -132,6 +132,13 @@ TYPE(time_type) FUNCTION diag_forecast_time_inc(time, output_freq, output_units,
CHARACTER(len=128) :: error_message_local !< Local variable to store the error_message
+ integer :: cyear !< The current year stored in the time type
+ integer :: cmonth !< The current month stored in the time type
+ integer :: cday !< The current day stored in the time type
+ integer :: chour !< The current hour stored in the time type
+ integer :: cmin !< The current minute stored in the time type
+ integer :: csecond !< The current second stored in the time type
+
IF ( PRESENT(err_msg) ) err_msg = ''
error_message_local = ''
@@ -180,7 +187,17 @@ TYPE(time_type) FUNCTION diag_forecast_time_inc(time, output_freq, output_units,
IF ( get_calendar_type() == NO_CALENDAR ) THEN
error_message_local = 'output units of years NOT allowed with no calendar'
ELSE
+ call get_date(Time, cyear, cmonth, cday, chour, cmin, csecond)
+ if (cmonth .eq. 2 .and. cday .eq. 29) then
+ !! TODO this is a hack, the leap year issue should be fixed inside increment_date instead
+ !! increment_date should also be updated to work in cases like when the frequency is 1 month and you
+ !! are starting from 1/31
+ ! This is a leap year, so increment the date from 2/28 instead
+ diag_forecast_time_inc = increment_date(set_date(cyear, cmonth, 28, chour, cmin, csecond), &
+ output_freq, 0, 0, 0, 0, 0, err_msg=error_message_local)
+ else
diag_forecast_time_inc = increment_date(time, output_freq, 0, 0, 0, 0, 0, err_msg=error_message_local)
+ endif
END IF
ELSE
error_message_local = 'illegal output units'
From a13eb33186230acf905c28e6538a5732b1925139 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 19 Mar 2024 16:27:40 -0400
Subject: [PATCH 157/168] Fix: Modern diag manager. Catch missing_values
without masks (#1481)
---
diag_manager/fms_diag_object.F90 | 13 ++++++------
diag_manager/fms_diag_output_buffer.F90 | 14 +++++++++++--
.../diag_manager/test_reduction_methods.F90 | 8 ++++++++
test_fms/diag_manager/test_time_avg.sh | 20 +++++++++++++++++++
4 files changed, 47 insertions(+), 8 deletions(-)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 7c8f279a9a..12c33e082a 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -888,7 +888,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
!! in blocks
type(time_type), intent(in), optional :: time !< Current time
- character(len=50) :: error_msg !< Error message to check
+ character(len=150) :: error_msg !< Error message to check
!TODO Mostly everything
#ifdef use_yaml
type(fmsDiagField_type), pointer :: field_ptr !< Pointer to the field's object
@@ -1032,26 +1032,27 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
endif
case (time_sum)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value)
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, field_ptr%has_missing_value())
if (trim(error_msg) .ne. "") then
return
endif
case (time_average)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value)
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, field_ptr%has_missing_value())
if (trim(error_msg) .ne. "") then
return
endif
case (time_power)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, &
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, field_ptr%has_missing_value(), &
pow_value=field_yaml_ptr%get_pow_value())
if (trim(error_msg) .ne. "") then
return
endif
case (time_rms)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, pow_value = 2)
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, field_ptr%has_missing_value(), &
+ pow_value = 2)
if (trim(error_msg) .ne. "") then
return
endif
@@ -1061,7 +1062,7 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
! sets the diurnal index for reduction within the buffer object
call buffer_ptr%set_diurnal_section_index(time)
error_msg = buffer_ptr%do_time_sum_wrapper(field_data, oor_mask, field_ptr%get_var_is_masked(), &
- field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value)
+ field_ptr%get_mask_variant(), bounds_in, bounds_out, missing_value, field_ptr%has_missing_value())
if (trim(error_msg) .ne. "") then
return
endif
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 1837dae81e..7c8b5a4ae0 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -650,7 +650,7 @@ end function do_time_max_wrapper
!> @brief Does the time_sum reduction method on the buffer object
!! @return Error message if the math was not successful
function do_time_sum_wrapper(this, field_data, mask, is_masked, mask_variant, bounds_in, bounds_out, missing_value, &
- pow_value) &
+ has_missing_value, pow_value) &
result(err_msg)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
class(*), intent(in) :: field_data(:,:,:,:) !< Buffer data for current time
@@ -660,10 +660,12 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, mask_variant, bo
logical, intent(in) :: is_masked !< .True. if the field has a mask
logical, intent(in) :: mask_variant !< .True. if the mask changes over time
real(kind=r8_kind), intent(in) :: missing_value !< Missing_value for data points that are masked
+ logical, intent(in) :: has_missing_value !< .True. if the field was registered with
+ !! a missing value
integer, optional, intent(in) :: pow_value !< power value, will calculate field_data^pow
!! before adding to buffer should only be
!! present if using pow reduction method
- character(len=50) :: err_msg
+ character(len=150) :: err_msg
!TODO This will be expanded for integers
err_msg = ""
@@ -671,6 +673,10 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, mask_variant, bo
type is (real(kind=r8_kind))
select type (field_data)
type is (real(kind=r8_kind))
+ if (.not. is_masked) then
+ if (any(field_data .eq. missing_value)) &
+ err_msg = "You cannot pass data with missing values without masking them!"
+ endif
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, mask_variant, &
bounds_in, bounds_out, missing_value, this%diurnal_section, &
pow=pow_value)
@@ -680,6 +686,10 @@ function do_time_sum_wrapper(this, field_data, mask, is_masked, mask_variant, bo
type is (real(kind=r4_kind))
select type (field_data)
type is (real(kind=r4_kind))
+ if (.not. is_masked) then
+ if (any(field_data .eq. missing_value)) &
+ err_msg = "You cannot pass data with missing values without masking them!"
+ endif
call do_time_sum_update(output_buffer, this%weight_sum, field_data, mask, is_masked, mask_variant, &
bounds_in, bounds_out, real(missing_value, kind=r4_kind), &
this%diurnal_section, pow=pow_value)
diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90
index 8327121ae5..0b09fc69ca 100644
--- a/test_fms/diag_manager/test_reduction_methods.F90
+++ b/test_fms/diag_manager/test_reduction_methods.F90
@@ -64,6 +64,8 @@ program test_reduction_methods
integer :: id_var0 !< diag_field id for 0d var
integer :: id_var1 !< diag_field id for 1d var
integer :: id_var2 !< diag_field id for 2d var
+ integer :: id_var2missing !< diag_field id for a var that is not masked but has missing
+ !! values passed into send_data
integer :: id_var2c !< diag_field id for 2d var_corner
integer :: id_var3 !< diag_field id for 3d var
integer :: id_var4 !< diag_field id for 4d var
@@ -177,6 +179,8 @@ program test_reduction_methods
'mullions', missing_value = missing_value)
id_var2 = register_diag_field ('ocn_mod', 'var2', (/id_x, id_y/), Time, 'Var2d', &
'mullions', missing_value = missing_value)
+ id_var2missing = register_diag_field ('ocn_mod', 'var2missing', (/id_x, id_y/), Time, 'Var2d', &
+ 'mullions', missing_value = missing_value)
id_var2c = register_diag_field ('ocn_mod', 'var2c', (/id_xc, id_yc/), Time, 'Var2d corner', &
'mullions', missing_value = missing_value)
id_var3 = register_diag_field ('ocn_mod', 'var3', (/id_x, id_y, id_z/), Time, 'Var3d', &
@@ -198,6 +202,10 @@ program test_reduction_methods
call set_buffer(cdata, i)
call set_buffer(cdata_corner, i)
+ ! This is passing in the data with missing values, but the variable is not masked.
+ ! An error is expected in this case.
+ used = send_data(id_var2missing, cdata(:,:,1,1)*0_r8_kind + missing_value, Time)
+
used = send_data(id_var2c, cdata_corner(:,:,1,1), Time)
used = send_data(id_var0, cdata(1,1,1,1), Time)
diff --git a/test_fms/diag_manager/test_time_avg.sh b/test_fms/diag_manager/test_time_avg.sh
index 3e80fcdc27..d40abf637b 100755
--- a/test_fms/diag_manager/test_time_avg.sh
+++ b/test_fms/diag_manager/test_time_avg.sh
@@ -191,5 +191,25 @@ test_expect_success "Running diag_manager with "avg" reduction method with halo
test_expect_success "Checking answers for the "avg" reduction method with halo output with real mask (test $my_test_count)" '
mpirun -n 1 ../check_time_avg
'
+
+cat <<_EOF > diag_table.yaml
+title: test_avg
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_failure
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: var2missing
+ reduction: average
+ kind: r4
+_EOF
+
+ my_test_count=`expr $my_test_count + 1`
+ test_expect_failure "Fail if passing in missing_values without masking them (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+ '
fi
test_done
From b1186aac3f2f1cca8db8328fb632e03c650a8758 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Tue, 19 Mar 2024 16:32:50 -0400
Subject: [PATCH 158/168] Fix: dmUpdate nvhpc compile error (#1473)
---
diag_manager/diag_data.F90 | 5 ++++-
exchange/xgrid.F90 | 27 ++++++++++++++++++++++-----
2 files changed, 26 insertions(+), 6 deletions(-)
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index c5a7539e37..7c0829e4ca 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -586,7 +586,10 @@ subroutine fms_add_attribute(this, att_name, att_value)
this%att_value = att_value
type is (character(len=*))
allocate(character(len=len(att_value)) :: this%att_value(natt))
- this%att_value = att_value
+ select type(aval => this%att_value)
+ type is (character(len=*))
+ aval = att_value
+ end select
end select
end subroutine fms_add_attribute
diff --git a/exchange/xgrid.F90 b/exchange/xgrid.F90
index 4194ef274c..88cfdbbbab 100644
--- a/exchange/xgrid.F90
+++ b/exchange/xgrid.F90
@@ -1514,7 +1514,7 @@ end subroutine get_ocean_model_area_elements
!> @brief Sets up exchange grid connectivity using grid specification file and
!! processor domain decomposition.
subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_domain)
- type (xmap_type), intent(inout) :: xmap
+ type(xmap_type), intent(inout) :: xmap
character(len=3), dimension(:), intent(in ) :: grid_ids
type(Domain2d), dimension(:), intent(in ) :: grid_domains
character(len=*), intent(in ) :: grid_file
@@ -1524,7 +1524,8 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_
integer :: g, p, i
integer :: nxgrid_file, i1, i2, i3, tile1, tile2, j
integer :: nxc, nyc, out_unit
- type (grid_type), pointer, save :: grid =>NULL(), grid1 =>NULL()
+ type(grid_type), pointer :: grid => NULL()!< pointer to loop through grid_type's in list
+ type(grid_type), pointer, save :: grid1 => NULL() !< saved pointer to the first grid in the list
real(r8_kind), dimension(3) :: xxx
real(r8_kind), dimension(:,:), allocatable :: check_data
real(r8_kind), dimension(:,:,:), allocatable :: check_data_3D
@@ -1541,6 +1542,8 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_
integer :: lnd_ug_id, l
integer, allocatable :: grid_index(:)
type(FmsNetcdfFile_t) :: gridfileobj, mosaicfileobj, fileobj
+ type(grid_type), allocatable, target :: grids_tmp(:) !< added for nvhpc workaround, stores xmap's
+ !! grid_type array so we can safely point to it
call mpp_clock_begin(id_setup_xmap)
@@ -1593,9 +1596,17 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_
endif
call mpp_clock_begin(id_load_xgrid)
- do g=1,size(grid_ids(:))
- grid => xmap%grids(g)
- if (g==1) grid1 => xmap%grids(g)
+
+ ! nvhpc compiler workaround
+ ! saves grid array as an allocatable and points to that to avoid error from pointing to xmap%grids in loop
+ grids_tmp = xmap%grids
+
+ grid1 => xmap%grids(1)
+
+ do g=1, size(grid_ids(:))
+
+ grid => grids_tmp(g)
+
grid%id = grid_ids (g)
grid%domain = grid_domains(g)
grid%on_this_pe = mpp_domain_is_initialized(grid_domains(g))
@@ -1855,6 +1866,9 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_
grid%frac_area = 1.0_r8_kind
endif
+ ! nvhpc workaround, needs to save the grid pointer since its allocatable
+ xmap%grids(g) = grid
+
! load exchange cells, sum grid cell areas, set your1my2/your2my1
select case(xmap%version)
case(VERSION1)
@@ -1960,6 +1974,9 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_
where (grid%area>0.0_r8_kind) grid%area_inv = 1.0_r8_kind/grid%area
endif
end if
+
+ ! nvhpc workaround, needs to save the grid pointer since its allocatable
+ xmap%grids(g) = grid
end do
if(xmap%version == VERSION2) call close_file(gridfileobj)
From fab32042832b81c6e32aa2bdb61acc1c484f7b66 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Thu, 28 Mar 2024 09:24:58 -0400
Subject: [PATCH 159/168] docs: update diag manager readme and add markdown
for yaml format (#1483)
---
diag_manager/README.md | 375 ++++++-------------------------
diag_manager/diag_yaml_format.md | 342 ++++++++++++++++++++++++++++
2 files changed, 415 insertions(+), 302 deletions(-)
create mode 100644 diag_manager/diag_yaml_format.md
diff --git a/diag_manager/README.md b/diag_manager/README.md
index 53abdab392..60ab87bbd5 100644
--- a/diag_manager/README.md
+++ b/diag_manager/README.md
@@ -1,342 +1,113 @@
-## Diag Table Yaml Format:
-
-The purpose of this document is to explain the diag_table yaml format.
+The purpose of this document is to document the differences between the old diag manager and the new (modern) diag manager.
## Contents
-- [1. Converting from legacy ascii diag_table format](README.md#1-converting-from-legacy-ascii-diag_table-format)
-- [2. Diag table yaml sections](README.md#2-diag-table-yaml-sections)
-- [2.1 Global Section](README.md#21-global-section)
-- [2.2 File Section](README.md#22-file-section)
-- [2.2.1 Flexible output timings](README.md#221-flexible-output-timings)
-- [2.2.2 Coupled Model Diag Files](README.md#222-coupled-model-diag-files)
-- [2.3 Variable Section](README.md#23-variable-section)
-- [2.4 Variable Metadata Section](README.md#24-variable-metadata-section)
-- [2.5 Global Meta Data Section](README.md#25-global-meta-data-section)
-- [2.6 Sub_region Section](README.md#26-sub_region-section)
-- [3. More examples](README.md#3-more-examples)
-
-### 1. Converting from legacy ascii diag_table format
-
-To convert the legacy ascii diad_table format to this yaml format, the python script [**diag_table_to_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/diag_table_to_yaml.py#L23-L26) can be used. To confirm that your diag_table.yaml was created correctly, the python script [**is_valid_diag_table_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/is_valid_diag_table_yaml.py#L24-L27) can be used.
-
-### 2. Diag table yaml sections
-The diag_table.yaml is organized by file. Each file has the required and optional key/value pairs for the file, an optional subsection defining any additional global metadata to add to the file, an optional subsection defining a subregion of the grid to output the data for and a required subsection for all of the variables in the file. Each variable has the required and optional key/value pairs for the variable and an optional subsection defining any additional variable attributes to add to the file. The hierarchical structure looks like this:
-
-```yaml
-title:
-base_date:
-diag_files:
-- file1
- - #key/value pairs for file1
- varlist:
- - var1
- - #key/value pairs for var1
- attributes:
- - #atributes for var1
- global_metadata:
- - #global attributes for file1
- subregion:
- - #subregion for file1
-```
-
-### 2.1 Global Section
-The diag_yaml requires “title” and the “baseDate”.
-- The **title** is a string that labels the diag yaml. The equivalent in the legacy diag_table would be the experiment. It is recommended that each diag_yaml have a separate title label that is descriptive of the experiment that is using it.
-- The **basedate** is an array of 6 integers indicating the base_date in the format [year month day hour minute second].
+- [1. Diag Table Format](README.md#1-diag-table-format)
+- [2. Scalar Axis](README.md#2-scalar-axis)
+- [3. Average Time Variables](README.md#3-average-time-variables)
+- [4. Subregional Files](README.md#4-subregional-files)
+- [5. Global attributes](README.md#5-global-attributes)
+- [6. Real attributes from diag_field_add_attribute calls](README.md#6-real-attributes-from-diag_field_add_attribute-calls)
+- [7. History files data output "changes"](README.md#7-history-files-data-output-changes)
-**Example:**
+### 1. Diag Table Format
+The modern diag manager uses a YAML format instead of the legacy ascii table. A description of the YAML diag table can be found [here](diag_yaml_format.md).
-In the YAML format:
-```yaml
-title: ESM4_piControl
-base_date: 2022 5 26 12 3 1
-```
+### 2. Scalar Axis
+The old diag manager was adding a `scalar_axis` dimension of size 1 for scalar variables
-In the legacy ascii format:
```
-ESM4_piControl
-2022 5 26 12 3 1
+dimensions:
+ scalar_axis = 1 ;
+variables:
+ double p700(scalar_axis) ;
+ p700:_FillValue = 1.e+20 ;
+ p700:missing_value = 1.e+20 ;
```
+The new diag manager will no longer have a dummy scalar axis dimension.
-### 2.2 File Section
-The files are listed under the diagFiles section as a dashed array.
-
-Below are the **required** keys needed to define each file.
-- **file_name** is a string that defines the name of the file. Do not add ".nc" and "tileX" to the filename as this will be handled by FMS.
-- **freq** defines the frequency and the units that data will be written
- - The acceptable values for freq are:
- - =-1: output at the end of the run only
- - =0: output every timestep
- - \>0 units: output frequency and units (with a space between the frequency number and units e.g 24 hours)
- - Values of -1 or 0 do not require units.
- - The acceptable values for units are seconds, minutes, hours, days, months, years.
-- **time_units** is a string that defines units for time. The acceptable values are seconds, minutes, hours, days, months, years.
-- **unlimdim** is a string that defines the name of the unlimited dimension in the output netcdf file, usually “time”.
-- **varlist** is a subsection that list all of the variable in the file
-
-**Example:** The following creates a file with data written every 6 hours.
+### 3. Average Time Variables
+The old diag manager includes time bounds metadata in a non-standard convention (i.e. `average_T1`, `average_T2`, and `average_DT`)
+1. `average_T1` is the start time for the averaging period (in the same time units as time)
+2. `average_T2` is the end time for the averaging period
+3. `average_DT` is the length of the averaging period, in days
-In the YAML format:
-```yaml
-diag_files:
-- file_name: atmos_6hours
- freq: 6 hours
- time_units: hours
- unlimdim: time
- varlist:
- - varinfo
```
-
-In the legacy ascii format:
+ double average_T1(time) ;
+ average_T1:_FillValue = 1.e+20 ;
+ average_T1:missing_value = 1.e+20 ;
+ average_T1:units = "days since 1979-01-01 00:00:00" ;
+ average_T1:long_name = "Start time for average period" ;
+ double average_T2(time) ;
+ average_T2:_FillValue = 1.e+20 ;
+ average_T2:missing_value = 1.e+20 ;
+ average_T2:units = "days since 1979-01-01 00:00:00" ;
+ average_T2:long_name = "End time for average period" ;
+ double average_DT(time) ;
+ average_DT:_FillValue = 1.e+20 ;
+ average_DT:missing_value = 1.e+20 ;
+ average_DT:units = "days" ;
+ average_DT:long_name = "Length of average period" ;
```
-"atmos_6hours", 6, "hours", 1, "hours", "time"
+These 3 variables are referenced as a variable attribute in each diagnostic. e.g.
```
-
-**NOTE:** The fourth column (file_format) has been deprecated. Netcdf files will always be written.
-
-Below are some *optional* keys that may be added.
-- **write_file** is a logical that indicates if you want the file to be created (default is true). This is a new feature that is not supported by the legacy ascii data_table.
-- **new_file_freq** is a string that defines the frequency and the frequency units (with a space between the frequency number and units) for closing the existing file
-- **start_time** is an array of 6 integer indicating when to start the file for the first time. It is in the format [year month day hour minute second]. Requires “new_file_freq”
-- **filename_time** is the time used to set the name of new files when using new_file_freq. The acceptable values are begin (which will use the begining of the file's time bounds), middle (which will use the middle of the file's time bounds), and end (which will use the end of the file's time bounds). The default is middle
-
-**Example:** The following will create a new file every 6 hours starting at Jan 1 2020. Variable data will be written to the file every 6 hours.
-
-In the YAML format:
-```yaml
-- file_name: ocn%4yr%2mo%2dy%2hr
- freq: 6 hours
- freq_units: hours
- unlimdim: time
- new_file_freq: 6 hours
- start_time: 2020 1 1 0 0 0
+ dis_liq:time_avg_info = "average_T1,average_T2,average_DT" ;
```
-In the legacy ascii format:
-```
-"ocn%4yr%2mo%2dy%2hr", 6, "hours", 1, "hours", "time", 6, "hours", "1901 1 1 0 0 0"
-```
+The new diag manager will not be using these non standard variables. Instead the time bounds information will be specified in CF standards. One time_bounds variable, with an extra nv dimension, that species both average_T1 and average_T2. The average_DT information can be obtained from the time_bnds variable.
-Because this is using the default `filename_time` (middle), this example will create the files:
```
-ocn_2020_01_01_03.nc for time_bnds [0,6]
-ocn_2020_01_01_09.nc for time_bnds [6,12]
-ocn_2020_01_01_15.nc for time_bnds [12,18]
-ocn_2020_01_01_21.nc for time_bnds [18,24]
+ double nv(nv) ;
+ nv:long_name = "vertex number" ;
+ double time_bnds(time, nv) ;
+ time_bnds:units = "days since 1979-01-01 00:00:00" ;
+ time_bnds:long_name = "time axis boundaries" ;
```
-
-**NOTE** If using the new_file_freq, there must be a way to distinguish each file, as it was done in the example above.
-
-- **file_duration** is a string that defines how long the file should receive data after start time in “file_duration_units”. This optional field can only be used if the start_time field is present. If this field is absent, then the file duration will be equal to the frequency for creating new files.
-- **global_meta** is a subsection that lists any additional global metadata to add to the file. This is a new feature that is not supported by the legacy ascii data_table.
-- **sub_region** is a subsection that defines the four corners of a subregional section to capture.
-
-### 2.2.1 Flexible output timings
-
-In order to provide more flexibility in output timings, the diag_table yaml format allows for different file frequencies for the same file by allowing the `freq`, `new_file_freq`, and `file_duration` keys to accept a comma seperated list.
-
-For example,
-``` yaml
-- file_name: flexible_timing%4yr%2mo%2dy%2hr
- freq: 1 hours, 1 hours, 1 hours
- time_units: hours
- unlimdim: time
- new_file_freq: 6 hours, 3 hours, 1 hours
- start_time: 2 1 1 0 0 0
- file_duration: 12 hours, 3 hours, 9 hours
- filename_time: begin
- varlist:
- - module: ocn_mod
- var_name: var1
- reduction: average
- kind: r4
-```
-This will create a file every 6 hours for 12 hours
-```
-flexible_timing_0002_01_01_00.nc - using hourly averaged data from hour 0 to hour 6
-flexible_timing_0002_01_01_06.nc - using hourly averaged data from hour 6 to hour 12
-```
-
-Then it will create a file every 3 hours for 3 hours
+This time_bounds variable is refernced as a variable attribute of time:
```
-flexible_timing_0002_01_01_12.nc - using hourly averaged data from hour 12 to hour 15
+ time:bounds = "time_bnds" ;
```
-Then it will create a file every 1 hour for 9 hours.
-```
-flexible_timing_0002_01_01_15.nc - using data from hour 15 to hour 16
-flexible_timing_0002_01_01_16.nc - using data from hour 16 to hour 17
-flexible_timing_0002_01_01_17.nc - using data from hour 17 to hour 18
-flexible_timing_0002_01_01_18.nc - using data from hour 18 to hour 19
-flexible_timing_0002_01_01_19.nc - using data from hour 19 to hour 20
-flexible_timing_0002_01_01_20.nc - using data from hour 20 to hour 21
-flexible_timing_0002_01_01_21.nc - using data from hour 21 to hour 22
-flexible_timing_0002_01_01_22.nc - using data from hour 22 to hour 23
-flexible_timing_0002_01_01_23.nc - using data from hour 23 to hour 24
+### 4. Subregional Files
-```
+#### A. `is_subregional` global attribute:
+Subregional files will have a global NetCDF attribute `is_subregional = True` set for non-global history files. This attribute will be used in PP tools.
-### 2.2.2 Coupled Model Diag Files
-In the *legacy ascii diag_table*, when running a coupled model (ATM + OCN) in a seperate PE list:
- - The ATM PEs ignored the files in the diag_table that contain "OCEAN" in the filename
- - The OCN PEs ignored the files in the diag_table that did not contain "OCEAN" in the filename
+#### B. Subregional dimension names:
+In some cases, the old diag manager was adding `sub0X` to the dimension names where X is a number greater than 1. This was causing problems in PP tools that were expecting the dimension to have `sub01` in the name. The new diag manager will not have this problem.
-In the *yaml diag_table*:
- - The ATM PEs will ignore the files in the diag_table.yaml that contain the key/value pair `is_ocean: true`
- - The OCN PEs will ignore the files in the diag_table.yaml that do not contain the key/value pair `is_ocean: true`
+#### C. Corner and center diagnostics:
+In the old diag manager, if mixing variables that are corner variables, such as velocities={uo,vo,umo,vmo} and center variables, such as tracers={thetao,so,volcello} you sometimes ended up with a different number of variables per file. The extra files had duplicate data for the corner velocities because the two PEs shared the point at the edge. This happened with some grid/layouts/masks/subregion combinations and it caused problems with the combiner. The new diag manager will not have this problem.
-### 2.3 Variable Section
-The variables in each file are listed under the varlist section as a dashed array.
+### 5. Global attributes
+#### A. Grid type and grid tile:
+The old diag manager was adding the global attributes grid_type = "regular" and grid_tile = "N/A" for all files regardless of what the grid_type and the grid_title actually were. The new diag manager will no longer be doing this as they are not correct and don’t seem to be used.
-- **var_name:** is a string that defines the variable name as it is defined in the register_diag_field call in the model
-- **reduction:** is a string that describes the data reduction method to perform prior to writing data to disk. Acceptable values are average, diurnalXX (where XX is the number of diurnal samples), powXX (whre XX is the power level), min, max, none, rms, and sum.
-- **module:** is a string that defines the module where the variable is registered in the model code
-- **kind:** is a string that defines the type of variable as it will be written out in the file. Acceptable values are r4, r8, i4, and i8
+#### B. Associated_files global attribute:
+We were unable to reproduce the exact order of the associated_files global attribute, so users may see differences like
-**Example:**
-
-In the YAML format:
-```yaml
- varlist:
- - module: moist
- var_name: precip
- reduction: average
- kind: r4
```
-
-In the legacy ascii format:
+lake_area: 19790101.land_static.nc soil_area: 19790101.land_static.nc land_area: 19790101.land_static.nc <> land_area: 19790101.land_static.nc soil_area: 19790101.land_static.nc lake_area: 19790101.land_static.nc
```
-"moist", "precip", "precip", "atmos_8xdaily", "all", .true., "none", 2
-```
-**NOTE:** The fifth column (time_sampling) has been deprecated. The reduction_method (`.true.`) has been replaced with `average`. The output name was not included in the yaml because it is the same as the var_name.
-
-which corresponds to the following model code
-```F90
-id_precip = register_diag_field ( 'moist', 'precip', axes, Time)
-```
-where:
-- `moist` corresonds to the module key in the diag_table.yaml
-- `precip` corresponds to the var_name key in the diag_table.yaml
-- `axes` are the ids of the axes the variable is a function of
-- `Time` is the model time
-Below are some *optional* keys that may be added.
-- **write_var:** is a logical that is set to false if the user doesn’t want the variable to be written to the file (default: true).
-- **out_name:** is a string that defines the name of the variable that will be written to the file (default same as var_name)
-- **long_name:** is a string defining the long_name attribute of the variable. It overwrites the long_name in the variable's register_diag_field call
-- **attributes:** is a subsection with any additional metadata to add to the variable in the netcdf file. This is a new feature that is not supported by the legacy ascii data_table.
-- **zbounds:** is a 2 member array of integers that define the bounds of the z axis (zmin, zmin), optional default is no limits.
+### 6. Real attributes from diag_field_add_attribute calls
+When real attributes were added to the file via a diag_field_add_attribute call, the old diag manager is always saving it as NF90_FLOAT regardless of the precision the data was [passed in](https://github.com/NOAA-GFDL/FMS/blob/ebb32649efa395ea14598f74c8d49e74d1408579/diag_manager/diag_manager.F90#L4532-L4543)
-### 2.4 Variable Metadata Section
-Any aditional variable attributes can be added for each variable can be listed under the attributes section as a dashed array. The key is attribute name and the value is the attribute value.
+The new diag manager is going to write the attribute as it is passed in. This will cause differences when the model component was compiled with r8 as it will write the attribute as r8 instead of r4.
-**Example:**
+### 7. History files data output "changes"
+When the model run time is less than then the output frequency (i.e if the module run time is 2 days and you are writing monthly diagnostics), the old diag manager was writing 9.96921e+36. The new diag manager is not going to write anything for this cases, so if you ncdump the output from the new diag manager, you will get:
-```yaml
- attributes:
- - attribute_name: attribute_value
- attribute_name: attribute_value
```
-
-Although this was not supported by the legacy ascii data_table, with the legacy diag_manager, a call to `diag_field_add_attribute` could have been used to do the same thing.
-
-```F90
-call diag_field_add_attribute(diag_field_id, attribute_name, attribute_value)
+ wa =
+ _, _, _, _, _, _, ...
```
-### 2.5 Global Meta Data Section
-Any aditional global attributes can be added for each file can be listed under the global_meta section as a dashed array. The key is the attribute name and the value is the attribute value.
+Similarly, when a variable was registered, but send_data was never called, the old diag manager was outputting the warning like
-```yaml
- global_meta:
- - attribute_name: attribute_value
- attribute_name: attribute_value
+```
+WARNING from PE 0: diag_manager_mod::closing_file: module/output_field soil/soil_fgw, skip one time level, maybe send_data never called
```
-### 2.6 Sub_region Section
-The sub region can be listed under the sub_region section as a dashed array. The legacy ascii diag_table only allows regions to be defined using the latitude and longitude, and it only allowed rectangular sub regions. With the yaml diag_table, you can use indices to defined the sub_region and you can define **any** four corner shape. Each file can only have 1 sub_region defined. These are keys that can be used:
-- **grid_type:** is a **required** string defining the method used to define the fourth sub_region corners. The acceptable values are "latlon" if using latitude/longitude or "indices" if using the indices of the corners.
-- **corner1:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the first corner of a sub_grid.
-- **corner2:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the second corner of a sub_grid.
-- **corner3:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the third corner of a sub_grid.
-- **corner4:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the fourth corner of a sub_grid.
-- **tile:** is an integer defining the tile number the sub_grid is on. It is **required** only if using (grid_type="indices").
-
-**Exampe:**
+And writing out `9.96921e+36` for the variable. The new diag manager will also be outputting the warning, but it will not write out anything.
-```yaml
- sub_region:
- - grid_type: latlon
- corner1: -80, 0
- corner2: -80, 75
- corner3: -60, 0
- corner4: -60, 75
-```
-### 3. More examples
-Bellow is a complete example of diag_table.yaml:
-```yaml
-title: test_diag_manager
-base_date: 2 1 1 0 0 0
-diag_files:
-- file_name: wild_card_name%4yr%2mo%2dy%2hr
- freq: 6 hours
- time_units: hours
- unlimdim: time
- new_file_freq: 6 hours
- start_time: 2 1 1 0 0 0
- file_duration: 12 hours
- varlist:
- - module: test_diag_manager_mod
- var_name: sst
- reduction: average
- kind: r4
- global_meta:
- - is_a_file: true
-- file_name: normal
- freq: 24 days
- time_units: hours
- unlimdim: records
- varlist:
- - module: test_diag_manager_mod
- var_name: sst
- reduction: average
- kind: r4
- write_var: true
- attributes:
- - do_sst: .true.
- sub_region:
- - grid_type: latlon
- corner1: -80, 0
- corner2: -80, 75
- corner3: -60, 0
- corner4: -60, 75
-- file_name: normal2
- freq: -1 days
- time_units: hours
- unlimdim: records
- write_file: true
- varlist:
- - module: test_diag_manager_mod
- var_name: sstt
- reduction: average
- kind: r4
- long_name: S S T
- - module: test_diag_manager_mod
- var_name: sstt2
- reduction: average
- kind: r4
- write_var: false
- sub_region:
- - grid_type: index
- tile: 1
- corner1: 10, 15
- corner2: 20, 15
- corner3: 10, 25
- corner4: 20, 25
-- file_name: normal3
- freq: -1 days
- time_units: hours
- unlimdim: records
- write_file: false
-```
diff --git a/diag_manager/diag_yaml_format.md b/diag_manager/diag_yaml_format.md
new file mode 100644
index 0000000000..63ed4630c0
--- /dev/null
+++ b/diag_manager/diag_yaml_format.md
@@ -0,0 +1,342 @@
+## Diag Table Yaml Format:
+
+The purpose of this document is to explain the diag_table yaml format.
+
+## Contents
+- [1. Converting from legacy ascii diag_table format](diag_yaml_format.md#1-converting-from-legacy-ascii-diag_table-format)
+- [2. Diag table yaml sections](diag_yaml_format.md#2-diag-table-yaml-sections)
+- [2.1 Global Section](diag_yaml_format.md#21-global-section)
+- [2.2 File Section](diag_yaml_format.md#22-file-section)
+- [2.2.1 Flexible output timings](diag_yaml_format.md#221-flexible-output-timings)
+- [2.2.2 Coupled Model Diag Files](diag_yaml_format.md#222-coupled-model-diag-files)
+- [2.3 Variable Section](diag_yaml_format.md#23-variable-section)
+- [2.4 Variable Metadata Section](diag_yaml_format.md#24-variable-metadata-section)
+- [2.5 Global Meta Data Section](diag_yaml_format.md#25-global-meta-data-section)
+- [2.6 Sub_region Section](diag_yaml_format.md#26-sub_region-section)
+- [3. More examples](diag_yaml_format.md#3-more-examples)
+
+### 1. Converting from legacy ascii diag_table format
+
+To convert the legacy ascii diad_table format to this yaml format, the python script [**diag_table_to_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/diag_table_to_yaml.py#L23-L26) can be used. To confirm that your diag_table.yaml was created correctly, the python script [**is_valid_diag_table_yaml.py**](https://github.com/NOAA-GFDL/fms_yaml_tools/blob/aafc3293d45df2fc173d3c7afd8b8b0adc18fde4/fms_yaml_tools/diag_table/is_valid_diag_table_yaml.py#L24-L27) can be used.
+
+### 2. Diag table yaml sections
+The diag_table.yaml is organized by file. Each file has the required and optional key/value pairs for the file, an optional subsection defining any additional global metadata to add to the file, an optional subsection defining a subregion of the grid to output the data for and a required subsection for all of the variables in the file. Each variable has the required and optional key/value pairs for the variable and an optional subsection defining any additional variable attributes to add to the file. The hierarchical structure looks like this:
+
+```yaml
+title:
+base_date:
+diag_files:
+- file1
+ - #key/value pairs for file1
+ varlist:
+ - var1
+ - #key/value pairs for var1
+ attributes:
+ - #atributes for var1
+ global_metadata:
+ - #global attributes for file1
+ subregion:
+ - #subregion for file1
+```
+
+### 2.1 Global Section
+The diag_yaml requires “title” and the “baseDate”.
+- The **title** is a string that labels the diag yaml. The equivalent in the legacy diag_table would be the experiment. It is recommended that each diag_yaml have a separate title label that is descriptive of the experiment that is using it.
+- The **basedate** is an array of 6 integers indicating the base_date in the format [year month day hour minute second].
+
+**Example:**
+
+In the YAML format:
+```yaml
+title: ESM4_piControl
+base_date: 2022 5 26 12 3 1
+```
+
+In the legacy ascii format:
+```
+ESM4_piControl
+2022 5 26 12 3 1
+```
+
+### 2.2 File Section
+The files are listed under the diagFiles section as a dashed array.
+
+Below are the **required** keys needed to define each file.
+- **file_name** is a string that defines the name of the file. Do not add ".nc" and "tileX" to the filename as this will be handled by FMS.
+- **freq** defines the frequency and the units that data will be written
+ - The acceptable values for freq are:
+ - =-1: output at the end of the run only
+ - =0: output every timestep
+ - \>0 units: output frequency and units (with a space between the frequency number and units e.g 24 hours)
+ - Values of -1 or 0 do not require units.
+ - The acceptable values for units are seconds, minutes, hours, days, months, years.
+- **time_units** is a string that defines units for time. The acceptable values are seconds, minutes, hours, days, months, years.
+- **unlimdim** is a string that defines the name of the unlimited dimension in the output netcdf file, usually “time”.
+- **varlist** is a subsection that list all of the variable in the file
+
+**Example:** The following creates a file with data written every 6 hours.
+
+In the YAML format:
+```yaml
+diag_files:
+- file_name: atmos_6hours
+ freq: 6 hours
+ time_units: hours
+ unlimdim: time
+ varlist:
+ - varinfo
+```
+
+In the legacy ascii format:
+```
+"atmos_6hours", 6, "hours", 1, "hours", "time"
+```
+
+**NOTE:** The fourth column (file_format) has been deprecated. Netcdf files will always be written.
+
+Below are some *optional* keys that may be added.
+- **write_file** is a logical that indicates if you want the file to be created (default is true). This is a new feature that is not supported by the legacy ascii data_table.
+- **new_file_freq** is a string that defines the frequency and the frequency units (with a space between the frequency number and units) for closing the existing file
+- **start_time** is an array of 6 integer indicating when to start the file for the first time. It is in the format [year month day hour minute second]. Requires “new_file_freq”
+- **filename_time** is the time used to set the name of new files when using new_file_freq. The acceptable values are begin (which will use the begining of the file's time bounds), middle (which will use the middle of the file's time bounds), and end (which will use the end of the file's time bounds). The default is middle
+
+**Example:** The following will create a new file every 6 hours starting at Jan 1 2020. Variable data will be written to the file every 6 hours.
+
+In the YAML format:
+```yaml
+- file_name: ocn%4yr%2mo%2dy%2hr
+ freq: 6 hours
+ freq_units: hours
+ unlimdim: time
+ new_file_freq: 6 hours
+ start_time: 2020 1 1 0 0 0
+```
+
+In the legacy ascii format:
+```
+"ocn%4yr%2mo%2dy%2hr", 6, "hours", 1, "hours", "time", 6, "hours", "1901 1 1 0 0 0"
+```
+
+Because this is using the default `filename_time` (middle), this example will create the files:
+```
+ocn_2020_01_01_03.nc for time_bnds [0,6]
+ocn_2020_01_01_09.nc for time_bnds [6,12]
+ocn_2020_01_01_15.nc for time_bnds [12,18]
+ocn_2020_01_01_21.nc for time_bnds [18,24]
+```
+
+**NOTE** If using the new_file_freq, there must be a way to distinguish each file, as it was done in the example above.
+
+- **file_duration** is a string that defines how long the file should receive data after start time in “file_duration_units”. This optional field can only be used if the start_time field is present. If this field is absent, then the file duration will be equal to the frequency for creating new files.
+- **global_meta** is a subsection that lists any additional global metadata to add to the file. This is a new feature that is not supported by the legacy ascii data_table.
+- **sub_region** is a subsection that defines the four corners of a subregional section to capture.
+
+### 2.2.1 Flexible output timings
+
+In order to provide more flexibility in output timings, the diag_table yaml format allows for different file frequencies for the same file by allowing the `freq`, `new_file_freq`, and `file_duration` keys to accept a comma seperated list.
+
+For example,
+``` yaml
+- file_name: flexible_timing%4yr%2mo%2dy%2hr
+ freq: 1 hours, 1 hours, 1 hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6 hours, 3 hours, 1 hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12 hours, 3 hours, 9 hours
+ filename_time: begin
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+```
+This will create a file every 6 hours for 12 hours
+```
+flexible_timing_0002_01_01_00.nc - using hourly averaged data from hour 0 to hour 6
+flexible_timing_0002_01_01_06.nc - using hourly averaged data from hour 6 to hour 12
+```
+
+Then it will create a file every 3 hours for 3 hours
+```
+flexible_timing_0002_01_01_12.nc - using hourly averaged data from hour 12 to hour 15
+```
+
+Then it will create a file every 1 hour for 9 hours.
+```
+flexible_timing_0002_01_01_15.nc - using data from hour 15 to hour 16
+flexible_timing_0002_01_01_16.nc - using data from hour 16 to hour 17
+flexible_timing_0002_01_01_17.nc - using data from hour 17 to hour 18
+flexible_timing_0002_01_01_18.nc - using data from hour 18 to hour 19
+flexible_timing_0002_01_01_19.nc - using data from hour 19 to hour 20
+flexible_timing_0002_01_01_20.nc - using data from hour 20 to hour 21
+flexible_timing_0002_01_01_21.nc - using data from hour 21 to hour 22
+flexible_timing_0002_01_01_22.nc - using data from hour 22 to hour 23
+flexible_timing_0002_01_01_23.nc - using data from hour 23 to hour 24
+
+```
+
+### 2.2.2 Coupled Model Diag Files
+In the *legacy ascii diag_table*, when running a coupled model (ATM + OCN) in a seperate PE list:
+ - The ATM PEs ignored the files in the diag_table that contain "OCEAN" in the filename
+ - The OCN PEs ignored the files in the diag_table that did not contain "OCEAN" in the filename
+
+In the *yaml diag_table*:
+ - The ATM PEs will ignore the files in the diag_table.yaml that contain the key/value pair `is_ocean: true`
+ - The OCN PEs will ignore the files in the diag_table.yaml that do not contain the key/value pair `is_ocean: true`
+
+### 2.3 Variable Section
+The variables in each file are listed under the varlist section as a dashed array.
+
+- **var_name:** is a string that defines the variable name as it is defined in the register_diag_field call in the model
+- **reduction:** is a string that describes the data reduction method to perform prior to writing data to disk. Acceptable values are average, diurnalXX (where XX is the number of diurnal samples), powXX (whre XX is the power level), min, max, none, rms, and sum.
+- **module:** is a string that defines the module where the variable is registered in the model code
+- **kind:** is a string that defines the type of variable as it will be written out in the file. Acceptable values are r4, r8, i4, and i8
+
+**Example:**
+
+In the YAML format:
+```yaml
+ varlist:
+ - module: moist
+ var_name: precip
+ reduction: average
+ kind: r4
+```
+
+In the legacy ascii format:
+```
+"moist", "precip", "precip", "atmos_8xdaily", "all", .true., "none", 2
+```
+**NOTE:** The fifth column (time_sampling) has been deprecated. The reduction_method (`.true.`) has been replaced with `average`. The output name was not included in the yaml because it is the same as the var_name.
+
+which corresponds to the following model code
+```F90
+id_precip = register_diag_field ( 'moist', 'precip', axes, Time)
+```
+where:
+- `moist` corresonds to the module key in the diag_table.yaml
+- `precip` corresponds to the var_name key in the diag_table.yaml
+- `axes` are the ids of the axes the variable is a function of
+- `Time` is the model time
+
+Below are some *optional* keys that may be added.
+- **write_var:** is a logical that is set to false if the user doesn’t want the variable to be written to the file (default: true).
+- **out_name:** is a string that defines the name of the variable that will be written to the file (default same as var_name)
+- **long_name:** is a string defining the long_name attribute of the variable. It overwrites the long_name in the variable's register_diag_field call
+- **attributes:** is a subsection with any additional metadata to add to the variable in the netcdf file. This is a new feature that is not supported by the legacy ascii data_table.
+- **zbounds:** is a 2 member array of integers that define the bounds of the z axis (zmin, zmin), optional default is no limits.
+
+### 2.4 Variable Metadata Section
+Any aditional variable attributes can be added for each variable can be listed under the attributes section as a dashed array. The key is attribute name and the value is the attribute value.
+
+**Example:**
+
+```yaml
+ attributes:
+ - attribute_name: attribute_value
+ attribute_name: attribute_value
+```
+
+Although this was not supported by the legacy ascii data_table, with the legacy diag_manager, a call to `diag_field_add_attribute` could have been used to do the same thing.
+
+```F90
+call diag_field_add_attribute(diag_field_id, attribute_name, attribute_value)
+```
+
+### 2.5 Global Meta Data Section
+Any aditional global attributes can be added for each file can be listed under the global_meta section as a dashed array. The key is the attribute name and the value is the attribute value.
+
+```yaml
+ global_meta:
+ - attribute_name: attribute_value
+ attribute_name: attribute_value
+```
+
+### 2.6 Sub_region Section
+The sub region can be listed under the sub_region section as a dashed array. The legacy ascii diag_table only allows regions to be defined using the latitude and longitude, and it only allowed rectangular sub regions. With the yaml diag_table, you can use indices to defined the sub_region and you can define **any** four corner shape. Each file can only have 1 sub_region defined. These are keys that can be used:
+- **grid_type:** is a **required** string defining the method used to define the fourth sub_region corners. The acceptable values are "latlon" if using latitude/longitude or "indices" if using the indices of the corners.
+- **corner1:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the first corner of a sub_grid.
+- **corner2:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the second corner of a sub_grid.
+- **corner3:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the third corner of a sub_grid.
+- **corner4:** is a **required** 2 member array of reals if using (grid_type="latlon") or integers if using (grid_type="indices") defining the x and y points of the fourth corner of a sub_grid.
+- **tile:** is an integer defining the tile number the sub_grid is on. It is **required** only if using (grid_type="indices").
+
+**Exampe:**
+
+```yaml
+ sub_region:
+ - grid_type: latlon
+ corner1: -80, 0
+ corner2: -80, 75
+ corner3: -60, 0
+ corner4: -60, 75
+```
+
+### 3. More examples
+Bellow is a complete example of diag_table.yaml:
+```yaml
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: wild_card_name%4yr%2mo%2dy%2hr
+ freq: 6 hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6 hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12 hours
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst
+ reduction: average
+ kind: r4
+ global_meta:
+ - is_a_file: true
+- file_name: normal
+ freq: 24 days
+ time_units: hours
+ unlimdim: records
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sst
+ reduction: average
+ kind: r4
+ write_var: true
+ attributes:
+ - do_sst: .true.
+ sub_region:
+ - grid_type: latlon
+ corner1: -80, 0
+ corner2: -80, 75
+ corner3: -60, 0
+ corner4: -60, 75
+- file_name: normal2
+ freq: -1 days
+ time_units: hours
+ unlimdim: records
+ write_file: true
+ varlist:
+ - module: test_diag_manager_mod
+ var_name: sstt
+ reduction: average
+ kind: r4
+ long_name: S S T
+ - module: test_diag_manager_mod
+ var_name: sstt2
+ reduction: average
+ kind: r4
+ write_var: false
+ sub_region:
+ - grid_type: index
+ tile: 1
+ corner1: 10, 15
+ corner2: 20, 15
+ corner3: 10, 25
+ corner4: 20, 25
+- file_name: normal3
+ freq: -1 days
+ time_units: hours
+ unlimdim: records
+ write_file: false
+```
From 41f59150608302367fd8b2b37a3f33589460d546 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Fri, 29 Mar 2024 10:04:03 -0400
Subject: [PATCH 160/168] fix: modern_diag_manager empty files and non
registered fields (#1482)
---
diag_manager/fms_diag_file_object.F90 | 81 ++++++++++++++++++++-----
diag_manager/fms_diag_object.F90 | 7 ++-
diag_manager/fms_diag_output_buffer.F90 | 10 ++-
diag_manager/fms_diag_yaml.F90 | 14 +++--
test_fms/diag_manager/test_time_none.sh | 55 +++++++++++++++++
5 files changed, 141 insertions(+), 26 deletions(-)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 2ea70dfb8c..8b6b2cbdb8 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -156,6 +156,7 @@ module fms_diag_file_object_mod
procedure, public :: dump_file_obj
procedure, public :: get_buffer_ids
procedure, public :: get_number_of_buffers
+ procedure, public :: has_send_data_been_called
end type fmsDiagFile_type
type, extends (fmsDiagFile_type) :: subRegionalFile_type
@@ -1323,12 +1324,6 @@ subroutine write_field_data(this, field_obj, buffer_obj)
else
diag_file%data_has_been_written = .true.
has_diurnal = buffer_obj%get_diurnal_sample_size() .gt. 1
- if (.not. buffer_obj%is_there_data_to_write()) then
- ! Only print the error message once
- if (diag_file%unlim_dimension_level .eq. 1) &
- call mpp_error(NOTE, "Send data was never called. Writing fill values for variable "//&
- field_obj%get_varname()//" in mod "//field_obj%get_modname())
- endif
call buffer_obj%write_buffer(fms2io_fileobj, &
unlim_dim_level=diag_file%unlim_dimension_level, is_diurnal=has_diurnal)
endif
@@ -1350,17 +1345,34 @@ logical function is_time_to_close_file (this, time_step)
end function
!> \brief Determine if it is time to "write" to the file
-logical function is_time_to_write(this, time_step)
- class(fmsDiagFileContainer_type), intent(in), target :: this !< The file object
- TYPE(time_type), intent(in) :: time_step !< Current model step time
+logical function is_time_to_write(this, time_step, output_buffers)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ TYPE(time_type), intent(in) :: time_step !< Current model step time
+ type(fmsDiagOutputBuffer_type), intent(in) :: output_buffers(:) !< Array of output buffer.
+ !! This is needed for error messages!
if (time_step > this%FMS_diag_file%next_output) then
is_time_to_write = .true.
if (this%FMS_diag_file%is_static) return
- if (time_step > this%FMS_diag_file%next_next_output) &
- call mpp_error(FATAL, this%FMS_diag_file%get_file_fname()//&
- &": Diag_manager_mod:: You skipped a time_step. Be sure that diag_send_complete is called at every time step "&
- &" needed by the file.")
+ if (time_step > this%FMS_diag_file%next_next_output) then
+ if (this%FMS_diag_file%num_registered_fields .eq. 0) then
+ !! If no variables have been registered, write a dummy time dimension for the first level
+ !! At least one time level is needed for the combiner to work ...
+ if (this%FMS_diag_file%unlim_dimension_level .eq. 1) then
+ call mpp_error(NOTE, this%FMS_diag_file%get_file_fname()//&
+ ": diag_manager_mod: This file does not have any variables registered. Fill values will be written")
+ this%FMS_diag_file%data_has_been_written = .true.
+ endif
+ is_time_to_write =.false.
+ else
+ !! Only fail if send data has actually been called for at least one variable
+ if (this%FMS_diag_file%has_send_data_been_called(output_buffers, .false.)) &
+ call mpp_error(FATAL, this%FMS_diag_file%get_file_fname()//&
+ ": diag_manager_mod: You skipped a time_step. Be sure that diag_send_complete is called at every "//&
+ "time_step needed by the file.")
+ is_time_to_write =.false.
+ endif
+ endif
else
is_time_to_write = .false.
if (this%FMS_diag_file%is_static) then
@@ -1663,8 +1675,12 @@ subroutine write_axis_data(this, diag_axis)
end subroutine write_axis_data
!< @brief Closes the diag_file
-subroutine close_diag_file(this)
- class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+subroutine close_diag_file(this, output_buffers, diag_fields)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ type(fmsDiagOutputBuffer_type), intent(in) :: output_buffers(:) !< Array of output buffers
+ !! This is needed for error checking
+ type(fmsDiagField_type), intent(in), optional :: diag_fields(:) !< Array of diag fields
+ !! This is needed for error checking
if (.not. this%FMS_diag_file%is_file_open) return
@@ -1690,6 +1706,8 @@ subroutine close_diag_file(this)
else
this%FMS_diag_file%next_close = diag_time_inc(this%FMS_diag_file%next_close, VERY_LARGE_FILE_FREQ, DIAG_DAYS)
endif
+
+ if (this%FMS_diag_file%has_send_data_been_called(output_buffers, .True., diag_fields)) return
end subroutine close_diag_file
!> \brief Gets the buffer_id list from the file object
@@ -1708,5 +1726,38 @@ pure function get_number_of_buffers(this)
get_number_of_buffers = this%number_of_buffers
end function get_number_of_buffers
+!> @brief Determine if send_data has been called for any fields in the file. Prints out warnings, if indicated
+!! @return .True. if send_data has been called for any fields in the file
+function has_send_data_been_called(this, output_buffers, print_warnings, diag_fields) &
+result(rslt)
+ class(fmsDiagFile_type), intent(in) :: this !< file object
+ type(fmsDiagOutputBuffer_type), intent(in), target :: output_buffers(:) !< Array of output buffers
+ logical, intent(in) :: print_warnings !< .True. if printing warnings
+ type(fmsDiagField_type), intent(in), optional :: diag_fields(:) !< Array of diag fields
+
+ logical :: rslt
+ integer :: i !< For do loops
+ integer :: field_id !< Field id
+
+ rslt = .false.
+
+ if (print_warnings) then
+ do i = 1, this%number_of_buffers
+ if (.not. output_buffers(this%buffer_ids(i))%is_there_data_to_write()) then
+ field_id = output_buffers(this%buffer_ids(i))%get_field_id()
+ call mpp_error(NOTE, "Send data was never called for field:"//&
+ trim(diag_fields(field_id)%get_varname())//" mod: "//trim(diag_fields(field_id)%get_modname())//&
+ " in file: "//trim(this%get_file_fname())//". Writting FILL VALUES!")
+ endif
+ enddo
+ else
+ do i = 1, this%number_of_buffers
+ if (output_buffers(this%buffer_ids(i))%is_there_data_to_write()) then
+ rslt = .true.
+ return
+ endif
+ enddo
+ endif
+end function has_send_data_been_called
#endif
end module fms_diag_file_object_mod
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 12c33e082a..9856f41293 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -825,7 +825,7 @@ subroutine fms_diag_do_io(this, end_time)
call diag_file%increase_unlim_dimension_level()
endif
- finish_writing = diag_file%is_time_to_write(model_time)
+ finish_writing = diag_file%is_time_to_write(model_time, this%FMS_diag_output_buffers)
! finish reduction method if its time to write
buff_ids = diag_file%FMS_diag_file%get_buffer_ids()
@@ -863,10 +863,11 @@ subroutine fms_diag_do_io(this, end_time)
call diag_file%update_next_write(model_time)
call diag_file%update_current_new_file_freq_index(model_time)
call diag_file%increase_unlim_dimension_level()
- if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file()
+ if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file(this%FMS_diag_output_buffers, &
+ diag_fields = this%FMS_diag_fields)
else if (force_write) then
call diag_file%write_time_data()
- call diag_file%close_diag_file()
+ call diag_file%close_diag_file(this%FMS_diag_output_buffers, diag_fields = this%FMS_diag_fields)
endif
enddo
#endif
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index 7c8b5a4ae0..a2bad476be 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -61,7 +61,7 @@ module fms_diag_output_buffer_mod
!! ie. diurnal24 = sample size of 24
integer :: diurnal_section= -1 !< the diurnal section (ie 5th index) calculated from the current model
!! time and sample size if using a diurnal reduction
- logical :: send_data_called !< .True. if send_data has been called
+ logical, allocatable :: send_data_called !< .True. if send_data has been called
type(time_type) :: time !< The last time the data was received
type(time_type) :: next_output !< The next time to output the data
@@ -826,11 +826,15 @@ end subroutine get_remapped_diurnal_data
!! @return .true. if there is data to write
function is_there_data_to_write(this) &
result(res)
- class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object
logical :: res
- res = this%send_data_called
+ if (allocated(this%send_data_called)) then
+ res = this%send_data_called
+ else
+ res = .false.
+ endif
end function
!> @brief Determine if it is time to finish the reduction method
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 308243edfe..919b37d744 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -37,7 +37,7 @@ module fms_diag_yaml_mod
middle_time, begin_time, end_time, MAX_STR_LEN
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
-use mpp_mod, only: mpp_error, FATAL, mpp_pe, mpp_root_pe, stdout
+use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe, mpp_root_pe, stdout
use, intrinsic :: iso_c_binding, only : c_ptr, c_null_char
use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique, string
use platform_mod, only: r4_kind, i4_kind
@@ -356,6 +356,7 @@ subroutine diag_yaml_object_init(diag_subset_output)
integer :: file_count !! The current number of files added to the diag_yaml obj
logical :: write_file !< Flag indicating if the user wants the file to be written
logical :: write_var !< Flag indicating if the user wants the variable to be written
+ character(len=:), allocatable :: filename!< Diag file name (for error messages)
if (diag_yaml_module_initialized) return
@@ -393,13 +394,16 @@ subroutine diag_yaml_object_init(diag_subset_output)
call get_value_from_key(diag_yaml_id, diag_file_ids(i), "write_file", write_file, is_optional=.true.)
if(.not. write_file) ignore(i) = .true.
+ !< If ignoring the file, ignore the fields in that file too!
if (.not. ignore(i)) then
- !< If ignoring the file, ignore the fields in that file too!
- total_nvars = total_nvars + get_total_num_vars(diag_yaml_id, diag_file_ids(i))
- if (total_nvars .ne. 0) then
+ nvars = get_total_num_vars(diag_yaml_id, diag_file_ids(i))
+ total_nvars = total_nvars + nvars
+ if (nvars .ne. 0) then
actual_num_files = actual_num_files + 1
else
- ignore(i) = .true.
+ call diag_get_value_from_key(diag_yaml_id, diag_file_ids(i), "file_name", filename)
+ call mpp_error(NOTE, "diag_manager_mod:: the file:"//trim(filename)//" has no variables defined. Ignoring!")
+ ignore(i) = .True.
endif
endif
enddo
diff --git a/test_fms/diag_manager/test_time_none.sh b/test_fms/diag_manager/test_time_none.sh
index 9840e0c0ac..421cbfe093 100755
--- a/test_fms/diag_manager/test_time_none.sh
+++ b/test_fms/diag_manager/test_time_none.sh
@@ -169,5 +169,60 @@ test_expect_success "Running diag_manager with "none" reduction method with halo
test_expect_success "Checking answers for the "none" reduction method with halo output with real mask (test $my_test_count)" '
mpirun -n 1 ../check_time_none
'
+
+cat <<_EOF > diag_table.yaml
+title: test_none
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_empty_file
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+_EOF
+
+my_test_count=`expr $my_test_count + 1`
+test_expect_success "Testing diag manager that defined a diag file with no variables (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+
+cat <<_EOF > diag_table.yaml
+title: test_none
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_unregistered_data
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: something_funny
+ reduction: none
+ kind: r4
+_EOF
+
+my_test_count=`expr $my_test_count + 1`
+test_expect_success "Testing diag manager where no variables were registered for a file (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+'
+
+cat <<_EOF > diag_table.yaml
+title: test_none
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: test_send_data_never_called
+ time_units: hours
+ unlimdim: time
+ freq: 6 hours
+ varlist:
+ - module: ocn_mod
+ var_name: IOnASphere
+ reduction: none
+ kind: r4
+_EOF
+
+my_test_count=`expr $my_test_count + 1`
+test_expect_success "Testing diag manager where send data was never called for any fields in a file (test $my_test_count)" '
+ mpirun -n 6 ../test_reduction_methods
+ '
fi
test_done
From 8d1bef65213fcb0b6d4b7c5275989819c28959d2 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Fri, 29 Mar 2024 10:06:09 -0400
Subject: [PATCH 161/168] fix: diag_manager uninitialized return value (#1484)
---
diag_manager/fms_diag_field_object.F90 | 2 ++
1 file changed, 2 insertions(+)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 34e425eb9b..5daa3a5a50 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -1884,6 +1884,8 @@ function check_for_slices(field, diag_axis, var_size) &
logical :: rslt
integer :: i !< For do loops
+ rslt = .false.
+
if (.not. field%has_axis_ids()) then
rslt = .false.
return
From 4b5cd169c8c1e76bbe19acccc3f39e36caaf4cd7 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Thu, 11 Apr 2024 10:57:48 -0400
Subject: [PATCH 162/168] fix: modern diag fixes for gcc (#1486)
---
diag_manager/fms_diag_field_object.F90 | 18 +++++++++++----
diag_manager/fms_diag_file_object.F90 | 28 ++++++++++++++---------
diag_manager/fms_diag_object.F90 | 14 +++++++++---
diag_manager/fms_diag_yaml.F90 | 18 +++++++--------
test_fms/diag_manager/test_diag_ocean.F90 | 10 ++++----
test_fms/diag_manager/test_diag_yaml.F90 | 22 ++++++++----------
6 files changed, 66 insertions(+), 44 deletions(-)
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 5daa3a5a50..4e4eb15025 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -1193,6 +1193,8 @@ subroutine write_field_metadata(this, fms2io_fileobj, file_id, yaml_id, diag_axi
character(len=120) :: cell_methods!< Cell methods attribute to write
integer :: i !< For do loops
character (len=MAX_STR_LEN), allocatable :: yaml_field_attributes(:,:) !< Variable attributes defined in the yaml
+ character(len=:), allocatable :: interp_method_tmp !< temp to hold the name of the interpolation method
+ integer :: interp_method_len !< length of the above string
field_yaml => diag_yaml%get_diag_field_from_id(yaml_id)
var_name = field_yaml%get_var_outname()
@@ -1235,8 +1237,10 @@ subroutine write_field_metadata(this, fms2io_fileobj, file_id, yaml_id, diag_axi
endif
if (this%has_interp_method()) then
- call register_variable_attribute(fms2io_fileobj, var_name, "interp_method", this%get_interp_method(), &
- str_len=len_trim(this%get_interp_method()))
+ interp_method_tmp = this%interp_method
+ interp_method_len = len_trim(interp_method_tmp)
+ call register_variable_attribute(fms2io_fileobj, var_name, "interp_method", interp_method_tmp, &
+ str_len=interp_method_len)
endif
cell_methods = ""
@@ -1797,12 +1801,18 @@ function find_missing_value(this, missing_val) &
result(res)
class(fmsDiagField_type), intent(in) :: this !< field object to get missing value for
class(*), allocatable, intent(out) :: missing_val !< outputted netcdf missing value (oriignal type)
- real(r8_kind) :: res !< returned r8 copy of missing_val
+ real(r8_kind), allocatable :: res !< returned r8 copy of missing_val
+ integer :: vtype !< temp to hold enumerated variable type
if(this%has_missing_value()) then
missing_val = this%get_missing_value(this%get_vartype())
else
- missing_val = get_default_missing_value(this%get_vartype())
+ vtype = this%get_vartype()
+ if(vtype .eq. r8) then
+ missing_val = CMOR_MISSING_VALUE
+ else
+ missing_val = real(CMOR_MISSING_VALUE, r4_kind)
+ endif
endif
select type(missing_val)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index 8b6b2cbdb8..d102d2353a 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -34,7 +34,7 @@ module fms_diag_file_object_mod
get_base_year, get_base_month, get_base_day, get_base_hour, get_base_minute, &
get_base_second, time_unit_list, time_average, time_rms, time_max, time_min, time_sum, &
time_diurnal, time_power, time_none, avg_name, no_units, pack_size_str, &
- middle_time, begin_time, end_time, MAX_STR_LEN, index_gridtype, latlon_gridtype
+ middle_time, begin_time, end_time, MAX_STR_LEN, index_gridtype, latlon_gridtype, null_gridtype
use time_manager_mod, only: time_type, operator(>), operator(/=), operator(==), get_date, get_calendar_type, &
VALID_CALENDAR_TYPES, operator(>=), date_to_string, &
OPERATOR(/), OPERATOR(+), operator(<)
@@ -364,6 +364,7 @@ subroutine set_file_time_ops(this, VarYaml, is_static)
class(fmsDiagFile_type), intent(inout) :: this !< The file object
type (diagYamlFilesVar_type), intent(in) :: VarYaml !< The variable's yaml file
logical, intent(in) :: is_static !< Flag indicating if variable is static
+ integer, allocatable :: var_reduct !< temp to hold enumerated reduction type
!< Go away if the file is static
if (this%is_static) return
@@ -375,7 +376,8 @@ subroutine set_file_time_ops(this, VarYaml, is_static)
" has variables that are time averaged and instantaneous")
endif
else
- select case (VarYaml%get_var_reduction())
+ var_reduct = VarYaml%get_var_reduction()
+ select case (var_reduct)
case (time_average, time_rms, time_max, time_min, time_sum, time_diurnal, time_power)
this%time_ops = .true.
end select
@@ -514,24 +516,28 @@ pure function get_file_unlimdim (this) result(res)
end function get_file_unlimdim
!> \brief Returns a copy of file_sub_region from the yaml object
-!! \return Copy of file_sub_region
+!! \return Pointer to file_sub_region
function get_file_sub_region (obj) result(res)
- class(fmsDiagFile_type), intent(in) :: obj !< The file object
- type(subRegion_type) :: res
- res = obj%diag_yaml_file%get_file_sub_region()
+ class(fmsDiagFile_type), target, intent(in) :: obj !< The file object
+ type(subRegion_type), pointer :: res
+ res => obj%diag_yaml_file%get_file_sub_region()
end function get_file_sub_region
!< @brief Query for the subregion grid type (latlon or index)
-!! @return subregion grid type
+!! @return Pointer to subregion grid type
function get_file_sub_region_grid_type(this) &
result(res)
class(fmsDiagFile_type), intent(in) :: this !< Diag file object
integer :: res
- type(subRegion_type) :: subregion !< Subregion type
+ type(subRegion_type), pointer :: subregion !< Subregion type
- subregion = this%diag_yaml_file%get_file_sub_region()
- res = subregion%grid_type
+ if(this%diag_yaml_file%has_file_sub_region()) then
+ subregion => this%diag_yaml_file%get_file_sub_region()
+ res = subregion%grid_type
+ else
+ res = null_gridtype
+ endif
end function get_file_sub_region_grid_type
!> \brief Returns a copy of file_new_file_freq from the yaml object
@@ -718,7 +724,7 @@ end subroutine set_domain_from_axis
subroutine set_file_domain(this, domain, type_of_domain)
class(fmsDiagFile_type), intent(inout) :: this !< The file object
integer, INTENT(in) :: type_of_domain !< fileobj_type to use
- CLASS(diagDomain_t), INTENT(in), target :: domain !< Domain
+ CLASS(diagDomain_t), INTENT(in), pointer :: domain !< Domain
if (type_of_domain .ne. this%type_of_domain) then
!! If the current type_of_domain in the file obj is not the same as the variable calling this subroutine
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 9856f41293..2c8e04d9df 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -22,7 +22,7 @@ module fms_diag_object_mod
&DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, &
&get_base_time, NULL_AXIS_ID, get_var_type, diag_not_registered, &
&time_none, time_max, time_min, time_sum, time_average, time_diurnal, &
- &time_power, time_rms, r8
+ &time_power, time_rms, r8, NO_DOMAIN
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
& OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
@@ -257,7 +257,11 @@ integer function fms_register_diag_field_obj &
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%add_buffer_id(fieldptr%buffer_ids(i))
- call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
+ if(fieldptr%get_type_of_domain() .eq. NO_DOMAIN) then
+ call fileptr%set_file_domain(NULL(), fieldptr%get_type_of_domain())
+ else
+ call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
+ endif
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i), &
fieldptr%buffer_ids(i), this%FMS_diag_output_buffers)
@@ -270,7 +274,11 @@ integer function fms_register_diag_field_obj &
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%add_buffer_id(fieldptr%buffer_ids(i))
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
- call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
+ if(fieldptr%get_type_of_domain() .eq. NO_DOMAIN) then
+ call fileptr%set_file_domain(NULL(), fieldptr%get_type_of_domain())
+ else
+ call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain())
+ endif
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i), &
fieldptr%buffer_ids(i), this%FMS_diag_output_buffers)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 919b37d744..cfd1802fcd 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -261,9 +261,9 @@ module fms_diag_yaml_mod
!! @return a copy of the diag_yaml module variable
function get_diag_yaml_obj() &
result(res)
- type (diagYamlObject_type) :: res
+ type (diagYamlObject_type), pointer :: res
- res= diag_yaml
+ res => diag_yaml
end function get_diag_yaml_obj
!> @brief get the basedate of a diag_yaml type
@@ -953,9 +953,9 @@ end function get_file_unlimdim
!! @return file_sub_region of a diag_yaml_file_obj
function get_file_sub_region (this) &
result (res)
- class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried
- type(subRegion_type) :: res !< What is returned
- res = this%file_sub_region
+ class (diagYamlFiles_type), target, intent(in) :: this !< The object being inquiried
+ type(subRegion_type), pointer :: res !< What is returned
+ res => this%file_sub_region
end function get_file_sub_region
!> @brief Inquiry for diag_files_obj%file_new_file_freq
!! @return file_new_file_freq of a diag_yaml_file_obj
@@ -1475,7 +1475,7 @@ subroutine dump_diag_yaml_obj( filename )
character(len=*), optional, intent(in) :: filename !< optional name of logfile to write to, otherwise
!! prints to stdout
type(diagyamlfilesvar_type), allocatable :: fields(:)
- type(diagyamlfiles_type), allocatable :: files(:)
+ type(diagyamlfiles_type), pointer :: files(:)
integer :: i, unit_num
if( present(filename)) then
open(newunit=unit_num, file=trim(filename), action='WRITE')
@@ -1489,8 +1489,7 @@ subroutine dump_diag_yaml_obj( filename )
if( diag_yaml%has_diag_basedate()) write(unit_num, *) 'basedate array:', diag_yaml%diag_basedate
write(unit_num, *) 'FILES'
allocate(fields(SIZE(diag_yaml%get_diag_fields())))
- allocate(files(SIZE(diag_yaml%get_diag_files())))
- files = diag_yaml%get_diag_files()
+ files => diag_yaml%diag_files
fields = diag_yaml%get_diag_fields()
do i=1, SIZE(files)
write(unit_num, *) 'File: ', files(i)%get_file_fname()
@@ -1527,7 +1526,8 @@ subroutine dump_diag_yaml_obj( filename )
if(fields(i)%has_pow_value()) write(unit_num, *) 'pow_value:', fields(i)%get_pow_value()
if(fields(i)%has_var_attributes()) write(unit_num, *) 'is_var_attributes:', fields(i)%is_var_attributes()
enddo
- deallocate(files, fields)
+ deallocate(fields)
+ nullify(files)
if( present(filename)) then
close(unit_num)
endif
diff --git a/test_fms/diag_manager/test_diag_ocean.F90 b/test_fms/diag_manager/test_diag_ocean.F90
index 449569dd49..1723c3248b 100644
--- a/test_fms/diag_manager/test_diag_ocean.F90
+++ b/test_fms/diag_manager/test_diag_ocean.F90
@@ -31,8 +31,8 @@ program test_diag_ocean
implicit none
-type(diagYamlObject_type) :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init
-type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< Files from the diag_yaml
+type(diagYamlObject_type), pointer :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init
+type(diagYamlFiles_type), pointer, dimension (:) :: diag_files !< Files from the diag_yaml
type(diagYamlFilesVar_type), allocatable, dimension(:) :: diag_fields !< Fields from the diag_yaml
character(len=10), allocatable :: file_names(:) !< The expected names of the files
character(len=10), allocatable :: var_names(:) !< The expected names of the variables
@@ -69,8 +69,8 @@ program test_diag_ocean
call diag_manager_init(diag_model_subset=diag_subset)
-my_yaml = get_diag_yaml_obj()
-diag_files = my_yaml%get_diag_files()
+my_yaml => get_diag_yaml_obj()
+diag_files => my_yaml%diag_files
if (size(diag_files) .ne. nfiles) call mpp_error(FATAL, "The number of files should be "//string(nfiles))
do i = 1, nfiles
@@ -88,7 +88,7 @@ program test_diag_ocean
&trim(var_names(i))//" not "//diag_fields(i)%get_var_varname())
end do
-deallocate(diag_files)
+nullify(diag_files)
deallocate(diag_fields)
deallocate(file_names)
deallocate(var_names)
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index c94eb6184f..58d9b96244 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -55,10 +55,10 @@ end subroutine compare_result_1d
integer :: io_status !< The status after reading the input.nml
integer, allocatable :: indices(:) !< Array of indices
-type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< Files from the diag_yaml
+#ifdef use_yaml
+type(diagYamlFiles_type), pointer, dimension (:) :: diag_files !< Files from the diag_yaml
type(diagYamlFilesVar_type), allocatable, dimension(:) :: diag_fields !< Fields from the diag_yaml
-type(diagYamlObject_type) :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init
-type(diagYamlObject_type) :: ans !< expected diagYamlObject
+type(diagYamlObject_type), pointer :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init
integer, ALLOCATABLE :: diag_files_ids(:) !< Ids of the diag_files
#endif
@@ -78,7 +78,7 @@ end subroutine compare_result_1d
call diag_data_init()
call diag_yaml_object_init(DIAG_ALL)
-my_yaml = get_diag_yaml_obj()
+my_yaml => get_diag_yaml_obj()
if (.not. checking_crashes) then
call compare_result("base_date", my_yaml%get_basedate(), (/2, 1, 1, 0, 0 , 0 /))
@@ -86,7 +86,7 @@ end subroutine compare_result_1d
call compare_result("title", my_yaml%get_title(), "test_diag_manager")
- diag_files = my_yaml%get_diag_files()
+ diag_files => my_yaml%diag_files
call compare_result("nfiles", size(diag_files), 3) !< the fourth file has file_write = false so it doesn't count
call compare_diag_files(diag_files)
@@ -97,7 +97,7 @@ end subroutine compare_result_1d
!< Check that get_num_unique_fields is getting the correct number of unique fields
call compare_result("number of unique fields", get_num_unique_fields(), 2)
- deallocate(diag_files)
+ nullify(diag_files)
deallocate(diag_fields)
indices = find_diag_field("sst", "test_diag_manager_mod")
@@ -114,14 +114,12 @@ end subroutine compare_result_1d
deallocate(diag_fields)
diag_files_ids = get_diag_files_id(indices)
- allocate(diag_files(size(diag_files_ids)))
- diag_files(1) = my_yaml%diag_files(diag_files_ids(1))
- diag_files(2) = my_yaml%diag_files(diag_files_ids(2))
+ diag_files => my_yaml%diag_files(1:2)
call compare_result("sst - nfiles", size(diag_files), 2)
- call compare_result("sst - filename", diag_files(1)%get_file_fname(), "normal")
- call compare_result("sst - filename", diag_files(2)%get_file_fname(), "wild_card_name%4yr%2mo%2dy%2hr")
- deallocate(diag_files)
+ call compare_result("sst - filename", diag_files(2)%get_file_fname(), "normal")
+ call compare_result("sst - filename", diag_files(1)%get_file_fname(), "wild_card_name%4yr%2mo%2dy%2hr")
+ nullify(diag_files)
deallocate(indices)
indices = find_diag_field("sstt", "test_diag_manager_mod")
From 7a135818be74bec2aa7d5ec7573f011f31d4e2b8 Mon Sep 17 00:00:00 2001
From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com>
Date: Tue, 16 Apr 2024 15:20:37 -0400
Subject: [PATCH 163/168] fix: diag manager keep track of time and unlimited
dimension at the file and buffer level (#1487)
---
diag_manager/fms_diag_file_object.F90 | 90 ++++++++++++++++++++-----
diag_manager/fms_diag_object.F90 | 57 ++++++++--------
diag_manager/fms_diag_output_buffer.F90 | 55 +++++++++++++--
3 files changed, 149 insertions(+), 53 deletions(-)
diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90
index d102d2353a..974364044d 100644
--- a/diag_manager/fms_diag_file_object.F90
+++ b/diag_manager/fms_diag_file_object.F90
@@ -63,6 +63,7 @@ module fms_diag_file_object_mod
type :: fmsDiagFile_type
private
integer :: id !< The number associated with this file in the larger array of files
+ TYPE(time_type) :: model_time !< The last time data was sent for any of the buffers in this file object
TYPE(time_type) :: start_time !< The start time for the file
TYPE(time_type) :: last_output !< Time of the last time output was writen
TYPE(time_type) :: next_output !< Time of the next write
@@ -184,12 +185,15 @@ module fms_diag_file_object_mod
procedure :: is_time_to_close_file
procedure :: write_time_data
procedure :: update_next_write
+ procedure :: prepare_for_force_write
+ procedure :: init_unlim_dim
procedure :: update_current_new_file_freq_index
- procedure :: increase_unlim_dimension_level
procedure :: get_unlim_dimension_level
procedure :: get_next_output
procedure :: get_next_next_output
procedure :: close_diag_file
+ procedure :: set_model_time
+ procedure :: get_model_time
end type fmsDiagFileContainer_type
!type(fmsDiagFile_type), dimension (:), allocatable, target :: FMS_diag_file !< The array of diag files
@@ -252,6 +256,7 @@ logical function fms_diag_files_object_init (files_array)
obj%done_writing_data = .false.
obj%start_time = get_base_time()
obj%last_output = get_base_time()
+ obj%model_time = get_base_time()
obj%next_output = diag_time_inc(obj%start_time, obj%get_file_freq(), obj%get_file_frequnit())
obj%next_next_output = diag_time_inc(obj%next_output, obj%get_file_freq(), obj%get_file_frequnit())
@@ -969,12 +974,9 @@ end subroutine define_new_subaxis
!> @brief adds the start time to the fileobj
!! @note This should be called from the register field calls. It can be called multiple times (one for each variable)
!! So it needs to make sure that the start_time is the same for each variable. The initial value is the base_time
-subroutine add_start_time(this, start_time, model_time)
+subroutine add_start_time(this, start_time)
class(fmsDiagFile_type), intent(inout) :: this !< The file object
TYPE(time_type), intent(in) :: start_time !< Start time to add to the fileobj
- TYPE(time_type), intent(out) :: model_time !< The current model time
- !! this will be set to the start_time
- !! at the begining of the run
!< If the start_time sent in is equal to the base_time return because
!! this%start_time was already set to the base_time
@@ -989,7 +991,7 @@ subroutine add_start_time(this, start_time, model_time)
else
!> If the this%start_time is equal to the base_time,
!! simply update it with the start_time and set up the *_output variables
- model_time = start_time
+ this%model_time = start_time
this%start_time = start_time
this%last_output = start_time
this%next_output = diag_time_inc(start_time, this%get_file_freq(), this%get_file_frequnit())
@@ -1302,10 +1304,11 @@ subroutine write_time_metadata(this)
end subroutine write_time_metadata
!> \brief Write out the field data to the file
-subroutine write_field_data(this, field_obj, buffer_obj)
+subroutine write_field_data(this, field_obj, buffer_obj, unlim_dim_was_increased)
class(fmsDiagFileContainer_type), intent(in), target :: this !< The diag file object to write to
type(fmsDiagField_type), intent(in), target :: field_obj !< The field object to write from
type(fmsDiagOutputBuffer_type), intent(inout), target :: buffer_obj !< The buffer object with the data
+ logical, intent(inout) :: unlim_dim_was_increased
class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open
class(FmsNetcdfFile_t), pointer :: fms2io_fileobj !< Fileobj to write to
@@ -1314,6 +1317,14 @@ subroutine write_field_data(this, field_obj, buffer_obj)
diag_file => this%FMS_diag_file
fms2io_fileobj => diag_file%fms2io_fileobj
+ !< Increase the unlim dimension index for the output buffer and update the output buffer for the file
+ !! if haven't already
+ call buffer_obj%increase_unlim_dim()
+ if (buffer_obj%get_unlim_dim() > diag_file%unlim_dimension_level) then
+ diag_file%unlim_dimension_level = buffer_obj%get_unlim_dim()
+ unlim_dim_was_increased = .true.
+ endif
+
!TODO This may be offloaded in the future
if (diag_file%is_static) then
!< Here the file is static so there is no need for the unlimited dimension
@@ -1323,15 +1334,15 @@ subroutine write_field_data(this, field_obj, buffer_obj)
else
if (field_obj%is_static()) then
!< If the variable is static, only write it the first time
- if (diag_file%unlim_dimension_level .eq. 1) then
+ if (buffer_obj%get_unlim_dim() .eq. 1) then
call buffer_obj%write_buffer(fms2io_fileobj)
diag_file%data_has_been_written = .true.
endif
else
- diag_file%data_has_been_written = .true.
+ if (unlim_dim_was_increased) diag_file%data_has_been_written = .true.
has_diurnal = buffer_obj%get_diurnal_sample_size() .gt. 1
call buffer_obj%write_buffer(fms2io_fileobj, &
- unlim_dim_level=diag_file%unlim_dimension_level, is_diurnal=has_diurnal)
+ unlim_dim_level=buffer_obj%get_unlim_dim(), is_diurnal=has_diurnal)
endif
endif
@@ -1346,7 +1357,11 @@ logical function is_time_to_close_file (this, time_step)
if (time_step >= this%FMS_diag_file%next_close) then
is_time_to_close_file = .true.
else
- is_time_to_close_file = .false.
+ if (this%FMS_diag_file%is_static) then
+ is_time_to_close_file = .true.
+ else
+ is_time_to_close_file = .false.
+ endif
endif
end function
@@ -1364,10 +1379,11 @@ logical function is_time_to_write(this, time_step, output_buffers)
if (this%FMS_diag_file%num_registered_fields .eq. 0) then
!! If no variables have been registered, write a dummy time dimension for the first level
!! At least one time level is needed for the combiner to work ...
- if (this%FMS_diag_file%unlim_dimension_level .eq. 1) then
+ if (this%FMS_diag_file%unlim_dimension_level .eq. 0) then
call mpp_error(NOTE, this%FMS_diag_file%get_file_fname()//&
": diag_manager_mod: This file does not have any variables registered. Fill values will be written")
this%FMS_diag_file%data_has_been_written = .true.
+ this%FMS_diag_file%unlim_dimension_level = 1
endif
is_time_to_write =.false.
else
@@ -1443,6 +1459,7 @@ subroutine write_time_data(this)
endif
endif
+ diag_file%data_has_been_written = .false.
end subroutine write_time_data
!> \brief Updates the current_new_file_freq_index if using a new_file_freq
@@ -1470,6 +1487,8 @@ subroutine update_current_new_file_freq_index(this, time_step)
diag_file%next_close = diag_file%no_more_data
endif
endif
+
+ if (diag_file%is_static) diag_file%done_writing_data = .true.
end subroutine update_current_new_file_freq_index
!> \brief Set up the next_output and next_next_output variable in a file obj
@@ -1494,13 +1513,32 @@ subroutine update_next_write(this, time_step)
end subroutine update_next_write
-!> \brief Increase the unlimited dimension level that the file is currently being written to
-subroutine increase_unlim_dimension_level(this)
+!> \brief Prepare the diag file for the force_write
+subroutine prepare_for_force_write(this)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+
+ if (this%FMS_diag_file%unlim_dimension_level .eq. 0) then
+ this%FMS_diag_file%unlim_dimension_level = 1
+ this%FMS_diag_file%data_has_been_written = .true.
+ endif
+end subroutine prepare_for_force_write
+
+!> \brief Initialize the unlim dimension in the file and in its buffer objects to 0
+subroutine init_unlim_dim(this, output_buffers)
class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ type(fmsDiagOutputBuffer_type), intent(in), target :: output_buffers(:) !< Array of output buffer.
- this%FMS_diag_file%unlim_dimension_level = this%FMS_diag_file%unlim_dimension_level + 1
- this%FMS_diag_file%data_has_been_written = .false.
-end subroutine increase_unlim_dimension_level
+ class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object
+ type(fmsDiagOutputBuffer_type), pointer :: output_buffer_obj !< Buffer object
+ integer :: i !< For looping through buffers
+
+ diag_file => this%FMS_diag_file
+ diag_file%unlim_dimension_level = 0
+ do i = 1, diag_file%number_of_buffers
+ output_buffer_obj => output_buffers(diag_file%buffer_ids(i))
+ call output_buffer_obj%init_buffer_unlim_dim()
+ enddo
+end subroutine init_unlim_dim
!> \brief Get the unlimited dimension level that is in the file
!! \return The unlimited dimension
@@ -1716,6 +1754,24 @@ subroutine close_diag_file(this, output_buffers, diag_fields)
if (this%FMS_diag_file%has_send_data_been_called(output_buffers, .True., diag_fields)) return
end subroutine close_diag_file
+!> \brief Set the model time for the diag file object
+subroutine set_model_time(this, model_time)
+ class(fmsDiagFileContainer_type), intent(inout) :: this !< The file object
+ type(time_type), intent(in) :: model_time !< Model time to add
+
+ if (model_time > this%FMS_diag_file%model_time) this%FMS_diag_file%model_time = model_time
+end subroutine
+
+!> \brief Get the model time from the file object
+!! \result A pointer to the model time
+function get_model_time(this) &
+ result(rslt)
+ class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file object
+ type(time_type), pointer :: rslt
+
+ rslt => this%FMS_diag_file%model_time
+end function get_model_time
+
!> \brief Gets the buffer_id list from the file object
pure function get_buffer_ids (this)
class(fmsDiagFile_type), intent(in) :: this !< The file object
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 2c8e04d9df..11ad58a8aa 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -26,7 +26,7 @@ module fms_diag_object_mod
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
& OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, &
- & get_ticks_per_second
+ & get_ticks_per_second, date_to_string
#ifdef use_yaml
use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init
use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init, get_default_missing_value, &
@@ -63,7 +63,6 @@ module fms_diag_object_mod
!! one for each variable in the diag_table.yaml
integer, private :: registered_buffers = 0 !< number of registered buffers, per dimension
class(fmsDiagAxisContainer_type), allocatable :: diag_axis(:) !< Array of diag_axis
- type(time_type) :: current_model_time !< The current model time
integer, private :: registered_variables !< Number of registered variables
integer, private :: registered_axis !< Number of registered axis
logical, private :: initialized=.false. !< True if the fmsDiagObject is initialized
@@ -95,7 +94,6 @@ module fms_diag_object_mod
procedure :: fms_diag_field_add_cell_measures
procedure :: allocate_diag_field_output_buffers
procedure :: fms_diag_compare_window
- procedure :: update_current_model_time
#ifdef use_yaml
procedure :: get_diag_buffer
#endif
@@ -134,7 +132,6 @@ subroutine fms_diag_object_init (this,diag_subset_output)
this%buffers_initialized =fms_diag_output_buffer_init(this%FMS_diag_output_buffers,SIZE(diag_yaml%get_diag_fields()))
this%registered_variables = 0
this%registered_axis = 0
- this%current_model_time = get_base_time()
this%initialized = .true.
#else
call mpp_error("fms_diag_object_init",&
@@ -265,7 +262,7 @@ integer function fms_register_diag_field_obj &
call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i))
call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i), &
fieldptr%buffer_ids(i), this%FMS_diag_output_buffers)
- call fileptr%add_start_time(init_time, this%current_model_time)
+ call fileptr%add_start_time(init_time)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
elseif (present(axes)) then !only axes present
@@ -288,7 +285,7 @@ integer function fms_register_diag_field_obj &
fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file
call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i))
call fileptr%add_buffer_id(fieldptr%buffer_ids(i))
- call fileptr%add_start_time(init_time, this%current_model_time)
+ call fileptr%add_start_time(init_time)
call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static())
enddo
else !no axis or init time present
@@ -312,7 +309,8 @@ integer function fms_register_diag_field_obj &
call bufferptr%set_diurnal_sample_size(yamlfptr%get_n_diurnal())
endif
call bufferptr%init_buffer_time(init_time)
- call bufferptr%set_next_output(this%FMS_diag_files(file_ids(i))%get_next_output(), fieldptr%is_static())
+ call bufferptr%set_next_output(this%FMS_diag_files(file_ids(i))%get_next_output(), &
+ this%FMS_diag_files(file_ids(i))%get_next_next_output(), is_static=fieldptr%is_static())
enddo
nullify (fileptr)
@@ -644,8 +642,6 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
!> Only 1 thread allocates the output buffer and sets set_math_needs_to_be_done
!$omp critical
- if (present(time)) call this%update_current_model_time(time)
-
!< These set_* calls need to be done inside an omp_critical to avoid any race conditions
!! and allocation issues
if(has_halos) call this%FMS_diag_fields(diag_field_id)%set_halo_present()
@@ -675,7 +671,6 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm
fms_diag_accept_data = .TRUE.
return
else
- if (present(time)) call this%update_current_model_time(time)
!< At this point if we are no longer in an openmp region or running with 1 thread
!! so it is safe to have these set_* calls
@@ -808,32 +803,38 @@ subroutine fms_diag_do_io(this, end_time)
class(*), allocatable :: missing_val !< netcdf missing value for a given field
real(r8_kind) :: mval !< r8 copy of missing value
character(len=128) :: error_string !< outputted error string from reducti
+ logical :: unlim_dim_was_increased !< .True. if the unlimited dimension index was increased for any of the buffers
force_write = .false.
- if (present (end_time)) then
- force_write = .true.
- model_time => end_time
- else
- model_time => this%current_model_time
- endif
do i = 1, size(this%FMS_diag_files)
diag_file => this%FMS_diag_files(i)
!< Go away if the file is a subregional file and the current PE does not have any data for it
if (.not. diag_file%writing_on_this_pe()) cycle
+ if (diag_file%FMS_diag_file%is_done_writing_data()) cycle
+
+ if (present (end_time)) then
+ force_write = .true.
+ model_time => end_time
+ else
+ model_time => diag_file%get_model_time()
+ endif
call diag_file%open_diag_file(model_time, file_is_opened_this_time_step)
if (file_is_opened_this_time_step) then
+ ! Initialize unlimited dimension in file and the buffer to 0
+ call diag_file%init_unlim_dim(this%FMS_diag_output_buffers)
+
call diag_file%write_global_metadata()
call diag_file%write_axis_metadata(this%diag_axis)
call diag_file%write_time_metadata()
call diag_file%write_field_metadata(this%FMS_diag_fields, this%diag_axis)
call diag_file%write_axis_data(this%diag_axis)
- call diag_file%increase_unlim_dimension_level()
endif
finish_writing = diag_file%is_time_to_write(model_time, this%FMS_diag_output_buffers)
+ unlim_dim_was_increased = .false.
! finish reduction method if its time to write
buff_ids = diag_file%FMS_diag_file%get_buffer_ids()
@@ -858,22 +859,25 @@ subroutine fms_diag_do_io(this, end_time)
mval, diag_field%get_var_is_masked(), diag_field%get_mask_variant())
endif
endif
- call diag_file%write_field_data(diag_field, diag_buff)
- call diag_buff%set_next_output(diag_file%get_next_next_output())
+ call diag_file%write_field_data(diag_field, diag_buff, unlim_dim_was_increased)
+ call diag_buff%set_next_output(diag_file%get_next_output(), diag_file%get_next_next_output())
endif
nullify(diag_buff)
nullify(field_yaml)
enddo buff_loop
deallocate(buff_ids)
- if (finish_writing) then
+ if (unlim_dim_was_increased) then
call diag_file%write_time_data()
call diag_file%update_next_write(model_time)
+ endif
+
+ if (finish_writing) then
call diag_file%update_current_new_file_freq_index(model_time)
- call diag_file%increase_unlim_dimension_level()
if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file(this%FMS_diag_output_buffers, &
diag_fields = this%FMS_diag_fields)
else if (force_write) then
+ call diag_file%prepare_for_force_write()
call diag_file%write_time_data()
call diag_file%close_diag_file(this%FMS_diag_output_buffers, diag_fields = this%FMS_diag_fields)
endif
@@ -963,6 +967,8 @@ function fms_diag_do_reduction(this, field_data, diag_field_id, oor_mask, weight
!< Go away if finished doing math for this buffer
if (buffer_ptr%is_done_with_math()) cycle
+ if (present(time)) call file_ptr%set_model_time(time)
+
bounds_out = bounds
if (.not. using_blocking) then
!< Set output bounds to start at 1:size(buffer_ptr%buffer)
@@ -1484,13 +1490,4 @@ function fms_diag_compare_window(this, field, field_id, &
#endif
end function fms_diag_compare_window
-!> @brief Update the current model time in the diag object
-subroutine update_current_model_time(this, time)
- class(fmsDiagObject_type), intent(inout) :: this !< Diag Object
- type(time_type), intent(in) :: time !< Current diag manager time
-#ifdef use_yaml
- if(time > this%current_model_time) this%current_model_time = time
-#endif
-end subroutine update_current_model_time
-
end module fms_diag_object_mod
diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90
index a2bad476be..15a96362fe 100644
--- a/diag_manager/fms_diag_output_buffer.F90
+++ b/diag_manager/fms_diag_output_buffer.F90
@@ -62,6 +62,7 @@ module fms_diag_output_buffer_mod
integer :: diurnal_section= -1 !< the diurnal section (ie 5th index) calculated from the current model
!! time and sample size if using a diurnal reduction
logical, allocatable :: send_data_called !< .True. if send_data has been called
+ integer :: unlmited_dimension !< Unlimited dimension index of the last write for this output buffer
type(time_type) :: time !< The last time the data was received
type(time_type) :: next_output !< The next time to output the data
@@ -81,6 +82,9 @@ module fms_diag_output_buffer_mod
procedure :: is_done_with_math
procedure :: set_done_with_math
procedure :: write_buffer
+ procedure :: init_buffer_unlim_dim
+ procedure :: increase_unlim_dim
+ procedure :: get_unlim_dim
!! These are needed because otherwise the write_data calls will go into the wrong interface
procedure :: write_buffer_wrapper_netcdf
procedure :: write_buffer_wrapper_domain
@@ -352,22 +356,37 @@ subroutine init_buffer_time(this, time)
if (present(time)) then
this%time = time
+ this%next_output = time
else
this%time = get_base_time()
+ this%next_output = this%time
endif
end subroutine init_buffer_time
!> @brief Sets the next output
-subroutine set_next_output(this, time, is_static)
- class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
- type(time_type), intent(in) :: time !< time to add to the buffer
- logical, optional, intent(in) :: is_static !< .True. if the field is static
+subroutine set_next_output(this, next_output, next_next_output, is_static)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object
+ type(time_type), intent(in) :: next_output !< The current next_output in the file obj
+ type(time_type), intent(in) :: next_next_output !< The current next_next_output in the file obj
+ logical, optional, intent(in) :: is_static !< .True. if the field is static
- this%next_output = time
if (present(is_static)) then
!< If the field is static set the next_output to be equal to time
!! this should only be used in the init, so next_output will be equal to the the init time
- if (is_static) this%next_output = this%time
+ if (is_static) then
+ this%next_output = this%time
+ return
+ endif
+ endif
+
+ !< If the file's next_output is greater than the buffer's next output set
+ !! the buffer's next output to the file's next_ouput, otherwise use the file's
+ !! next_next_output
+ !! This is needed for when file have fields that get data send data sent at different frequencies
+ if (next_output > this%next_output) then
+ this%next_output = next_output
+ else
+ this%next_output = next_next_output
endif
end subroutine set_next_output
@@ -410,6 +429,30 @@ function get_yaml_id(this) &
res = this%yaml_id
end function get_yaml_id
+!> @brief Get the unlim dimension index of the buffer object
+!! @return The unlim dimension index of the buffer object
+function get_unlim_dim(this) &
+ result(res)
+ class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write
+ integer :: res
+
+ res = this%unlmited_dimension
+end function get_unlim_dim
+
+!> @brief Increase the unlim dimension index of the buffer object
+subroutine increase_unlim_dim(this)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
+
+ this%unlmited_dimension = this%unlmited_dimension + 1
+end subroutine increase_unlim_dim
+
+!> @brief Init the unlim dimension index of the buffer object to 0
+subroutine init_buffer_unlim_dim(this)
+ class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
+
+ this%unlmited_dimension = 0
+end subroutine init_buffer_unlim_dim
+
!> @brief Write the buffer to the file
subroutine write_buffer(this, fms2io_fileobj, unlim_dim_level, is_diurnal)
class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to write
From d8bf2dbccf0b473347c7b975a2d97d3e5931c02c Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Thu, 18 Apr 2024 13:34:18 -0400
Subject: [PATCH 164/168] feat: diag manager output yaml routine (#1080)
---
diag_manager/fms_diag_field_object.F90 | 49 +-
diag_manager/fms_diag_object.F90 | 7 +-
diag_manager/fms_diag_yaml.F90 | 450 ++++++++++++++++++-
test_fms/diag_manager/Makefile.am | 3 +-
test_fms/diag_manager/test_diag_manager2.sh | 413 ++++++++++++++++-
test_fms/diag_manager/test_diag_out_yaml.F90 | 61 +++
6 files changed, 969 insertions(+), 14 deletions(-)
create mode 100644 test_fms/diag_manager/test_diag_out_yaml.F90
diff --git a/diag_manager/fms_diag_field_object.F90 b/diag_manager/fms_diag_field_object.F90
index 4e4eb15025..550037a904 100644
--- a/diag_manager/fms_diag_field_object.F90
+++ b/diag_manager/fms_diag_field_object.F90
@@ -216,7 +216,7 @@ end subroutine fms_diag_field_object_end
!! Sets the diag_id to the not registered value.
!! Initializes the number of registered variables to be 0
logical function fms_diag_fields_object_init(ob)
- class (fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object
+ type(fmsDiagField_type), allocatable, intent(inout) :: ob(:) !< diag field object
integer :: i !< For looping
allocate(ob(get_num_unique_fields()))
do i = 1,size(ob)
@@ -261,6 +261,9 @@ subroutine fms_register_diag_field_obj &
LOGICAL, OPTIONAL, INTENT(in) :: static !< Set to true if it is a static field
LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple
!! times for the same time
+ integer :: i, j !< for looponig over field/axes indices
+ character(len=:), allocatable, target :: a_name_tmp !< axis name tmp
+ type(diagYamlFilesVar_type), pointer :: yaml_var_ptr !< pointer this fields yaml variable entries
!> Fill in information from the register call
this%varname = trim(varname)
@@ -269,17 +272,56 @@ subroutine fms_register_diag_field_obj &
!> Add the yaml info to the diag_object
this%diag_field = get_diag_fields_entries(diag_field_indices)
+ if (present(static)) then
+ this%static = static
+ else
+ this%static = .false.
+ endif
+
!> Add axis and domain information
if (present(axes)) then
+
this%scalar = .false.
this%axis_ids = axes
call get_domain_and_domain_type(diag_axis, this%axis_ids, this%type_of_domain, this%domain, this%varname)
+
+ ! store dim names for output
+ ! cant use this%diag_field since they are copies
+ do i=1, SIZE(diag_field_indices)
+ yaml_var_ptr => diag_yaml%get_diag_field_from_id(diag_field_indices(i))
+ ! add dim names from axes
+ do j=1, SIZE(axes)
+ a_name_tmp = diag_axis(axes(j))%axis%get_axis_name( yaml_var_ptr%is_file_subregional())
+ if(yaml_var_ptr%has_var_zbounds() .and. a_name_tmp .eq. 'z') &
+ a_name_tmp = trim(a_name_tmp)//"_sub01"
+ call yaml_var_ptr%add_axis_name(a_name_tmp)
+ enddo
+ ! add time_of_day_N dimension if diurnal
+ if(yaml_var_ptr%has_n_diurnal()) then
+ a_name_tmp = "time_of_day_"// int2str(yaml_var_ptr%get_n_diurnal())
+ call yaml_var_ptr%add_axis_name(a_name_tmp)
+ endif
+ ! add time dimension if not static
+ if(.not. this%static) then
+ a_name_tmp = "time"
+ call yaml_var_ptr%add_axis_name(a_name_tmp)
+ endif
+ enddo
else
!> The variable is a scalar
this%scalar = .true.
this%type_of_domain = NO_DOMAIN
this%domain => null()
+ ! store dim name for output (just the time if not static and no axes)
+ if(.not. this%static) then
+ do i=1, SIZE(diag_field_indices)
+ a_name_tmp = "time"
+ yaml_var_ptr => diag_yaml%get_diag_field_from_id(diag_field_indices(i))
+ call yaml_var_ptr%add_axis_name(a_name_tmp)
+ enddo
+ endif
endif
+ nullify(yaml_var_ptr)
!> get the optional arguments if included and the diagnostic is in the diag table
if (present(longname)) this%longname = trim(longname)
@@ -296,11 +338,6 @@ subroutine fms_register_diag_field_obj &
allocate(this%tile_count)
this%tile_count = tile_count
endif
- if (present(static)) then
- this%static = static
- else
- this%static = .false.
- endif
if (present(missing_value)) then
select type (missing_value)
diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90
index 11ad58a8aa..661455afdc 100644
--- a/diag_manager/fms_diag_object.F90
+++ b/diag_manager/fms_diag_object.F90
@@ -32,7 +32,7 @@ module fms_diag_object_mod
use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init, get_default_missing_value, &
check_for_slices
use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, find_diag_field, &
- & get_diag_files_id, diag_yaml, get_diag_field_ids, DiagYamlFilesVar_type
+ & get_diag_files_id, diag_yaml, get_diag_field_ids, DiagYamlFilesVar_type, fms_diag_yaml_out
use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, &
&diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, &
&fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, &
@@ -58,7 +58,7 @@ module fms_diag_object_mod
private
!TODO: Remove FMS prefix from variables in this type
class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files
- class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields
+ type(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields
type(fmsDiagOutputBuffer_type), allocatable :: FMS_diag_output_buffers(:) !< array of output buffer objects
!! one for each variable in the diag_table.yaml
integer, private :: registered_buffers = 0 !< number of registered buffers, per dimension
@@ -152,6 +152,9 @@ subroutine fms_diag_object_end (this, time)
!TODO: loop through files and force write
if (.not. this%initialized) return
+ ! write output yaml
+ call fms_diag_yaml_out()
+
call this%do_buffer_math()
call this%fms_diag_do_io(end_time=time)
!TODO: Deallocate diag object arrays and clean up all memory
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index cfd1802fcd..65f310d4ca 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -37,10 +37,13 @@ module fms_diag_yaml_mod
middle_time, begin_time, end_time, MAX_STR_LEN
use yaml_parser_mod, only: open_and_parse_file, get_value_from_key, get_num_blocks, get_nkeys, &
get_block_ids, get_key_value, get_key_ids, get_key_name
+use fms_yaml_output_mod, only: fmsYamlOutKeys_type, fmsYamlOutValues_type, write_yaml_from_struct_3, &
+ yaml_out_add_level2key, initialize_key_struct, initialize_val_struct
use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe, mpp_root_pe, stdout
use, intrinsic :: iso_c_binding, only : c_ptr, c_null_char
-use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique, string
-use platform_mod, only: r4_kind, i4_kind
+use fms_string_utils_mod, only: fms_array_to_pointer, fms_find_my_string, fms_sort_this, fms_find_unique, string, &
+ fms_f2c_string
+use platform_mod, only: r4_kind, i4_kind, r8_kind, i8_kind
use fms_mod, only: lowercase
implicit none
@@ -54,6 +57,7 @@ module fms_diag_yaml_mod
public :: get_num_unique_fields, find_diag_field, get_diag_fields_entries, get_diag_files_id
public :: get_diag_field_ids
public :: dump_diag_yaml_obj
+public :: fms_diag_yaml_out
public :: MAX_SUBAXES
!> @}
@@ -128,6 +132,9 @@ module fms_diag_yaml_mod
!< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
character (len=MAX_STR_LEN), allocatable :: file_varlist(:) !< An array of variable names
!! within a file
+ character (len=MAX_STR_LEN), allocatable :: file_outlist(:) !< An array of variable output names
+ !! within a file, used to distinguish
+ !! varlist names for yaml output
character (len=MAX_STR_LEN), allocatable :: file_global_meta(:,:) !< Array of key(dim=1)
!! and values(dim=2) to be
!! added as global meta data to
@@ -187,10 +194,13 @@ module fms_diag_yaml_mod
!! 0 if var_reduction is not "diurnalXX"
integer , private :: pow_value !< The power value
!! 0 if pow_value is not "powXX"
+ logical , private :: var_file_is_subregional !< true if the file this entry
+ !! belongs to is subregional
!< Need to use `MAX_STR_LEN` because not all filenames/global attributes are the same length
character (len=MAX_STR_LEN), dimension (:, :), private, allocatable :: var_attributes !< Attributes to overwrite or
!! add from diag_yaml
+ character(len=:), allocatable :: var_axes_names !< list of axes names
contains
!> All getter functions (functions named get_x(), for member field named x)
!! return copies of the member variables unless explicitly noted.
@@ -220,6 +230,8 @@ module fms_diag_yaml_mod
procedure :: has_var_attributes
procedure :: has_n_diurnal
procedure :: has_pow_value
+ procedure :: add_axis_name
+ procedure :: is_file_subregional
end type diagYamlFilesVar_type
@@ -247,7 +259,7 @@ module fms_diag_yaml_mod
end type diagYamlObject_type
type (diagYamlObject_type), target :: diag_yaml !< Obj containing the contents of the diag_table.yaml
-type (varList_type), save :: variable_list !< List of all the variables in the diag_table.yaml
+type (varList_type), save :: variable_list !< List of all the variables in the diag_table.yaml
type (fileList_type), save :: file_list !< List of all files in the diag_table.yaml
logical, private :: diag_yaml_module_initialized = .false.
@@ -434,6 +446,7 @@ subroutine diag_yaml_object_init(diag_subset_output)
call get_block_ids(diag_yaml_id, "varlist", var_ids, parent_block_id=diag_file_ids(i))
file_var_count = 0
allocate(diag_yaml%diag_files(file_count)%file_varlist(get_total_num_vars(diag_yaml_id, diag_file_ids(i))))
+ allocate(diag_yaml%diag_files(file_count)%file_outlist(get_total_num_vars(diag_yaml_id, diag_file_ids(i))))
nvars_loop: do j = 1, nvars
write_var = .true.
call get_value_from_key(diag_yaml_id, var_ids(j), "write_var", write_var, is_optional=.true.)
@@ -445,10 +458,19 @@ subroutine diag_yaml_object_init(diag_subset_output)
!> Save the filename in the diag_field type
diag_yaml%diag_fields(var_count)%var_fname = diag_yaml%diag_files(file_count)%file_fname
+ !> initialize axes string
+ diag_yaml%diag_fields(var_count)%var_axes_names = ""
+ diag_yaml%diag_fields(var_count)%var_file_is_subregional = diag_yaml%diag_files(file_count)%has_file_sub_region()
+
call fill_in_diag_fields(diag_yaml_id, var_ids(j), diag_yaml%diag_fields(var_count))
!> Save the variable name in the diag_file type
diag_yaml%diag_files(file_count)%file_varlist(file_var_count) = diag_yaml%diag_fields(var_count)%var_varname
+ if(diag_yaml%diag_fields(var_count)%has_var_outname()) then
+ diag_yaml%diag_files(file_count)%file_outlist(file_var_count) = diag_yaml%diag_fields(var_count)%var_outname
+ else
+ diag_yaml%diag_files(file_count)%file_outlist(file_var_count) = ""
+ endif
!> Save the variable name and the module name in the variable_list
variable_list%var_name(var_count) = trim(diag_yaml%diag_fields(var_count)%var_varname)//&
@@ -477,6 +499,7 @@ subroutine diag_yaml_object_end()
do i = 1, size(diag_yaml%diag_files, 1)
if(allocated(diag_yaml%diag_files(i)%file_varlist)) deallocate(diag_yaml%diag_files(i)%file_varlist)
+ if(allocated(diag_yaml%diag_files(i)%file_outlist)) deallocate(diag_yaml%diag_files(i)%file_outlist)
if(allocated(diag_yaml%diag_files(i)%file_global_meta)) deallocate(diag_yaml%diag_files(i)%file_global_meta)
if(allocated(diag_yaml%diag_files(i)%file_sub_region%corners)) &
deallocate(diag_yaml%diag_files(i)%file_sub_region%corners)
@@ -515,6 +538,8 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, yaml_fileobj)
character(len=:), ALLOCATABLE :: grid_type !< grid_type as it is read in from the yaml
character(len=:), ALLOCATABLE :: buffer !< buffer to store any *_units as it is read from the yaml
+ yaml_fileobj%file_frequnit = 0
+
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", yaml_fileobj%file_fname)
call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq", buffer)
call parse_key(yaml_fileobj%file_fname, buffer, yaml_fileobj%file_freq, yaml_fileobj%file_frequnit, "freq")
@@ -1489,7 +1514,7 @@ subroutine dump_diag_yaml_obj( filename )
if( diag_yaml%has_diag_basedate()) write(unit_num, *) 'basedate array:', diag_yaml%diag_basedate
write(unit_num, *) 'FILES'
allocate(fields(SIZE(diag_yaml%get_diag_fields())))
- files => diag_yaml%diag_files
+ files => diag_yaml%diag_files
fields = diag_yaml%get_diag_fields()
do i=1, SIZE(files)
write(unit_num, *) 'File: ', files(i)%get_file_fname()
@@ -1534,6 +1559,423 @@ subroutine dump_diag_yaml_obj( filename )
endif
end subroutine
+!> Writes an output yaml with all available information on the written files.
+!! Will only write with root pe.
+!! Global attributes are limited to 16 per file.
+subroutine fms_diag_yaml_out()
+ type(diagYamlFiles_type), pointer :: fileptr !< pointer for individual variables
+ type(diagYamlFilesVar_type), pointer :: varptr !< pointer for individual variables
+ type (fmsyamloutkeys_type), allocatable :: keys(:), keys2(:), keys3(:)
+ type (fmsyamloutvalues_type), allocatable :: vals(:), vals2(:), vals3(:)
+ integer :: i, j, k
+ character(len=128) :: tmpstr1, tmpstr2 !< string to store output fields
+ integer, parameter :: tier1size = 3 !< size of first tier, will always be 3 for basedate, title and diag_files
+ integer :: tier2size, tier3size !< size of each 'tier'(based one numbers of tabs) in the yaml
+ integer, allocatable :: tier3each(:) !< tier 3 list sizes corresponding to where they are in the second tier
+ integer, dimension(basedate_size) :: basedate_loc !< local copy of basedate to loop through
+ integer :: varnum_i, key3_i, gm
+ character(len=32), allocatable :: st_vals(:) !< start times for gcc bug
+
+ if( mpp_pe() .ne. mpp_root_pe()) return
+
+ allocate(tier3each(SIZE(diag_yaml%diag_files) * 3))
+ tier3size = 0; tier3each = 0
+
+ !! allocations for key+val structs
+ allocate(keys(1))
+ allocate(vals(1))
+ allocate(keys2(SIZE(diag_yaml%diag_files)))
+ allocate(vals2(SIZE(diag_yaml%diag_files)))
+ allocate(st_vals(SIZE(diag_yaml%diag_files)))
+ do i=1, SIZE(diag_yaml%diag_files)
+ call initialize_key_struct(keys2(i))
+ call initialize_val_struct(vals2(i))
+ if (allocated(diag_yaml%diag_files(i)%file_varlist) ) then
+ do j=1, SIZE(diag_yaml%diag_files(i)%file_varlist)
+ tier3size = tier3size + 1
+ enddo
+ endif
+ tier3size = tier3size + 2
+ enddo
+ allocate(keys3(tier3size))
+ allocate(vals3(tier3size))
+
+ !! tier 1 - title, basedate, diag_files
+ call initialize_key_struct(keys(1))
+ call initialize_val_struct(vals(1))
+ call fms_f2c_string( keys(1)%key1, 'title')
+ call fms_f2c_string( vals(1)%val1, diag_yaml%diag_title)
+ call fms_f2c_string( keys(1)%key2, 'base_date')
+ basedate_loc = diag_yaml%get_basedate()
+ tmpstr1 = ''; tmpstr2 = ''
+ tmpstr1 = string(basedate_loc(1))
+ tmpstr2 = trim(tmpstr1)
+ do i=2, basedate_size
+ tmpstr1 = string(basedate_loc(i))
+ tmpstr2 = trim(tmpstr2) // ' ' // trim(tmpstr1)
+ enddo
+ call fms_f2c_string(vals(1)%val2, trim(tmpstr2))
+ call yaml_out_add_level2key('diag_files', keys(1))
+ key3_i = 0
+ !! tier 2 - diag files
+ do i=1, SIZE(diag_yaml%diag_files)
+ fileptr => diag_yaml%diag_files(i)
+
+ call fms_f2c_string(keys2(i)%key1, 'file_name')
+ call fms_f2c_string(keys2(i)%key2, 'freq')
+ call fms_f2c_string(keys2(i)%key3, 'freq_units')
+ call fms_f2c_string(keys2(i)%key4, 'time_units')
+ call fms_f2c_string(keys2(i)%key5, 'unlimdim')
+ call fms_f2c_string(keys2(i)%key6, 'new_file_freq')
+ call fms_f2c_string(keys2(i)%key7, 'new_file_freq_units')
+ call fms_f2c_string(keys2(i)%key8, 'start_time')
+ call fms_f2c_string(keys2(i)%key9, 'file_duration')
+ call fms_f2c_string(keys2(i)%key10, 'file_duration_units')
+
+ call fms_f2c_string(vals2(i)%val1, fileptr%file_fname)
+ call fms_f2c_string(vals2(i)%val5, fileptr%file_unlimdim)
+ call fms_f2c_string(vals2(i)%val4, get_diag_unit_string((/fileptr%file_timeunit/)))
+ tmpstr1 = ''
+ do k=1, SIZE(fileptr%file_freq)
+ if(fileptr%file_freq(k) .eq. diag_null) exit
+ tmpstr2 = ''
+ tmpstr2 = string(fileptr%file_freq(k))
+ tmpstr1 = trim(tmpstr1)//" "//trim(tmpstr2)
+ enddo
+ call fms_f2c_string(vals2(i)%val2, adjustl(tmpstr1))
+ call fms_f2c_string(vals2(i)%val3, get_diag_unit_string(fileptr%file_frequnit))
+ tmpstr1 = ''
+ do k=1, SIZE(fileptr%file_new_file_freq)
+ if(fileptr%file_new_file_freq(k) .eq. diag_null) exit
+ tmpstr2 = ''
+ tmpstr2 = string(fileptr%file_new_file_freq(k))
+ tmpstr1 = trim(tmpstr1)//" "//trim(tmpstr2)
+ enddo
+ call fms_f2c_string(vals2(i)%val6, adjustl(tmpstr1))
+ call fms_f2c_string(vals2(i)%val7, get_diag_unit_string(fileptr%file_new_file_freq_units))
+ call fms_f2c_string(vals2(i)%val8, trim(fileptr%get_file_start_time()))
+ st_vals(i) = fileptr%get_file_start_time()
+ tmpstr1 = ''
+ do k=1, SIZE(fileptr%file_duration)
+ if(fileptr%file_duration(k) .eq. diag_null) exit
+ tmpstr2 = ''
+ tmpstr2 = string(fileptr%file_duration(k))
+ tmpstr1 = trim(tmpstr1)//" "//trim(tmpstr2)
+ enddo
+ call fms_f2c_string(vals2(i)%val9, adjustl(tmpstr1))
+ call fms_f2c_string(vals2(i)%val10, get_diag_unit_string(fileptr%file_duration_units))
+
+ !! tier 3 - varlists, subregion, global metadata
+ call yaml_out_add_level2key('varlist', keys2(i))
+ j = 0
+ if( SIZE(fileptr%file_varlist) .gt. 0) then
+ do j=1, SIZE(fileptr%file_varlist)
+ key3_i = key3_i + 1
+ call initialize_key_struct(keys3(key3_i))
+ call initialize_val_struct(vals3(key3_i))
+ !! find the variable object from the list
+ varptr => NULL()
+ do varnum_i=1, SIZE(diag_yaml%diag_fields)
+ if( trim(diag_yaml%diag_fields(varnum_i)%var_varname ) .eq. trim(fileptr%file_varlist(j)) .and. &
+ trim(diag_yaml%diag_fields(varnum_i)%var_fname) .eq. trim(fileptr%file_fname)) then
+ ! if theres a output name, that should match as well
+ if(diag_yaml%diag_fields(varnum_i)%has_var_outname()) then
+ if(trim(diag_yaml%diag_fields(varnum_i)%var_outname) .eq. trim(fileptr%file_outlist(j))) then
+ varptr => diag_yaml%diag_fields(varnum_i)
+ exit
+ endif
+ else
+ varptr => diag_yaml%diag_fields(varnum_i)
+ exit
+ endif
+ endif
+ enddo
+ if( .not. associated(varptr)) call mpp_error(FATAL, "diag_yaml_output: could not find variable in list."//&
+ " var: "// trim(fileptr%file_varlist(j)))
+ call fms_f2c_string(keys3(key3_i)%key1, 'module')
+ call fms_f2c_string(keys3(key3_i)%key2, 'var_name')
+ call fms_f2c_string(keys3(key3_i)%key3, 'reduction')
+ call fms_f2c_string(keys3(key3_i)%key4, 'kind')
+ call fms_f2c_string(keys3(key3_i)%key5, 'output_name')
+ call fms_f2c_string(keys3(key3_i)%key6, 'long_name')
+ call fms_f2c_string(keys3(key3_i)%key7, 'units')
+ call fms_f2c_string(keys3(key3_i)%key8, 'zbounds')
+ call fms_f2c_string(keys3(key3_i)%key9, 'n_diurnal')
+ call fms_f2c_string(keys3(key3_i)%key10, 'pow_value')
+ call fms_f2c_string(keys3(key3_i)%key11, 'dimensions')
+ if (varptr%has_var_module()) call fms_f2c_string(vals3(key3_i)%val1, varptr%var_module)
+ if (varptr%has_var_varname()) call fms_f2c_string(vals3(key3_i)%val2, varptr%var_varname)
+ if (varptr%has_var_reduction()) then
+ call fms_f2c_string(vals3(key3_i)%val3, &
+ get_diag_reduction_string((/varptr%var_reduction/)))
+ endif
+ if (varptr%has_var_outname()) call fms_f2c_string(vals3(key3_i)%val5, varptr%var_outname)
+ if (varptr%has_var_longname()) call fms_f2c_string(vals3(key3_i)%val6, varptr%var_longname)
+ if (varptr%has_var_units()) call fms_f2c_string(vals3(key3_i)%val7, varptr%var_units)
+ if (varptr%has_var_kind()) then
+ select case(varptr%var_kind)
+ case(i4)
+ call fms_f2c_string(vals3(key3_i)%val4, 'i4')
+ case(i8)
+ call fms_f2c_string(vals3(key3_i)%val4, 'i8')
+ case(r4)
+ call fms_f2c_string(vals3(key3_i)%val4, 'r4')
+ case(r8)
+ call fms_f2c_string(vals3(key3_i)%val4, 'r8')
+ end select
+ endif
+
+ if( abs(varptr%var_zbounds(1) - real(diag_null, r4_kind)) .gt. 1.0e-5 ) then
+ tmpstr2 = string(varptr%var_zbounds(1), "F8.2") // ' ' // string(varptr%var_zbounds(2), "F8.2")
+ call fms_f2c_string(vals3(key3_i)%val8, trim(tmpstr2))
+ endif
+
+ if( varptr%n_diurnal .gt. 0) then
+ tmpstr1 = ''; tmpstr1 = string(varptr%n_diurnal)
+ call fms_f2c_string(vals3(key3_i)%val9, tmpstr1)
+ endif
+
+ if( varptr%pow_value .gt. 0) then
+ tmpstr1 = ''; tmpstr1 = string(varptr%pow_value)
+ call fms_f2c_string(vals3(key3_i)%val10, tmpstr1)
+ endif
+
+ tmpstr1 = ''; tmpstr1 = varptr%var_axes_names
+ call fms_f2c_string(vals3(key3_i)%val11, trim(adjustl(tmpstr1)))
+ enddo
+ endif
+
+ key3_i = key3_i + 1
+ tier3each(i*3-2) = j-1 ! j-1 structs to print for varlist keys
+ tier3each(i*3-1) = 1 ! 1 struct per sub_region key
+ tier3each(i*3) = 1 ! 1 struct per global metadata key
+ call initialize_key_struct(keys3(key3_i))
+ call initialize_val_struct(vals3(key3_i))
+ !! sub region
+ call yaml_out_add_level2key('sub_region', keys2(i))
+ call fms_f2c_string(keys3(key3_i)%key1, 'grid_type')
+ call fms_f2c_string(keys3(key3_i)%key2, 'tile')
+ call fms_f2c_string(keys3(key3_i)%key3, 'corner1')
+ call fms_f2c_string(keys3(key3_i)%key4, 'corner2')
+ call fms_f2c_string(keys3(key3_i)%key5, 'corner3')
+ call fms_f2c_string(keys3(key3_i)%key6, 'corner4')
+
+ select case (fileptr%file_sub_region%grid_type)
+ case(latlon_gridtype)
+ call fms_f2c_string(vals3(key3_i)%val1, 'latlon')
+ case(index_gridtype)
+ call fms_f2c_string(vals3(key3_i)%val1, 'index')
+ end select
+ if(fileptr%file_sub_region%tile .ne. diag_null) then
+ tmpstr1 = ''; tmpstr1 = string(fileptr%file_sub_region%tile)
+ call fms_f2c_string(vals3(key3_i)%val2, tmpstr1)
+ endif
+ if(fileptr%has_file_sub_region()) then
+ if( allocated(fileptr%file_sub_region%corners)) then
+ select type (corners => fileptr%file_sub_region%corners)
+ type is (real(r8_kind))
+ tmpstr1 = ''; tmpstr1 = string(corners(1,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(1,2))
+ call fms_f2c_string(vals3(key3_i)%val3, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(2,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(2,2))
+ call fms_f2c_string(vals3(key3_i)%val4, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(3,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(3,2))
+ call fms_f2c_string(vals3(key3_i)%val5, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(4,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(4,2))
+ call fms_f2c_string(vals3(key3_i)%val6, trim(tmpstr1)//' '//trim(tmpstr2))
+ type is (real(r4_kind))
+ tmpstr1 = ''; tmpstr1 = string(corners(1,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(1,2))
+ call fms_f2c_string(vals3(key3_i)%val3, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(2,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(2,2))
+ call fms_f2c_string(vals3(key3_i)%val4, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(3,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(3,2))
+ call fms_f2c_string(vals3(key3_i)%val5, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(4,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(4,2))
+ call fms_f2c_string(vals3(key3_i)%val6, trim(tmpstr1)//' '//trim(tmpstr2))
+ type is (integer(i4_kind))
+ tmpstr1 = ''; tmpstr1 = string(corners(1,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(1,2))
+ call fms_f2c_string(vals3(key3_i)%val3, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(2,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(2,2))
+ call fms_f2c_string(vals3(key3_i)%val4, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(3,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(3,2))
+ call fms_f2c_string(vals3(key3_i)%val5, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(4,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(4,2))
+ call fms_f2c_string(vals3(key3_i)%val6, trim(tmpstr1)//' '//trim(tmpstr2))
+ type is (integer(i8_kind))
+ tmpstr1 = ''; tmpstr1 = string(corners(1,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(1,2))
+ call fms_f2c_string(vals3(key3_i)%val3, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(2,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(2,2))
+ call fms_f2c_string(vals3(key3_i)%val4, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(3,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(3,2))
+ call fms_f2c_string(vals3(key3_i)%val5, trim(tmpstr1)//' '//trim(tmpstr2))
+ tmpstr1 = ''; tmpstr1 = string(corners(4,1))
+ tmpstr2 = ''; tmpstr2 = string(corners(4,2))
+ call fms_f2c_string(vals3(key3_i)%val6, trim(tmpstr1)//' '//trim(tmpstr2))
+ end select
+ endif
+ endif
+ !! global metadata
+ key3_i = key3_i + 1
+ call initialize_key_struct(keys3(key3_i))
+ call initialize_val_struct(vals3(key3_i))
+ call yaml_out_add_level2key('global_meta', keys2(i))
+ if ( fileptr%has_file_global_meta()) then
+ do gm=1, SIZE(fileptr%file_global_meta, 1)
+ select case(gm)
+ case (1)
+ call fms_f2c_string(keys3(key3_i)%key1, fileptr%file_global_meta(1,1))
+ call fms_f2c_string(vals3(key3_i)%val1, fileptr%file_global_meta(1,2))
+ case (2)
+ call fms_f2c_string(keys3(key3_i)%key2, fileptr%file_global_meta(2,1))
+ call fms_f2c_string(vals3(key3_i)%val2, fileptr%file_global_meta(2,2))
+ case (3)
+ call fms_f2c_string(keys3(key3_i)%key3, fileptr%file_global_meta(3,1))
+ call fms_f2c_string(vals3(key3_i)%val3, fileptr%file_global_meta(3,2))
+ case (4)
+ call fms_f2c_string(keys3(key3_i)%key4, fileptr%file_global_meta(4,1))
+ call fms_f2c_string(vals3(key3_i)%val4, fileptr%file_global_meta(4,2))
+ case (5)
+ call fms_f2c_string(keys3(key3_i)%key5, fileptr%file_global_meta(5,1))
+ call fms_f2c_string(vals3(key3_i)%val5, fileptr%file_global_meta(5,2))
+ case (6)
+ call fms_f2c_string(keys3(key3_i)%key6, fileptr%file_global_meta(6,1))
+ call fms_f2c_string(vals3(key3_i)%val6, fileptr%file_global_meta(6,2))
+ case (7)
+ call fms_f2c_string(keys3(key3_i)%key7, fileptr%file_global_meta(7,1))
+ call fms_f2c_string(vals3(key3_i)%val7, fileptr%file_global_meta(7,2))
+ case (8)
+ call fms_f2c_string(keys3(key3_i)%key8, fileptr%file_global_meta(8,1))
+ call fms_f2c_string(vals3(key3_i)%val8, fileptr%file_global_meta(8,2))
+ case (9)
+ call fms_f2c_string(keys3(key3_i)%key9, fileptr%file_global_meta(9,1))
+ call fms_f2c_string(vals3(key3_i)%val9, fileptr%file_global_meta(9,2))
+ case (10)
+ call fms_f2c_string(keys3(key3_i)%key10, fileptr%file_global_meta(10,1))
+ call fms_f2c_string(vals3(key3_i)%val10, fileptr%file_global_meta(10,2))
+ case (11)
+ call fms_f2c_string(keys3(key3_i)%key11, fileptr%file_global_meta(11,1))
+ call fms_f2c_string(vals3(key3_i)%val11, fileptr%file_global_meta(11,2))
+ case (12)
+ call fms_f2c_string(keys3(key3_i)%key12, fileptr%file_global_meta(12,1))
+ call fms_f2c_string(vals3(key3_i)%val12, fileptr%file_global_meta(12,2))
+ case (13)
+ call fms_f2c_string(keys3(key3_i)%key13, fileptr%file_global_meta(13,1))
+ call fms_f2c_string(vals3(key3_i)%val13, fileptr%file_global_meta(13,2))
+ case (14)
+ call fms_f2c_string(keys3(key3_i)%key14, fileptr%file_global_meta(14,1))
+ call fms_f2c_string(vals3(key3_i)%val14, fileptr%file_global_meta(14,2))
+ case (15)
+ call fms_f2c_string(keys3(key3_i)%key15, fileptr%file_global_meta(15,1))
+ call fms_f2c_string(vals3(key3_i)%val15, fileptr%file_global_meta(15,2))
+ case (16)
+ call fms_f2c_string(keys3(key3_i)%key16, fileptr%file_global_meta(16,1))
+ call fms_f2c_string(vals3(key3_i)%val16, fileptr%file_global_meta(16,2))
+ end select
+ enddo
+ endif
+ enddo
+ tier2size = i
+
+ call write_yaml_from_struct_3( 'diag_out.yaml'//c_null_char, 1, keys, vals, &
+ SIZE(diag_yaml%diag_files), keys2, vals2, &
+ tier3size, tier3each, keys3, vals3, &
+ (/size(diag_yaml%diag_files), 0, 0, 0, 0, 0, 0, 0/))
+ deallocate( keys, keys2, keys3, vals, vals2, vals3)
+
+end subroutine
+
+!> private function for getting unit string from diag_data parameter values
+pure function get_diag_unit_string( unit_param )
+ integer, intent(in) :: unit_param(:) !< diag unit parameter values from diag_data_mod.
+ !!
eg. DIAG_SECONDS, DIAG_MINUTES,DIAG_HOURS, DIAG_DAYS, DIAG_YEARS
+ character(len=8 * SIZE(unit_param)) :: get_diag_unit_string
+ character(len=7) :: tmp
+ integer :: i
+ get_diag_unit_string = ' '
+ do i=1, SIZE(unit_param)
+ select case(unit_param(i))
+ case (DIAG_SECONDS)
+ tmp = 'seconds'
+ case (DIAG_MINUTES)
+ tmp = 'minutes'
+ case (DIAG_HOURS)
+ tmp = 'hours'
+ case (DIAG_DAYS)
+ tmp = 'days'
+ case (DIAG_MONTHS)
+ tmp = 'months'
+ case (DIAG_YEARS)
+ tmp = 'years'
+ case default
+ exit
+ end select
+ get_diag_unit_string = trim(get_diag_unit_string)//" "//trim(tmp)
+ enddo
+ get_diag_unit_string = adjustl(get_diag_unit_string)
+end function
+
+!> private function for getting reduction type string from parameter values
+pure function get_diag_reduction_string( reduction_val )
+ integer, intent(in) :: reduction_val(:) !< reduction types (eg. time_average)
+ integer :: i
+ character(len=8 * MAX_FREQ) :: get_diag_reduction_string
+ character(len=7) :: tmp
+ get_diag_reduction_string = ''
+ do i=1, SIZE(reduction_val)
+ select case (reduction_val(i))
+ case (time_none)
+ tmp = 'none'
+ case (time_average)
+ tmp = 'average'
+ case (time_min)
+ tmp = 'min'
+ case (time_max)
+ tmp = 'max'
+ case (time_rms)
+ tmp = 'rms'
+ case (time_sum)
+ tmp = 'sum'
+ case (time_diurnal)
+ tmp = 'diurnal'
+ case default
+ exit
+ end select
+ get_diag_reduction_string = trim(get_diag_reduction_string) //" "//trim(tmp)
+ enddo
+ get_diag_reduction_string = adjustl(get_diag_reduction_string)
+end function
+
+subroutine add_axis_name( this, axis_name )
+ class(diagYamlFilesVar_type), intent(inout) :: this
+ character(len=:), allocatable, intent(in) :: axis_name
+ character(len=:), allocatable :: tmp_str
+
+ this%var_axes_names = trim(axis_name)//" "//trim(this%var_axes_names)
+
+end subroutine add_axis_name
+
+pure function is_file_subregional( this ) &
+ result(res)
+ class(diagYamlFilesVar_type), intent(in) :: this
+ logical :: res
+
+ res = this%var_file_is_subregional
+end function is_file_subregional
+
#endif
end module fms_diag_yaml_mod
!> @}
diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am
index 4eb3841f7f..de3d0eec29 100644
--- a/test_fms/diag_manager/Makefile.am
+++ b/test_fms/diag_manager/Makefile.am
@@ -33,7 +33,7 @@ check_PROGRAMS = test_diag_manager test_diag_manager_time \
test_flexible_time test_diag_update_buffer test_reduction_methods check_time_none \
check_time_min check_time_max check_time_sum check_time_avg test_diag_diurnal check_time_diurnal \
check_time_pow check_time_rms check_subregional test_cell_measures test_var_masks \
- check_var_masks test_multiple_send_data
+ check_var_masks test_multiple_send_data test_diag_out_yaml
# This is the source code for the test.
test_diag_manager_SOURCES = test_diag_manager.F90
@@ -44,6 +44,7 @@ test_diag_ocean_SOURCES = test_diag_ocean.F90
test_modern_diag_SOURCES = test_modern_diag.F90
test_diag_buffer_SOURCES= test_diag_buffer.F90
test_flexible_time_SOURCES = test_flexible_time.F90
+test_diag_out_yaml_SOURCES = test_diag_out_yaml.F90
test_reduction_methods_SOURCES = testing_utils.F90 test_reduction_methods.F90
test_diag_diurnal_SOURCES = testing_utils.F90 test_diag_diurnal.F90
check_time_none_SOURCES = testing_utils.F90 check_time_none.F90
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index af7d2cabab..7f6f6a9848 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -591,7 +591,7 @@ _EOF
mpirun -n 1 ../test_diag_yaml
'
. $top_srcdir/test_fms/diag_manager/check_crashes.sh
- my_test_count = `expr $my_test_count + 14`
+ my_test_count=`expr $my_test_count + 14`
printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml
cat <<_EOF > diag_table.yaml
@@ -805,6 +805,417 @@ _EOF
mpirun -n 6 ../test_modern_diag
'
+## print out a reference for the yaml output test, just uses the last diag table created
+ cat <<_EOF > diag_out_ref.yaml
+---
+title: test_diag_manager
+base_date: 2 1 1 0 0 0
+diag_files:
+- file_name: static_file
+ freq: -1
+ freq_units: days
+ time_units: hours
+ unlimdim: time
+ new_file_freq:
+ new_file_freq_units:
+ start_time:
+ file_duration:
+ file_duration_units:
+ varlist:
+ - module: atm_mod
+ var_name: var7
+ reduction: none
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: z
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - is_important: False
+ has_important: True
+- file_name: file1
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq:
+ new_file_freq_units:
+ start_time:
+ file_duration:
+ file_duration_units:
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time y x
+ - module: ocn_mod
+ var_name: var2
+ reduction: average
+ kind: r4
+ output_name: potato
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time x y
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - {}
+- file_name: file2
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq:
+ new_file_freq_units:
+ start_time:
+ file_duration:
+ file_duration_units:
+ varlist:
+ - module: atm_mod
+ var_name: var3
+ reduction: average
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time y3 x3
+ - module: atm_mod
+ var_name: var4
+ reduction: average
+ kind: r8
+ output_name: i_on_a_sphere
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time z y3 x3
+ - module: atm_mod
+ var_name: var6
+ reduction: average
+ kind: r8
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time z
+ - module: atm_mod
+ var_name: var4
+ reduction: average
+ kind: r8
+ output_name: var4_bounded
+ long_name:
+ units:
+ zbounds: 2.00 3.00
+ n_diurnal:
+ pow_value:
+ dimensions: time z_sub01 y3 x3
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - {}
+- file_name: file3
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq:
+ new_file_freq_units:
+ start_time:
+ file_duration:
+ file_duration_units:
+ varlist:
+ - module: lnd_mod
+ var_name: var5
+ reduction: average
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time grid_index
+ - module: atm_mod
+ var_name: var7
+ reduction: average
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: z
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - {}
+- file_name: file4
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq:
+ new_file_freq_units:
+ start_time:
+ file_duration:
+ file_duration_units:
+ varlist:
+ - module: lnd_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - {}
+- file_name: file5
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq:
+ new_file_freq_units:
+ start_time:
+ file_duration:
+ file_duration_units:
+ varlist:
+ - module: atm_mod
+ var_name: var4
+ reduction: average
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time z y3_sub01 x3_sub01
+ sub_region:
+ - grid_type: index
+ tile: 1
+ corner1: 10 15
+ corner2: 20 15
+ corner3: 10 25
+ corner4: 20 25
+ global_meta:
+ - {}
+- file_name: file6%4yr%2mo%2dy%2hr
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6
+ new_file_freq_units: hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12
+ file_duration_units: hours
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time y x
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - {}
+- file_name: file7
+ freq: 6
+ freq_units: hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq:
+ new_file_freq_units:
+ start_time:
+ file_duration:
+ file_duration_units:
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: none
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time y x
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - {}
+- file_name: file8%4yr%2mo%2dy%2hr%2min
+ freq: 1 1 1
+ freq_units: hours hours hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6 3 1
+ new_file_freq_units: hours hours hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12 3 9
+ file_duration_units: hours hours hours
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time y x
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - {}
+- file_name: file9%4yr%2mo%2dy%2hr%2min
+ freq: 1 1 1
+ freq_units: hours hours hours
+ time_units: hours
+ unlimdim: time
+ new_file_freq: 6 3 1
+ new_file_freq_units: hours hours hours
+ start_time: 2 1 1 0 0 0
+ file_duration: 12 3 9
+ file_duration_units: hours hours hours
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: average
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal:
+ pow_value:
+ dimensions: time y x
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - {}
+- file_name: file10_diurnal
+ freq: 1
+ freq_units: days
+ time_units: hours
+ unlimdim: time
+ new_file_freq:
+ new_file_freq_units:
+ start_time:
+ file_duration:
+ file_duration_units:
+ varlist:
+ - module: ocn_mod
+ var_name: var1
+ reduction: diurnal
+ kind: r4
+ output_name:
+ long_name:
+ units:
+ zbounds:
+ n_diurnal: 12
+ pow_value:
+ dimensions: time time_of_day_12 y x
+ sub_region:
+ - grid_type:
+ tile:
+ corner1:
+ corner2:
+ corner3:
+ corner4:
+ global_meta:
+ - {}
+...
+_EOF
+
+my_test_count=`expr $my_test_count + 1`
+test_expect_success "check modern diag manager yaml output (test $my_test_count)" '
+ mpirun -n 1 ../test_diag_out_yaml
+'
+
printf "&diag_manager_nml \n use_modern_diag = .true. \n use_clock_average = .true. \n /" | cat > input.nml
cat <<_EOF > diag_table.yaml
title: test_diag_manager
diff --git a/test_fms/diag_manager/test_diag_out_yaml.F90 b/test_fms/diag_manager/test_diag_out_yaml.F90
new file mode 100644
index 0000000000..3039ac224a
--- /dev/null
+++ b/test_fms/diag_manager/test_diag_out_yaml.F90
@@ -0,0 +1,61 @@
+!***********************************************************************
+!* 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 .
+!***********************************************************************
+!> @author Ryan Mulhall
+!> @brief Simple test program for diag manager output yaml file.
+!! Just checks output from previous test
+program test_diag_out_yaml
+
+use fms_mod, only: fms_init, fms_end
+use time_manager_mod, only: set_calendar_type, JULIAN, time_type
+use mpp_mod, only: mpp_root_pe, mpp_pe, mpp_error, FATAL
+
+implicit none
+
+type(time_type) :: time
+
+call fms_init
+call check_output_yaml
+call fms_end
+
+contains
+
+!> checks output and reference file are equivalent
+subroutine check_output_yaml
+ integer :: i, un_out, un_ref
+ integer, parameter :: yaml_len = 402
+ character(len=128) :: out_yaml_line, ref_yaml_line
+ character(len=17), parameter :: ref_fname = 'diag_out_ref.yaml'
+ character(len=13), parameter :: out_fname = 'diag_out.yaml'
+ if( mpp_root_pe() .ne. mpp_pe()) return
+ open(newunit=un_out, file=out_fname, status="old", action="read")
+ open(newunit=un_ref, file=ref_fname, status="old", action="read")
+ do i=1, yaml_len
+ read(un_out, '(A)') out_yaml_line
+ read(un_ref, '(A)') ref_yaml_line
+ if(out_yaml_line .ne. ref_yaml_line) call mpp_error(FATAL, 'diag_out.yaml does not match reference file.' &
+ //'reference line:'//ref_yaml_line &
+ //'output line:'//out_yaml_line)
+ enddo
+ close(un_out)
+ close(un_ref)
+
+end subroutine
+
+
+end program
\ No newline at end of file
From 65b16d5172cea2090ed5e57be2f65ee22566972c Mon Sep 17 00:00:00 2001
From: rem1776
Date: Fri, 3 May 2024 10:00:25 -0400
Subject: [PATCH 165/168] chore: delete docs_uml directory and bring over any
diffs
---
CMakeLists.txt | 5 -
Makefile.am | 1 +
diag_manager/Makefile.am | 23 +-
diag_manager/diag_axis.F90 | 4 +-
diag_manager/diag_data.F90 | 13 +-
diag_manager/diag_manager.F90 | 69 +++--
diag_manager/diag_util.F90 | 146 +--------
diag_manager/docs_uml/MDMClassObjects.drawio | 1 -
diag_manager/docs_uml/Untitled Diagram.drawio | 141 ---------
.../docs_uml/classDiagramDiagObjects.drawio | 277 ------------------
diag_manager/docs_uml/diag_manager_end.drawio | 175 -----------
.../docs_uml/diag_manager_init.drawio | 1 -
.../fms_diag_object_relationships.drawio | 277 ------------------
diag_manager/fms_diag_yaml.F90 | 3 +-
test_fms/diag_manager/check_crashes.sh | 5 +-
.../diagTables/diag_table_yaml_26 | 61 ----
test_fms/diag_manager/test_diag_manager2.sh | 1 -
17 files changed, 68 insertions(+), 1135 deletions(-)
delete mode 100644 diag_manager/docs_uml/MDMClassObjects.drawio
delete mode 100644 diag_manager/docs_uml/Untitled Diagram.drawio
delete mode 100644 diag_manager/docs_uml/classDiagramDiagObjects.drawio
delete mode 100644 diag_manager/docs_uml/diag_manager_end.drawio
delete mode 100644 diag_manager/docs_uml/diag_manager_init.drawio
delete mode 100644 diag_manager/docs_uml/fms_diag_object_relationships.drawio
delete mode 100644 test_fms/diag_manager/diagTables/diag_table_yaml_26
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 4a6292027b..849e87e0b8 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -125,11 +125,6 @@ list(APPEND fms_fortran_src_files
diag_manager/diag_output.F90
diag_manager/diag_table.F90
diag_manager/diag_util.F90
- diag_manager/fms_diag_time_reduction.F90
- diag_manager/fms_diag_outfield.F90
- diag_manager/fms_diag_elem_weight_procs.F90
- diag_manager/fms_diag_fieldbuff_update.F90
- diag_manager/fms_diag_bbox.F90
diag_manager/fms_diag_time_utils.F90
diag_manager/fms_diag_object.F90
diag_manager/fms_diag_yaml.F90
diff --git a/Makefile.am b/Makefile.am
index 22fb68f97d..cd8837ffe1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -45,6 +45,7 @@ SUBDIRS = \
mosaic2 \
fms \
parser \
+ string_utils \
affinity \
mosaic \
time_manager \
diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am
index a90137d368..1b67920de8 100644
--- a/diag_manager/Makefile.am
+++ b/diag_manager/Makefile.am
@@ -31,20 +31,13 @@ noinst_LTLIBRARIES = libdiag_manager.la
# Each convenience library depends on its source.
libdiag_manager_la_SOURCES = \
- diag_data.F90 \
diag_axis.F90 \
+ diag_data.F90 \
diag_grid.F90 \
diag_manager.F90 \
diag_output.F90 \
diag_table.F90 \
diag_util.F90 \
- fms_diag_time_reduction.F90 \
- fms_diag_outfield.F90 \
- fms_diag_elem_weight_procs.F90 \
- fms_diag_fieldbuff_update.F90 \
- fms_diag_bbox.F90 \
- include/fms_diag_fieldbuff_update.inc \
- include/fms_diag_fieldbuff_update.fh \
fms_diag_time_utils.F90 \
fms_diag_file_object.F90 \
fms_diag_field_object.F90 \
@@ -57,7 +50,7 @@ libdiag_manager_la_SOURCES = \
fms_diag_outfield.F90 \
fms_diag_elem_weight_procs.F90 \
fms_diag_fieldbuff_update.F90 \
- fms_diag_bbox.F90 \
+ fms_diag_bbox.F90 \
fms_diag_reduction_methods.F90 \
include/fms_diag_fieldbuff_update.inc \
include/fms_diag_fieldbuff_update.fh \
@@ -70,10 +63,10 @@ libdiag_manager_la_SOURCES = \
# Some mods are dependant on other mods in this dir.
diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT)
-diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT)
+diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_object_mod.$(FC_MODEXT)
diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT)
diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \
- diag_grid_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT)
+ diag_grid_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT)
fms_diag_time_utils_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT)
fms_diag_yaml_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT)
@@ -117,14 +110,6 @@ MODFILES = \
diag_util_mod.$(FC_MODEXT) \
fms_diag_time_utils_mod.$(FC_MODEXT) \
diag_table_mod.$(FC_MODEXT) \
- fms_diag_time_reduction_mod.$(FC_MODEXT) \
- fms_diag_outfield_mod.$(FC_MODEXT) \
- fms_diag_bbox_mod.$(FC_MODEXT) \
- fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \
- fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \
- diag_manager_mod.$(FC_MODEXT) \
- include/fms_diag_fieldbuff_update.inc \
- include/fms_diag_fieldbuff_update.fh
fms_diag_yaml_mod.$(FC_MODEXT) \
fms_diag_file_object_mod.$(FC_MODEXT) \
fms_diag_field_object_mod.$(FC_MODEXT) \
diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90
index 9457651b84..85bd119bf6 100644
--- a/diag_manager/diag_axis.F90
+++ b/diag_manager/diag_axis.F90
@@ -41,9 +41,7 @@ MODULE diag_axis_mod
& max_num_axis_sets, max_axis_attributes, debug_diag_manager,&
& first_send_data_call, diag_atttype, use_modern_diag
use fms_diag_object_mod, only:fms_diag_object
-#ifdef use_netCDF
USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR
-#endif
IMPLICIT NONE
@@ -140,7 +138,7 @@ INTEGER FUNCTION diag_axis_init(name, array_data, units, cart_name, long_name, d
if (use_modern_diag) then
!TODO Passing in the axis_length because of a gnu issue where inside fms_diag_axis_init, the size of DATA
!was 2 which was causing the axis_data to not be written correctly...
- diag_axis_init = fms_diag_object%fms_diag_axis_init(name, DATA, units, cart_name, size(DATA(:)), &
+ diag_axis_init = fms_diag_object%fms_diag_axis_init(name, array_data, units, cart_name, size(array_data(:)), &
& long_name=long_name, direction=direction, set_name=set_name, edges=edges, Domain=Domain, Domain2=Domain2, &
& DomainU=DomainU, aux=aux, req=req, tile_count=tile_count, domain_position=domain_position)
return
diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90
index 7c0829e4ca..abf08d18f7 100644
--- a/diag_manager/diag_data.F90
+++ b/diag_manager/diag_data.F90
@@ -51,13 +51,14 @@ MODULE diag_data_mod
USE time_manager_mod, ONLY: get_calendar_type, NO_CALENDAR, set_date, set_time, month_name, time_type
USE constants_mod, ONLY: SECONDS_PER_HOUR, SECONDS_PER_MINUTE
USE mpp_domains_mod, ONLY: domain1d, domain2d, domainUG
- USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type
USE fms_mod, ONLY: write_version_number
+ USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type
use mpp_mod, ONLY: mpp_error, FATAL, WARNING, mpp_pe, mpp_root_pe, stdlog
+
! NF90_FILL_REAL has value of 9.9692099683868690e+36.
USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL
use fms2_io_mod
- use iso_c_binding
+
IMPLICIT NONE
PUBLIC
@@ -385,6 +386,8 @@ MODULE diag_data_mod
LOGICAL :: prepend_date = .TRUE. !< Should the history file have the start date prepended to the file name.
!! .TRUE. is only supported if the diag_manager_init
!! routine is called with the optional time_init parameter.
+ LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io
+ LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons.
LOGICAL :: use_modern_diag = .false. !< Namelist flag to use the modernized diag_manager code
LOGICAL :: use_clock_average = .false. !< .TRUE. if the averaging of variable is done based on the clock
!! For example, if doing daily averages and your start the simulation in
@@ -392,13 +395,9 @@ MODULE diag_data_mod
!! the default behavior will do the average between day1 hour3 to day2 hour3
!
-#ifdef use_netCDF
- REAL(r8_kind) :: FILL_VALUE = NF_FILL_REAL !< Fill value used. Value will be NF90_FILL_REAL if using the
+ REAL :: FILL_VALUE = NF_FILL_REAL !< Fill value used. Value will be NF90_FILL_REAL if using the
!! netCDF module, otherwise will be 9.9692099683868690e+36.
! from file /usr/local/include/netcdf.inc
-#else
- REAL(r8_kind) :: FILL_VALUE = 9.9692099683868690e+36
-#endif
!! @note `pack_size` and `pack_size_str` are set in diag_manager_init depending on how FMS was compiled
!! if FMS was compiled with default reals as 64bit, it will be set to 1 and "double",
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index d546efb759..2877f66b25 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -201,6 +201,9 @@ MODULE diag_manager_mod
! The values are defined as GLO_REG_VAL (-999) and GLO_REG_VAL_ALT
! (-1) in diag_data_mod.
!
+ !
+ ! Set to true, diag_manager uses mpp_io. Default is fms2_io.
+ !
!
USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),&
@@ -230,7 +233,8 @@ MODULE diag_manager_mod
& diag_log_unit, time_unit_list, pelist_name, max_axes, module_is_initialized, max_num_axis_sets,&
& use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,&
& max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,&
- & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time,diag_data_init,&
+ & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time, diag_data_init,&
+ & use_mpp_io, use_refactored_send, &
& use_modern_diag, use_clock_average, diag_null, pack_size_str
USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND
USE diag_table_mod, ONLY: parse_diag_table
@@ -374,6 +378,7 @@ MODULE diag_manager_mod
!> @addtogroup diag_manager_mod
!> @{
CONTAINS
+
!> @brief Registers a scalar field
!! @return field index for subsequent call to send_data.
INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, &
@@ -385,8 +390,8 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
- REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
- REAL, OPTIONAL, INTENT(in) :: range(2) !< Range to add a variable attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
@@ -395,6 +400,13 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
LOGICAL, OPTIONAL, INTENT(in) :: multiple_send_data !< .True. if send data is called, multiple times
!! for the same time
+ ! Fatal error if range is present and its extent is not 2.
+ IF ( PRESENT(range) ) THEN
+ IF ( SIZE(range) .NE. 2 ) THEN
+ ! extent of range should be 2
+ CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', FATAL)
+ END IF
+ END IF
if (use_modern_diag) then
if( do_diag_field_log) then
if ( PRESENT(do_not_log) ) THEN
@@ -417,7 +429,7 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
endif
end function register_diag_field_scalar
- !> @brief Registers an array field
+ !> @brief Registers an array field
!> @return field index for subsequent call to send_data.
INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_time, &
& long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
@@ -537,8 +549,8 @@ INTEGER FUNCTION register_diag_field_scalar_old(module_name, field_name, init_ti
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
- REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
- REAL, OPTIONAL, INTENT(in) :: range(2) !< Range to add a variable attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
+ CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field
@@ -559,22 +571,20 @@ INTEGER FUNCTION register_diag_field_scalar_old(module_name, field_name, init_ti
END IF
END FUNCTION register_diag_field_scalar_old
-INTEGER FUNCTION register_diag_field_array_old(module_name, field_name, axes, init_time, &
+ !> @brief Registers an array field
+ !> @return field index for subsequent call to send_data.
+ INTEGER FUNCTION register_diag_field_array_old(module_name, field_name, axes, init_time, &
& long_name, units, missing_value, range, mask_variant, standard_name, verbose,&
& do_not_log, err_msg, interp_method, tile_count, area, volume, realm)
- CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from
- CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field
- INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis
- TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute
- REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute
- REAL, OPTIONAL, INTENT(in) :: range(2) !< Range to add a variable attribute
- LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file
- LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information
- LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged
- CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call
+ CHARACTER(len=*), INTENT(in) :: module_name, field_name
+ INTEGER, INTENT(in) :: axes(:)
+ TYPE(time_type), INTENT(in) :: init_time
+ CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value
+ CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range
+ LOGICAL, OPTIONAL, INTENT(in) :: mask_variant,verbose
+ LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged
+ CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg
CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when
!! regridding the field in post-processing.
!! Valid options are "conserve_order1",
@@ -589,6 +599,7 @@ INTEGER FUNCTION register_diag_field_array_old(module_name, field_name, axes, in
INTEGER :: stdout_unit
LOGICAL :: mask_variant1, verbose1
CHARACTER(len=128) :: msg
+ TYPE(time_type) :: diag_file_init_time !< The intial time of the diag_file
! get stdout unit number
stdout_unit = stdout()
@@ -787,7 +798,7 @@ INTEGER FUNCTION register_static_field_old(module_name, field_name, axes, long_n
LOGICAL :: mask_variant1, dynamic1, allow_log
CHARACTER(len=128) :: msg
INTEGER :: domain_type, i
- character(len=256) :: axes_list, axis_name
+ character(len=256) :: axis_name
! Fatal error if the module has not been initialized.
IF ( .NOT.module_is_initialized ) THEN
@@ -847,7 +858,7 @@ INTEGER FUNCTION register_static_field_old(module_name, field_name, axes, long_n
! only writes log if do_diag_field_log is true in the namelist (default false)
! if do_diag_field_log is true and do_not_log arg is present as well, it will only print if do_not_log = false
IF ( do_diag_field_log.AND.allow_log ) THEN
- CALL log_diag_field_info (module_name, field_name, axes, &
+ CALL log_diag_field_info (module_name, field_name, axes, &
& long_name, units, missing_value=missing_value, range=range, &
& DYNAMIC=dynamic1)
END IF
@@ -1646,7 +1657,7 @@ END FUNCTION send_data_2d
LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
& mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
INTEGER, INTENT(in) :: diag_field_id
- CLASS(*), DIMENSION(:,:,:), INTENT(in), TARGET, CONTIGUOUS :: field
+ CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field
CLASS(*), INTENT(in), OPTIONAL :: weight
TYPE (time_type), INTENT(in), OPTIONAL :: time
INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
@@ -1669,12 +1680,13 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
endif
END FUNCTION send_data_3d
+
!> @return true if send is successful
!TODO documentation, seperate the old and new
LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, &
& mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
INTEGER, INTENT(in) :: diag_field_id
- CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field
+ CLASS(*), DIMENSION(:,:,:), INTENT(in),TARGET,CONTIGUOUS :: field
CLASS(*), INTENT(in), OPTIONAL :: weight
TYPE (time_type), INTENT(in), OPTIONAL :: time
INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
@@ -1757,10 +1769,6 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in,
& SIZE(field,1), SIZE(field,2), SIZE(field,3), status
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN
END IF
- if (use_modern_diag) then !> Set up array lengths for remapping
-
-
- endif
SELECT TYPE (field)
TYPE IS (real(kind=r4_kind))
field_out = field
@@ -4060,6 +4068,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
INTEGER, DIMENSION(6), OPTIONAL, INTENT(IN) :: time_init !< Model time diag_manager initialized
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
+ CHARACTER(len=*), PARAMETER :: SEP = '|'
INTEGER, PARAMETER :: FltKind = R4_KIND
INTEGER, PARAMETER :: DblKind = R8_KIND
@@ -4074,8 +4083,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
& max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,&
& max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,&
& oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,&
- & max_file_attributes, max_axis_attributes, prepend_date, field_log_separator, use_modern_diag, &
- & use_clock_average
+ & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, &
+ & field_log_separator, use_refactored_send
! If the module was already initialized do nothing
IF ( module_is_initialized ) RETURN
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index e03d86497b..216f14bad3 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -77,14 +77,13 @@ MODULE diag_util_mod
IMPLICIT NONE
PRIVATE
- PUBLIC get_subfield_size, log_diag_field_info, init_file, diag_time_inc,&
+ 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,&
- & update_bounds, check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,&
& fms_diag_check_out_of_bounds, &
- & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static,&
- & get_time_string, init_mask_3d, real_copy_set, check_indices_order
+ & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static, get_file_start_time
!> @brief Prepend a value to a string attribute in the output field or output file.
@@ -109,6 +108,7 @@ MODULE diag_util_mod
!> @addtogroup diag_util_mod
!> @{
+
! Include variable "version" to be written to log file.
#include
@@ -647,10 +647,11 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,&
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
REAL :: missing_value_use !< Local copy of missing_value
REAL, DIMENSION(2) :: range_use !< Local copy of range
- CHARACTER(len=256) :: axis_name, axes_list
IF ( .NOT.do_diag_field_log ) RETURN
IF ( mpp_pe().NE.mpp_root_pe() ) RETURN
@@ -2495,135 +2496,16 @@ SUBROUTINE prepend_attribute_file(out_file, att_name, prepend_value, err_msg)
END IF
END SUBROUTINE prepend_attribute_file
- !> @brief Allocates outmask(second argument) with sizes of the first three dimensions of field(first argument).
- !! Initializes the outmask depending on presence/absence of inmask and rmask.
- !! Uses and sets rmask_threshold.
- subroutine init_mask_3d(field, outmask, rmask_threshold, inmask, rmask, err_msg)
- class(*), intent(in) :: field(:,:,:,:) !< Dummy variable whose sizes only in the first three dimensions are important
- logical, allocatable, intent(inout) :: outmask(:,:,:) !< Output logical mask
- real, intent(inout) :: rmask_threshold !< Holds the values 0.5_r4_kind or 0.5_r8_kind, or related threhold values
- !! needed to be passed to the math/buffer update functions.
- logical, intent(in), optional :: inmask(:,:,:) !< Input logical mask
- class(*), intent(in), optional :: rmask(:,:,:) !< Floating point input mask value
- character(len=*), intent(out), optional :: err_msg !< Error message to relay back to caller
-
- character(len=256) :: err_msg_local !< Stores locally generated error message
- integer :: status !< Stores status of memory allocation call
-
- ! Initialize character strings
- err_msg_local = ''
- if (present(err_msg)) err_msg = ''
-
- ! Check if outmask is allocated
- if (allocated(outmask)) deallocate(outmask)
- ALLOCATE(outmask(SIZE(field, 1), SIZE(field, 2), SIZE(field, 3)), STAT=status)
- IF ( status .NE. 0 ) THEN
- WRITE (err_msg_local, FMT='("Unable to allocate outmask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
- & SIZE(field, 1), SIZE(field, 2), SIZE(field, 3), status
- if (fms_error_handler('diag_util_mod:init_mask_3d', trim(err_msg_local), err_msg)) then
- return
- end if
- END IF
-
- IF ( PRESENT(inmask) ) THEN
- outmask = inmask
- ELSE
- outmask = .TRUE.
- END IF
-
- IF ( PRESENT(rmask) ) THEN
- SELECT TYPE (rmask)
- TYPE IS (real(kind=r4_kind))
- WHERE (rmask < real(rmask_threshold, kind=r4_kind)) outmask = .FALSE.
- rmask_threshold = real(rmask_threshold, kind=r4_kind)
- TYPE IS (real(kind=r8_kind))
- WHERE ( rmask < real(rmask_threshold, kind=r8_kind) ) outmask = .FALSE.
- rmask_threshold = real(rmask_threshold, kind=r8_kind)
- CLASS DEFAULT
- if (fms_error_handler('diag_util_mod:init_mask_3d',&
- & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) then
- end if
- END SELECT
- END IF
- end subroutine init_mask_3d
-
- !> @brief Copies input data to output data with proper type if the input data is present
- !! else sets the output data to a given value val if it is present.
- !! If the value val and the input data are not present, the output data is untouched.
- subroutine real_copy_set(out_data, in_data, val, err_msg)
- real, intent(out) :: out_data !< Proper type copy of in_data
- class(*), intent(in), optional :: in_data !< Data to copy to out_data
- real, intent(in), optional :: val !< Default value to assign to out_data if in_data is absent
- character(len=*), intent(out), optional :: err_msg !< Error message to pass back to caller
-
- IF ( PRESENT(err_msg) ) err_msg = ''
-
- IF ( PRESENT(in_data) ) THEN
- SELECT TYPE (in_data)
- TYPE IS (real(kind=r4_kind))
- out_data = in_data
- TYPE IS (real(kind=r8_kind))
- out_data = real(in_data)
- CLASS DEFAULT
- if (fms_error_handler('diag_util_mod:real_copy_set',&
- & 'The in_data is not one of the supported types of real(kind=4) or real(kind=8)', err_msg)) THEN
- return
- end if
- END SELECT
- ELSE
- if (present(val)) out_data = val
- END IF
- end subroutine real_copy_set
-
- !> @brief Checks improper combinations of is, ie, js, and je.
- !> @return Returns .false. if there is no error else .true.
- !> @note send_data works in either one or another of two modes.
- ! 1. Input field is a window (e.g. FMS physics)
- ! 2. Input field includes halo data
- ! It cannot handle a window of data that has halos.
- ! (A field with no windows or halos can be thought of as a special case of either mode.)
- ! The logic for indexing is quite different for these two modes, but is not clearly separated.
- ! If both the beggining and ending indices are present, then field is assumed to have halos.
- ! If only beggining indices are present, then field is assumed to be a window.
- !> @par
- ! There are a number of ways a user could mess up this logic, depending on the combination
- ! of presence/absence of is,ie,js,je. The checks below should catch improper combinations.
- function check_indices_order(is_in, ie_in, js_in, je_in, error_msg) result(rslt)
- integer, intent(in), optional :: is_in, ie_in, js_in, je_in !< Indices passed to fms_diag_accept_data()
- character(len=*), intent(inout), optional :: error_msg !< An error message used only for testing purpose!!!
-
- character(len=128) :: err_module_name !< Stores the module name to be used in error calls
- logical :: rslt !< Return value
-
- rslt = .false. !< If no error occurs.
-
- err_module_name = 'diag_util_mod:check_indices_order'
-
- IF ( PRESENT(ie_in) ) THEN
- IF ( .NOT.PRESENT(is_in) ) THEN
- rslt = fms_error_handler(trim(err_module_name), 'ie_in present without is_in', error_msg)
- IF (rslt) return
- END IF
- IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN
- rslt = fms_error_handler(trim(err_module_name),&
- & 'is_in and ie_in present, but js_in present without je_in', error_msg)
- IF (rslt) return
- END IF
- END IF
+ !> @brief Get the a diag_file's start_time as it is defined in the diag_table
+ !! @return the start_time for the file
+ function get_file_start_time(file_num) &
+ result (start_time)
+ integer, intent(in) :: file_num !< File number of the file to get the start_time from
- IF ( PRESENT(je_in) ) THEN
- IF ( .NOT.PRESENT(js_in) ) THEN
- rslt = fms_error_handler(trim(err_module_name), 'je_in present without js_in', error_msg)
- IF (rslt) return
- END IF
- IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN
- rslt = fms_error_handler(trim(err_module_name),&
- & 'js_in and je_in present, but is_in present without ie_in', error_msg)
- IF (rslt) return
- END IF
- END IF
- end function check_indices_order
+ TYPE(time_type) :: start_time !< The start_time to return
+ start_time = files(file_num)%start_time
+ end function get_file_start_time
END MODULE diag_util_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/docs_uml/MDMClassObjects.drawio b/diag_manager/docs_uml/MDMClassObjects.drawio
deleted file mode 100644
index 890182f218..0000000000
--- a/diag_manager/docs_uml/MDMClassObjects.drawio
+++ /dev/null
@@ -1 +0,0 @@
-7T1bc9s21r+lD5pJdyYe3nR7dBynm9a51En3S/rCoURKZkORCi+xnV//ASABgSRIAhBJyTU62o1F8QAHwLnj4GBiXu0efoud/d27yPWCiaG5DxPz9cQA/2kz8A988pg/0fXFMn+yjX23eHZ48Mn/6RUPteJp5rteUnoxjaIg9fflh+soDL11WnrmxHF0X35tEwXlXvfO1qs9+LR2gvrT//Pd9K4YmGkuDz/81/O3d0XXpqkVmO8c/HbxILlz3OieemReT8yrOIrS/K/dw5UXwOnDE5PDvWn4lWAWe2HKA/CHtrIe36dvv2fLW+t74uw/Z7+/LFr54QRZMeKJMQtAe69W4I8t/GOzS177zvbD6h8wwXb6uPfwK6Av8lYxxvQRz9xdugvAXzr4LfrhxZsAjX0VROtvsHX476e9s/bDbfFWcu/vAicE4K/Wd37g3jiPUQZHlqTO+hv+9uouiv2fUZg6uPXDg0/wRfBUA09jLwHE9BHPjl559M55KL144yRp8WAdBYGzT/wVGgl8sgGtfypGBr/vnHjrh6+iNI12xSOM/Bs/CK6iIIrRJJgb9B/8PXXitCBvYwoe3N/5qQcnAD65B9yD+8nf0WcX8+IJ1ZzpWLrlgOdO4G9D8GwNhuLFsH0ylQibNI6+eSzA/JcP8O0U8qSuoTmIstD13GKenFUSBVnqXcZrjA18Sr4tSTuYJbSLBSEBmiAxdXlx6j1QjwoC/c2Ldl4aP4JX8K9zzD6FwMDMc39gvumieHZH8d1sVjx0CobfkrYPLAH+KLhCgEOMGoesAydJXhRsARYcTDSgPj/0YsQdv06MK4hIAEjcSR1IRmAU5iX8GNqbd59sF8DZGwCYgAcvwPNfCdPFB37SoFgrd+UFrlgXACBp7QC2htt/lW02Xiw1mBUCbe/KB6S6BcSKGtzH/g8nLTUWe1s/AdTsubg59CuYcUgT2i+gNWcH2SQgbZrg/6NNCRZ8IdBvXH/nhYkfhVzze/ngJyKjRyN3AFBfw/7hxD7sJBEaLgV1NAZwNEKd5wDsfoNo6wNN2tivH/qpDyTZTyR5LjZOkHgXzN592G96h3CLkB6CD+G3MEorLUkig9jRbkBJtknIfv22WdB2v406D81Dr2h1IN2xOqUUfK5DiR1UV0FhhPT6htKOxSOsyQJvAxGGqgLielk83vmuC/vGCu4GvfbaOjy5LTq1yobGHQD0QqTb0oJ1c8T2EeAHpCSmr8AHzM+VdjGdTF/D6Zm+0g/fwQe+HgMNHILhALEA+/GApXDvQWuBQ+mzlO1xmr+uZFvtum7NixXtlE/RGtZ0IEVrMkzRCvUFPqKZsvGh90JYnyOwDq9f6jVSM+ukZjLIKnBWXvAxSgATRbD9OH+3Qm5dFDXY6s457ajFQItr1RZ3H0drz83imkrAWp9IMKCecysjF/12/hLwLE1dIzIu/zAbRbBe6HY2jN7hbxeCY2VIGVx2AsjMiftoCXiwzqN0Q8DnACSfNyXaCLFthGcbd8+cbdYgweRDpQ+0vvYOWBXBY0mhEz16ITWEYh5d8L80jf1VBjWf7FQc1czWS2032gGeN4RXA8IiDAIv3AL+len6MBu+a2/iaGeHzk5qFAgTCJw340sS13rt7QFeQIpKwSeAW+11tNsHnuSaupHtRyVI09+4HrQ1s8SzHx1g3wi0S2Y5t9HKDQNkoRGrrKlnYk3NF3z61lwYx2vcUPvz91evfg8//+/b+lK7CXY3v719qeNICkVvnrv1cCALrMRdtI1CJ7g+PKUiQXByD+/cRMg+guT5j5emj8X0OlkalYnXe/DTL9TfX1F4CIW84NfXOOyGvjziLyEY8Rf6SwFmWPjBARB9K0F+9GLg6KNA2GutLRCVRFm89tomrQgxOzHg5u6gEJzPVnIA6gzo4B/lYDJrqQvQj5CdJodw2GxZDoeRRcVt5JgWYAeKucwNB/JawaaNHS2w+V/0Y87LoeSO1zFaB3rNEThQL5mTIwiaO1TNCmSpmLWKWQ8Ts7Y6I9bWlBWx7sHVYvJJR8A6Zw4bPeOIb+bGTG6k16NLyp45d3umVZQeEx1iErXZQ3CIibEKDg23uDNOiTWUwMIpAW2LO4LlKm81TsexBs3K3uiSzxbsy/6adttfQAsDwl2nFXe7qnaULaZssWFsMaPiLs0Zuxozhmgzqn5Vb8Jt1sg1YMrDEsnPvmcRYidAhVs0pS/X+RJQu6VonvCbmHlKO7wla651GzEP3WFWzPHB3Fi39fInrv+Ds9dsFfhrutMw29le4O3A8uItc8Zeb5agjWUfzk0K3PqXDlh+ZwuJ84ArhQUDsdze/Q/LumVjtgaTndqaW9rI7+ymGP8L37K/+aH7a1PrxWRXvND2tscnkia0XX/XslrpHaSrJA/Uo/QAz1nfIeehknrRQGHVmVAexZP0KKbckrplv5klmXVtKJdirlyKwVZXNxn7zazlHcynaFS7lLRhbw8FWXJ32MPhE9cNO6E7Z99LS4mX2iyVrSTnM5ScusnYW2Lx1myorSWDJTorrqD3kHqh2xR1rFoZmquC9MoxHDKxfFr2DC1GQpRlsuyP+VCeodGso3q0+lt8oSoTNlv5h2ZJbtOhmwZHscHeH3toyLVrG9uLBwAPVvPqZ94O8jmjzUvXefx1vLEIzKPS809SzxOledSmC0tETYfykAyOwLxykWSXd8GpgcRdJHJEAs1AISZYfkUhMz3ipFRSNiu/25pbS4hrTOPN0zebWq69wd02TMJMo0aM6V+529wS/6rWIPwJNmN0MYupUatdcJcS089ATC/q7hibj8XdMfC14GWRrfJ6rv2R3pmuvDPlnY3pnc24vbM+jv2yuah5u/uk3plyt5S7pfR4tx4nWrB3d6uPA5BslFm5Asrd6ml5eVXKCdytXEI2OV26y5JWEr5XuZu6BybYEdsRq4yl5I4JdsDwysqtwxd0Lt9srnyzZynTGcewTuubNcf8JX0zQ/lmyjcb0zdbTE/vm7Hi0qf2zeBrT8xDIygrP03p9FPp9AW3QDoXPw0f+FN+2hDL+2T9NGMsP02wI3E/TbADLj/N4PHTLJo0lJ/2fGT6uflpltG3n2YqP035aWP6abrGyMEf2VGzWMe2z8NRe7LuWgVx5YMpfX2sviba7gn5YKwkF+WD9bS8T9YHM8fywQQ7EvfBBDvg8sFMLh9sqnywZynTz84Hay6dIOmDWcoHUz7YqD4YucfohD5Y82HN8/DBnrgnpvwxpbv71t0zbsFzNv4YK7FF+WM9Le+T9cessfwxwY7E/THBDrj8MYvLH1sqf+xZyvRz88ewbdufPzZV/pjyx0b1x8zlyf2xaXMd+3Pyx/4VXpnyzZQe77tcl8YthM7FN5uyklmUb9bT8j5Z32w6lm8m2JG4bybYAZdvNuXxzaam8s2epUw/N99syfLNKiJ+jMu/yD1eFzN9PqHu8tIvNG0x6fMuL/qOrrYSsIPfyjAr34VlVQsG5tdH1K5lYDRUKVE40F1fNYTHuLxraZ2EHvFldID6yhfSabPlhO9GuoulsSxRsgwVw7b7u6UOy6tzYYFZ5WIS3TIr1g4vD5A7ErHtbAzDA9V+9AoT1IdYjSSIAlh6+/tTq/X9gbhyfmItMZ8uK1rC+lcqiSq9mRYfXXc2NKteAtTAaaIMMtPZ/TSSe+V9fIFU0/uWNW17fyByX5xaCRllJTQ3eJXQYmpVGUXKnOpXEWExfz5sppfVR9UW60l9zMwytS+KUuuN3FF5H/sKjdyBKZX9/kDcsTwld7zU6uyxtHjZQ59XvQ3TOD174BzMs2GPeUULLSohx57YQ9eXZWNJK6T9sPcDa/w3BL/xA0/dD6w2IcfYhDSmlUu8GQVU2HfDD7YHqWv1LYHiZkbtBcUiiDPa99/evPtko4uCNz78Qe1qPckI6EF2HnWBF4uKjaG2tXRNXQo85ALziqmhrvACVkOjPu+6MMtP7Njb+tASpRS7xM1boCEo2Gyg61J4PeIxbUV7L6Rl5TFt3cdAKtiwKJMNZttxAWVxNzhA3kMLjs4DmEMGjjyXQYrMxcb3Ald8Mrow76cxIArsKLTTO9CiwC2gTSSJ1j2NbIRnb62tgyjx+qXN42cv27twzzr0HtI+hls0t85iKDBBs/c5f29i77vtA4Px4cjpDNcxkM6enYWBvwPoujbrJlSJlvPV6RQfygB7LgbYlHENINONwMZ+/xoaB31Ptn8AA29U3Afu60nvz32h/v5K/c0OPslHhchS02GhP7SV9fg+ffs9W95a3xNn/zn7/aUxTlio5qBW/c6e9hQMa8F0hJuioLX3ZyNEQXVdLIqkgkcTFTyaDBY8Mq1FeaOMUdRpxpL6h1T3AcR+PXpELpenTCG3KSvv89eP1y9yqzOPLx2AEFkg2zF/tfKp16n9nF9AD8EmeZVa8M8mgpjkd9PTxpIAIgGgfxsw2D5LudDIO442pF/YwAEj0tK9k2ATOZRAC9nBx6AFG8AIyPZfRkKg12M7j+xdFGOvgm/owHiA5AFMC6gn157/A0oFQyvawJTiJ/KkgqYDmee8NEuhhuG6iTWIttDSZvZRfKpRCxhx6MTm4nOceRcQalPBQ0OzAhvxGnk5P6TxZpe899K1u8lVYnvIGDYerf5hIgM0q2H70QEFnATN7h2uxQvoE311dgHsO6FD1sggKQsl5D89gpcLJ4qZ/xtmQfCCefQF9kmJupE/eBBwiHa0sd1oB5yc9pWBA36N3iPLQk2LLAYdPd85sbOGp3IC6NK9zs/gaHnvxB0u7ojqIBQS0QEuerQD/O96QefKCPcDQ0e+mzBJ8u1r+HwdxcAw2kehm8uPFNOo/cOJAz9pJFFZpBCRSuCUMzCExiPrFChNmO1j/4cDJXXn3MFgawIWvFlOlKah0lbf/BFmOwqjPDLInkdgCU4KRUXeosdCT2mbbJZdZBRiRIvcb7vFwYgm8nEKzw0NnByFyN8GQiNa+2DZ4fDvfWBkCk1AaRVWAAcgp+Aou6a/eAcKFTFdSIQi1M3Rnt1RWccVon+dJwBACMDDPpxDZAXkJkFhw+y92Emp4B3HwJmhv0bTlbxNrzDELg9RBnCdVl7O4NBwarEbGbMCyAtvXfCq/tj7nnnh+nFS6P+Xes2VVVHFJxJV1PvY1mX6l9ZssH1dXe3rDrnCFuMMPHOJB9vY1esbu9SWB7I8slWAZFbpVGBuazihaxfG0aTldm92M3dO4RqxzUrJ1pA3IwNcdUdE20i8tPAC8nHkWlSmFTQpxKwXbAAujvPgSXQNIemYjzTqB/Uvt4jEAxAFh4dFS5T4C1TtH15/EIAvecQF8DHt1bxcRrOC6PXDMHlr9bn+hZhDmwhYtPe5ubPJ1lCG5q4OMsfufSReMipkUng6fvg985GY22QhBqPR4x/pJnSqpCgADM2n0E+PgZeFhTxwTN/IFAU2qCx8kq2KtBvZFkr78ZKNwNVjSBNJJGw4odKk1CTa+FsAL2H/4yj448ZxiHFIgW+DaOUESIQINkH0tQxTHoDlmLIELwsryZQEXpIpCbw0U5IWjmFKdiNSxHgYkSxTkRYkmaoGf9w45JiKgMszlZvt9sUGATQ6lHP/XJx7cq6s0/VbDpczND1JzhB9zKxSCkDjLAVAMotyuOmkI9Go17NkZLU7D5ORwx395Q0dueLNFchJtkylcCR9+IRy9rLVbZHVrVJvJir1ZtKcegMlQJK/0sp3Apk400X5UK5OjlPSVYDwlWe0NF22RNKK/m69deqEW+Ss4/S32dwsd2jhB3SHBkN84yQh3KETgJUJndR7BSc3qbF0L3lz9QrgsrtX0GTt2hlj7HXkeef1NHvObZJslSf8exsf5Tsos+iJmkVzbtZuqdDI4uMBtzxYN9qrLY++FphV9Ze1wIPteDCWc0SjF3A1cBBLNq8+5bN5tQsrr8JAF3I7gxJYhAi6zWG82zR4Gv1iUdXXRkUPN9RX6E0HG6ep59TmW1m8dDafz8r+lW6eA50ZZp3ORjysIXzGwqyesSiMz8ZDFlWA+bxCmkMcsjBYW/xNhyzgdpFy9ZSr1+Dq9eDbGdNZlWvqFgO7uoFW9bV6NBrqaRI5G2jllOf/OXFjoQ6W50UFgvPTpC05ouRT8uWO/AhgiKLULW4gG79aBySTtYfsUjRpcMe/A6CebpeF/vfMy9cd5xnizMMjB1ifQfGB0UmjHcigvPtCQF+maeyvsrStWkxX1w5uIynwH4Aa+6QBmGF8wLkT3VKm9aDEWa5TcQYIdWeGnwCpnZN8sxHnhY15+ydAy43sMEpt0OEZIQWbbjxxQT68DCmPKsYHLBttDDZixD6Ectx0UTgU6QinwyGIwu3JkQDiJnRPjgXehT8dBrvo9LMQe06wOykG6FjZHmYk3EWCFmWnQdOOEDEXD4cXzsZeTKEJi66pOsmUdG2kHCij87zgQbbzzc9Br7WdFiSft+8/X/92fXvUpFc/PItJForrWOUJKAi4tk7e6g/gIfOImeab03rBjYg9P0lgaavcQz0XrFCW8u3l+9+u+ZyJDrxKbDcxGLfLVbAv4YFP152NPUdhZeMroc7LNk/v7NDz3ATd8AQPJYSe2o19qruxJNLbe2HRmTbYdixGQW3HDrLCM0YRm3FLixqz2gI3XhWXh/rgO0QybnbF0a3a4Z+KVGPXCHTzMzS5x1Bp+hCStcvvCXWxjvaPtabhwxxt1nm19gZxGIc5FfhHm0K+OM4ED/a882IPHWM+XA04weftLwTxSLz07esaEgk+8yS8FhCyCKrXmzyEGkSbLKl+FrIl00C09QYVyein4U2hHtHhPhzrbKPXyotCnRRTbfvh91oX93cO4LKEsRyQuq7uvPW3SeOxr25upE7IM4YG6NimXhFtulRMotw8lB2l6Kh0069aUT+mj3KglDGASiRVsPkitshoF0cd6ZV+S1dqmBwuNIVTu26hgl8OpyfbMSIncvGWmMhwCLCwDIKQpc0EUWAp4oSA0qQBgY9YegheXWFeODmhXEBKqNIcVxJrlVgbEiEVhWWcLuJbmUi2RxxDFIWrRv5E4em4nShsKb4mzHcotCJOSjgOI7w0lYiJsIQhsQ1Z4JrVAUXrbx4U77IqFApsaQEGgaUE2FH680jdxVJRvHByAqyAlODrHFcpAVasjZQAg7AyAgytjJQAywlCXIAhJ+4IAYaOOUsKMAgrLcAQ34kLMERKMgIMLc0RAmyLPR8ZAYYGm+9lCEIWx12JVyqOM7ssCsfKVncURD09Kv1JGGl/B3lIBhTIGTv55ocyjIAlDX09hUgbDZd5iMt2FUV+1lHkmcl5PYJuDnfWeXrSKzWLI8pc1xlQifjU+Y48ER9eGN/npcwcSfeMe2VPeUOCrs/KF8vqnPc3C9+caRhauSPTGiMdv352c9KQjn8JVLC6OVOl5Y+Rlq9r0zI3EO6ghDq5Sp0W6tV7n3vcOaqf1MzzByj+4Lg2My/Up8yRJ2qOLLhJuXlTm0m45mB72njPVe1pD7LAM07JpA8mmczZSY1N2tS8aD9dLG8ZWvNxDL7KmUhyRrL/g7zu2/APw7l7u8r+/jmNPm6+2l8eGRW3z99tID7CV9yeqMNQkcoa+O/Nm6q1NDvOszC5j41jeXkuVZRMjipKVRtEmebKNB/KNLfmF5WbyeYsG2daV4HEiherhzQ3uvvT5yybqtLdGNWQzLpH3Xt6e0PaMQmSN4LWT6ainCrqvq6ijngtJ1g5LE/TYTH7qInEZubhHBZVE2nIBcahla4FHiwHF3tHPDm4+QQw9v+at61hOTeP923UcGXLWeBOe14QntfzGxHibJ1m8PIq6vhW95jLYF0gPswwomC2MZwsJeKfi4hnXCDOlAD6rIcNMqafaz4VP5fbNaUcYkNfllziC+3wYKR9NMvg9XaxMB58J40EwHDcrBoQG2onbTad0u0x9vgMsw1goK03vEQCxZHpLYaDNC9+/JStlPs/Ue7/ZFD3fzkr++JzXGSRzrbAnF3WJVK+/2xWjTbMGfarZTJ6PIX3b9XL21399/L28urz9W2t7sLlzc2Hq8vPl69urlmnaUk6WFGfuLvORI+BhhZ0IKPAREAfUOTDGSDkoVtwedBBxatILfmDJJWZBdzKGUxA1UdShvx5GfJhdANDAo3ai9fQJxbDUSeqmcK57UQ1QzgLNl8NFY0iies1FFUQqT/K0lknuVlrP1wUqX5UnxnsgGuJa/wr2XhusnFICmXkATOl01BBjrrAGTHIUSrH3RrioCIXs8WiErmwzI7IhViApM8QB/eG/kAhDuHAhIX3KPHlBIVL1BiYmC6OBJhNOwCMxbQNYKjQh/i9UK2hjzdZEKjYx0TFPibDxj4a+LekYTSGhqmFOnu0gurpBs0Bh/zTFnYopRJwFbbsoze+Mp599AQPqcmNSxesrd2EwRpeYcqHwc3lp0+kOl37h3tN4UYkX3G8PqabHIPMtz85yyoeHytpXYHCF3jx7vKL/emvV5dfrj8J1B0fGLmQeCpSRTv56eBElTm7COW80AKUvwWS/VzQcf3YW6edQcdJP8wLzWVJJQDsSn5x2USmWUc0d6B+86uuz2PB6QIBVaB6Lt9nlMEXZrsVElR5Vh+8J6RzPJ+/frzmv9WhacEEr3IYaxIFr2wYjZlzsb3HMT75qsOyGFAZQL6LF00FyJ5ogKyPRE+m92INV27VUpmeQ66wxQrSs5Z4sCA93qunFvjj7Yer69d/3V6XdIdbJDxylJFkNtBYprRcohT10VoLho0eBMPGYKUDkkVKjEWRlmGtl5KhJQrcWRmHCQmRXke7PVTzXTVqGhvwQ9dft9WZaYTcBtHKCWw/Ip0rtfNc1I7F2pdhCSV93sPGzMfk7w/Rzz+1L6l//9L9K/34NbnCpyzbws/0PXv4mj0VWVaR5YEO1c0to5LmtsBbOXSa25J1TAPzTu9sYtTYhNwhBB7XIgvEw2ipfgELjG3aQgq99NBxSxdnLE+kR+BDZa2RmV7GtYvcrPnCyAGGVZSCG25EQLYNTg1d96X10knrFgasTfkCzSXwESw0q523ODE/dI8/Vyh56oXRGGmRIQjusAaJrgDDOgPs1nhT4ChY7KP79ruIGIuM4v+fb+2b6/e/Vi78gS+hhq/yTgSJgY42KcP23A3bVhPxmGgKU10bsx6iKUyUWTerq1hKT6vLuBacbY0NtLj1bNbWIq6tNlYrZIft1ArbaQW1QrdbN62gbXZKK2CH/dEK22VXtAK32gutkIXel4Lt3gZpBO/U881HuLt0c9MZ5SMwLm59kOADDCnDBxhWjg8wtAQfYFBhPsCAMnyAYaX4AAOL8wGGlOEDDHsEVcnxAYSk+EAZhc/EKFzWY51Ms2GqDRXrnNao7UxP2pM09JewErUxMelK1JpOEtN7P0HfttTdyeVGYZmdOrl8iS1UfEy2+N6U+m2Y8yMBZsVdin3liseb64/X7t+2nr1ffHf/cm6Dm488ofoibwVG6z+s/vHWqQrWT1Swvubm0sH6mgRnCInmYL1R5gN9xgjVTzE7lk6kV4+ky0h5JpvUQ/WY/sGkhyWin33PIsQ/gA63aFJfrvNFQGZ3flMnmin85oF98iZd/wd+RMJqtcApT8YY2pJP/TSguZVqndFhKQuqFI8rBe9WTuK54Ccb8s2vtT7xzySFLlwle6rDTjTQSXJ6j7C59DdCNFsF8JorVpCxjt2GztmTQAXvV3auBC868L7WdnzA05zQVL3Ac7ZwO+ReswYWSiJjib5FD1FPJnoq6jnc4uo6p2ITj3pGyFIDMEFRGoFSWZR8Yd+PBSjelpCULfewiaigxmaatYrG8aiez33rpVkM72QsarMe2tec3D04FuPSJB6PIN1czygWKqiKIzdO6Frf/nHK72n33ePaJDcI90CIpC2KGvtoTozVBrA+OS5upvErmyNstI0u5WJR4rFQRsqo+fcbNbrOSFFk6T3gCwprPvC1UH4CVs6sOwzyw4lv/EQFP1TwY8jgh6GVgx9MG5FZjm/Zw9Y4kzeai0mMG/swptP2q7/gzhPcKCsdj+NRpVWrB7n8a3ufxt0dIhEPcDy2z7bjZ/VwAT4bwNGtCh38a7XsTDR0wBQcfSRMMdFj3X2pQgf9LC4rX4q1uEMpBayVWjeOgEujTCZlMo1tMhmsox2jmkx687bqmdlMkEcljCZeCwk1L2UiCdhDoAtlDilzqNBJ52sP4WCGMoiGWN6TW0SsnbKKRVSuja5MImUSjWQSWdbJTSJWvfAxTCJSb0hm03CER2TjK/bdqlhoN5HyEnX/abfA1lEcenGCj9tJmWDnME29PcITAyt3KVPxuZqK5pmbivXi+8pU7G15T24qsspytRRIUYW3lbk4pLm4rJiL/BnXS/xi/xnXzQHmYe1Fkr3La4W1lLfgMVDaImel45XP1F472tDLZzL2vsOzkKgq9Zvb6z+fuxnc37SqKe11SlN/50FKHUcAtUmfLAz8nevvuDFh3/93XtML0LPj0s2Cilr5AhT5VpF3byvOH2Au85P6EjM6GPsj4xmJI7W64qsLLTc1ebKs4WaxA2MHSsL0Mo3SwkVNZh5Ez2J0BXBZYpduRJaR0/UKeW3y+IcTB36SiqVRHN1rUUoaOPUO9x6CCpz/ewPnS9HAecNJ/aEi5wYr9UpFzntaX5N1Jd+oJ1arYpo6tkZXAjhIMXSalRag3LJTuCt4dlEibndEP0VUa6SuRuhGOPoh35VweEO+K4mgg3xnJSNl7P7KBeeGnFJx71S+M2xHj9jVaBM5nlSkTMnhexP3v4W78pNxhgQPYY+hVg79DK5WSl2N0M3waoV0NbxaIV2NoVZIZyOpFXZ/Q0vDw5SOoFZIZ8OrlVpXo03k4GqF9DSKDPbDdQwcrCpZtoaAjE5f1aCcLVX/4vmEScwZZwGM2VgFMAyzFiUZs47thKpiS2radtSx1S4WS1K1NoecWfOJdBnbSoXZzrq2rWlLdGFb9otsAuGuYntckMx6gqu9nM3Kq71YGOOtdtsNXoMvNgIVLlk8w7eD4rQ+rbgasKkEcR1iVpwbaYJYWMcCzBclANEqx+BrHEUp/TqQ8nfvIhfGEK//Hw==7Z1bc9o6F4Z/TWb2d1GNzpIvm6THJD03bXrDEDDBDeDUQE6//pPAJj4IG4itqI07s3eLcSBa8qO11istaY8cjG/fRN2r4UnY90d7GPZv98jhHsaIEqr+0lfulleEIMsLF1HQj296uPA1uPfjizC+Og/6/jRz4ywMR7PgKnuxF04mfm+WudaNovAme9sgHGW/9ap74RcufO11R8WrP4L+bLi8SgiED2+89YOLYfzV6i1v+c64m9wd3zoddvvhTeoSebVHDqIwnC3/Nb498Efaeolhlj/3es27q98s8iezTX7gPeHvXv3ov+sMh29+BR1yfC2iF/GnXHdH87jFp340C5QB1NVvke+rv467d+F8FjdidpeYZnoTjEfdiXq1P511o1nceeq3IPvDMAruw8lMfQw5ROpCbxiM+vEHkcOZ+uDkRerexfeRQ/0BkT8N7rvno+R1T98QTPzo292VH3+CujxQl+PvRcqg+0WbJA1UrfJvU5diG73xw7E/i+7ULcm7LO6v+IlFJH5989D/lAq+vDhM9T2lyYMXP3QXqw9/6Bb1j7hntuglXOilPcxH2njn6h8X+h+D8bTTD7oXnfD8twYhfl993eqWQg/eDIOZ//Wq29OvbxTAujdm46TPisYsfYQ2tjBmkgPOFUPxH5YxOC3aGyW4pc2d9Evt1iYFa78++bo07iAY+dP/9sjL/606IErMqx5Y/789rH4ahgP9e/Vm8wVGix/SXzrRA6H6GD2I6Wf7f670iEQCIJbtBoQN/SAh4J7hyW+qK6jhwc+ZzO+rATt+6Y/Ow5tXDxf2FxfUG9fJoJYxZxTOJ32/nwxR8+h68UKPN9NwHvX8T34UqIb4ke6SYHIRv6lGuwt/tubN9FjI9a8w6adebdeDy9+iemBY/kLVj7S2VenzEPmj7iy4zjq/2nuVlQHmj/qbEjafBH/m/uKTokADNXWGKDVkUYDoaoiDpBouhkDiQazAxVu4aoGLOQWXaHu1ll6Vdfdq/KOfwkC1YzVQvBDcoxgwj6DlQIEyA4WXgz828vIzck/K6pfa/eGR60fm8/lg4EelQ/PivruuelgwS43mzgzKhAgOBHkYlWn1oMwRYDYHZa/FtxZ8EwHBAr/Cc4bfpNWpx2cBYvc2KCNXf+x0oVncqlt1suIIsJ5ggEtRjSkkANpMTFBROGk5NWQc1Zxie5yqLNcVTouKTk5jQM54TSqywsBKm03zh2wKNKio0LTw7QQftQafR9bDh6Rl+oqyEkj/cYU8BGVWi3YAvaJ206K3E3rcGnrcJfSKolPO8U2ccXxohZE7+LXqTjl+SWBVzZ89fQeT9fmhdf5KFB7NnyvsUanGrCx8XhE+yYrs4cbYa6WZCvbohuxhe9qMS+zhojjzl4SdBvTs+j3cyi0V7PFN2bOntzjFXoXg4gx7hZjz6dlr1ZYK9uSm7NmTW4hgwFuxh7OPlLDMXlFuWUwMdoLylR7p6cTiLTmt1HCHfrNz3Y1GwXTmTFKJs3gTvuFqN97Y2sJW0akLb3uSDhFyrWtdPVK28C5KOsu1Aim+3WAP8Wr4ZEOu1T/2zujP05Ozw97x9xffe78ImhpWX7foGVZWpckz2tFaTMsopE8wh1jW6JJVlO7MISJBJcDZ5TZGNRV6xuU2dRB493kyODkc3U1G8mg+OOtdvqbnLYHbE2i0ozUCCaMMSEispZNlzTUrOa5Ap4JGnQRsAB0HDFuErk0o64HOWjqJpScAZJI/KXTFNDLv8NyZO8QMYkA3YU8Cz1BL1hh77QTiir2yqKqSPWvThxhTpEIn/LQOrzhtuFBXKhScQpVickHXbe7pqt1RGC0+jv+Zh8sbFmWBg0H6UkbwUaBnvlI1Z/lp2W9IFz4afr2l5qvaPF38GlHkT6/CSV8/dLrCWN3WHeuhYnI+1X+FPfUsqyestyjk08VH2fdnw8X62aQOyZVRCJFNZnKwBwzzqPkHrLYRqJ1GrWcEsrfCHRMpgOC5IahBGbm0vX+BzsSot8HqBdGQ1GS2Xpvp1oSdtVQXcc4BRIibxCbr9BVT3n531o3LwjR+e/gg9393gORsEyCbTIS/y5PB7dGbiwtJPow/f5nuo4sfrfpUkQgbZl6MdrSGJBRCIUmhzDxLzcXiZa0tK9J0R/klUOj0JascGDNhDIE0lHA1Bl+rQtUDnzUVCqpsBhAqc1spNOcIy5q7ZhGfM9gxjoCXODOXsGuXG9SDna3FBtxjhAOufJ5xHZ9l+krKRxLf544ITIQaHCTFq/0GntYL/gx57+w38o5OPnReBPPh4HDQLkFI4VgWbKVxNNrRVgjKJVePCCM4G4I2yGFZc/P7DMSCTHj+2xkGoWTAy8efhuTPQ6v5mrrBwzdvv30V3cHgy5/9b9cvP0+9Y9GCVwGeoZjEaMd/F7yy5v6V4adx8qE5f2e0X5v1lWNnqCMx2tFW1ucIdsWsz1V/J4gElDzEnNnNc4xVlB4QDa25+8RHbNq7uPx2z079e3JzT4LW81UuOIdFBo2GtOb6PKTcDEE0p7ygxhgsa65xbyuHBE8pCRCkWnkxbaRbB3PkxRWeT2fD9zz6NH4z5zN0+71lbgfmjIa0F25SBAGWXHjLP9nnCTaGXlmr3V7vSjwPu0deG3DWRJ61iFNQhgEiFC/BywaetslbE3gunJ47Sqcaq5BGLwk6c2sVLDJ49JF8Pfz6E0ZHnR+f5q/3v3x614qcKQbLIqs0gkY7WnN+nHK9Uy8SlhEsa3Xq6dH0uYIe8SABMnmiS9I8LNVtFqFrHd8KurKYqhI6a37PKehKp9ndYc8UcRrYs+rt2hn2cvAMMwtGO1qbYXcKvOIMu0veji4mDPC6QNOAHoGNub1vgh3+OBZvYWc4EG8P7v68ujhsC6we6CubOU7TZ7SjrQIrLiDBgLI1QktzRf1lrTbVOLiCIOaMAQLRmlM0iCgyqH7AIxYZbEuM6mHQWolROYSkuQXWpc1OPT+T+bjjj/yxsn9pxaNqOgzVJZg6pqwfzKPJ4iTAaXd85dQpZYIhoDD0kj/Z0MOEMhLQVC1Yx0Eb5r5otZuaWLYm3gioT7KDNGY5OwFtneWietNTfT7rwFUZcaaS99/g2uNajl3PNQXJoR6Zs64ESJYLZNw0SYivn+5WJKqJbnsqEVQeADNsnB2xTndRJorj5Zk+J9oRHAniEsitImbOQdI2KxFze65HXSBaU42YBtGDLFGNskucrZO4dhfIfjB2qzyfYOX/PJqVjkwQSmVfm9JRe7pHXRBaE49UmMsA5sgNb7hOPfpvoiF0B0DiMSD5RgAKm7pRe8RHTQBaO+GDK/AIIEg6kWwaTvhYJJvuEcgQB8x7iEizK3tNLDZYH8U6H+969+LLq/37H4P7y5fdz/SknUfZfr8aox2tuUJMsV6wumbZXHPzKGWtzi2bO+uOR6/1kQGn3SRDzKs9evMavX8NdGTvurU7661kqMXedOmt6WBuNzpnRh0kIQf5wyhMK5X03pmyONawGsaa3tfb95+PfswjJL9/EAff8P67r+36wB2OQDAaElsabJjHPKH8Ebee/JY1O/X86OlaqP+pXyWrFJ6eQJzbD9J0AkIylVO3lzdartV/ayLPlv7LJGEEcEaw5YC7rNWpx0efF/QsDxYiGxxuYj5ZqCm2W0m5JrZtScpMwMVEhWdciGib7aKgvDw1LPIvFHd+5PefHeMMusZ4m6XXxLitNJ1RLDzAMXaC8WKarhcbV/hv/aE6vx13bzvdW9+Ztcmc7khnPQss0Nz/dPX7JpLTdx9/81F4encO28x2exXNaEdriS3yCAKYedjyauSyVueLT11NbiGVm2y73tBeJ2eju3HnN/wVnHnTD4y+3z/3W2VpB/6MdrTFHxX6CDrPY2ueo/rBK2vuer/oCHFoo33VOW9s6mjmTV9+3OdfboYvRx3282x6eXbaQrdDUGo0pDXqCIIYoNweX4STpqAra23qsbnSX+VH+jQDvdw3zijjA+PzoeniZh2XzsKtkk83UBYbKMPIJA3r9S81RK+Tzg9y+5Fdv+Y/X51ei/uzt+xtC/IDyGUn4qU5NtrRFsdqpPcwkMoHGKszm6tkLWv1+jPL3CBP17SuDr0trSEHvKElwSdve1/wn6s3dzjsX1x+5GHn80ELX4UXNYSuRjtagw8LXZgpPGbcbbzB3frKmp16fB6E206yNGFqWoAR55WpJQ7zSfBn7u89LGlwRvOhSA14JLeWGGGD7yQQeA0VzuFfB7P907uX43P6+kvn6FX08/JLi+/2vtNoR2v4QkEQEBLH+CaFa4lHaE6ZLWu2cf8VV+DTVUgA0VWVm1e9y3uDTtRoxnZ9Qz0U2lregCSXVCU0AjpB4Zrd/1YCLIYTZ2Dkevhao1fbIRB+H5++wh+jHiW97p/Dk/fBXbvb9C5ikNGQthwh4kgQQClfUy2ZXwVaH4JlzV5z4ILyhXAcRn6xjNwNKr0NVgVJ05RkDTheBr+C/fBX98vp5T759eX2zfj3sHWIFQ7RkFUa7WjNIepN7oC3mo+0txF1WbPd3hZQb5EE1k3dWjpv9tNFh59P+79fHb2fk/OzIxS9a8/e20HSMdrR1oI8TwgKJLIm5JQ1dh1ysftzgzxKOAHYq5ZjtExtqDCpQ4052H8x/vGhN74/vLwYnb6C7OQ1NG0pdZpAhOG3yNfq1nH3LpzPCrac3gTjUXfi52jQGcD+MIyC+3Ay6yaW7Q2DUT/+IHI4Ux+cvEjdu/i+JV+RPw3utaQWv+7pG4KJH33T5VHLT9hbFj3F36tSIlMHbl8NhHOrGQU1DJEeNBQA0+b6qZguJIVjH89/+71ZXDYGkzqxNbsHZeb6ljOBptqux1JT/qxt3hWQc+WwKBPZyXxTh+CGRExzU4rRd6aOb5feWM685srwquvtCtWAxPzjS8W625vNF2gvvq2GuaaaeppilX4zhFeiWbbDETH1uGnWV9axZNHcqGeQIpT2ZjpMKR2k0nFKKT71BSqP61mznGWoyq0COirgWqy03ZrxWThbIJuaeFphvJp4cgdlhD0BPLwBwMIywM8gzbAFcO1p/qY9O74gf97CX/vRpOeffYZ3N/h6/hy01Ed2rCGDNFrSmpgKJfQAwxLHPj+bS/LmxNSyZmceoM1jNrRmNHdkQFYZDGAoNyDrY1eKW20aJVdUx4hsNHsbUT1wW/ZcVmJrTXWFHqIxttnnSRQdd8PMFoO2dG1kWQ1mKpBKLdyBwUSbeujH2ZFDERXM2poYzi1D3IyuaIrdNpiqy+faUm1dgrdCvHUEPEqZspeLnvMZ1Ddbos9WgTOCQmAA10W89hEs1jhvE/NOYhfpcNyrz4ORqVV4uYlPI8YeA55pFVAtJE8n0d3p6MN3eCD+vMbhcThmpM1dK0k2rMUzWtJe7goJA/yB5Gx5WIO5a1mzd+B4IUY6nrx60gPS28gDG+ZNG+S2jX/r4tbeqgXMdTGnGdtGHXBZux2PgREhGAixCYHmTUSaQ7ANgutC0FYQ7BFI13tO+wjuHgMvfOfEbd+JuFThbH7LCHPca5fcZ7Cf/cbklgV1leBaOwlRqj8xuRa1o9I2p56e627UGUy6460X/KksdnSw2jGb9Lu+HPQWvR2Fl37qHd6T/vmgSVqlRAB61UovN8W5NSx0Mtu6TU+3n6IxW9JWeupR5K33sRLbzU4NK+UW0zR/O61EQADxBrQ2VMRiNnablFb4Vb4prbaSUkkYjZPSJ/erxYT0X/CrSEEI+Gr3CZg76MEIbUO7gplDvaLZW2h3CoaxsAUtw9AIrW3viosSSLPVn3UxiaAoyLomEoUENsNdbBIEWhZ3cKDYs8SikAIBxh1gsShqaPep/qvDgTJf9qnJgUp8TvgOPb2VAsy2dKAqlWU2uSVFSeD5clu2Wq6SW4Js+VBIBcCEiKTo52npJUWhI7OccPsdMR0iOLFlQqz3sC6wYgkTlrXsomk2eVEaaKHdDVpiDVqvDFoPFhecNs1tcQ05eMQ0qkPQovyxDY5QW1x33VK7G7XMErWCqXgMU1IIkZ+C16JEmfGzE/WPv9rV5jc2MlNrmm9tlNpWZKqg1rDdmNmStkQmjjAEENHE18qn1odJUWwyVNw4ojAxzgGjDzlrdusVo9SkxkhRpLK5nLVdBFETkkmgZON4XwKQxMnUanZFue2UlRZFj9qmVgcDn/eMEzZ94Z1D2CS6enMpQjaYWuVAcIvA0nYtRIU4vDGw2BKwVHIKJEPCCKx9F5o0vIEp1qckFjE9T8M2QFaAxAR2kG0rzOtC1laJOeXqIYFch71PqwjTotBR33zOQPZ8M63nUoetjdLKJVeh7kaTr0mQaofWdvlSBa1JClaNq7WzuQlEwOOScidCYtPh3I+axWmMQl1bLlOTqvntxI0nhBozVFzLlllme7YlNrURae0kbaKPW6LriPQKVR1NM1lcU5PZqd6dUjfGBEA85xfd4LDViurikNkSi1QgSwGCpLD1ln0E2RqlqM5Jl6eMaDmXgOYVIwO4HgSmbZvrAde4SXkrGe2w5aTRktYkI8gZEEJinsOW88agLWtw/oylWTAb1bCvfW25JIWAiNz5SqbdXpkEXkNqrdF8rfJTF3m2lB+CdKEGfdgG/Gn5W3PG2Xl36ve7M4cQFMQDhGyAoLHIuwb+Di9e8oPTu/vriH0IoiGicjhp+duhqsVoSFv4CeX3EOFSiqUoQbLPE2zuRKWyZv9zq+n1hkablHk3V/liNHcrvW5f+GI0pCXhlSEChHw4MUM8La1r9zLac70SjTKx0WRIgyUtRou2yuv2M5dGQ1rSXZGkDHhYcCKoC0SuVV2dJ1LqPaL4NuVmDU5UmhtVHO6e+6lpONEYSw5NE+YTXRs71qc4hKrw8TiYbntYWrJJfEeLpTZ3/OLb9gLJBZaGTjAlgc2dk1YchXQUr0P4sg36n/bEo62tvjqJbOvDjhqz+7OdL+LF6KF0cKg+6qj2+OFRPZs8anlZarEjYSeY9INe7hTBHdkq/PBMBQ2LYzJm+v/hzaQ4bsL4+50hk5Idyczv4Vxf/z3bGaHayUxQsE/m8e0PdnR08AZ+fnt1PPH6Z6PL989X8Ny4Yw0Zm9GS9k4zwtaOHStrqCk60ivVoOFcSXWXvhGmDvBlxdvyG7wbbnmEmtrYcJ2Lo1avq/aY5jWM1sYOeraqaO1MW9vkPemifB5qCekn2dR9+4yFV5NmStbrSFiMZnu2amftoFlbZirWCD6WQCtRFuLlbPW4z/jD/hYPKjdwocjkQpsKi5/vDtKPSXjMpsSW2Ea5tJlbZtuwabSG7Up/nx+tUTcW72ppYhYupYy0zOgInpxuoEdgA56ENHYsOi4a+7lPZhDC1zi3VD9RZugnnJ/lq6+bivqCXsNtms6AhRmMxWpvy7MXq+dqm5m/jNWfevYCrzliuGr6wiStLk5NbGog2t7Um8xYmMah5mz9XFPtVTurwoRkAKjWRWvXzx7Xs8WUeHWO6CYTFmU0bTJJsZyUCBqblXj8OGekjxjoa25W4rnm3w3QV7vS9aj067lOBD+qY81JiaXCQSxgrvDB8qyE4XytxVidTb8cGUsJqx5LzcuOtgZOvYzCcJY2tmrn8CTs+/qO/wM=
\ No newline at end of file
diff --git a/diag_manager/docs_uml/Untitled Diagram.drawio b/diag_manager/docs_uml/Untitled Diagram.drawio
deleted file mode 100644
index a4e56faf62..0000000000
--- a/diag_manager/docs_uml/Untitled Diagram.drawio
+++ /dev/null
@@ -1,141 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/diag_manager/docs_uml/classDiagramDiagObjects.drawio b/diag_manager/docs_uml/classDiagramDiagObjects.drawio
deleted file mode 100644
index 7d9233fcd7..0000000000
--- a/diag_manager/docs_uml/classDiagramDiagObjects.drawio
+++ /dev/null
@@ -1,277 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/diag_manager/docs_uml/diag_manager_end.drawio b/diag_manager/docs_uml/diag_manager_end.drawio
deleted file mode 100644
index 7ccb47c159..0000000000
--- a/diag_manager/docs_uml/diag_manager_end.drawio
+++ /dev/null
@@ -1,175 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/diag_manager/docs_uml/diag_manager_init.drawio b/diag_manager/docs_uml/diag_manager_init.drawio
deleted file mode 100644
index dc8b20961a..0000000000
--- a/diag_manager/docs_uml/diag_manager_init.drawio
+++ /dev/null
@@ -1 +0,0 @@
-UzV2zq1wL0osyPDNT0nNUTV2VTV2LsrPL4GwciucU3NyVI0MMlNUjV1UjYwMgFjVyA2HrCFY1qAgsSg1rwSLBiADYTaQg2Y1AA==
\ No newline at end of file
diff --git a/diag_manager/docs_uml/fms_diag_object_relationships.drawio b/diag_manager/docs_uml/fms_diag_object_relationships.drawio
deleted file mode 100644
index c431fb9f9d..0000000000
--- a/diag_manager/docs_uml/fms_diag_object_relationships.drawio
+++ /dev/null
@@ -1,277 +0,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90
index 65f310d4ca..550bd159a7 100644
--- a/diag_manager/fms_diag_yaml.F90
+++ b/diag_manager/fms_diag_yaml.F90
@@ -643,7 +643,8 @@ subroutine fill_in_diag_fields(diag_file_id, var_id, field)
enddo
deallocate(key_ids)
elseif (natt .ne. 0) then
- call mpp_error(FATAL, "diag_yaml_object_init: variable "//trim(field%var_varname)//" has multiple attribute blocks")
+ call mpp_error(FATAL, "diag_yaml_object_init: variable "//trim(field%var_varname)//&
+ " has multiple attribute blocks")
endif
!> Set the zbounds if they exist
diff --git a/test_fms/diag_manager/check_crashes.sh b/test_fms/diag_manager/check_crashes.sh
index c6634f7926..0a9a7cfeca 100755
--- a/test_fms/diag_manager/check_crashes.sh
+++ b/test_fms/diag_manager/check_crashes.sh
@@ -23,7 +23,6 @@
# execute tests in the test_fms/data_override directory.
# Set common test settings.
-. ../test_common.sh
printf "&check_crashes_nml \n checking_crashes = .true. \n/" | cat > input.nml
sed '/tile/d' diag_table.yaml_base > diag_table.yaml
@@ -61,7 +60,7 @@ test_expect_failure "freq is less than -1" '
mpirun -n 1 ../test_diag_yaml
'
-sed 's/kind: float/kind: mullions/g' diag_table.yaml_base > diag_table.yaml
+sed 's/kind: r4/kind: mullions/g' diag_table.yaml_base > diag_table.yaml
test_expect_failure "kind is not valid" '
mpirun -n 1 ../test_diag_yaml
'
@@ -95,5 +94,3 @@ sed 's/grid_type: latlon/grid_type: ice_cream/g' diag_table.yaml_base > diag_tab
test_expect_failure "the sub_region grid_type is not valid" '
mpirun -n 1 ../test_diag_yaml
'
-
-test_done
diff --git a/test_fms/diag_manager/diagTables/diag_table_yaml_26 b/test_fms/diag_manager/diagTables/diag_table_yaml_26
deleted file mode 100644
index d7c6132ded..0000000000
--- a/test_fms/diag_manager/diagTables/diag_table_yaml_26
+++ /dev/null
@@ -1,61 +0,0 @@
-title: test_diag_manager
-base_date: 2 1 1 0 0 0
-diag_files:
-- file_name: wild_card_name%4yr%2mo%2dy%2hr
- freq: 6
- freq_units: hours
- time_units: hours
- unlimdim: time
- new_file_freq: 6
- new_file_freq_units: hours
- start_time: 2 1 1 0 0 0
- file_duration: 12
- file_duration_units: hours
- write_file: false
- realm: ATM
- varlist:
- - module: test_diag_manager_mod
- var_name: sst
- output_name: sst
- reduction: average
- kind: float
- write_var: false
- global_meta:
- - is_a_file: true
-- file_name: normal
- freq: 24
- freq_units: days
- time_units: hours
- unlimdim: records
- varlist:
- - module: test_diag_manager_mod
- var_name: sst
- output_name: sst
- reduction: average
- kind: float
- write_var: true
- attributes:
- - do_sst: .true.
- sub_region:
- - grid_type: latlon
- dim1_begin: 64.0
- dim3_end: 20.0
-- file_name: normal2
- freq: -1
- freq_units: days
- time_units: hours
- unlimdim: records
- write_file: true
- varlist:
- - module: test_diag_manager_mod
- var_name: sstt
- output_name: sstt
- reduction: average
- kind: float
- long_name: S S T
- sub_region:
- - grid_type: index
- tile: 1
- dim2_begin: 10
- dim2_end: 20
- dim1_begin: 10
diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh
index 7f6f6a9848..3e92781ad8 100755
--- a/test_fms/diag_manager/test_diag_manager2.sh
+++ b/test_fms/diag_manager/test_diag_manager2.sh
@@ -483,7 +483,6 @@ test_expect_success "wildcard filenames (test $my_test_count)" '
mpirun -n 1 ../test_diag_manager_time
'
-
rm -f input.nml diag_table
touch input.nml
From 980cb5447d97d4e4ba8f6f222054f62b64bd21c7 Mon Sep 17 00:00:00 2001
From: rem1776
Date: Fri, 3 May 2024 10:11:42 -0400
Subject: [PATCH 166/168] fix: missed changes for test_diag_yaml
---
test_fms/diag_manager/test_diag_yaml.F90 | 3 ---
1 file changed, 3 deletions(-)
diff --git a/test_fms/diag_manager/test_diag_yaml.F90 b/test_fms/diag_manager/test_diag_yaml.F90
index 58d9b96244..57b8610e3a 100644
--- a/test_fms/diag_manager/test_diag_yaml.F90
+++ b/test_fms/diag_manager/test_diag_yaml.F90
@@ -21,7 +21,6 @@
!! in fms_diag_yaml_mod
program test_diag_yaml
-#ifdef use_yaml
use FMS_mod, only: fms_init, fms_end
use fms_diag_yaml_mod
use diag_data_mod, only: DIAG_NULL, DIAG_ALL, get_base_year, get_base_month, get_base_day, get_base_hour, &
@@ -48,8 +47,6 @@ subroutine compare_result_1d(key_name, res, expected_res)
end subroutine compare_result_1d
end interface compare_result
-type(diagYamlObject_type) :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init
-type(diagYamlObject_type) :: ans !< expected diagYamlObject
logical :: checking_crashes = .false.!< Flag indicating that you are checking crashes
integer :: i !< For do loops
integer :: io_status !< The status after reading the input.nml
From 87344eeb1aea61e70604c19abeddec2d91f30d6c Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Fri, 3 May 2024 14:06:03 -0400
Subject: [PATCH 167/168] chore: 2024.01 changelog and version updates (#1507)
---
CHANGELOG.md | 55 ++++++++++++++++++++++++++++++++++++++++++++++
CMakeLists.txt | 2 +-
configure.ac | 2 +-
libFMS/Makefile.am | 2 +-
4 files changed, 58 insertions(+), 3 deletions(-)
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 89c455606c..c4e463ac02 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -6,6 +6,61 @@ and this project uses `yyyy.rr[.pp]`, where `yyyy` is the year a patch is releas
`rr` is a sequential release number (starting from `01`), and an optional two-digit
sequential patch number (starting from `01`).
+## [2024.01] - 2024-05-03
+
+### Known Issues
+- Diag Manager Rewrite:
+ - If two empty files are present in the diag_table.yaml file the code will crash with a allocation error (#1506)
+ - Setting an output frequency of '0 days' does not work as expected and may cause an error stating a time_step has been skipped (#1502)
+ - The `flush_nc_files` and `mix_snapshot_average_fields` nml options are not yet functional. The `mix_snapshot_average_fields` option is planned to be deprecated (for the rewritten diag_manager only).
+ - Expected output file changes:
+ - If the model run time is less than the output frequency, old diag_manager would write a specific value (9.96921e+36). The new diag_manager will not, so only fill values will be present.
+ - A `scalar_axis` dimension will not be added to scalar variables
+ - The `average_*` variables will no longer be added as they are non-standard conventions
+ - Attributes added via `diag_field_add_attributes` in the old code were saved as `NF90_FLOAT` regardless of precision, but will now be written as the precision that is passed in
+ - Subregional output will have a global attribute `is_subregional = True` set for non-global history files.
+ - The `grid_type` and `grid_tile` global attributes will no longer be added for all files, and some differences may be seen in the exact order of the `associated_files` attribute
+
+- DIAG_MANAGER: When using the `do_diag_field_log` nml option, the output log file may be ovewritten if using a multiple root pe's
+- TESTS: `test_mpp_gatscat.F90` fails to compile with the Intel Oneapi 2024.01's version of ifort
+- BUILD(HDF5): HDF5 version 1.14.3 generates floating point exceptions, and will cause errors if FMS is built with FPE traps enabled.
+
+### Added
+- DIAG_MANAGER: The diag manager has been rewritten with a object oriented design. The old diag_manager code has been kept intact and will be used by default. The rewritten diag manager can be enabled via `use_modern_diag = .true.` to your `diag_manager_nml`. New features include:
+ - Self-describing YAML formatting for diag_table's
+ - Allows 4d variables
+ - Support defining subregions with indices
+ - More flexibility when adding metadata and defining output frequency
+- FMS2_IO: Adds support for collective parallel reads to improve model startup time. The collective reads are disabled by default and enabled via the `use_collective` flag in `netcdf_io_mod`.
+- DATA_OVERRIDE: Adds multifile support for using 3 input netcdf files instead of one. Three keys have been added to the data_table: `is_multi_file` to be set to true to enable the feature, as well as `prev_file_name` and `next_file_name` to set to the names of the additional files.
+- INTERPOLATOR: Adds support for yearly/annual data
+- DATA_OVERRIDE: Adds support for monotonically increasing/decreasing arrays
+- DOCS: Add documentation for the exchange grid (xgrid_mod) and update the contribution guide to add a section on code reviews
+- MPP: MPI sub-communicators for domains are now accessible via `mpp_get_domain_tile_commid` and `mpp_get_domain_commid` in `mpp_domains_mod`
+
+### Changed
+- DATA_OVERRIDE: Changes behavior to crash if both data_table and data_table.yaml are present and adds error checking when reading in yaml files
+- FIELD_MANAGER: Changes behavior to crash if both field_table and field_table.yaml are present as well as adds a namelist flag (`use_field_table_yaml`) to enable support for the yaml input.
+
+### Fixed
+- DATA_OVERRIDE: Fixes allocation error with scalar routine and replaces pointers with allocatables
+- INTERPOLATOR: Increase max string size for file paths
+- AXIS_UTILS: Improves performance of `nearest_index` routine
+- CMAKE: Fixes macOS linking issues with OpenMP
+
+### Tag Commit Hashes
+- 2024.01-beta5 d3bab5a84b6a51eddd46ab6fb65eaa532830c6c7
+- 2024.01-beta4 ac363ddfd3075637cecae30ddfbae7a78751197b
+- 2024.01-alpha6 2ace94564a08aec4d7ab7eca0e57c0289e52d5b1
+- 2024.01-alpha5 5ed0bd373cc59a9681052fa837cb83a67169d102
+- 2024.01-alpha4 8dd90d72b58f0de3632dc62920f8adfb996b2265
+- 2024.01-beta3 f71405a075102aef42f5811dc09e239ddd002637
+- 2024.01-beta2 bb6de937f70a08a440f5e63b8553b047c1921509
+- 2024.01-beta1 913f8aaecca374d5e10280056de862d5e4a7a668
+- 2024.01-alpha3 085c6bfc945a6f1c586b842ca6268fca442884d8
+- 2024.01-alpha2 38bfde30e1cb8bf5222410a9c37e71529567bf69
+- 2024.01-alpha1 ac0d086296ea8b9196552463655cb9a848db39fe
+
## [2023.04] - 2023-12-04
### Known Issues
- GCC 9 and below as well as GCC 11.1.0 are unsupported due to compilation issues. See prior releases for more details.
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 849e87e0b8..319ac474f6 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -26,7 +26,7 @@ set(CMAKE_Fortran_FLAGS_DEBUG)
# Define the CMake project
project(FMS
- VERSION 2023.04.0
+ VERSION 2024.01.0
DESCRIPTION "GFDL FMS Library"
HOMEPAGE_URL "https://www.gfdl.noaa.gov/fms"
LANGUAGES C Fortran)
diff --git a/configure.ac b/configure.ac
index 69c4ca15ef..4e0f5332d0 100644
--- a/configure.ac
+++ b/configure.ac
@@ -25,7 +25,7 @@ AC_PREREQ([2.69])
# Initialize with name, version, and support email address.
AC_INIT([GFDL FMS Library],
- [2023.04.00-dev],
+ [2024.01.00],
[gfdl.climate.model.info@noaa.gov],
[FMS],
[https://www.github.com/NOAA-GFDL/FMS])
diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am
index 4dea086bf2..fe796928aa 100644
--- a/libFMS/Makefile.am
+++ b/libFMS/Makefile.am
@@ -28,7 +28,7 @@ lib_LTLIBRARIES = libFMS.la
# These linker flags specify libtool version info.
# See http://www.gnu.org/software/libtool/manual/libtool.html#Libtool-versioning
# for information regarding incrementing `-version-info`.
-libFMS_la_LDFLAGS = -version-info 18:0:0
+libFMS_la_LDFLAGS = -version-info 19:0:0
# Add the convenience libraries to the FMS library.
libFMS_la_LIBADD = $(top_builddir)/platform/libplatform.la
From d42f8aca45bfefaaa45295888a36548b9a9b5a29 Mon Sep 17 00:00:00 2001
From: "github-actions[bot]"
<41898282+github-actions[bot]@users.noreply.github.com>
Date: Mon, 6 May 2024 09:34:33 -0400
Subject: [PATCH 168/168] chore: append dev to version number after release
(#1509)
---
configure.ac | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index 4e0f5332d0..f86eeb7d4f 100644
--- a/configure.ac
+++ b/configure.ac
@@ -25,7 +25,7 @@ AC_PREREQ([2.69])
# Initialize with name, version, and support email address.
AC_INIT([GFDL FMS Library],
- [2024.01.00],
+ [2024.01.00-dev],
[gfdl.climate.model.info@noaa.gov],
[FMS],
[https://www.github.com/NOAA-GFDL/FMS])