diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index db81ffb9af..4421b72854 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -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 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 08fed288cc..de71dcbbdf 100644 --- a/.github/workflows/github_cmake_gnu.yml +++ b/.github/workflows/github_cmake_gnu.yml @@ -16,13 +16,24 @@ 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:13.2.0 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/.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/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 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/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 759e6a1990..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) @@ -125,11 +125,20 @@ 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_utils.F90 + 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_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 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 @@ -345,9 +354,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/CONTRIBUTING.md b/CONTRIBUTING.md index 5769c50323..170f5431f5 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -103,6 +103,33 @@ Descriptive commit messages within PR’s should still be used, and some project The commit message on the main branch must follow the guidelines of [conventional commits](https://www.conventionalcommits.org/en/v1.0.0/), meaning it includes a ‘type’ prefix (ie. usually fix or feat(ure)) and a footer for any API-breaking changes. Additionally, commits should include the number of the pull request in parentheses (this is automatically added on github) to allow easier tracking of each commit. +## 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 github actions workflows to run build, runtime, and code linting tests for libFMS. Users may be required to create diff --git a/Makefile.am b/Makefile.am index 22fb68f97d..b07346ea3e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -45,6 +45,7 @@ SUBDIRS = \ mosaic2 \ fms \ parser \ + string_utils \ affinity \ mosaic \ time_manager \ @@ -125,10 +126,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/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() diff --git a/configure.ac b/configure.ac index 223733b9f9..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], - [2023.04.00-dev], + [2024.01.00-dev], [gfdl.climate.model.info@noaa.gov], [FMS], [https://www.github.com/NOAA-GFDL/FMS]) @@ -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 @@ -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_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 + 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() 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 land_area: 19790101.land_static.nc soil_area: 19790101.land_static.nc lake_area: 19790101.land_static.nc +``` + +### 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) + +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. + +### 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: + +``` + wa = + _, _, _, _, _, _, ... +``` + +Similarly, when a variable was registered, but send_data was never called, the old diag manager was outputting the warning like + +``` +WARNING from PE 0: diag_manager_mod::closing_file: module/output_field soil/soil_fgw, skip one time level, maybe send_data never called +``` + +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. + + diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index 606ebd76f2..85bd119bf6 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_object_mod, only:fms_diag_object USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR IMPLICIT NONE @@ -52,7 +53,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 @@ -134,6 +135,14 @@ 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 + !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, 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 + endif IF ( PRESENT(tile_count)) THEN tile = tile_count ELSE @@ -576,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 @@ -599,14 +612,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_diag_object%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. @@ -688,6 +705,12 @@ TYPE(domain2d) FUNCTION get_domain2d(ids) ! input argument has incorrect size. CALL error_mesg('diag_axis_mod::get_domain2d', 'input argument has incorrect size', FATAL) END IF + + if (use_modern_diag) then + get_domain2d = fms_diag_object%fms_get_domain2d(ids) + return + endif + get_domain2d = null_domain2d flag = 0 DO i = 1, SIZE(ids(:)) @@ -1040,7 +1063,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_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 END SUBROUTINE diag_axis_add_attribute_scalar_r SUBROUTINE diag_axis_add_attribute_scalar_i(diag_axis_id, att_name, att_value) @@ -1048,7 +1075,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_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 END SUBROUTINE diag_axis_add_attribute_scalar_i SUBROUTINE diag_axis_add_attribute_scalar_c(diag_axis_id, att_name, att_value) @@ -1056,7 +1087,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_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 END SUBROUTINE diag_axis_add_attribute_scalar_c SUBROUTINE diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value) @@ -1064,15 +1099,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_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 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_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 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 e5d7942946..abf08d18f7 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -48,10 +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_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 @@ -62,6 +64,29 @@ MODULE diag_data_mod PUBLIC ! 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 + !> 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 @@ -73,13 +98,37 @@ 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 :: 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 !! 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 + INTEGER, PARAMETER :: null_gridtype = DIAG_NULL + INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method + 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 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 + 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. @@ -280,6 +329,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 + procedure :: write_metadata + end type fmsDiagAttribute_type ! Include variable "version" to be written to log file. #include @@ -330,24 +388,38 @@ MODULE diag_data_mod !! 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 + !! 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 !! 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 - 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 !! 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 ! @@ -381,10 +453,200 @@ 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 + + !> @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 + 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) + this%att_name = att_name + select type (att_value) + type is (integer(kind=i4_kind)) + 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) :: this%att_value(natt)) + this%att_value = att_value + type is (real(kind=r4_kind)) + 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) :: this%att_value(natt)) + this%att_value = att_value + type is (character(len=*)) + allocate(character(len=len(att_value)) :: this%att_value(natt)) + select type(aval => this%att_value) + type is (character(len=*)) + aval = att_value + end select + 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 + 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 9a72598915..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(>),& @@ -208,7 +211,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 @@ -223,19 +226,22 @@ 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,& & 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 + & 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 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 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, & @@ -341,6 +347,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 @@ -376,7 +383,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 @@ -390,6 +397,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 ! Fatal error if range is present and its extent is not 2. IF ( PRESENT(range) ) THEN @@ -398,24 +407,33 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', FATAL) END IF END IF - - IF ( PRESENT(init_time) ) THEN - register_diag_field_scalar = 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,& - & (/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 + 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, & + & 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, & + & 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) + & 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 @@ -424,7 +442,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t 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 - LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant + 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 @@ -437,6 +455,144 @@ 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 + 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, & + & 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, & + 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, & + & 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 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,& + & 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 + 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 + !! 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 + + ! 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 + + 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,& + & 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 +END FUNCTION register_static_field + + !> @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 + 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 + 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_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_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_old + + !> @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, 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", + !! "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 INTEGER :: field, j, ind, file_num, freq INTEGER :: output_units @@ -471,7 +627,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) @@ -486,7 +642,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 ! @@ -497,8 +653,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 @@ -508,7 +664,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 '& @@ -526,7 +682,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 '& @@ -542,7 +698,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 '& @@ -610,11 +766,11 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t END DO END IF - 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,& + 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 @@ -642,12 +798,12 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, 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 ! 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. @@ -702,15 +858,15 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, ! 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 - 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) @@ -727,7 +883,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 @@ -740,7 +896,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 @@ -761,7 +917,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) @@ -771,7 +927,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) @@ -779,7 +935,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) @@ -899,7 +1055,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 (" & @@ -910,7 +1066,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 (" & @@ -1010,7 +1166,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) @@ -1057,7 +1213,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 @@ -1090,7 +1246,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. @@ -1100,9 +1256,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_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 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 @@ -1297,7 +1460,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 @@ -1308,9 +1471,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) @@ -1330,7 +1507,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 @@ -1340,11 +1517,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) @@ -1399,7 +1591,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 @@ -1411,9 +1603,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) @@ -1474,16 +1680,18 @@ 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 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 @@ -1518,7 +1726,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(*), 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 ! @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 @@ -3635,6 +3914,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 @@ -3697,6 +3981,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) + + if (use_modern_diag) then + call fms_diag_object%diag_end(time) + endif END SUBROUTINE diag_manager_end !> @brief Replaces diag_manager_end; close just one file: files(file) @@ -3780,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 @@ -3794,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, use_mpp_io, field_log_separator,& - & use_refactored_send + & 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 @@ -3810,7 +4099,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 @@ -3849,6 +4142,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 @@ -3884,21 +4181,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) @@ -3907,7 +4197,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) @@ -3915,12 +4205,16 @@ 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 + if (use_modern_diag) then + 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) + 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 @@ -3937,22 +4231,10 @@ 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 - !> @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) @@ -3961,12 +4243,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. @@ -4215,7 +4497,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_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 END SUBROUTINE diag_field_add_attribute_scalar_r !> @brief Add a scalar integer attribute to the diag field corresponding to a given id @@ -4224,7 +4510,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_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 END SUBROUTINE diag_field_add_attribute_scalar_i !> @brief Add a scalar character attribute to the diag field corresponding to a given id @@ -4233,7 +4523,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_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 END SUBROUTINE diag_field_add_attribute_scalar_c !> @brief Add a real 1D array attribute to the diag field corresponding to a given id @@ -4242,7 +4536,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_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 END SUBROUTINE diag_field_add_attribute_r1d !> @brief Add an integer 1D array attribute to the diag field corresponding to a given id @@ -4251,7 +4549,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_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 END SUBROUTINE diag_field_add_attribute_i1d !> @brief Add the cell_measures attribute to a diag out field @@ -4272,6 +4574,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) @@ -4279,6 +4586,38 @@ 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 + 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, intent(out) :: data_out(:,:,:,:) !< 4D version of the data + + !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 subroutine copy_3d_to_4d + END MODULE diag_manager_mod !> @} ! close documentation grouping 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..216f14bad3 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,& @@ -57,8 +57,9 @@ 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 ! @addtogroup diag_util_mod !> @{ + ! Include variable "version" to be written to log file. #include @@ -645,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 @@ -1194,7 +1197,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 +1211,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 +1225,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) ) @@ -1266,75 +1269,6 @@ SUBROUTINE sync_file_times(file_id, init_time, err_msg) END DO END SUBROUTINE sync_file_times - !> @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) @@ -1738,8 +1672,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 @@ -2118,195 +2052,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) - 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. @@ -2332,7 +2077,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 +2112,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/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 +``` diff --git a/diag_manager/fms_diag_axis_object.F90 b/diag_manager/fms_diag_axis_object.F90 new file mode 100644 index 0000000000..a28d22b291 --- /dev/null +++ b/diag_manager/fms_diag_axis_object.F90 @@ -0,0 +1,1491 @@ +!*********************************************************************** +!* 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 +#ifdef use_yaml + use mpp_domains_mod, only: domain1d, domain2d, domainUG, mpp_get_compute_domain, CENTER, & + & 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, & + 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, MAX_SUBAXES + use diag_grid_mod, only: get_local_indices_cubesphere => get_local_indexes + use axis_utils2_mod, only: nearest_index + implicit none + + PRIVATE + + 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, 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 + + !> @} + + !> @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 + procedure :: get_ntiles + 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 diagnostic axis description. + !> @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 :: get_axis_name + procedure :: is_z_axis + procedure :: write_axis_metadata + procedure :: write_axis_data + 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 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 + 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 + 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 + 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 + !> @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 + 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 + 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, 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", + !! 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=:), 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 + 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 + CHARACTER(len=:), ALLOCATABLE, private :: set_name !< Name of the axis set. This is to distinguish + !! two axis with the same name + + contains + + PROCEDURE :: add_axis_attribute + PROCEDURE :: register => register_diag_axis_obj + PROCEDURE :: axis_length => get_axis_length + PROCEDURE :: set_edges + PROCEDURE :: set_axis_id + PROCEDURE :: get_compute_domain + PROCEDURE :: get_indices + PROCEDURE :: get_global_io_domain + PROCEDURE :: get_aux + 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 + + !> @addtogroup fms_diag_yaml_mod + !> @{ + contains + + !!!!!!!!!!!!!!!!! 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, axis_length ) + 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 + 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 + 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, intent(in), optional :: axis_length !< The length of the axis size(axis_data(:)) + + 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)) this%long_name = trim(long_name) + + select type (axis_data) + type is (real(kind=r8_kind)) + 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(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. & + & Currently only r4 and r8 data is supported.") + end select + + 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 :: 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 :: 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 :: this%axis_domain) + call this%axis_domain%set(DomainU=DomainU) + this%type_of_domain = UG_DOMAIN + endif + + this%tile_count = 1 + if (present(tile_count)) this%tile_count = tile_count + + this%domain_position = CENTER + if (present(domain_position)) this%domain_position = domain_position + call check_if_valid_domain_position(this%domain_position) + + this%direction = 0 + if (present(direction)) this%direction = direction + call check_if_valid_direction(this%direction) + + 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) + + 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 + + !> @brief Add an attribute to an axis + subroutine add_axis_attribute(this, att_name, att_value) + 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 + + integer :: j !< obj%num_attributes (for less typing) + + if (.not. allocated(this%attributes)) & + allocate(this%attributes(max_axis_attributes)) + + this%num_attributes = this%num_attributes + 1 + + 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(this, fms2io_fileobj, edges_in_file, parent_axis) + class(fmsDiagAxis_type), target, INTENT(IN) :: this !< diag_axis obj + 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 + !! 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 + + 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) + axis_name => this%axis_name + axis_length = this%length + 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 + 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) + type is (fmsDiagFullAxis_type) + 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(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 (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(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) + !< 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(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(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(fms2io_fileobj, axis_name) + call register_field(fms2io_fileobj, axis_name, diag_axis%type_of_data, (/axis_name/)) + case default + !< 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(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 + 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) + + if (trim(diag_axis%units) .NE. "none") & + 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(fms2io_fileobj, axis_name, "positive", "up", str_len=2) + case (direction_down) + 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(fms2io_fileobj, axis_name, "edges", diag_axis%edges_name, & + str_len=len_trim(diag_axis%edges_name)) + endif + + if(allocated(diag_axis%attributes)) then + 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(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(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 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) :: 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 + 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 this%get_global_io_domain(global_io_index) + 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 + + if (present(parent_axis)) then + select type(parent_axis) + type is (fmsDiagFullAxis_type) + call write_data(fms2io_fileobj, this%subaxis_name, parent_axis%axis_data(i:j)) + end select + endif + type is (fmsDiagDiurnalAxis_type) + call write_data(fms2io_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) + 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 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 + 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) & + result (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 + axis_length = this%axis_domain%length(this%cart_name, this%domain_position, this%length) + else + axis_length = this%length + endif + + 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 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 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) & + 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) & + 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 + integer, intent(in) :: axis_id !< Axis_id + + this%axis_id = axis_id + + end subroutine set_axis_id + + !> @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 + 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 + subroutine get_indices(this, compute_idx, corners_indices, starting_index, ending_index, need_to_define_axis) + 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 + !! 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 + + !< 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 = 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 = 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 + 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 + + 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 + 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 + + 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 + + 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, 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 + 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 + 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 + 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 + 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 + ! 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 + !> @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 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 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) & + 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 + function get_length(this, cart_axis, domain_position, global_length) & + result (length) + 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 + + integer :: length + + select type (this) + type is(diagDomain2d_t) + 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 + end select + end function get_length + + !!!!!!!!!!!!!!!!! FMS_DOMAIN PROCEDURES !!!!!!!!!!!!!!!!! + + !> @brief Set the axis domain + 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(this) + type is (diagDomain1d_t) + this%Domain = Domain + type is (diagDomain2d_t) + this%Domain2 = Domain2 + type is (diagDomainUg_t) + this%DomainUG = DomainU + end select + end subroutine set_axis_domain + + !< @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 + + 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 + + fms_diag_axis_object_init = .true. + end function fms_diag_axis_object_init + + !< @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 + + if (allocated(axis_array)) deallocate(axis_array) + fms_diag_axis_object_end = .false. + + 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 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 + + 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 Loop through a variable's axis_id to determine and return the domain type and domain to use + 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 + 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) + 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) > 1) & + & .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 + endif + end select + enddo + end subroutine get_domain_and_domain_type + + !> @brief Fill in the subaxis object for a subRegion defined by index + 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 + 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 :: 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 + + !< 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) + + if (.not. write_on_this_pe) return + + 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 + + !< 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_new_subaxis_index + + !> @brief Fill in the subaxis object for a subRegion defined by lat lon + 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 + 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(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 + 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 + !! 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, is_x_y_axis) + + !< If this is not a "X" or "Y" axis go to the next axis + 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(1), ending_index(1), & + 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 + 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, is_x_y_axis) + + !< If this is not a "X" or "Y" axis go to the next axis + 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(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) + 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) + 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 + 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) + 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) + 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 + 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) + 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,:), global_idx(i,:)) + end select + enddo + + 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, & + nz_subaxis) + + 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 + 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(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 + 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! + + !< 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 + 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, compute_idx, global_idx=global_idx, zbounds=zbounds, nz_subaxis=nz_subaxis) + 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 + type is (fmsDiagDiurnalAxis_type) + parent_axis_id = diag_null + 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 + + !< @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, 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 + + 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 + if (trim(axis%set_name) .eq. trim(set_name)) then + axis_id = i + return + endif + endif + end select + enddo + + 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, fms2io_fileobj) + class(fmsDiagDiurnalAxis_type), intent(in) :: this !< Diurnal axis Object + class(FmsNetcdfFile_t), intent(inout) :: fms2io_fileobj !< Fms2_io fileobj to write the data to + + 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(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(fms2io_fileobj, this%axis_name, "edges", & + &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, 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 + 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 + 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 + !! 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 + + 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, nz_subaxis=nz_subaxis) + var_axis_ids(i) = subaxis_id + return + endif + end select + 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 +!> @} +! close documentation grouping diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 index 7fa331258a..81c0a33d51 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, string implicit none @@ -39,28 +39,100 @@ 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 + !! 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, 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) @@ -104,6 +176,83 @@ 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) + 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 @@ -136,17 +285,78 @@ 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) 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 @@ -162,6 +372,156 @@ 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 + + !> @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_field_object.F90 b/diag_manager/fms_diag_field_object.F90 new file mode 100644 index 0000000000..550037a904 --- /dev/null +++ b/diag_manager/fms_diag_field_object.F90 @@ -0,0 +1,1951 @@ +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: 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, & + &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, 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, 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 +!!!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 + +!> \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 + 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 + logical, allocatable, private :: scalar !< .True. if the variable is a scalar + logical, allocatable, private :: registered !< true when registered + 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 + 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 + 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 + !! functions. False when done. + 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 + logical :: halo_present = .false. !< set if any halos are used + 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 :: 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 + 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 + procedure :: set_var_is_masked + procedure :: get_var_is_masked +! 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 + 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 + 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_axis_ids + procedure :: has_area + procedure :: has_volume + procedure :: has_missing_value + procedure :: has_data_RANGE + procedure :: has_input_data_buffer +! 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 + 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 + procedure :: set_file_ids + 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 + procedure :: add_area_volume + procedure :: append_time_cell_methods + 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 + 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 + +logical,private :: module_is_initialized = .false. !< Flag indicating if the module is initialized + +!type(fmsDiagField_type) :: diag_object_placeholder (10) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +public :: fmsDiagField_type +public :: fms_diag_fields_object_init +public :: null_ob +public :: fms_diag_field_object_end +public :: get_default_missing_value +public :: check_for_slices +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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) + 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) + 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 & + (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, & + multiple_send_data) + + 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 + !! 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 + 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 + 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) + this%modname = trim(modname) + +!> 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) + if (present(standname)) this%standname = trim(standname) + + !> 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 + endif + + if (present(missing_value)) then + select type (missing_value) + type is (integer(kind=i4_kind)) + allocate(integer(kind=i4_kind) :: this%missing_value) + this%missing_value = missing_value + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: this%missing_value) + this%missing_value = missing_value + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: this%missing_value) + this%missing_value = missing_value + type is (real(kind=r8_kind)) + 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 + endif + + if (present(varRANGE)) then + select type (varRANGE) + type is (integer(kind=i4_kind)) + allocate(integer(kind=i4_kind) :: this%data_RANGE(2)) + this%data_RANGE = varRANGE + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: this%data_RANGE(2)) + this%data_RANGE = varRANGE + type is (real(kind=r4_kind)) + allocate(integer(kind=r4_kind) :: this%data_RANGE(2)) + this%data_RANGE = varRANGE + type is (real(kind=r8_kind)) + 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 + 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(this%area) + this%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(this%volume) + this%volume = volume + endif + + this%mask_variant = .false. + if (present(mask_variant)) then + this%mask_variant = mask_variant + endif + + if (present(do_not_log)) then + allocate(this%do_not_log) + 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)) + 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(this , id) + class (fmsDiagField_type) , intent(inout):: this + integer :: 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 + 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 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 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, 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) + 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) + 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 +!> 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 + + character(len=128) :: err_msg !< Error msg + err_msg = "" + + allocate(this%input_data_buffer) + 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 + 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) + 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 Set the mask_variant to .true. +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%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) + 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 + 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 (this%vartype) + case (r8) + 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(this%varname)//& + " is REAL(kind=4)", NOTE) + case (i8) + 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(this%varname)//& + " is INTEGER(kind=4)", NOTE) + case (string) + 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(this%varname)//& + " was not set", WARNING) + case default + 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(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(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 = this%diag_id + + 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 (this) result(diag_id) + class(fmsDiagField_type) , intent(in) :: this +!> Check if the diag_object registration has been done + if (allocated(this%registered)) then + !> Return the diag_id if the variable has been registered + diag_id = this%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: +!> [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(this) result(rslt) + class(fmsDiagField_type), allocatable, intent(in) :: this + character(:), allocatable :: rslt + character (len=:), allocatable :: registered, vartype, varname, diag_id + if ( .not. allocated (this)) then + varname = "?" + vartype = "?" + registered = "?" + diag_id = "?" + rslt = "[Obj:" // varname // "," // vartype // "," // registered // "," // diag_id // "]" + return + end if + +! if(allocated (this%registered)) then +! registered = logical_to_cs (this%registered) +! else +! registered = "?" +! end if + +! if(allocated (this%diag_id)) then +! diag_id = int_to_cs (this%diag_id) +! else +! diag_id = "?" +! end if + +! if(allocated (this%vartype)) then +! vartype = int_to_cs (this%vartype) +! else +! registered = "?" +! end if + + if(allocated (this%varname)) then + varname = this%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 (this) result (rslt) + class(fmsDiagField_type), intent(in) :: this + logical :: rslt + rslt = this%registered +end function diag_obj_is_registered + +function diag_obj_is_static (this) result (rslt) + class(fmsDiagField_type), intent(in) :: this + logical :: rslt + rslt = .false. + if (allocated(this%static)) 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 + +!> @brief Gets attributes +!! @return A pointer to the attributes of the diag_obj, null pointer if there are no attributes +function get_attributes (this) & +result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag object + type(fmsDiagAttribute_type), pointer :: rslt(:) + + rslt => null() + if (this%num_attributes > 0 ) rslt => this%attributes +end function get_attributes + +!> @brief Gets static +!! @return copy of variable static +pure function get_static (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + logical :: rslt + rslt = this%static +end function get_static + +!> @brief Gets regisetered +!! @return copy of registered +pure function get_registered (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + logical :: rslt + rslt = this%registered +end function get_registered + +!> @brief Gets mask variant +!! @return copy of mask variant +pure function get_mask_variant (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + logical :: rslt + rslt = .false. + if (allocated(this%mask_variant)) rslt = this%mask_variant +end function get_mask_variant + +!> @brief Gets local +!! @return copy of local +pure function get_local (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + logical :: rslt + rslt = this%local +end function get_local + +!> @brief Gets vartype +!! @return copy of The integer related to the variable type +pure function get_vartype (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer :: rslt + rslt = this%vartype +end function get_vartype + +!> @brief Gets varname +!! @return copy of the variable name +pure function get_varname (this, to_write) & +result(rslt) + 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 +!! @return copy of the variable long name or a single string if there is no long name +pure function get_longname (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + 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 (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + 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 (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + 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 (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + 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 (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + 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 (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + 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 (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer, allocatable, dimension (:) :: rslt + 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 (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer :: rslt + 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 (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer :: rslt + 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 (this) & +result(rslt) + class (fmsDiagField_type), intent(in) :: this !< diag object + integer :: rslt + 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 +!! @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 + 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 + + !< 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 +!! @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 + 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 +!! @return pointer to the axis ids +function get_axis_id (this) & +result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag object + integer, pointer, dimension(:) :: rslt !< field's axis_ids + + if(allocated(this%axis_ids)) then + rslt => this%axis_ids + else + rslt => null() + 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 + +!> @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 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) & +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() + 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_varname() + 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, 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 + 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) + 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)) + + !< 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 + 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 + 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(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(fms2io_fileobj) + type is (FmsNetcdfFile_t) + call register_field(fms2io_fileobj, varname, vartype, dimensions) + type is (FmsNetcdfDomainFile_t) + call register_field(fms2io_fileobj, varname, vartype, dimensions) + type is (FmsNetcdfUnstructuredDomainFile_t) + 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, 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) :: 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 + 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(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 + 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() + + if (allocated(this%axis_ids)) then + call this%get_dimnames(diag_axis, field_yaml, unlim_dimname, dimnames, is_regional) + 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(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(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(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(fms2io_fileobj, var_name, "units", units, str_len=len_trim(units)) + + if (this%has_missing_value()) then + call register_variable_attribute(fms2io_fileobj, var_name, "missing_value", & + this%get_missing_value(field_yaml%get_var_kind())) + call register_variable_attribute(fms2io_fileobj, var_name, "_FillValue", & + this%get_missing_value(field_yaml%get_var_kind())) + else + call register_variable_attribute(fms2io_fileobj, var_name, "missing_value", & + get_default_missing_value(field_yaml%get_var_kind())) + 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(fms2io_fileobj, var_name, "valid_range", & + this%get_data_range(field_yaml%get_var_kind())) + endif + + if (this%has_interp_method()) then + 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 = "" + !< 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(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(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(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(fms2io_fileobj, var_name, "standard_name", & + trim(this%get_standname()), str_len=len_trim(this%get_standname())) + + 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(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) + endif +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, fms2io_fileobj, var_name, diag_axis) + CLASS(fmsDiagField_type), intent(in) :: this !< The field object + 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 + + 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(fms2io_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) & + result(rslt) + class (fmsDiagField_type), target, intent(in) :: this !< diag field + class(*),dimension(:,:,:,:), pointer :: rslt !< The field's data buffer + + 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 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) + class (fmsDiagField_type), intent(in) :: this !< diag object + 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 + +!!> @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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (this) + class (fmsDiagField_type), intent(in) :: this !< diag object + 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) + 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 (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 (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 (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%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_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 + character(len=*), intent(in) :: att_name !< Name of the attribute + class(*), intent(in) :: att_value(:) !< The attribute value to add + + 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(this%varname)//". Increase diag_manager_nml:max_field_attributes.") + + 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(real(kind=r4_kind) :: rslt) + rslt = real(CMOR_MISSING_VALUE, kind=r4_kind) + case (r8) + allocate(real(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) & + result(diag_field_id) + 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 (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 + +!> @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_methods = trim(cell_methods)//" time: point " + case (time_diurnal) + cell_methods = trim(cell_methods)//" time: mean" + case (time_power) + cell_methods = trim(cell_methods)//" time: mean_pow"//int2str(field_yaml%get_pow_value()) + case (time_rms) + cell_methods = trim(cell_methods)//" time: root_mean_square" + case (time_max) + cell_methods = trim(cell_methods)//" time: max" + case (time_min) + cell_methods = trim(cell_methods)//" time: min" + case (time_average) + cell_methods = trim(cell_methods)//" time: mean" + case (time_sum) + cell_methods = trim(cell_methods)//" time: sum" + end select +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 + 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 + +!< @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 + +!> 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 + +!> @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 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, 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 *, "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 + else + this%mask = mask_in + 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), 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 + 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) + 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 + +!> @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 + +!> @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 + +!> @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 + + rslt = .false. + + 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 new file mode 100644 index 0000000000..974364044d --- /dev/null +++ b/diag_manager/fms_diag_file_object.F90 @@ -0,0 +1,1825 @@ +!*********************************************************************** +!* 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 +#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, & + 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, 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(<) +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_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, & + uppercase, lowercase, NOTE + +implicit none +private + +public :: fmsDiagFileContainer_type +public :: fmsDiagFile_type, 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 + 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 + 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!< .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 + logical :: is_file_open !< .True. if the file is opened + + 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 + 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 :: 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 + 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 :: 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 :: 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 + + 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 + procedure, public :: has_fileobj + procedure, public :: has_diag_yaml_file + 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 + 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_field_ids +! The following fuctions come will use the yaml inquiry functions + 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_sub_region_grid_type + 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 + 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 + 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 :: 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 + 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 +type fmsDiagFileContainer_type + 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_global_metadata + procedure :: write_time_metadata + procedure :: write_field_data + procedure :: write_axis_metadata + procedure :: write_field_metadata + 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 :: prepare_for_force_write + procedure :: init_unlim_dim + procedure :: update_current_new_file_freq_index + 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 +!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 (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 + if (diag_yaml%has_diag_files()) then + nFiles = diag_yaml%size_diag_files() + allocate (files_array(nFiles)) + set_ids_loop: do i= 1,nFiles + !> 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 + 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. + obj%is_subaxis_defined = .false. + obj%number_of_axis = 0 + 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%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 + obj%domain => null() + + !> This will be set in a add_axes + allocate(obj%axis_ids(max_axes)) + 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%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()) + + 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%unlim_dimension_level = 0 + obj%is_static = obj%get_file_freq() .eq. -1 + obj%nz_subaxis = 0 + + nullify(obj) + 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 +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 + 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_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. +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 + 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 + + 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 + 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 + 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) + 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 (this) + class(fmsDiagFile_type), intent(in) :: this !< The file object + 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 +!! \return .True. if diag_yaml_file exists .False. if diag_yaml has not been set +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 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) + 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 (this) result (res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + res = this%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 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! TODO +!!> \brief Returns a copy of the value of diag_yaml_file +!!! \return A copy of diag_yaml_file +!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 + +!> \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 (this) result (res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character(len=:), dimension(:), allocatable :: res + 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 (this) result (res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer, dimension(:), allocatable :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=:), allocatable :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=:), allocatable :: res + res = this%diag_yaml_file%get_file_unlimdim() +end function get_file_unlimdim + +!> \brief Returns a copy of file_sub_region from the yaml object +!! \return Pointer to file_sub_region +function get_file_sub_region (obj) result(res) + 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 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), pointer :: subregion !< Subregion 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 +!! \return Copy of file_new_file_freq +pure function get_file_new_file_freq (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=:), allocatable :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + integer :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=:), allocatable, dimension(:) :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + character (len=MAX_STR_LEN), allocatable, dimension(:,:) :: 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) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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 (this) result(res) + class(fmsDiagFile_type), intent(in) :: this !< The file object + logical :: res + 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(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(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 +!> @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(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), 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 + + 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 + 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: "//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(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(fmsDiagOutputBuffer_type), intent(inout) :: output_buffers(:) !< Array of output buffers + + 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 + 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), + !! 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, this%nz_subaxis) + endif + + select type(this) + type is (subRegionalFile_type) + 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 this%define_new_subaxis(var_axis_ids, x_y_axis_id, is_cube_sphere, diag_axis, naxis) + this%is_subaxis_defined = .true. + endif subaxis_defined + type is (fmsDiagFile_type) + do i = 1, size(var_axis_ids) + 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 +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 + !! 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 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 this%start_time is equal to the base_time, + !! simply update it with the start_time and set up the *_output variables + 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()) + 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 + 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 + 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 + +!> 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_close', date_to_string(this%next_close) + + 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', & + 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 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 + 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 + 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 + + file_is_opened = .false. + !< Go away if it the file is already open + if (diag_file%is_file_open) return + + is_regional = .false. + !< 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%fms2io_fileobj) + is_regional = .true. + type is (fmsDiagFile_type) + !< 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%fms2io_fileobj) + case (TWO_D_DOMAIN) + allocate(FmsNetcdfDomainFile_t :: diag_file%fms2io_fileobj) + case (UG_DOMAIN) + allocate(FmsNetcdfUnstructuredDomainFile_t :: diag_file%fms2io_fileobj) + end select + end select + 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, diag_file%get_filename_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 (fms2io_fileobj => diag_file%fms2io_fileobj) + type is (FmsNetcdfFile_t) + if (is_regional) then + 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(fms2io_fileobj, "is_subregional", "True", str_len=4) + else + allocate(pes(mpp_npes())) + call mpp_get_current_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(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(fms2io_fileobj, file_name, "overwrite", domain%DomainUG)) & + &call mpp_error(FATAL, "Error opening the file:"//file_name) + end select + end select + + file_is_opened = .true. + diag_file%is_file_open = file_is_opened + domain => null() + 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 :: 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 + 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(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) + endif +end subroutine write_global_metadata + +!< @brief Writes a variable's metadata in the netcdf file +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(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(fms2io_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 + + class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open + 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 + + 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 + fms2io_fileobj => diag_file%fms2io_fileobj + + time_var_name = diag_file%get_file_unlimdim() + 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(),& + & 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) + + dimensions(1) = "nv" + dimensions(2) = trim(time_var_name) + + 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(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(fms2io_fileobj, time_var_name, "calendar_type", & + uppercase(trim(calendar)), str_len=len_trim(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(fms2io_fileobj, time_var_name, "bounds", & + trim(time_var_name)//"_bnds", str_len=len_trim(time_var_name//"_bnds")) + + !< 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 + 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(fms2io_fileobj, time_var_name//"_bnds", dimensions, & + trim(time_var_name)//" axis boundaries", time_units_str) + endif + +end subroutine write_time_metadata + +!> \brief Write out the field data to the file +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 + logical :: has_diurnal !< indicates if theres a diurnal axis to adjust for + + 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 + !! 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 (buffer_obj%get_unlim_dim() .eq. 1) then + call buffer_obj%write_buffer(fms2io_fileobj) + diag_file%data_has_been_written = .true. + endif + else + 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=buffer_obj%get_unlim_dim(), is_diurnal=has_diurnal) + endif + 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) + 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 + 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 + +!> \brief Determine if it is time to "write" to the file +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) 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. 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 + !! 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 + ! 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 + +!> \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) + 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 :: 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 + real :: T2 !< The ending time of the averaging period + + diag_file => this%FMS_diag_file + fms2io_fileobj => diag_file%fms2io_fileobj + + !< If data has not been written for the current unlimited dimension + !! 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 + 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(fms2io_fileobj, diag_file%get_file_unlimdim(), dif, & + 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()) + + 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(fms2io_fileobj, "nv", (/1, 2/)) + 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 +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%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 + diag_file%last_output = diag_file%no_more_data + 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 +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%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(), & + diag_file%get_file_frequnit()) + endif + +end subroutine update_next_write + +!> \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. + + 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 +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 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 + 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 +subroutine write_axis_metadata(this, diag_axis) + class(fmsDiagFileContainer_type), intent(inout), target :: this !< The file 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 :: 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 + integer :: edges_id !< Id of the axis edge + + 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 + fms2io_fileobj => diag_file%fms2io_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(fms2io_fileobj, .true.) + call diag_file%add_new_axis(edges_id) + endif + endif + + if (parent_axis_id .eq. DIAG_NULL) then + call axis_ptr%axis%write_axis_metadata(fms2io_fileobj, edges_in_file) + else + 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(fms2io_fileobj, .false.) + enddo + endif + + enddo + +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 :: 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 + + 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() + + 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 = "" + 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. + call diag_field(field_ptr%get_area())%generate_associated_files_att(associated_files, diag_file%start_time) + 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. + 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) + 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 +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 :: 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 + 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(fms2io_fileobj) + else + 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(fms2io_fileobj) + enddo + endif + enddo + +end subroutine write_axis_data + +!< @brief Closes the diag_file +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 + + !< 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( fms2io_fileobj => this%FMS_diag_file%fms2io_fileobj) + type is (FmsNetcdfDomainFile_t) + call close_file(fms2io_fileobj) + type is (FmsNetcdfFile_t) + call close_file(fms2io_fileobj) + type is (FmsNetcdfUnstructuredDomainFile_t) + call close_file(fms2io_fileobj) + end select + + !< 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. + + 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 + + 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 + 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(1:this%number_of_buffers) +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 + +!> @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_input_buffer.F90 b/diag_manager/fms_diag_input_buffer.F90 new file mode 100644 index 0000000000..92952ecadc --- /dev/null +++ b/diag_manager/fms_diag_input_buffer.F90 @@ -0,0 +1,356 @@ +!*********************************************************************** +!* 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 + 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 :: 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 + 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 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 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 + 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 + + 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." + end select + + this%weight = 1.0_r8_kind + this%initialized = .true. + 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) + 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 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) & + 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 + 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%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 + +#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 new file mode 100644 index 0000000000..661455afdc --- /dev/null +++ b/diag_manager/fms_diag_object.F90 @@ -0,0 +1,1496 @@ +!*********************************************************************** +!* 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 +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, & + &time_none, time_max, time_min, time_sum, time_average, time_diurnal, & + &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, & + & 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, & + 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, 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, & + &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 +USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type, determine_if_block_is_in_region +#if defined(_OPENMP) +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 + +type fmsDiagObject_type +!TODO add container arrays +#ifdef use_yaml +private +!TODO: Remove FMS prefix from variables in this type + class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files + 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 + 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 + logical, private :: buffers_initialized=.false. !< True if the fmsDiagObject is initialized + logical, private :: axes_initialized=.false. !< True if the fmsDiagObject is initialized +#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 + 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_field_name_from_id + 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 + procedure :: allocate_diag_field_output_buffers + procedure :: fms_diag_compare_window +#ifdef use_yaml + procedure :: get_diag_buffer +#endif +end type fmsDiagObject_type + +type (fmsDiagObject_type), target :: fms_diag_object + +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 +integer, private :: registered_variables !< Number of registered variables +public :: dump_diag_obj + +contains + +!> @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 (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 (this%initialized) return + +! 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%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%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 (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 + + ! 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 + do i=1, size(this%FMS_diag_output_buffers) + 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) + 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 + +!> @brief Registers a field. +!! @description This to avoid having duplicate code in each of the _scalar, _array and _static register calls +!! @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, & + 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 + CHARACTER(len=*), INTENT(in) :: varname !< The variable name + 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 !< .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 + !! 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 !< 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 + 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 +#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_FIELD_NOT_FOUND + fms_register_diag_field_obj = DIAG_FIELD_NOT_FOUND + deallocate(diag_field_indices) + return + endif + + this%registered_variables = this%registered_variables + 1 + fms_register_diag_field_obj = this%registered_variables + + call this%FMS_diag_fields(this%registered_variables)%& + &setID(this%registered_variables) + +!> 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) + +!> 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, & + 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, 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 + 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)) + 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) + 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) + 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)) + 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()) + 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_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) + 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_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 + + !> 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(), & + this%FMS_diag_files(file_ids(i))%get_next_next_output(), is_static=fieldptr%is_static()) + enddo + + nullify (fileptr) + nullify (fieldptr) + deallocate(diag_field_indices) +#endif +end function fms_register_diag_field_obj + +!> @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, 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 + 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 + 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") +#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, multiple_send_data=multiple_send_data) +#endif +end function fms_register_diag_field_scalar + +!> @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, & + & 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 + 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 !< .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 + 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 + 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 +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, & + & multiple_send_data=multiple_send_data) +#endif +end function fms_register_diag_field_array + +!> @brief 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) + 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 + 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(*), OPTIONAL, INTENT(in) :: range(:) !< Range to be added as a attribute + 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 + !! 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 + +#ifndef use_yaml +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" + ! 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 + +!> @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, axis_length, 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") + 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 + 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 + +#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 + + 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(edges_name, edges) + 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, axis_length=axis_length) + + id = this%registered_axis + call axis%set_axis_id(id) + end select +#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, 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, allocatable, INTENT(in) :: mask(:,:,:,:) !< Logical mask indicating the grid + !! points to mask (null if no mask) + 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 + 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 :: 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=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 + !! 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 + + !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()) + + !< 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)) + + !< Set the field_weight. If "weight" is not present it will be set to 1.0_r8_kind + field_weight = set_weight(weight) + + !< 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)) + + 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. 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 (allocated(mask) .and. allocated(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 + 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 + + !> 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 (.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 +!$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)) 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 = & + this%FMS_diag_fields(diag_field_id)%allocate_data_buffer(field_data, 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_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 + 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 + 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)) 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)) + + call this%allocate_diag_field_output_buffers(field_data, diag_field_id) + 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.) + 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, field_info) + return + end if main_if + !> Return false if nothing is done + fms_diag_accept_data = .FALSE. + return +#endif +end function fms_diag_accept_data + +!< @brief Do the math for all the buffers +subroutine do_buffer_math(this) + class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object + +#ifdef use_yaml + integer :: i !< For do loops + integer :: ifile !< For file loops + integer :: ifield !< For field loops + + 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 :: 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 + 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) + 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 + 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) + 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=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 + 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) + 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 + +#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 + +!> @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, end_time) + class(fmsDiagObject_type), target, intent(inout) :: this !< The diag object + 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) + 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 !< force the last write if at end of run + 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 + 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. + + 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) + 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() + ! 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 + + 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 + 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()) + error_string = diag_buff%diag_reduction_done_wrapper( & + field_yaml%get_var_reduction(), & + mval, diag_field%get_var_is_masked(), diag_field%get_mask_variant()) + endif + endif + 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 (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) + 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 + enddo +#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 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(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 + 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 + + 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 + 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, 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 + 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 + 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 + 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) + 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 + + !< 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) + 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 + 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 + 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 + 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 + + !< Determine the reduction method for the buffer + reduction_method = field_yaml_ptr%get_var_reduction() + if (present(time)) call 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_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_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_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_var_is_masked(), & + 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%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%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, field_ptr%has_missing_value(), & + pow_value = 2) + if (trim(error_msg) .ne. "") then + 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_var_is_masked(), & + 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 default + 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 = "" + 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 +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 + 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 +#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 + else + 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 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 + + 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 +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") + + 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) + 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, 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") + enddo + call axis%add_structured_axis_ids(uncmx_ids) + endif + end select +#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) & + 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 + +#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. + do i=1, this%registered_variables + !< 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 + + !< 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 + diag_field_id = DIAG_FIELD_NOT_FOUND + 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 +!! 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 + 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') + rslt = this%FMS_diag_output_buffers(bufferid) +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) + class(fmsDiagObject_type), intent (in) :: this !< The diag object + INTEGER, DIMENSION(:), INTENT(in) :: ids !< Axis IDs. + +#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 + + 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 +#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 + +#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 + + 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() + type is (fmsDiagSubAxis_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 + +#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") + + !! 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) + axis_name = axis%get_axis_name() + end select +#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 + +!> @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 :: 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, 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=:), 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 + + 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)) + + ! Get variable/field name + 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() + + ! 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 + call this%FMS_diag_output_buffers(buffer_id)%get_axis_ids(axis_ids) + ndims = size(axis_ids) + endif + + 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 + + axes_length = 1 + do j = 1, ndims + axes_length(j) = this%fms_get_axis_length(axis_ids(j)) + enddo + + if (num_diurnal_samples .ne. 0) then + 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:4), & + 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 + nullify(axis_ids) + + 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") +#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 diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90 new file mode 100644 index 0000000000..15a96362fe --- /dev/null +++ b/diag_manager/fms_diag_output_buffer.F90 @@ -0,0 +1,907 @@ +!*********************************************************************** +!* 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_output_buffer_mod +#ifdef use_yaml +use platform_mod +use iso_c_binding +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, 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 +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, time_update_done +use fms_diag_time_utils_mod, only: diag_time_inc + +implicit none + +private + +!> holds an allocated buffer0-5d object +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 + 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 + 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, 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 + + 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 + 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 + 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 + procedure :: write_buffer_wrapper_u + procedure :: allocate_buffer + procedure :: initialize_buffer + procedure :: get_buffer + procedure :: flush_buffer + procedure :: do_time_none_wrapper + procedure :: do_time_min_wrapper + procedure :: do_time_max_wrapper + 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 +public :: fmsDiagOutputBuffer_type + +! public routines +public :: fms_diag_output_buffer_init + +contains + +!!--------module routines + +!> Initializes a list of diag buffers +!> @returns true if allocation is successfull +logical function fms_diag_output_buffer_init(buffobjs, buff_list_size) + 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 + +!!--------generic routines for any fmsDiagBuffer_class objects + +!> 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 + + this%buffer_id = id +end subroutine set_buffer_id + +!> 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%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, 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 + + integer :: n_samples !< number of diurnal samples, defaults to 1 + + 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:" // & + 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), & + & n_samples)) + 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%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%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%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. + this%send_data_called = .false. + 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) = n_samples +end subroutine allocate_buffer + +!> 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 + + integer(i4_kind) :: buff_size(5)!< sizes for allocated buffer + + 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, "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 + +!> @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.') + + select type(buff => this%buffer) + type is(real(r8_kind)) + 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 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 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 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') + end select + +end subroutine initialize_buffer + +!> @brief Adds the axis ids to the buffer object +subroutine add_axis_ids(this, axis_ids) + class(fmsDiagOutputBuffer_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 +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 + else + allocate(res(1)) + res = diag_null + endif +end subroutine + +!> @brief Get the field id of the buffer +!! @return the field id of the buffer +function get_field_id(this) & + result(res) + class(fmsDiagOutputBuffer_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(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(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 + +!> @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 + 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, 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 + + 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) 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 + +!> @brief Update the buffer time if it is a new time +subroutine update_buffer_time(this, time) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object + type(time_type), intent(in) :: time !< Current model time + + if (time > this%time) then + this%time = time + endif +end subroutine update_buffer_time + +!> @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) & + result(res) + + class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object + integer :: res + + 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 + 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, is_diurnal=is_diurnal) + type is (FmsNetcdfDomainFile_t) + 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, 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.") + 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 +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, buff_ptr(1,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (1) + 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, buff_ptr(:,:,1,1,1), unlim_dim_level=unlim_dim_level) + case (3) + call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,1,1), unlim_dim_level=unlim_dim_level) + case (4) + call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,1), unlim_dim_level=unlim_dim_level) + case (5) + 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, 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, buff_ptr(1,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (1) + 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, buff_ptr(:,:,1,1,1), unlim_dim_level=unlim_dim_level) + case (3) + call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,1,1), unlim_dim_level=unlim_dim_level) + case (4) + call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,1), unlim_dim_level=unlim_dim_level) + case (5) + 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, 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, buff_ptr(1,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (1) + 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, buff_ptr(:,:,1,1,1), unlim_dim_level=unlim_dim_level) + case (3) + call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,1,1), unlim_dim_level=unlim_dim_level) + case (4) + call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,1), unlim_dim_level=unlim_dim_level) + case (5) + call write_data(fms2io_fileobj, varname, buff_ptr(:,:,:,:,:), 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, 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_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 + 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, is_masked, bounds_in, bounds_out, & + real(missing_value, kind=r4_kind)) + class default + 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 + +!> @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, & + 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 + 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 + 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=150) :: 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)) + 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) + 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)) + 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) + 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 + +!> 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, 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 + + 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, 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, & + mask_variant, this%diurnal_sample_size) + 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 !< 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) & + result(res) + class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object + + logical :: res + + 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 +!! @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 + + this%send_data_called = .true. +end subroutine set_send_data_called +#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 new file mode 100644 index 0000000000..86fe98aedf --- /dev/null +++ b/diag_manager/fms_diag_reduction_methods.F90 @@ -0,0 +1,169 @@ +!*********************************************************************** +!* 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 + use fms_diag_bbox_mod, only: fmsDiagIbounds_type + use fms_string_utils_mod, only: string + use diag_data_mod, only: time_diurnal, time_rms + 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, 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 + interface do_time_none + 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 + + !> @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 + + !> @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. + !! @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(:,:,:,:), 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 + + ALLOCATE(oor_mask(SIZE(field, 1), SIZE(field, 2), SIZE(field, 3), SIZE(field, 4))) + oor_mask = .true. + + if (allocated(mask)) then + oor_mask = mask + elseif (allocated(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 + +#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/fms_diag_time_utils.F90 b/diag_manager/fms_diag_time_utils.F90 new file mode 100644 index 0000000000..9bc306b562 --- /dev/null +++ b/diag_manager/fms_diag_time_utils.F90 @@ -0,0 +1,386 @@ +!*********************************************************************** +!* 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, 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, 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 + +implicit none +private + +public :: diag_time_inc +public :: get_time_string +public :: get_date_dif + +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. + + 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_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 + + 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 = '' + + ! 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_forecast_time_inc = increment_time(time, output_freq, 0, err_msg=error_message_local) + ELSE + 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_forecast_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_MINUTE), 0, & + &err_msg=error_message_local) + ELSE + 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_forecast_time_inc = increment_time(time, NINT(output_freq*SECONDS_PER_HOUR), 0, & + &err_msg=error_message_local) + ELSE + 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_forecast_time_inc = increment_time(time, 0, output_freq, err_msg=error_message_local) + ELSE + 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_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 + 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' + END IF + + IF ( error_message_local /= '' ) THEN + IF ( fms_error_handler('diag_forecast_time_inc',error_message_local,err_msg) ) RETURN + END IF + 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 + !! @return Character(len=128) get_time_string + CHARACTER(len=128) FUNCTION get_time_string(filename, current_time) + CHARACTER(len=*), 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) + 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/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 new file mode 100644 index 0000000000..550bd159a7 --- /dev/null +++ b/diag_manager/fms_diag_yaml.F90 @@ -0,0 +1,1983 @@ +!*********************************************************************** +!* 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 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, & + 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, & + fms_f2c_string +use platform_mod, only: r4_kind, i4_kind, r8_kind, i8_kind +use fms_mod, only: lowercase + +implicit none + +private + +public :: diag_yaml +public :: diag_yaml_object_init, diag_yaml_object_end +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 +public :: fms_diag_yaml_out +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 +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 + 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 :: 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 + 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 :: 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 + !! 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), 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 + !! 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, 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 :: 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. + 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 +type diagYamlFilesVar_type + character (len=:), private, allocatable :: var_fname !< The field/diagnostic name + character (len=:), private, allocatable :: var_varname !< The name of the variable + 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 + 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 + 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 + !! 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. + procedure :: get_var_fname + procedure :: get_var_varname + procedure :: get_var_reduction + procedure :: get_var_module + procedure :: get_var_kind + 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 + procedure :: is_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_zbounds + procedure :: has_var_attributes + procedure :: has_n_diurnal + procedure :: has_pow_value + procedure :: add_axis_name + procedure :: is_file_subregional + +end type diagYamlFilesVar_type + +!> @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, public, dimension (:) :: diag_files!< History file info + type(diagYamlFilesVar_type), allocatable, public, 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 + procedure :: get_diag_fields !< Returns the diag_field array + procedure :: get_diag_field_from_id + + procedure :: has_diag_title + procedure :: has_diag_basedate + procedure :: has_diag_files + procedure :: has_diag_fields + +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 (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 + +!> @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), pointer :: 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 (this) & +result (diag_basedate) + class (diagYamlObject_type), intent(in) :: this !< The diag_yaml + integer, dimension (basedate_size) :: diag_basedate !< Basedate array result to return + + 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(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 +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 (this) & + result (diag_title) + class (diagYamlObject_type), intent(in) :: this !< The diag_yaml + character(len=:),allocatable :: diag_title !< Basedate array result to return + + 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(this) & +result(diag_files) + class (diagYamlObject_type), intent(in) :: this !< The diag_yaml + type(diagYamlFiles_type), allocatable, dimension (:) :: diag_files !< History file info + + 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(this, yaml_id) & + result(diag_field) + 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 + + 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 => 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(this) & +result(diag_fields) + class (diagYamlObject_type), intent(in) :: this !< The diag_yaml + type(diagYamlFilesVar_type), allocatable, dimension (:) :: diag_fields !< Diag fields info + + 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 +!! diag_yaml object +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 + 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 + character(len=:), allocatable :: filename!< Diag file name (for error messages) + + 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) + 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)) + allocate(ignore(nfiles)) + + call get_block_ids(diag_yaml_id, "diag_files", diag_file_ids) + + ignore = .false. + total_nvars = 0 + !< If you are on two seperate pelists + if(diag_subset_output .ne. DIAG_ALL) then + 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. + 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 ignoring the file, ignore the fields in that file too! + if (.not. ignore(i)) 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 + 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 + + 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 + !> Loop through the number of nfiles and fill in the diag_yaml obj + nfiles_loop: do i = 1, nfiles + 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)) + + !> 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)) + 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.) + 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 + + !> 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)//& + ":"//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) + 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) + diag_yaml_module_initialized = .true. +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_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) + 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) + + 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 +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) :: 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 + 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 + 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") + deallocate(buffer) + + 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(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(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(yaml_fileobj, buffer) + deallocate(buffer) + + 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(yaml_fileobj%file_fname, buffer, yaml_fileobj%file_duration, yaml_fileobj%file_duration_units, & + "file_duration") + + 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, & + yaml_fileobj%file_fname) + elseif (nsubregion .eq. 0) then + yaml_fileobj%file_sub_region%grid_type = null_gridtype + else + call mpp_error(FATAL, "diag_yaml_object_init: file "//trim(yaml_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(yaml_fileobj%file_global_meta(nkeys, 2)) + do j = 1, nkeys + 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(yaml_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(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 + 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 + 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", buffer) + call set_field_reduction(field, buffer) + + call diag_get_value_from_key(diag_file_id, var_id, "module", field%var_module) + 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.) + !! 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 + + !> 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 +!! 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, 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,:)) + +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_id) & +result(total_nvars) + + integer, intent(in) :: diag_yaml_id !< Id for 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, 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 + +!> @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 + 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 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 (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 + + 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(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 ("") + yaml_fileobj%filename_time = middle_time !< This is the default + case ("begin") + yaml_fileobj%filename_time = begin_time + case ("middle") + yaml_fileobj%filename_time = middle_time + case ("end") + 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(yaml_fileobj%file_fname)) + end select +end subroutine set_filename_time + +!> @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(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 set_field_kind + +!> @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 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 + integer :: ioerror !< io error status after reading in the diurnal samples + + n_diurnal = 0 + pow_value = 0 + ioerror = 0 + if (index(reduction_method, "diurnal") .ne. 0) then + 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) & + 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)) + field%var_reduction = time_diurnal + elseif (index(reduction_method, "pow") .ne. 0) then + 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) & + 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 (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(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 + endif + + field%n_diurnal = n_diurnal + field%pow_value = pow_value +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 +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") + 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 + 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 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 (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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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(this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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(this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + 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 (this) & +result (res) + 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 +pure function get_file_new_file_freq(this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + character (:), allocatable :: res(:) !< What is returned + 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 (this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + 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, +!! 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(this) & +result (res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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(this) & + result(res) + class (diagYamlFiles_type), intent(in) :: this !< The object being inquiried + logical :: res + res = .false. + if (allocated(this%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 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!! 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + integer, allocatable :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + integer, allocatable :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + + if (this%has_var_outname()) then + res = this%var_outname + else + 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=:), allocatable :: res !< What is returned + 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 (this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + real(kind=r4_kind) :: res(2) !< What is returned + 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(this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + character (len=MAX_STR_LEN), allocatable :: res (:,:) !< What is returned + 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(this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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(this) & +result (res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + integer :: res !< What is returned + 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(this) & +result(res) + class (diagYamlFilesVar_type), intent(in) :: this !< The object being inquiried + logical :: res + res = .false. + if (allocated(this%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_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 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 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 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 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 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 diag_file_obj%file_write is on the stack, so this will always be true +!! @return true +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 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 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 (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 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 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 diag_file_obj%file_duration is allocated on th stack, so this is always true +!! @return true +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 diag_file_obj%file_duration_units is on the stack, so this will retrun true +!! @return true +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 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 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 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 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 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 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 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 diag_file_obj%var_write is on the stack, so this returns true +!! @return true +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 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. + endif + else + has_var_outname = .true. + endif +end function has_var_outname +!> @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 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 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 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 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 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 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 diag_file_obj%diag_basedate is on the stack, so this is always true +!! @return true +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 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 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 +!! @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 + +!> @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, 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), & + & 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 +!! @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 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) & + result(file_id) + + integer, intent(in) :: indices(:) !< Indices of the field in the sorted variable_list + integer, allocatable :: file_id(:) + + integer :: field_id !< Indices of the field in the diag_yaml field array + integer :: i !< For do loops + character(len=120) :: filename !< Filename of the field + integer, allocatable :: file_indices(:) !< Indices of the file in the sorted variable_list + + 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_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 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)) + 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), pointer :: 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()))) + 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() + 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(fields) + nullify(files) + if( present(filename)) then + close(unit_num) + endif + 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 +!> @} +! close documentation grouping 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 new file mode 100644 index 0000000000..2c93d9ebe7 --- /dev/null +++ b/diag_manager/include/fms_diag_reduction_methods.inc @@ -0,0 +1,405 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +! for any debug prints +#ifndef DEBUG_REDUCT +#define DEBUG_REDUCT .false. +#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 + 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 + + 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() + + 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, :) + endif + +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_ + +!> 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, mask_variant, bounds_in, bounds_out, & + 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 + 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 + !! of the output buffer + real(FMS_TRM_KIND_), intent(in) :: missing_value !< Missing_value for data points that are masked + 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 + + 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_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 + + if(present(weight)) then + weight_scale = weight + else + weight_scale = 1.0_kindl + endif + + if(present(pow)) then + pow_loc = pow + else + pow_loc = 1.0_kindl + endif + + if(diurnal_section .lt. 0) then + diurnal = 1 + else + diurnal = diurnal_section + endif + + 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 + 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_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, :) + weight_scale + endwhere + enddo + enddo + enddo + else + 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 + 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 + 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 + 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_scale) ** pow_loc + enddo + enddo + 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, 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 + 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, 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 + 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 + 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(1,1,1,1) + 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/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..04a4f4f0ba --- /dev/null +++ b/diag_manager/include/fms_diag_reduction_methods_r4.fh @@ -0,0 +1,47 @@ +!*********************************************************************** +!* 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 + +#undef DO_TIME_MIN_ +#define DO_TIME_MIN_ do_time_min_r4 + +#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 + +#undef SUM_UPDATE_DONE_ +#define SUM_UPDATE_DONE_ sum_update_done_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..bff7f44ac2 --- /dev/null +++ b/diag_manager/include/fms_diag_reduction_methods_r8.fh @@ -0,0 +1,47 @@ +!*********************************************************************** +!* 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 + +#undef DO_TIME_MIN_ +#define DO_TIME_MIN_ do_time_min_r8 + +#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 + +#undef SUM_UPDATE_DONE_ +#define SUM_UPDATE_DONE_ sum_update_done_r8 + +#include "fms_diag_reduction_methods.inc" + +!> @} +! close documentation grouping \ No newline at end of file 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" + } + } + } + } + } + } + } + } +} 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) 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 ! 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..e12a5d63ae 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,MPP_COMM_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,23 @@ 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 + +!> 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) 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 diff --git a/test_fms/data_override/Makefile.am b/test_fms/data_override/Makefile.am index d71512a364..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 @@ -72,10 +72,12 @@ TESTS_ENVIRONMENT= test_input_path="@TEST_INPUT_PATH@" \ # Run the test program. -TESTS = test_data_override2.sh test_data_override_init.sh test_data_override2_mono.sh test_data_override2_ongrid.sh +TESTS = test_data_override2.sh test_data_override_init.sh test_data_override2_mono.sh test_data_override2_ongrid.sh \ + test_data_override2_scalar.sh # Include these files with the distribution. -EXTRA_DIST = test_data_override2.sh test_data_override_init.sh test_data_override2_mono.sh test_data_override2_ongrid.sh +EXTRA_DIST = test_data_override2.sh test_data_override_init.sh test_data_override2_mono.sh test_data_override2_ongrid.sh \ + test_data_override2_scalar.sh # Clean up CLEANFILES = input.nml *.nc* *.out diag_table data_table data_table.yaml INPUT/* *.dpi *.spi *.dyn *.spl *-files/* diff --git a/test_fms/data_override/test_data_override2_scalar.sh b/test_fms/data_override/test_data_override2_scalar.sh new file mode 100755 index 0000000000..faf9aca08f --- /dev/null +++ b/test_fms/data_override/test_data_override2_scalar.sh @@ -0,0 +1,71 @@ +#!/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-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 diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index f5e646cd27..de3d0eec29 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -28,21 +28,62 @@ 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_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 test_var_masks \ + 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 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_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 +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 +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) \ $(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 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_multiple_send_data.sh + +testing_utils.mod: testing_utils.$(OBJEXT) # Copy over other needed files to the srcdir -EXTRA_DIST = test_diag_manager2.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 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_multiple_send_data.sh + +if USING_YAML +skipflag="" +else +skipflag="skip" +endif + +TESTS_ENVIRONMENT = skipflag=${skipflag} + +CLEANFILES = *.yaml input.nml *.nc *.out diag_table* *-files/* *.dpi *.spi *.dyn *.spl *.mod -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..0a9a7cfeca --- /dev/null +++ b/test_fms/diag_manager/check_crashes.sh @@ -0,0 +1,96 @@ +#!/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. + +printf "&check_crashes_nml \n checking_crashes = .true. \n/" | cat > input.nml +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: 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: 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: 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: 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: 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 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 +' + +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 +' + +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 +' diff --git a/test_fms/diag_manager/check_subregional.F90 b/test_fms/diag_manager/check_subregional.F90 new file mode 100644 index 0000000000..b683f8bf13 --- /dev/null +++ b/test_fms/diag_manager/check_subregional.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 . +!*********************************************************************** + +!> @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, file_exists + 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 check_corner_files() + + 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 + + !> @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/check_time_avg.F90 b/test_fms/diag_manager/check_time_avg.F90 new file mode 100644 index 0000000000..e729619f77 --- /dev/null +++ b/test_fms/diag_manager/check_time_avg.F90 @@ -0,0 +1,276 @@ +!*********************************************************************** +!* 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 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) + 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/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/check_time_max.F90 b/test_fms/diag_manager/check_time_max.F90 new file mode 100644 index 0000000000..fd835ce4a3 --- /dev/null +++ b/test_fms/diag_manager/check_time_max.F90 @@ -0,0 +1,217 @@ +!*********************************************************************** +!* 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 + + 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 :: 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), 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_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 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) + 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..da2440a638 --- /dev/null +++ b/test_fms/diag_manager/check_time_min.F90 @@ -0,0 +1,217 @@ +!*********************************************************************** +!* 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 + + 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 :: 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), 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_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 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) + 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..3925aeaad8 --- /dev/null +++ b/test_fms/diag_manager/check_time_none.F90 @@ -0,0 +1,235 @@ +!*********************************************************************** +!* 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, 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 + + 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 + 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 + 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 test_none.nc") + + if (.not. open_file(fileobj1, "test_none_regional.nc.0004", "read")) & + 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 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 + 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), 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_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 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) + 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, buffer + 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/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/check_time_sum.F90 b/test_fms/diag_manager/check_time_sum.F90 new file mode 100644 index 0000000000..463e1cea5f --- /dev/null +++ b/test_fms/diag_manager/check_time_sum.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_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 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) + 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/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_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_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90 new file mode 100644 index 0000000000..33bcbffcd1 --- /dev/null +++ b/test_fms/diag_manager/test_diag_buffer.F90 @@ -0,0 +1,135 @@ +!*********************************************************************** +!* 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, 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, time_none, EMPTY + + implicit none + + 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 + + call fms_init + + !< Test the r8_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, .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) + 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, 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") + end select + deallocate(p_val) + call buffobj(i+1)%flush_buffer() + end do + + !< Test the r4_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, .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) + 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, 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 + 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, 4 + buff_sizes(i+1) = i+5 + 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) + 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, 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 + 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, 4 + buff_sizes(i+1) = i+5 + 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) + 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, 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 + 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 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..5890cff294 --- /dev/null +++ b/test_fms/diag_manager/test_diag_diurnal.F90 @@ -0,0 +1,358 @@ +!*********************************************************************** +!* 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 + 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 :: 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 + 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 + 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) + 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 + 1 + Time = set_date(2,m,1) + ndays = days_in_month(Time) + 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, nhours ! 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 a625db4d1e..3e92781ad8 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -45,7 +45,7 @@ setup_test () { &diag_manager_nml max_field_attributes=3 debug_diag_manager=.true. - use_mpp_io = .false. + do_diag_field_log=.true. / &ensemble_nml @@ -73,7 +73,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 @@ -89,7 +89,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 @@ -105,7 +105,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 @@ -123,7 +123,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 @@ -141,7 +141,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 @@ -159,7 +159,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 @@ -175,7 +175,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 @@ -193,7 +193,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 @@ -209,7 +209,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 @@ -225,7 +225,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 @@ -241,7 +241,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 @@ -260,7 +260,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 @@ -280,7 +280,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 @@ -297,7 +297,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 @@ -314,7 +314,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 @@ -331,7 +331,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 @@ -348,7 +348,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 @@ -368,7 +368,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 @@ -387,7 +387,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 @@ -406,7 +406,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 @@ -423,7 +423,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 @@ -440,7 +440,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 @@ -459,8 +459,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 @@ -479,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 @@ -496,15 +494,785 @@ 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` 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 ' - test_done + +## 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: +- file_name: wild_card_name%4yr%2mo%2dy%2hr + filename_time: end + 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 + output_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 + output_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 + time_units: hours + unlimdim: records + write_file: true + varlist: + - module: test_diag_manager_mod + var_name: sstt + output_name: sstt + reduction: average + kind: r4 + long_name: S S T + - module: test_diag_manager_mod + var_name: sstt2 + output_name: sstt2 + reduction: average + kind: r4 + long_name: S S T + 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 + time_units: hours + unlimdim: records + write_file: false +_EOF + cp diag_table.yaml diag_table.yaml_base + + 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 +title: test_diag_manager +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: file1 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: test_diag_manager_mod + var_name: sst1 + output_name: sst1 + reduction: average + kind: r4 +- file_name: file2 + freq: 6 hours + time_units: hours + unlimdim: time + is_ocean: True + varlist: + - module: test_diag_manager_mod + var_name: sst2 + output_name: sst2 + reduction: average + kind: r4 +- file_name: file3 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: test_diag_manager_mod + var_name: sst3 + output_name: sst3 + reduction: average + kind: r4 + - module: test_diag_manager_mod + var_name: sst4 + output_name: sst4 + reduction: average + kind: r4 +_EOF + + 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 + ' + + + 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 + +diag_files: +- file_name: static_file + freq: -1 + time_units: hours + unlimdim: time + varlist: + - module: atm_mod + var_name: var7 + reduction: none + kind: r4 + global_meta: + - is_important: False + has_important: True +- file_name: file1 + freq: 6 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 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 + - module: atm_mod + var_name: var4 + output_name: var4_bounded + reduction: average + kind: r8 + zbounds: 2.0 3.0 +- file_name: file3 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: lnd_mod + var_name: var5 + reduction: average + kind: r4 + - module: atm_mod + var_name: var7 + reduction: average + kind: r4 +- file_name: file4 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: lnd_mod + var_name: var1 + reduction: average + kind: r4 +- file_name: file5 + freq: 6 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: file6%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: ocn_mod + var_name: var1 + reduction: average + kind: r4 +- file_name: file7 + freq: 6 hours + time_units: hours + unlimdim: time + varlist: + - module: ocn_mod + var_name: var1 + reduction: none + kind: r4 + attributes: + - GFDL_name: var_var +- file_name: file8%4yr%2mo%2dy%2hr%2min + 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 + varlist: + - module: ocn_mod + var_name: var1 + reduction: average + kind: r4 +- file_name: file9%4yr%2mo%2dy%2hr%2min + filename_time: begin + 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 + varlist: + - module: ocn_mod + var_name: var1 + reduction: average + kind: r4 +- file_name: file10_diurnal + freq: 1 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` + 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 + ' + +## 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 +base_date: 2 1 1 0 0 0 + +diag_files: +- file_name: file1_clock + freq: 1 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 days + time_units: hours + unlimdim: time + varlist: + - module: atm_mod + 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` + 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)" ' + mpirun -n 6 ../test_modern_diag + ' +fi +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..1723c3248b --- /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), 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 +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%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 + +nullify(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_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 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..57b8610e3a --- /dev/null +++ b/test_fms/diag_manager/test_diag_yaml.F90 @@ -0,0 +1,391 @@ +!*********************************************************************** +!* 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 + +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, & + & time_average, r4, middle_time, end_time +use time_manager_mod, only: set_calendar_type, JULIAN +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 + +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 + +#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), pointer :: my_yaml !< diagYamlObject obtained from diag_yaml_object_init +integer, ALLOCATABLE :: diag_files_ids(:) !< Ids of the diag_files +#endif + +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') + +#ifndef use_yaml +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%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) + + diag_fields = my_yaml%get_diag_fields() + 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) + + nullify(diag_files) + deallocate(diag_fields) + + 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!') + 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_ids = get_diag_files_id(indices) + + diag_files => my_yaml%diag_files(1:2) + call compare_result("sst - nfiles", size(diag_files), 2) + 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") + 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", "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", "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!") + +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() + +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(), 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_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") + 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("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) + + 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(), 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") + call compare_result("file_unlimdim 3", res(3)%get_file_unlimdim(), "records") + + 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) + + 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(), 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(), "") + 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 + +!> @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 + +#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)//".") + 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) + 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 + 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) + 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 + class default + call mpp_error(FATAL, "Error!: "//trim(key_name)//" does not have the same type") + 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 + 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) + 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 + 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) + 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 + 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 +#endif 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..2dd881177d --- /dev/null +++ b/test_fms/diag_manager/test_flexible_time.F90 @@ -0,0 +1,69 @@ +!*********************************************************************** +!* 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, 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, & + 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) :: Time_step !< 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 +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/), 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 + +call diag_manager_end(End_Time) + +call fms_end() + +end program test_flexible_time 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..f32b5c5dad --- /dev/null +++ b/test_fms/diag_manager/test_modern_diag.F90 @@ -0,0 +1,321 @@ +!*********************************************************************** +!* 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 +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, & + diag_axis_add_attribute, diag_field_add_attribute, diag_send_complete, & + 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 +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 + +!> @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 +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 +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_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 !< 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 +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, 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) + +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_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/)) +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 (.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') +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 ('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') +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_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 +call dump_diag_obj('diag_obj_dump.log') +call dump_diag_obj() + +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) +Time_step = set_time (3600,0) !< 1 hour +do i=1,23 + 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) + 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_step) +enddo +call deallocate_dummy_data(var_data) + +call diag_manager_end(Time) +call fms_end + +contains + +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(nland)) !< 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 + 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 + +!> @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 + 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 +end program test_modern_diag 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 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..0b09fc69ca --- /dev/null +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -0,0 +1,396 @@ +!*********************************************************************** +!* 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, NORTH, EAST + + 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 :: 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 + 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_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_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 + 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 + 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 + 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, use_pow_data + + 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', 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) + 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, :) = .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 + + !< 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') + + 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_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', & + '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 + 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) + 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) + + 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, 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) + 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)) + 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, 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)) + 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) + 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) + 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 + 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 + + if(use_pow_data) return + 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_subregional.sh b/test_fms/diag_manager/test_subregional.sh new file mode 100755 index 0000000000..dcb1f5e9da --- /dev/null +++ b/test_fms/diag_manager/test_subregional.sh @@ -0,0 +1,172 @@ +#!/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 +' + +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 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..d40abf637b --- /dev/null +++ b/test_fms/diag_manager/test_time_avg.sh @@ -0,0 +1,215 @@ +#!/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 + - module: ocn_mod + var_name: IOnASphere + reduction: average + 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 + +# 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)" ' + 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 +' + +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 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 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..d2a0fd7cdc --- /dev/null +++ b/test_fms/diag_manager/test_time_max.sh @@ -0,0 +1,174 @@ +#!/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.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: var4 + output_name: var4_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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 + +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 "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 "&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 +' +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 "&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 +' +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..f2969d47c9 --- /dev/null +++ b/test_fms/diag_manager/test_time_min.sh @@ -0,0 +1,174 @@ +#!/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.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: var4 + output_name: var4_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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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..421cbfe093 --- /dev/null +++ b/test_fms/diag_manager/test_time_none.sh @@ -0,0 +1,228 @@ +#!/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 + +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: var4 + output_name: var4_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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 "&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 +' +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 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 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..c7631217a4 --- /dev/null +++ b/test_fms/diag_manager/test_time_sum.sh @@ -0,0 +1,171 @@ +#!/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: var4 + output_name: var4_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 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 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 diff --git a/test_fms/field_manager/Makefile.am b/test_fms/field_manager/Makefile.am index 3353580ff0..01f10ed0dd 100644 --- a/test_fms/field_manager/Makefile.am +++ b/test_fms/field_manager/Makefile.am @@ -39,7 +39,7 @@ 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 +if USING_YAML skipflag="skip" else skipflag="" 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/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 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} 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 diff --git a/test_fms/tracer_manager/Makefile.am b/test_fms/tracer_manager/Makefile.am index f2a020b6fa..747151344e 100644 --- a/test_fms/tracer_manager/Makefile.am +++ b/test_fms/tracer_manager/Makefile.am @@ -38,7 +38,7 @@ 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 +if USING_YAML skipflag="skip" else skipflag="" 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